[r2003-05-25 16:53:21 by cvscast] toplevel

Original author: cvscast
Date: 2003-05-25 16:53:22+00:00

driver/cduce.ml

@@ -5,8 +5,10 @@ let quiet = ref false
 
 let typing_env = State.ref "Cduce.typing_env" Env.empty
 
+let eval_env = State.ref "Cduce.eval_env" Env.empty
+
 let enter_global_value x v t =
-  Eval.enter_global x v;
+  eval_env := Env.add x v !eval_env;
   typing_env := Env.add x t !typing_env
 
 let rec is_abstraction = function
@@ -38,7 +40,7 @@ let dump_env ppf =
 	 print_norm t
 	 print_value v
     )
-    !Eval.global_env
+    !eval_env
   
 
 let rec print_exn ppf = function
@@ -130,91 +132,88 @@ let debug ppf = function
 
 
 
+let insert_type_bindings ppf = 
+  List.iter 
+    (fun (x,t) ->
+       typing_env := Env.add x t !typing_env;
+       if not !quiet then
+	 Format.fprintf ppf "|- %a : %a@." 
+	   U.print (Id.value x) print_norm t) 
 
-
-let run ppf ppf_err input =
-  let insert_type_bindings = 
-    List.iter (fun (x,t) ->
-		 typing_env := Env.add x t !typing_env;
-		 if not !quiet then
-		   Format.fprintf ppf "|- %a : %a@\n@." U.print (Id.value x) print_norm t) 
-  in
+let insert_eval_bindings ppf =
+  List.iter 
+    (fun (x,v) ->
+       eval_env := Env.add x v !eval_env;
+       if not !quiet then
+	 Format.fprintf ppf "=> %a : @[%a@]@." 
+	   U.print (Id.value x) print_value v
+    )
   
-  let type_decl decl =
-    insert_type_bindings (Typer.type_let_decl !typing_env decl);
-    Typer.report_unused_branches ()
-  in
-
-  let eval_decl decl =
-    let bindings = Eval.eval_let_decl Env.empty decl in
-    List.iter 
-      (fun (x,v) ->
-	 Eval.enter_global x v;
-	 if not !quiet then
-	   Format.fprintf ppf "=> %a : @[%a@]@\n@." U.print (Id.value x) print_value v
-      ) bindings
-  in
-
-  let phrase ph = 
-    match ph.descr with
-      | Ast.EvalStatement e ->
-	  let (fv,e) = Typer.expr e in
-	  let t = Typer.type_check !typing_env e Types.any true in
-	  Typer.report_unused_branches ();
-	  Location.dump_loc ppf e.Typed.exp_loc;
-	  if not !quiet then
-	    Format.fprintf ppf "|- %a@\n@." print_norm t;
-	  let v = Eval.eval Env.empty e in
-	  if not !quiet then
-	    Format.fprintf ppf "=> @[%a@]@\n@." print_value v
-      | Ast.LetDecl (p,e) when is_abstraction e -> ()
-      | Ast.LetDecl (p,e) ->
-	  let decl = Typer.let_decl p e in
-	  type_decl decl;
-	  Typer.report_unused_branches ();
-	  eval_decl decl
-      | Ast.TypeDecl _ -> ()
-      | Ast.Debug l -> debug ppf l
-      | _ -> assert false
-  in
-
-  let do_fun_decls decls =
-    let decls = List.map (fun (p,e) -> Typer.let_decl p e) decls in
-    insert_type_bindings (Typer.type_rec_funs !typing_env decls);
-    Typer.report_unused_branches ();
-    List.iter eval_decl decls
-  in
-  let rec phrases funs = function
-    | { descr = Ast.LetDecl (p,e) } :: phs when is_abstraction e -> 
-	phrases ((p,e)::funs) phs
-    | ph :: phs ->
-	do_fun_decls funs;
-	phrase ph;
-	phrases [] phs
-    | _ ->
-	do_fun_decls funs
-  in
+let rec collect_funs ppf accu = function
+  | { descr = Ast.FunDecl e } :: rest -> 
+      let (_,e) = Typer.expr e in
+      collect_funs ppf (e::accu) rest
+  | rest ->
+      insert_type_bindings ppf (Typer.type_rec_funs !typing_env accu);
+      Typer.report_unused_branches ();
+      insert_eval_bindings ppf (Eval.eval_rec_funs !eval_env accu);
+      rest
+
+let rec collect_types ppf accu = function
+  | { descr = Ast.TypeDecl (x,t) } :: rest -> 
+      collect_types ppf ((x,t) :: accu) rest
+  | rest ->
+      Typer.register_global_types accu;
+      rest
+
+let rec phrases ppf phs = match phs with
+  | { descr = Ast.FunDecl _ } :: _ -> 
+      phrases ppf (collect_funs ppf [] phs)
+  | { descr = Ast.TypeDecl (_,_) } :: _ ->
+      phrases ppf (collect_types ppf [] phs)
+  | { descr = Ast.EvalStatement e } :: rest ->
+      let (fv,e) = Typer.expr e in
+      let t = Typer.type_check !typing_env e Types.any true in
+      Typer.report_unused_branches ();
+      if not !quiet then
+	Location.dump_loc ppf e.Typed.exp_loc;
+      if not !quiet then
+	Format.fprintf ppf "|- %a@." print_norm t;
+      let v = Eval.eval !eval_env e in
+      if not !quiet then
+	Format.fprintf ppf "=> @[%a@]@." print_value v;
+      phrases ppf rest
+  | { descr = Ast.LetDecl (p,e) } :: rest ->
+      let decl = Typer.let_decl p e in
+      insert_type_bindings ppf (Typer.type_let_decl !typing_env decl);
+      Typer.report_unused_branches ();
+      insert_eval_bindings ppf (Eval.eval_let_decl !eval_env decl);
+      phrases ppf rest
+  | { descr = Ast.Debug l } :: rest -> 
+      debug ppf l;
+      phrases ppf rest
+  | [] -> ()
+  | _ -> assert false
+
+let run rule ppf ppf_err input =
   try 
     let p = 
