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

[r2004-07-08 13:55:14 by afrisch] Operators

Original author: afrisch
Date: 2004-07-08 13:55:15+00:00
parent b31535c1
......@@ -60,7 +60,7 @@ let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
and compile_aux env tail = function
| Typed.Forget (e,_) -> compile env tail e
| Typed.Var x -> Var (find x env)
| Typed.ExtVar (cu,x) -> Var (find_ext cu x)
| Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
| Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const c
......@@ -86,7 +86,7 @@ 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) ->
| Typed.Op (op,_,args) ->
let rec aux = function
| [arg] -> [ compile env tail arg ]
| arg::l -> (compile env false arg) :: (aux l)
......
......@@ -43,6 +43,54 @@ module Binary = struct
end
let register op typ eval =
Typer.register_op op typ;
let register op arity typ eval =
Typer.register_op op arity typ;
Eval.register_op op eval
let register_unary op typ eval =
register op 1
(function
| [ tf ] ->
typ tf
| _ ->
raise (Typer.Error (
("Built-in operator " ^ op ^ " needs exactly one argument")))
)
(function
| [ v ] -> eval v
| _ -> assert false
)
let register_binary op typ eval =
register op 1
(function
| [ tf1; tf2 ] ->
typ tf1 tf2
| _ ->
raise (Typer.Error (
("Built-in operator " ^ op ^ " needs exactly two arguments")))
)
(function
| [ v1; v2 ] -> eval v1 v2
| _ -> assert false
)
let register_cst op t v =
register op 0
(function
| [ ] -> fun _ _ -> t
| _ -> assert false)
(function
| [ ] -> v
| _ -> assert false
)
let register_fun op dom codom eval =
register_cst op
(Types.arrow (Types.cons dom) (Types.cons codom))
(Value.Abstraction ([(dom,codom)],eval))
let register_op op ?(expect=Types.any) typ eval =
register_unary op
(fun tf _ _ -> let t = tf expect true in typ t)
eval
......@@ -28,5 +28,13 @@ end
val register:
string -> (type_fun list -> type_fun) -> (Value.t list -> Value.t) -> unit
string -> int -> (type_fun list -> type_fun) -> (Value.t list -> Value.t) -> unit
val register_unary:
string -> (type_fun -> type_fun) -> (Value.t -> Value.t) -> unit
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
......@@ -226,23 +226,25 @@ driver/librarian.cmx: types/builtin.cmx compile/compile.cmx \
compile/lambda.cmx parser/location.cmx parser/parser.cmx \
misc/serialize.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
driver/librarian.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmi compile/compile.cmi \
misc/encodings.cmi runtime/eval.cmi runtime/explain.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi misc/ns.cmi parser/parser.cmi \
driver/cduce.cmo: parser/ast.cmo types/builtin.cmi types/builtin_defs.cmi \
compile/compile.cmi misc/encodings.cmi runtime/eval.cmi \
runtime/explain.cmi types/ident.cmo driver/librarian.cmi \
parser/location.cmi misc/ns.cmi compile/operators.cmi parser/parser.cmi \
types/patterns.cmi types/sample.cmi schema/schema_common.cmi \
misc/state.cmi typing/typer.cmi types/types.cmi parser/ulexer.cmi \
runtime/value.cmi driver/cduce.cmi
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx compile/compile.cmx \
misc/encodings.cmx runtime/eval.cmx runtime/explain.cmx types/ident.cmx \
driver/librarian.cmx parser/location.cmx misc/ns.cmx parser/parser.cmx \
driver/cduce.cmx: parser/ast.cmx types/builtin.cmx types/builtin_defs.cmx \
compile/compile.cmx misc/encodings.cmx runtime/eval.cmx \
runtime/explain.cmx types/ident.cmx driver/librarian.cmx \
parser/location.cmx misc/ns.cmx compile/operators.cmx parser/parser.cmx \
types/patterns.cmx types/sample.cmx schema/schema_common.cmx \
misc/state.cmx typing/typer.cmx types/types.cmx parser/ulexer.cmx \
runtime/value.cmx driver/cduce.cmi
ocamliface/mltypes.cmo: driver/config.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi types/types.cmi \
ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: driver/config.cmx types/ident.cmx \
driver/librarian.cmx parser/location.cmx types/types.cmx \
ocamliface/mltypes.cmx: ocamliface/asttypes.cmx driver/config.cmx \
types/ident.cmx driver/librarian.cmx parser/location.cmx types/types.cmx \
ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi driver/config.cmi types/externals.cmi types/ident.cmo \
......@@ -290,11 +292,11 @@ tools/validate.cmo: schema/schema_common.cmi schema/schema_parser.cmi \
schema/schema_types.cmi
tools/validate.cmx: schema/schema_common.cmx schema/schema_parser.cmx \
schema/schema_types.cmx
ocamliface/mltypes.cmo: driver/config.cmi types/ident.cmo \
driver/librarian.cmi parser/location.cmi types/types.cmi \
ocamliface/mltypes.cmo: ocamliface/asttypes.cmo driver/config.cmi \
types/ident.cmo driver/librarian.cmi parser/location.cmi types/types.cmi \
ocamliface/mltypes.cmi
ocamliface/mltypes.cmx: driver/config.cmx types/ident.cmx \
driver/librarian.cmx parser/location.cmx types/types.cmx \
ocamliface/mltypes.cmx: ocamliface/asttypes.cmx driver/config.cmx \
types/ident.cmx driver/librarian.cmx parser/location.cmx types/types.cmx \
ocamliface/mltypes.cmi
ocamliface/mlstub.cmo: types/atoms.cmi types/builtin_defs.cmi \
compile/compile.cmi driver/config.cmi types/externals.cmi types/ident.cmo \
......@@ -368,8 +370,8 @@ types/builtin.cmi: typing/typer.cmi runtime/value.cmi
driver/librarian.cmi: compile/compile.cmi types/ident.cmo typing/typer.cmi \
types/types.cmi runtime/value.cmi
driver/cduce.cmi: misc/encodings.cmi runtime/value.cmi
ocamliface/mltypes.cmi: types/types.cmi
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
query/query.cmi: parser/ast.cmo
ocamliface/mltypes.cmi: types/types.cmi
ocamliface/mltypes.cmi: ocamliface/asttypes.cmo types/types.cmi
schema/schema_types.cmi: misc/encodings.cmi types/intervals.cmi misc/ns.cmi \
runtime/value.cmi
......@@ -346,20 +346,11 @@ let eval s =
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
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"
)
......
......@@ -268,18 +268,7 @@ EXTEND
exp loc (Dot (e, label l))
]
|
[ op = [ IDENT "flatten"
| IDENT "load_xml"
| IDENT "load_file" | IDENT "load_file_utf8"
| IDENT "float_of"
| IDENT "getenv" | IDENT "argv"
| IDENT "load_html"
| IDENT "print_xml" | IDENT "print_xml_utf8"
| IDENT "print"
| IDENT "int_of"
| IDENT "string_of"
| IDENT "atom_of"
| IDENT "raise"
[ 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" ];
......
......@@ -44,13 +44,7 @@ let binary_op_gen name typ run =
(fun s -> ())
let unary_op_gen name typ run =
Unary.register name
(fun _ -> ())
(fun () -> typ)
(fun () -> run)
(fun s () -> ())
(fun s -> ())
let unary_op_gen = register_unary
let binary_op name t1 t2 f run =
......@@ -80,17 +74,10 @@ let binary_op_warning2 name t1 t2 w2 t run =
let unary_op_warning name targ w t run =
unary_op_gen name
(fun loc arg constr precise ->
(fun arg constr precise ->
let res = arg targ true in
if not (Types.subtype res w) then
Typer.warning loc "This operator may fail";
t)
run
let unary_op_cst name targ t run =
unary_op_gen name
(fun loc arg constr precise ->
ignore (arg targ false);
raise (Typer.Warning ("This operator may fail",t));
t)
run
......@@ -164,7 +151,7 @@ binary_op_cst ">"
(* I/O *)
unary_op_cst "string_of"
register_fun "string_of"
any string_latin1
(fun v ->
let b = Buffer.create 16 in
......@@ -174,23 +161,23 @@ unary_op_cst "string_of"
Value.string_latin1 (Buffer.contents b)
);;
unary_op_warning "load_xml"
string string_latin1 any
register_fun "load_xml"
string_latin1 any
(fun v -> Load_xml.load_xml (Value.get_string_latin1 v));;
unary_op_warning "load_html"
string string_latin1 Sequence.any
register_fun "load_html"
string_latin1 Sequence.any
(fun v -> Load_xml.load_html (Value.get_string_latin1 v));;
unary_op_warning "load_file_utf8"
string string_latin1 string
register_fun "load_file_utf8"
string_latin1 string
(eval_load_file ~utf8:true);;
unary_op_warning "load_file" string string_latin1 string_latin1
register_fun "load_file"
string_latin1 string_latin1
(eval_load_file ~utf8:false);;
unary_op_cst "getenv" string_latin1 string_latin1
register_fun "getenv" string_latin1 string_latin1
(fun e ->
Location.protect_op "getenv";
let var = Value.get_string_latin1 e in
......@@ -199,7 +186,7 @@ unary_op_cst "getenv" string_latin1 string_latin1
let argv = ref Value.Absent;;
unary_op_cst "argv" nil (Sequence.star string_latin1)
register_fun "argv" nil (Sequence.star string_latin1)
(fun e ->
Location.protect_op "argv";
!argv);;
......@@ -223,8 +210,8 @@ Unary.register "print_xml_utf8"
Ns.serialize_table
Ns.deserialize_table;;
unary_op_warning "print"
string string_latin1 nil
register_fun "print"
string_latin1 nil
(fun v ->
Location.protect_op "print";
print_string (Value.get_string_latin1 v);
......@@ -232,6 +219,16 @@ unary_op_warning "print"
Value.nil
);;
register_fun "print_utf8"
string nil
(fun v ->
Location.protect_op "print";
let s = Value.cduce2ocaml_string_utf8 v in
print_string (U.get_str s);
flush stdout;
Value.nil
);;
unary_op_warning "int_of"
string intstr int
(fun v ->
......@@ -239,14 +236,14 @@ unary_op_warning "int_of"
try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
with Failure _ -> raise exn_int_of);;
unary_op_cst "atom_of"
register_fun "atom_of"
string atom
(fun v ->
let (s,_) = Value.get_string_utf8 v in (* TODO: check that s is a correct Name wrt XML *)
Value.Atom (Atoms.V.mk Ns.empty s));;
binary_op_warning2 "dump_to_file"
string string string_latin1 nil
string_latin1 string string_latin1 nil
(fun f v ->
Location.protect_op "dump_to_file";
let oc = open_out (Value.get_string_latin1 f) in
......@@ -255,7 +252,7 @@ binary_op_warning2 "dump_to_file"
Value.nil);;
binary_op_cst "dump_to_file_utf8"
string string nil
string_latin1 string nil
(fun f v ->
Location.protect_op "dump_to_file_utf8";
let oc = open_out (Value.get_string_latin1 f) in
......@@ -337,7 +334,6 @@ unary_op_gen "flatten"
Value.flatten;;
unary_op_cst "raise"
any Types.empty
register_fun "raise" any Types.empty
(fun v -> raise (Value.CDuceExn v));;
......@@ -25,7 +25,7 @@ and texpr' =
| Forget of texpr * ttyp
(* CDuce is a Lambda-calculus ... *)
| Var of id
| ExtVar of Types.CompUnit.t * id
| ExtVar of Types.CompUnit.t * id * Types.t
| Apply of texpr * texpr
| Abstraction of abstr
......@@ -53,7 +53,7 @@ and texpr' =
| BinaryOp of int * texpr * texpr
| Ref of texpr * ttyp
| External of Types.t * int
| Op of string * texpr list
| Op of string * int * texpr list
and abstr = {
fun_name : id option;
......
......@@ -25,6 +25,9 @@ exception UnboundId of id * bool
exception UnboundExtId of Types.CompUnit.t * id
exception Error of string
exception Warning of string * Types.t
let raise_loc loc exn = raise (Location (loc,`Full,exn))
let raise_loc_str loc ofs exn = raise (Location (loc,`Char ofs,exn))
let error loc msg = raise_loc loc (Error msg)
......@@ -111,6 +114,9 @@ let enter_value id t env =
let enter_values l env =
{ env with ids =
List.fold_left (fun accu (id,t) -> Env.add id (Val t) accu) env.ids l }
let enter_values_dummy l env =
{ env with ids =
List.fold_left (fun accu id -> Env.add id (Val Types.empty) accu) env.ids l }
let find_value id env =
match Env.find id env.ids with
| Val t -> t
......@@ -858,16 +864,14 @@ let exp loc fv 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 register_op op arity f = Hashtbl.add ops op (arity,f)
let typ_op op = snd (Hashtbl.find ops op)
let is_op env s =
if (Env.mem (ident s) env.ids) then None
else
try let s = U.get_str s in Some (s, fst (Hashtbl.find ops s))
with Not_found -> None
let rec expr env loc = function
| LocatedExpr (loc,e) -> expr env loc e
......@@ -876,36 +880,14 @@ let rec expr env loc = function
exp loc fv (Typed.Forget (e,t))
| Var s -> var env loc s
| 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
let t = List.fold_left
(fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
Types.any iface in
let iface = List.map
(fun (t1,t2) -> (Types.descr t1, Types.descr t2))
iface in
let (fv0,body) = branches env a.fun_body in
let fv = match a.fun_name with
| None -> fv0
| Some f -> Fv.remove f fv0 in
let e = Typed.Abstraction
{ Typed.fun_name = a.fun_name;
Typed.fun_iface = iface;
Typed.fun_body = body;
Typed.fun_typ = t;
Typed.fun_fv = fv
} in
exp loc fv e
let (fv1,e1) = expr env loc e1 and (fv2,e2) = expr env loc e2 in
let fv = Fv.cup fv1 fv2 in
(match e1.Typed.exp_descr with
| Typed.Op (op,arity,args) when arity > 0 ->
exp loc fv (Typed.Op (op,arity - 1,args @ [e2]))
| _ ->
exp loc fv (Typed.Apply (e1,e2)))
| Abstraction a -> abstraction env loc a
| (Integer _ | Char _ | Atom _ | Const _) as c ->
exp loc Fv.empty (Typed.Cst (const env loc c))
| Pair (e1,e2) ->
......@@ -940,7 +922,6 @@ let rec expr env loc = function
| [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
......@@ -973,63 +954,105 @@ let rec expr env loc = function
exp loc fv (Typed.Ref (e,t))
| External (s,args) ->
extern loc env s args
and extern loc env s args =
let args = List.map (typ env) args in
try
let (i,t) = Externals.resolve s args in
exp loc Fv.empty (Typed.External (t,i))
with exn -> raise_loc loc exn
and var env loc s =
match Ns.split_qname s with
| "", id ->
let s = U.get_str id in
if String.contains s '.' then
extern loc env s []
else
let id = ident id in
and extern loc env s args =
let args = List.map (typ env) args in
try
let (i,t) = Externals.resolve s args in
exp loc Fv.empty (Typed.External (t,i))
with exn -> raise_loc loc exn
and var env loc s =
match is_op env s with
| Some (s,arity) -> exp loc Fv.empty (Typed.Op (s, arity, []))
| None ->
match Ns.split_qname s with
| "", id ->
let s = U.get_str id in
if String.contains s '.' then
extern loc env s []
else
let id = ident id in
(try ignore (find_value id env)
with Not_found -> raise_loc loc (UnboundId (id, Env.mem id env.ids)));
exp loc (Fv.singleton id) (Typed.Var id)
| cu, id ->
let cu = find_cu (U.mk cu) env in
exp loc Fv.empty (Typed.ExtVar (cu, ident id))
and branches env b =
let fv = ref Fv.empty in
let accept = ref Types.empty in
let branch (p,e) =
let cur_br = !cur_branch in
cur_branch := [];
let (fv2,e) = expr env noloc e in
let br_loc = merge_loc p.loc e.Typed.exp_loc in
let p = pat env p in
(match Fv.pick (Fv.diff (Patterns.fv p) fv2) with
| None -> ()
| Some x ->
let x = U.to_string (Id.value x) in
warning br_loc
("The capture variable " ^ x ^
" is declared in the pattern but not used in the body of this branch. It might be a misspelled or undeclared type or name (if it isn't, use _ instead)."));
let fv2 = Fv.diff fv2 (Patterns.fv p) in
fv := Fv.cup !fv fv2;
accept := Types.cup !accept (Types.descr (Patterns.accept p));
let br =
{
Typed.br_loc = br_loc;
Typed.br_used = br_loc = noloc;
Typed.br_pat = p;
Typed.br_body = e } in
cur_branch := Branch (br, !cur_branch) :: cur_br;
br in
let b = List.map branch b in
(!fv,
{
Typed.br_typ = Types.empty;
Typed.br_branches = b;
Typed.br_accept = !accept;
Typed.br_compiled = None;
}
)
| cu, id ->
let cu = find_cu (U.mk cu) env in
let id = ident id in
let t =
try find_value_global cu id env
with Not_found ->
raise_loc loc (UnboundExtId (cu,id) ) in
exp loc Fv.empty (Typed.ExtVar (cu, id, t))
and abstraction env loc a =
let iface =
List.map
(fun (t1,t2) -> (typ env t1, typ env t2)) a.fun_iface in
let t =
List.fold_left
(fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
Types.any iface in
let iface =
List.map
(fun (t1,t2) -> (Types.descr t1, Types.descr t2))
iface in
let env' =
match a.fun_name with
| None -> env
| Some f -> enter_values_dummy [ f ] env
in
let (fv0,body) = branches env' a.fun_body in
let fv = match a.fun_name with
| None -> fv0
| Some f -> Fv.remove f fv0 in
let e = Typed.Abstraction
{ Typed.fun_name = a.fun_name;
Typed.fun_iface = iface;
Typed.fun_body = body;
Typed.fun_typ = t;
Typed.fun_fv = fv
} in
exp loc fv e
and branches env b =
let fv = ref Fv.empty in
let accept = ref Types.empty in
let branch (p,e) =
let cur_br = !cur_branch in
cur_branch := [];
let p' = pat env p in
let fvp = Patterns.fv p' in
let env' = enter_values_dummy fvp env in
let (fv2,e) = expr env' noloc e in
let br_loc = merge_loc p.loc e.Typed.exp_loc in
(match Fv.pick (Fv.diff fvp fv2) with
| None -> ()
| Some x ->
let x = U.to_string (Id.value x) in
warning br_loc
("The capture variable " ^ x ^
" is declared in the pattern but not used in the body of this branch. It might be a misspelled or undeclared type or name (if it isn't, use _ instead)."));
let fv2 = Fv.diff fv2 fvp in
fv := Fv.cup !fv fv2;
accept := Types.cup !accept (Types.descr (Patterns.accept p'));
let br =
{
Typed.