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

Intermediate state...

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