Commit 24523591 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Add a println builtin function that prints a newline.

parent d9edaee1
...@@ -5,11 +5,11 @@ let eval = ref (fun ppf err s -> assert false) ...@@ -5,11 +5,11 @@ let eval = ref (fun ppf err s -> assert false)
(* Types *) (* Types *)
let stringn = Types.cons string let stringn = Types.cons string
let namespaces = let namespaces =
Sequence.star (Types.times stringn stringn) Sequence.star (Types.times stringn stringn)
let types = let types =
[ [
"Empty", Types.empty; "Empty", Types.empty;
"Any", any; "Any", any;
"Int", int; "Int", int;
...@@ -30,7 +30,7 @@ let types = ...@@ -30,7 +30,7 @@ let types =
let env = let env =
List.fold_left List.fold_left
(fun accu (n,t) -> (fun accu (n,t) ->
let n = (Ns.empty, Ident.U.mk n) in let n = (Ns.empty, Ident.U.mk n) in
Types.Print.register_global ("",n,[||]) t; Types.Print.register_global ("",n,[||]) t;
Typer.enter_type (Ident.ident n) t accu Typer.enter_type (Ident.ident n) t accu
...@@ -60,7 +60,7 @@ let binary_op_cst = register_op2 ...@@ -60,7 +60,7 @@ let binary_op_cst = register_op2
let binary_op_warning2 name t1 t2 w2 t run = let binary_op_warning2 name t1 t2 w2 t run =
binary_op_gen name binary_op_gen name
(fun arg1 arg2 constr precise -> (fun arg1 arg2 constr precise ->
ignore (arg1 t1 false); ignore (arg1 t1 false);
let r = arg2 t2 true in let r = arg2 t2 true in
if not (Types.subtype r w2) then if not (Types.subtype r w2) then
raise (Typer.Warning ("This operator may fail", t)); raise (Typer.Warning ("This operator may fail", t));
...@@ -127,9 +127,9 @@ let eval_load_file ~utf8 e = ...@@ -127,9 +127,9 @@ let eval_load_file ~utf8 e =
Cduce_loc.protect_op "load_file"; Cduce_loc.protect_op "load_file";
let fn = Value.get_string_latin1 e in let fn = Value.get_string_latin1 e in
let s = Url.load_url fn in let s = Url.load_url fn in
if utf8 then if utf8 then
match U.mk_check s with match U.mk_check s with
| Some s -> Value.string_utf8 s | Some s -> Value.string_utf8 s
| None -> raise (Lazy.force exn_load_file_utf8) | None -> raise (Lazy.force exn_load_file_utf8)
else Value.string_latin1 s else Value.string_latin1 s
...@@ -138,30 +138,30 @@ let () = ();; ...@@ -138,30 +138,30 @@ let () = ();;
(* Comparison operators *) (* Comparison operators *)
binary_op "=" binary_op "="
any any any any
(fun t1 t2 -> (fun t1 t2 ->
if Types.is_empty (Types.cap t1 t2) then false_type if Types.is_empty (Types.cap t1 t2) then false_type
else bool) else bool)
(fun v1 v2 -> (fun v1 v2 ->
Value.vbool (Value.compare v1 v2 == 0));; Value.vbool (Value.compare v1 v2 == 0));;
binary_op_cst "<=" binary_op_cst "<="
any any bool any any bool
(fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));; (fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));;
binary_op_cst "<" binary_op_cst "<"
any any bool any any bool
(fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));; (fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));;
binary_op_cst ">=" binary_op_cst ">="
any any bool any any bool
(fun v1 v2 -> (fun v1 v2 ->
Value.vbool (Value.compare v1 v2 >= 0));; Value.vbool (Value.compare v1 v2 >= 0));;
binary_op_cst ">" binary_op_cst ">"
any any bool any any bool
(fun v1 v2 -> (fun v1 v2 ->
Value.vbool (Value.compare v1 v2 > 0));; Value.vbool (Value.compare v1 v2 > 0));;
(* I/O *) (* I/O *)
...@@ -181,10 +181,10 @@ register_fun "int_of_char" ...@@ -181,10 +181,10 @@ register_fun "int_of_char"
Value.Integer (Intervals.V.from_int (Chars.V.to_int x)) Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
| _ -> assert false);; | _ -> assert false);;
register_fun "string_of" register_fun "string_of"
any string_latin1 any string_latin1
(fun v -> (fun v ->
let b = Buffer.create 16 in let b = Buffer.create 16 in
let ppf = Format.formatter_of_buffer b in let ppf = Format.formatter_of_buffer b in
Value.print ppf v; Value.print ppf v;
...@@ -195,7 +195,7 @@ register_fun "string_of" ...@@ -195,7 +195,7 @@ register_fun "string_of"
register_fun "load_xml" register_fun "load_xml"
string_latin1 any_xml string_latin1 any_xml
(fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml (Value.get_string_latin1 v));; (fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml (Value.get_string_latin1 v));;
register_fun "!load_xml" register_fun "!load_xml"
string_latin1 any_xml string_latin1 any_xml
(fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml ~ns:true (fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml ~ns:true
...@@ -206,12 +206,12 @@ register_fun "load_html" ...@@ -206,12 +206,12 @@ register_fun "load_html"
string_latin1 Sequence.any string_latin1 Sequence.any
(fun v -> Cduce_loc.protect_op "load_html"; Load_xml.load_html (Value.get_string_latin1 v));; (fun v -> Cduce_loc.protect_op "load_html"; Load_xml.load_html (Value.get_string_latin1 v));;
register_fun "load_file_utf8" register_fun "load_file_utf8"
string_latin1 string string_latin1 string
(eval_load_file ~utf8:true);; (eval_load_file ~utf8:true);;
register_fun "load_file" register_fun "load_file"
string_latin1 string_latin1 string_latin1 string_latin1
(eval_load_file ~utf8:false);; (eval_load_file ~utf8:false);;
...@@ -219,24 +219,24 @@ let argv = ref Value.Absent;; ...@@ -219,24 +219,24 @@ let argv = ref Value.Absent;;
register_fun "print_xml" register_fun "print_xml"
Types.any string_latin1 Types.any string_latin1
(fun v -> Print_xml.print_xml ~utf8:false !Eval.ns_table v);; (fun v -> Print_xml.print_xml ~utf8:false !Eval.ns_table v);;
register_fun "print_xml_utf8" register_fun "print_xml_utf8"
Types.any string Types.any string
(fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);; (fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
register_fun "dump_xml" register_fun "dump_xml"
Types.any nil Types.any nil
(fun v -> (fun v ->
Cduce_loc.protect_op "print"; Cduce_loc.protect_op "print";
Print_xml.dump_xml ~utf8:false !Eval.ns_table v);; Print_xml.dump_xml ~utf8:false !Eval.ns_table v);;
register_fun "dump_xml_utf8" register_fun "dump_xml_utf8"
Types.any nil Types.any nil
(fun v -> (fun v ->
Cduce_loc.protect_op "print"; Cduce_loc.protect_op "print";
Print_xml.dump_xml ~utf8:true !Eval.ns_table v);; Print_xml.dump_xml ~utf8:true !Eval.ns_table v);;
...@@ -250,6 +250,15 @@ register_fun "print" ...@@ -250,6 +250,15 @@ register_fun "print"
Value.nil Value.nil
);; );;
register_fun "println"
string_latin1 nil
(fun v ->
Cduce_loc.protect_op "println";
print_endline (Value.get_string_latin1 v);
flush stdout;
Value.nil
);;
register_fun "print_utf8" register_fun "print_utf8"
string nil string nil
(fun v -> (fun v ->
...@@ -271,12 +280,12 @@ unary_op_warning "int_of" ...@@ -271,12 +280,12 @@ unary_op_warning "int_of"
modifier = 'b' || modifier = 'b' ||
modifier = 'B' || modifier = 'B' ||
modifier = 'o' || modifier = 'o' ||
modifier = 'O') modifier = 'O')
then then
Value.Integer (Intervals.V.from_int (int_of_string(str))) Value.Integer (Intervals.V.from_int (int_of_string(str)))
else else
Value.Integer (Intervals.V.mk (str)) Value.Integer (Intervals.V.mk (str))
with _ -> with _ ->
(try Value.Integer (Intervals.V.mk (str)) (try Value.Integer (Intervals.V.mk (str))
with Failure _ -> raise (Lazy.force exn_int_of)));; with Failure _ -> raise (Lazy.force exn_int_of)));;
...@@ -290,13 +299,13 @@ unary_op_warning "int_of" ...@@ -290,13 +299,13 @@ unary_op_warning "int_of"
register_fun "atom_of" register_fun "atom_of"
string atom string atom
(fun v -> (fun v ->
let (s,_) = Value.get_string_utf8 v in let (s,_) = Value.get_string_utf8 v in
Value.Atom (Atoms.V.mk Ns.empty s));; Value.Atom (Atoms.V.mk Ns.empty s));;
*) *)
register_fun "split_atom" register_fun "split_atom"
atom (Types.times stringn stringn) atom (Types.times stringn stringn)
(function (function
| Value.Atom q -> | Value.Atom q ->
let (ns,l) = Atoms.V.value q in let (ns,l) = Atoms.V.value q in
Value.Pair( Value.Pair(
...@@ -314,7 +323,7 @@ register_fun "make_atom" ...@@ -314,7 +323,7 @@ register_fun "make_atom"
Value.Atom (Atoms.V.mk (Ns.Uri.mk ns, l)));; Value.Atom (Atoms.V.mk (Ns.Uri.mk ns, l)));;
binary_op_warning2 "dump_to_file" binary_op_warning2 "dump_to_file"
string_latin1 string string_latin1 nil string_latin1 string string_latin1 nil
...@@ -325,7 +334,7 @@ binary_op_warning2 "dump_to_file" ...@@ -325,7 +334,7 @@ binary_op_warning2 "dump_to_file"
close_out oc; close_out oc;
Value.nil Value.nil
with exn -> raise_gen exn);; with exn -> raise_gen exn);;
binary_op_cst "dump_to_file_utf8" binary_op_cst "dump_to_file_utf8"
string_latin1 string nil string_latin1 string nil
(fun f v -> try (fun f v -> try
...@@ -348,24 +357,24 @@ let intop f x y = ...@@ -348,24 +357,24 @@ let intop f x y =
binary_op_gen "+" binary_op_gen "+"
(fun arg1 arg2 constr precise -> (fun arg1 arg2 constr precise ->
let t1 = arg1 (Types.cup int Types.Record.any) true in let t1 = arg1 (Types.cup int Types.Record.any) true in
if Types.subtype t1 int if Types.subtype t1 int
then ( then (
let t2 = arg2 int true in let t2 = arg2 int true in
Types.interval Types.interval
(intop Intervals.add (Types.Int.get t1) (Types.Int.get t2)) (intop Intervals.add (Types.Int.get t1) (Types.Int.get t2))
) )
else if Types.subtype t1 Types.Record.any else if Types.subtype t1 Types.Record.any
then ( then (
let t2 = arg2 Types.Record.any true in let t2 = arg2 Types.Record.any true in
Types.Record.merge t1 t2 Types.Record.merge t1 t2
) )
else raise (Typer.Error "The first argument mixes integers and records")) else raise (Typer.Error "The first argument mixes integers and records"))
Value.add;; Value.add;;
binary_op "-" binary_op "-"
int int int int
(fun t1 t2 -> (fun t1 t2 ->
Types.interval Types.interval
(intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2))) (intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with (fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y) | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
...@@ -374,7 +383,7 @@ binary_op "-" ...@@ -374,7 +383,7 @@ binary_op "-"
binary_op "*" binary_op "*"
int int int int
(fun t1 t2 -> (fun t1 t2 ->
Types.interval Types.interval
(intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2))) (intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with (fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y) | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
...@@ -413,17 +422,17 @@ binary_op_gen "@" ...@@ -413,17 +422,17 @@ binary_op_gen "@"
unary_op_gen "flatten" unary_op_gen "flatten"
Typer.flatten Typer.flatten
Value.flatten;; Value.flatten;;
register_fun "raise" any Types.empty register_fun "raise" any Types.empty
(fun v -> raise (Value.CDuceExn v));; (fun v -> raise (Value.CDuceExn v));;
register_fun "namespaces" any_xml register_fun "namespaces" any_xml
namespaces namespaces
(function (function
Value.XmlNs (_,_,_,ns,s) -> Value.XmlNs (_,_,_,ns,s) ->
Value.sequence_rev Value.sequence_rev
(List.map (List.map
(fun (pr,ns) -> (fun (pr,ns) ->
Value.Pair (Value.string_utf8 pr, Value.Pair (Value.string_utf8 pr,
Value.string_utf8 (Ns.Uri.value ns), s)) Value.string_utf8 (Ns.Uri.value ns), s))
......
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