Commit dc3fd463 authored by Pietro Abate's avatar Pietro Abate

[r2002-10-16 16:18:48 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-16 16:18:48+00:00
parent 128c2bfa
......@@ -2,10 +2,10 @@ 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
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo parser/location.cmi types/types.cmi \
parser/parser.cmi
parser/parser.cmx: parser/ast.cmx parser/location.cmx types/types.cmx \
parser/parser.cmi
parser/parser.cmo: parser/ast.cmo types/chars.cmi parser/location.cmi \
types/types.cmi parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/chars.cmx parser/location.cmx \
types/types.cmx parser/parser.cmi
parser/parser.cmi: parser/ast.cmo
typing/typed.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
typing/typed.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
......@@ -38,17 +38,17 @@ types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
types/strings.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmi
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/intervals.cmi \
types/recursive.cmi types/sortedList.cmi types/sortedMap.cmi \
types/strings.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/intervals.cmx \
types/recursive.cmx types/sortedList.cmx types/sortedMap.cmx \
types/strings.cmx types/types.cmi
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi types/recursive.cmi types/sortedList.cmi \
types/sortedMap.cmi types/strings.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/recursive.cmx types/sortedList.cmx \
types/sortedMap.cmx types/strings.cmx types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/sortedMap.cmi types/strings.cmi
types/types.cmi: types/chars.cmi types/sortedMap.cmi types/strings.cmi
driver/cduce.cmo: parser/ast.cmo parser/location.cmi parser/parser.cmi \
typing/typer.cmi types/types.cmi
driver/cduce.cmx: parser/ast.cmx parser/location.cmx parser/parser.cmx \
......
......@@ -28,9 +28,19 @@ let phrase ph =
let (fv,e) = Typer.expr e in
let t = Typer.compute_type Typer.Env.empty e in
Format.fprintf ppf "%a@\n" Types.Print.print_descr t;
| Ast.TypeDecl _ -> ()
| _ -> assert false
let () =
try List.iter phrase (prog ())
try
let p = prog () in
let type_decls =
List.fold_left
(fun accu ph -> match ph.descr with
| Ast.TypeDecl (x,t) -> (x,t) :: accu
| _ -> accu
) [] p in
Typer.register_global_types type_decls;
List.iter phrase p
with exn -> print_exn ppf exn
......@@ -24,7 +24,12 @@ open Ast
GLOBAL: prog expr pat regexp const;
prog: [
[ l = LIST0 [ e = expr; ";;" -> mk loc (EvalStatement e) ] -> l ]
[ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; ";;" -> l ]
];
phrase: [
[ e = expr -> EvalStatement e
| "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
];
expr: [
......@@ -114,6 +119,8 @@ open Ast
| i = INT ; "--"; j = INT ->
let i = int_of_string i and j = int_of_string j in
mk loc (Internal (Types.interval i j))
| i = char ; "--"; j = char ->
mk loc (Internal (Types.char_class i j))
| c = const -> mk loc (Internal (Types.constant c))
| "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
| "["; r = [ r = regexp -> r | -> Epsilon ];
......@@ -137,11 +144,19 @@ open Ast
| h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
] ];
char:
[
[ c = CHAR -> Chars.Unichar.from_char (Token.eval_char c)
| "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
];
const:
[
[ i = INT -> Types.Integer (int_of_string i)
| x = STRING -> Types.String (Token.eval_string x)
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a) ]
| "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a)
| c = char -> Types.Char c ]
];
tag_spec:
......
......@@ -8,6 +8,9 @@ module Unichar = struct
failwith "Chars.from_int: code point out of bound";
c
let from_char c =
Char.code c
let to_int c = c
let print ppf c =
......@@ -30,8 +33,9 @@ let to_int c = c
let empty = []
let full = [0,max_char]
let char_class (a,b) =
if a<=b then [a,b] else empty
let char_class a b = if a<=b then [a,b] else empty
let atom a = [a,a]
let rec add l ((a,b) as i) = match l with
| [] ->
......
module Unichar : sig
type t
val from_int: int -> t
val from_char: char -> t
val to_int: t -> int
val print : Format.formatter -> t -> unit
end
......@@ -12,7 +14,8 @@ val full : t
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val char_class : Unichar.t * Unichar.t -> t
val char_class : Unichar.t -> Unichar.t -> t
val atom : Unichar.t -> t
val is_empty : t -> bool
......
......@@ -6,7 +6,7 @@ open Printf
type label = int
type atom = int
type const = Integer of int | Atom of atom | String of string
type const = Integer of int | Atom of atom | String of string | Char of Chars.Unichar.t
module I = struct
type 'a t = {
......@@ -15,6 +15,7 @@ module I = struct
times : ('a * 'a) Boolean.t;
arrow : ('a * 'a) Boolean.t;
record: (label * bool * 'a) Boolean.t;
chars : Chars.t;
strs : Strings.t;
}
......@@ -24,6 +25,7 @@ module I = struct
record= Boolean.empty;
ints = Intervals.empty;
atoms = Atoms.empty;
chars = Chars.empty;
strs = Strings.empty;
}
let any = {
......@@ -32,6 +34,7 @@ module I = struct
record= Boolean.full;
ints = Intervals.full;
atoms = Atoms.full;
chars = Chars.full;
strs = Strings.any;
}
......@@ -41,10 +44,13 @@ module I = struct
let record label opt t = { empty with record = Boolean.atom (label,opt,t) }
let atom a = { empty with atoms = Atoms.atom a }
let string r = { empty with strs = Strings.Regexp.compile r }
let char c = { empty with chars = Chars.atom c }
let char_class c1 c2 = { empty with chars = Chars.char_class c1 c2 }
let constant = function
| Integer i -> interval i i
| Atom a -> atom a
| String s -> string (Strings.Regexp.str s)
| Char c -> char c
let any_record = { empty with record = any.record }
......@@ -56,6 +62,7 @@ module I = struct
record= Boolean.cup x.record y.record;
ints = Intervals.cup x.ints y.ints;
atoms = Atoms.cup x.atoms y.atoms;
chars = Chars.cup x.chars y.chars;
strs = Strings.cup x.strs y.strs;
}
......@@ -66,6 +73,7 @@ module I = struct
arrow = Boolean.cap x.arrow y.arrow;
ints = Intervals.cap x.ints y.ints;
atoms = Atoms.cap x.atoms y.atoms;
chars = Chars.cap x.chars y.chars;
strs = Strings.cap x.strs y.strs;
}
......@@ -76,6 +84,7 @@ module I = struct
record= Boolean.diff x.record y.record;
ints = Intervals.diff x.ints y.ints;
atoms = Atoms.diff x.atoms y.atoms;
chars = Chars.diff x.chars y.chars;
strs = Strings.diff x.strs y.strs;
}
......@@ -84,6 +93,7 @@ module I = struct
let equal e a b =
if a.ints <> b.ints then raise NotEqual;
if a.atoms <> b.atoms then raise NotEqual;
if a.chars <> b.chars then raise NotEqual;
if a.strs <> b.strs then raise NotEqual;
Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;
Boolean.equal (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow;
......@@ -97,6 +107,7 @@ module I = struct
record= Boolean.map (fun (l,o,x) -> (l,o, f x)) a.record;
ints = a.ints;
atoms = a.atoms;
chars = a.chars;
strs = a.strs;
}
......@@ -220,6 +231,7 @@ let rec empty_rec d =
else if Assumptions.mem d !memo then true
else if not (Intervals.is_empty d.ints) then false
else if not (Atoms.is_empty d.atoms) then false
else if not (Chars.is_empty d.chars) then false
else if not (Strings.is_empty d.strs) then false
else (
let backup = !memo in
......@@ -298,6 +310,7 @@ let rec find f = function
type t =
| Int of int
| Atom of atom
| Char of Chars.Unichar.t
| String of string
| Pair of t * t
| Record of (label * t) list
......@@ -311,6 +324,7 @@ let rec sample_rec memo d =
else
try Int (Intervals.sample d.ints) with Not_found ->
try Atom (Atoms.sample (gen_atom 0) d.atoms) with Not_found ->
try Char (Chars.sample d.chars) with Not_found ->
try String (Strings.sample d.strs) with Not_found ->
try sample_rec_arrow d.arrow with Not_found ->
......@@ -604,6 +618,7 @@ struct
if d = any then Format.fprintf ppf "Any" else
print_union ppf
(Intervals.print d.ints @
Chars.print d.chars @
Strings.print d.strs @
Atoms.print "AnyAtom" print_atom d.atoms @
Boolean.print "(Any,Any)" print_times d.times @
......@@ -653,6 +668,7 @@ struct
let rec print_sample ppf = function
| Sample.Int i -> Format.fprintf ppf "%i" i
| Sample.Atom a -> Format.fprintf ppf "`%s" (atom_name a)
| Sample.Char c -> Chars.Unichar.print ppf c
| Sample.String s -> Format.fprintf ppf "%S" s
| Sample.Pair (x1,x2) ->
Format.fprintf ppf "(%a,%a)"
......
type label = int
type atom = int
type const = Integer of int | Atom of atom | String of string
type const = Integer of int | Atom of atom | String of string | Char of Chars.Unichar.t
(** Algebra **)
......@@ -33,6 +33,8 @@ val atom : atom -> descr
val times : node -> node -> descr
val arrow : node -> node -> descr
val record : label -> bool -> node -> descr
val char : Chars.Unichar.t -> descr
val char_class : Chars.Unichar.t -> Chars.Unichar.t -> descr
val string : Strings.Regexp.regexp -> descr
val constant : const -> descr
......@@ -126,6 +128,7 @@ sig
type t =
| Int of int
| Atom of atom
| Char of Chars.Unichar.t
| String of string
| Pair of t * t
| Record of (label * t) list
......
......@@ -42,11 +42,11 @@ module StringSet = Set.Make(S)
let mk' =
let counter = ref 0 in
fun () ->
fun loc ->
incr counter;
let rec x = {
id = !counter;
loc' = noloc;
loc' = loc;
fv = None;
descr' = `Alias ("__dummy__", x);
type_node = None;
......@@ -55,8 +55,7 @@ let mk' =
x
let cons loc d =
let x = mk' () in
x.loc' <- loc;
let x = mk' loc in
x.descr' <- d;
x
......@@ -158,14 +157,7 @@ let rec compile env { loc = loc; descr = d } : ti =
with Not_found ->
raise_loc loc (Pattern ("Undefined type variable " ^ s))
)
| Recurs (t, b) ->
let b = List.map (fun (v,t) -> (v,t,mk' ())) b in
let env =
List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
List.iter
(fun (v,t,x) -> x.loc' <- t.loc; x.descr' <- `Alias (v, compile env t))
b;
compile env t
| Recurs (t, b) -> compile (compile_many env b) t
| Regexp (r,q) -> compile env (Regexp.compile r q)
| Internal t -> cons loc (`Type t)
| Or (t1,t2) -> cons loc (`Or (compile env t1, compile env t2))
......@@ -177,6 +169,14 @@ let rec compile env { loc = loc; descr = d } : ti =
| Constant (x,v) -> cons loc (`Constant (x,v))
| Capture x -> cons loc (`Capture x)
and compile_many env b =
let b = List.map (fun (v,t) -> (v,t,mk' t.loc)) b in
let env =
List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
env
let rec comp_fv seen s =
match s.fv with
| Some l -> l
......@@ -266,16 +266,24 @@ and pat_node s : Patterns.node =
Patterns.define x t;
x
let typ e =
let e = compile StringMap.empty e in
let global_types = ref StringMap.empty
let mk_typ e =
if fv e = [] then type_node e
else (raise_loc e.loc'
(Pattern "Capture variables are not allowed in types"))
else raise_loc e.loc' (Pattern "Capture variables are not allowed in types")
let typ e =
mk_typ (compile !global_types e)
let pat e =
let e = compile StringMap.empty e in
let e = compile !global_types e in
pat_node e
let register_global_types b =
let env = compile_many !global_types b in
List.iter (fun (v,_) -> ignore (mk_typ (StringMap.find v env))) b;
global_types := env
(* II. Build skeleton *)
......
......@@ -4,6 +4,9 @@ exception Constraint of Types.descr * Types.descr * string
val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat
val register_global_types : (string * Ast.ppat) list -> unit
(* the global environment is untouched if the function fails *)
val typ : Ast.ppat -> Typed.ttyp
val pat : Ast.ppat -> Typed.tpat
......
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