-      try Parser.prog input
+      try rule input
       with
-	| Stdpp.Exc_located (_, (Location _ as e)) -> raise e
-	| Stdpp.Exc_located ((i,j), e) -> raise_loc i j e
+	| Stdpp.Exc_located (_, (Location _ as e)) ->
+	    Parser.sync input; raise e
+	| Stdpp.Exc_located ((i,j), e) -> 
+	    Parser.sync input; raise_loc i j e
     in
-    let (type_decls,fun_decls) = 
-      List.fold_left
-	(fun ((typs,funs) as accu) ph -> match ph.descr with
-	   | Ast.TypeDecl (x,t) -> ((x,t) :: typs,funs)
-	   | Ast.LetDecl (p,e) when is_abstraction e -> 
-	       (typs, (p,e)::funs)
-	   | _ -> accu
-	) ([],[]) p in
-    Typer.register_global_types type_decls;
-    phrases [] p;
+    phrases ppf p;
     true
   with 
-    | (Failure _ | Not_found | Invalid_argument _) as e -> 
+    | (End_of_file | Failure _ | Not_found | Invalid_argument _) as e -> 
 	raise e  (* To get ocamlrun stack trace *)
-    | exn -> print_exn ppf_err exn; false
-	
+    | exn -> 
+	print_exn ppf_err exn;
+	Format.fprintf ppf_err "@.";
+	false
 
+let script = run Parser.prog
+let toplevel = run Parser.top_phrases

driver/cduce.mli

 val quiet: bool ref
 
-val print_exn: Format.formatter -> exn -> unit
-
 val enter_global_value : Ident.id -> Value.t -> Types.descr -> unit
-val run : Format.formatter -> Format.formatter -> char Stream.t -> bool
-  (* Returns true if everything is ok (no error) *)
+val script   : Format.formatter -> Format.formatter -> char Stream.t -> bool
+val toplevel : Format.formatter -> Format.formatter -> char Stream.t -> bool
 
 val dump_env : Format.formatter -> unit

