Commit 48448987 authored by Pietro Abate's avatar Pietro Abate

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

Original author: afrisch
Date: 2004-07-08 13:55:15+00:00
parent 443ee108
......@@ -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;
......
This diff is collapsed.
......@@ -9,6 +9,9 @@ exception UnboundId of id * bool
exception UnboundExtId of Types.CompUnit.t * id
exception ShouldHave2 of Types.descr * string * Types.descr
exception Error of string
exception Warning of string * Types.t
val warning: loc -> string -> unit
val error: loc -> string -> 'a
......@@ -61,8 +64,7 @@ val type_let_funs: t -> Ast.pexpr list ->
val flatten: loc ->
(Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
val flatten: (Types.t -> bool -> Types.t) -> (Types.t -> bool -> Types.t)
(** {2 Schema stuff} *)
......@@ -80,4 +82,4 @@ 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
val register_op: string -> int -> (type_fun list -> type_fun) -> unit
......@@ -14,7 +14,7 @@ using H = "xhtml"
(** Input types **)
type Site = <site>[ <title>String Page ]
type Page = <page name=String url=?String new=?"">[ <title>String <banner>[InlineText*]? Item* ]
type Page = <page name=Latin1 url=?String new=?"">[ <title>String <banner>[InlineText*]? Item* ]
type External = <external {|href=String; title=String; name=String |}>[]
type Item =
......
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