Lexer et Parser

parent 05a9cd8a
......@@ -59,7 +59,7 @@ COQDEP = @COQDEP@
COQLIB = "@COQLIB@"
COQVER = @COQVER@
GENERATED = src/version.ml
GENERATED = src/version.ml src/parser.mli src/parser.ml src/lexer.ml
# main targets
##############
......@@ -90,7 +90,8 @@ check: $(BINARY) $(PRELUDE)
LIBCMO = lib/pp.cmo lib/loc.cmo
CMO = $(LIBCMO) src/name.cmo src/hashcons.cmo src/term.cmo src/pretty.cmo
CMO = $(LIBCMO) src/name.cmo src/hashcons.cmo src/term.cmo src/pretty.cmo \
src/parser.cmo src/lexer.cmo
CMX = $(CMO:.cmo=.cmx)
bin/why.opt: $(CMX)
......
{
open Lexing
open Ptree
open Parser
let keywords = Hashtbl.create 97
let () =
List.iter
(fun (x,y) -> Hashtbl.add keywords x y)
[ "absurd", ABSURD;
"and", AND;
"array", ARRAY;
"as", AS;
"assert", ASSERT;
"axiom", AXIOM;
"begin", BEGIN;
"bool", BOOL;
"check", CHECK;
"do", DO;
"done", DONE;
"else", ELSE;
"end", END;
"exception", EXCEPTION;
"exists", EXISTS;
"external", EXTERNAL;
"false", FALSE;
"for", FOR;
"forall", FORALL;
"fun", FUN;
"function", FUNCTION;
"goal", GOAL;
"if", IF;
"in", IN;
"include", INCLUDE;
"inductive", INDUCTIVE;
"int", INT;
"invariant", INVARIANT;
"let", LET;
"logic", LOGIC;
"match", MATCH;
"not", NOT;
"of", OF;
"or", OR;
"parameter", PARAMETER;
"predicate", PREDICATE;
"prop", PROP;
"raise", RAISE;
"raises", RAISES;
"reads", READS;
"real", REAL;
"rec", REC;
"ref", REF;
"returns", RETURNS;
"then", THEN;
"true", TRUE;
"try", TRY;
"type", TYPE;
"unit", UNIT;
"variant", VARIANT;
"void", VOID;
"while", WHILE;
"with", WITH;
"writes", WRITES ]
let newline lexbuf =
let pos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <-
{ pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum }
let string_buf = Buffer.create 1024
exception Lexical_error of string
let char_for_backslash = function
| 'n' -> '\n'
| 't' -> '\t'
| c -> c
let update_loc lexbuf file line chars =
let pos = lexbuf.lex_curr_p in
let new_file = match file with None -> pos.pos_fname | Some s -> s in
lexbuf.lex_curr_p <-
{ pos with
pos_fname = new_file;
pos_lnum = int_of_string line;
pos_bol = pos.pos_cnum - int_of_string chars;
}
let remove_leading_plus s =
let n = String.length s in
if n > 0 && s.[0] = '+' then String.sub s 1 (n-1) else s
let option_app f = function None -> None | Some x -> Some (f x)
}
let newline = '\n'
let space = [' ' '\t' '\r']
let alpha = ['a'-'z' 'A'-'Z']
let letter = alpha | '_'
let digit = ['0'-'9']
let ident = letter (letter | digit | '\'')*
let hexadigit = ['0'-'9' 'a'-'f' 'A'-'F']
(*
let hexafloat = '0' ['x' 'X'] (hexadigit* '.' hexadigit+ | hexadigit+ '.' hexadigit* ) ['p' 'P'] ['-' '+']? digit+
*)
rule token = parse
| "#" space* ("\"" ([^ '\010' '\013' '"' ]* as file) "\"")?
space* (digit+ as line) space* (digit+ as char) space* "#"
{ update_loc lexbuf file line char; token lexbuf }
| newline
{ newline lexbuf; token lexbuf }
| space+
{ token lexbuf }
| ident as id
{ try Hashtbl.find keywords id with Not_found -> IDENT id }
| digit+ as s
{ INTEGER s }
| (digit+ as i) ("" as f) ['e' 'E'] (['-' '+']? digit+ as e)
| (digit+ as i) '.' (digit* as f) (['e' 'E'] (['-' '+']? digit+ as e))?
| (digit* as i) '.' (digit+ as f) (['e' 'E'] (['-' '+']? digit+ as e))?
{ FLOAT (RConstDecimal (i, f, option_app remove_leading_plus e)) }
| '0' ['x' 'X'] ((hexadigit* as i) '.' (hexadigit+ as f)
|(hexadigit+ as i) '.' (hexadigit* as f)
|(hexadigit+ as i) ("" as f))
['p' 'P'] (['-' '+']? digit+ as e)
{ FLOAT (RConstHexa (i, f, remove_leading_plus e)) }
| "(*"
{ comment lexbuf; token lexbuf }
| "'"
{ QUOTE }
| ","
{ COMMA }
| "("
{ LEFTPAR }
| ")"
{ RIGHTPAR }
| "!"
{ BANG }
| ":"
{ COLON }
| ";"
{ SEMICOLON }
| ":="
{ COLONEQUAL }
| "->"
{ ARROW }
| "<->"
{ LRARROW }
| "="
{ EQUAL }
| "<"
{ LT }
| "<="
{ LE }
| ">"
{ GT }
| ">="
{ GE }
| "<>"
{ NOTEQ }
| "+"
{ PLUS }
| "-"
{ MINUS }
| "*"
{ TIMES }
| "/"
{ SLASH }
| "%"
{ PERCENT }
| "@"
{ AT }
| "."
{ DOT }
| "["
{ LEFTSQ }
| "]"
{ RIGHTSQ }
| "{"
{ LEFTB }
| "}"
{ RIGHTB }
| "{{"
{ LEFTBLEFTB }
| "}}"
{ RIGHTBRIGHTB }
| "|"
{ BAR }
| "||"
{ BARBAR }
| "&&"
{ AMPAMP }
| "=>"
{ BIGARROW }
| "\""
{ Buffer.clear string_buf; string lexbuf }
| eof
{ EOF }
| _ as c
{ raise (Lexical_error ("illegal character: " ^ String.make 1 c)) }
and comment = parse
| "*)"
{ () }
| "(*"
{ comment lexbuf; comment lexbuf }
| newline
{ newline lexbuf; comment lexbuf }
| eof
{ raise (Lexical_error "unterminated comment") }
| _
{ comment lexbuf }
and string = parse
| "\""
{ STRING (Buffer.contents string_buf) }
| "\\" (_ as c)
{ Buffer.add_char string_buf (char_for_backslash c); string lexbuf }
| newline
{ newline lexbuf; Buffer.add_char string_buf '\n'; string lexbuf }
| eof
{ raise (Lexical_error "unterminated string") }
| _ as c
{ Buffer.add_char string_buf c; string lexbuf }
{
let loc lb = (lexeme_start_p lb, lexeme_end_p lb)
let with_location f lb =
try f lb with e -> raise (Loc.Located (loc lb, e))
let parse_lexpr = with_location (lexpr token)
let parse_logic_file = with_location (logic_file token)
let lexpr_of_string s = parse_lexpr (from_string s)
}
(*
Local Variables:
compile-command: "unset LANG; make -j -C .. bin/why.byte"
End:
*)
%{
open Ptree
open Parsing
let loc () = (symbol_start_pos (), symbol_end_pos ())
let loc_i i = (rhs_start_pos i, rhs_end_pos i)
let loc_ij i j = (rhs_start_pos i, rhs_end_pos j)
let mk_ppl loc d = { pp_loc = loc; pp_desc = d }
let mk_pp d = mk_ppl (loc ()) d
let mk_pp_i i d = mk_ppl (loc_i i) d
let infix_ppl loc a i b = mk_ppl loc (PPinfix (a, i, b))
let infix_pp a i b = infix_ppl (loc ()) a i b
let prefix_ppl loc p a = mk_ppl loc (PPprefix (p, a))
let prefix_pp p a = prefix_ppl (loc ()) p a
(***
let with_loc loc d = { pdesc = d; ploc = loc }
let locate d = with_loc (loc ()) d
let locate_i i d = with_loc (loc_i i) d
let rec_name = function Srec (x,_,_,_,_,_) -> x | _ -> assert false
let join (b,_) (_,e) = (b,e)
let rec app f = function
| [] ->
assert false
| [a] ->
Sapp (f, a)
| a :: l ->
let loc = join f.ploc a.ploc in
app (with_loc loc (Sapp (f, a))) l
let bin_op (loc_op,op) e1 e2 =
let f = with_loc loc_op (Svar op) in
let f_e1 = with_loc (join e1.ploc loc_op) (Sapp (f, e1)) in
locate (Sapp (f_e1, e2))
let un_op (loc_op,op) e =
locate (app (with_loc loc_op (Svar op)) [e])
let ptype_c_of_v v =
{ pc_result_name = Ident.result;
pc_result_type = v;
pc_effect = { pe_reads = []; pe_writes = []; pe_raises = [] };
pc_pre = [];
pc_post = None }
let list_of_some = function None -> [] | Some x -> [x]
(*s ensures a postcondition for a function body *)
let force_function_post ?(warn=false) e = match e.pdesc with
| Spost _ ->
e
| _ ->
if warn then
Format.eprintf
"%ano postcondition for this function; true inserted@\n"
Loc.report_position e.ploc;
let q =
{ pa_name = Anonymous; pa_value = mk_pp PPtrue; pa_loc = loc () }
in
{ e with pdesc = Spost (e, (q, []), Transparent) }
***)
%}
/* Tokens */
%token <string> IDENT
%token <string> INTEGER
%token <Ptree.real_constant> FLOAT
%token <string> STRING
%token ABSURD AMPAMP AND ARRAY ARROW AS ASSERT AT AXIOM
%token BANG BAR BARBAR BEGIN
%token BIGARROW BOOL CHECK COLON COLONEQUAL COMMA DO DONE DOT ELSE END EOF EQUAL
%token EXCEPTION EXISTS EXTERNAL FALSE FOR FORALL FPI FUN FUNCTION GE GOAL GT
%token IF IN INCLUDE INDUCTIVE INT INVARIANT
%token LE LEFTB LEFTBLEFTB LEFTPAR LEFTSQ LET LOGIC LRARROW LT MATCH MINUS
%token NOT NOTEQ OF OR PARAMETER PERCENT PLUS PREDICATE PROP
%token QUOTE RAISE RAISES READS REAL REC REF RETURNS RIGHTB RIGHTBRIGHTB
%token RIGHTPAR RIGHTSQ
%token SEMICOLON SLASH
%token THEN TIMES TRUE TRY TYPE UNIT VARIANT VOID WHILE WITH WRITES
/* Precedences */
%nonassoc prec_recfun
%nonassoc prec_fun
%left LEFTB LEFTBLEFTB
%left prec_simple
%left COLON
%left prec_letrec
%left IN
%right SEMICOLON
%left prec_no_else
%left ELSE
%right prec_named
%left COLONEQUAL
%right prec_forall prec_exists
%right ARROW LRARROW
%right OR BARBAR
%right AND AMPAMP
%right NOT
%right prec_if
%left prec_relation EQUAL NOTEQ LT LE GT GE
%left PLUS MINUS
%left TIMES SLASH PERCENT
%right uminus
%left prec_app
%left prec_ident
%left LEFTSQ
/* Entry points */
%type <Ptree.lexpr> lexpr
%start lexpr
%type <Ptree.logic_file> logic_file
%start logic_file
%%
logic_file:
| list1_decl EOF
{ $1 }
| EOF
{ [] }
;
list1_decl:
| decl
{ [$1] }
| decl list1_decl
{ $1 :: $2 }
;
decl:
| external_ LOGIC list1_ident_sep_comma COLON logic_type
{ Logic (loc_i 3, $1, $3, $5) }
| AXIOM ident COLON lexpr
{ Axiom (loc (), $2, $4) }
| PREDICATE ident LEFTPAR list0_logic_binder_sep_comma RIGHTPAR EQUAL lexpr
{ Predicate_def (loc (), $2, $4, $7) }
| INDUCTIVE ident COLON logic_type inddefn
{ Inductive_def (loc (), $2, $4, $5) }
| FUNCTION ident LEFTPAR list0_logic_binder_sep_comma RIGHTPAR COLON
primitive_type EQUAL lexpr
{ Function_def (loc (), $2, $4, $7, $9) }
| GOAL ident COLON lexpr
{ Goal (loc (), $2, $4) }
| EXTERNAL TYPE typedecl
{ let loc, vl, id = $3 in TypeDecl (loc, true, vl, id) }
| TYPE typedecl typedefn
{ let loc, vl, id = $2 in $3 loc vl id }
;
typedecl:
| ident
{ (loc_i 1, [], $1) }
| type_var ident
{ (loc_i 2, [$1], $2) }
| LEFTPAR type_var COMMA list1_type_var_sep_comma RIGHTPAR ident
{ (loc_i 6, $2 :: $4, $6) }
;
typedefn:
| /* epsilon */
{ fun loc vl id -> TypeDecl (loc, false, vl, id) }
| EQUAL bar_ typecases typecont
{ fun loc vl id -> AlgType ((loc, vl, id, $3) :: $4) }
;
typecont:
| /* epsilon */
{ [] }
| AND typedecl EQUAL bar_ typecases typecont
{ let loc, vl, id = $2 in (loc, vl, id, $5) :: $6 }
;
typecases:
| typecase { [$1] }
| typecase BAR typecases { $1::$3 }
;
typecase:
| ident
{ (loc_i 1,$1,[]) }
| ident LEFTPAR list1_primitive_type_sep_comma RIGHTPAR
{ (loc_i 1,$1,$3) }
;
inddefn:
| /* epsilon */ { [] }
| EQUAL bar_ indcases { $3 }
;
indcases:
| indcase { [$1] }
| indcase BAR indcases { $1::$3 }
;
indcase:
| ident COLON lexpr { (loc_i 1,$1,$3) }
;
primitive_type:
| INT
{ PPTint }
| BOOL
{ PPTbool }
| REAL
{ PPTreal }
| UNIT
{ PPTunit }
| type_var
{ PPTvarid ($1, loc ()) }
| ident
{ PPTexternal ([], $1, loc ()) }
| primitive_type ident
{ PPTexternal ([$1], $2, loc_i 2) }
| LEFTPAR primitive_type COMMA list1_primitive_type_sep_comma RIGHTPAR ident
{ PPTexternal ($2 :: $4, $6, loc_i 6) }
/*
| LEFTPAR list1_primitive_type_sep_comma RIGHTPAR
{ match $2 with [p] -> p | _ -> raise Parse_error }
*/
;
logic_type:
| list0_primitive_type_sep_comma ARROW PROP
{ PPredicate $1 }
| PROP
{ PPredicate [] }
| list0_primitive_type_sep_comma ARROW primitive_type
{ PFunction ($1, $3) }
| primitive_type
{ PFunction ([], $1) }
;
list0_primitive_type_sep_comma:
| /* epsilon */ { [] }
| list1_primitive_type_sep_comma { $1 }
;
list1_primitive_type_sep_comma:
| primitive_type { [$1] }
| primitive_type COMMA list1_primitive_type_sep_comma { $1 :: $3 }
;
list0_logic_binder_sep_comma:
| /* epsilon */ { [] }
| list1_logic_binder_sep_comma { $1 }
;
list1_logic_binder_sep_comma:
| logic_binder { [$1] }
| logic_binder COMMA list1_logic_binder_sep_comma { $1 :: $3 }
;
logic_binder:
| ident COLON primitive_type
{ (loc_i 1, $1, $3) }
/***
| ident COLON primitive_type ARRAY
{ (loc_i 1, $1, PPTexternal ([$3], Ident.farray, loc_i 3)) }
***/
;
external_:
| /* epsilon */ { false }
| EXTERNAL { true }
;
lexpr:
| lexpr ARROW lexpr
{ infix_pp $1 PPimplies $3 }
| lexpr LRARROW lexpr
{ infix_pp $1 PPiff $3 }
| lexpr OR lexpr
{ infix_pp $1 PPor $3 }
| lexpr AND lexpr
{ infix_pp $1 PPand $3 }
| NOT lexpr
{ prefix_pp PPnot $2 }
| lexpr relation lexpr %prec prec_relation
{ infix_pp $1 $2 $3 }
| lexpr PLUS lexpr
{ infix_pp $1 PPadd $3 }
| lexpr MINUS lexpr
{ infix_pp $1 PPsub $3 }
| lexpr TIMES lexpr
{ infix_pp $1 PPmul $3 }
| lexpr SLASH lexpr
{ infix_pp $1 PPdiv $3 }
| lexpr PERCENT lexpr
{ infix_pp $1 PPmod $3 }
| MINUS lexpr %prec uminus
{ prefix_pp PPneg $2 }
/***
| qualid_ident
{ mk_pp (PPvar $1) }
| qualid_ident LEFTPAR list1_lexpr_sep_comma RIGHTPAR
{ mk_pp (PPapp ($1, $3)) }
| qualid_ident LEFTSQ lexpr RIGHTSQ
{ mk_pp (PPapp (Ident.access, [mk_pp_i 1 (PPvar $1); $3])) }
***/
| IF lexpr THEN lexpr ELSE lexpr %prec prec_if
{ mk_pp (PPif ($2, $4, $6)) }
| FORALL list1_ident_sep_comma COLON primitive_type triggers
DOT lexpr %prec prec_forall
{ let rec mk = function
| [] -> assert false
| [id] -> mk_pp (PPforall (id, $4, $5, $7))
| id :: l -> mk_pp (PPforall (id, $4, [], mk l))
in
mk $2 }
| EXISTS ident COLON primitive_type DOT lexpr %prec prec_exists
{ mk_pp (PPexists ($2, $4, $6)) }
| INTEGER
{ mk_pp (PPconst (ConstInt $1)) }
| FLOAT
{ mk_pp (PPconst (ConstFloat $1)) }
| TRUE
{ mk_pp PPtrue }
| FALSE
{ mk_pp PPfalse }
/***
| VOID
{ mk_pp (PPconst ConstUnit) }
***/
| LEFTPAR lexpr RIGHTPAR
{ $2 }
| ident_or_string COLON lexpr %prec prec_named
{ mk_pp (PPnamed ($1, $3)) }
| LET ident EQUAL lexpr IN lexpr
{ mk_pp (PPlet ($2, $4, $6)) }
| MATCH lexpr WITH bar_ match_cases END
{ mk_pp (PPmatch ($2, $5)) }
;
match_cases:
| match_case { [$1] }
| match_case BAR match_cases { $1::$3 }
;
match_case:
| pattern ARROW lexpr { ($1,$3) }
;
pattern:
| ident { ($1, [], loc ()) }
| ident LEFTPAR list1_ident_sep_comma RIGHTPAR { ($1, $3, loc ()) }
;
triggers:
| /* epsilon */ { [] }
| LEFTSQ list1_trigger_sep_bar RIGHTSQ { $2 }
;
list1_trigger_sep_bar:
| trigger { [$1] }
| trigger BAR list1_trigger_sep_bar { $1 :: $3 }
;
trigger:
list1_lexpr_sep_comma { $1 }
;
list1_lexpr_sep_comma:
| lexpr { [$1] }
| lexpr COMMA list1_lexpr_sep_comma { $1 :: $3 }
;
relation:
| LT { PPlt }
| LE { PPle }
| GT { PPgt }
| GE { PPge }
| EQUAL { PPeq }
| NOTEQ { PPneq }
;
type_var:
| QUOTE ident { $2 }
;
list1_type_var_sep_comma:
| type_var { [$1] }
| type_var COMMA list1_type_var_sep_comma { $1 :: $3 }
;
ident:
| IDENT { $1 }
;
qualid_ident:
| IDENT { $1, None }
| IDENT AT { $1, Some "" }
| IDENT AT IDENT { $1, Some $3 }
;
ident_or_string:
| IDENT { $1 }
| STRING { $1 }
;
bar_:
| /* epsilon */ { () }
| BAR { () }
;
list1_ident_sep_comma:
| ident { [$1] }
| ident COMMA list1_ident_sep_comma { $1 :: $3 }
;
/******* programs **************************************************
list0_ident_sep_comma:
| /* epsilon * / { [] }
| list1_ident_sep_comma { $1 }
;
decl:
| INCLUDE STRING
{ Include (loc_i 2,$2) }
| LET ident EQUAL expr
{ Program (loc_i 2,$2, $4) }
| LET ident binders EQUAL list0_bracket_assertion expr
{ Program (loc_i 2,$2, locate (Slam ($3, $5, force_function_post $6))) }
| LET REC recfun
{ let (loc,p) = $3 in Program (loc,rec_name p, locate p) }
| EXCEPTION ident
{ Exception (loc (), $2, None) }
| EXCEPTION ident OF primitive_type
{ Exception (loc (), $2, Some $4) }
| external_ PARAMETER list1_ident_sep_comma COLON type_v
{ Parameter (loc_i 3, $1, $3, $5) }
type_v:
| simple_type_v ARROW type_c
{ PVarrow ([Ident.anonymous, $1], $3) }
| ident COLON simple_type_v ARROW type_c
{ PVarrow ([($1, $3)], $5) }
| simple_type_v
{ $1 }
;
simple_type_v:
| primitive_type ARRAY { PVref (PPTexternal ([$1], Ident.farray, loc_i 2)) }
| primitive_type REF { PVref $1 }
| primitive_type { PVpure $1 }
| LEFTPAR type_v RIGHTPAR { $2 }
;
type_c:
| LEFTB opt_assertion RIGHTB result effects LEFTB opt_post_condition RIGHTB
{ let id,v = $4 in
{ pc_result_name = id; pc_result_type = v;
pc_effect = $5; pc_pre = list_of_some $2; pc_post = $7 } }
| type_v
{ ptype_c_of_v $1 }
;
result: