[r2003-05-25 10:34:50 by cvscast] review Builtin

Original author: cvscast
Date: 2003-05-25 10:34:50+00:00

Makefile

@@ -47,7 +47,7 @@ OBJECTS = \
  \
  types/sortedList.cmo types/boolean.cmo types/ident.cmo \
  types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
- types/types.cmo types/patterns.cmo types/sequence.cmo types/builtin.cmo \
+ types/types.cmo types/patterns.cmo types/sequence.cmo \
  types/sample.cmo \
  \
  parser/location.cmo parser/wlexer.cmo parser/ast.cmo parser/parser.cmo \
@@ -57,7 +57,7 @@ OBJECTS = \
  runtime/value.cmo runtime/load_xml.cmo runtime/run_dispatch.cmo \
  runtime/print_xml.cmo runtime/eval.cmo \
  \
- driver/cduce.cmo
+ types/builtin.cmo driver/cduce.cmo
 
 CDUCE = $(OBJECTS) driver/run.cmo
 WEBIFACE  = $(OBJECTS) driver/examples.cmo driver/webiface.cmo

depend

@@ -12,38 +12,42 @@ parser/ast.cmo: types/ident.cmo parser/location.cmi types/types.cmi
 parser/ast.cmx: types/ident.cmx parser/location.cmx types/types.cmx 
 parser/location.cmo: parser/location.cmi 
 parser/location.cmx: parser/location.cmi 
-parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/builtin.cmo \
-    types/chars.cmi misc/encodings.cmi types/ident.cmo types/intervals.cmi \
+parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
+    misc/encodings.cmi types/ident.cmo types/intervals.cmi \
     parser/location.cmi types/sequence.cmi types/types.cmi parser/wlexer.cmo \
     parser/parser.cmi 
-parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/builtin.cmx \
-    types/chars.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
+parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
+    misc/encodings.cmx types/ident.cmx types/intervals.cmx \
     parser/location.cmx types/sequence.cmx types/types.cmx parser/wlexer.cmx \
     parser/parser.cmi 
 parser/wlexer.cmo: misc/encodings.cmi parser/location.cmi 
 parser/wlexer.cmx: misc/encodings.cmx parser/location.cmx 
 typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
-    types/types.cmi 
+    types/types.cmi runtime/value.cmi 
 typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
-    types/types.cmx 
-typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin.cmo \
-    types/ident.cmo types/intervals.cmi parser/location.cmi \
-    types/patterns.cmi types/sequence.cmi misc/state.cmi typing/typed.cmo \
-    types/types.cmi typing/typer.cmi 
-typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin.cmx \
-    types/ident.cmx types/intervals.cmx parser/location.cmx \
-    types/patterns.cmx types/sequence.cmx misc/state.cmx typing/typed.cmx \
-    types/types.cmx typing/typer.cmi 
+    types/types.cmx runtime/value.cmx 
+typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/ident.cmo \
+    types/intervals.cmi parser/location.cmi types/patterns.cmi \
+    types/sequence.cmi misc/state.cmi typing/typed.cmo types/types.cmi \
+    typing/typer.cmi 
+typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/ident.cmx \
+    types/intervals.cmx parser/location.cmx types/patterns.cmx \
+    types/sequence.cmx misc/state.cmx typing/typed.cmx types/types.cmx \
+    typing/typer.cmi 
 types/atoms.cmo: misc/encodings.cmi misc/pool.cmi types/sortedList.cmi \
     types/atoms.cmi 
 types/atoms.cmx: misc/encodings.cmx misc/pool.cmx types/sortedList.cmx \
     types/atoms.cmi 
 types/boolean.cmo: types/sortedList.cmi types/boolean.cmi 
 types/boolean.cmx: types/sortedList.cmx types/boolean.cmi 
