Commit b31535c1 authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2004-07-08 11:54:50+00:00
parent e87d00fa
......@@ -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 =
......
......@@ -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 =
......
......@@ -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;
......
......@@ -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
......@@ -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
......@@ -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
)
......@@ -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
......
......@@ -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
......
......@@ -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;
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment