Commit 5d94bf3f authored by Pietro Abate's avatar Pietro Abate
Browse files

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

parents 3add7855 ab10beba
......@@ -147,7 +147,7 @@ OBJECTS = \
\
types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
types/types.cmo compile/auto_pat.cmo \
types/var.cmo types/boolVar.cmo types/types.cmo compile/auto_pat.cmo \
types/sequence.cmo types/builtin_defs.cmo \
\
runtime/value.cmo \
......@@ -309,14 +309,26 @@ misc/q_symbol.cmo: misc/q_symbol.ml
@echo "Build $@"
$(HIDE)$(CAMLC) -c -pp camlp4orf $<
types/%.cmo: types/%.ml
@echo "Build $@"
$(HIDE)$(CAMLC) -c $(INCLUDES) $<
.ml.cmo:
@echo "Build $@"
$(HIDE)$(CAMLC) -c $(INCLUDES) $(SYNTAX_PARSER) $<
types/%.cmx: types/%.ml
@echo "Build $@"
$(HIDE)$(CAMLOPT) $(FORPACKOPT) -c $(INCLUDES) $<
.ml.cmx:
@echo "Build $@"
$(HIDE)$(CAMLOPT) $(FORPACKOPT) -c $(SYNTAX_PARSER) $(INCLUDES) $<
types/%.cmi: types/%.mli
@echo "Build $@"
$(HIDE)$(CAMLC) -c $(INCLUDES) $<
.mli.cmi:
@echo "Build $@"
$(HIDE)$(CAMLC) -c $(SYNTAX_PARSER) $(INCLUDES) $<
......
......@@ -55,6 +55,7 @@ and compile_aux env = function
let d = Patterns.Compile.make_checker !t0 (Types.descr t) in
Check (compile env e, d)
| Typed.Var x -> Var (find x env)
| Typed.TVar x -> Var (find x env)
| Typed.ExtVar (cu,x,_) -> Var (find_ext cu x)
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
| Typed.Abstraction a -> compile_abstr env a
......@@ -121,7 +122,7 @@ and compile_abstr env a =
let slots = Array.of_list (List.rev slots) in
let env = { env with vars = fun_env; stack_size = 0; max_stack = ref 0 } in
let body = compile_branches env a.Typed.fun_body in
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack))
Abstraction (slots, a.Typed.fun_iface, body, !(env.max_stack), true, List [[]])
and compile_branches env (brs : Typed.branches) =
(* Don't compile unused branches, because they have not been
......
expr = id
| integer
| string
| abstr
| expr "." expr
| expr "," expr
| "(" expr ")"
| "match" expr ":" type_id "with" "|" match_value "->" expr branches
(* TODO: Add the "_" special keyword *)
abstr = "fun" id id ":" type_id params ":" type_id "->" expr
match_value = id ":" type_id
| integer
| string
| match_value "," match_value
| "(" match_value ")"
params = (* empty *)
| id ":" type_id params
branches = (* empty *)
| "|" match_value "->" expr branches
id = [a-z_][A-Za-z0-9_]*
(* TODO: Add union and polymorphic types *)
type_id = [A-Z][A-Za-z0-9_]*
| (complex_type_id)
complex_type_id = [A-Z][A-Za-z0-9_]*
| complex_type_id * complex_type_id
| complex_type_id -> complex_type_id
integer = [0-9]+
COMPILER ?= ocamlbuild
ROOTDIR ?= ../..
SRCDIR ?= src
EXTDIR ?= $(SRCDIR)/externals
LIBFLAGS ?= -libs nums,netstring,pcre,ulexing\
-lflags -I,`ocamlfind query netstring` -lflags -I,`ocamlfind query pcre`\
-lflags -I,`ocamlfind query ulex`
DEBUGFLAGS ?= -cflags -g -lflags -g
INEXTFILES = misc/custom.ml misc/encodings.ml misc/upool.ml misc/ns.ml\
types/sortedList.ml types/ident.ml misc/html.ml types/sequence.ml\
types/patterns.ml parser/cduce_loc.mli parser/cduce_loc.ml typing/typed.ml\
types/builtin_defs.ml parser/ast.ml typing/typepat.mli typing/typepat.ml\
types/externals.mli types/externals.ml typing/typer.ml\
runtime/run_dispatch.ml runtime/explain.ml schema/schema_pcre.ml\
schema/schema_xml.mli schema/schema_xml.ml schema/schema_common.mli\
schema/schema_common.ml runtime/eval.mli runtime/eval.ml\
compile/compile.ml types/compunit.mli types/compunit.ml types/var.ml\
types/boolVar.ml misc/imap.ml types/atoms.ml types/intervals.ml\
types/chars.mli types/chars.ml misc/bool.mli misc/bool.ml types/types.mli\
misc/stats.mli misc/stats.ml types/normal.mli types/normal.ml misc/pretty.mli\
misc/pretty.ml types/types.ml compile/auto_pat.mli runtime/value.mli\
runtime/value.ml schema/schema_types.mli schema/schema_validator.mli\
schema/schema_builtin.mli schema/schema_builtin.ml schema/schema_validator.ml\
compile/lambda.ml
EXTFILES = $(INEXTFILES:%=$(ROOTDIR)/%)
RM ?= rm -f
OUT ?= main.native
OUTDEBUG ?= main.byte
.PHONY: clean check test _import
all: _import
$(COMPILER) -use-ocamlfind $(LIBFLAGS) $(OUT)
debug: _import
$(COMPILER) -use-ocamlfind $(DEBUGFLAGS) $(LIBFLAGS) $(OUTDEBUG)
_import:
@echo -n "Copying external files..."
@test -d $(EXTDIR) || mkdir $(EXTDIR)
@cp $(EXTFILES) $(EXTDIR)
@echo "done"
clean:
$(COMPILER) -clean
test $(EXTDIR) = "src" || test $(EXTDIR) = "." || $(RM) -r $(EXTDIR)
check: test
test: all
tests/test.sh
<src>: include
<src/parse*>: pp(camlp4orf.opt), package(camlp4.lib)
<src/compute*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
<src/main*>: pp(camlp4orf.opt), package(camlp4.lib, unix, netsys, str)
<src/externals>: include
<src/externals/schema_*>: package(pcre, netcgi2)
<src/externals/cduce_loc*>: package(ulex), syntax(camlp4o)
open Parse
open Typed
open Compile
open Camlp4.PreCast
open Types
open Big_int
(* Gives a unique id for a name *)
module Locals = Map.Make(String)
(* To throw in case of an unbound name *)
exception Error
(* TODO: We will need a much better representation of types and a much better
function when we'll add union types and polymorphism. *)
let is_subtype t1 t2 = if String.compare t1 t2 = 0 then true else false
let rec _to_typed env l expr =
(* From Camlp4 locations to CDuce locations *)
let loc = caml_loc_to_cduce (get_loc expr) in
match expr with
| Parse.Apply (_, e1, e2) ->
let _, _, e1 = _to_typed env l e1 in
let _, _, e2 = _to_typed env l e2 in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Apply(e1, e2) }
| Abstr (_, fun_name, params, return_type, body) ->
parse_abstr env l loc (Some(0, fun_name)) params return_type body
| Match (_, e, t, b) ->
let b = parse_branches env l t b [] in
let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=b } in
let _, _, exp_descr = _to_typed env l e in
env, l, { exp_loc=loc; exp_typ=Types.empty;
exp_descr=Match(exp_descr, brs) }
| Pair (_, e1, e2) ->
let _, _, exp_descr1 = _to_typed env l e1 in
let _, _, exp_descr2 = _to_typed env l e2 in
env, l, { exp_loc=loc; exp_typ=Types.empty;
exp_descr=Pair(exp_descr1, exp_descr2) }
| Var (origloc, vname) ->
let line = Loc.start_line origloc in
let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
let cend = Loc.stop_off origloc - Loc.start_bol origloc in
let index = (try Locals.find vname l with Not_found ->
Printf.eprintf "File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
(Loc.file_name origloc) line cbegin cend vname; raise Error) in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Var(index, vname) }
| Int (_, i) ->
let i = Big_int.big_int_of_int i in
env, l, { exp_loc=loc; exp_typ=Types.empty;
exp_descr=Cst(Types.Integer i) }
| String (_, s) ->
let s = Types.String (0, (String.length s) - 1, s,
Types.Integer (Big_int.big_int_of_int 0)) in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Cst s }
and parse_abstr env l loc fun_name params return_type body =
let rec _parse_abstr env l fv loc fun_name params return_type body nb =
let brloc = caml_loc_to_cduce (get_loc body) in
let empty, env, l, nfv, iface, rest = parse_iface env l params [] nb [] in
let node = make_node (fv @ nfv) nfv in
let body = if empty
then let _, _, body = _to_typed env l body in body
else let _, _, body = _parse_abstr env l (fv @ nfv) loc None rest
return_type body (nb + 1) in body
in
let b = { br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=body } in
let brs = { br_typ=Types.empty; br_accept=Types.empty; br_branches=[b] } in
let abstr = { fun_name=fun_name; fun_iface=iface; fun_body=brs;
fun_typ=Types.empty; fun_fv=[] } in
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Abstraction(abstr) }
in
_parse_abstr env l [] loc fun_name params return_type body 0
and make_node fv nfv =
let d = (match nfv with
| el :: rest -> Patterns.Capture(el)
| [] -> Patterns.Dummy)
in
incr Patterns.counter;
{ Patterns.id=(!Patterns.counter); Patterns.descr=(Types.empty, fv, d);
Patterns.accept=(Types.make ()); Patterns.fv=fv }
and parse_iface env l params fv nb iface = match params with
| (_, pname, _) :: [] -> true, env, (Locals.add pname nb l),
(fv @ [nb, pname]), (iface @ [Types.empty, Types.empty]), []
| (_, pname, _) :: rest -> false, env, (Locals.add pname nb l),
(fv @ [nb, pname]), (iface @ [Types.empty, Types.empty]), rest
| [] -> true, env, l, fv, iface, []
and parse_branches env l toptype brs res = match brs with
| (loc, p, e) :: rest ->
let brloc = caml_loc_to_cduce loc in
let t, list, br_locals, br_used = parse_match_value env l [] p toptype in
let line = Loc.start_line loc in
let cbegin = Loc.start_off loc - Loc.start_bol loc in
let cend = Loc.stop_off loc - Loc.start_bol loc in
let _, _, br_body = _to_typed env br_locals e in
let fname = Loc.file_name loc in
let node =
(if not br_used then
(Printf.eprintf
"File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
fname line cbegin cend; make_patterns [] t)
else make_patterns list t) in
let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=br_body} in
parse_branches env l toptype rest (res @ [b])
| [] -> res
and make_patterns fv pattype = incr Patterns.counter;
{ Patterns.id=(!Patterns.counter);
Patterns.descr=(Types.empty,Ident.IdSet.empty,pattype);
Patterns.accept=(Types.make()); fv=fv }
and parse_match_value env l list p toptype = match p with
| MPair (_) -> Patterns.Dummy, list, l, false;
(* TODO: Allow pairs in types *)
| MVar (_, mname, mtype) ->
let lsize = Locals.cardinal l in
Patterns.Dummy, (list @ [lsize, mname]), Locals.add mname lsize l,
is_subtype toptype mtype
| MInt (_, i) -> Patterns.Constr(constant (Integer(big_int_of_int i))), list,
l, is_subtype toptype "Int"
| MString (_, s) -> Patterns.Constr(constant (
String(0,String.length s - 1,s, Integer(big_int_of_int 0)))),
list, l, is_subtype toptype "String"
let to_typed expr =
let env, _, expr = _to_typed empty_toplevel Locals.empty expr in
env, expr
exception Error
val to_typed : Parse.expr -> Compile.env * Typed.texpr
open Printf
open Parse
open Value
open Typed
open Types
open Camlp4.PreCast
let load_file f =
let ic = open_in f in
let n = in_channel_length ic in
let s = String.create n in
really_input ic s 0 n;
close_in ic;
s
let rec typed_to_string e = match e with
| Typed.Forget(e, _) -> "Forget(" ^ typed_to_string e.Typed.exp_descr ^ ")"
| Typed.Check(_, e, _) -> "Check(" ^ typed_to_string e.Typed.exp_descr ^ ")"
| Typed.Var(id, name) -> "Var(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| Typed.ExtVar(_, (id, name), _) -> "ExtVar("
^ (string_of_int (Upool.int id)) ^ ", " ^ (Encodings.Utf8.to_string name)
^ ")"
| Typed.Apply(e1, e2) -> "(" ^ typed_to_string e1.Typed.exp_descr ^ ").("
^ (typed_to_string e2.Typed.exp_descr) ^ ")"
| Typed.Abstraction(abstr) -> "Abstraction(" ^ (abst abstr) ^ ")"
| Typed.Cst(cst) -> const cst
| Typed.Pair(e1, e2) -> "(" ^ (typed_to_string e1.Typed.exp_descr) ^ ", " ^
(typed_to_string e2.Typed.exp_descr) ^ ")"
| Typed.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| Typed.Match(e, b) -> "Match(" ^ (typed_to_string e.Typed.exp_descr) ^ ", "
^ (branches b.Typed.br_branches) ^ ")"
| _ -> assert false
and const cst = match cst with
| Types.Integer(i) -> "Integer(" ^ (Intervals.V.to_string i) ^ ")"
| Types.Atom(a) -> "Atom(" ^ (Atoms.V.to_string a) ^ ")"
| Types.Char(c) -> "Char(" ^ (string_of_int (Chars.V.to_int c)) ^ ")"
| Types.Pair(c1, c2) -> "(" ^ const c1 ^ ", " ^ const c2 ^ ")"
| Types.String(_, _, s, _) -> "\"" ^ (Encodings.Utf8.to_string s) ^ "\""
| _ -> assert false
and abst abstr = (match abstr.Typed.fun_name with
| Some (id, name) -> "name:(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ "), body:["
| None -> "name:<none>, body:[") ^
(branches abstr.Typed.fun_body.Typed.br_branches) ^ "], fv:["
^ (fv_to_string abstr.Typed.fun_fv) ^ "]"
and branches brs = match brs with
| br :: [] -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
^ (node br.Typed.br_pat) ^ "}; body:"
^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}"
| br :: rest -> "{used:" ^ (string_of_bool br.Typed.br_used) ^ "; ghost:"
^ (string_of_bool br.Typed.br_ghost) ^ "; br_vars_empty:["
^ (fv_to_string br.Typed.br_vars_empty) ^ "]; pat:{"
^ (node br.Typed.br_pat) ^ "}; body:"
^ (typed_to_string br.Typed.br_body.Typed.exp_descr) ^ "}, "
^ (branches rest)
| [] -> ""
and node node = "id:" ^ (string_of_int node.Patterns.id) ^ "; descr:["
^ (descr node.Patterns.descr) ^ "]; fv:[" ^ (fv_to_string node.Patterns.fv)
^ "]"
and descr (t, fv, d) = "<type>; [" ^ (fv_to_string fv) ^ "]; " ^ descr2 d
and descr2 d = match d with
| Patterns.Constr(t) -> "<type>"
| Patterns.Cup(d1, d2) -> "Cup(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
| Patterns.Cap(d1, d2) -> "Cap(" ^ (descr d1) ^ ", " ^ (descr d2) ^ ")"
| Patterns.Times(n1, n2) -> "Times(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
| Patterns.Xml(n1, n2) -> "Xml(" ^ (node n1) ^ ", " ^ (node n2) ^ ")"
| Patterns.Record(l, n) -> "Record(" ^ (Ns.Label.string_of_tag l) ^ ", "
^ (node n) ^ ")"
| Patterns.Capture((id, name)) -> "Capture(" ^ "<id>, "
^ (Encodings.Utf8.to_string name) ^ ")"
| Patterns.Constant((id, name), ct) -> "Constant((" ^ "<id>, "
^ (Encodings.Utf8.to_string name) ^ "), " ^ const ct ^ ")"
| Patterns.Dummy -> "Dummy"
and fv_to_string fv = match fv with
| (id, name) :: [] -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ ")"
| (id, name) :: rest -> "(" ^ (string_of_int (Upool.int id)) ^ ", "
^ (Encodings.Utf8.to_string name) ^ "), " ^ (fv_to_string rest)
| [] -> ""
let rec print_value v = match v with
| Value.Pair(v1, v2) -> printf "("; print_value v1; printf ", ";
print_value v2; printf ")"
| Xml(_,_,_) -> printf "Xml"
| XmlNs(_,_,_,_) -> printf "XmlNs"
| Record(_) -> printf "Record"
| Atom(_) -> printf "Atom"
| Integer(i) -> printf "%d" (Big_int.int_of_big_int i)
| Char(i) -> printf "Char()"
| Abstraction(_, _) -> printf "Abstraction()"
| Abstract((name, _)) -> printf "Abstract(%s)" name
| String_latin1(i1, i2, s, v) -> printf "String_latin1(%d, %d, %s)" i1 i2 s;
print_value v
| String_utf8(_,_,s,_) -> printf "String(%s)" s
| Concat(v1, v2) -> printf "Concat("; print_value v1; printf ", ";
print_value v2; printf ")"
| Absent -> printf "Absent"
let str, file =
if Array.length Sys.argv > 1 then load_file Sys.argv.(1), Sys.argv.(1)
else (eprintf "Fatal error: No input file\n"; exit 1)
in
try
let expr = ExprParser.of_string str file in
let env, texpr = Compute.to_typed expr in
(* printf "%s\n" (typed_to_string texpr.exp_descr);*)
let evalexpr = Compile.compile_eval_expr env texpr in
print_value evalexpr; printf "\n"
with
| Compute.Error -> exit 3
| Loc.Exc_located (loc, exn) ->
let l = Loc.start_line loc in
let cbegin = Loc.start_off loc - Loc.start_bol loc in
let cend = Loc.stop_off loc - Loc.start_bol loc in
eprintf "File %s, line %d, characters %d-%d:\n" (Loc.file_name loc) l
cbegin cend; raise exn
| e -> eprintf "Runtime error.\n"; raise e
open Printf
open Camlp4.PreCast
type expr =
| Apply of Loc.t * expr * expr
| Abstr of Loc.t * fun_name * params * ptype * expr
| Match of Loc.t * expr * ptype * branches
| Pair of Loc.t * expr * expr
| Var of Loc.t * string
| Int of Loc.t * int
| String of Loc.t * string
and fun_name = string
and params = (Loc.t * string * ptype) list
and branches = (Loc.t * match_value * expr) list
and match_value =
| MPair of Loc.t * match_value * match_value
| MVar of Loc.t * string * ptype
| MInt of Loc.t * int
| MString of Loc.t * string
and ptype = string
module ExprParser = struct
let exp_eoi = Gram.Entry.mk "exp_eoi"
EXTEND Gram
GLOBAL: exp_eoi;
exp_eoi:[[e = expression; `EOI -> e]];
expression:
[
"abstr" RIGHTA
[ "fun"; x = LIDENT; p = LIST1 param; ":"; t = type_id; "->";
e = SELF -> Abstr(_loc, x, p, t, e)
| "match"; e = SELF; ":"; t = type_id; "with"; b = LIST1 branch ->
Match(_loc, e, t, b) ]
| "pair" LEFTA
[ e1 = SELF; ","; e2 = SELF -> Pair(_loc, e1, e2)
| e1 = SELF ; "."; e2 = SELF -> Apply(_loc, e1, e2) ]
| "paren" [ "("; e = SELF; ")" -> e ]
| "var" [ x = LIDENT -> Var(_loc, x) ]
| "int" [ x = INT -> Int(_loc, int_of_string x) ]
| "string" [ x = STRING -> String(_loc, x) ]
];
param:[[p = LIDENT; ":"; t = type_id -> _loc, p, t]];
branch:[ "branch" [ "|"; t = match_value; "->"; e = expression ->
_loc, t, e ]];
match_value:
[
"pair" LEFTA [ e1 = SELF; ","; e2 = SELF -> MPair(_loc, e1, e2) ]
| "paren" [ "("; e = SELF; ")" -> e ]
| "var" [ x = LIDENT; ":"; t = type_id -> MVar(_loc, x, t) ]
| "int" [ x = INT -> MInt(_loc, int_of_string x) ]
| "string" [ x = STRING -> MString(_loc, x) ]
];
type_id: [ "atom_type" [ t = UIDENT -> t ]
| [ "("; t = complex_type_id; ")" -> t ]];
complex_type_id: [ "complex_type" LEFTA [ t = UIDENT -> t ]
| [ t1 = SELF; "*"; t2 = SELF -> t1 ^ "*" ^ t2
| t1 = SELF; "->"; t2 = SELF -> t1 ^ "->" ^ t2 ]];
END;;
let of_string s file = Gram.parse_string exp_eoi (Loc.mk file) s
end
let get_loc expr = match expr with
| Apply (loc, _, _) -> loc
| Abstr (loc, _, _, _, _) -> loc
| Match (loc, _, _, _) -> loc
| Pair (loc, _, _) -> loc
| Var (loc, _) -> loc
| Int (loc, _) -> loc
| String (loc, _) -> loc
let caml_loc_to_cduce loc =
`File(Loc.file_name loc), Loc.start_off loc - Loc.start_bol loc,
Loc.stop_off loc - Loc.start_bol loc
open Camlp4.PreCast
type expr =
| Apply of Loc.t * expr * expr
| Abstr of Loc.t * fun_name * params * ptype * expr
| Match of Loc.t * expr * ptype * branches
| Pair of Loc.t * expr * expr
| Var of Loc.t * string
| Int of Loc.t * int
| String of Loc.t * string
and fun_name = string
and params = (Loc.t * string * ptype) list
and branches = (Loc.t * match_value * expr) list
and match_value =
| MPair of Loc.t * match_value * match_value
| MVar of Loc.t * string * ptype
| MInt of Loc.t * int
| MString of Loc.t * string
and ptype = string
module ExprParser : sig
val of_string : string -> string -> expr
end
val get_loc : expr -> Loc.t
val caml_loc_to_cduce : Loc.t -> Cduce_loc.loc
File ./tests/eval/tests/match_error_simple.test, line 1, characters 49-50:
Unbound identifier a
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