Skip to content

GitLab

C
cduce
Commit 2fef8c49 authored by Pietro Abate's avatar Pietro Abate
Browse files
Options

[r2004-07-08 15:50:08 by afrisch] Clean up: delete old system for operators 

Original author: afrisch
Date: 2004-07-08 15:51:05+00:00
parent cf300014
Hide whitespace changes
Inline Side-by-side
Showing with 87 additions and 212 deletions
compile/compile.ml
View file @ 2fef8c49
......@@ -79,8 +79,6 @@ and compile_aux env tail = function
| Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
| Typed.Dot (e,l) -> Dot (compile env tail e, l)
| Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
| Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
| Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
| Typed.Ref (e,t) -> Ref (compile env tail e, t)
| Typed.External (t,i) ->
(match env.cu with
......@@ -92,6 +90,8 @@ and compile_aux env tail = function
| arg::l -> (compile env false arg) :: (aux l)
| [] -> [] in
Op (op, aux args)
| Typed.NsTable (ns,e) ->
NsTable (ns, compile_aux env tail e)
and compile_abstr env a =
let fun_env =
......
compile/lambda.ml
View file @ 2fef8c49
......@@ -58,10 +58,9 @@ type expr =
| Validate of expr * schema_component_kind * string * U.t
| RemoveField of expr * label
| Dot of expr * label
| UnaryOp of int * expr
| BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t
| Op of string * expr list
| NsTable of Ns.table * expr
and branches = {
brs: (Patterns.node * expr) list;
......@@ -198,15 +197,6 @@ module Put = struct
bits nbits s 15;
expr s e;
LabelPool.serialize s l
| UnaryOp (op,e) ->
bits nbits s 16;
!unary_op s op;
expr s e
| BinaryOp (op,e1,e2) ->
bits nbits s 17;
!binary_op s op;
expr s e1;
expr s e2
| Ref (e,t) ->
bits nbits s 18;
expr s e;
......@@ -215,6 +205,10 @@ module Put = struct
bits nbits s 19;
string s op;
list expr s args
| NsTable (ns,e) ->
bits nbits s 20;
Ns.serialize_table s ns;
expr s e
and branches s brs =
list (pair Patterns.Node.serialize expr) s brs.brs;
......@@ -319,15 +313,6 @@ module Get = struct
let e = expr s in
let l = LabelPool.deserialize s in
Dot (e,l)
| 16 ->
let op = !unary_op s in
let e = expr s in
UnaryOp (op,e)
| 17 ->
let op = !binary_op s in
let e1 = expr s in
let e2 = expr s in
BinaryOp (op,e1,e2)
| 18 ->
let e = expr s in
let t = Types.Node.deserialize s in
......@@ -336,6 +321,10 @@ module Get = struct
let op = string s in
let args = list expr s in
Op (op,args)
| 20 ->
let ns = Ns.deserialize_table s in
let e = expr s in
NsTable (ns,e)
| _ -> assert false
and branches s =
......
compile/lambda.mli
View file @ 2fef8c49
......@@ -31,10 +31,9 @@ type expr =
| Validate of expr * schema_component_kind * string * U.t
| RemoveField of expr * label
| Dot of expr * label
| UnaryOp of int * expr
| BinaryOp of int * expr * expr
| Ref of expr * Types.Node.t
| Op of string * expr list
| Op of string * expr list (* the string is replaced at runtime by eval function *)
| NsTable of Ns.table * expr
and branches = {
brs: (Patterns.node * expr) list;
......
compile/operators.ml
View file @ 2fef8c49
open Location
type type_fun = Types.t -> bool -> Types.t
module Unary = struct
module Op = struct
type t = (loc -> type_fun -> type_fun) * (Value.t -> Value.t)
end
module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
include Pool.NoHash(Proxy)
let register name make typ run ser deser =
Proxy.register name make
{ Proxy.content = (fun x -> (typ x, run x));
Proxy.serialize = ser;
Proxy.deserialize = deser };;
Typer.mk_unary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_unary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_unary_op := (fun i -> snd (Proxy.content (value i)));;
Lambda.Put.unary_op := serialize;;
Lambda.Get.unary_op := deserialize;;
end
module Binary = struct
module Op = struct
type t = (loc -> type_fun -> type_fun -> type_fun) *
(Value.t -> Value.t -> Value.t)
end
module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
include Pool.NoHash(Proxy)
let register name make typ run ser deser =
Proxy.register name make
{ Proxy.content = (fun x -> (typ x, run x));
Proxy.serialize = ser;
Proxy.deserialize = deser };;
Typer.mk_binary_op := (fun name env -> mk (Proxy.instantiate name env));;
Typer.typ_binary_op := (fun i -> fst (Proxy.content (value i)));;
Eval.eval_binary_op := (fun i -> snd (Proxy.content (value i)));;
Lambda.Put.binary_op := serialize;;
Lambda.Get.binary_op := deserialize;;
end
let register op arity typ eval =
Typer.register_op op arity typ;
Eval.register_op op eval
......@@ -62,7 +20,7 @@ let register_unary op typ eval =
)
let register_binary op typ eval =
register op 1
register op 2
(function
| [ tf1; tf2 ] ->
typ tf1 tf2
......@@ -94,3 +52,8 @@ let register_op op ?(expect=Types.any) typ eval =
register_unary op
(fun tf _ _ -> let t = tf expect true in typ t)
eval
let register_op2 op t1 t2 s eval =
register_binary op
(fun tf1 tf2 _ _ -> ignore (tf1 t1 false); ignore (tf2 t2 false); s)
eval
compile/operators.mli
View file @ 2fef8c49
open Location
type type_fun = Types.t -> bool -> Types.t
module Unary: sig
include Custom.T with type t = int
val register:
string ->
(Typer.t -> 'a) ->
('a -> loc -> type_fun -> type_fun) ->
('a -> Value.t -> Value.t) ->
('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit
end
module Binary: sig
include Custom.T with type t = int
val register:
string ->
(Typer.t -> 'a) ->
('a -> loc -> type_fun -> type_fun -> type_fun) ->
('a -> Value.t -> Value.t -> Value.t) ->
('a Serialize.Put.f) ->
('a Serialize.Get.f) -> unit
end
val register:
string -> int -> (type_fun list -> type_fun) -> (Value.t list -> Value.t) -> unit
......@@ -36,5 +10,9 @@ val register_binary:
string -> (type_fun -> type_fun -> type_fun) -> (Value.t -> Value.t -> Value.t) -> unit
val register_fun: string -> Types.t -> Types.t -> (Value.t -> Value.t) -> unit
val register_op:
string -> ?expect:Types.t -> (Types.t -> Types.t) -> (Value.t -> Value.t) -> unit
val register_op2:
string -> Types.t -> Types.t -> Types.t -> (Value.t -> Value.t -> Value.t) -> unit
driver/cduce.ml
View file @ 2fef8c49
......@@ -343,16 +343,13 @@ let eval s =
print_exn ppf exn;
Format.fprintf ppf "@.";
Value.failwith' (Buffer.contents b)
let () =
let () =
Operators.register_fun "eval_expr" Builtin_defs.string_latin1 Types.any
(fun v ->
match eval (Value.cduce2ocaml_string v) with
| [ (None,v) ] -> v
| _ -> Value.failwith' "eval: the string must evaluate to a single value"
)
(fun v ->
match eval (Value.cduce2ocaml_string v) with
| [ (None,v) ] -> v
| _ -> Value.failwith' "eval: the string must evaluate to a single value"
)
parser/ast.ml
View file @ 2fef8c49
......@@ -70,7 +70,7 @@ and pexpr =
(* Other *)
| NamespaceIn of U.t * Ns.t * pexpr
| Forget of pexpr * ppat
| Op of string * pexpr list
(* | Op of string * pexpr list *)
| Ref of pexpr * ppat
| External of string * ppat list
......
parser/parser.ml
View file @ 2fef8c49
......@@ -88,6 +88,9 @@ let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
let logical_and e1 e2 = if_then_else e1 e2 cst_false
let logical_or e1 e2 = if_then_else e1 cst_true e2
let logical_not e = if_then_else e cst_false cst_true
let apply_op2_noloc op e1 e2 = Apply (Apply (Var (parse_ident op), e1), e2)
let apply_op2 loc op e1 e2 = exp loc (apply_op2_noloc op e1 e2)
EXTEND
......@@ -240,18 +243,17 @@ EXTEND
| "<<" -> "<"
| ">>" -> ">"
| s -> s in
exp loc (Op (op,[e1;e2]))
apply_op2 loc op e1 e2
]
|
[ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr ->
exp loc (Op (op,[e1;e2]))
[ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> apply_op2 loc op e1 e2
| e1 = expr; "||"; e2 = expr -> exp loc (logical_or e1 e2)
| e = expr; "\\"; l = [IDENT | keyword ] ->
exp loc (RemoveField (e, label l))
]
|
[ e1 = expr; op = ["*"]; e2 = expr -> exp loc (Op (op,[e1;e2]))
[ e1 = expr; op = ["*"]; e2 = expr -> apply_op2 loc op e1 e2
| e1 = expr; "&&"; e2 = expr -> exp loc (logical_and e1 e2)
| e = expr; op = "/"; p = pat LEVEL "simple" ->
let tag = mk loc (Internal (Types.atom (Atoms.any))) in
......@@ -267,14 +269,9 @@ EXTEND
[ e = expr; "."; l = [IDENT | keyword ] ->
exp loc (Dot (e, label l))
]
|
[ op = [ IDENT "print_xml" | IDENT "print_xml_utf8"
];
e = expr -> exp loc (Op (op,[e]))
| op = [ IDENT "dump_to_file" | IDENT "dump_to_file_utf8" ];
e1 = expr LEVEL "no_appl"; e2 = expr -> exp loc (Op (op, [e1;e2]))
| e1 = SELF; IDENT "div"; e2 = expr -> exp loc (Op ("/", [e1;e2]))
| e1 = SELF; IDENT "mod"; e2 = expr -> exp loc (Op ("mod", [e1;e2]))
| [
e1 = SELF; IDENT "div"; e2 = expr -> apply_op2 loc "/" e1 e2
| e1 = SELF; IDENT "mod"; e2 = expr -> apply_op2 loc "mod" e1 e2
| e1 = SELF; e2 = expr -> exp loc (Apply (e1,e2))
]
......@@ -291,7 +288,7 @@ EXTEND
match x with
| `String (loc,i,j,s) -> exp loc (String (i,j,s,q))
| `Elems ((loc,_),x) -> exp (loc,loc_end) (Pair(x,q))
| `Explode x -> Op ("@",[x;q])
| `Explode x -> apply_op2_noloc "@" x q
) l e
in
exp loc l
......
query/query.ml
View file @ 2fef8c49
......@@ -128,8 +128,6 @@ let rec string_of_pexpr x =
in match x with
| Integer i -> string_of_int(Intervals.V.get_int(i))
| Atom a -> "`" ^ U.get_str ( a)
| Op(op,[e1;e2]) -> string_of_pexpr e1 ^ " " ^ op^ " " ^ string_of_pexpr e2
| Op(op,[e1]) -> op^ "(" ^ string_of_pexpr e1^") "
| Var( s) -> U.get_str (s)
| Xml(e1,e2) -> " <" ^ string_of_pexpr e1 ^ ">" ^ string_of_pexpr e2
| Pair(e1,e2) -> "(" ^ string_of_pexpr e1 ^ "," ^ string_of_pexpr e2 ^ ")"
......@@ -157,8 +155,6 @@ let rec string_of_pexpr x =
let rec var_of_pexpr x =
match x with
LocatedExpr(_,x) -> var_of_pexpr x
|Op(_,[e1;e2]) -> var_of_pexpr e1 @ var_of_pexpr e2
|Op(_,[e1]) -> var_of_pexpr e1
|Var(s) -> [ident s]
|Pair(e1,e2) -> var_of_pexpr e1 @ var_of_pexpr e2
|Apply(e1,e2) -> var_of_pexpr e2
......
query/query_parse.ml
View file @ 2fef8c49
......@@ -24,6 +24,8 @@ let rec multi_prod loc = function
let if_then_else cond e1 e2 = Match (cond, [pat_true,e1; pat_false,e2])
let op2 op e1 e2 = Apply (Apply (Var (U.mk op), e1), e2)
EXTEND
GLOBAL: expr pat keyword;
......@@ -58,8 +60,7 @@ EXTEND
| e = expr; "//" ; p = pat -> (* projections sur tous les descendants *)
let assign=
exp loc ( Apply (Dot (Var(U.mk"$stack"), U.mk"set"),
(Op("@",
[(Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil));Pair(Var(U.mk"$$$"),cst_nil)]))))
(op2 "@" (Apply(Dot(Var(U.mk"$stack"),U.mk"get"),cst_nil)) (Pair(Var(U.mk"$$$"),cst_nil)))))
in let branche=Pair(Var (Id.value id_dummy),cst_nil)
in let branches= exp loc (Match(assign,[pat_nil,branche]))
in let xt=exp loc (Xtrans (e,[(mk loc(And(mk loc(PatVar(U.mk "$$$")),p))),branches]))
......@@ -100,8 +101,7 @@ EXTEND
fun_body = [
( mk loc(Prod(mk loc(PatVar(s)),mk loc(Regexp(Elem(mk loc(PatVar(h))),
mk loc(PatVar(t)))))),
exp loc (if_then_else (exp loc (Op("=", [(exp loc (Var (s)));(exp loc
(Var (h)))]))) cst_true (exp loc( Apply(exp loc (Var(U.mk "member")),
exp loc (if_then_else (op2 "=" (Var s) (Var h)) cst_true (exp loc( Apply(exp loc (Var(U.mk "member")),
exp loc(Pair(exp loc (Var (s)),exp loc (Var(t)))))))));(any, cst_false)]} in
let e = exp loc (Abstraction abst) in
(( exp loc (Match (e,[p,exp loc(Apply( exp loc
......@@ -130,7 +130,7 @@ EXTEND
fun_iface = [multi_prod loc [mk loc (Regexp(Star(Elem(int)),pat_nil)); int],int];
fun_body = [
(mk loc ( Prod(mk loc(Regexp(Elem(mk loc(PatVar(h))),mk loc(PatVar(t)))),mk loc(PatVar(a)))),
exp loc(if_then_else (exp loc (Op(">",[(exp loc (Var (a)));(exp loc (Var (h)))])))
exp loc(if_then_else (op2 ">" (Var a) (Var h))
(exp loc( Apply(exp loc (Var(U.mk "aux")),
exp loc(Pair(exp loc (Var (t)),exp loc (Var(h)))))))
(exp loc( Apply(exp loc (Var(U.mk "aux")),
......@@ -176,7 +176,7 @@ EXTEND
fun_iface = [multi_prod loc [mk loc (Regexp(Star(Elem(int)),pat_nil)); int],int];
fun_body = [
(mk loc ( Prod(mk loc(Regexp(Elem(mk loc(PatVar(h))),mk loc(PatVar(t)))),mk loc(PatVar(a)))),
exp loc(if_then_else (exp loc (Op("<",[(exp loc (Var (a)));(exp loc (Var (h)))])))
exp loc(if_then_else (op2 "<" (Var a) (Var h))
(exp loc( Apply(exp loc (Var(U.mk "aux")),
exp loc(Pair(exp loc (Var (t)),exp loc (Var(h)))))))
(exp loc( Apply(exp loc (Var(U.mk "aux")),
......@@ -223,7 +223,7 @@ EXTEND
fun_body = [
(mk loc ( Prod(mk loc(Regexp(Elem(mk loc(PatVar(h))),mk loc(PatVar(t)))),mk loc(PatVar(a)))),
(exp loc( Apply(exp loc (Var(U.mk "aux")),
exp loc(Pair(exp loc (Var (t)),exp loc (Op("+",[(exp loc (Var (a)));(exp loc (Var (h)))])))))))
exp loc(Pair(exp loc (Var (t)), op2 "+" (Var a) (Var h))))))
);
(mk loc ( Prod(any,mk loc(PatVar(a)))),exp loc (Var(a))) ]} in
......
runtime/eval.ml
View file @ 2fef8c49
......@@ -3,8 +3,7 @@ open Run_dispatch
open Ident
open Lambda
let eval_unary_op = ref (fun _ -> assert false)
let eval_binary_op = ref (fun _ _ -> assert false)
let ns_table = ref Ns.empty_table
let ops = Hashtbl.create 13
let register_op = Hashtbl.add ops
......@@ -124,14 +123,19 @@ let rec eval env = function
| Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Dot (e, l) -> eval_dot l (eval env e)
| RemoveField (e, l) -> eval_remove_field l (eval env e)
| UnaryOp (op,e) -> !eval_unary_op op (eval env e)
| BinaryOp (op,e1,e2) ->
let v1 = eval env e1 in
let v2 = eval env e2 in
!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)
| Op (op,args) as e ->
let args = List.map (eval env) args in
(* eval_op op args *)
if Obj.tag (Obj.repr op) = Obj.string_tag then
let eval_fun = eval_op op in
Obj.set_field (Obj.repr e) 0 (Obj.repr eval_fun);
eval_fun args
else
(Obj.magic op) args
| NsTable (ns,e) -> ns_table := ns; eval env e
and eval_abstraction env slots iface body =
let local_env = Array.map (eval_var env) slots in
......
runtime/eval.mli
View file @ 2fef8c49
......@@ -2,8 +2,8 @@ open Value
open Ident
open Lambda
val eval_unary_op: (int -> (t -> t)) ref
val eval_binary_op : (int -> (t -> t -> t)) ref
val ns_table: Ns.table ref
val register_op: string -> (t list -> t) -> unit
val get_global: (Types.CompUnit.t -> int -> t) ref
......
types/builtin.ml
View file @ 2fef8c49
......@@ -35,14 +35,7 @@ let env =
open Operators
let binary_op_gen name typ run =
Binary.register name
(fun _ -> ())
(fun () -> typ)
(fun () -> run)
(fun s () -> ())
(fun s -> ())
let binary_op_gen = register_binary
let unary_op_gen = register_unary
......@@ -50,25 +43,20 @@ let unary_op_gen = register_unary
let binary_op name t1 t2 f run =
binary_op_gen
name
(fun loc arg1 arg2 constr precise ->
(fun 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_cst = register_op2
let binary_op_warning2 name t1 t2 w2 t run =
binary_op_gen name
(fun loc arg1 arg2 constr precise ->
(fun 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";
raise (Typer.Warning ("This operator may fail", t));
t)
run
......@@ -192,23 +180,13 @@ register_fun "argv" nil (Sequence.star string_latin1)
!argv);;
Unary.register "print_xml"
(fun tenv -> Typer.get_ns_table tenv)
(fun ns_table loc arg constr precise ->
ignore (arg Types.any false);
string_latin1)
(Print_xml.print_xml ~utf8:false)
Ns.serialize_table
Ns.deserialize_table;;
Unary.register "print_xml_utf8"
(fun tenv -> Typer.get_ns_table tenv)
(fun ns_table loc arg constr precise ->
ignore (arg Types.any false);
string)
(Print_xml.print_xml ~utf8:true)
Ns.serialize_table
Ns.deserialize_table;;
register_fun "print_xml"
Types.any string_latin1
(fun v -> Print_xml.print_xml ~utf8:false !Eval.ns_table v);;
register_fun "print_xml_utf8"
Types.any string
(fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
register_fun "print"
string_latin1 nil
......@@ -264,7 +242,7 @@ binary_op_cst "dump_to_file_utf8"
(* Integer operators *)
binary_op_gen "+"
(fun loc arg1 arg2 constr precise ->
(fun arg1 arg2 constr precise ->
let t1 = arg1 (Types.cup int Types.Record.any) true in
if Types.subtype t1 int
then (
......@@ -277,7 +255,7 @@ binary_op_gen "+"
let t2 = arg2 Types.Record.any true in
Types.Record.merge t1 t2
)
else Typer.error loc "The first argument mixes integers and records")
else raise (Typer.Error "The first argument mixes integers and records"))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
| (Value.Record r1, Value.Record r2) -> Value.Record (LabelMap.merge (fun x y -> y) r1 r2)
......@@ -312,7 +290,7 @@ binary_op_cst "mod"
binary_op_gen "@"
(fun loc arg1 arg2 constr precise ->
(fun arg1 arg2 constr precise ->
let constr' = Sequence.star
(Sequence.approx (Types.cap Sequence.any constr)) in
let exact = Types.subtype constr' constr in
......@@ -336,4 +314,3 @@ unary_op_gen "flatten"
register_fun "raise" any Types.empty
(fun v -> raise (Value.CDuceExn v));;
typing/typed.ml
View file @ 2fef8c49
......@@ -49,11 +49,10 @@ and texpr' =
(* Exception *)
| Try of texpr * branches
| UnaryOp of int * texpr
| BinaryOp of int * texpr * texpr
| Ref of texpr * ttyp
| External of Types.t * int
| Op of string * int * texpr list
| NsTable of Ns.table * texpr'
and abstr = {
fun_name : id option;
......
typing/typer.ml
View file @ 2fef8c49
......@@ -843,12 +843,6 @@ let pat env p =
type type_fun = Types.t -> bool -> Types.t
let typ_cst = ref (fun _ -> assert false)
let mk_unary_op = ref (fun _ _ -> assert false)
let typ_unary_op = ref (fun _ _ _ -> assert false)
let mk_binary_op = ref (fun _ _ -> assert false)
let typ_binary_op = ref (fun _ _ _ _ -> assert false)
module Fv = IdSet
......@@ -913,15 +907,6 @@ let rec expr env loc = function
| String (i,j,s,e) ->
let (fv,e) = expr env loc e in
exp loc fv (Typed.String (i,j,s,e))
| Op (op,le) ->
let (fvs,ltes) = List.split (List.map (expr env loc) le) in
let fv = List.fold_left Fv.cup Fv.empty fvs in
(try
(match ltes with
| [e] -> exp loc fv (Typed.UnaryOp (!mk_unary_op op env, e))
| [e1;e2] -> exp loc fv (Typed.BinaryOp (!mk_binary_op op env, e1,e2))
| _ -> assert false)
with Not_found -> assert false)
| Match (e,b) ->
let (fv1,e) = expr env loc e
and (fv2,b) = branches env b in
......@@ -964,7 +949,11 @@ and extern loc env s args =
and var env loc s =
match is_op env s with
| Some (s,arity) -> exp loc Fv.empty (Typed.Op (s, arity, []))
| Some (s,arity) ->
let need_ns = s = "print_xml" || s = "print_xml_utf8" in
let e = Typed.Op (s, arity, []) in
let e = if need_ns then Typed.NsTable (env.ns,e) else e in
exp loc Fv.empty e
| None ->
match Ns.split_qname s with
| "", id ->
......@@ -1175,15 +1164,6 @@ and type_check' loc env e constr precise = match e with
in
verify loc res constr
| UnaryOp (o,e) ->
let t = !typ_unary_op o loc (type_check env e) constr precise in
verify loc t constr
| BinaryOp (o,e1,e2) ->
let t = !typ_binary_op o loc
(type_check env e1) (type_check env e2) constr precise in
verify loc t constr
| Var s ->
verify loc (find_value s env) constr
......@@ -1235,7 +1215,9 @@ and type_check' loc env e constr precise = match e with
let args = List.map (type_check env) args in
let t = localize loc (typ_op op args constr) precise in
verify loc t constr
| NsTable (ns,e) ->
type_check' loc env e constr precise
and type_check_pair ?(kind=`Normal) loc env e1 e2 constr precise =
let rects = Types.Product.normal ~kind constr in
......
typing/typer.mli
View file @ 2fef8c49
......@@ -76,10 +76,4 @@ val get_schema_names: t -> U.t list (** registered schema names *)
type type_fun = Types.t -> bool -> Types.t
val mk_unary_op: (string -> t -> int) ref
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 -> int -> (type_fun list -> type_fun) -> unit