Commit 1fdc3162 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-26 17:37:58 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-26 17:38:18+00:00
parent 322f1452
......@@ -61,15 +61,8 @@ EXTEND
| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
| "transform"; e = SELF; "with"; b = branches ->
mk noloc (Op ("flatten", [mk loc (Map (e,b))]))
| "fun"; f = OPT LIDENT; "("; a = LIST1 arrow SEP ";"; ")";
b = branches ->
| "fun"; (f,a,b) = fun_decl ->
mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| "fun"; f = OPT LIDENT;
"("; arg = LIDENT; ":"; targ = pat; ")"; ":"; tres = pat ;
"="; body = expr ->
let fun_body = (mk noloc (Capture arg), body) in
mk loc (Abstraction { fun_name = f; fun_iface = [(targ,tres)];
fun_body = [fun_body] })
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
mk loc (Match (e1,[p,e2]))
]
......@@ -113,15 +106,28 @@ EXTEND
let_binding: [
[ "let"; p = pat; "="; e = expr -> (p,e)
| "let"; "fun"; f = LIDENT; "("; a = LIST0 arrow SEP ";"; ")";
b = branches ->
let p = mk loc (Capture f) in
let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
| "let"; "fun"; (f,a,b) = fun_decl ->
let p = match f with
| Some x -> mk loc (Capture x)
| _ -> failwith "Function name mandatory in let fun declarations"
in
let abst = { fun_name = f; fun_iface = a; fun_body = b } in
let e = mk loc (Abstraction abst) in
(p,e)
(p,e);
]
];
fun_decl: [
[ f = OPT LIDENT; "("; a = LIST0 arrow SEP ";"; ")"; b = branches ->
(f,a,b)
| f = OPT LIDENT; "("; arg = LIDENT; ":"; targ = pat; ")"; ":"; tres = pat ;
"="; body = expr ->
let b = [mk noloc (Capture arg), body] in
let a = [targ,tres] in
(f,a,b)
]
];
arrow: [
[ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
];
......
module Env = Map.Make (struct type t = string let compare = compare end)
let empty_env = Env.empty
type t =
| Pair of t * t
| Record of (Types.label,t) SortedMap.t
| Atom of Types.atom
| Integer of Big_int.big_int
| Char of Chars.Unichar.t
| Fun of abstr
and env = t Env.t
and abstr = {
fun_iface : (Types.descr * Types.descr) list;
mutable fun_env : env;
fun_body : Typed.branches;
}
let rec print ppf = function
| Pair (x,y) ->
Format.fprintf ppf "(%a,%a)" print x print y
| Record l ->
Format.fprintf ppf "{%a}" print_record l
| Atom a ->
Format.fprintf ppf "`%s" (Types.atom_name a)
| Integer i ->
Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c ->
Chars.Unichar.print ppf c
| Fun c ->
Format.fprintf ppf "<fun>"
and print_record ppf = function
| [] -> ()
| [f] -> print_field ppf f
| f :: rem -> Format.fprintf ppf "%a; %a" print_field f print_record rem
and print_field ppf (l,v) =
Format.fprintf ppf "%s = %a" (Types.label_name l) print v
(* Running dispatchers *)
let const = function
| Types.Integer i -> Integer i
| Types.Atom a -> Atom a
| Types.Char c -> Char c
let make_result_prod r1 r2 v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Left i -> r1.(i)
| `Right j -> r2.(j)
| `Recompose (i,j) -> Pair (r1.(i), r2.(j))
| _ -> assert false
) r in
(code,ret)
let make_result_record v fields (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| `Field (l,i) -> (List.assoc l fields).(i)
| _ -> assert false
) r in
(code,ret)
let make_result_basic v (code,r) =
let ret = Array.map
(function
| `Catch -> v
| `Const c -> const c
| _ -> assert false
) r in
(code,ret)
let dummy_r = [||]
let rec run_dispatcher d v =
let actions = Patterns.Compile.actions d in
match v with
| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
| Record r -> run_disp_record v [] r actions.Patterns.Compile.record
| Atom a ->
run_disp_basic v (fun t -> Types.Atom.has_atom t a)
actions.Patterns.Compile.basic
| Char c ->
run_disp_basic v (fun t -> Types.Char.has_char t c)
actions.Patterns.Compile.basic
| Integer i ->
run_disp_basic v (fun t -> Types.Int.has_int t i)
actions.Patterns.Compile.basic
| Fun f ->
run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t)
actions.Patterns.Compile.basic
and run_disp_basic v f = function
| [(_,r)] -> make_result_basic v r
| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
| _ -> assert false
and run_disp_prod v v1 v2 = function
| `None -> assert false
| `TailCall d1 -> run_dispatcher d1 v1
| `Ignore d2 -> run_disp_prod2 dummy_r v v2 d2
| `Dispatch (d1,b1) ->
let (code1,r1) = run_dispatcher d1 v1 in
run_disp_prod2 r1 v v2 b1.(code1)
and run_disp_prod2 r1 v v2 = function
| `None -> assert false
| `Ignore r -> make_result_prod r1 dummy_r v r
| `TailCall d2 -> run_dispatcher d2 v2
| `Dispatch (d2,b2) ->
let (code2,r2) = run_dispatcher d2 v2 in
make_result_prod r1 r2 v b2.(code2)
and run_disp_record v bindings fields = function
| None -> assert false
| Some record -> run_disp_record' v bindings fields record
and run_disp_record' v bindings fields = function
| `Result r -> make_result_record v bindings r
| `Label (l, present, absent) ->
let rec aux = function
| (l1,_) :: rem when l1 < l -> aux rem
| (l1,vl) :: rem when l1 = l ->
run_disp_field v bindings rem l vl present
| _ -> run_disp_record v bindings fields absent
in
aux fields
and run_disp_field v bindings fields l vl = function
| `None -> assert false
| `Ignore r -> run_disp_record' v bindings fields r
| `TailCall d -> run_dispatcher d vl
| `Dispatch (dl,bl) ->
let (codel,rl) = run_dispatcher dl vl in
run_disp_record' v ((l,rl)::bindings) fields bl.(codel)
(* Evaluation of expressions *)
let rec eval env e =
match e.Typed.exp_descr with
| Typed.Var s -> Env.find s env
| Typed.Apply (f,arg) ->
let f = eval env f and arg = eval env arg in
(match f with
| Fun a -> eval_branches a.fun_env a.fun_body arg
| _ -> failwith "application with a non-functional value !"
)
| Typed.Abstraction a ->
let a' = {
fun_env = env;
fun_iface = a.Typed.fun_iface;
fun_body = a.Typed.fun_body
} in
let self = Fun a' in
(match a.Typed.fun_name with
| Some f -> a'.fun_env <- Env.add f self a'.fun_env
| None -> ());
self
| Typed.RecordLitt r ->
Record (List.map (fun (l,e) -> (l, eval env e)) r)
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Cst c -> const c
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| _ -> assert false
and eval_branches env brs arg =
let (disp, rhs) = Typed.dispatcher brs in
let (code, bindings) = run_dispatcher disp arg in
let (bind, e) = rhs.(code) in
let env =
List.fold_left (fun env (x,i) -> Env.add x bindings.(i) env) env bind in
eval env e
debug filter [ (1 2 3?)* ] [ (x::(1 2) 3?)* ];;
debug compile [(`A `B `C?)*] [ (((x::`A) `B (x::`C))|_)* ];;
debug compile [(`A)*] [ (x::`A)* ];;
debug compile Any {x=`A;y=`B};;
debug compile Any [((x::1)|(y::2))*];;
debug compile Any ((x,_),_) ((_,x),_);;
debug compile [ (1 3?)* ] [(x::1 3?)*];;
debug compile [ (1 3?)* ] [(1 (x::3)?)*];;
type Str = [String];;
type Bool = `True | `False;;
let fun check (Str -> Bool)
| [ _* 'Castagna' _* ] -> `True
| _ -> `False
in
(check "Giuseppe Castagna",
check "Alain Frisch"
);;
......@@ -853,7 +853,7 @@ struct
*)
Format.fprintf ppf "@\n";
in
Array.iteri print_code d.codes;
(* Array.iteri print_code d.codes; *)
Format.fprintf ppf "let disp_%i = function@\n" d.id;
print_actions ppf (actions d);
Format.fprintf ppf "====================================@\n";
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment