Commit 6b733b5a authored by Kim Nguyễn's avatar Kim Nguyễn

Merge branch 'typing/types-recursive-modules' :

This branch fixes several problem with the typechecker and pretty-printer.
It also re-organizes the Types module and extract the Tallying into a separate file.
parents 9ef600d9 71ddc3a0
......@@ -5,8 +5,12 @@ cduce
*.cdo
*.cma
*.cmi
*.cmt
*.cmti
.merlin
*.cmx
*.cmxa
*.a
Makefile.conf
web/doc/*.html
#directory "_build";;
#use "topfind";;
#require "num";;
#load "cduce_boolvar.cma";;
#camlp4o;;
#require "camlp4.extend";;
#require "ulex";;
#require "pcre";;
#require "netstring";;
#load "typesOUnit.cma";;
open TypesOUnit;;
open Types;;
let parse_typ s =
let st = Stream.of_string s in
let astpat = Parser.pat st in
let nodepat = Typer.typ Builtin.env astpat in
Types.descr nodepat
;;
type pp = P of vv * string | N of string * vv
and vv = V of string
let mk_pp = function
|P(V alpha,t) -> Tallying.CS.singleton (Tallying.Pos (Var.mk alpha,parse_typ t))
|N(t,V alpha) -> Tallying.CS.singleton (Tallying.Neg (parse_typ t,Var.mk alpha))
let mk_prod l =
List.fold_left (fun acc2 c ->
Tallying.CS.prod Var.Set.empty (mk_pp c) acc2
) Tallying.CS.sat l
let mk_union l1 l2 =
Tallying.CS.union (mk_prod l1) (mk_prod l2)
let mk_s ll =
List.fold_left (fun acc1 l ->
Tallying.CS.union (mk_prod l) acc1
) Tallying.CS.S.empty ll
module BIN = struct
open Builtin_defs
(* Types *)
let stringn = Types.cons string
let namespaces =
Sequence.star (Types.times stringn stringn)
let types =
[
"Empty", Types.empty;
"Any", any;
"Int", int;
"Char", Types.char Chars.any;
"Byte", char_latin1;
"Atom", atom;
"Pair", Types.Product.any;
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
"String", string;
"Latin1", string_latin1;
"Bool", bool;
"Float", float;
"AnyXml", any_xml;
"Namespaces", namespaces;
"Caml_int", caml_int;
]
let env =
List.fold_left
(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
)
Typer.empty_env
types
end
let parse_expr s =
let astexpr = Parser.expr (Stream.of_string s) in
let texpr = fst (Typer.type_expr BIN.env astexpr) in
texpr
;;
......@@ -49,26 +49,7 @@ package: clean
git archive --prefix=$(PACKAGE)/ -o $(PACKAGE).tar.gz HEAD
OCAML_STDLIBDIR := $(shell ocamlc -where)
.PHONY: .ocamlinit
.ocamlinit:
echo '(* AUTOMATICALLY GENERATED by Makefile: DO NOT EDIT! *)' > $@
echo '#load "$(OCAML_STDLIBDIR)/pcre/pcre.cma";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/unix.cma";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/netstring/netstring.cma";;' >> $@
# echo '#load "$(OCAML_STDLIBDIR)/netstring/netstring_top.cmo";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/pxp-engine/pxp_engine.cma";;' >> $@
# echo '#load "$(OCAML_STDLIBDIR)/pxp-engine/pxp_top.cmo";;' *)' >> $@
echo '#load "$(OCAML_STDLIBDIR)/pxp-lex-iso88591/pxp_lex_iso88591.cma";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/pxp-lex-iso88591/pxp_lex_link_iso88591.cmo";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/ulex/ulexing.cma";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/nums.cma";;' >> $@
# echo '#load "$(OCAML_STDLIBDIR)/num_top.cma";;' >> $@
echo '#load "$(OCAML_STDLIBDIR)/cgi/cgi.cma";;' >> $@
for o in $(VALIDATE_OBJECTS); do echo "prerr_endline \"Loading $$o ...\";;" >> $@; echo "#load \"$$o\";;" >> $@; done
for d in $(DIRS); do echo "#directory \"$$d\";;" >> $@; done
for p in pcre netstring pxp-engine ulex cgi; do echo "#directory \"`$(OCAMLFIND) query $$p`\";;" >> $@; done
echo "prerr_endline \"All done!\"" >> $@
echo '(* vim: set ft=ocaml: *)' >> $@
.PHONY:
CVS_DISTRIB = web CHANGES LICENSE README AUTHORS cduce dtd2cduce
CVS_DOC = doc/cdo2ml.1 doc/cduce.1 doc/cduce_mktop.1 doc/cduce_validate.1 doc/dtd2cduce.1 doc/fomanual/tutorial.pdf doc/fomanual/manual.pdf
......@@ -119,7 +100,3 @@ evaluator: $(EVALUATOR:.cmo=.$(EXTENSION))
# (to compile it on a machine which is not the web server)
# Seems to be some problems with statically linking curl
# EXTRA_OPTS_WEBIFACE += -ccopt -static
typestop:
ocamlbuild typesOUnit.cma
ocaml -init tests/toplevel/typesOUnit.ocamlinit
......@@ -36,8 +36,12 @@ else
endif
GIT_COMMIT=$(shell test -x "$$(which git)" && git rev-parse --short HEAD)
GIT_VERSION=$(subst -devel,-devel-$(GIT_COMMIT),$(VERSION))
SYNTAX = -I misc/ q_symbol.cmo \
-symbol cduce_version=\"$(VERSION)\" \
-symbol cduce_version=\"$(GIT_VERSION)\" \
-symbol build_date=\"$(shell date +%Y-%m-%d)\" \
-symbol session_dir=\"$(SESSION_DIR)\" \
-loc "_loc"
......@@ -67,6 +71,15 @@ ifeq ($(INTERFACE), true)
OPT += -passopt -i
endif
ifneq ($(strip $(DEBUG)),)
OPT += -g
SYNTAX += -symbol cduce_debug=\"$(DEBUG)\"
endif
ifeq ($(BIN_ANNOT), true)
OPT += -passopt -bin-annot
endif
OCAMLFIND = ocamlfind
CAMLC = $(OCAMLFIND) $(CAMLC_P) $(OPT) -package "$(PACKAGES)"
CAMLOPT = $(OCAMLFIND) $(CAMLOPT_P) $(OPT) -package "$(PACKAGES)"
......@@ -156,9 +169,9 @@ OBJECTS = \
driver/cduce_config.cmo misc/stats.cmo misc/custom.cmo misc/encodings.cmo \
misc/upool.cmo misc/pretty.cmo misc/ns.cmo misc/imap.cmo misc/html.cmo misc/utils.cmo \
\
types/compunit.cmo types/sortedList.cmo misc/bool.cmo types/ident.cmo \
types/compunit.cmo types/sortedList.cmo types/ident.cmo types/var.cmo types/bool.cmo \
types/intervals.cmo types/chars.cmo types/atoms.cmo types/normal.cmo \
types/var.cmo types/boolVar.cmo types/types.cmo compile/auto_pat.cmo \
types/types.cmo compile/auto_pat.cmo types/type_tallying.cmo \
types/sequence.cmo types/builtin_defs.cmo \
\
runtime/value.cmo \
......@@ -199,6 +212,9 @@ endif
ifneq ($(NETCLIENT), false)
OBJECTS += parser/cduce_netclient.cmo
PACKAGES += netclient
ifneq (($NETCLIENT4), false)
SYNTAX += -symbol HAS_NETCLIENT4=true
endif
endif
PXP_PACK=pxp-engine pxp-lex-iso88591
......@@ -304,12 +320,12 @@ compute_depend: $(DEPEND_OCAMLDEP)
clean:
for i in $(CLEAN_DIRS); do \
(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *~); \
(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *.cmt *.cmti *~); \
done
rm -f misc/q_symbol.cmo.stamp
test -n "$(OCAMLIFACE)" && (cd $(OCAMLIFACE); $(MAKE) clean) || true
rm -f `find . -name "*~"`
rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.o *~ META
rm -f *.cmi *.cmo *.cma *.cmx *.a *.cmxa *.cmt *.cmti *.o *~ META
rm -f cduce$(EXE) ocamlprof.dump
rm -f dtd2cduce$(EXE) webiface$(EXE) evaluator$(EXE)
rm -Rf prepro package
......@@ -342,9 +358,6 @@ misc/q_symbol.cmo: misc/q_symbol.ml
$(HIDE) $(CAMLC) -c -pp camlp4orf $<
types/boolVar.cmo: SYNTAX_PARSER=
types/boolVar.cmi: SYNTAX_PARSER=
types/boolVar.cmx: SYNTAX_PARSER=
parser/parser.$(EXTENSION): PACKAGES += camlp4.extend
.ml.cmo:
......@@ -365,6 +378,18 @@ include depend
cduceres.o: win32/cduce.rc win32/cduce_logo-bw.ico
(cd win32; windres -i cduce.rc -o cduceres.o; mv cduceres.o ..)
.merlin:
rm -f .merlin
for m in S B; do \
for i in $(DIRS); do \
echo "$$m $$i" >> .merlin; \
done; \
done; \
for p in $(PACKAGES); do \
echo "PKG $$p" >> .merlin; \
done
# Documentation
doc: cduce web/site.cdo
......
DIRS= cduce/misc cduce/types cduce/compile cduce/runtime
ML_SRC= \
cduce/misc/serialize.ml \
cduce/misc/custom.ml \
cduce/misc/encodings.ml \
cduce/misc/imap.ml \
cduce/misc/state.ml \
cduce/misc/pool.ml \
cduce/misc/ns.ml \
cduce/types/sortedList.ml \
cduce/types/atoms.ml \
cduce/misc/bool.ml \
cduce/types/chars.ml \
cduce/types/var.ml \
cduce/types/boolVar.ml \
cduce/types/ident.ml \
cduce/types/intervals.ml \
cduce/misc/inttbl.ml \
cduce/types/normal.ml \
cduce/misc/pretty.ml \
cduce/misc/stats.ml \
cduce/types/types.ml \
cduce/types/sequence.ml \
cduce/types/sample.ml \
cduce/types/patterns.ml \
cduce/compile/lambda.ml \
cduce/runtime/value.ml \
cduce/runtime/run_dispatch.ml \
cduce/runtime/explain.ml \
cduce/runtime/serial.ml
CMO_OBJECTS=$(ML_SRC:.ml=.cmo)
CMX_OBJECTS=$(ML_SRC:.ml=.cmx)
$(CMO_OBJECTS) $(CMX_OBJECTS): $(COMPILER)
$(CMX_OBJECTS): $(OPTCOMPILER)
cduce_types.cmo: $(CMO_OBJECTS)
$(CAMLC) $(COMPFLAGS) -pack -o cduce_types.cmo $(CDUCE_INCLUDES) $(CMO_OBJECTS)
cduce_types.cmx: $(CMX_OBJECTS)
$(CAMLOPT) $(OPTCOMPFLAGS) -pack -o cduce_types.cmx $(CDUCE_INCLUDES) $(CMX_OBJECTS)
cduce_types.p.cmx: cduce_types.cmx
cp cduce_types.cmx cduce_types.p.cmx
cp cduce_types.o cduce_types.p.o
CDUCE_INCLUDES = $(DIRS:%=-I %)
.SUFFIXES: .ml .mli .cmo .cmi .cmx
.ml.cmo:
$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) $<
.ml.cmx:
$(CAMLOPT) $(OPTCOMPFLAGS) -c $(CDUCE_INCLUDES) $<
.mli.cmi:
$(CAMLC) $(COMPFLAGS) -c $(CDUCE_INCLUDES) $<
.PHONY: compute_depend
compute_depend:
ocamldep $(CDUCE_INCLUDES) $(SRC) $(SRC:.ml=.mli) > cduce/types_depend
include cduce/types_depend
clean:
for i in $(DIRS); do \
(cd $$i; rm -f *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa *~); \
done
VERSION=1.0.0-alpha
VERSION=1.0.0-devel
\ No newline at end of file
true: -traverse
<{misc,types}/**>: traverse
<misc>: include
<types>: include
<parser>: include
<typing>: include
<compile>: include
<schema>: include
<runtime>: include
<{misc,types,typing,schema,compile,runtime,parser}/*.cmx>: for-pack(TypesOUnit)
<{misc,types}/*.cmx>: for-pack(BoolVarOUnit)
<parser/**>: package(ulex), package(netstring), package(camlp4.extend), syntax(camlp4o)
<schema/**>: package(pcre), package(netstring)
<runtime/**>: package(pcre), package(netstring)
<tests/libtest/*Test.*>: package(netstring), package(pcre), package(oUnit), package(ulex), package(num), package(camlp4.lib)
Upool
Serialize
Custom
Encodings
Imap
State
Pool
Ns
SortedList
Var
Atoms
Bool
Chars
Ident
Intervals
Inttbl
Normal
Pretty
Stats
BoolVar
......@@ -16,7 +16,7 @@ let pp_vars ppf vars =
Ident.pp_env pp_item ppf vars
let pp_xi ppf xi =
let pp_item ppf (s,t) = Format.fprintf ppf "%s : %a" s Var.Set.pp t in
let pp_item ppf (s,t) = Format.fprintf ppf "%s : %a" s Var.Set.print t in
Ident.pp_idmap pp_item ppf xi
let pp_env ppf env =
......@@ -75,14 +75,14 @@ let enter_global_cu cu env x =
let rec domain = function
|Identity -> Var.Set.empty
|List l -> Types.Tallying.domain l
|Comp (s1,s2) -> Var.Set.union (domain s1) (domain s2)
|List l -> Type_tallying.domain l
|Comp (s1,s2) -> Var.Set.cup (domain s1) (domain s2)
|Sel(_,_,sigma) -> (domain sigma)
let rec codomain = function
| Identity -> Var.Set.empty
| List(l) -> Types.Tallying.codomain l
| Comp(s1,s2) -> Var.Set.union (codomain s1) (codomain s2)
| List(l) -> Type_tallying.codomain l
| Comp(s1,s2) -> Var.Set.cup (codomain s1) (codomain s2)
| Sel(_,_,sigma) -> (codomain sigma)
let fresharg =
......@@ -111,7 +111,7 @@ let rec comp s1 s2 = match s1, s2 with
| res -> comp s3 (comp res s6))
(* If a variable in the image of s2 is in the domain of s1 we can't simplify *)
| _, _ when not (Var.Set.is_empty (Var.Set.inter (domain s1) (codomain s2)))
| _, _ when not (Var.Set.is_empty (Var.Set.cap (domain s1) (codomain s2)))
-> Comp(s1, s2)
| List(_), List(_) | Sel(_), List(_) ->
......@@ -135,8 +135,8 @@ and compile_aux env te = function
let is_mono x =
if Var.Set.is_empty ts then true else
let from_xi = try IdMap.assoc x env.xi with Not_found -> Var.Set.empty in
let d = Var.Set.inter from_xi (domain(env.sigma)) in
Var.Set.is_empty (Var.Set.inter ts d)
let d = Var.Set.cap from_xi (domain(env.sigma)) in
Var.Set.is_empty (Var.Set.cap ts d)
in
if is_mono x then Var (v) else TVar(v,env.sigma)
| Typed.Subst(e,sl) ->
......@@ -193,15 +193,15 @@ and compile_abstr env a =
List.fold_left(fun acc (t1,t2) ->
let ts1 = Types.all_vars t1 in
let ts2 = Types.all_vars t2 in
let tu = Var.Set.union ts1 ts2 in
Var.Set.union acc tu
let tu = Var.Set.cup ts1 ts2 in
Var.Set.cup acc tu
) Var.Set.empty a.Typed.fun_iface
in
if Var.Set.is_empty vars then true else
if env.sigma = Identity then false
else
let d = domain(env.sigma) in
Var.Set.is_empty (Var.Set.inter d vars)
Var.Set.is_empty (Var.Set.cap d vars)
in
let (slots,nb_slots,fun_env) =
(* we add a nameless empty slot for the argument *)
......@@ -258,7 +258,7 @@ and compile_branches env (brs : Typed.branches) =
(* p_i / t_i -> br.Typed.br_pat / br.Typed.br_type *)
and compile_branch env br =
let env = List.fold_left enter_local env (Patterns.fv br.Typed.br_pat) in
let env = List.fold_left enter_local env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
let env =
{ env with
xi = IdMap.merge (fun _ v2 -> v2) env.xi br.Typed.br_vars_poly
......@@ -278,7 +278,7 @@ let compile_expr env e =
let compile_let_decl env decl =
let pat = decl.Typed.let_pat in
let e,lsize = compile_expr env decl.Typed.let_body in
let env = enter_globals env (Patterns.fv pat) in
let env = enter_globals env (IdSet.get (Patterns.fv pat)) in
let te = decl.Typed.let_body.Typed.exp_typ in
let comp = Patterns.Compile.make_branches te [ pat, () ] in
......
......@@ -26,7 +26,7 @@ type iface = (Types.descr * Types.descr) list
type sigma =
| Identity (* this is basically as Types.Tallying.CS.sat *)
| List of Types.Tallying.CS.sl
| List of Types.Subst.t list
| Comp of (sigma * sigma)
| Sel of (var_loc * iface * sigma)
......@@ -104,7 +104,7 @@ module Print = struct
) ppf
in
function
|List ll -> Types.Tallying.CS.pp_sl ppf ll
|List ll -> Type_tallying.pp_sl ppf ll
|Comp(s1,s2) -> Format.fprintf ppf "Comp(%a,%a)" pp_sigma s1 pp_sigma s2
|Sel(x,iface,s) -> Format.fprintf ppf "Sel(%a,%a,%a)" pp_vloc x pp_aux iface pp_sigma s
|Identity -> Format.fprintf ppf "Id"
......
......@@ -26,7 +26,7 @@ type iface = (Types.t * Types.t) list
type sigma =
| Identity
| List of Types.Tallying.CS.sl
| List of Types.Subst.t list
| Comp of (sigma * sigma)
| Sel of (var_loc * iface * sigma)
......
......@@ -237,6 +237,17 @@ let cgidir = dir ~def:(wprefix^"/cgi-bin") "cgidir"
let htmldir = dir ~def:(wprefix^"/html") "htmldir"
let sessiondir = dir "sessiondir"
let netclient4 =
let res =
netclient &&
0 =
(Sys.command "echo 'open Nethttp_client' > test_netclient4.ml &&
ocamlfind ocamlc -o test_netclient4 -linkpkg -package \
netclient test_netclient4.ml")
in
ignore (Sys.command "rm -r test_netclient4.ml test_netclient4 test_netclient4.cm*");
res
let curl,netclient =
match curl,netclient with
| true,true ->
......@@ -276,6 +287,18 @@ let has_forpack =
else
(print "not available\n"; false)
let has_bin_annot =
print "testing for -bin-annot option: ";
let comm =
match Sys.os_type with
| "Win32" -> "ocamlc -bin-annot"
| _ -> "ocamlc -bin-annot 2> /dev/null" in
if Sys.command comm = 0 then
(print "available\n"; true)
else
(print "not available\n"; false)
let has_natdynlink =
print "testing for native dynlink: ";
if Sys.command "ocamlopt -o foo dynlink.cmxa && rm -f foo" = 0 then
......@@ -303,6 +326,7 @@ let () =
fprintf out "EXPAT=%b\n" expat;
fprintf out "CURL=%b\n" curl;
fprintf out "NETCLIENT=%b\n" netclient;
fprintf out "NETCLIENT4=%b\n" netclient4;
fprintf out "CGI=%b\n" cgi;
fprintf out "PXP_WLEX=%b\n" pxp_wlex;
fprintf out "BINDIR=%s\n" bindir;
......@@ -316,4 +340,5 @@ let () =
fprintf out "PROFILE=false\n";
fprintf out "FORPACK=%b\n" has_forpack;
fprintf out "NATDYNLINK=%b\n" has_natdynlink;
fprintf out "BIN_ANNOT=%b\n" has_bin_annot;
close_out out
This diff is collapsed.
......@@ -83,7 +83,8 @@ let directive_help ppf =
let directive_help_debug ppf =
Format.fprintf ppf
"Debug sub-directives:
#debug sybtype <type> <type> ;; check if t1 < t2 for all substitutions
#debug subtype <type> <type> ;; check if t1 < t2 for all substitutions
#debug bdd <type>;; dump the internal type representation
#debug typed <expr> ;; dump typed internal representation
#debug lambda <expr> ;; dump lambda internal representation
#debug accept <???> ;;
......@@ -201,6 +202,13 @@ let debug ppf tenv cenv = function
and t2 = Types.descr (Typer.typ tenv t2) in
let s = Types.subtype t1 t2 in
Format.fprintf ppf "%a %a %a : %b@." print_norm t1 print_protect "<=" print_norm t2 s
| `Bdd (t) ->
Format.fprintf ppf "[DEBUG:bdd]@.";
let t = Types.descr (Typer.typ tenv t) in
Format.fprintf ppf "@[%a@]@." Types.Print.dump t
| `Id_bdd (i) ->
Format.fprintf ppf "[DEBUG:id_bdd]@.";
Format.fprintf ppf "@[%a@]@." Types.Print.dump_by_id i
| `Sample t ->
Format.fprintf ppf "[DEBUG:sample]@.";
(try
......@@ -325,7 +333,6 @@ let catch_exn ppf_err exn =
Format.fprintf ppf_err "@."
let parse rule input =
Ulexer.toplevel := !toplevel;
try Parser.localize_exn (fun () -> rule input)
with e -> Parser.sync (); raise e
......@@ -408,4 +415,3 @@ let () =
| [ (None,v) ] -> v
| _ -> Value.failwith' "eval: the string must evaluate to a single value"
)
......@@ -103,6 +103,18 @@ let outflush s =
output_string stdout s;
flush stdout
let has_newline b =
let rec loop i found =
if i >= 1 then
let c = Buffer.nth b i in
if c == ';' && Buffer.nth b (i-1) == ';'
then found
else loop (i - 1) (c == '\n')
else false
in
loop (Buffer.length b - 1) false
let toploop () =
let restore =
try
......@@ -141,6 +153,8 @@ let toploop () =
bol := false;
Buffer.clear buf_in;
ignore (Cduce.topinput ppf ppf_err input);
if not (has_newline buf_in) then
(* ";;\n" was eaten by a regular expression in the lexer *)
while (input_char stdin != '\n') do () done;
loop () in
(try loop () with End_of_file -> ());
......
This diff is collapsed.
module type S =
sig
include Custom.T
type elem
val get: t -> (elem list * elem list) list
val get': t -> (elem list * (elem list) list) list
val empty : t
val full : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val atom : elem -> t
val iter: (elem-> unit) -> t -> unit
val compute: empty:'b -> full:'b -> cup:('b -> 'b -> 'b)
-> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
atom:(elem -> 'b) -> t -> 'b
(*
val print: string -> (Format.formatter -> elem -> unit) -> t ->
(Format.formatter -> unit) list
*)
val trivially_disjoint : t -> t -> bool
end
module type MAKE = functor (X : Custom.T) -> S with type elem = X.t
module Make : MAKE
(*
module type S' = sig
include S
type bdd = False | True | Br of elem * t * t
val br: t -> bdd
end
module MakeBdd(X : Custom.T) : S' with type elem = X.t
module type S'' = sig
include S
val dnf: (elem list -> (elem list) list -> unit) -> t -> unit
end
module Make2(X : Custom.T) : S'' with type elem = X.t
*)
......@@ -108,20 +108,20 @@ module Array(X : T) = struct
end
module List(X : T) = struct
module Elem = X
type t = X.t list
let dump = dump_list X.dump
let check l = List.iter X.check l
module Elem : T with type t = X.t = X
type t = Elem.t list
let dump = dump_list Elem.dump
let check l = List.iter Elem.check l
let rec equal l1 l2 =
(l1 == l2) ||
match (l1,l2) with
| x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2)
| x1::l1, x2::l2 -> (Elem.equal x1 x2) && (equal l1 l2)
| _ -> false
let rec hash accu = function
| [] -> 1 + accu
| x::l -> hash (17 * accu + X.hash x) l
| x::l -> hash (17 * accu + Elem.hash x) l
let hash l = hash 1 l
......@@ -129,7 +129,7 @@ module List(X : T) = struct
if l1 == l2 then 0
else match (l1,l2) with
| x1::l1, x2::l2 ->
let c = X.compare x1 x2 in if c <> 0 then c
let c = Elem.compare x1 x2 in if c <> 0 then c
else compare l1 l2
| [],_ -> -1
| _ -> 1
......
......@@ -2,20 +2,43 @@ open Camlp4.PreCast
module Caml_syntax = Syntax
let symbols = ref []
let debug_symbols = ref []
let debug = ref false
let split_string c s =
let res = ref [] in
let buff = Buffer.create 32 in
let add s = if s <> "" then res:= s :: !res in
for i = 0 to String.length s - 1 do
match s.[i] with
d when d == c -> let f = Buffer.contents buff in
Buffer.clear buff; add f
| ('a'..'z' | '0'..'9' | '_' | 'A'..'Z') as d -> Buffer.add_char buff d
| _ -> ()
done;
let f = Buffer.contents buff in
add f;
!res
let define s =
let i =
try String.index s '='
with Not_found -> failwith ("Invalid symbol definition :" ^ s) in
let symbol = String.sub s 0 i in
let value_str = String.sub s (i + 1) (String.length s - i - 1) in
let value =
Gram.parse_string
Caml_syntax.expr (Loc.mk "<from-string>") (String.sub s (i + 1) (String.length s - i - 1))
Caml_syntax.expr (Loc.mk "<from-string>") value_str
in
symbols := (symbol, value) :: !symbols
symbols := (symbol, value) :: !symbols;
if symbol = "cduce_debug" then begin
debug := true;
let l = split_string ',' value_str in
debug_symbols := l @ !debug_symbols
end
EXTEND Caml_syntax.Gram
GLOBAL: Caml_syntax.str_item;
GLOBAL: Caml_syntax.str_item Caml_syntax.expr;
Caml_syntax.str_item: FIRST
[ [ "ifdef"; c = UIDENT; "then"; e1 = SELF;
......@@ -29,6 +52,20 @@ EXTEND Caml_syntax.Gram
| "ifndef"; c = UIDENT; "then"; e1 = SELF ->
if List.mem_assoc c !symbols then <:str_item<>> else e1
] ];
Caml_syntax.expr: BEFORE "simple"
[ [
"DEBUG" ; x = OPT [ x = LIDENT -> x ]; "("; e = Caml_syntax.expr; ")" ->