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

Original author: cvscast
Date: 2002-10-26 17:38:18+00:00

parser/parser.ml

@@ -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)]
   ];

runtime/value.ml

+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
+
+

tests/patterns.cd

+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)?)*];;

tests/str.cd

+type Str = [String];;
+type Bool = `True | `False;;
+
+let fun check (Str -> Bool)
+  | [ _* 'Castagna' _* ] -> `True
+  | _ -> `False
+in
+(check "Giuseppe Castagna",
+ check "Alain Frisch"
+);;

types/patterns.ml

@@ -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";