Commit 644ef011 by Jean-Christophe Filliâtre

### distinction lident/uident a la Caml

parent 64abfa8a
 ... @@ -127,10 +127,12 @@ ... @@ -127,10 +127,12 @@ let newline = '\n' let newline = '\n' let space = [' ' '\t' '\r'] let space = [' ' '\t' '\r'] let alpha = ['a'-'z' 'A'-'Z'] let lalpha = ['a'-'z' '_'] let letter = alpha | '_' let ualpha = ['A'-'Z'] let alpha = lalpha | ualpha let digit = ['0'-'9'] let digit = ['0'-'9'] let ident = letter (letter | digit | '\'')* let lident = lalpha (alpha | digit | '\'')* let uident = ualpha (alpha | digit | '\'')* let hexadigit = ['0'-'9' 'a'-'f' 'A'-'F'] let hexadigit = ['0'-'9' 'a'-'f' 'A'-'F'] (* (* let hexafloat = '0' ['x' 'X'] (hexadigit* '.' hexadigit+ | hexadigit+ '.' hexadigit* ) ['p' 'P'] ['-' '+']? digit+ let hexafloat = '0' ['x' 'X'] (hexadigit* '.' hexadigit+ | hexadigit+ '.' hexadigit* ) ['p' 'P'] ['-' '+']? digit+ ... @@ -144,8 +146,10 @@ rule token = parse ... @@ -144,8 +146,10 @@ rule token = parse { newline lexbuf; token lexbuf } { newline lexbuf; token lexbuf } | space+ | space+ { token lexbuf } { token lexbuf } | ident as id | lident as id { try Hashtbl.find keywords id with Not_found -> IDENT id } { try Hashtbl.find keywords id with Not_found -> LIDENT id } | uident as id { UIDENT id } | digit+ as s | digit+ as s { INTEGER s } { INTEGER s } | (digit+ as i) ("" as f) ['e' 'E'] (['-' '+']? digit+ as e) | (digit+ as i) ("" as f) ['e' 'E'] (['-' '+']? digit+ as e) ... ...
 ... @@ -87,7 +87,7 @@ ... @@ -87,7 +87,7 @@ /* Tokens */ /* Tokens */ %token IDENT %token LIDENT UIDENT %token INTEGER %token INTEGER %token FLOAT %token FLOAT %token STRING %token STRING ... @@ -168,12 +168,26 @@ list0_decl: ... @@ -168,12 +168,26 @@ list0_decl: ; ; ident: ident: | IDENT { { id = \$1; id_loc = loc () } } | LIDENT { { id = \$1; id_loc = loc () } } | UIDENT { { id = \$1; id_loc = loc () } } ; ; qualid: lident: | ident { Qident \$1 } | LIDENT { { id = \$1; id_loc = loc () } } | ident DOT ident { Qdot (\$1, \$3) } ; uident: | UIDENT { { id = \$1; id_loc = loc () } } ; lqualid: | lident { Qident \$1 } | uqualid DOT lident { Qdot (\$1, \$3) } ; uqualid: | uident { Qident \$1 } | uqualid DOT uident { Qdot (\$1, \$3) } ; ; decl: decl: ... @@ -277,11 +291,11 @@ primitive_type: ... @@ -277,11 +291,11 @@ primitive_type: */ */ | type_var | type_var { PPTvarid \$1 } { PPTvarid \$1 } | qualid | lqualid { PPTexternal ([], \$1) } { PPTexternal ([], \$1) } | primitive_type qualid | primitive_type lqualid { PPTexternal ([\$1], \$2) } { PPTexternal ([\$1], \$2) } | LEFTPAR primitive_type COMMA list1_primitive_type_sep_comma RIGHTPAR qualid | LEFTPAR primitive_type COMMA list1_primitive_type_sep_comma RIGHTPAR lqualid { PPTexternal (\$2 :: \$4, \$6) } { PPTexternal (\$2 :: \$4, \$6) } /* /* | LEFTPAR list1_primitive_type_sep_comma RIGHTPAR | LEFTPAR list1_primitive_type_sep_comma RIGHTPAR ... @@ -360,9 +374,9 @@ lexpr: ... @@ -360,9 +374,9 @@ lexpr: { infix_pp \$1 PPmod \$3 } { infix_pp \$1 PPmod \$3 } | MINUS lexpr %prec uminus | MINUS lexpr %prec uminus { prefix_pp PPneg \$2 } { prefix_pp PPneg \$2 } | qualid | lqualid { mk_pp (PPvar \$1) } { mk_pp (PPvar \$1) } | qualid LEFTPAR list1_lexpr_sep_comma RIGHTPAR | lqualid LEFTPAR list1_lexpr_sep_comma RIGHTPAR { mk_pp (PPapp (\$1, \$3)) } { mk_pp (PPapp (\$1, \$3)) } /*** /*** | qualid_ident LEFTSQ lexpr RIGHTSQ | qualid_ident LEFTSQ lexpr RIGHTSQ ... @@ -412,8 +426,8 @@ match_case: ... @@ -412,8 +426,8 @@ match_case: ; ; pattern: pattern: | qualid { (\$1, [], loc ()) } | uqualid { (\$1, [], loc ()) } | qualid LEFTPAR list1_ident_sep_comma RIGHTPAR { (\$1, \$3, loc ()) } | uqualid LEFTPAR list1_ident_sep_comma RIGHTPAR { (\$1, \$3, loc ()) } ; ; triggers: triggers: ... @@ -462,7 +476,7 @@ qualid_ident: ... @@ -462,7 +476,7 @@ qualid_ident: ***/ ***/ ident_or_string: ident_or_string: | IDENT { \$1 } | ident { \$1.id } | STRING { \$1 } | STRING { \$1 } ; ; ... ...
 ... @@ -40,7 +40,7 @@ type ident = { id : string; id_loc : loc } ... @@ -40,7 +40,7 @@ type ident = { id : string; id_loc : loc } type qualid = type qualid = | Qident of ident | Qident of ident | Qdot of ident * ident | Qdot of qualid * ident type ppure_type = type ppure_type = (* (* ... ...
 (* test file *) (* test file *) theory int theory Int type int type int end end theory list theory List uses int uses Int type 'a list type 'a list ... @@ -19,11 +19,11 @@ theory list ... @@ -19,11 +19,11 @@ theory list logic is_nil : 'a list -> prop logic is_nil : 'a list -> prop logic length : 'a list -> int.int logic length : 'a list -> Int.int end end theory eq theory Eq logic eq : 'a, 'a -> prop logic eq : 'a, 'a -> prop ... @@ -31,30 +31,30 @@ end ... @@ -31,30 +31,30 @@ end theory set theory set uses eq uses Eq type elt type elt type t type t logic In : elt, t -> prop logic in_ : elt, t -> prop logic empty : t logic empty : t axiom empty_def1 : forall x:elt, not In(x, empty) axiom empty_def1 : forall x:elt, not in_(x, empty) logic add : elt, t -> t logic add : elt, t -> t axiom add_def1 : forall x,y:elt, forall s:t, axiom add_def1 : forall x,y:elt, forall s:t, In(x, add(y, s)) <-> (eq.eq(x, y) or In(x, s)) in_(x, add(y, s)) <-> (Eq.eq(x, y) or in_(x, s)) end end theory test theory test uses eq, list uses Eq, List axiom a : forall x : 'a, not eq.eq(list.nil, list.cons(list.nil, list.nil)) axiom a : forall x : 'a, not Eq.eq(List.nil, List.cons(List.nil, List.nil)) end end
 ... @@ -23,6 +23,7 @@ open Ptree ... @@ -23,6 +23,7 @@ open Ptree (** errors *) (** errors *) type error = type error = | Message of string | ClashType of string | ClashType of string | BadTypeArity of string | BadTypeArity of string | UnboundType of qualid | UnboundType of qualid ... @@ -43,11 +44,13 @@ let error ?loc e = match loc with ... @@ -43,11 +44,13 @@ let error ?loc e = match loc with | None -> raise (Error e) | None -> raise (Error e) | Some loc -> raise (Loc.Located (loc, Error e)) | Some loc -> raise (Loc.Located (loc, Error e)) let print_qualid fmt = function let rec print_qualid fmt = function | Qident s -> fprintf fmt "%s" s.id | Qident s -> fprintf fmt "%s" s.id | Qdot (m, s) -> fprintf fmt "%s.%s" m.id s.id | Qdot (m, s) -> fprintf fmt "%a.%s" print_qualid m s.id let report fmt = function let report fmt = function | Message s -> fprintf fmt "%s" s | ClashType s -> | ClashType s -> fprintf fmt "clash with previous type %s" s fprintf fmt "clash with previous type %s" s | BadTypeArity s -> | BadTypeArity s -> ... @@ -99,9 +102,9 @@ let is_empty env = ... @@ -99,9 +102,9 @@ let is_empty env = M.is_empty env.fsymbols && M.is_empty env.fsymbols && M.is_empty env.psymbols M.is_empty env.psymbols let find_tysymbol s env = M.find s env.tysymbols let find_tysymbol s env = M.find s.id env.tysymbols let find_fsymbol s env = M.find s env.fsymbols let find_fsymbol s env = M.find s.id env.fsymbols let find_psymbol s env = M.find s env.psymbols let find_psymbol s env = M.find s.id env.psymbols let add_tysymbol x ty env = { env with tysymbols = M.add x ty env.tysymbols } let add_tysymbol x ty env = { env with tysymbols = M.add x ty env.tysymbols } ... @@ -226,16 +229,17 @@ let rec specialize env t = match t.Ty.ty_node with ... @@ -226,16 +229,17 @@ let rec specialize env t = match t.Ty.ty_node with | Ty.Tyapp (s, tl) -> | Ty.Tyapp (s, tl) -> Tyapp (s, List.map (specialize env) tl) Tyapp (s, List.map (specialize env) tl) let find_local_theory t env = let find_local_theory t env = try M.find t.id env.theories try M.find t.id env.theories with Not_found -> error ~loc:t.id_loc (UnboundTheory t.id) with Not_found -> error ~loc:t.id_loc (UnboundTheory t.id) let find f q env = match q with let rec find_theory q env = match q with | Qident x -> | Qident t -> find_local_theory t env f x.id env | Qdot (q, t) -> let env = find_theory q env in find_local_theory t env | Qdot (m, x) -> let env = find_local_theory m env in let rec find f q env = match q with f x.id env | Qident x -> f x env | Qdot (m, x) -> let env = find_theory m env in f x env let specialize_tysymbol x env = let specialize_tysymbol x env = let s = find find_tysymbol x env.env in let s = find find_tysymbol x env.env in ... @@ -255,9 +259,9 @@ let specialize_psymbol x env = ... @@ -255,9 +259,9 @@ let specialize_psymbol x env = (** Typing types *) (** Typing types *) let qloc = function let rec qloc = function | Qident x -> x.id_loc | Qident x -> x.id_loc | Qdot (m, x) -> Loc.join m.id_loc x.id_loc | Qdot (m, x) -> Loc.join (qloc m) x.id_loc (* parsed types -> intermediate types *) (* parsed types -> intermediate types *) let rec dty env = function let rec dty env = function ... @@ -267,7 +271,7 @@ let rec dty env = function ... @@ -267,7 +271,7 @@ let rec dty env = function let loc = qloc x in let loc = qloc x in let s, tv = let s, tv = try specialize_tysymbol x env try specialize_tysymbol x env with Not_found -> error ~loc:loc (UnboundType x); with Not_found -> error ~loc:loc (UnboundType x) in in let np = List.length p in let np = List.length p in let a = List.length tv in let a = List.length tv in ... ...
 ... @@ -22,9 +22,9 @@ type env ... @@ -22,9 +22,9 @@ type env val empty : env val empty : env val find_tysymbol : string -> env -> tysymbol val find_tysymbol : Ptree.ident -> env -> tysymbol val find_fsymbol : string -> env -> fsymbol val find_fsymbol : Ptree.ident -> env -> fsymbol val find_psymbol : string -> env -> psymbol val find_psymbol : Ptree.ident -> env -> psymbol (** typing *) (** typing *) ... ...
Supports Markdown
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