Skip to content

GitLab

M
menhir
Commit 2c1983e7 authored by POTTIER Francois's avatar POTTIER Francois
Browse files
Options

Removed attic/modified-ocaml.mly. 

Moved ChangeLog to attic.
parent 162edc1f
Hide whitespace changes
Inline Side-by-side
Showing with 0 additions and 1426 deletions
attic/modified-ocaml.mly deleted 100644 → 0
View file @ 162edc1f
// TEMPORARY %inline sur tous les nt a une seule production
/***********************************************************************/
/* */
/* Objective Caml */
/* */
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
/* */
/* Copyright 1996 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the Q Public License version 1.0. */
/* */
/***********************************************************************/
/* $Id: menhir.mly,v 1.1 2005/12/18 17:00:47 fpottier Exp $ */
/* The parser definition */
%{
open Parsing
open Location
open Asttypes
open Longident
open Parsetree
let mktyp d =
{ ptyp_desc = d; ptyp_loc = symbol_rloc() }
let mkpat d =
{ ppat_desc = d; ppat_loc = symbol_rloc() }
let mkexp d =
{ pexp_desc = d; pexp_loc = symbol_rloc() }
let mkmty d =
{ pmty_desc = d; pmty_loc = symbol_rloc() }
let mksig d =
{ psig_desc = d; psig_loc = symbol_rloc() }
let mkmod d =
{ pmod_desc = d; pmod_loc = symbol_rloc() }
let mkstr d =
{ pstr_desc = d; pstr_loc = symbol_rloc() }
let mkfield d =
{ pfield_desc = d; pfield_loc = symbol_rloc() }
let mkclass d =
{ pcl_desc = d; pcl_loc = symbol_rloc() }
let mkcty d =
{ pcty_desc = d; pcty_loc = symbol_rloc() }
let reloc_pat x = { x with ppat_loc = symbol_rloc () };;
let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
let mkoperator name pos =
{ pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos }
(*
Ghost expressions and patterns:
expressions and patterns that do not appear explicitely in the
source file they have the loc_ghost flag set to true.
Then the profiler will not try to instrument them and the
-stypes option will not try to display their type.
Every grammar rule that generates an element with a location must
make at most one non-ghost element, the topmost one.
How to tell whether your location must be ghost:
A location corresponds to a range of characters in the source file.
If the location contains a piece of code that is syntactically
valid (according to the documentation), and corresponds to the
AST node, then the location must be real; in all other cases,
it must be ghost.
*)
let ghexp d = { pexp_desc = d; pexp_loc = symbol_gloc () };;
let ghpat d = { ppat_desc = d; ppat_loc = symbol_gloc () };;
let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
let mkassert e =
match e with
| {pexp_desc = Pexp_construct (Lident "false", None, false) } ->
mkexp (Pexp_assertfalse)
| _ -> mkexp (Pexp_assert (e))
;;
let mkinfix arg1 name arg2 =
mkexp(Pexp_apply(mkoperator name 2, ["", arg1; "", arg2]))
let neg_float_string f =
if String.length f > 0 && f.[0] = '-'
then String.sub f 1 (String.length f - 1)
else "-" ^ f
let mkuminus name arg =
match name, arg.pexp_desc with
| "-", Pexp_constant(Const_int n) ->
mkexp(Pexp_constant(Const_int(-n)))
| "-", Pexp_constant(Const_int32 n) ->
mkexp(Pexp_constant(Const_int32(Int32.neg n)))
| "-", Pexp_constant(Const_int64 n) ->
mkexp(Pexp_constant(Const_int64(Int64.neg n)))
| "-", Pexp_constant(Const_nativeint n) ->
mkexp(Pexp_constant(Const_nativeint(Nativeint.neg n)))
| _, Pexp_constant(Const_float f) ->
mkexp(Pexp_constant(Const_float(neg_float_string f)))
| _ ->
mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, ["", arg]))
let rec mktailexp = function
[] ->
ghexp(Pexp_construct(Lident "[]", None, false))
| e1 :: el ->
let exp_el = mktailexp el in
let l = {loc_start = e1.pexp_loc.loc_start;
loc_end = exp_el.pexp_loc.loc_end;
loc_ghost = true}
in
let arg = {pexp_desc = Pexp_tuple [e1; exp_el]; pexp_loc = l} in
{pexp_desc = Pexp_construct(Lident "::", Some arg, false); pexp_loc = l}
let rec mktailpat = function
[] ->
ghpat(Ppat_construct(Lident "[]", None, false))
| p1 :: pl ->
let pat_pl = mktailpat pl in
let l = {loc_start = p1.ppat_loc.loc_start;
loc_end = pat_pl.ppat_loc.loc_end;
loc_ghost = true}
in
let arg = {ppat_desc = Ppat_tuple [p1; pat_pl]; ppat_loc = l} in
{ppat_desc = Ppat_construct(Lident "::", Some arg, false); ppat_loc = l}
let ghstrexp e =
{ pstr_desc = Pstr_eval e; pstr_loc = {e.pexp_loc with loc_ghost = true} }
let array_function str name =
Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))
let rec deep_mkrangepat c1 c2 =
if c1 = c2 then ghpat(Ppat_constant(Const_char c1)) else
ghpat(Ppat_or(ghpat(Ppat_constant(Const_char c1)),
deep_mkrangepat (Char.chr(Char.code c1 + 1)) c2))
let rec mkrangepat c1 c2 =
if c1 > c2 then mkrangepat c2 c1 else
if c1 = c2 then mkpat(Ppat_constant(Const_char c1)) else
reloc_pat (deep_mkrangepat c1 c2)
let syntax_error () =
raise Syntaxerr.Escape_error
let unclosed opening_name opening_num closing_name closing_num =
raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name,
rhs_loc closing_num, closing_name)))
let bigarray_function str name =
Ldot(Ldot(Lident "Bigarray", str), name)
let bigarray_untuplify = function
{ pexp_desc = Pexp_tuple explist} -> explist
| exp -> [exp]
let bigarray_get arr arg =
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "get")),
["", arr; "", c1]))
| [c1;c2] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "get")),
["", arr; "", c1; "", c2]))
| [c1;c2;c3] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "get")),
["", arr; "", c1; "", c2; "", c3]))
| coords ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")),
["", arr; "", ghexp(Pexp_array coords)]))
let bigarray_set arr arg newval =
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "set")),
["", arr; "", c1; "", newval]))
| [c1;c2] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "set")),
["", arr; "", c1; "", c2; "", newval]))
| [c1;c2;c3] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "set")),
["", arr; "", c1; "", c2; "", c3; "", newval]))
| coords ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")),
["", arr;
"", ghexp(Pexp_array coords);
"", newval]))
%}
/* Tokens */
%token AMPERAMPER
%token AMPERSAND
%token AND
%token AS
%token ASSERT
%token BACKQUOTE
%token BAR
%token BARBAR
%token BARRBRACKET
%token BEGIN
%token <char> CHAR
%token CLASS
%token COLON
%token COLONCOLON
%token COLONEQUAL
%token COLONGREATER
%token COMMA
%token CONSTRAINT
%token DO
%token DONE
%token DOT
%token DOTDOT
%token DOWNTO
%token ELSE
%token END
%token EOF
%token EQUAL
%token EXCEPTION
%token EXTERNAL
%token FALSE
%token <string> FLOAT
%token FOR
%token FUN
%token FUNCTION
%token FUNCTOR
%token GREATER
%token GREATERRBRACE
//%token GREATERRBRACKET // TEMPORARY
%token IF
%token IN
%token INCLUDE
%token <string> INFIXOP0
%token <string> INFIXOP1
%token <string> INFIXOP2
%token <string> INFIXOP3
%token <string> INFIXOP4
%token INHERIT
%token INITIALIZER
%token <int> INT
%token <int32> INT32
%token <int64> INT64
%token <string> LABEL
%token LAZY
%token LBRACE
%token LBRACELESS
%token LBRACKET
%token LBRACKETBAR
%token LBRACKETLESS
%token LBRACKETGREATER
%token LESS
%token LESSMINUS
%token LET
%token <string> LIDENT
%token LPAREN
%token MATCH
%token METHOD
%token MINUS
%token MINUSDOT
%token MINUSGREATER
%token MODULE
%token MUTABLE
%token <nativeint> NATIVEINT
%token NEW
%token OBJECT
%token OF
%token OPEN
%token <string> OPTLABEL
%token OR
/* %token PARSER */
%token PLUS
%token <string> PREFIXOP
%token PRIVATE
%token QUESTION
//%token QUESTIONQUESTION // TEMPORARY
%token QUOTE
%token RBRACE
%token RBRACKET
%token REC
%token RPAREN
%token SEMI
%token SEMISEMI
%token SHARP
%token SIG
%token STAR
%token <string> STRING
%token STRUCT
%token THEN
%token TILDE
%token TO
%token TRUE
%token TRY
%token TYPE
%token <string> UIDENT
%token UNDERSCORE
%token VAL
%token VIRTUAL
%token WHEN
%token WHILE
%token WITH
/* Precedences and associativities.
Tokens and rules have precedences. A reduce/reduce conflict is resolved
in favor of the first rule (in source file order). A shift/reduce conflict
is resolved by comparing the precedence and associativity of the token to
be shifted with those of the rule to be reduced.
By default, a rule has the precedence of its rightmost terminal (if any).
When there is a shift/reduce conflict between a rule and a token that
have the same precedence, it is resolved using the associativity:
if the token is left-associative, the parser will reduce; if
right-associative, the parser will shift; if non-associative,
the parser will declare a syntax error.
We will only use associativities with operators of the kind x * x -> x
for example, in the rules of the form expr: expr BINOP expr
in all other cases, we define two precedences if needed to resolve
conflicts.
The precedences must be listed from low to high.
*/
%nonassoc below_SEMI
%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */
%nonassoc LET /* above SEMI ( ...; let ... in ...) */
%nonassoc below_WITH
%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */
%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */
%nonassoc THEN /* below ELSE (if ... then ...) */
%nonassoc ELSE /* (if ... then ... else ...) */
%nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */
%right COLONEQUAL /* expr (e := e := e) */
%nonassoc AS
%left BAR /* pattern (p|p|p) */
%nonassoc below_COMMA
%left COMMA /* expr/open_tuple(expr) (e,e,e) */
%right MINUSGREATER /* core_type2 (t -> t -> t) */
%right OR BARBAR /* expr (e || e || e) */
%right AMPERSAND AMPERAMPER /* expr (e && e && e) */
%nonassoc below_EQUAL
%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */
%right INFIXOP1 /* expr (e OP e OP e) */
%right COLONCOLON /* expr (e :: e :: e) */
%left INFIXOP2 PLUS MINUS MINUSDOT /* expr (e OP e OP e) */
%left INFIXOP3 STAR /* expr (e OP e OP e) */
%right INFIXOP4 /* expr (e OP e OP e) */
%nonassoc prec_unary_minus /* unary - */
%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */
%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */
%nonassoc below_SHARP
%nonassoc SHARP /* simple_expr/toplevel_directive */
%nonassoc below_DOT
%nonassoc DOT
/* Finally, the first tokens of simple_expr are above everything else. */
%nonassoc BACKQUOTE BEGIN CHAR FALSE FLOAT INT INT32 INT64
LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN
NEW NATIVEINT PREFIXOP STRING TRUE UIDENT
/* Entry points */
%start implementation /* for implementation files */
%type <Parsetree.structure> implementation
%start interface /* for interface files */
%type <Parsetree.signature> interface
%start toplevel_phrase /* for interactive use */
%type <Parsetree.toplevel_phrase> toplevel_phrase
%start use_file /* for the #use directive */
%type <Parsetree.toplevel_phrase list> use_file
%%
/* Entry points */
implementation:
structure EOF { $1 }
;
interface:
items = signature EOF { items }
;
toplevel_phrase:
items = structure_item+ SEMISEMI { Ptop_def items }
| seq_expr SEMISEMI { Ptop_def[ghstrexp $1] }
| toplevel_directive SEMISEMI { $1 }
| EOF { raise End_of_file }
;
use_file:
use_file_tail { $1 }
| seq_expr use_file_tail { Ptop_def[ghstrexp $1] :: $2 }
;
use_file_tail:
EOF { [] }
| SEMISEMI EOF { [] }
| SEMISEMI seq_expr use_file_tail { Ptop_def[ghstrexp $2] :: $3 }
| SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
| SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
| structure_item use_file_tail { Ptop_def[$1] :: $2 }
| toplevel_directive use_file_tail { $1 :: $2 }
;
/* Module expressions */
%inline raw_module_expr:
mod_longident
{ Pmod_ident $1 }
| STRUCT structure END
{ Pmod_structure($2) }
| STRUCT structure error
{ unclosed "struct" 1 "end" 3 }
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
{ Pmod_functor($3, $5, $8) }
| module_expr LPAREN module_expr RPAREN
{ Pmod_apply($1, $3) }
| module_expr LPAREN module_expr error
{ unclosed "(" 2 ")" 4 }
| LPAREN module_expr COLON module_type RPAREN
{ Pmod_constraint($2, $4) }
| LPAREN module_expr COLON module_type error
{ unclosed "(" 1 ")" 5 }
module_expr:
m = raw_module_expr
{ mkmod m }
| LPAREN m = module_expr RPAREN
{ m }
| LPAREN module_expr error
{ unclosed "(" 1 ")" 3 }
structure:
structure_tail { $1 }
| seq_expr structure_tail { ghstrexp $1 :: $2 }
;
structure_tail:
/* empty */ { [] }
| SEMISEMI { [] }
| SEMISEMI seq_expr structure_tail { ghstrexp $2 :: $3 }
| SEMISEMI structure_item structure_tail { $2 :: $3 }
| structure_item structure_tail { $1 :: $2 }
;
structure_item:
LET flag = rec_flag bs = let_bindings
{ match bs with
[{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
| _ -> mkstr(Pstr_value(flag, bs)) }
| EXTERNAL x = val_ident_colon t = core_type EQUAL ps = STRING+
{ mkstr(Pstr_primitive(x, {pval_type = t; pval_prim = ps})) }
| TYPE ds = separated_nonempty_list(AND, type_declaration)
{ mkstr(Pstr_type ds) }
| EXCEPTION id = UIDENT args = constructor_arguments
{ mkstr(Pstr_exception(id, args)) }
| EXCEPTION UIDENT EQUAL constr_longident
{ mkstr(Pstr_exn_rebind($2, $4)) }
| MODULE UIDENT module_binding
{ mkstr(Pstr_module($2, $3)) }
| MODULE REC bs = separated_nonempty_list(AND, module_rec_binding)
{ mkstr(Pstr_recmodule bs) }
| MODULE TYPE ident EQUAL module_type
{ mkstr(Pstr_modtype($3, $5)) }
| OPEN mod_longident
{ mkstr(Pstr_open $2) }
| CLASS ds = separated_nonempty_list(AND, class_declaration)
{ mkstr(Pstr_class ds) }
| CLASS TYPE ds = separated_nonempty_list(AND, class_type_declaration)
{ mkstr(Pstr_class_type ds) }
| INCLUDE module_expr
{ mkstr(Pstr_include $2) }
;
module_binding:
EQUAL module_expr
{ $2 }
| COLON module_type EQUAL module_expr
{ mkmod(Pmod_constraint($4, $2)) }
| LPAREN UIDENT COLON module_type RPAREN module_binding
{ mkmod(Pmod_functor($2, $4, $6)) }
;
module_rec_binding:
UIDENT COLON module_type EQUAL module_expr { ($1, $3, $5) }
;
/* Module types */
module_type:
mty_longident
{ mkmty(Pmty_ident $1) }
| SIG items = signature END
{ mkmty(Pmty_signature items) }
| SIG signature error
{ unclosed "sig" 1 "end" 3 }
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
%prec below_WITH
{ mkmty(Pmty_functor($3, $5, $8)) }
| mty = module_type WITH cs = separated_nonempty_list(AND, with_constraint)
{ mkmty(Pmty_with(mty, cs)) }
| LPAREN module_type RPAREN
{ $2 }
| LPAREN module_type error
{ unclosed "(" 1 ")" 3 }
;
%inline signature:
items = terminated(signature_item, SEMISEMI?)*
{ items }
signature_item:
VAL val_ident_colon core_type
{ mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) }
| EXTERNAL x = val_ident_colon t = core_type EQUAL ps = STRING+
{ mksig(Psig_value(x, {pval_type = t; pval_prim = ps})) }
| TYPE ds = separated_nonempty_list(AND, type_declaration)
{ mksig(Psig_type ds) }
| EXCEPTION id = UIDENT args = constructor_arguments
{ mksig(Psig_exception(id, args)) }
| MODULE UIDENT module_declaration
{ mksig(Psig_module($2, $3)) }
| MODULE REC ds = separated_nonempty_list(AND, module_rec_declaration)
{ mksig(Psig_recmodule ds) }
| MODULE TYPE ident
{ mksig(Psig_modtype($3, Pmodtype_abstract)) }
| MODULE TYPE ident EQUAL module_type
{ mksig(Psig_modtype($3, Pmodtype_manifest $5)) }
| OPEN mod_longident
{ mksig(Psig_open $2) }
| INCLUDE module_type
{ mksig(Psig_include $2) }
| CLASS ds = separated_nonempty_list(AND, class_description)
{ mksig(Psig_class ds) }
| CLASS TYPE ds = separated_nonempty_list(AND, class_type_declaration)
{ mksig(Psig_class_type ds) }
;
module_declaration:
COLON module_type
{ $2 }
| LPAREN UIDENT COLON module_type RPAREN module_declaration
{ mkmty(Pmty_functor($2, $4, $6)) }
;
module_rec_declaration:
UIDENT COLON module_type { ($1, $3) }
;
/* Class expressions */
class_declaration:
virtual_flag class_type_parameters LIDENT class_fun_binding
{ let params, variance = List.split (fst $2) in
{pci_virt = $1; pci_params = params, snd $2;
pci_name = $3; pci_expr = $4; pci_variance = variance;
pci_loc = symbol_rloc ()} }
;
class_fun_binding:
EQUAL class_expr
{ $2 }
| COLON class_type EQUAL class_expr
{ mkclass(Pcl_constraint($4, $2)) }
| labeled_simple_pattern class_fun_binding
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
;
class_type_parameters:
/*empty*/
{ [], symbol_gloc () }
| LBRACKET ps = separated_nonempty_list(COMMA, type_parameter) RBRACKET
{ ps, symbol_rloc () }
;
class_fun_def:
labeled_simple_pattern MINUSGREATER class_expr
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $3)) }
| labeled_simple_pattern class_fun_def
{ let (l,o,p) = $1 in mkclass(Pcl_fun(l, o, p, $2)) }
;
class_expr:
class_simple_expr
{ $1 }
| FUN class_fun_def
{ $2 }
| e = class_simple_expr es = labeled_simple_expr+
{ mkclass(Pcl_apply(e, es)) }
| LET flag = rec_flag bs = let_bindings IN e = class_expr
{ mkclass(Pcl_let (flag, bs, e)) }
;
class_simple_expr:
LBRACKET ts = core_type_comma_list RBRACKET id = class_longident
{ mkclass(Pcl_constr(id, ts)) }
| class_longident
{ mkclass(Pcl_constr($1, [])) }
| OBJECT class_structure END
{ mkclass(Pcl_structure($2)) }
| OBJECT class_structure error
{ unclosed "object" 1 "end" 3 }
| LPAREN class_expr COLON class_type RPAREN
{ mkclass(Pcl_constraint($2, $4)) }
| LPAREN class_expr COLON class_type error
{ unclosed "(" 1 ")" 5 }
| LPAREN class_expr RPAREN
{ $2 }
| LPAREN class_expr error
{ unclosed "(" 1 ")" 3 }
;
class_structure:
class_self_pattern class_fields
{ $1, List.rev $2 }
;
class_self_pattern:
LPAREN pattern RPAREN
{ reloc_pat $2 }
| LPAREN pattern COLON core_type RPAREN
{ mkpat(Ppat_constraint($2, $4)) }
| /* empty */
{ ghpat(Ppat_any) }
;
class_fields:
/* empty */
{ [] }
| class_fields INHERIT class_expr preceded(AS, LIDENT)?
{ Pcf_inher ($3, $4) :: $1 }
| class_fields VAL value
{ Pcf_val $3 :: $1 }
| class_fields virtual_method
{ Pcf_virt $2 :: $1 }
| class_fields concrete_method
{ Pcf_meth $2 :: $1 }
| class_fields