Commit b31535c1 authored by Pietro Abate's avatar Pietro Abate
Browse files

[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 ...@@ -86,6 +86,12 @@ and compile_aux env tail = function
(match env.cu with (match env.cu with
| Some cu -> Var (External (cu,i)) | Some cu -> Var (External (cu,i))
| None -> failwith "Cannot compile externals in the toplevel") | 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 = and compile_abstr env a =
let fun_env = let fun_env =
......
...@@ -61,6 +61,7 @@ type expr = ...@@ -61,6 +61,7 @@ type expr =
| UnaryOp of int * expr | UnaryOp of int * expr
| BinaryOp of int * expr * expr | BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t | Ref of expr * Types.Node.t
| Op of string * expr list
and branches = { and branches = {
brs: (Patterns.node * expr) list; brs: (Patterns.node * expr) list;
...@@ -210,6 +211,10 @@ module Put = struct ...@@ -210,6 +211,10 @@ module Put = struct
bits nbits s 18; bits nbits s 18;
expr s e; expr s e;
Types.Node.serialize s t Types.Node.serialize s t
| Op (op,args) ->
bits nbits s 19;
string s op;
list expr s args
and branches s brs = and branches s brs =
list (pair Patterns.Node.serialize expr) s brs.brs; list (pair Patterns.Node.serialize expr) s brs.brs;
...@@ -327,6 +332,10 @@ module Get = struct ...@@ -327,6 +332,10 @@ module Get = struct
let e = expr s in let e = expr s in
let t = Types.Node.deserialize s in let t = Types.Node.deserialize s in
Ref (e,t) Ref (e,t)
| 19 ->
let op = string s in
let args = list expr s in
Op (op,args)
| _ -> assert false | _ -> assert false
and branches s = and branches s =
......
...@@ -34,6 +34,7 @@ type expr = ...@@ -34,6 +34,7 @@ type expr =
| UnaryOp of int * expr | UnaryOp of int * expr
| BinaryOp of int * expr * expr | BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t | Ref of expr * Types.Node.t
| Op of string * expr list
and branches = { and branches = {
brs: (Patterns.node * expr) list; brs: (Patterns.node * expr) list;
......
...@@ -41,3 +41,8 @@ module Binary = struct ...@@ -41,3 +41,8 @@ module Binary = struct
Lambda.Put.binary_op := serialize;; Lambda.Put.binary_op := serialize;;
Lambda.Get.binary_op := deserialize;; Lambda.Get.binary_op := deserialize;;
end end
let register op typ eval =
Typer.register_op op typ;
Eval.register_op op eval
...@@ -25,3 +25,8 @@ module Binary: sig ...@@ -25,3 +25,8 @@ module Binary: sig
('a Serialize.Put.f) -> ('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit ('a Serialize.Get.f) -> unit
end end
val register:
string -> (type_fun list -> type_fun) -> (Value.t list -> Value.t) -> unit
...@@ -342,6 +342,26 @@ let eval s = ...@@ -342,6 +342,26 @@ let eval s =
let ppf = Format.formatter_of_buffer b in let ppf = Format.formatter_of_buffer b in
print_exn ppf exn; print_exn ppf exn;
Format.fprintf ppf "@."; 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 ...@@ -6,6 +6,10 @@ open Lambda
let eval_unary_op = ref (fun _ -> assert false) let eval_unary_op = ref (fun _ -> assert false)
let eval_binary_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 *) (* To write tail-recursive map-like iteration *)
let make_accu () = Value.Pair(nil,Absent) let make_accu () = Value.Pair(nil,Absent)
...@@ -127,6 +131,7 @@ let rec eval env = function ...@@ -127,6 +131,7 @@ let rec eval env = function
!eval_binary_op op v1 v2 !eval_binary_op op v1 v2
| Validate (e, kind, schema, name) -> eval_validate env e kind schema name | Validate (e, kind, schema, name) -> eval_validate env e kind schema name
| Ref (e,t) -> eval_ref env e t | 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 = and eval_abstraction env slots iface body =
let local_env = Array.map (eval_var env) slots in let local_env = Array.map (eval_var env) slots in
......
...@@ -4,6 +4,7 @@ open Lambda ...@@ -4,6 +4,7 @@ open Lambda
val eval_unary_op: (int -> (t -> t)) ref val eval_unary_op: (int -> (t -> t)) ref
val eval_binary_op : (int -> (t -> 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 get_global: (Types.CompUnit.t -> int -> t) ref
val set_global: (Types.CompUnit.t -> int -> t -> unit) ref val set_global: (Types.CompUnit.t -> int -> t -> unit) ref
......
...@@ -53,6 +53,7 @@ and texpr' = ...@@ -53,6 +53,7 @@ and texpr' =
| BinaryOp of int * texpr * texpr | BinaryOp of int * texpr * texpr
| Ref of texpr * ttyp | Ref of texpr * ttyp
| External of Types.t * int | External of Types.t * int
| Op of string * texpr list
and abstr = { and abstr = {
fun_name : id option; fun_name : id option;
......
...@@ -857,6 +857,17 @@ let exp loc fv e = ...@@ -857,6 +857,17 @@ let exp loc fv e =
Typed.exp_descr = 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 let rec expr env loc = function
| LocatedExpr (loc,e) -> expr env loc e | LocatedExpr (loc,e) -> expr env loc e
...@@ -865,8 +876,15 @@ let rec expr env loc = function ...@@ -865,8 +876,15 @@ let rec expr env loc = function
exp loc fv (Typed.Forget (e,t)) exp loc fv (Typed.Forget (e,t))
| Var s -> var env loc s | Var s -> var env loc s
| Apply (e1,e2) -> | Apply (e1,e2) ->
let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in (try
exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2)) 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 -> | Abstraction a ->
let iface = List.map (fun (t1,t2) -> (typ env t1, typ env t2)) let iface = List.map (fun (t1,t2) -> (typ env t1, typ env t2))
a.fun_iface in a.fun_iface in
...@@ -1188,6 +1206,12 @@ and type_check' loc env e constr precise = match e with ...@@ -1188,6 +1206,12 @@ and type_check' loc env e constr precise = match e with
| External (t,i) -> | External (t,i) ->
verify loc t constr 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 = and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
let rects = Types.Product.normal ~kind constr in let rects = Types.Product.normal ~kind constr in
if Types.Product.is_empty rects then if Types.Product.is_empty rects then
......
...@@ -79,3 +79,5 @@ val typ_unary_op: (int -> loc -> type_fun -> type_fun) ref ...@@ -79,3 +79,5 @@ val typ_unary_op: (int -> loc -> type_fun -> type_fun) ref
val mk_binary_op: (string -> t -> int) ref val mk_binary_op: (string -> t -> int) ref
val typ_binary_op: (int -> loc -> type_fun -> type_fun -> type_fun) 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