[r2002-11-01 12:53:44 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-01 12:53:45+00:00

Makefile

@@ -8,16 +8,18 @@ PARSER = parser/lexer.cmo parser/location.cmo parser/ast.cmo parser/parser.cmo
 
 TYPING = typing/typed.cmo typing/typer.cmo
 
-TYPES  = types/recursive.cmo types/recursive_share.cmo types/recursive_noshare.cmo \
-         types/sortedList.cmo \
-         types/sortedMap.cmo types/boolean.cmo \
+TYPES  = types/recursive.cmo \
+         types/recursive_share.cmo types/recursive_noshare.cmo \
+         types/sortedList.cmo types/sortedMap.cmo types/boolean.cmo \
          types/intervals.cmo types/chars.cmo types/atoms.cmo \
          types/types.cmo \
          types/patterns.cmo \
 	 types/sequence.cmo \
 	 types/builtin.cmo
 
-RUNTIME = runtime/value.cmo
+RUNTIME = runtime/value.cmo \
+          runtime/load_xml.cmo runtime/run_dispatch.cmo \
+          runtime/eval.cmo
 
 DRIVER = driver/cduce.cmo
 

depend

@@ -44,28 +44,38 @@ types/sortedList.cmo: types/sortedList.cmi
 types/sortedList.cmx: types/sortedList.cmi 
 types/sortedMap.cmo: types/sortedMap.cmi 
 types/sortedMap.cmx: types/sortedMap.cmi 
-types/strings.cmo: types/boolean.cmi types/intervals.cmi types/recursive.cmo \
-    types/strings.cmi 
-types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
-    types/strings.cmi 
 types/type_bool.cmo: types/boolean.cmi types/recursive.cmo 
 types/type_bool.cmx: types/boolean.cmx types/recursive.cmx 
 types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
-    types/intervals.cmi types/recursive.cmo types/recursive_share.cmo \
+    types/intervals.cmi types/recursive.cmo types/recursive_noshare.cmo \
     types/sortedList.cmi types/sortedMap.cmi types/types.cmi 
 types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
-    types/intervals.cmx types/recursive.cmx types/recursive_share.cmx \
+    types/intervals.cmx types/recursive.cmx types/recursive_noshare.cmx \
     types/sortedList.cmx types/sortedMap.cmx types/types.cmi 
-runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
-    types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi 
-runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \
-    types/sortedMap.cmx typing/typed.cmx types/types.cmx runtime/value.cmi 
-driver/cduce.cmo: parser/ast.cmo types/builtin.cmo parser/location.cmi \
-    parser/parser.cmi types/patterns.cmi typing/typer.cmi types/types.cmi \
-    runtime/value.cmi 
-driver/cduce.cmx: parser/ast.cmx types/builtin.cmx parser/location.cmx \
-    parser/parser.cmx types/patterns.cmx typing/typer.cmx types/types.cmx \
-    runtime/value.cmx 
+runtime/eval.cmo: types/chars.cmi runtime/load_xml.cmi \
+    runtime/run_dispatch.cmi typing/typed.cmo types/types.cmi \
+    runtime/value.cmi runtime/eval.cmi 
+runtime/eval.cmx: types/chars.cmx runtime/load_xml.cmx \
+    runtime/run_dispatch.cmx typing/typed.cmx types/types.cmx \
+    runtime/value.cmx runtime/eval.cmi 
+runtime/load_xml.cmo: types/sortedMap.cmi types/types.cmi runtime/value.cmi \
+    runtime/load_xml.cmi 
+runtime/load_xml.cmx: types/sortedMap.cmx types/types.cmx runtime/value.cmx \
+    runtime/load_xml.cmi 
+runtime/run_dispatch.cmo: types/patterns.cmi types/types.cmi \
+    runtime/run_dispatch.cmi 
+runtime/run_dispatch.cmx: types/patterns.cmx types/types.cmx \
+    runtime/run_dispatch.cmi 
+runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
+    types/types.cmi runtime/value.cmi 
+runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
+    types/types.cmx runtime/value.cmi 
+driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
+    parser/location.cmi parser/parser.cmi types/patterns.cmi typing/typer.cmi \
+    types/types.cmi runtime/value.cmi 
+driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
+    parser/location.cmx parser/parser.cmx types/patterns.cmx typing/typer.cmx \
+    types/types.cmx runtime/value.cmx 
 parser/parser.cmi: parser/ast.cmo 
 typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi 
 types/boolean.cmi: types/sortedList.cmi 
@@ -75,4 +85,7 @@ types/sortedMap.cmi: types/sortedList.cmi
 types/syntax.cmi: types/patterns.cmi types/types.cmi 
 types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
     types/sortedMap.cmi 
-runtime/value.cmi: types/patterns.cmi typing/typed.cmo 
+runtime/eval.cmi: typing/typed.cmo runtime/value.cmi 
+runtime/load_xml.cmi: runtime/value.cmi 
+runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi 
+runtime/value.cmi: types/chars.cmi types/sortedMap.cmi types/types.cmi 

driver/cduce.ml

@@ -88,7 +88,7 @@ let debug = function
   | _ -> Format.fprintf ppf "Unknown or ill-formed debugging directive !! @\n"
 
 let typing_env = ref Typer.Env.empty
-let eval_env = ref Value.Env.empty
+let eval_env = ref Eval.Env.empty
 
 let insert_type_bindings = 
   List.iter (fun (x,t) ->
@@ -99,10 +99,10 @@ let type_decl decl =
   insert_type_bindings (Typer.type_let_decl !typing_env decl)
 
 let eval_decl decl =
-  let bindings = Value.eval_let_decl !eval_env decl in
+  let bindings = Eval.eval_let_decl !eval_env decl in
   List.iter 
     (fun (x,v) ->
-       eval_env := Value.Env.add x v !eval_env;
+       Eval.enter_global x v;
        Format.fprintf ppf "=> %s : @[%a@]@\n" x Value.print v
     ) bindings
 
@@ -112,7 +112,7 @@ let phrase ph =
 	let (fv,e) = Typer.expr e in
 	let t = Typer.type_check !typing_env e Types.any true in
 	Format.fprintf ppf "|- %a@\n" print_norm t;
-	let v = Value.eval !eval_env e in
+	let v = Eval.eval !eval_env e in
 	Format.fprintf ppf "=> @[%a@]@\n" Value.print v
     | Ast.LetDecl (p,{descr=Ast.Abstraction _}) -> ()
     | Ast.LetDecl (p,e) ->

runtime/eval.ml

+open Value
+open Run_dispatch
+
+module Env = Map.Make (struct type t = string let compare = compare end)
+type env = t Env.t
+
+let global_env = ref Env.empty
+let enter_global x v = global_env := Env.add x v !global_env
+
+
+let exn_int_of = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),
+				 string "int_of"))
+
+
+
+
+(* Evaluation of expressions *)
+
+
+let rec eval env e0 = 
+  match e0.Typed.exp_descr with
+    | Typed.Forget (e,_) -> eval env e
+    | Typed.Var s -> 
+	(try Env.find s env
+	with Not_found -> Env.find s !global_env)
+    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
+    | Typed.Abstraction a ->
+	let env = 
+	  List.fold_left 
+	    (fun accu x -> 
+	       try Env.add x (Env.find x env) accu
+	       with Not_found -> accu (* global *))
+	    Env.empty a.Typed.fun_fv in
+	let env_ref = ref env in
+	let rec self = Abstraction (a.Typed.fun_iface, 
+				    eval_branches' env_ref a.Typed.fun_body) in
+	(match a.Typed.fun_name with
+	  | None -> ()
+	  | Some f -> env_ref := Env.add f self env;
+	);
+	self
+(* Optimizations:
+       - for the non-recursive case, use eval_branches
+       - for the recursive case, could cheat bt pathing self afterwards:
+                (Obj.magic self).(1) <- ....
+*)
+    | 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)
+    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
+    | Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
+    | Typed.Try (arg,brs) -> 
+	(try eval env arg with CDuceExn v -> eval_branches env brs v)
+    | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
+    | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
+    | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
+    | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
+    | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
+    | Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
+    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
+    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
+    | Typed.Dot (e, l) -> eval_dot l (eval env e)
+    | Typed.DebugTyper t -> failwith "Evaluating a ! expression"
+    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
+
+
+and eval_apply f arg = match f with
+  | Abstraction (_,clos) -> clos arg
+  | _ -> assert false
+
+and eval_branches' env_ref brs arg =
+  eval_branches !env_ref brs arg
+
+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) -> 
+		      if (i = -1) then Env.add x arg env 
+		      else Env.add x bindings.(i) env) env bind in
+  eval env e
+
+and eval_let_decl env l =
+  let v = eval env l.Typed.let_body in
+  let (disp,bind) = Typed.dispatcher_let_decl l in
+  let (_,bindings) = run_dispatcher disp v in
+  List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) bind
+
+and eval_map env brs = function
+  | Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
+  | String (_,_,_,_) as v -> eval_map env brs (normalize v)
+  | q -> q
+  
+and eval_flatten = function
+  | Pair (x,y) -> eval_concat x (eval_flatten y)
+  | q -> q
+
+and eval_concat l1 l2 = match l1 with
+  | Pair (x,y) -> Pair (x, eval_concat y l2)
+  | String (s,i,j,q) -> String (s,i,j, eval_concat q l2)
+  | q -> l2
+
+and eval_dot l = function
+  | Record r -> List.assoc l r
+  | _ -> assert false
+
+and eval_add x y = match (x,y) with
+  | (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
+  | _ -> assert false
+
+and eval_mul x y = match (x,y) with
+  | (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
+  | _ -> assert false
+
+and eval_sub x y = match (x,y) with
+  | (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
+  | _ -> assert false
+
+and eval_div x y = match (x,y) with
+  | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
+  | _ -> assert false
+
+and eval_load_xml e =
+  Load_xml.run (get_string e)
+
+and eval_int_of e =
+  let s = get_string e in
+  try Integer (Big_int.big_int_of_string s)
+  with Failure _ -> raise exn_int_of
+  
+and get_string e =
+  let rec compute_len accu = function
+    | Pair (_,y) -> compute_len (accu + 1) y
+    | String (i,j,_,y) -> compute_len (accu + j - i) y
+    | _ -> accu in
+  let rec fill pos s = function
+    | Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
+    | String (i,j,src,y) -> 
+	String.blit src i s pos (j - i); fill (pos + j - i) s y
+    | _ -> s in
+  fill 0 (String.create (compute_len 0 e)) e

runtime/eval.mli

+open Value
+
+module Env : Map.S with type key = string
+type env = t Env.t
+
+
+val enter_global : string -> t -> unit
+
+val eval: env -> Typed.texpr -> t
+val eval_let_decl: env -> Typed.let_decl -> (string * t) list
+
+

runtime/load_xml.ml

+(* Loading XML documents *)
+
+(*TODO: close the file ! *)
+
+open Pxp_yacc
+open Pxp_lexer_types
+open Pxp_types
+open Value
+
+let string s q =
+  let rec check_ws i = (i < 0) || 
+		       (match s.[i] with
+			  | ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1) 
+			  | _ -> false) in
+  if check_ws (String.length s - 1) then q 
+  else String (0,String.length s,s,q)
+
+let run s =
+  let config = { default_config with 
+		   store_element_positions = false;
+		   drop_ignorable_whitespace = true
+	       }
+  in
+  let mgr = create_entity_manager config (from_file s) in
+  let next_event = 
+    create_pull_parser config (`Entry_document[]) mgr in
+  let curr = ref E_end_of_stream in
+  let get () =
+    match next_event () with 
+      | Some x -> curr := x 
+      | None -> () in
+
+  let rec parse_elt name att =
+    let att = List.map (fun (l,v) -> Types.label l, string v nil) att in
+    let att = SortedMap.from_list (fun _ _ -> assert false) att in
+    let child = parse_seq () in
+    
+    let elt = Pair 
+		(Atom (Types.mk_atom name),
+		 Pair (Record att, child)
+		) in
+    (match !curr with
+       | E_end_tag (_,_) -> get ()
+       | _ -> failwith "Expect end_tag");
+    elt
+      
+      
+  and parse_seq () =
+    match !curr with
+      | E_start_tag (name,att,_) -> 
+	  get ();
+	  let e1 = parse_elt name att in
+	  let rest = parse_seq () in
+	  Pair (e1, rest)
+      | E_char_data data ->
+	  get ();
+	  let rest = parse_seq () in
+	  string data rest
+      | E_end_tag (_,_) ->
+	  nil
+      | _ -> failwith "Expect start_tag, char_data, or end_tag"
+	  
+  and parse_doc () =
+    match !curr with
+      | E_start_tag (name,att,_) ->  get (); parse_elt name att
+      | _ -> get (); parse_doc ()
+  in
+  get ();
+  parse_doc ()

runtime/load_xml.mli

+val run: string -> Value.t

runtime/run_dispatch.ml

+(* Running dispatchers *)
+
+open Value
+
+
+let make_result_prod v1 r1 v2 r2 v (code,r) = 
+  let ret = Array.map
+    (function
+       | `Catch -> v
+       | `Const c -> const c
+       | `Left i -> if (i < 0) then v1 else r1.(i)
+       | `Right j -> if (j < 0) then v2 else r2.(j)
+       | `Recompose (i,j) -> 
+	   Pair ((if (i < 0) then v1 else r1.(i)),
+		 (if (j < 0) then v2 else r2.(j)))
+       | _ -> assert false
+    ) r in
+  (code,ret)
+
+let make_result_record fields v bindings (code,r) =
+  let ret = Array.map
+    (function
+       | `Catch -> v
+       | `Const c -> const c
+       | `Field (l,i) -> 
+	   if (i < 0) then List.assoc l fields
+	   else (List.assoc l bindings).(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 actions with
+    | `Ignore r -> make_result_basic v r
+    | `Kind k -> run_disp_kind k v
+
+and run_disp_kind actions v = match v with
+  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
+  | Record r -> run_disp_record r 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
+  | Abstraction (iface,_) ->
+      run_disp_basic v (fun t -> Types.Arrow.check_iface iface t) 
+        actions.Patterns.Compile.basic
+  | v ->
+      run_disp_kind actions (normalize v) 
+
+
+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 v1 dummy_r v v2 d2
+  | `Dispatch (d1,b1) ->
+      let (code1,r1) = run_dispatcher d1 v1 in
+      run_disp_prod2 v1 r1 v v2 b1.(code1)
+
+and run_disp_prod2 v1 r1 v v2 = function
+  | `None -> assert false
+  | `Ignore r -> make_result_prod v1 r1 v2 dummy_r v r
+  | `TailCall d2 -> run_dispatcher d2 v2
+  | `Dispatch (d2,b2) ->
+      let (code2,r2) = run_dispatcher d2 v2 in
+      make_result_prod v1 r1 v2 r2 v b2.(code2)
+	    
+and run_disp_record f v bindings fields = function
+  | None -> assert false
+  | Some record -> run_disp_record' f v bindings fields record
+
+and run_disp_record' f v bindings fields = function
+  | `Result r -> make_result_record f 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 f v bindings rem l vl present
+	| _ -> run_disp_record f v bindings fields absent
+      in
+      aux fields
+
+and run_disp_field f v bindings fields l vl = function
+  | `None -> assert false
+  | `Ignore r -> run_disp_record' f v bindings fields r
+  | `TailCall d -> run_dispatcher d vl
+  | `Dispatch (dl,bl) ->
+      let (codel,rl) = run_dispatcher dl vl in
+      run_disp_record' f v ((l,rl)::bindings) fields bl.(codel)

runtime/run_dispatch.mli

+open Value
+
+val run_dispatcher: Patterns.Compile.dispatcher -> t -> int * t array

runtime/value.ml

-module Env = Map.Make (struct type t = string let compare = compare end)
-
 type t =
   | Pair of t * t
   | Record of (Types.label,t) SortedMap.t
@@ -9,14 +7,16 @@ type t =
   | Abstraction of (Types.descr * Types.descr) list * (t -> t)
   | String of int * int * string * t
 
-type env = t Env.t
 
 exception CDuceExn of t
 
 let nil = Atom Sequence.nil_atom
 let string s = String (0,String.length s, s, nil)
-let exn_int_of = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),
-				 string "int_of"))
+
+let const = function
+  | Types.Integer i -> Integer i
+  | Types.Atom a -> Atom a
+  | Types.Char c -> Char c
 
 let rec is_seq = function
   | Pair (_, y) when is_seq y -> true
@@ -83,344 +83,9 @@ and print_field ppf (l,v) =
   Format.fprintf ppf "%s=%a" (Types.label_name l) print v  
 
 
-(* Loading XML documents *)
-
-(*TODO: close the file ! *)
-
-module Load_xml = 
-struct
-
-  open Pxp_yacc
-  open Pxp_lexer_types
-  open Pxp_types
-
-  let run s =
-    let config = { default_config with 
-		     store_element_positions = false;
-		     drop_ignorable_whitespace = true
-		 }
-    in
-    let mgr = create_entity_manager config (from_file s) in
-    let next_event = 
-      create_pull_parser config (`Entry_document[]) mgr in
-    let curr = ref E_end_of_stream in
-    let get () =
-      match next_event () with 
-	| Some x -> curr := x 
-	| None -> () in
-    
-    let string s q =
-      let rec check_ws i = (i < 0) || 
-			   (match s.[i] with
-			      | ' ' | '\t' | '\n' | '\r' -> check_ws (i - 1) 
-			      | _ -> false) in
-      if check_ws (String.length s - 1) then q 
-      else
-	String (0,String.length s,s,q)
-(*
-	let rec aux i accu =
-	  if i < 0 then accu
-	  else aux (i - 1) (Pair 
-			      (Char (Chars.Unichar.from_char s.[i]), 
-			       accu))
-	in
-	aux (String.length s - 1) q
-*)
-
-    in
-    
-    let nil = Atom Sequence.nil_atom in
-    
-    
-    let rec parse_elt name att =
-      let att = List.map (fun (l,v) -> Types.label l, string v nil) att in
-      let att = SortedMap.from_list (fun _ _ -> assert false) att in
-      let child = parse_seq () in
-      
-      let elt = Pair 
-		  (Atom (Types.mk_atom name),
-		   Pair (Record att, child)
-		  ) in
-      (match !curr with
-	 | E_end_tag (_,_) -> get ()
-	 | _ -> failwith "Expect end_tag");
-      elt
-	
-	
-    and parse_seq () =
-      match !curr with
-	| E_start_tag (name,att,_) -> 
-	    get ();
-	    let e1 = parse_elt name att in
-	    let rest = parse_seq () in
-	    Pair (e1, rest)
-	| E_char_data data ->
-	    get ();
-	    let rest = parse_seq () in
-	    string data rest
-	| E_end_tag (_,_) ->
-	    nil
-	| _ -> failwith "Expect start_tag, char_data, or end_tag"
-	    
-    and parse_doc () =
-      match !curr with
-	| E_start_tag (name,att,_) ->  get (); parse_elt name att
-	| _ -> get (); parse_doc ()
-    in
-    get ();
-    parse_doc ()
-
-end
-
-
-(* Running dispatchers *)
-
-let const = function
-  | Types.Integer i -> Integer i
-  | Types.Atom a -> Atom a
-  | Types.Char c -> Char c
-
-(*
-module Array = struct
-  include Array
-  let get a i = assert (i < length a); assert (i >= 0); get a i
-end
-*)
-
-let make_result_prod v1 r1 v2 r2 v (code,r) = 
-  let ret = Array.map
-    (function
-       | `Catch -> v
-       | `Const c -> const c
-       | `Left i -> if (i < 0) then v1 else r1.(i)
-       | `Right j -> if (j < 0) then v2 else r2.(j)
-       | `Recompose (i,j) -> 
-	   Pair ((if (i < 0) then v1 else r1.(i)),
-		 (if (j < 0) then v2 else r2.(j)))
-       | _ ->