Skip to content

GitLab

Commit 6a159d62 authored by Jean-Christophe Filliâtre's avatar Jean-Christophe Filliâtre
Browse files

programs are now parsed with src/parser/

parent 7d2eca12
Hide whitespace changes
Inline Side-by-side
Makefile.in
View file @ 6a159d62
......@@ -282,10 +282,9 @@ install_no_local::
# Whyml
########
PGMGENERATED = src/programs/pgm_parser.mli src/programs/pgm_parser.ml \
src/programs/pgm_lexer.ml
PGMGENERATED =
PGM_FILES = pgm_ttree pgm_ptree pgm_parser pgm_lexer \
PGM_FILES = pgm_ttree \
pgm_types pgm_module pgm_wp pgm_env pgm_typing pgm_main
PGMMODULES = $(addprefix src/programs/, $(PGM_FILES))
......
modules/stdlib.mlw
View file @ 6a159d62
module Ref
{ use import programs.Prelude }
use import programs.Prelude
mutable type ref 'a model 'a
......
src/parser/lexer.mli
View file @ 6a159d62
......@@ -29,6 +29,8 @@ val parse_list0_decl :
val parse_lexpr : Lexing.lexbuf -> Ptree.lexpr
val parse_program_file : Lexing.lexbuf -> Ptree.program_file
(** other functions to be re-used in other lexers/parsers *)
val newline : Lexing.lexbuf -> unit
......
src/parser/lexer.mll
View file @ 6a159d62
......@@ -301,6 +301,8 @@ and string = parse
let parse_lexpr = with_location (lexpr_eof token)
let parse_program_file = with_location (program_file token)
let read_channel env file c =
let lb = Lexing.from_channel c in
Loc.set_file file lb;
......
src/parser/parser.pre.mly
View file @ 6a159d62
......@@ -1144,6 +1144,7 @@ simple_type_c:
;
annotation:
| LEFTBRC RIGHTBRC { mk_pp PPtrue }
| LEFTBRC lexpr RIGHTBRC { $2 }
;
......
src/programs/pgm_lexer.mll deleted 100644 → 0
View file @ 7d2eca12
(**************************************************************************)
(* *)
(* Copyright (C) 2010- *)
(* François Bobot *)
(* Jean-Christophe Filliâtre *)
(* Claude Marché *)
(* Andrei Paskevich *)
(* *)
(* This software is free software; you can redistribute it and/or *)
(* modify it under the terms of the GNU Library General Public *)
(* License version 2.1, with the special exception on linking *)
(* described in file LICENSE. *)
(* *)
(* This software is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *)
(* *)
(**************************************************************************)
{
open Format
open Lexing
open Why
open Lexer
open Term
open Pgm_parser
exception UnterminatedLogic
exception IllegalCharacter of char
let () = Exn_printer.register (fun fmt exn -> match exn with
| UnterminatedLogic -> fprintf fmt "unterminated logic block"
| IllegalCharacter c -> fprintf fmt "illegal character %c" c
| Parsing.Parse_error -> fprintf fmt "syntax error"
| _ -> raise exn)
let keywords = Hashtbl.create 97
let () =
List.iter
(fun (x,y) -> Hashtbl.add keywords x y)
[ "absurd", ABSURD;
"and", AND;
"any", ANY;
"as", AS;
"assert", ASSERT;
"assume", ASSUME;
"begin", BEGIN;
"check", CHECK;
"do", DO;
"done", DONE;
"downto", DOWNTO;
"else", ELSE;
"export", EXPORT;
"end", END;
"exception", EXCEPTION;
"for", FOR;
"fun", FUN;
"ghost", GHOST;
"if", IF;
"import", IMPORT;
"in", IN;
"invariant", INVARIANT;
"label", LABEL;
"let", LET;
"match", MATCH;
"model", MODEL;
"module", MODULE;
"mutable", MUTABLE;
"namespace", NAMESPACE;
"not", NOT;
"of", OF;
"parameter", PARAMETER;
"raise", RAISE;
"raises", RAISES;
"reads", READS;
"rec", REC;
"then", THEN;
"to", TO;
"try", TRY;
"type", TYPE;
"use", USE;
"variant", VARIANT;
"while", WHILE;
"with", WITH;
"writes", WRITES;
]
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 logic_start_loc = ref Loc.dummy_position
let logic_buffer = Buffer.create 1024
let loc lb = (lexeme_start_p lb, lexeme_end_p lb)
}
let newline = '\n'
let space = [' ' '\t' '\r']
let lalpha = ['a'-'z' '_']
let ualpha = ['A'-'Z']
let alpha = lalpha | ualpha
let digit = ['0'-'9']
let lident = lalpha (alpha | digit | '\'')*
let uident = ualpha (alpha | digit | '\'')*
let decimal_literal =
['0'-'9'] ['0'-'9' '_']*
let hex_literal =
'0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
let oct_literal =
'0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
let bin_literal =
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
let int_literal =
decimal_literal | hex_literal | oct_literal | bin_literal
let hexadigit = ['0'-'9' 'a'-'f' 'A'-'F']
let op_char_1 = ['=' '<' '>' '~']
let op_char_2 = ['+' '-']
let op_char_3 = ['*' '/' '%']
let op_char_4 = ['!' '$' '&' '?' '@' '^' '.' ':' '|' '#']
let op_char_34 = op_char_3 | op_char_4
let op_char_234 = op_char_2 | op_char_34
let op_char_1234 = op_char_1 | op_char_234
let op_char_pref = ['!' '?']
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 }
| '_'
{ UNDERSCORE }
| lident as id
{ try Hashtbl.find keywords id with Not_found -> LIDENT id }
| uident as id
{ UIDENT id }
| int_literal 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))?
{ REAL (RConstDecimal (i, f, Util.option_map 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)
{ REAL (RConstHexa (i, f, remove_leading_plus e)) }
| "(*)"
{ LEFTPAR_STAR_RIGHTPAR }
| "(*"
{ comment lexbuf; token lexbuf }
| "'"
{ QUOTE }
| "`"
{ BACKQUOTE }
| ","
{ COMMA }
| "("
{ LEFTPAR }
| ")"
{ RIGHTPAR }
| ":"
{ COLON }
| ";"
{ SEMICOLON }
| ":="
{ COLONEQUAL }
| "->"
{ ARROW }
| "="
{ EQUAL }
| "<>"
{ LTGT }
| "@"
{ AT }
| "."
{ DOT }
| "["
{ LEFTSQ }
| "]"
{ RIGHTSQ }
| "{"
{ logic_start_loc := loc lexbuf;
let s = logic lexbuf in
LOGIC ((fst !logic_start_loc, snd (loc lexbuf)), s) }
(* FIXME: allow newlines as well *)
| "{" space* "}"
{ LOGIC (loc lexbuf, "true") }
| "{{"
{ LEFTBLEFTB }
| "}}"
{ RIGHTBRIGHTB }
| "|"
{ BAR }
| "||"
{ BARBAR }
| "&&"
{ AMPAMP }
| op_char_pref op_char_4* as s
{ OPPREF s }
| op_char_1234* op_char_1 op_char_1234* as s
{ OP1 s }
| op_char_234* op_char_2 op_char_234* as s
{ OP2 s }
| op_char_34* op_char_3 op_char_34* as s
{ OP3 s }
| op_char_4+ as s
{ OP4 s }
| "\""
{ STRING (string lexbuf) }
| eof
{ EOF }
| _ as c
{ raise (IllegalCharacter c) }
and logic = parse
| "}"
{ let s = Buffer.contents logic_buffer in
Buffer.clear logic_buffer;
s }
| newline
{ newline lexbuf; Buffer.add_char logic_buffer '\n'; logic lexbuf }
| eof
{ raise (Loc.Located (!logic_start_loc, UnterminatedLogic)) }
| _ as c
{ Buffer.add_char logic_buffer c; logic lexbuf }
{
let parse_file = with_location (file token)
}
(*
Local Variables:
compile-command: "unset LANG; make -C ../.. testl"
End:
*)
src/programs/pgm_main.ml
View file @ 6a159d62
......@@ -24,13 +24,14 @@ open Why
open Util
open Ident
open Ptree
open Pgm_ptree
open Pgm_module
let add_module ?(type_only=false) env penv lmod m =
let wp = not type_only in
let id = m.mod_name in
let uc = create_module (Ident.id_user id.id id.id_loc) in
let prelude = Env.find_theory env ["programs"] "Prelude" in
let uc = use_export_theory uc prelude in
let uc = List.fold_left (Pgm_typing.decl ~wp env penv lmod) uc m.mod_decl in
let m = close_module uc in
Mnm.add id.id m lmod
......@@ -38,7 +39,7 @@ let add_module ?(type_only=false) env penv lmod m =
let retrieve penv file c =
let lb = Lexing.from_channel c in
Loc.set_file file lb;
let ml = Pgm_lexer.parse_file lb in
let ml = Lexer.parse_program_file lb in
if Debug.test_flag Typing.debug_parse_only then
Mnm.empty
else
......
src/programs/pgm_module.ml
View file @ 6a159d62
......@@ -175,24 +175,11 @@ let use_export uc m =
uc_th = Theory.use_export uc.uc_th m.m_th; }
| _ -> assert false
(* parsing LOGIC strings using functions from src/parser/
requires proper relocation *)
let use_export_theory uc th =
{ uc with uc_th = Theory.use_export uc.uc_th th }
let reloc loc lb =
lb.Lexing.lex_curr_p <- loc;
lb.Lexing.lex_abs_pos <- loc.Lexing.pos_cnum + 1
let parse_string f loc s =
let lb = Lexing.from_string s in
reloc loc lb;
f lb
let logic_lexpr ((pos, _), s) =
parse_string Lexer.parse_lexpr pos s
let parse_logic_decls env ((loc, _), s) uc =
let parse = Lexer.parse_list0_decl env Theory.Mnm.empty uc.uc_th in
{ uc with uc_th = parse_string parse loc s }
let add_logic_pdecl env d uc =
{ uc with uc_th = Typing.add_decl env Theory.Mnm.empty uc.uc_th d }
......
src/programs/pgm_module.mli
View file @ 6a159d62
......@@ -40,6 +40,7 @@ val open_namespace : uc -> uc
val close_namespace : uc -> bool -> string option -> uc
val use_export : uc -> t -> uc
val use_export_theory : uc -> Theory.theory -> uc
(** insertion *)
......@@ -51,9 +52,7 @@ val add_mtsymbol : mtsymbol -> uc -> uc
val add_decl : Pgm_ttree.decl -> uc -> uc
val add_logic_decl : Decl.decl -> uc -> uc
(** TODO: *)
val parse_logic_decls : Env.env -> Loc.position * string -> uc -> uc
val logic_lexpr : Loc.position * string -> Ptree.lexpr
val add_logic_pdecl : Env.env -> Ptree.decl -> uc -> uc
(** exceptions *)
......
src/programs/pgm_parser.mly deleted 100644 → 0
View file @ 7d2eca12
/**************************************************************************/
/* */
/* Copyright (C) 2010- */
/* François Bobot */
/* Jean-Christophe Filliâtre */
/* Claude Marché */
/* Andrei Paskevich */
/* */
/* This software is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU Library General Public */
/* License version 2.1, with the special exception on linking */
/* described in file LICENSE. */
/* */
/* This software is distributed in the hope that it will be useful, */
/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. */
/* */
/**************************************************************************/
%{
open Parsing
open Lexing
open Why
open Ptree
open Pgm_ptree
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_expr d = { expr_loc = loc (); expr_desc = d }
let mk_expr_i i d = { expr_loc = loc_i i; expr_desc = d }
let mk_pat p = { pat_loc = loc (); pat_desc = p }
let add_lab id l = { id with id_lab = l }
let user_loc fname lnum bol cnum1 cnum2 =
let pos = {
Lexing.pos_fname = fname;
Lexing.pos_lnum = lnum;
Lexing.pos_bol = bol;
Lexing.pos_cnum = cnum1 }
in
pos, { pos with Lexing.pos_cnum = cnum2 }
(* FIXME: factorize with parser/parser.mly *)
let infix s = "infix " ^ s
let prefix s = "prefix " ^ s
let postfix s = "postfix " ^ s
let join (b,_) (_,e) = (b,e)
let rec mk_apply f = function
| [] ->
assert false
| [a] ->
Eapply (f, a)
| a :: l ->
let loc = join f.expr_loc a.expr_loc in
mk_apply { expr_loc = loc; expr_desc = Eapply (f, a) } l
let mk_apply_id id =
let e =
{ expr_desc = Eident (Qident id); expr_loc = id.id_loc }
in
mk_apply e
let mk_infix e1 op e2 =
let id = { id = infix op; id_lab = []; id_loc = loc_i 2 } in
mk_expr (mk_apply_id id [e1; e2])
let mk_binop e1 op e2 =
let id = { id = op; id_lab = []; id_loc = loc_i 2 } in
mk_expr (mk_apply_id id [e1; e2])
let mk_prefix op e1 =
let id = { id = prefix op; id_lab = []; id_loc = loc_i 1 } in
mk_expr (mk_apply_id id [e1])
let id_unit () = { id = "unit"; id_lab = []; id_loc = loc () }
let id_result () = { id = "result"; id_lab = []; id_loc = loc () }
let id_anonymous () = { id = "_"; id_lab = []; id_loc = loc () }
let exit_exn () = Qident { id = "%Exit"; id_lab = []; id_loc = loc () }
let id_lt_nat () = Qident { id = "lt_nat"; id_lab = []; id_loc = loc () }
let ty_unit () = Tpure (PPTtyapp ([], Qident (id_unit ())))
let lexpr_true () = loc (), "true"
let lexpr_false () = loc (), "false"
let empty_effect = { pe_reads = []; pe_writes = []; pe_raises = [] }
let type_c p ty ef q =
{ pc_result_type = ty;
pc_effect = ef;
pc_pre = p;
pc_post = q; }
let cast_body c ((p,e,q) as t) = match c with
| None -> t
| Some pt -> p, { e with expr_desc = Ecast (e, pt) }, q
%}
/* Tokens */
%token <string> LIDENT UIDENT
%token <string> INTEGER
%token <string> OP1 OP2 OP3 OP4 OPPREF
%token <Why.Ptree.real_constant> REAL
%token <string> STRING
%token <Why.Loc.position * string> LOGIC
/* keywords */
%token ABSURD AND ANY AS ASSERT ASSUME BEGIN CHECK DO DONE DOWNTO ELSE END
%token EXCEPTION EXPORT FOR
%token FUN GHOST IF IMPORT IN INVARIANT LABEL LET MATCH MODEL MODULE MUTABLE
%token NAMESPACE NOT OF PARAMETER
%token RAISE RAISES READS REC
%token THEN TO TRY TYPE USE VARIANT WHILE WITH WRITES
/* symbols */
%token UNDERSCORE QUOTE COMMA LEFTPAR RIGHTPAR COLON SEMICOLON
%token COLONEQUAL ARROW EQUAL LTGT AT DOT LEFTSQ RIGHTSQ
%token LEFTBLEFTB RIGHTBRIGHTB BAR BARBAR AMPAMP
%token BACKQUOTE LEFTPAR_STAR_RIGHTPAR EOF
/* Precedences */
%nonassoc prec_post
%nonassoc BAR
%nonassoc prec_id_pattern
%nonassoc prec_recfun
%nonassoc prec_triple
%left LEFTBLEFTB
%left prec_simple
%left COLON
%left prec_letrec
%left IN
%nonassoc GHOST
%right SEMICOLON
%left prec_no_else
%left ELSE
%left COLONEQUAL
%right BARBAR
%right AMPAMP
%right prec_if
%left EQUAL LTGT OP1
%left OP2
%left OP3
%left OP4
%nonassoc prefix_op
%right unary_op
%left prec_app
%left prec_ident
%left LEFTSQ
%nonassoc prec_decls
%nonassoc LOGIC TYPE INDUCTIVE
/* Entry points */
%type <Pgm_ptree.file> file
%start file
%%
file:
| list0_module_ EOF { $1 }
;
list0_module_:
| /* epsilon */
{ [] }
| list1_module_
{ $1 }
;
list1_module_:
| module_
{ [$1] }
| module_ list1_module_
{ $1 :: $2 }
;
module_:
| MODULE uident list0_decl END
{ { mod_name = $2; mod_decl = $3 } }
;
list0_decl:
| /* epsilon */
{ [] }
| list1_decl
{ $1 }
;
list1_decl:
| decl
{ [$1] }
| decl list1_decl
{ $1 :: $2 }
;
decl:
| LOGIC
{ Dlogic $1 }
| LET lident labels list1_type_v_binder opt_cast EQUAL triple
{ Dlet (add_lab $2 $3, mk_expr_i 7 (Efun ($4, cast_body $5 $7))) }
| LET lident labels EQUAL FUN list1_type_v_binder ARROW triple
{ Dlet (add_lab $2 $3, mk_expr_i 8 (Efun ($6, $8))) }
| LET REC list1_recfun_sep_and
{ Dletrec $3 }
| PARAMETER lident labels COLON type_v
{ Dparam (add_lab $2 $3, $5) }
| EXCEPTION uident labels