Commit 8b575b91 authored by Pietro Abate's avatar Pietro Abate

[r2003-05-25 10:34:50 by cvscast] review Builtin

Original author: cvscast
Date: 2003-05-25 10:34:50+00:00
parent 25a01d55
......@@ -47,7 +47,7 @@ OBJECTS = \
\
types/sortedList.cmo types/boolean.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
types/types.cmo types/patterns.cmo types/sequence.cmo types/builtin.cmo \
types/types.cmo types/patterns.cmo types/sequence.cmo \
types/sample.cmo \
\
parser/location.cmo parser/wlexer.cmo parser/ast.cmo parser/parser.cmo \
......@@ -57,7 +57,7 @@ OBJECTS = \
runtime/value.cmo runtime/load_xml.cmo runtime/run_dispatch.cmo \
runtime/print_xml.cmo runtime/eval.cmo \
\
driver/cduce.cmo
types/builtin.cmo driver/cduce.cmo
CDUCE = $(OBJECTS) driver/run.cmo
WEBIFACE = $(OBJECTS) driver/examples.cmo driver/webiface.cmo
......
......@@ -12,38 +12,42 @@ parser/ast.cmo: types/ident.cmo parser/location.cmi types/types.cmi
parser/ast.cmx: types/ident.cmx parser/location.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/builtin.cmo \
types/chars.cmi misc/encodings.cmi types/ident.cmo types/intervals.cmi \
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi \
parser/location.cmi types/sequence.cmi types/types.cmi parser/wlexer.cmo \
parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/builtin.cmx \
types/chars.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx \
parser/location.cmx types/sequence.cmx types/types.cmx parser/wlexer.cmx \
parser/parser.cmi
parser/wlexer.cmo: misc/encodings.cmi parser/location.cmi
parser/wlexer.cmx: misc/encodings.cmx parser/location.cmx
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
types/types.cmi
types/types.cmi runtime/value.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/builtin.cmo \
types/ident.cmo types/intervals.cmi parser/location.cmi \
types/patterns.cmi types/sequence.cmi misc/state.cmi typing/typed.cmo \
types/types.cmi typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/builtin.cmx \
types/ident.cmx types/intervals.cmx parser/location.cmx \
types/patterns.cmx types/sequence.cmx misc/state.cmx typing/typed.cmx \
types/types.cmx typing/typer.cmi
types/types.cmx runtime/value.cmx
typing/typer.cmo: parser/ast.cmo types/atoms.cmi types/ident.cmo \
types/intervals.cmi parser/location.cmi types/patterns.cmi \
types/sequence.cmi misc/state.cmi typing/typed.cmo types/types.cmi \
typing/typer.cmi
typing/typer.cmx: parser/ast.cmx types/atoms.cmx types/ident.cmx \
types/intervals.cmx parser/location.cmx types/patterns.cmx \
types/sequence.cmx misc/state.cmx typing/typed.cmx types/types.cmx \
typing/typer.cmi
types/atoms.cmo: misc/encodings.cmi misc/pool.cmi types/sortedList.cmi \
types/atoms.cmi
types/atoms.cmx: misc/encodings.cmx misc/pool.cmx types/sortedList.cmx \
types/atoms.cmi
types/boolean.cmo: types/sortedList.cmi types/boolean.cmi
types/boolean.cmx: types/sortedList.cmx types/boolean.cmi
types/builtin.cmo: types/atoms.cmi types/chars.cmi types/sequence.cmi \
types/types.cmi
types/builtin.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
types/types.cmx
types/builtin.cmo: types/atoms.cmi types/chars.cmi runtime/eval.cmi \
types/ident.cmo runtime/load_xml.cmi parser/location.cmi \
runtime/print_xml.cmo types/sequence.cmi typing/typer.cmi types/types.cmi \
runtime/value.cmi
types/builtin.cmx: types/atoms.cmx types/chars.cmx runtime/eval.cmx \
types/ident.cmx runtime/load_xml.cmx parser/location.cmx \
runtime/print_xml.cmx types/sequence.cmx typing/typer.cmx types/types.cmx \
runtime/value.cmx
types/chars.cmo: types/chars.cmi
types/chars.cmx: types/chars.cmi
types/ident.cmo: misc/encodings.cmi misc/pool.cmi types/sortedList.cmi
......@@ -90,12 +94,12 @@ runtime/run_dispatch.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
runtime/run_dispatch.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/patterns.cmx types/types.cmx runtime/value.cmx \
runtime/run_dispatch.cmi
runtime/value.cmo: types/atoms.cmi types/builtin.cmo types/chars.cmi \
misc/encodings.cmi types/ident.cmo types/intervals.cmi types/sequence.cmi \
types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/builtin.cmx types/chars.cmx \
misc/encodings.cmx types/ident.cmx types/intervals.cmx types/sequence.cmx \
types/types.cmx runtime/value.cmi
runtime/value.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx types/sequence.cmx types/types.cmx \
runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
types/ident.cmo parser/location.cmi parser/parser.cmi types/patterns.cmi \
types/sample.cmi misc/state.cmi typing/typed.cmo typing/typer.cmi \
......
......@@ -5,11 +5,11 @@ let version = "0.0.9 (alpha)"
let quiet = ref false
let typing_env = State.ref "Cduce.typing_env" Typer.Env.empty
let typing_env = State.ref "Cduce.typing_env" Env.empty
let enter_global_value x v t =
Eval.enter_global x v;
typing_env := Typer.Env.add x t !typing_env
typing_env := Env.add x t !typing_env
let rec is_abstraction = function
| Ast.Abstraction _ -> true
......@@ -27,9 +27,9 @@ let dump_env ppf =
Format.fprintf ppf "Global types:";
Typer.dump_global_types ppf;
Format.fprintf ppf ".@\n";
Eval.Env.iter
Env.iter
(fun x v ->
let t = Typer.Env.find x !typing_env in
let t = Env.find x !typing_env in
Format.fprintf ppf "@[|- %a : %a@ => %a@]@\n"
U.print (Id.value x)
print_norm t
......@@ -63,7 +63,9 @@ let rec print_exn ppf = function
print_norm t1
msg
print_norm t2
| Typer.Constraint (s,t,msg) ->
| Typer.Error s ->
Format.fprintf ppf "%s@\n" s
| Typer.Constraint (s,t) ->
Format.fprintf ppf "This expression should have type:@\n%a@\n"
print_norm t;
Format.fprintf ppf "but its inferred type is:@\n%a@\n"
......@@ -72,7 +74,7 @@ let rec print_exn ppf = function
Location.protect ppf
(fun ppf ->
Sample.print ppf (Sample.get (Types.diff s t)));
Format.fprintf ppf "@\n%s@\n" msg
Format.fprintf ppf "@\n"
| Typer.NonExhaustive t ->
Format.fprintf ppf "This pattern matching is not exhaustive@\n";
Format.fprintf ppf "Residual type:@\n%a@\n"
......@@ -131,18 +133,12 @@ let debug ppf = function
let mk_builtin () =
let bi = List.map (fun (n,t) -> [n, mknoloc (Ast.Internal t)])
Builtin.types in
List.iter Typer.register_global_types bi
let () = mk_builtin ()
let run ppf ppf_err input =
let insert_type_bindings =
List.iter (fun (x,t) ->
typing_env := Typer.Env.add x t !typing_env;
typing_env := Env.add x t !typing_env;
if not !quiet then
Format.fprintf ppf "|- %a : %a@\n@." U.print (Id.value x) print_norm t)
in
......@@ -153,7 +149,7 @@ let run ppf ppf_err input =
in
let eval_decl decl =
let bindings = Eval.eval_let_decl Eval.Env.empty decl in
let bindings = Eval.eval_let_decl Env.empty decl in
List.iter
(fun (x,v) ->
Eval.enter_global x v;
......@@ -171,7 +167,7 @@ let run ppf ppf_err input =
Location.dump_loc ppf e.Typed.exp_loc;
if not !quiet then
Format.fprintf ppf "|- %a@\n@." print_norm t;
let v = Eval.eval Eval.Env.empty e in
let v = Eval.eval Env.empty e in
if not !quiet then
Format.fprintf ppf "=> @[%a@]@\n@." print_value v
| Ast.LetDecl (p,e) when is_abstraction e -> ()
......
......@@ -26,6 +26,7 @@ and pexpr =
| LocatedExpr of loc * pexpr
| Forget of pexpr * ppat
| Op of string * pexpr list
(* CDuce is a Lambda-calculus ... *)
| Var of id
......@@ -39,9 +40,9 @@ and pexpr =
| RecordLitt of pexpr label_map
(* Data destructors *)
| Op of string * pexpr list
| Match of pexpr * branches
| Map of bool * pexpr * branches
| Map of pexpr * branches
| Transform of pexpr * branches
| Xtrans of pexpr * branches
| Dot of pexpr* label
| RemoveField of pexpr * label
......
......@@ -8,6 +8,10 @@ let () = Grammar.error_verbose := true
let gram = Grammar.gcreate (Wlexer.lexer Wlexer.token Wlexer.latin1_engine)
let true_atom = Atoms.mk_ascii "true"
let false_atom = Atoms.mk_ascii "false"
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
let parse_ident = Encodings.Utf8.mk_latin1
......@@ -145,20 +149,23 @@ EXTEND
expr: [
"top" RIGHTA
[ "match"; e = SELF; "with"; b = branches -> exp loc (Match (e,b))
[ "match"; e = SELF; "with"; b = branches ->
exp loc (Match (e,b))
| "try"; e = SELF; "with"; b = branches ->
let default =
mknoloc (Capture id_dummy),
Op ("raise",[Var id_dummy]) in
Op ("raise", [Var id_dummy]) in
exp loc (Try (e,b@[default]))
| "map"; e = SELF; "with"; b = branches -> exp loc (Map (false,e,b))
| "xtransform"; e = SELF; "with"; b = branches -> exp loc (Xtrans (e,b))
| "map"; e = SELF; "with"; b = branches ->
exp loc (Map (e,b))
| "xtransform"; e = SELF; "with"; b = branches ->
exp loc (Xtrans (e,b))
| "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
let p1 = mk loc (Internal (Builtin.true_type))
and p2 = mk loc (Internal (Builtin.false_type)) in
let p1 = mk loc (Internal true_type)
and p2 = mk loc (Internal false_type) in
exp loc (Match (e, [p1,e1; p2,e2]))
| "transform"; e = SELF; "with"; b = branches ->
exp loc (Op ("flatten", [Map (true,e,b)]))
exp loc (Transform (e,b))
| "fun"; (f,a,b) = fun_decl ->
exp loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
| (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
......@@ -194,7 +201,7 @@ EXTEND
let ct = mk loc (Regexp (re,any)) in
let p = mk loc (XmlT (tag, multi_prod loc [att;ct])) in
let b = (p, Var id_dummy) in
exp loc (Op ("flatten", [Map (false,e,[b])]))
exp loc (Transform (e,[b]))
]
|
[ e = expr; "."; l = [LIDENT | UIDENT | keyword ] ->
......@@ -208,10 +215,10 @@ EXTEND
| LIDENT "load_html"
| LIDENT "print_xml" | LIDENT "print_xml_utf8"
| LIDENT "print"
| LIDENT "raise"
| LIDENT "int_of"
| LIDENT "string_of"
| LIDENT "atom_of"
| LIDENT "raise"
];
e = expr -> exp loc (Op (op,[e]))
| op = [ LIDENT "dump_to_file" | LIDENT "dump_to_file_utf8" ];
......
......@@ -3,7 +3,6 @@ open Run_dispatch
open Ident
exception MultipleDeclaration of id
module Env = Map.Make (Ident.Id)
type env = t Env.t
let global_env = State.ref "Eval.global_env" Env.empty
......@@ -14,9 +13,6 @@ let enter_global x v =
global_env := Env.add x v !global_env
let exn_int_of = CDuceExn (Pair (
Atom (Atoms.mk_ascii "Invalid_argument"),
string_latin1 "int_of"))
let exn_load_file_utf8 = CDuceExn (Pair (
......@@ -31,7 +27,7 @@ let rec eval env e0 =
| Typed.Forget (e,_) -> eval env e
| Typed.Var s ->
(try Env.find s env
with Not_found -> Env.find s !global_env)
with Not_found -> Env.find s !global_env)
| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
| Typed.Abstraction a ->
let env =
......@@ -57,51 +53,22 @@ let rec eval env e0 =
| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
Xml (eval env e1, eval env e2, eval env e3)
| Typed.Xml (_,_) -> assert false
| Typed.Cst c -> const c
| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
| Typed.Map (false,arg,brs) -> eval_map env brs (eval env arg)
| Typed.Map (true,_,_) -> assert false
| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
| Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
| Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
| Typed.Try (arg,brs) ->
(try eval env arg with CDuceExn v -> eval_branches env brs v)
| Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (true,arg,brs)}]) ->
eval_transform env brs (eval env arg)
| Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
| Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
| Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
| Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
| Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
| Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
| Typed.Op ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
| Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
| Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
| Typed.Op ("load_file", [e]) -> eval_load_file ~utf8:false (eval env e)
| Typed.Op ("load_file_utf8", [e]) -> eval_load_file ~utf8:true (eval env e)
| Typed.Op ("print_xml", [e]) -> Print_xml.print_xml ~utf8:false (eval env e)
| Typed.Op ("print_xml_utf8", [e]) -> Print_xml.print_xml ~utf8:true (eval env e)
| Typed.Op ("print", [e]) -> eval_print (eval env e)
| Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
| Typed.Op ("atom_of", [e]) -> eval_atom_of (eval env e)
| Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
| Typed.Op ("dump_to_file", [e1; e2]) ->
eval_dump_to_file (eval env e1) (eval env e2)
| Typed.Op ("dump_to_file_utf8", [e1; e2]) ->
eval_dump_to_file_utf8 (eval env e1) (eval env e2)
| Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
| Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
| Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
| Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
| Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
| Typed.Try (arg,brs) -> (try eval env arg with CDuceExn v -> eval_branches env brs v)
| Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
| _ -> assert false
| Typed.UnaryOp (o,e) -> o.Typed.un_op_eval (eval env e)
| Typed.BinaryOp (o,e1,e2) -> o.Typed.bin_op_eval (eval env e1) (eval env e2)
and eval_apply f arg = match f with
| Abstraction (_,clos) -> clos arg
| _ -> eval_concat f arg
| _ -> assert false
and eval_branches' env_ref brs arg =
eval_branches !env_ref brs arg
......@@ -132,14 +99,11 @@ and eval_map env brs = function
eval_map env brs (normalize v)
| q -> q
and eval_flatten = function
| Pair (x,y) -> eval_concat x (eval_flatten y)
| q -> q
and eval_transform env brs = function
| Pair (x,y) ->
let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
eval_concat x (eval_transform env brs y)
concat x (eval_transform env brs y)
| String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
if Types.Char.is_empty (brs.Typed.br_accept)
then eval_transform env brs q
......@@ -167,15 +131,9 @@ and eval_xtrans env brs = function
Pair (x,y)
| x ->
let y = eval_xtrans env brs y in
eval_concat x y)
concat x y)
| q -> q
and eval_concat l1 l2 = match l1 with
| Pair (x,y) -> Pair (x, eval_concat y l2)
| String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
| String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
| q -> l2
and eval_dot l = function
| Record r -> LabelMap.assoc l r
| _ -> assert false
......@@ -183,102 +141,3 @@ and eval_dot l = function
and eval_remove_field l = function
| Record r -> Record (LabelMap.remove l r)
| _ -> assert false
and eval_add x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Intervals.vadd x y)
| Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
| _ -> assert false
and eval_mul x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Intervals.vmult x y)
| _ -> assert false
and eval_sub x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Intervals.vsub x y)
| _ -> assert false
and eval_div x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
| _ -> assert false
and eval_mod x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Intervals.vmod x y)
| _ -> assert false
and eval_load_xml e =
Load_xml.load_xml (get_string_latin1 e)
(* Note: loading iso-8859-1 (even ASCII) files with utf-8 internal
encoding has a non negligible overhead with PXP *)
and eval_load_html e =
Load_xml.load_html (get_string_latin1 e)
and eval_load_file ~utf8 e =
Location.protect_op "load_file";
let ic = open_in (get_string_latin1 e) in
let len = in_channel_length ic in
let s = String.create len in
really_input ic s 0 len;
close_in ic;
if utf8 then
if U.check s
then Value.string_utf8 (U.mk s)
else raise exn_load_file_utf8
else Value.string_latin1 s
and eval_int_of e =
let (s,_) = get_string_utf8 e in
try Integer (Intervals.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
with Failure _ -> raise exn_int_of
and eval_atom_of e =
let (s,_) = get_string_utf8 e in (* TODO: check that s is a correct Name wrt XML *)
Atom (Atoms.mk s)
and eval_print v =
Location.protect_op "print";
print_string (get_string_latin1 v);
flush stdout;
Value.nil
and eval_dump_to_file f v =
Location.protect_op "dump_to_file";
let oc = open_out (get_string_latin1 f) in
output_string oc (get_string_latin1 v);
close_out oc;
Value.nil
and eval_dump_to_file_utf8 f v =
Location.protect_op "dump_to_file_utf8";
let oc = open_out (get_string_latin1 f) in
let (v,_) = get_string_utf8 v in
output_string oc (U.get_str v);
close_out oc;
Value.nil
and eval_string_of v =
let b = Buffer.create 16 in
let ppf = Format.formatter_of_buffer b in
Value.print ppf v;
Format.pp_print_flush ppf ();
string_latin1 (Buffer.contents b)
and eval_equal v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 == 0)
and eval_lt v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 < 0)
and eval_lte v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 <= 0)
and eval_gt v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 > 0)
and eval_gte v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 >= 0)
......@@ -2,7 +2,6 @@ open Value
open Ident
exception MultipleDeclaration of id
module Env : Map.S with type key = id
type env = t Env.t
val global_env : env ref
......
......@@ -19,14 +19,24 @@ exception CDuceExn of t
let nil = Atom Sequence.nil_atom
let string_latin1 s = String_latin1 (0,String.length s, s, nil)
let string_utf8 s = String_utf8 (Utf8.start_index s,Utf8.end_index s, s, nil)
let vtrue = Atom Builtin.true_atom
let vfalse = Atom Builtin.false_atom
let vtrue = Atom (Atoms.mk_ascii "true")
let vfalse = Atom (Atoms.mk_ascii "false")
let vbool x = if x then vtrue else vfalse
let rec sequence = function
| [] -> nil
| h::t -> Pair (h, sequence t)
let rec concat l1 l2 = match l1 with
| Pair (x,y) -> Pair (x, concat y l2)
| String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, concat q l2)
| String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, concat q l2)
| q -> l2
let rec flatten = function
| Pair (x,y) -> concat x (flatten y)
| q -> q
let const = function
| Types.Integer i -> Integer i
| Types.Atom a -> Atom a
......
......@@ -35,6 +35,8 @@ val vfalse : t
val vbool : bool -> t
val sequence : t list -> t
val concat : t -> t -> t
val flatten : t -> t
val get_string_latin1 : t -> string
val get_string_utf8 : t -> U.t * t
......
......@@ -18,22 +18,302 @@ let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
let bool = Types.cup true_type false_type
let nil = Sequence.nil_type
let string = Sequence.string
let any = Types.any
let int = Types.Int.any
let atom = Types.atom Atoms.any
let char_latin1 = Types.char (Chars.mk_classes [ (0,255) ])
let string_latin1 = Sequence.star char_latin1
(* Types *)
let types =
[
"Empty", Types.empty;
"Any", Types.any;
"Int", Types.Int.any;
"Any", any;
"Int", int;
"Char", Types.char Chars.any;
"Byte", char_latin1;
"Atom", Types.atom Atoms.any;
"Atom", atom;
"Pair", Types.Product.any;
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
"String", Sequence.string;
"String", string;
"Latin1", string_latin1;
"Bool", bool
];
]
let () =
List.iter
(fun (n,t) ->
Typer.register_global_types [n, Location.mknoloc (Ast.Internal t)])
types
(* Operators *)
let binary_op_gen name typ run =
Typed.register_op name
(`Binary { Typed.bin_op_typer = typ; Typed.bin_op_eval = run })
let unary_op_gen name typ run =
Typed.register_op name
(`Unary { Typed.un_op_typer = typ; Typed.un_op_eval = run })
let binary_op name t1 t2 f run =
binary_op_gen
name
(fun loc 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_warning2 name t1 t2 w2 t run =
binary_op_gen name
(fun loc 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";
t)
run
let unary_op_warning name targ w t run =
Typed.register_op name
(`Unary
{ Typed.un_op_typer =
(fun loc arg constr precise ->
let res = arg targ true in
if not (Types.subtype res w) then
Typer.warning loc "This operator may fail";
t);
Typed.un_op_eval = run })
let unary_op_cst name targ t run =
Typed.register_op name
(`Unary
{ Typed.un_op_typer =
(fun loc arg constr precise ->
ignore (arg targ false);
t);
Typed.un_op_eval = run })
open Ident
let exn_load_file_utf8 =
Value.CDuceExn (
Value.Pair (
Value.Atom (Atoms.mk_ascii "load_file_utf8"),
Value.string_latin1 "File is not a valid UTF-8 stream"))