driver/run.ml

@@ -43,10 +43,36 @@ let ppf =
   else Format.std_formatter
 let ppf_err = Format.err_formatter
 
+
+let first_line = ref true
+let bol = ref true
+
+let read i =
+  let first = !first_line in
+  if first
+  then output_string stdout "* " 
+  else if !bol then output_string stdout "> ";
+  flush stdout;
+  first_line := false;
+  let c = input_char stdin in
+  flush stderr;
+  bol := (not first) && c = '\n';
+  Some c
+
+
+let toploop () =
+  Location.push_source `Stream;
+  let input = Stream.from read in
+  let rec loop () =
+    first_line := true; bol := false;
+    ignore (Cduce.toplevel ppf ppf_err input);
+    loop () in
+  try loop ()
+  with End_of_file -> exit 0
+
 let do_file s =
-  let (src, chan) = 
-    if s = "" then (`Stream, stdin) else (`File s, open_in s) in
-  Location.push_source src;
+  let chan = open_in s in
+  Location.push_source (`File s);
   let input = Stream.of_channel chan in
   if Stream.peek input = Some '#' then
     (
@@ -55,10 +81,10 @@ let do_file s =
 	  | '\n' -> n
 	  | _ -> count (n + 1) in
       Wlexer.set_delta_loc (count 1)
-    );
-  let ok = Cduce.run ppf ppf_err input in
-  if s <> "" then close_in chan;
-  if not ok then (Format.fprintf ppf_err "@."; exit 1)
+    ); 
+  let ok = Cduce.script ppf ppf_err input in
+  close_in chan;
+  if not ok then exit 1
 
   
 