-types/builtin.cmo: types/atoms.cmi types/chars.cmi types/sequence.cmi \
-    types/types.cmi 
-types/builtin.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
-    types/types.cmx 
+types/builtin.cmo: types/atoms.cmi types/chars.cmi runtime/eval.cmi \
+    types/ident.cmo runtime/load_xml.cmi parser/location.cmi \
+    runtime/print_xml.cmo types/sequence.cmi typing/typer.cmi types/types.cmi \
+    runtime/value.cmi 
+types/builtin.cmx: types/atoms.cmx types/chars.cmx runtime/eval.cmx \
+    types/ident.cmx runtime/load_xml.cmx parser/location.cmx \
+    runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
+    runtime/value.cmx 
 types/chars.cmo: types/chars.cmi 
 types/chars.cmx: types/chars.cmi 
 types/ident.cmo: misc/encodings.cmi misc/pool.cmi types/sortedList.cmi 
@@ -90,12 +94,12 @@ runtime/run_dispatch.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
 runtime/run_dispatch.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
     types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
     runtime/run_dispatch.cmi 
-runtime/value.cmo: types/atoms.cmi types/builtin.cmo types/chars.cmi \
-    misc/encodings.cmi types/ident.cmo types/intervals.cmi types/sequence.cmi \
-    types/types.cmi runtime/value.cmi 
-runtime/value.cmx: types/atoms.cmx types/builtin.cmx types/chars.cmx \
-    misc/encodings.cmx types/ident.cmx types/intervals.cmx types/sequence.cmx \
-    types/types.cmx runtime/value.cmi 
+runtime/value.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
+    types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
+    runtime/value.cmi 
+runtime/value.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
+    types/ident.cmx types/intervals.cmx types/sequence.cmx types/types.cmx \
+    runtime/value.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
     types/ident.cmo parser/location.cmi parser/parser.cmi types/patterns.cmi \
     types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \

driver/cduce.ml

@@ -5,11 +5,11 @@ let version = "0.0.9 (alpha)"
 
 let quiet = ref false
 
-let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
+let typing_env = State.ref "Cduce.typing_env" Env.empty
 
 let enter_global_value x v t =
   Eval.enter_global x v;
-  typing_env := Typer.Env.add x t !typing_env
+  typing_env := Env.add x t !typing_env
 
 let rec is_abstraction = function
   | Ast.Abstraction _ -> true
@@ -27,9 +27,9 @@ let dump_env ppf =
   Format.fprintf ppf "Global types:";
   Typer.dump_global_types ppf;
   Format.fprintf ppf ".@\n";
