Skip to content

GitLab

Commit 7cf0335b authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-17 11:34:45 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-11-17 11:34:45+00:00
parent dd8dc14f
Hide whitespace changes
Inline Side-by-side
parser/wlexer.ml
View file @ 7cf0335b
......@@ -98,35 +98,38 @@ let lex_tables = {
\005\000\254\255\014\000\013\000\001\000\004\000\253\255\255\255\
\247\255\246\255\019\000\047\000\051\000\017\000\043\000\250\255\
\027\000\010\000\001\000\022\000\016\000\249\255\248\255\250\255\
\058\000\061\000\053\000\065\000\081\000\070\000";
\058\000\061\000\059\000\063\000\071\000\073\000\083\000\081\000\
\067\000";
Lexing.lex_backtrk =
"\255\255\255\255\255\255\255\255\255\255\255\255\004\000\255\255\
\002\000\255\255\004\000\002\000\004\000\004\000\255\255\255\255\
\255\255\255\255\000\000\001\000\002\000\003\000\005\000\255\255\
\005\000\005\000\005\000\005\000\005\000\255\255\255\255\255\255\
\255\255\004\000\003\000\002\000\001\000\000\000";
\255\255\004\000\255\255\003\000\002\000\255\255\001\000\255\255\
\000\000";
Lexing.lex_default =
"\023\000\005\000\005\000\005\000\000\000\000\000\255\255\000\000\
\255\255\000\000\255\255\255\255\255\255\255\255\000\000\000\000\
\000\000\000\000\255\255\255\255\255\255\255\255\255\255\000\000\
\255\255\255\255\255\255\255\255\255\255\000\000\000\000\000\000\
\255\255\255\255\255\255\255\255\255\255\255\255";
\255\255\255\255\033\000\255\255\255\255\036\000\255\255\038\000\
\255\255";
Lexing.lex_trans =
"\016\000\017\000\017\000\018\000\019\000\020\000\021\000\019\000\
\022\000\004\000\008\000\008\000\004\000\024\000\025\000\026\000\
\027\000\026\000\004\000\011\000\011\000\015\000\037\000\034\000\
\027\000\026\000\004\000\011\000\011\000\015\000\040\000\035\000\
\031\000\028\000\012\000\009\000\026\000\031\000\029\000\031\000\
\029\000\030\000\013\000\009\000\009\000\031\000\031\000\014\000\
\031\000\014\000\007\000\010\000\009\000\009\000\032\000\033\000\
\033\000\006\000\007\000\036\000\036\000\036\000\036\000\035\000\
\035\000\035\000\035\000\034\000\036\000\032\000\033\000\033\000\
\035\000\033\000\033\000\033\000\033\000\035\000\035\000\035\000\
\035\000\037\000\033\000\000\000\000\000\000\000\035\000\036\000\
\000\000\000\000\000\000\035\000\000\000\036\000\036\000\036\000\
\036\000\000\000\000\000\000\000\000\000\033\000\036\000\000\000\
\000\000\035\000\000\000\000\000\000\000\000\000\000\000\000\000\
\033\000\006\000\007\000\038\000\038\000\038\000\038\000\036\000\
\036\000\036\000\036\000\255\255\039\000\032\000\033\000\033\000\
\037\000\033\000\033\000\033\000\033\000\035\000\040\000\000\000\
\255\255\255\255\034\000\036\000\036\000\036\000\036\000\038\000\
\000\000\255\255\000\000\036\000\037\000\000\000\255\255\038\000\
\038\000\038\000\038\000\000\000\000\000\033\000\255\255\000\000\
\039\000\000\000\000\000\000\000\000\000\000\000\000\000\036\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\036\000\000\000";
\000\000\000\000\000\000\038\000\000\000";
Lexing.lex_check =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\001\000\006\000\008\000\002\000\000\000\000\000\000\000\
......@@ -136,13 +139,13 @@ let lex_tables = {
\024\000\001\000\002\000\002\000\010\000\010\000\022\000\022\000\
\022\000\003\000\003\000\019\000\019\000\019\000\019\000\020\000\
\020\000\020\000\020\000\034\000\019\000\032\000\032\000\032\000\
\020\000\033\000\033\000\033\000\033\000\035\000\035\000\035\000\
\035\000\037\000\033\000\255\255\255\255\255\255\035\000\019\000\
\255\255\255\255\255\255\020\000\255\255\036\000\036\000\036\000\
\036\000\255\255\255\255\255\255\255\255\033\000\036\000\255\255\
\255\255\035\000\255\255\255\255\255\255\255\255\255\255\255\255\
\020\000\033\000\033\000\033\000\033\000\035\000\040\000\255\255\
\034\000\037\000\033\000\036\000\036\000\036\000\036\000\019\000\
\255\255\039\000\255\255\020\000\036\000\255\255\037\000\038\000\
\038\000\038\000\038\000\255\255\255\255\033\000\039\000\255\255\
\038\000\255\255\255\255\255\255\255\255\255\255\255\255\036\000\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\036\000\255\255"
\255\255\255\255\255\255\038\000\255\255"
}
let rec token engine lexbuf =
......
parser/wlexer.mll
View file @ 7cf0335b
......@@ -38,7 +38,7 @@ classes
}
let identchar = lowercase | uppercase | ascii_digit | '_' | '\'' | ':'
let identchar = lowercase | uppercase | ascii_digit | '_' | '\'' | ':' [^':']
rule token = parse
blank+ { token engine lexbuf }
......
typing/typer.ml
View file @ 7cf0335b
......@@ -4,6 +4,10 @@
open Location
open Ast
module S = struct type t = string let compare = compare end
module StringMap = Map.Make(S)
module StringSet = Set.Make(S)
exception NonExhaustive of Types.descr
exception MultipleLabel of Types.label
exception Constraint of Types.descr * Types.descr * string
......@@ -19,7 +23,7 @@ let raise_loc loc exn = raise (Location (loc,exn))
type ti = {
id : int;
mutable loc' : loc;
mutable fv : string SortedList.t option;
mutable fv : StringSet.t option;
mutable descr': descr;
mutable type_node: Types.node option;
mutable pat_node: Patterns.node option
......@@ -39,11 +43,6 @@ and descr =
]
module S = struct type t = string let compare = compare end
module StringMap = Map.Make(S)
module StringSet = Set.Make(S)
type glb = ti StringMap.t
let mk' =
......@@ -91,7 +90,7 @@ module Regexp = struct
let uniq_id = let r = ref 0 in fun () -> incr r; !r
type flat = [ `Epsilon
| `Elem of int * Ast.ppat (* the int arg is used to
| `Elem of int * Ast.ppat (* the int arg is used
to stop generic comparison *)
| `Seq of flat * flat
| `Alt of flat * flat
......@@ -124,10 +123,11 @@ module Regexp = struct
module Coind = Set.Make(struct type t = flat list let compare = compare end)
let memo = ref Memo.empty
let rec compile fin e seq : [`Res of Ast.ppat | `Empty] =
if Coind.mem seq !e then `Empty
else (
e := Coind.add seq !e;
e := Coind.add seq !e;
match seq with
| [] ->
`Res fin
......@@ -157,6 +157,64 @@ module Regexp = struct
| `Res d -> defs := (n,d) :: !defs);
v
(*
type trans = [ `Alt of gnode * gnode | `Elem of Ast.ppat * gnode | `Final ]
and gnode =
{
mutable seen : bool;
mutable compile : bool;
name : string;
mutable trans : trans;
}
let new_node() = { seen = false; compile = false;
name = name(); trans = `Final }
let to_compile = ref []
let rec compile after = function
| `Epsilon -> after
| `Elem (_,p) ->
if not after.compile then (after.compile <- true;
to_compile := after :: !to_compile);
{ new_node () with trans = `Elem (p, after) }
| `Seq(r1,r2) -> compile (compile after r2) r1
| `Alt(r1,r2) ->
let r1 = compile after r1 and r2 = compile after r2 in
{ new_node () with trans = `Alt (r1,r2) }
| `Star r ->
let n = new_node() in
n.trans <- `Alt (compile n r, after);
n
| `WeakStar r ->
let n = new_node() in
n.trans <- `Alt (after, compile n r);
n
let seens = ref []
let rec collect_aux accu n =
if n.seen then accu
else ( seens := n :: !seens;
match n.trans with
| `Alt (n1,n2) -> collect_aux (collect_aux accu n2) n1
| _ -> n :: accu
)
let collect fin n =
let l = collect_aux [] n in
List.iter (fun n -> n.seen <- false) !seens;
let l = List.map (fun n ->
match n.trans with
| `Final -> fin
| `Elem (p,a) ->
mk !re_loc (Prod(p, mk !re_loc (PatVar a.name)))
| _ -> assert false
) l in
match l with
| h::t ->
List.fold_left (fun accu p -> mk !re_loc (Or (accu,p))) h t
| _ -> assert false
*)
let constant_nil v t =
mk !re_loc
......@@ -166,10 +224,19 @@ module Regexp = struct
re_loc := loc;
let vars = seq_vars StringSet.empty regexp in
let fin = StringSet.fold constant_nil vars queue in
let n = guard_compile fin [propagate (fun p -> p) regexp] in
let re = propagate (fun p -> p) regexp in
let n = guard_compile fin [re] in
memo := Memo.empty;
let d = !defs in
defs := [];
(*
let after = new_node() in
let n = collect queue (compile after re) in
let d = List.map (fun n -> (n.name, collect queue n)) !to_compile in
to_compile := [];
*)
mk !re_loc (Recurs (n,d))
end
......@@ -203,17 +270,22 @@ and compile_many env b =
List.iter (fun (v,t,x) -> x.descr' <- `Alias (v, compile env t)) b;
env
let comp_fv_seen = ref []
let comp_fv_res = ref []
module IntSet =
Set.Make(struct type t = int let compare (x:int) y = compare x y end)
let comp_fv_seen = ref IntSet.empty
let comp_fv_res = ref StringSet.empty
let rec comp_fv s =
if List.memq s !comp_fv_seen then ()
else (
comp_fv_seen := s :: !comp_fv_seen;
match s.fv with
| Some fv -> comp_fv_res := List.rev_append fv !comp_fv_res
| None ->
(match s.descr' with
| `Alias (_,x) -> comp_fv x
match s.fv with
| Some fv -> comp_fv_res := StringSet.union fv !comp_fv_res
| None ->
(match s.descr' with
| `Alias (_,x) ->
if IntSet.mem x.id !comp_fv_seen then ()
else (
comp_fv_seen := IntSet.add x.id !comp_fv_seen;
comp_fv x
)
| `Or (s1,s2)
| `And (s1,s2)
| `Diff (s1,s2)
......@@ -222,10 +294,8 @@ let rec comp_fv s =
| `Record (l,opt,s) -> comp_fv s
| `Type _ -> ()
| `Capture x
| `Constant (x,_) -> comp_fv_res := x :: !comp_fv_res
| `Constant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res
)
)
let fv s =
......@@ -233,19 +303,19 @@ let fv s =
| Some l -> l
| None ->
comp_fv s;
let l = SortedList.from_list !comp_fv_res in
comp_fv_res := [];
comp_fv_seen := [];
let l = !comp_fv_res in
comp_fv_res := StringSet.empty;
comp_fv_seen := IntSet.empty;
s.fv <- Some l;
l
let rec typ seen s : Types.descr =
match s.descr' with
| `Alias (v,x) ->
if List.memq s seen then
if IntSet.mem s.id seen then
raise_loc_generic s.loc'
("Unguarded recursion on variable " ^ v ^ " in this type")
else typ (s :: seen) x
else typ (IntSet.add s.id seen) x
| `Type t -> t
| `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
| `And (s1,s2) -> Types.cap (typ seen s1) (typ seen s2)
......@@ -262,7 +332,7 @@ and typ_node s : Types.node =
| None ->
let x = Types.make () in
s.type_node <- Some x;
let t = typ [] s in
let t = typ IntSet.empty s in
Types.define x t;
x
......@@ -273,7 +343,9 @@ let type_node s =
s
let rec pat seen s : Patterns.descr =
if fv s = [] then Patterns.constr (Types.descr (type_node s)) else
if StringSet.is_empty (fv s)
then Patterns.constr (Types.descr (type_node s))
else
try pat_aux seen s
with Patterns.Error e -> raise_loc_generic s.loc' e
| Location (loc,exn) when loc = noloc -> raise (Location (s.loc', exn))
......@@ -281,14 +353,14 @@ let rec pat seen s : Patterns.descr =
and pat_aux seen s = match s.descr' with
| `Alias (v,x) ->
if List.memq s seen
if IntSet.mem s.id seen
then raise
(Patterns.Error
("Unguarded recursion on variable " ^ v ^ " in this pattern"));
pat (s :: seen) x
pat (IntSet.add s.id seen) x
| `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
| `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
| `Diff (s1,s2) when fv s2 = [] ->
| `Diff (s1,s2) when StringSet.is_empty (fv s2) ->
let s2 = Types.neg (Types.descr (type_node s2)) in
Patterns.cap (pat seen s1) (Patterns.constr s2)
| `Diff _ ->
......@@ -308,14 +380,15 @@ and pat_node s : Patterns.node =
match s.pat_node with
| Some x -> x
| None ->
let x = Patterns.make (fv s) in
let fv = SortedList.from_list (StringSet.elements (fv s)) in
let x = Patterns.make fv in
s.pat_node <- Some x;
let t = pat [] s in
let t = pat IntSet.empty s in
Patterns.define x t;
x
let mk_typ e =
if fv e = [] then type_node e
if StringSet.is_empty (fv e) then type_node e
else raise_loc_generic e.loc' "Capture variables are not allowed in types"
......
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