@@ -83,9 +109,9 @@ let main () =
   (match !src with
      | [] -> 
 	 Format.fprintf ppf 
-	   "CDuce version %s\nNo script specified; using stdin ...@."
+	   "        CDuce version %s\n@."
 	   Cduce_config.version;
-	 do_file ""
+	 toploop ()
      | l -> List.iter do_file l);
   (match !dump with
      | Some f ->

driver/webiface.ml

@@ -259,7 +259,7 @@ let main (cgi : Netcgi.std_activation) =
       Location.set_protected true;
       
       Location.warning_ppf := ppf;
-      let ok = Cduce.run ppf ppf input in
+      let ok = Cduce.script ppf ppf input in
       if ok then Format.fprintf ppf "@\nOk.@\n";
       let res = Format.flush_str_formatter () in
       p "<div class=\"box\"><h2>Results</h2><pre>"; 

parser/ast.ml

@@ -9,8 +9,8 @@ and pmodule_item = pmodule_item' located
 and pmodule_item' =
   | TypeDecl of string * ppat
   | PatDecl of string * ppat
-  | FunDecl of abstr
   | LetDecl of ppat * pexpr
+  | FunDecl of pexpr
   | EvalStatement of pexpr
   | Debug of debug_directive
 and debug_directive =

parser/parser.ml

@@ -21,6 +21,7 @@ let label s = LabelPool.mk (parse_ident s)
 let ident s = ident (parse_ident s)
 
 let prog    = Grammar.Entry.create gram "prog"
+let top_phrases   = Grammar.Entry.create gram "toplevel phrases"
 let expr    = Grammar.Entry.create gram "expression"
 let pat     = Grammar.Entry.create gram "type/pattern expression"
 let regexp  = Grammar.Entry.create gram "type/pattern regexp"
@@ -93,20 +94,26 @@ let char_list loc s =
 let include_stack = ref []
 
 EXTEND
-  GLOBAL: prog expr pat regexp const;
+  GLOBAL: top_phrases prog expr pat regexp const;
+
+  top_phrases: [
+    [ l = LIST0 phrase; ";;" -> List.flatten l ]
+  ];
 
   prog: [
-    [ l = LIST0 [ p = phrase; ";;" -> p ]; EOI -> List.flatten l ]
+    [ l = LIST0 [ p = phrase ; OPT ";;" -> p ]; EOI -> List.flatten l ]
   ];
 
   phrase: [
-    [ (p,e) = let_binding -> [ mk loc (LetDecl (p,e)) ]
-    | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
+    [ (f,p,e) = let_binding -> 
+	if f then [ mk loc (FunDecl e) ] else
+	  [ mk loc (LetDecl (p,e)) ]
+    | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         [ mk loc (EvalStatement (exp loc (Match (e1,[p,e2])))) ]
-    | LIDENT "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
-    | LIDENT "type"; x = LIDENT -> [ error loc "Type identifiers must be capitalized" ]
-    | LIDENT "debug"; d = debug_directive -> [ mk loc (Debug d) ]
-    | LIDENT "include"; s = STRING2 ->
+    | "type"; x = UIDENT; "="; t = pat -> [ mk loc (TypeDecl (x,t)) ]
+    | "type"; x = LIDENT -> error loc "Type identifiers must be capitalized"
+    | "debug"; d = debug_directive -> [ mk loc (Debug d) ]
+    | "include"; s = STRING2 ->
 	let s = get_string s in
 	protect_op "File inclusion";
 	(* avoid looping; should issue an error ? *)
@@ -141,7 +148,7 @@ EXTEND
 	[ "map" | "match" | "with" | "try" | "xtransform"
 	| "if" | "then"	| "else"
 	| "transform" | "fun" | "in"
-	| "let"
+	| "let" | "type" | "debug" | "include"
 	]
 	-> a
     ]
@@ -165,7 +172,7 @@ EXTEND
 	exp loc (Transform (e,b))
     | "fun"; (f,a,b) = fun_decl ->
 	exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
-    | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
+    | (_,p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
         exp loc (Match (e1,[p,e2]))
     | e = expr; ":"; p = pat ->
 	exp loc (Forget (e,p))
@@ -259,8 +266,8 @@ EXTEND
   ];
 	  
   let_binding: [
-    [ "let"; p = pat; "="; e = expr -> (p,e)
-    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, Forget (e,t))
+    [ "let"; p = pat; "="; e = expr -> (false,p,e)
+    | "let"; p = pat; ":"; t = pat; "="; e = expr -> (false,p, Forget (e,t))
     | "let"; "fun"; (f,a,b) = fun_decl ->
 	let p = match f with 
 	  | Some x -> mk loc (Capture x)
@@ -268,7 +275,7 @@ EXTEND
 	in
 	let abst = { fun_name = f; fun_iface = a; fun_body = b } in
         let e = exp loc (Abstraction abst) in
-        (p,e);
+        (true,p,e)
     ] 
   ];
 
@@ -462,10 +469,12 @@ END
 let pat = Grammar.Entry.parse pat
 and expr = Grammar.Entry.parse expr
 and prog = Grammar.Entry.parse prog
-
-
-module From_string = struct
-  let pat s = Grammar.Entry.parse pat' (Stream.of_string s)
-  let expr s = expr (Stream.of_string s)
-end
-
+and top_phrases = Grammar.Entry.parse top_phrases
+
+let rec sync s =
+  match Stream.next s with
+    | ';' ->  
+	(match Stream.next s with
+	   | ';' -> ()
+	   | _ -> sync s)
+    | _ -> sync s

parser/parser.mli

@@ -3,8 +3,6 @@ exception Error of string
 val expr : char Stream.t -> Ast.pexpr
 val pat : char Stream.t -> Ast.ppat
 val prog : char Stream.t -> Ast.pmodule_item list
+val top_phrases : char Stream.t -> Ast.pmodule_item list
 
-module From_string : sig
-  val pat  : string -> Ast.ppat
-  val expr : string -> Ast.pexpr
-end
+val sync : char Stream.t -> unit

parser/wlexer.mll

 (* File to be processed by wlex, not ocamllex ! *)
-(* Loosely inspired from OCaml lexer.mll *)
 
 classes 
    encoding_error
    xml_char
-   blank 
+   blank
    lowercase uppercase ascii_digit 
-   "_<>=.,:;+-*/@&{}[]()|?`\"\\\'!"
+   "#_<>=.,:;+-*/@&{}[]()|?`\"\\\'!"
 
    unicode_base_char
    unicode_ideographic
@@ -85,17 +84,6 @@ let ncname_char =
 let ncname = (letter | '_' ) ncname_char*
 let qname = (ncname ':')? ncname
 
-(*
-let lident = (lowercase | '_' | unicode_base_char | unicode_ideographic) 
-	       name_char*
-let uident = uppercase name_char*
-*)
-
-(*
-let identchar = lowercase | uppercase | ascii_digit | '_' | '\'' | '-'
-let ident = identchar* ( ':' identchar+)*
-*)
-
 rule token = parse
     blank+    { token engine lexbuf }
   | qname 
@@ -203,6 +191,7 @@ and parse_hexa_char = parse
 	  (Illegal_character '\\') }
 
 
+
 {
 
   let delta_loc = ref 0

runtime/eval.ml

@@ -5,19 +5,11 @@ open Ident
 exception MultipleDeclaration of id
 type env = t Env.t
 
-let global_env = State.ref "Eval.global_env" Env.empty
-
-let enter_global x v = 
-  if Env.mem x !global_env then
-    raise (MultipleDeclaration x);
-  global_env := Env.add x v !global_env
-
-
 (* 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.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
   | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
   | Typed.Abstraction a -> eval_abstraction env a
   | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
@@ -44,19 +36,22 @@ and eval_try env arg brs =
       | x -> x
 
 and eval_abstraction env a =
+  let self = ref Value.Absent in
   let env = 
     IdSet.fold
-      (fun accu x -> 
-	 try Env.add x (Env.find x env) accu with Not_found -> accu)
+      (fun accu x -> Env.add x (Env.find x env) accu)
       Env.empty a.Typed.fun_fv in
-  let env_ref = ref env in
-  let 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
+  match a.Typed.fun_name with
+    | None -> 
+	Abstraction (a.Typed.fun_iface, eval_branches env a.Typed.fun_body)
+    | Some f -> 
+	let self = ref Value.Absent in
+	let env = Env.add f (Value.Delayed self) env in
+	let a = 
+	  Abstraction 
+	    (a.Typed.fun_iface, eval_branches env a.Typed.fun_body) in
+	self := a;
+	a
 
 
 and eval_apply f arg = match f with
@@ -87,6 +82,21 @@ and eval_let_decl env l =
     (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) 
     (IdMap.get bind)
 
+and eval_rec_funs env l =
+  let slots = 
+    List.fold_left
+      (fun accu -> function  
+	 | { Typed.exp_descr=Typed.Abstraction 
+			       { Typed.fun_name = Some f } } as e ->
+	     (f, e, ref Absent) :: accu
+	 | _ -> assert false
+      ) [] l in
+  let env' = 
+    List.fold_left 
+      (fun env (f, _ ,s) -> Env.add f (Delayed s) env) 
+      env slots in
+  List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots
+
 and eval_map env brs = function
   | Pair (x,y) -> 
       let x = eval_branches env brs x in

runtime/eval.mli

@@ -4,12 +4,6 @@ open Ident
 exception MultipleDeclaration of id
 type env = t Env.t
 
-val global_env : env ref
-
-val enter_global : id -> t -> unit
-
 val eval: env -> Typed.texpr -> t
 val eval_let_decl: env -> Typed.let_decl -> (id * t) list
-
-
-
+val eval_rec_funs: env -> Typed.texpr list -> (id * t) list

runtime/run_dispatch.ml

@@ -168,6 +168,7 @@ and run_disp_kind actions v =
         actions.basic
   | Absent ->
       run_disp_basic v (fun t -> Types.Record.has_absent t) actions.basic
+  | Delayed _ -> assert false
 
 
 and run_disp_prod v v1 v2 = function

runtime/value.ml

@@ -13,6 +13,8 @@ type t =
   | String_utf8 of Utf8.uindex * Utf8.uindex * Utf8.t * t
   | Absent
 
+  | Delayed of t ref
+
 
 exception CDuceExn of t
 
@@ -117,6 +119,8 @@ let rec print ppf v =
 	(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
     | Absent -> 	
 	Format.fprintf ppf "<[absent]>"
+    | Delayed x ->
+	Format.fprintf ppf "<[delayed]>"
 and print_quoted_str ppf = function
   | Pair (Char c, q) -> 
       Chars.print_v_in_string ppf c; 
@@ -204,7 +208,8 @@ let rec compare x y =
       | Abstraction (_,_), _
       | _, Abstraction (_,_) -> 
 	  raise (CDuceExn (string_latin1 "comparing functional values"))
-      | Absent,_ | _,Absent -> assert false
+      | Absent,_ | _,Absent 
+      | Delayed _, _ | _, Delayed _ -> assert false
       | String_latin1 (ix,jx,sx,qx), String_latin1 (iy,jy,sy,qy) ->
 	  if (sx == sy) && (ix = iy) && (jx = jy) then compare qx qy
 	  else

runtime/value.mli

@@ -18,6 +18,8 @@ type t =
 (* Special value for absent record fields, and failed pattern matching *)
   | Absent
 
+(* Only in evaluation environment *)
+  | Delayed of t ref
 
 exception CDuceExn of t
 

tests/overloading.cd

-type Person = FPerson | MPerson;; 
-type FPerson = <person gender = "F" >[ Name Children (Tel | Email)?];; 
-type MPerson = <person gender="M">[ Name Children (Tel | Email)?];; 
-type Children = <children>[Person*];; 
-type Name = <name>[ PCDATA ];;
-type Tel = <tel kind=?"home"|"work">['0'--'9'+ '-' '0'--'9'+];;
-type Email = <email>[PCDATA '@' PCDATA];;
-
-type Man = <man name=String>[ Sons Daughters ];;
-type Woman = <woman name=String>[ Sons Daughters ];;
-type Sons = <sons>[ Man* ];;
-type Daughters = <daughters>[ Woman* ];;
+type Person = FPerson | MPerson
+type FPerson = <person gender = "F" >[ Name Children (Tel | Email)?]
+type MPerson = <person gender="M">[ Name Children (Tel | Email)?]
+type Children = <children>[Person*]
+type Name = <name>[ PCDATA ]
+type Tel = <tel kind=?"home"|"work">['0'--'9'+ '-' '0'--'9'+]
+type Email = <email>[PCDATA '@' PCDATA]
+
+type Man = <man name=String>[ Sons Daughters ]
+type Woman = <woman name=String>[ Sons Daughters ]
+type Sons = <sons>[ Man* ]
+type Daughters = <daughters>[ Woman* ]
 
 let fun sort (MPerson -> Man ; FPerson -> Woman)
    <person gender=g>[ <name>n <children>[(mc::MPerson | fc::FPerson)*]; _] ->
@@ -17,7 +17,7 @@ let fun sort (MPerson -> Man ; FPerson -> Woman)
        let s = map mc with x -> sort x in
        let d = map fc with x -> sort x in	
            <(tag) name=n>[ <sons>s  <daughters>d ] 
-;; 
+
 
 let base : Person = 
 <person gender="M">[ 
@@ -34,8 +34,8 @@ let base : Person =
     <tel> "314-1592654"
     ]
   ]
-]
-;;
+];;
+
 
 
 sort base;;

typing/typer.ml

@@ -492,26 +492,34 @@ and pat_node s : Patterns.node =
     x
       
 let glb = State.ref "Typer.glb_env" TypeEnv.empty
-	    
-	    
+
 let register_global_types b =
   List.iter 
     (fun (v,p) ->
        if TypeEnv.mem v !glb
        then raise_loc_generic p.loc ("Multiple definition for type " ^ v)
     ) b;