-  Eval.Env.iter 
+  Env.iter 
     (fun x v ->
-       let t = Typer.Env.find x !typing_env in
+       let t = Env.find x !typing_env in
        Format.fprintf ppf "@[|- %a : %a@ => %a@]@\n"
 	 U.print (Id.value x)
 	 print_norm t
@@ -63,7 +63,9 @@ let rec print_exn ppf = function
         print_norm t1
         msg
         print_norm t2
-  | Typer.Constraint (s,t,msg) ->
+  | Typer.Error s ->
+      Format.fprintf ppf "%s@\n" s
+  | Typer.Constraint (s,t) ->
       Format.fprintf ppf "This expression should have type:@\n%a@\n" 
         print_norm t;
       Format.fprintf ppf "but its inferred type is:@\n%a@\n" 
@@ -72,7 +74,7 @@ let rec print_exn ppf = function
       Location.protect ppf
 	(fun ppf ->
 	   Sample.print ppf (Sample.get (Types.diff s t)));
-      Format.fprintf ppf "@\n%s@\n" msg
+      Format.fprintf ppf "@\n"
   | Typer.NonExhaustive t ->
       Format.fprintf ppf "This pattern matching is not exhaustive@\n";
       Format.fprintf ppf "Residual type:@\n%a@\n"
@@ -131,18 +133,12 @@ let debug ppf = function
 
 
 
-let mk_builtin () =
-  let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)]) 
-	     Builtin.types in
-  List.iter Typer.register_global_types bi
-
-let () = mk_builtin ()
 
 
 let run ppf ppf_err input =
   let insert_type_bindings = 
     List.iter (fun (x,t) ->
-		 typing_env := Typer.Env.add x t !typing_env;
+		 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
@@ -153,7 +149,7 @@ let run ppf ppf_err input =
   in
 
   let eval_decl decl =
-    let bindings = Eval.eval_let_decl Eval.Env.empty decl in
+    let bindings = Eval.eval_let_decl Env.empty decl in
     List.iter 
       (fun (x,v) ->
 	 Eval.enter_global x v;
@@ -171,7 +167,7 @@ let run ppf ppf_err input =
 	  Location.dump_loc ppf e.Typed.exp_loc;
 	  if not !quiet then
 	    Format.fprintf ppf "|- %a@\n@." print_norm t;
-	  let v = Eval.eval Eval.Env.empty e in
+	  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 -> ()

parser/ast.ml

@@ -26,6 +26,7 @@ and pexpr =
   | LocatedExpr of loc * pexpr
 
   | Forget of pexpr * ppat    
+  | Op of string * pexpr list
 
   (* CDuce is a Lambda-calculus ... *)
   | Var of id
@@ -39,9 +40,9 @@ and pexpr =
   | RecordLitt of pexpr label_map
       
   (* Data destructors *)
-  | Op of string * pexpr list
   | Match of pexpr * branches
-  | Map of bool * pexpr * branches
+  | Map of pexpr * branches
+  | Transform of pexpr * branches
   | Xtrans of pexpr * branches
   | Dot of pexpr* label
   | RemoveField of pexpr * label

parser/parser.ml

@@ -8,6 +8,10 @@ let ()  = Grammar.error_verbose := true
 
 let gram    = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
 
+let true_atom = Atoms.mk_ascii "true"
+let false_atom = Atoms.mk_ascii "false"
+let true_type = Types.atom (Atoms.atom true_atom)
+let false_type = Types.atom (Atoms.atom false_atom)
 
 let parse_ident = Encodings.Utf8.mk_latin1
 
@@ -145,20 +149,23 @@ EXTEND
 
   expr: [
     "top" RIGHTA
-    [ "match"; e = SELF; "with"; b = branches -> exp loc (Match (e,b))
+    [ "match"; e = SELF; "with"; b = branches -> 
+	exp loc (Match (e,b))
     | "try"; e = SELF; "with"; b = branches -> 
 	let default = 
 	  mknoloc (Capture id_dummy), 
-	  Op ("raise",[Var id_dummy]) in
+	  Op ("raise", [Var id_dummy]) in
 	exp loc (Try (e,b@[default]))
-    | "map"; e = SELF; "with"; b = branches -> exp loc (Map (false,e,b))
-    | "xtransform"; e = SELF; "with"; b = branches -> exp loc (Xtrans (e,b))
+    | "map"; e = SELF; "with"; b = branches -> 
+	exp loc (Map (e,b))
+    | "xtransform"; e = SELF; "with"; b = branches -> 
+	exp loc (Xtrans (e,b))
     | "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
-	let p1 = mk loc (Internal (Builtin.true_type))
-	and p2 = mk loc (Internal (Builtin.false_type)) in
+	let p1 = mk loc (Internal true_type)
+	and p2 = mk loc (Internal false_type) in
 	exp loc (Match (e, [p1,e1; p2,e2]))
     | "transform"; e = SELF; "with"; b = branches -> 
-	exp loc (Op ("flatten", [Map (true,e,b)]))
+	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"->
@@ -194,7 +201,7 @@ EXTEND
 	let ct = mk loc (Regexp (re,any)) in
         let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
 	let b = (p,  Var id_dummy) in
-	exp loc (Op ("flatten", [Map (false,e,[b])]))
+	exp loc (Transform (e,[b]))
     ]
     |
     [ e = expr;  "."; l = [LIDENT | UIDENT | keyword ] -> 
@@ -208,10 +215,10 @@ EXTEND
 	   | LIDENT "load_html"
 	   | LIDENT "print_xml" | LIDENT "print_xml_utf8"
 	   | LIDENT "print"
-	   | LIDENT "raise" 
 	   | LIDENT "int_of"
 	   | LIDENT "string_of"
 	   | LIDENT "atom_of"
+	   | LIDENT "raise"
 	   ]; 
       e = expr -> exp loc (Op (op,[e]))
     | op = [ LIDENT "dump_to_file" | LIDENT "dump_to_file_utf8" ];

runtime/eval.ml

@@ -3,7 +3,6 @@ open Run_dispatch
 open Ident
 
 exception MultipleDeclaration of id
-module Env = Map.Make (Ident.Id)
 type env = t Env.t
 
 let global_env = State.ref "Eval.global_env" Env.empty
@@ -14,9 +13,6 @@ let enter_global x v =
   global_env := Env.add x v !global_env
 
 
-let exn_int_of = CDuceExn (Pair (
-			     Atom (Atoms.mk_ascii "Invalid_argument"),
-			     string_latin1 "int_of"))
 
 
 let exn_load_file_utf8 = CDuceExn (Pair (
@@ -31,7 +27,7 @@ let rec eval env e0 =
     | Typed.Forget (e,_) -> eval env e
     | Typed.Var s -> 
 	(try Env.find s env
-	with Not_found -> Env.find s !global_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 = 
@@ -57,51 +53,22 @@ let rec eval env e0 =
     | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
     | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
 	Xml (eval env e1, eval env e2, eval env e3)
+    | Typed.Xml (_,_) -> assert false
     | Typed.Cst c -> const c
     | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
-    | Typed.Map (false,arg,brs) -> eval_map env brs (eval env arg)
-    | Typed.Map (true,_,_) -> assert false
+    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
     | Typed.Xtrans (arg,brs) -> eval_xtrans 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", [{Typed.exp_descr=Typed.Map (true,arg,brs)}]) -> 
-	eval_transform env brs (eval env arg) 
-    | 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 ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
-    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
-    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
-    | Typed.Op ("load_file", [e]) -> eval_load_file ~utf8:false (eval env e)
-    | Typed.Op ("load_file_utf8", [e]) -> eval_load_file ~utf8:true (eval env e)
-    | Typed.Op ("print_xml", [e]) -> Print_xml.print_xml ~utf8:false (eval env e)
-    | Typed.Op ("print_xml_utf8", [e]) -> Print_xml.print_xml ~utf8:true (eval env e)
-    | Typed.Op ("print", [e]) -> eval_print (eval env e)
-    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
-    | Typed.Op ("atom_of", [e]) -> eval_atom_of (eval env e)
-    | Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
-    | Typed.Op ("dump_to_file", [e1; e2]) -> 
-	eval_dump_to_file (eval env e1) (eval env e2)
-    | Typed.Op ("dump_to_file_utf8", [e1; e2]) -> 
-	eval_dump_to_file_utf8 (eval env e1) (eval env e2)
-    | Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
-    | Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
-    | Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
-    | Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
-    | Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
+    | Typed.Try (arg,brs) -> (try eval env arg with CDuceExn v -> eval_branches env brs v)
+    | Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg) 
     | Typed.Dot (e, l) -> eval_dot l (eval env e)
     | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
-    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
-    | _ -> assert false
+    | Typed.UnaryOp (o,e) -> o.Typed.un_op_eval (eval env e)
+    | Typed.BinaryOp (o,e1,e2) -> o.Typed.bin_op_eval (eval env e1) (eval env e2)
 
 
 and eval_apply f arg = match f with
   | Abstraction (_,clos) -> clos arg
-  | _ -> eval_concat f arg
+  | _ -> assert false
 
 and eval_branches' env_ref brs arg =
   eval_branches !env_ref brs arg
@@ -132,14 +99,11 @@ and eval_map env brs = function
       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_transform env brs = function
   | Pair (x,y) -> 
       let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
-      eval_concat x (eval_transform env brs y)
+      concat x (eval_transform env brs y)
   | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
       if Types.Char.is_empty (brs.Typed.br_accept) 
       then eval_transform env brs q
@@ -167,15 +131,9 @@ and eval_xtrans env brs = function
 	     Pair (x,y)
 	 | x ->
 	     let y = eval_xtrans env brs y in
-	     eval_concat x y)
+	     concat x y)
   | q -> q
 
-and eval_concat l1 l2 = match l1 with
-  | Pair (x,y) -> Pair (x, eval_concat y l2)
-  | String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
-  | String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
-  | q -> l2
-
 and eval_dot l = function
   | Record r -> LabelMap.assoc l r
   | _ -> assert false
@@ -183,102 +141,3 @@ and eval_dot l = function
 and eval_remove_field l = function
   | Record r -> Record (LabelMap.remove l r)
   | _ -> assert false
-
-and eval_add x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
-  | Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
-  | _ -> assert false
-
-and eval_mul x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Intervals.vmult x y)
-  | _ -> assert false
-
-and eval_sub x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Intervals.vsub x y)
-  | _ -> assert false
-
-and eval_div x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
-  | _ -> assert false
-
-and eval_mod x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Intervals.vmod x y)
-  | _ -> assert false
-
-and eval_load_xml e =
-  Load_xml.load_xml (get_string_latin1 e)
-    (* Note: loading iso-8859-1 (even ASCII) files with utf-8 internal
-       encoding has a non negligible overhead with PXP *)
-
-and eval_load_html e =
-  Load_xml.load_html (get_string_latin1 e)
-
-and eval_load_file ~utf8 e =
-  Location.protect_op "load_file";
-  let ic = open_in (get_string_latin1 e) in
-  let len = in_channel_length ic in
-  let s = String.create len in
-  really_input ic s 0 len;
-  close_in ic;
-  if utf8 then 
-    if U.check s 
-    then Value.string_utf8 (U.mk s) 
-    else raise exn_load_file_utf8
-  else Value.string_latin1 s
-
-and eval_int_of e =
-  let (s,_) = get_string_utf8 e in
-  try Integer (Intervals.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
-  with Failure _ -> raise exn_int_of
-
-and eval_atom_of e =
-  let (s,_) = get_string_utf8 e in (* TODO: check that s is a correct Name wrt XML *)
-  Atom (Atoms.mk s)
-  
-and eval_print v =
-  Location.protect_op "print";
-  print_string (get_string_latin1 v);
-  flush stdout;
-  Value.nil
-
-and eval_dump_to_file f v =
-  Location.protect_op "dump_to_file";
-  let oc = open_out (get_string_latin1 f) in
-  output_string oc (get_string_latin1 v);
-  close_out oc;
-  Value.nil
-and eval_dump_to_file_utf8 f v =
-  Location.protect_op "dump_to_file_utf8";
-  let oc = open_out (get_string_latin1 f) in
-  let (v,_) = get_string_utf8 v in
-  output_string oc (U.get_str v);
-  close_out oc;
-  Value.nil
-
-
-and eval_string_of v =
-  let b = Buffer.create 16 in
-  let ppf = Format.formatter_of_buffer b in
-  Value.print ppf v;
-  Format.pp_print_flush ppf ();
-  string_latin1 (Buffer.contents b)
-    
-and eval_equal v1 v2 =
-  let c = Value.compare v1 v2 in
-  Value.vbool (Value.compare v1 v2 == 0)
-
-and eval_lt v1 v2 =
-  let c = Value.compare v1 v2 in
-  Value.vbool (Value.compare v1 v2 < 0)
-
-and eval_lte v1 v2 =
-  let c = Value.compare v1 v2 in
-  Value.vbool (Value.compare v1 v2 <= 0)
-
-and eval_gt v1 v2 =
-  let c = Value.compare v1 v2 in
-  Value.vbool (Value.compare v1 v2 > 0)
-
-and eval_gte v1 v2 =
-  let c = Value.compare v1 v2 in
-  Value.vbool (Value.compare v1 v2 >= 0)

runtime/eval.mli

@@ -2,7 +2,6 @@ open Value
 open Ident
 
 exception MultipleDeclaration of id
-module Env : Map.S with type key = id
 type env = t Env.t
 
 val global_env : env ref

runtime/value.ml

@@ -19,14 +19,24 @@ exception CDuceExn of t
 let nil = Atom Sequence.nil_atom
 let string_latin1 s = String_latin1 (0,String.length s, s, nil)
 let string_utf8 s = String_utf8 (Utf8.start_index s,Utf8.end_index s, s, nil)
-let vtrue = Atom Builtin.true_atom
-let vfalse = Atom Builtin.false_atom
+let vtrue = Atom (Atoms.mk_ascii "true")
+let vfalse = Atom (Atoms.mk_ascii "false")
 let vbool x = if x then vtrue else vfalse
 
 let rec sequence = function
   | [] -> nil
   | h::t -> Pair (h, sequence t)
 
+let rec concat l1 l2 = match l1 with
+  | Pair (x,y) -> Pair (x, concat y l2)
+  | String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, concat q l2)
+  | String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, concat q l2)
+  | q -> l2
+
+let rec flatten = function
+  | Pair (x,y) -> concat x (flatten y)
+  | q -> q
+
 let const = function
   | Types.Integer i -> Integer i
   | Types.Atom a -> Atom a

