Skip to content

GitLab

Commit 70842f4d authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-26 09:25:47 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-11-26 09:25:47+00:00
parent d2480cc5
Hide whitespace changes
Inline Side-by-side
parser/ast.ml
View file @ 70842f4d
......@@ -65,7 +65,7 @@ and ppat' =
| Prod of ppat * ppat
| XmlT of ppat * ppat
| Arrow of ppat * ppat
| Record of Types.label * bool * ppat
| Record of bool * (Types.label * bool * ppat) list
| Capture of Patterns.capture
| Constant of Patterns.capture * Types.const
| Regexp of regexp * ppat
......
parser/parser.ml
View file @ 70842f4d
......@@ -259,7 +259,8 @@ EXTEND
| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
| x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
|
[ "{"; r = record_spec; "}" -> r
[ "{"; r = record_spec; "}" -> mk loc (Record (true,r))
| "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
| LIDENT "_" -> mk loc (Internal Types.any)
| a = LIDENT -> mk loc (Capture a)
| "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
......@@ -313,12 +314,10 @@ EXTEND
record_spec:
[ [ r = LIST0 [ l = [LIDENT | UIDENT]; "=";
o = [ "?" -> true | -> false];
x = pat ->
mk loc (Record (Types.LabelPool.mk l,o,x))
x = pat -> (Types.LabelPool.mk l,o,x)
] SEP ";" ->
match r with
| [] -> mk loc (Internal Types.Record.any)
| h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
(* TODO: check here uniqueness *)
List.sort (fun (l1,_,_) (l2,_,_) -> compare l1 l2) r
] ];
char:
......@@ -337,7 +336,8 @@ EXTEND
attrib_spec:
[ [ r = record_spec -> r | "("; t = pat; ")" -> t ] ];
[ [ r = record_spec -> mk loc (Record (true,r))
| "("; t = pat; ")" -> t ] ];
expr_record_spec:
[ [ r = LIST1
......
parser/wlexer.ml
View file @ 70842f4d
......@@ -101,63 +101,67 @@ let nb_classes = 34
let lex_tables = {
Lexing.lex_base =
"\000\000\009\000\012\000\018\000\252\255\251\255\004\000\255\255\
\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\069\000\081\000\085\000\098\000\
\102\000\074\000";
\005\000\254\255\014\000\013\000\003\000\005\000\253\255\255\255\
\247\255\246\255\020\000\047\000\051\000\018\000\043\000\250\255\
\027\000\017\000\005\000\050\000\011\000\044\000\040\000\249\255\
\250\255\248\255\064\000\066\000\057\000\071\000\081\000\086\000\
\101\000\090\000\119\000\062\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\255\255\002\000\001\000\255\255\
\001\000\000\000";
\005\000\005\000\005\000\005\000\005\000\005\000\005\000\255\255\
\255\255\255\255\255\255\004\000\003\000\002\000\255\255\002\000\
\001\000\255\255\001\000\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\
\255\255\255\255";
\255\255\255\255\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\255\255\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\041\000\034\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\038\000\038\000\038\000\038\000\035\000\
\035\000\035\000\035\000\034\000\039\000\032\000\033\000\033\000\
\036\000\033\000\033\000\033\000\033\000\035\000\035\000\035\000\
\035\000\037\000\037\000\037\000\037\000\041\000\036\000\038\000\
\000\000\000\000\000\000\035\000\000\000\037\000\037\000\037\000\
\037\000\038\000\038\000\038\000\038\000\033\000\036\000\000\000\
\000\000\035\000\039\000\000\000\000\000\037\000\040\000\040\000\
\040\000\040\000\040\000\040\000\040\000\040\000\000\000\000\000\
\000\000\037\000\000\000\039\000\000\000\038\000\000\000\000\000\
\027\000\026\000\004\000\011\000\011\000\028\000\015\000\043\000\
\036\000\029\000\012\000\030\000\026\000\009\000\031\000\032\000\
\031\000\032\000\013\000\009\000\009\000\032\000\032\000\014\000\
\032\000\014\000\007\000\010\000\009\000\009\000\034\000\035\000\
\035\000\006\000\007\000\040\000\040\000\040\000\040\000\037\000\
\037\000\037\000\037\000\032\000\041\000\033\000\032\000\036\000\
\038\000\043\000\032\000\034\000\035\000\035\000\035\000\035\000\
\035\000\035\000\000\000\037\000\037\000\037\000\037\000\040\000\
\000\000\000\000\000\000\037\000\038\000\039\000\039\000\039\000\
\039\000\000\000\039\000\039\000\039\000\039\000\042\000\042\000\
\042\000\042\000\035\000\038\000\000\000\000\000\000\000\037\000\
\000\000\040\000\040\000\040\000\040\000\000\000\000\000\000\000\
\000\000\039\000\041\000\000\000\000\000\000\000\039\000\000\000\
\000\000\000\000\042\000\042\000\042\000\042\000\042\000\000\000\
\000\000\000\000\000\000\000\000\041\000\040\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\040\000\000\000\000\000\000\000\040\000\000\000\
";
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\042\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\
\000\000\000\000\003\000\011\000\010\000\013\000\018\000\021\000\
\025\000\000\000\001\000\012\000\000\000\026\000\000\000\027\000\
\000\000\028\000\001\000\006\000\006\000\024\000\027\000\001\000\
\000\000\000\000\003\000\011\000\010\000\000\000\013\000\018\000\
\021\000\000\000\001\000\000\000\000\000\012\000\000\000\025\000\
\000\000\026\000\001\000\006\000\006\000\024\000\028\000\001\000\
\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\036\000\036\000\036\000\036\000\041\000\035\000\019\000\
\255\255\255\255\255\255\020\000\255\255\037\000\037\000\037\000\
\037\000\038\000\038\000\038\000\038\000\033\000\037\000\255\255\
\255\255\035\000\038\000\255\255\255\255\036\000\039\000\039\000\
\039\000\039\000\040\000\040\000\040\000\040\000\255\255\255\255\
\255\255\037\000\255\255\040\000\255\255\038\000\255\255\255\255\
\020\000\020\000\020\000\027\000\019\000\029\000\030\000\036\000\
\020\000\043\000\027\000\034\000\034\000\034\000\035\000\035\000\
\035\000\035\000\255\255\037\000\037\000\037\000\037\000\019\000\
\255\255\255\255\255\255\020\000\037\000\038\000\038\000\038\000\
\038\000\255\255\039\000\039\000\039\000\039\000\041\000\041\000\
\041\000\041\000\035\000\039\000\255\255\255\255\255\255\037\000\
\255\255\040\000\040\000\040\000\040\000\255\255\255\255\255\255\
\255\255\038\000\040\000\255\255\255\255\255\255\039\000\255\255\
\255\255\255\255\041\000\042\000\042\000\042\000\042\000\255\255\
\255\255\255\255\255\255\255\255\042\000\040\000\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\039\000\255\255\255\255\255\255\040\000\255\255\
"
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\042\000\
\255\255"
}
let rec token engine lexbuf =
......@@ -184,10 +188,10 @@ let rec token engine lexbuf =
"TAG", tag_of_tag s 1
)
| 5 -> (
# 64 "parser/wlexer.mll"
# 65 "parser/wlexer.mll"
"",Lexing.lexeme lexbuf )
| 6 -> (
# 67 "parser/wlexer.mll"
# 68 "parser/wlexer.mll"
let string_start = Lexing.lexeme_start lexbuf in
string_start_pos := string_start;
let double_quote = Lexing.lexeme_char lexbuf 0 = '"' in
......@@ -197,15 +201,15 @@ let rec token engine lexbuf =
(if double_quote then "STRING2" else "STRING1"),
(get_stored_string()) )
| 7 -> (
# 77 "parser/wlexer.mll"
# 78 "parser/wlexer.mll"
comment_start_pos := [Lexing.lexeme_start lexbuf];
comment engine lexbuf;
token engine lexbuf )
| 8 -> (
# 82 "parser/wlexer.mll"
# 83 "parser/wlexer.mll"
"EOI","" )
| 9 -> (
# 84 "parser/wlexer.mll"
# 85 "parser/wlexer.mll"
error
(Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)
(Illegal_character ((Lexing.lexeme lexbuf).[0])) )
......@@ -214,17 +218,17 @@ let rec token engine lexbuf =
and comment engine lexbuf =
match engine lex_tables 1 lexbuf with
0 -> (
# 90 "parser/wlexer.mll"
# 91 "parser/wlexer.mll"
comment_start_pos := Lexing.lexeme_start lexbuf :: !comment_start_pos;
comment engine lexbuf;
)
| 1 -> (
# 94 "parser/wlexer.mll"
# 95 "parser/wlexer.mll"
comment_start_pos := List.tl !comment_start_pos;
if !comment_start_pos <> [] then comment engine lexbuf;
)
| 2 -> (
# 98 "parser/wlexer.mll"
# 99 "parser/wlexer.mll"
string_start_pos := Lexing.lexeme_start lexbuf;
let string =
if Lexing.lexeme_char lexbuf 0 = '"' then string2 else string1 in
......@@ -235,33 +239,33 @@ and comment engine lexbuf =
Buffer.clear string_buff;
comment engine lexbuf )
| 3 -> (
# 108 "parser/wlexer.mll"
# 109 "parser/wlexer.mll"
let st = List.hd !comment_start_pos in
error st (st+2) Unterminated_comment
)
| 4 -> (
# 112 "parser/wlexer.mll"
# 113 "parser/wlexer.mll"
comment engine lexbuf )
| _ -> failwith "lexing: empty token [comment]"
and string2 engine lexbuf =
match engine lex_tables 2 lexbuf with
0 -> (
# 116 "parser/wlexer.mll"
# 117 "parser/wlexer.mll"
() )
| 1 -> (
# 118 "parser/wlexer.mll"
# 119 "parser/wlexer.mll"
store_char (Lexing.lexeme_char lexbuf 1);
string2 engine lexbuf )
| 2 -> (
# 121 "parser/wlexer.mll"
# 122 "parser/wlexer.mll"
store_char (char_for_decimal_code (Lexing.lexeme lexbuf));
string2 engine lexbuf )
| 3 -> (
# 124 "parser/wlexer.mll"
# 125 "parser/wlexer.mll"
error !string_start_pos (!string_start_pos+1) Unterminated_string )
| 4 -> (
# 126 "parser/wlexer.mll"
# 127 "parser/wlexer.mll"
store_char (Lexing.lexeme_char lexbuf 0);
(* TODO: Unicode *)
string2 engine lexbuf )
......@@ -270,28 +274,28 @@ and string2 engine lexbuf =
and string1 engine lexbuf =
match engine lex_tables 3 lexbuf with
0 -> (
# 132 "parser/wlexer.mll"
# 133 "parser/wlexer.mll"
() )
| 1 -> (
# 134 "parser/wlexer.mll"
# 135 "parser/wlexer.mll"
store_char (Lexing.lexeme_char lexbuf 1);
string1 engine lexbuf )
| 2 -> (
# 137 "parser/wlexer.mll"
# 138 "parser/wlexer.mll"
store_char (char_for_decimal_code (Lexing.lexeme lexbuf));
string1 engine lexbuf )
| 3 -> (
# 140 "parser/wlexer.mll"
# 141 "parser/wlexer.mll"
error !string_start_pos (!string_start_pos+1) Unterminated_string )
| 4 -> (
# 142 "parser/wlexer.mll"
# 143 "parser/wlexer.mll"
store_char (Lexing.lexeme_char lexbuf 0);
string1 engine lexbuf )
| _ -> failwith "lexing: empty token [string1]"
;;
# 145 "parser/wlexer.mll"
# 146 "parser/wlexer.mll"
let lexer_func_of_wlex lexfun lexengine cs =
......
parser/wlexer.mll
View file @ 70842f4d
......@@ -60,6 +60,7 @@ rule token = parse
}
| [ "<>=.,:;+-*/@&{}[]()|?`!" ]
| "->" | "::" | ";;" | "--" | ":=" | "\\"
| "{|" | "|}"
| ["?+*"] "?"
{ "",Lexing.lexeme lexbuf }
......
types/patterns.ml
View file @ 70842f4d
......@@ -999,6 +999,7 @@ struct
if x==ab then aux_ab else
aux x fields)) pr in
`Label (l1, pr, aux_ab)
| _ -> assert false
in
let line accu ((res,fields),acc) =
......
types/types.ml
View file @ 70842f4d
......@@ -30,7 +30,6 @@ module I = struct
times : ('a * 'a) Boolean.t;
xml : ('a * 'a) Boolean.t;
arrow : ('a * 'a) Boolean.t;
(* record: (label * bool * 'a) Boolean.t; *)
record: (bool * (label, (bool * 'a)) SortedMap.t) Boolean.t;
}
......@@ -61,6 +60,8 @@ module I = struct
let arrow x y = { empty with arrow = Boolean.atom (x,y) }
let record label opt t =
{ empty with record = Boolean.atom (true,[label,(opt,t)]) }
let record' x =
{ empty with record = Boolean.atom x }
let atom a = { empty with atoms = a }
let char c = { empty with chars = c }
let constant = function
......@@ -690,8 +691,8 @@ struct
Format.fprintf ppf "@[{%s" o;
let first = ref true in
List.iter (fun (l,(o,t)) ->
let sep = if !first then (first := false; " ") else ";@ " in
Format.fprintf ppf "%s@[%s =%s@] %a" sep
let sep = if !first then (first := false; "") else ";" in
Format.fprintf ppf "%s@ @[%s =%s@] %a" sep
(LabelPool.value l) (if o then "?" else "") print t
) r;
Format.fprintf ppf " %s}@]" o
......@@ -1040,6 +1041,8 @@ struct
type normal =
[ `Success
| `Fail
| `NoField
| `SomeField
| `Label of label * (descr * normal) list * normal ]
let first_label t =
......@@ -1079,7 +1082,8 @@ struct
normal_aux absent)
| `Fail -> `Fail
| `Success -> `Success
| _ -> assert false
| `NoField -> `NoField
| `SomeField -> `SomeField
let normal t = normal_aux (get t)
......
types/types.mli
View file @ 70842f4d
......@@ -47,6 +47,7 @@ val times : node -> node -> descr
val xml : node -> node -> descr
val arrow : node -> node -> descr
val record : label -> bool -> node -> descr
val record' : bool * (label, (bool * node)) SortedMap.t -> descr
val char : Chars.t -> descr
val constant : const -> descr
......@@ -117,8 +118,10 @@ module Record : sig
*)
type normal =
[ `Success
| `Fail
[ `Success (* { } *)
| `Fail (* Empty *)
| `NoField (* {| |} *)
| `SomeField (* { } \ {| |} *)
| `Label of label * (descr * normal) list * normal ]
val normal: descr -> normal
......
typing/typer.ml
View file @ 70842f4d
......@@ -38,7 +38,7 @@ and descr =
| `Times of ti * ti
| `Xml of ti * ti
| `Arrow of ti * ti
| `Record of Types.label * bool * ti
| `Record of bool * (Types.label * bool * ti) list
| `Capture of Patterns.capture
| `Constant of Patterns.capture * Types.const
]
......@@ -261,7 +261,8 @@ let rec compile env { loc = loc; descr = d } : ti =
| Prod (t1,t2) -> cons loc (`Times (compile env t1, compile env t2))
| XmlT (t1,t2) -> cons loc (`Xml (compile env t1, compile env t2))
| Arrow (t1,t2) -> cons loc (`Arrow (compile env t1, compile env t2))
| Record (l,o,t) -> cons loc (`Record (l,o,compile env t))
| Record (o,r) ->
cons loc (`Record (o, List.map (fun (l,o,t) -> l,o,compile env t) r))
| Constant (x,v) -> cons loc (`Constant (x,v))
| Capture x -> cons loc (`Capture x)
......@@ -294,7 +295,7 @@ let rec comp_fv s =
| `Diff (s1,s2)
| `Times (s1,s2) | `Xml (s1,s2)
| `Arrow (s1,s2) -> comp_fv s1; comp_fv s2
| `Record (l,opt,s) -> comp_fv s
| `Record (_,r) -> List.iter (fun (l,opt,s) -> comp_fv s) r
| `Type _ -> ()
| `Capture x
| `Constant (x,_) -> comp_fv_res := StringSet.add x !comp_fv_res
......@@ -327,7 +328,9 @@ let rec typ seen s : Types.descr =
| `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
| `Xml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
| `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| `Record (l,o,s) -> Types.record l o (typ_node s)
| `Record (o,r) ->
Types.record'
(o,List.map (fun (l,o,s) -> (l,(o,typ_node s))) r)
| `Capture x | `Constant (x,_) -> assert false
and typ_node s : Types.node =
......@@ -371,9 +374,24 @@ and pat_aux seen s = match s.descr' with
raise (Patterns.Error "Difference not allowed in patterns")
| `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
| `Xml (s1,s2) -> Patterns.xml (pat_node s1) (pat_node s2)
| `Record (l,false,s) -> Patterns.record l (pat_node s)
| `Record _ ->
raise (Patterns.Error "Optional field not allowed in record patterns")
| `Record (false,_) ->
(* TODO: handle this case with a type constraint ... *)
raise
(Patterns.Error "Closed records are not allowed in record patterns");
| `Record (true,r) ->
let l =
List.map
(fun (l,o,s) ->
if o then
raise
(Patterns.Error
"Optional field not allowed in record patterns");
Patterns.record l (pat_node s)
) r
in
(match l with
| [] -> Patterns.constr Types.Record.any
| h::t -> List.fold_left Patterns.cap h t)
| `Capture x -> Patterns.capture x
| `Constant (x,c) -> Patterns.constant x c
| `Arrow _ ->
......@@ -595,6 +613,8 @@ and type_check' loc env e constr precise = match e with
type_check_pair loc env e1 e2 constr precise
| Xml (e1,e2) ->
type_check_pair ~kind:`XML loc env e1 e2 constr precise
(*
| RecordLitt r ->
let rconstr = Types.Record.get constr in
if Types.Record.is_empty rconstr then
......@@ -628,6 +648,7 @@ and type_check' loc env e constr precise = match e with
in
(* check loc res constr ""; *)
res
*)
| Map (e,b) ->
let t = type_check env e (Sequence.star b.br_accept) true in
......@@ -770,14 +791,11 @@ and compute_type' loc env = function
and t2 = compute_type env e2 in
Types.times (Types.cons t1) (Types.cons t2)
| RecordLitt r ->
List.fold_left
(fun accu (l,e) ->
let t = compute_type env e in
let t = Types.record l false (Types.cons t) in
Types.cap accu t
) Types.Record.any r
let r =
List.map
(fun (l,e) -> (l,(false,Types.cons (compute_type env e))))
r in
Types.record' (false,r)
| _ -> assert false
and type_check_branches loc env targ brs constr precise =
......
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