[r2004-07-08 11:54:48 by afrisch] New system for operators

Original author: afrisch
Date: 2004-07-08 11:54:50+00:00

compile/compile.ml

@@ -86,6 +86,12 @@ and compile_aux env tail = function
       (match env.cu with
 	 | Some cu -> Var (External (cu,i))
 	 | None -> failwith "Cannot compile externals in the toplevel")
+  | Typed.Op (op,args) -> 
+      let rec aux = function
+	| [arg] -> [ compile env tail arg ]
+	| arg::l -> (compile env false arg) :: (aux l)
+	| [] -> [] in
+      Op (op, aux args)
 
 and compile_abstr env a =
   let fun_env = 

compile/lambda.ml

@@ -61,6 +61,7 @@ type expr =
   | UnaryOp of int * expr
   | BinaryOp of int * expr * expr
   | Ref of expr * Types.Node.t
+  | Op of string * expr list
 
 and branches = {
   brs: (Patterns.node * expr) list;
@@ -210,6 +211,10 @@ module Put = struct
 	bits nbits s 18;
 	expr s e;
 	Types.Node.serialize s t
+    | Op (op,args) ->
+	bits nbits s 19;
+	string s op;
+	list expr s args
 	  
   and branches s brs =
     list (pair Patterns.Node.serialize expr) s brs.brs;
@@ -327,6 +332,10 @@ module Get = struct
 	  let e = expr s in
 	  let t = Types.Node.deserialize s in
 	  Ref (e,t)
+      | 19 ->
+	  let op = string s in
+	  let args = list expr s in
+	  Op (op,args)
       | _ -> assert false
 
   and branches s =

compile/lambda.mli

@@ -34,6 +34,7 @@ type expr =
   | UnaryOp of int * expr
   | BinaryOp of int * expr * expr
   | Ref of expr * Types.Node.t
+  | Op of string * expr list
 
 and branches = {
   brs: (Patterns.node * expr) list;

compile/operators.ml

@@ -41,3 +41,8 @@ module Binary = struct
   Lambda.Put.binary_op := serialize;;
   Lambda.Get.binary_op := deserialize;;
 end
+
+
+let register op typ eval =
+  Typer.register_op op typ;
+  Eval.register_op op eval

compile/operators.mli

@@ -25,3 +25,8 @@ module Binary: sig
     ('a Serialize.Put.f) ->
     ('a Serialize.Get.f) -> unit
 end
+
+
+val register: 
+  string -> (type_fun list -> type_fun) -> (Value.t list -> Value.t) -> unit
+

driver/cduce.ml

@@ -342,6 +342,26 @@ let eval s =
     let ppf = Format.formatter_of_buffer b in
     print_exn ppf exn;
     Format.fprintf ppf "@.";
-    raise (Value.CDuceExn (Value.ocaml2cduce_string (Buffer.contents b)))
-
-
+    Value.failwith' (Buffer.contents b)
+
+
+let () =
+  Operators.register "eval_expr"
+    (function
+       | [ tf ] ->
+	   ignore (tf Builtin_defs.string_latin1 false);
+	   fun _ _ -> Types.any
+       | _ ->
+	   Location.raise_generic "eval needs exactly one argument"
+    )
+    (function
+       | [ v ] ->
+	   (match eval (Value.cduce2ocaml_string v) with
+	     | [ (None,v) ] -> v
+	     | _ -> Value.failwith' "eval: the string must evaluate to a single value")
+       | _ -> assert false
+    )
+
+	   
+       
+  

runtime/eval.ml

@@ -6,6 +6,10 @@ open Lambda
 let eval_unary_op = ref (fun _ -> assert false)
 let eval_binary_op = ref (fun _ _ -> assert false)
 
+let ops = Hashtbl.create 13
+let register_op = Hashtbl.add ops
+let eval_op = Hashtbl.find ops
+
 (* To write tail-recursive map-like iteration *)
 
 let make_accu () = Value.Pair(nil,Absent)
@@ -127,6 +131,7 @@ let rec eval env = function
       !eval_binary_op op v1 v2
   | Validate (e, kind, schema, name) -> eval_validate env e kind schema name
   | Ref (e,t) -> eval_ref env e t
+  | Op (op,args) -> eval_op op (List.map (eval env) args)
 
 and eval_abstraction env slots iface body =
   let local_env = Array.map (eval_var env) slots in

runtime/eval.mli

@@ -4,6 +4,7 @@ open Lambda
 
 val eval_unary_op: (int -> (t -> t)) ref
 val eval_binary_op : (int -> (t -> t -> t)) ref
+val register_op: string -> (t list -> t) -> unit
 
 val get_global: (Types.CompUnit.t -> int -> t) ref
 val set_global: (Types.CompUnit.t -> int -> t -> unit) ref

typing/typed.ml

@@ -53,6 +53,7 @@ and  texpr' =
   | BinaryOp of int * texpr * texpr
   | Ref of texpr * ttyp
   | External of Types.t * int
+  | Op of string * texpr list
 
 and abstr = { 
   fun_name : id option; 

typing/typer.ml

@@ -857,6 +857,17 @@ let exp loc fv e =
     Typed.exp_descr = e;
   }
 
+let ops = Hashtbl.create 13
+let is_op = Hashtbl.mem ops 
+let register_op = Hashtbl.add ops
+let typ_op = Hashtbl.find ops
+
+let rec apply_op args = function
+  | Apply (e1,e2) -> apply_op (e2::args) e1
+  | LocatedExpr (_,e) -> apply_op args e
+  | Var s when is_op (U.get_str s) -> (U.get_str s,args)
+  | _ -> raise Not_found
+
 
 let rec expr env loc = function
   | LocatedExpr (loc,e) -> expr env loc e
@@ -865,8 +876,15 @@ let rec expr env loc = function
       exp loc fv (Typed.Forget (e,t))
   | Var s -> var env loc s
   | Apply (e1,e2) -> 
-      let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
-      exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
+      (try 
+	 let (op,args) = apply_op [e2] e1 in
+	 let (fvs,args) = List.split (List.map (expr env loc) args) in
+	 let fv = List.fold_left Fv.cup Fv.empty fvs in
+	 exp loc fv (Typed.Op (op,args))
+       with Not_found ->
+	 let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
+	exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
+      )
   | Abstraction a ->
       let iface = List.map (fun (t1,t2) -> (typ env t1, typ env t2)) 
 		    a.fun_iface in
@@ -1188,6 +1206,12 @@ and type_check' loc env e constr precise = match e with
   | External (t,i) ->
       verify loc t constr
 
+  | Op (op,args) ->
+      let args = List.map (type_check env) args in
+      let t = typ_op op args constr precise in
+      verify loc t constr
+      
+
 and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
   let rects = Types.Product.normal ~kind constr in
   if Types.Product.is_empty rects then 

typing/typer.mli

@@ -79,3 +79,5 @@ val typ_unary_op: (int -> loc -> type_fun -> type_fun) ref
 
 val mk_binary_op: (string -> t -> int) ref
 val typ_binary_op: (int -> loc -> type_fun -> type_fun -> type_fun) ref
+
+val register_op: string -> (type_fun list -> type_fun) -> unit