runtime/value.mli

@@ -35,6 +35,8 @@ val vfalse : t
 val vbool : bool -> t
 
 val sequence : t list -> t
+val concat : t -> t -> t
+val flatten : t -> t
 
 val get_string_latin1 : t -> string
 val get_string_utf8 : t -> U.t * t

types/builtin.ml

@@ -18,22 +18,302 @@ let true_type = Types.atom (Atoms.atom true_atom)
 let false_type = Types.atom (Atoms.atom false_atom)
 
 let bool = Types.cup true_type false_type
+let nil = Sequence.nil_type
+let string = Sequence.string
+let any = Types.any
+let int = Types.Int.any
+let atom = Types.atom Atoms.any
 
 let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
 let string_latin1 = Sequence.star char_latin1
 
+(* Types *)
+
 let types =
   [ 
     "Empty",   Types.empty;
-    "Any",     Types.any;
-    "Int",     Types.Int.any;
+    "Any",     any;
+    "Int",     int;
     "Char",    Types.char Chars.any;
     "Byte",    char_latin1;
-    "Atom",    Types.atom Atoms.any;
+    "Atom",    atom;
     "Pair",    Types.Product.any;
     "Arrow",   Types.Arrow.any;
     "Record",  Types.Record.any;
-    "String",  Sequence.string;
+    "String",  string;
     "Latin1",  string_latin1;
     "Bool",    bool
-  ];
+  ]
+
+let () =
+  List.iter
+    (fun (n,t) -> 
+       Typer.register_global_types [n, Location.mknoloc (Ast.Internal t)]) 
+    types
+
+(* Operators *)
+
+let binary_op_gen name typ run =
+  Typed.register_op name 
+    (`Binary { Typed.bin_op_typer = typ; Typed.bin_op_eval = run })
+
+let unary_op_gen name typ run =
+  Typed.register_op name 
+    (`Unary { Typed.un_op_typer = typ; Typed.un_op_eval = run })
+
+
+let binary_op name t1 t2 f run =
+  binary_op_gen
+    name
+    (fun loc arg1 arg2 constr precise ->
+       f (arg1 t1 true) (arg2 t2 true))
+    run
+
+let binary_op_cst name t1 t2 t run =
+  binary_op_gen name
+    (fun loc arg1 arg2 constr precise ->
+       ignore (arg1 t1 false); 
+       ignore (arg2 t2 false); 
+       t)
+    run
+
+let binary_op_warning2 name t1 t2 w2 t run =
+  binary_op_gen name
+    (fun loc arg1 arg2 constr precise ->
+       ignore (arg1 t1 false); 
+       let r = arg2 t2 true in
+       if not (Types.subtype r w2) then
+	 Typer.warning loc "This operator may fail"</