From 4242dd9331f47c8bacc219e66321d27bd5af7164 Mon Sep 17 00:00:00 2001 From: Andrei Paskevich Date: Mon, 24 Dec 2012 19:47:38 +0100 Subject: [PATCH] accept type expressions as arguments for metas --- src/driver/driver.ml | 13 ++++++++- src/driver/driver_ast.ml | 7 ++++- src/driver/driver_lexer.mll | 3 ++ src/driver/driver_parser.mly | 53 ++++++++++++++++++++++++++++++++++-- src/parser/parser.mly | 3 +- src/parser/ptree.ml | 2 +- src/parser/typing.ml | 2 +- src/whyml/mlw_driver.ml | 13 ++++++++- 8 files changed, 87 insertions(+), 9 deletions(-) diff --git a/src/driver/driver.ml b/src/driver/driver.ml index 09f7ebc01..6f9af4532 100644 --- a/src/driver/driver.ml +++ b/src/driver/driver.ml @@ -150,8 +150,19 @@ let load_driver = let driver_tag = ref (-1) in fun env file extra_files -> let td = remove_prop (find_pr th q) in add_meta th td (if c then meta_cl else meta) | Rmeta (c,s,al) -> + let rec ty_of_pty = function + | PTyvar x -> + Ty.ty_var (Typing.create_user_tv x) + | PTyapp ((loc,_) as q,tyl) -> + let ts = find_ts th q in + let tyl = List.map ty_of_pty tyl in + Loc.try2 loc Ty.ty_app ts tyl + | PTuple tyl -> + let ts = Ty.ts_tuple (List.length tyl) in + Ty.ty_app ts (List.map ty_of_pty tyl) + in let convert = function - | PMAts q -> MAts (find_ts th q) + | PMAty ty -> MAty (ty_of_pty ty) | PMAfs q -> MAls (find_fs th q) | PMAps q -> MAls (find_ps th q) | PMApr q -> MApr (find_pr th q) diff --git a/src/driver/driver_ast.ml b/src/driver/driver_ast.ml index e89054f75..9836e64ba 100644 --- a/src/driver/driver_ast.ml +++ b/src/driver/driver_ast.ml @@ -15,8 +15,13 @@ type qualid = loc * string list type cloned = bool +type pty = + | PTyvar of string + | PTyapp of qualid * pty list + | PTuple of pty list + type metarg = - | PMAts of qualid + | PMAty of pty | PMAfs of qualid | PMAps of qualid | PMApr of qualid diff --git a/src/driver/driver_lexer.mll b/src/driver/driver_lexer.mll index 5c545eb2b..1bdde1edc 100644 --- a/src/driver/driver_lexer.mll +++ b/src/driver/driver_lexer.mll @@ -40,6 +40,7 @@ "time", TIME; "unknown", UNKNOWN; "fail", FAIL; + "constant", CONSTANT; "function", FUNCTION; "predicate", PREDICATE; "type", TYPE; @@ -93,6 +94,8 @@ rule token = parse { DOT } | "," { COMMA } + | "'" + { QUOTE } | op_char+ as op { OPERATOR op } | "\"" diff --git a/src/driver/driver_parser.mly b/src/driver/driver_parser.mly index b5dbace47..2ebcc50be 100644 --- a/src/driver/driver_parser.mly +++ b/src/driver/driver_parser.mly @@ -27,13 +27,16 @@ %token OPERATOR %token THEORY END SYNTAX REMOVE META PRELUDE PRINTER %token VALID INVALID TIMEOUT OUTOFMEMORY UNKNOWN FAIL TIME -%token UNDERSCORE LEFTPAR RIGHTPAR CLONED DOT EOF +%token UNDERSCORE LEFTPAR RIGHTPAR CLONED DOT QUOTE EOF %token BLACKLIST %token MODULE EXCEPTION VAL %token FUNCTION PREDICATE TYPE PROP FILENAME TRANSFORM PLUGIN -%token LEFTPAR_STAR_RIGHTPAR COMMA +%token LEFTPAR_STAR_RIGHTPAR COMMA CONSTANT %token LEFTSQ RIGHTSQ LARROW +%nonassoc SYNTAX REMOVE PRELUDE +%nonassoc prec_pty + %type file %start file %type file_extract @@ -88,6 +91,7 @@ list0_trule: trule: | PRELUDE STRING { Rprelude ($2) } | SYNTAX cloned TYPE qualid STRING { Rsyntaxts ($2, $4, $5) } +| SYNTAX cloned CONSTANT qualid STRING { Rsyntaxfs ($2, $4, $5) } | SYNTAX cloned FUNCTION qualid STRING { Rsyntaxfs ($2, $4, $5) } | SYNTAX cloned PREDICATE qualid STRING { Rsyntaxps ($2, $4, $5) } | REMOVE cloned PROP qualid { Rremovepr ($2, $4) } @@ -101,7 +105,7 @@ meta_args: ; meta_arg: -| TYPE qualid { PMAts $2 } +| TYPE primitive_type_top { PMAty $2 } | FUNCTION qualid { PMAfs $2 } | PREDICATE qualid { PMAps $2 } | PROP qualid { PMApr $2 } @@ -163,6 +167,49 @@ list1_string_list: | list1_string_list STRING { $2 :: $1 } ; +/* Types */ + +primitive_type_top: +| qualid primitive_type_args_top { PTyapp ($1, $2) } +| primitive_type_arg_common { $1 } +; + +primitive_type_args_top: +| /* epsilon */ %prec prec_pty { [] } +| primitive_type_arg primitive_type_args_top { $1 :: $2 } +; + +primitive_type: +| qualid primitive_type_args { PTyapp ($1, $2) } +| primitive_type_arg { $1 } +; + +primitive_type_args: +| primitive_type_arg { [$1] } +| primitive_type_arg primitive_type_args { $1 :: $2 } +; + +primitive_type_arg: +| qualid { PTyapp ($1, []) } +| primitive_type_arg_common { $1 } +; + +primitive_type_arg_common: +| type_var { PTyvar $1 } +| LEFTPAR primitive_types RIGHTPAR { PTuple $2 } +| LEFTPAR RIGHTPAR { PTuple [] } +| LEFTPAR primitive_type RIGHTPAR { $2 } +; + +primitive_types: +| primitive_type COMMA primitive_type { [$1; $3] } +| primitive_type COMMA primitive_types { $1 :: $3 } +; + +type_var: +| QUOTE ident { $2 } +; + /* WhyML */ file_extract: diff --git a/src/parser/parser.mly b/src/parser/parser.mly index ca1b79da9..e96c8d484 100644 --- a/src/parser/parser.mly +++ b/src/parser/parser.mly @@ -379,7 +379,8 @@ list1_meta_arg_sep_comma: ; meta_arg: -| TYPE qualid { PMAts $2 } +| TYPE primitive_type { PMAty $2 } +| CONSTANT qualid { PMAfs $2 } | FUNCTION qualid { PMAfs $2 } | PREDICATE qualid { PMAps $2 } | PROP qualid { PMApr $2 } diff --git a/src/parser/ptree.ml b/src/parser/ptree.ml index c0e9986dd..be75951da 100644 --- a/src/parser/ptree.ml +++ b/src/parser/ptree.ml @@ -148,7 +148,7 @@ type prop_kind = | Kaxiom | Klemma | Kgoal type metarg = - | PMAts of qualid + | PMAty of pty | PMAfs of qualid | PMAps of qualid | PMApr of qualid diff --git a/src/parser/typing.ml b/src/parser/typing.ml index 65464ebd2..9dc1b0c5a 100644 --- a/src/parser/typing.ml +++ b/src/parser/typing.ml @@ -1115,7 +1115,7 @@ let add_decl loc th = function add_prop (prop_kind k) loc s f th | Meta (id, al) -> let convert = function - | PMAts q -> MAts (find_tysymbol q th) + | PMAty ty -> MAty (ty_of_pty th ty) | PMAfs q -> MAls (find_fsymbol q th) | PMAps q -> MAls (find_psymbol q th) | PMApr q -> MApr (find_prop q th) diff --git a/src/whyml/mlw_driver.ml b/src/whyml/mlw_driver.ml index c881d3b0f..f35b70442 100644 --- a/src/whyml/mlw_driver.ml +++ b/src/whyml/mlw_driver.ml @@ -115,8 +115,19 @@ let load_driver lib file extra_files = | Rremovepr (_,q) -> ignore (find_pr th q) | Rmeta (_,s,al) -> + let rec ty_of_pty = function + | PTyvar x -> + Ty.ty_var (Typing.create_user_tv x) + | PTyapp ((loc,_) as q,tyl) -> + let ts = find_ts th q in + let tyl = List.map ty_of_pty tyl in + Loc.try2 loc Ty.ty_app ts tyl + | PTuple tyl -> + let ts = Ty.ts_tuple (List.length tyl) in + Ty.ty_app ts (List.map ty_of_pty tyl) + in let convert = function - | PMAts q -> MAts (find_ts th q) + | PMAty ty -> MAty (ty_of_pty ty) | PMAfs q -> MAls (find_fs th q) | PMAps q -> MAls (find_ps th q) | PMApr q -> MApr (find_pr th q) -- GitLab