[r2002-10-26 17:05:30 by cvscast] Evaluateur tourne !

Original author: cvscast
Date: 2002-10-26 17:05:31+00:00

Makefile

@@ -17,14 +17,14 @@ RUNTIME = runtime/value.cmo
 
 DRIVER = driver/cduce.cmo
 
-DIRS = parser typing types driver
+DIRS = parser typing types runtime driver
 
 OBJECTS = $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
 XOBJECTS = $(OBJECTS:.cmo=.cmx)
 XDRIVER = $(DRIVER:.cmo=.cmx)
 
 DEPEND = parser/*.ml parser/*.mli typing/*.ml typing/*.mli types/*.ml types/*.mli runtime/*.mli runtime/*.ml driver/*.mli driver/*.ml
-INCLUDES = -I +camlp4 -I parser -I types -I typing
+INCLUDES = -I +camlp4 -I parser -I types -I runtime -I typing
 
 SYNTAX_PARSER = -pp 'camlp4o pa_extend.cmo'
 

driver/cduce.ml

@@ -98,7 +98,9 @@ let phrase ph =
     | Ast.EvalStatement e ->
 	let (fv,e) = Typer.expr e in
 	let t = Typer.type_check Typer.Env.empty e Types.any true in
-	Format.fprintf ppf "%a@\n" print_norm t
+	Format.fprintf ppf "|- %a@\n" print_norm t;
+	let v = Value.eval Value.empty_env e in
+	Format.fprintf ppf "=> %a@\n" Value.print v
     | Ast.TypeDecl _ -> ()
     | Ast.Debug l -> debug l
     | _ -> assert false

runtime/value.mli

 type t
 type env
+val empty_env : env
 
 val print: Format.formatter -> t -> unit
 

types/patterns.ml

@@ -376,7 +376,7 @@ struct
     in
     aux f a 0
 
-  let combine disp act =
+  let combine (disp,act) =
     if Array.length act = 0 then `None
     else
       if (array_for_all (fun (_,ar,_) -> ar = 0) disp.codes) 
@@ -575,8 +575,32 @@ struct
       d t selected unselect
     in
     let res = Array.map result disp.codes in
-    post (combine disp res)
-
+    post (disp,res)
+
+  let make_branches t brs =
+    let (_,brs) = 
+      List.fold_left
+	(fun (t,brs) (p,e) ->
+	   let p = Normal.restrict t (Normal.nf p) in
+	   let t = Types.diff t (p.Normal.a) in
+	   (t, (p,e) :: brs)
+	) (t,[]) brs in
+	   
+    let pl = Array.map (fun x -> [x]) (Array.of_list brs) in
+    get_tests 
+      pl 
+      (fun x -> [x],[])
+      t
+      (fun _ pl _ ->
+	 let r = ref None in
+	 let aux = function 
+	   | [x] -> assert (!r = None); r := Some x
+	   | [] -> () | _ -> assert false in
+	 Array.iter aux pl;
+	 let r = match !r with None -> assert false | Some x -> x in
+	 r
+      )
+      (fun x -> x)
 
 
   let rec dispatch_prod disp =
@@ -586,14 +610,14 @@ struct
       (fun (res,(p,q)) -> [p, (res,q)], [])
       (Types.Product.pi1 t)
       (dispatch_prod1 disp t)
-      detect_left_tail_call
+      (fun x -> detect_left_tail_call (combine x))
   and dispatch_prod1 disp t t1 pl _ =
     let t = Types.Product.restrict_1 t t1 in
     get_tests pl
       (fun (ret1, (res,q)) -> [q, (ret1,res)], [] ) 
       (Types.Product.pi2 t)
       (dispatch_prod2 disp t)
-      detect_right_tail_call
+      (fun x -> detect_right_tail_call (combine x))
   and dispatch_prod2 disp t t2 pl _ =
     let aux_final (ret2, (ret1, res)) =  
       List.map (conv_source_prod ret1 ret2) res in
@@ -656,7 +680,7 @@ struct
 		 | x -> [],[x])
 	      (Types.Record.project_field t l)
 	      (dispatch_record_field l disp t)
-	      (fun x -> x)
+	      (fun x -> combine x)
 	  in
 	  let absent = 
 	    let pl = label_not_found l pl in

types/patterns.mli

@@ -66,4 +66,8 @@ module Compile: sig
   val actions: dispatcher -> actions
 
   val show : Format.formatter -> Types.descr -> normal array -> unit
+
+  val make_branches :
+    Types.descr -> (descr * 'a) list ->
+    dispatcher * ((capture, int) SortedMap.t * 'a) array
 end

typing/typed.ml

@@ -57,7 +57,18 @@ and branch = {
   br_pat : tpat; 
   br_body :  texpr 
 }
-and compiled_branches = {
-  actions : Patterns.Compile.actions;
-  rhs : (texpr * (string * int) list) array
-}
+and compiled_branches =  
+    Patterns.Compile.dispatcher * ((string * int) list * texpr) array
+
+
+let dispatcher brs =
+  match brs.br_compiled with
+    | Some d -> d
+    | None ->
+	let aux b = Patterns.descr b.br_pat, b.br_body in
+	let x = Patterns.Compile.make_branches
+		  brs.br_typ
+		  (List.map aux brs.br_branches) in
+	brs.br_compiled <- Some x;
+	x
+