Commit 9ef600d9 authored by Giuseppe Castagna's avatar Giuseppe Castagna

Merge branch 'master' of https://git.cduce.org/cduce

parents 26bcb797 bd1de27e
configure.log
cduce
*.o
*.cmo
*.cdo
*.cma
*.cmi
*.cmx
*.cmxa
*.a
Makefile.conf
default: cduce
.default: cduce
include Makefile.conf
include VERSION
......@@ -331,17 +331,15 @@ distclean: clean
$(OCAMLIFACE)/mltypes.$(EXTENSION): $(OCAMLIFACE)/caml_cduce.$(EXTENSION)
$(ALL_INTERFACES): misc/q_symbol.cmo.stamp
$(ALL_OBJECTS:.cmo=.cmi): misc/q_symbol.cmo.stamp
$(ALL_OBJECTS:.cmo=.cmx) caml_cduce.cmx: misc/q_symbol.cmo.stamp
$(ALL_OBJECTS) caml_cduce.cmo: misc/q_symbol.cmo.stamp
$(ALL_INTERFACES): misc/q_symbol.cmo
$(ALL_OBJECTS:.cmo=.cmi): misc/q_symbol.cmo
$(ALL_OBJECTS:.cmo=.cmx) caml_cduce.cmx: misc/q_symbol.cmo
$(ALL_OBJECTS) caml_cduce.cmo: misc/q_symbol.cmo
$(OCAMLIFACE)/mlstub.$(EXTENSION): SYNTAX += q_MLast.cmo
misc/q_symbol.cmo.stamp: misc/q_symbol.ml
misc/q_symbol.cmo: misc/q_symbol.ml
@echo "Build $@"
$(HIDE) $(CAMLC) -c -pp camlp4orf $<
$(HIDE) sync
$(HIDE) touch misc/q_symbol.cmo.stamp
types/boolVar.cmo: SYNTAX_PARSER=
......
......@@ -45,6 +45,24 @@ let keyword = Gram.Entry.mk "keyword"
let lop pos = Cduce_loc.loc_of_pos (tloc pos)
let exp pos e = LocatedExpr (lop pos,e)
let split_id_list loc l =
let rec loop l acc =
match l with
[] -> acc, []
| qname :: ll ->
try
let i = String.index qname ':' in
let pre = String.sub qname 0 i in
let post = String.sub qname (i+1) (String.length qname - i - 1) in
pre :: acc, post::ll
with
Not_found -> loop ll (qname :: acc)
in
let l1, l2 = loop l [] in
if l2 == [] then raise Stream.Failure else
(mk loc (PatVar(List.rev_map ident l1, [])),
mk loc (PatVar(List.map ident l2, [])))
let rec multi_prod loc = function
| [ x ] -> x
| x :: l -> mk loc (Prod (x, multi_prod loc l))
......@@ -329,7 +347,7 @@ EXTEND Gram
let tres = targ in
let arg = mknoloc(PatVar ([x],[])) in
let abst = {fun_name = Some (lop _loc,ident "f") ; fun_iface = [(targ, tres)] ;fun_body = [(arg,xt)] } in
let body =
let body =
let_in rf (mknoloc (PatVar ([stk],[])))
(let_in ((Abstraction abst)) (mknoloc (PatVar ([ident "f"],[])))
(let_in ((Apply(Var(f) , e) ) ) (mknoloc (Internal Types.any)) (get_ref (Var stk))))
......@@ -437,6 +455,17 @@ EXTEND Gram
]
];
arg_colon_type: [
[ p1 = pat ; targ1 = OPT [ ":"; p = pat -> p ] ->
match p1.descr,targ1 with
PatVar(id1, []), None ->
split_id_list _loc (List.map Ident.U.get_str id1)
| _, Some targ1 -> p1, targ1
| _ -> raise Stream.Failure
]
];
fun_decl_after_lparen: [
(* need an hack to do this, because both productions would
match [ OPT IDENT; "("; pat ] .... *)
......@@ -444,40 +473,48 @@ EXTEND Gram
res = [ "->"; p2 = pat;
a = [ ";"; a = LIST0 arrow SEP ";" -> a | -> [] ];
")"; b = branches -> `Classic (p2,a,b)
| ":"; targ1 = pat;
args = LIST0 [ ","; arg = pat; ":"; targ = pat -> (arg,targ) ];
| targ1 = OPT [ ":"; p = pat -> p ];
args = LIST0 [ ","; arg = arg_colon_type -> arg ];
")";
others = LIST0
[ "(";
args =
LIST1
[ arg = pat; ":"; targ = pat -> (arg,targ) ]
[ arg = arg_colon_type -> arg ]
SEP ",";
")" -> args ];
":"; tres = pat ;
":" ; tres = pat ;
"="; body = expr ->
`Compact (targ1,args,others,tres,body)
] ->
match res with
| `Classic (p2,a,b) -> (p1,p2)::a,b
| `Compact (targ1,args,others,tres,body) ->
let mkfun args =
multi_prod nopos (List.map snd args),
multi_prod nopos (List.map fst args)
in
let (tres,body) =
List.fold_right
(fun args (tres,body) ->
let (targ,arg) = mkfun args in
let e = Abstraction
{ fun_name = None; fun_iface = [targ,tres];
fun_body = [arg,body] } in
let t = mknoloc (Arrow (targ,tres)) in
(t,e)
)
others (tres,body) in
let (targ,arg) = mkfun ((p1,targ1) :: args) in
[(targ,tres)],[(arg,body)]
match res with
| `Classic (p2,a,b) -> (p1,p2)::a,b
| `Compact (targ1,args,others,tres,body) ->
let mkfun args =
multi_prod nopos (List.map snd args),
multi_prod nopos (List.map fst args)
in
let (tres,body) =
List.fold_right
(fun args (tres,body) ->
let (targ,arg) = mkfun args in
let e = Abstraction
{ fun_name = None; fun_iface = [targ,tres];
fun_body = [arg,body] } in
let t = mknoloc (Arrow (targ,tres)) in
(t,e)
)
others (tres,body) in
let p1, targ1 =
match p1.descr,targ1 with
PatVar(id1, []), None ->
split_id_list _loc (List.map Ident.U.get_str id1)
| _, Some targ1 -> p1, targ1
| _ -> raise Stream.Failure
in
let (targ,arg) = mkfun ((p1,targ1) :: args) in
[(targ,tres)],[(arg,body)]
]
];
......@@ -575,7 +612,7 @@ EXTEND Gram
pat: [
[ x = pat; "where";
b = LIST1 [ x = located_ident; "="; y = pat -> (x,[],y) ] SEP "and" ->
b = LIST1 [ x = located_ident; "="; y = pat -> (x,[],y) ] SEP "and" ->
mk _loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk _loc (Arrow (x,y))
| x = pat; "@"; y = pat -> mk _loc (Concat (x,y))
......@@ -583,7 +620,7 @@ EXTEND Gram
| "no_arrow" [ x = pat; "|"; y = pat -> mk _loc (Or (x,y)) ]
| "simple" [ x = pat; "&"; y = pat -> mk _loc (And (x,y))
| x = pat; "\\"; y = pat -> mk _loc (Diff (x,y)) ]
| "var" [ x = PVAR ->
| "var" [ x = PVAR ->
mk _loc (Internal (Types.var (Var.mk (ident_aux x)))) ]
|
[ "{"; r = record_spec; "}" -> r
......@@ -633,7 +670,7 @@ EXTEND Gram
mk _loc (Regexp r)
| "<"; t =
[ x = tag_type -> x
| "("; t = pat; ")" -> t ];
| "("; t = pat; ")" -> t ];
a = attrib_spec; ">"; c = pat ->
mk _loc (XmlT (t, multi_prod _loc [a;c]))
| s = STRING ->
......@@ -653,11 +690,11 @@ EXTEND Gram
or_else : [ [ OPT [ "else"; y = pat -> y ] ] ];
opt_field_pat: [
opt_field_pat: [
[ OPT [ "=";
o = [ "?" -> true | -> false];
x = pat; y = or_else -> (o,x,y) ]
]
x = pat; y = or_else -> (o,x,y) ]
]
];
record_spec: [
......@@ -688,7 +725,7 @@ EXTEND Gram
opt_field_expr: [ [ OPT [ "="; x = expr LEVEL "no_appl" -> x ] ] ];
expr_record_spec: [
expr_record_spec: [
[ r = LIST0 [ l = ident_or_keyword;
x = opt_field_expr; OPT ";" ->
let x = match x with Some x -> x | None -> Var (ident l) in
......
......@@ -5,11 +5,11 @@ let eval = ref (fun ppf err s -> assert false)
(* Types *)
let stringn = Types.cons string
let namespaces =
let namespaces =
Sequence.star (Types.times stringn stringn)
let types =
[
[
"Empty", Types.empty;
"Any", any;
"Int", int;
......@@ -30,7 +30,7 @@ let types =
let env =
List.fold_left
(fun accu (n,t) ->
(fun accu (n,t) ->
let n = (Ns.empty, Ident.U.mk n) in
Types.Print.register_global ("",n,[||]) t;
Typer.enter_type (Ident.ident n) t accu
......@@ -60,7 +60,7 @@ let binary_op_cst = register_op2
let binary_op_warning2 name t1 t2 w2 t run =
binary_op_gen name
(fun arg1 arg2 constr precise ->
ignore (arg1 t1 false);
ignore (arg1 t1 false);
let r = arg2 t2 true in
if not (Types.subtype r w2) then
raise (Typer.Warning ("This operator may fail", t));
......@@ -127,9 +127,9 @@ let eval_load_file ~utf8 e =
Cduce_loc.protect_op "load_file";
let fn = Value.get_string_latin1 e in
let s = Url.load_url fn in
if utf8 then
match U.mk_check s with
| Some s -> Value.string_utf8 s
if utf8 then
match U.mk_check s with
| Some s -> Value.string_utf8 s
| None -> raise (Lazy.force exn_load_file_utf8)
else Value.string_latin1 s
......@@ -138,30 +138,30 @@ let () = ();;
(* Comparison operators *)
binary_op "="
any any
binary_op "="
any any
(fun t1 t2 ->
if Types.is_empty (Types.cap t1 t2) then false_type
else bool)
(fun v1 v2 ->
Value.vbool (Value.compare v1 v2 == 0));;
binary_op_cst "<="
binary_op_cst "<="
any any bool
(fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));;
binary_op_cst "<"
binary_op_cst "<"
any any bool
(fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));;
binary_op_cst ">="
binary_op_cst ">="
any any bool
(fun v1 v2 ->
(fun v1 v2 ->
Value.vbool (Value.compare v1 v2 >= 0));;
binary_op_cst ">"
binary_op_cst ">"
any any bool
(fun v1 v2 ->
(fun v1 v2 ->
Value.vbool (Value.compare v1 v2 > 0));;
(* I/O *)
......@@ -181,10 +181,10 @@ register_fun "int_of_char"
Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
| _ -> assert false);;
register_fun "string_of"
register_fun "string_of"
any string_latin1
(fun v ->
(fun v ->
let b = Buffer.create 16 in
let ppf = Format.formatter_of_buffer b in
Value.print ppf v;
......@@ -195,7 +195,7 @@ register_fun "string_of"
register_fun "load_xml"
string_latin1 any_xml
(fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml (Value.get_string_latin1 v));;
register_fun "!load_xml"
string_latin1 any_xml
(fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml ~ns:true
......@@ -206,12 +206,12 @@ register_fun "load_html"
string_latin1 Sequence.any
(fun v -> Cduce_loc.protect_op "load_html"; Load_xml.load_html (Value.get_string_latin1 v));;
register_fun "load_file_utf8"
string_latin1 string
register_fun "load_file_utf8"
string_latin1 string
(eval_load_file ~utf8:true);;
register_fun "load_file"
string_latin1 string_latin1
register_fun "load_file"
string_latin1 string_latin1
(eval_load_file ~utf8:false);;
......@@ -219,24 +219,24 @@ let argv = ref Value.Absent;;
register_fun "print_xml"
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"
register_fun "print_xml_utf8"
Types.any string
(fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
register_fun "dump_xml"
register_fun "dump_xml"
Types.any nil
(fun v ->
Cduce_loc.protect_op "print";
Cduce_loc.protect_op "print";
Print_xml.dump_xml ~utf8:false !Eval.ns_table v);;
register_fun "dump_xml_utf8"
register_fun "dump_xml_utf8"
Types.any nil
(fun v ->
(fun v ->
Cduce_loc.protect_op "print";
Print_xml.dump_xml ~utf8:true !Eval.ns_table v);;
......@@ -250,6 +250,15 @@ register_fun "print"
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"
string nil
(fun v ->
......@@ -271,12 +280,12 @@ unary_op_warning "int_of"
modifier = 'b' ||
modifier = 'B' ||
modifier = 'o' ||
modifier = 'O')
then
modifier = 'O')
then
Value.Integer (Intervals.V.from_int (int_of_string(str)))
else
Value.Integer (Intervals.V.mk (str))
with _ ->
with _ ->
(try Value.Integer (Intervals.V.mk (str))
with Failure _ -> raise (Lazy.force exn_int_of)));;
......@@ -290,13 +299,13 @@ unary_op_warning "int_of"
register_fun "atom_of"
string atom
(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));;
*)
register_fun "split_atom"
atom (Types.times stringn stringn)
(function
(function
| Value.Atom q ->
let (ns,l) = Atoms.V.value q in
Value.Pair(
......@@ -314,7 +323,7 @@ register_fun "make_atom"
Value.Atom (Atoms.V.mk (Ns.Uri.mk ns, l)));;
binary_op_warning2 "dump_to_file"
string_latin1 string string_latin1 nil
......@@ -325,7 +334,7 @@ binary_op_warning2 "dump_to_file"
close_out oc;
Value.nil
with exn -> raise_gen exn);;
binary_op_cst "dump_to_file_utf8"
string_latin1 string nil
(fun f v -> try
......@@ -348,24 +357,24 @@ let intop f x y =
binary_op_gen "+"
(fun arg1 arg2 constr precise ->
let t1 = arg1 (Types.cup int Types.Record.any) true in
if Types.subtype t1 int
if Types.subtype t1 int
then (
let t2 = arg2 int true in
Types.interval
Types.interval
(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 (
let t2 = arg2 Types.Record.any true in
let t2 = arg2 Types.Record.any true in
Types.Record.merge t1 t2
)
else raise (Typer.Error "The first argument mixes integers and records"))
Value.add;;
binary_op "-"
int int
(fun t1 t2 ->
Types.interval
Types.interval
(intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
......@@ -374,7 +383,7 @@ binary_op "-"
binary_op "*"
int int
(fun t1 t2 ->
Types.interval
Types.interval
(intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2)))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
......@@ -413,17 +422,17 @@ binary_op_gen "@"
unary_op_gen "flatten"
Typer.flatten
Value.flatten;;
register_fun "raise" any Types.empty
(fun v -> raise (Value.CDuceExn v));;
register_fun "namespaces" any_xml
register_fun "namespaces" any_xml
namespaces
(function
(function
Value.XmlNs (_,_,_,ns,s) ->
Value.sequence_rev
(List.map
Value.sequence_rev
(List.map
(fun (pr,ns) ->
Value.Pair (Value.string_utf8 pr,
Value.string_utf8 (Ns.Uri.value ns), s))
......
......@@ -1964,7 +1964,7 @@ module Print = struct
in
let u_acc, tt =
let tt_times = { empty with times = tt.times } in
if subtype tt_times seqs_descr then
if subtype tt_times seqs_descr && not (has_tlv tt_times) then
let seq = cap tt seqs_descr in
let seq_times = { empty with times = seq.times } in
if is_empty seq || (is_empty seq_times && not finite_atoms) then
......
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