Skip to content

GitLab

Commit 45245d35 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-06 07:46:53 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-11-06 07:47:30+00:00
parent 8154cdfc
Hide whitespace changes
Inline Side-by-side
Makefile
View file @ 45245d35
# Source directories
DIRS = parser typing types runtime driver
DIRS = misc parser typing types runtime driver
CLEAN_DIRS = $(DIRS) tools tests
# Objects to build
MISC = misc/pool.cmo
PARSER = parser/lexer.cmo parser/location.cmo parser/ast.cmo parser/parser.cmo
TYPING = typing/typed.cmo typing/typer.cmo
......@@ -27,7 +29,7 @@ DRIVER = driver/cduce.cmo
TOPLEVEL = toplevel/toploop.cmo
OBJECTS = $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
OBJECTS = $(MISC) $(TYPES) $(PARSER) $(TYPING) $(RUNTIME)
XOBJECTS = $(OBJECTS:.cmo=.cmx)
XDRIVER = $(DRIVER:.cmo=.cmx)
......
depend
View file @ 45245d35
misc/pool.cmo: misc/pool.cmi
misc/pool.cmx: misc/pool.cmi
parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
......@@ -47,19 +49,27 @@ types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi types/recursive.cmo types/recursive_noshare.cmo \
types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/intervals.cmi misc/pool.cmi types/recursive.cmo \
types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/recursive.cmx types/recursive_noshare.cmx \
types/sortedList.cmx types/sortedMap.cmx types/types.cmi
runtime/eval.cmo: runtime/load_xml.cmi runtime/run_dispatch.cmi \
typing/typed.cmo types/types.cmi runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: runtime/load_xml.cmx runtime/run_dispatch.cmx \
typing/typed.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi
types/intervals.cmx misc/pool.cmx types/recursive.cmx \
types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
types/types.cmi
runtime/eval.cmo: runtime/load_xml.cmi runtime/print_xml.cmo \
runtime/run_dispatch.cmi typing/typed.cmo types/types.cmi \
runtime/value.cmi runtime/eval.cmi
runtime/eval.cmx: runtime/load_xml.cmx runtime/print_xml.cmx \
runtime/run_dispatch.cmx typing/typed.cmx types/types.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/sortedMap.cmi types/types.cmi runtime/value.cmi \
runtime/load_xml.cmi
runtime/load_xml.cmx: types/sortedMap.cmx types/types.cmx runtime/value.cmx \
runtime/load_xml.cmi
runtime/print_xml.cmo: types/chars.cmi types/sequence.cmi types/types.cmi \
runtime/value.cmi
runtime/print_xml.cmx: types/chars.cmx types/sequence.cmx types/types.cmx \
runtime/value.cmx
runtime/run_dispatch.cmo: types/patterns.cmi types/types.cmi \
runtime/value.cmi runtime/run_dispatch.cmi
runtime/run_dispatch.cmx: types/patterns.cmx types/types.cmx \
......@@ -82,7 +92,7 @@ types/sequence.cmi: types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sortedMap.cmi
misc/pool.cmi
runtime/eval.cmi: typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
......
driver/cduce.ml
View file @ 45245d35
......@@ -34,12 +34,12 @@ let rec print_exn ppf = function
Value.print v
| Typer.WrongLabel (t,l) ->
Format.fprintf ppf "Wrong record selection: the label %s@\n"
(Types.label_name l);
(Types.LabelPool.value l);
Format.fprintf ppf "applied to an expression of type %a@\n"
print_norm t
| Typer.MultipleLabel l ->
Format.fprintf ppf "Multiple occurences for the record label %s@\n"
(Types.label_name l);
(Types.LabelPool.value l);
| Typer.ShouldHave (t,msg) ->
Format.fprintf ppf "This expression should have type %a@\n%s@\n"
print_norm t
......@@ -94,7 +94,7 @@ let debug = function
| `Any -> Format.fprintf ppf "Any"
| `Label l ->
let (pr,ab) = Types.Record.normal' t l in
Format.fprintf ppf "Label (%s,@[" (Types.label_name l);
Format.fprintf ppf "Label (%s,@[" (Types.LabelPool.value l);
List.iter (fun (d,n) ->
Format.fprintf ppf "%a => @[%a@];@\n"
Types.Print.print_descr d
......
parser/parser.ml
View file @ 45245d35
......@@ -91,7 +91,8 @@ EXTEND
[ e1 = expr; op = ["*" | "/"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
]
|
[ e = expr; "."; l = [LIDENT | UIDENT] -> mk loc (Dot (e,Types.label l))
[ e = expr; "."; l = [LIDENT | UIDENT] ->
mk loc (Dot (e,Types.LabelPool.mk l))
]
|
......@@ -254,7 +255,7 @@ EXTEND
[ [ r = LIST0 [ l = [LIDENT | UIDENT];
o = ["=?" -> true | "=" -> false];
x = pat ->
mk loc (Record (Types.label l,o,x))
mk loc (Record (Types.LabelPool.mk l,o,x))
] SEP ";" ->
match r with
| [] -> mk loc (Internal Types.Record.any)
......@@ -271,7 +272,7 @@ EXTEND
const:
[
[ i = INT -> Types.Integer (Big_int.big_int_of_string i)
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a)
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.AtomPool.mk a)
| c = char -> Types.Char c ]
];
......@@ -279,7 +280,7 @@ EXTEND
[
[ LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any))) ]
| [ a = [LIDENT | UIDENT] ->
mk loc (Internal (Types.atom (Atoms.atom (Types.mk_atom a)))) ]
mk loc (Internal (Types.atom (Atoms.atom (Types.AtomPool.mk a)))) ]
| [ t = pat -> t ]
];
......@@ -288,7 +289,8 @@ EXTEND
expr_record_spec:
[ [ r = LIST1
[ l = [LIDENT | UIDENT]; "="; x = expr -> (Types.label l,x) ]
[ l = [LIDENT | UIDENT]; "="; x = expr ->
(Types.LabelPool.mk l,x) ]
SEP ";" ->
mk loc (RecordLitt r)
] ];
......@@ -296,7 +298,7 @@ EXTEND
expr_tag_spec:
[
[ a = [LIDENT | UIDENT] ->
mk loc (Cst (Types.Atom (Types.mk_atom a))) ]
mk loc (Cst (Types.Atom (Types.AtomPool.mk a))) ]
| [ e = expr LEVEL "no_appl" -> e ]
];
......
runtime/eval.ml
View file @ 45245d35
......@@ -8,8 +8,9 @@ let global_env = ref Env.empty
let enter_global x v = global_env := Env.add x v !global_env
let exn_int_of = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),
string "int_of"))
let exn_int_of = CDuceExn (Pair (
Atom (Types.AtomPool.mk "Invalid_argument"),
string "int_of"))
......
runtime/load_xml.ml
View file @ 45245d35
......@@ -31,12 +31,12 @@ let run s =
| None -> () in
let rec parse_elt name att =
let att = List.map (fun (l,v) -> Types.label l, string v nil) att in
let att = List.map (fun (l,v) -> Types.LabelPool.mk l, string v nil) att in
let att = SortedMap.from_list (fun _ _ -> assert false) att in
let child = parse_seq () in
let elt = Pair
(Atom (Types.mk_atom name),
(Atom (Types.AtomPool.mk name),
Pair (Record att, child)
) in
(match !curr with
......
runtime/print_xml.ml
View file @ 45245d35
......@@ -4,8 +4,9 @@ open Pxp_aux
open Pxp_types
open Value
let exn_print_xml = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),
string "print_xml"))
let exn_print_xml = CDuceExn (Pair (
Atom (Types.AtomPool.mk "Invalid_argument"),
string "print_xml"))
let to_enc = `Enc_iso88591
......@@ -38,11 +39,11 @@ let string_of_xml v=
let rec print_elt = function
| Pair (Atom tag, Pair (Record attrs, content)) ->
let tag = Types.atom_name tag in
let tag = Types.AtomPool.value tag in
element_start tag
(List.map (fun (n,v) ->
if not (is_str v) then raise exn_print_xml;
(Types.label_name n,get_string v)) attrs);
(Types.LabelPool.value n,get_string v)) attrs);
print_content content;
element_end tag
| Char x ->
......
runtime/value.ml
View file @ 45245d35
......@@ -53,7 +53,7 @@ let rec print ppf v =
else match v with
| Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
| Record l -> Format.fprintf ppf "{%a }" print_record l
| Atom a -> Format.fprintf ppf "`%s" (Types.atom_name a)
| Atom a -> Format.fprintf ppf "`%s" (Types.AtomPool.value a)
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Char c -> Chars.Unichar.print ppf c
| Abstraction _ -> Format.fprintf ppf "<fun>"
......@@ -89,7 +89,7 @@ and print_str ppf = function
and print_xml ppf = function
| Pair(Atom tag, Pair (Record attr,content)) ->
Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]"
(Types.atom_name tag)
(Types.AtomPool.value tag)
print_record attr
print_seq content
| _ -> assert false
......@@ -100,7 +100,7 @@ and print_record ppf = function
| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
and print_field ppf (l,v) =
Format.fprintf ppf "%s=%a" (Types.label_name l) print v
Format.fprintf ppf "%s=%a" (Types.LabelPool.value l) print v
let normalize = function
......
types/patterns.ml
View file @ 45245d35
......@@ -701,16 +701,15 @@ struct
return disp pl aux_final
let dummy_label = Types.label ""
let dummy_label = Types.LabelPool.dummy_max
let collect_first_label pl =
let f = ref true and m = ref dummy_label in
let aux = function
| (res, _, `Label (l, _, _)) ->
if (!f) then (f := false; m := l) else if (l < !m) then m:= l;
| (res, _, `Label (l, _, _)) -> if (l < !m) then m:= l;
| _ -> () in
Array.iter (List.iter aux) pl;
if !f then None else Some !m
if !m = dummy_label then None else Some !m
let map_record f =
let rec aux = function
......@@ -738,7 +737,7 @@ struct
| `Success -> Format.fprintf ppf "Success"
| `Fail -> Format.fprintf ppf "Fail"
| `Label (l,pr,ab) ->
Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.label_name l)
Format.fprintf ppf "Label (%s,pr=%a,ab=%a)" (Types.LabelPool.value l)
print_normal_record_pr pr
print_normal_record ab
| _ -> assert false
......@@ -756,7 +755,7 @@ struct
List.iter (fun (x,s) -> Format.fprintf ppf "%s," x) res;
Format.fprintf ppf "Catch:";
List.iter (fun (l,r) ->
Format.fprintf ppf "%s[" (Types.label_name l);
Format.fprintf ppf "%s[" (Types.LabelPool.value l);
List.iter (fun (x,i) ->
Format.fprintf ppf "%s->%i" x i) r;
Format.fprintf ppf "]"
......@@ -852,14 +851,14 @@ struct
| `Const c -> Types.Print.print_const ppf c
| `Left (-1) -> Format.fprintf ppf "v1"
| `Right (-1) -> Format.fprintf ppf "v2"
| `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.label_name l)
| `Field (l,-1) -> Format.fprintf ppf "v%s" (Types.LabelPool.value l)
| `Left i -> Format.fprintf ppf "l%i" i
| `Right j -> Format.fprintf ppf "r%i" j
| `Recompose (i,j) ->
Format.fprintf ppf "(%a,%a)"
print_source (`Left i)
print_source (`Right j)
| `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
| `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.LabelPool.value l) i
let print_result ppf =
Array.iteri
......@@ -936,7 +935,7 @@ struct
| `Result r -> print_ret ppf r
| `Absent -> Format.fprintf ppf "Jump to Absent"
| `Label (l, present, absent) ->
let l = Types.label_name l in
let l = Types.LabelPool.value l in
Format.fprintf ppf "check label %s:@\n" l;
Format.fprintf ppf "Present => @[%a@]@\n" (print_present l) present;
match absent with
......
types/sequence.ml
View file @ 45245d35
let nil_atom = Types.mk_atom "nil"
let nil_atom = Types.AtomPool.mk "nil"
let nil_type = Types.atom (Atoms.atom nil_atom)
let decompose t =
......
types/types.ml
View file @ 45245d35
......@@ -5,27 +5,18 @@ open Printf
let map_sort f l =
SortedList.from_list (List.map f l)
type label = int
type atom = int
let counter_label = ref 0
let label_table = Hashtbl.create 63
let label_names = Hashtbl.create 63
let label s =
try Hashtbl.find label_table s
with Not_found ->
incr counter_label;
Hashtbl.add label_table s !counter_label;
Hashtbl.add label_names !counter_label s;
!counter_label
let label_name l =
Hashtbl.find label_names l
module HashedString =
struct
type t = string
let hash = Hashtbl.hash
let equal = (=)
end
let mk_atom = label
module LabelPool = Pool.Make(HashedString)
module AtomPool = Pool.Make(HashedString)
let atom_name = label_name
type label = LabelPool.t
type atom = AtomPool.t
type const = Integer of Big_int.big_int | Atom of atom | Char of Chars.Unichar.t
......@@ -168,7 +159,8 @@ let cons d =
module Print =
struct
let print_atom ppf a = Format.fprintf ppf "`%s" (atom_name a)
let print_atom ppf a =
Format.fprintf ppf "`%s" (AtomPool.value a)
let print_const ppf = function
| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
......@@ -245,7 +237,7 @@ struct
Format.fprintf ppf "@[(%a -> %a)@]" print t1 print t2
and print_record ppf (l,o,t) =
Format.fprintf ppf "@[{ %s =%s %a }@]"
(label_name l) (if o then "?" else "") print t
(LabelPool.value l) (if o then "?" else "") print t
let end_print ppf =
......@@ -431,14 +423,13 @@ type t =
| Record of (label * t) list
| Fun of (node * node) list
let rec gen_atom i l =
if SortedList.mem l i then gen_atom (succ i) l else i
let rec sample_rec memo d =
if (Assumptions.mem d memo) || (is_empty d) then raise Not_found
else
try Int (Intervals.sample d.ints) with Not_found ->
try Atom (Atoms.sample (gen_atom 0) d.atoms) with Not_found ->
try Atom (Atoms.sample (fun _ -> AtomPool.dummy_min) d.atoms) with
Not_found ->
(* Here: could create a fresh atom ... *)
try Char (Chars.sample d.chars) with Not_found ->
try sample_rec_arrow d.arrow with Not_found ->
......@@ -506,7 +497,11 @@ let get x = sample_rec Assumptions.empty x
let rec print ppf = function
| Int i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
| Atom a -> Format.fprintf ppf "`%s" (atom_name a)
| Atom a ->
if a = LabelPool.dummy_min then
Format.fprintf ppf "(almost any atom)"
else
Format.fprintf ppf "`%s" (AtomPool.value a)
| Char c -> Chars.Unichar.print ppf c
| Pair (x1,x2) -> Format.fprintf ppf "(%a,%a)" print x1 print x2
| Record r ->
......@@ -514,7 +509,7 @@ let get x = sample_rec Assumptions.empty x
(print_sep
(fun ppf (l,x) ->
Format.fprintf ppf "%s = %a"
(label_name l)
(LabelPool.value l)
print x
)
" ; "
......
types/types.mli
View file @ 45245d35
type label = int
type atom = int
module LabelPool : Pool.T with type value = string
module AtomPool : Pool.T with type value = string
type label = LabelPool.t
type atom = AtomPool.t
type const = Integer of Big_int.big_int | Atom of atom | Char of Chars.Unichar.t
(** Algebra **)
......@@ -59,14 +61,6 @@ sig
val solve: v -> node
end
(** Labels and atom names **)
val mk_atom : string -> atom
val atom_name : atom -> string
val label : string -> label
val label_name : label -> string
(** Normalization **)
module Product : sig
......
typing/typer.ml
View file @ 45245d35
......@@ -154,9 +154,8 @@ module Regexp = struct
v
let atom_nil = Types.mk_atom "nil"
let constant_nil v t =
mk noloc (And (t, (mk noloc (Constant (v, Types.Atom atom_nil))), true))
mk noloc (And (t, (mk noloc (Constant (v, Types.Atom Sequence.nil_atom))), true))
let compile regexp queue : ppat =
let vars = seq_vars StringSet.empty regexp in
......@@ -518,7 +517,7 @@ and type_check' loc env e constr precise = match e with
raise_loc loc
(ShouldHave (constr,(Printf.sprintf
"Field %s is not allowed here."
(Types.label_name l)
(Types.LabelPool.value l)
)
));
let t = type_check env e pi true in
......
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