Commit 67d9d8f2 authored by POGODALLA Sylvain's avatar POGODALLA Sylvain

Intermediate state...

parent cd876851
#ACGC=acgc
ACGC=acgc
BUILD_PATH=../../../_build/default/src/
ACGC=$(BUILD_PATH)/grammars/acgc.exe
#ACGC=$(BUILD_PATH)/grammars/acgc.exe
#ACG=$(BUILD_PATH)/scripting/acg.exe
.PHONY: default clean all archive
......
This diff is collapsed.
......@@ -11,7 +11,7 @@
(menhir
(merge_into data_parser)
(flags (--explain --table --strict))
(modules file_parser sig_parser lex_parser type_parser term_parser))
(modules file_parser sig_parser lex_parser term_type_parser))
;; Rule to generate the messages ml file
......@@ -22,7 +22,7 @@
(alias update)
(alias check)
(:message_file data_parser.messages.new)
(:parsers file_parser.mly lex_parser.mly sig_parser.mly term_parser.mly type_parser.mly)
(:parsers file_parser.mly lex_parser.mly sig_parser.mly term_type_parser.mly)
)
(action
(with-stdout-to messages.ml (run %{bin:menhir} --base data_parser --explain --table --compile-errors %{message_file} %{parsers})))
......@@ -31,7 +31,7 @@
;; Rule to generate the automatic message file
(rule
(targets data_parser.messages.automatic)
(deps (:parsers file_parser.mly lex_parser.mly sig_parser.mly term_parser.mly type_parser.mly))
(deps (:parsers file_parser.mly lex_parser.mly sig_parser.mly term_type_parser.mly))
(action
(with-stdout-to data_parser.messages.automatic (run %{bin:menhir} --base data_parser --explain --table --list-errors %{parsers})))
)
......@@ -39,7 +39,7 @@
;; Rule to generate the message file
(rule
(targets data_parser.messages.new)
(deps (:parsers file_parser.mly lex_parser.mly sig_parser.mly term_parser.mly type_parser.mly))
(deps (:parsers file_parser.mly lex_parser.mly sig_parser.mly term_type_parser.mly))
(action (with-stdout-to data_parser.messages.new (run %{bin:menhir} --base data_parser --explain --table --update-errors data_parser.messages %{parsers}))
)
)
......@@ -54,7 +54,7 @@
(deps
data_parser.messages.automatic
data_parser.messages
(:parsers file_parser.mly lex_parser.mly sig_parser.mly term_parser.mly type_parser.mly)
(:parsers file_parser.mly lex_parser.mly sig_parser.mly term_type_parser.mly)
)
(action (run %{bin:menhir} --base data_parser --explain --table --compare-errors data_parser.messages.automatic --compare-errors data_parser.messages %{parsers}))
)
......
%{
type kind =
| Both
| Type
| Term
open Parser_types
let add_cst_interpretations term abs_sig lex (id,l) =
match Environment.Signature1.is_constant id abs with
| true,_ -> Environment.Lexicon.insert (Abstract_syntax.Constant (id,l,term)) lex
| false,_ -> emit_parse_error (Error.Unknown_constant id) l
let add_type_interpretation stype abs_sig lex (id,l) =
match Environment.Signature1.is_type id abs with
| true -> Environment.Lexicon.insert (Abstract_syntax.Type (id,l,term)) acc
| false -> emit_parse_error (Error.Unknown_type id) l
%}
%token <Logic.Abstract_syntax.Abstract_syntax.location> COLON_EQUAL
......@@ -18,8 +26,32 @@
lex_entry_eoi :
| e = lex_entry EOI { e }
%public lex_entry :
| cst = separated_nonempty_list(COMMA,id_or_sym) COLON_EQUAL t=atomic_type_or_term
%public lex_entry :
| cst = separated_nonempty_list(COMMA,id_or_sym) COLON_EQUAL t=type_or_term
{
fun lex e ->
let abs,obj = Environment.Lexicon.get_sig lex in
match t with
| t,Term_k ->
let term = get_term t Typing_env.empty obj [] in
List.fold_left (add_cst_interpretations term abs) lex cst
| t,Type_k ->
let stype = get_type t obj [] in
List.fold_left (add_type_interpretation stype abs) lex cst
| t,Both ->
let term = get_term t Typing_env.empty obj [] in
let stype = get_type t obj [] in
List.fold_left
(fun acc cst ->
add_type_interpretation
stype
abs
(add_cst_interpretations term abs acc cst)
cst)
}
(*
| cst = separated_nonempty_list(COMMA,id_or_sym) COLON_EQUAL t=type_or_term
{
fun lex e ->
let abs,obj = Environment.Lexicon.get_sig lex in
......@@ -72,32 +104,4 @@
cst
| false,false -> raise (Error.(Error (Parse_error ((Unknown_constant_nor_variable id),loc))))
}
| cst = separated_nonempty_list(COMMA,id_or_sym) COLON_EQUAL t=not_atomic_term
{
fun lex e ->
let abs,obj = Environment.Lexicon.get_sig lex in
let term,loc,ws = t Typing_env.empty obj [] in
List.fold_left
(fun acc (id,l) ->
match Environment.Signature1.is_constant id abs,Environment.Signature1.is_type id abs with
| (true,_),false -> Environment.Lexicon.insert (Abstract_syntax.Constant (id,loc,term)) acc
| (false,_), _ -> emit_parse_error (Error.Unknown_constant id) l
| (true,_),true -> failwith (Printf.sprintf "Bug: should not happen. \"%s\" should not be both a type and a term" id))
lex
cst
}
| cst = separated_nonempty_list(COMMA,id_or_sym) COLON_EQUAL t=not_atomic_type_expression
{
fun lex e ->
let abs,obj = Environment.Lexicon.get_sig lex in
let term,loc = t obj in
List.fold_left
(fun acc (id,l) ->
match Environment.Signature1.is_constant id abs,Environment.Signature1.is_type id abs with
| (false,_),true -> Environment.Lexicon.insert (Abstract_syntax.Type (id,loc,term)) acc
| _,false -> emit_parse_error (Error.Unknown_type id) l
| (true,_),true -> failwith (Printf.sprintf "Bug: should not happen. \"%s\" should not be both a type and a term" id))
lex
cst
}
*)
type kind_parameter =
| Type
| Term
type type_or_term_value =
| Type_value of Logic.Abstract_syntax.Abstract_syntax.type_def
| Term_value of Logic.Abstract_syntax.Abstract_syntax.term
| Term_token of Term_sequence.token
type kind =
| Type_k
| Term_k
| Both
type kind_parameter =
| Type
| Term
type type_or_term_value =
| Type_value of Logic.Abstract_syntax.Abstract_syntax.type_def
| Term_value of Logic.Abstract_syntax.Abstract_syntax.term
| Term_token of Term_sequence.token
......@@ -64,48 +64,29 @@ sig_entry_eoi :
ids
}
type_or_term_definition_prefix :
| id = IDENT EQUAL type_or_cst = atomic_type_or_term COLON { id,type_or_cst }
type_definition :
| definition = type_or_term_definition_prefix TYPE
| id = IDENT EQUAL type_or_cst = type_or_term COLON TYPE
{
fun sg _ ->
let (id_name,id_loc),(type_expr,type_expr_loc) = definition in
if Environment.Signature1.is_type type_expr sg then
try
Environment.Signature1.add_entry (Abstract_syntax.(Type_def (id_name,id_loc,Type_atom(type_expr,type_expr_loc,[]),K []))) sg
with
| Environment.Signature1.Duplicate_type_definition ->
emit_parse_error (Error.Duplicated_type id_name) id_loc
else
emit_parse_error (Error.Unknown_type type_expr) type_expr_loc
}
| id = IDENT EQUAL type_expr = not_atomic_type_expression COLON TYPE
{
fun s _ ->
let id_name,id_loc = id in
let type_expr',_ = type_expr s in
let type_expr,type_expr_loc,_ = get_type type_or_cst sg [] in
try
Environment.Signature1.add_entry (Abstract_syntax.Type_def (id_name,id_loc,type_expr',Abstract_syntax.K [])) s
Environment.Signature1.add_entry (Abstract_syntax.Type_def (id_name,id_loc,type_expr,Abstract_syntax.K [])) s
with
| Environment.Signature1.Duplicate_type_definition ->
emit_parse_error (Error.Duplicated_type id_name) id_loc
}
term_declaration :
| dec = term_dec_start COLON type_exp = type_expression
term_declaration :
| dec = term_dec_start COLON type_exp = type_or_term
{
fun s e ->
let dec',s' = dec s in
List.fold_left
(fun acc ((id,loc),kind) ->
try
let ty = fst (type_exp acc) in
let ty = get_type type_exp acc [] in
Environment.Signature1.add_entry (Abstract_syntax.Term_decl (id,kind,loc,ty)) acc
with
| Environment.Signature1.Duplicate_term_definition ->
......@@ -125,52 +106,32 @@ sig_entry_eoi :
| INFIX opt = infix_option sym = SYMBOL { fun sg ->
let sym,fix,sg' = build_infix opt sym sg in
[sym,fix],sg'
(* let sym_id,_ = sym in
let p,sg' = Environment.Signature1.new_precedence sym_id sg in
[sym,Abstract_syntax.Infix (Left,p)],sg *)
}
| BINDER id = IDENT { fun sg -> [id,Abstract_syntax.Binder],sg }
term_definition :
| definition = type_or_term_definition_prefix ty = type_expression
{
fun sg _ ->
let (id,l),(term,term_loc) = definition in
if fst (Environment.Signature1.is_constant term sg) then
try
let term = Abstract_syntax.Const (term,term_loc) in
let ty',_ = ty sg in
Environment.Signature1.add_entry (Abstract_syntax.Term_def (id,Abstract_syntax.Default,l,term,ty')) sg
with
| Environment.Signature1.Duplicate_term_definition ->
emit_parse_error (Error.Duplicated_term id) l
else
emit_parse_error (Error.Unknown_constant term) term_loc
}
| id = IDENT EQUAL t = not_atomic_term COLON ty = type_expression
| id = IDENT EQUAL t = type_or_term COLON ty = type_or_term
{
fun s _ ->
let id',l = id in
try
(* Attention, BUG : pas de gestion des warnings !!! *)
let term,_,_ = t Typing_env.empty s [] in
let ty',_ = ty s in
let term,_,_ = get_term t Typing_env.empty s [] in
let ty',_ = get_type ty s [] in
Environment.Signature1.add_entry (Abstract_syntax.Term_def (id',Abstract_syntax.Default,l,term,ty')) s
with
| Environment.Signature1.Duplicate_term_definition ->
emit_parse_error (Error.Duplicated_term id') l}
| def = term_def_start EQUAL t = term COLON ty = type_expression
| def = term_def_start EQUAL t = type_or_term COLON ty = type_or_term
{
fun s _ ->
let (id,l),k,s' = def s in
try
(* Attention, BUG : pas de gestion des warnings !!! *)
let term,_,_ = t Typing_env.empty s' [] in
let ty',_ = ty s' in
let term,_,_ = get_term t Typing_env.empty s' [] in
let ty',_ = get_type ty s' [] in
Environment.Signature1.add_entry (Abstract_syntax.Term_def (id,k,l,term,ty')) s'
with
| Environment.Signature1.Duplicate_term_definition ->
......@@ -185,23 +146,7 @@ sig_entry_eoi :
let sym_id,_ = sym in
let p,sg' = Environment.Signature1.new_precedence sym_id sg in
sym,Abstract_syntax.Infix (Abstract_syntax.Left,p),sg'}
| INFIX opt = infix_option sym = SYMBOL {fun sg -> build_infix opt sym sg
(* let sym_id,_ = sym in
match opt {assoc = None ; prec_spec = None } sg with
| {assoc = None ; prec_spec = None } ->
let p,sg' = Environment.Signature1.new_precedence sym_id sg in
sym,Abstract_syntax.Infix (Abstract_syntax.Left,p),sg'
| {assoc = None ; prec_spec = Some id } ->
let p,sg' = Environment.Signature1.new_precedence ~before:id sym_id sg in
sym,Abstract_syntax.Infix (Abstract_syntax.Left,p),sg'
| {assoc = Some a ; prec_spec = None} ->
let p,sg' = Environment.Signature1.new_precedence sym_id sg in
sym,Abstract_syntax.Infix (a,p),sg'
| {assoc = Some a ; prec_spec = Some id} ->
let p,sg' = Environment.Signature1.new_precedence ~before:id sym_id sg in
sym,Abstract_syntax.Infix (a,p),sg'
*)
}
| INFIX opt = infix_option sym = SYMBOL {fun sg -> build_infix opt sym sg }
| BINDER id = IDENT {fun sg -> id,Abstract_syntax.Binder,sg}
......
......@@ -46,7 +46,7 @@
%public atomic_type_or_term:
| id = IDENT { id }
| LPAREN t = atomic_type_or_term RPAREN { t }
(*| LPAREN t = atomic_type_or_term RPAREN { t } *)
ident_sequence:
| id0 = IDENT ids = IDENT+ { id0,ids }
......
This diff is collapsed.
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