diff options
Diffstat (limited to 'ghc/compiler/yaccParser/hsparser.y')
| -rw-r--r-- | ghc/compiler/yaccParser/hsparser.y | 2131 |
1 files changed, 2131 insertions, 0 deletions
diff --git a/ghc/compiler/yaccParser/hsparser.y b/ghc/compiler/yaccParser/hsparser.y new file mode 100644 index 0000000000..fb2d934366 --- /dev/null +++ b/ghc/compiler/yaccParser/hsparser.y @@ -0,0 +1,2131 @@ +/************************************************************************** +* File: hsparser.y * +* * +* Author: Maria M. Gutierrez * +* Modified by: Kevin Hammond * +* Last date revised: December 13 1991. KH. * +* Modification: Haskell 1.1 Syntax. * +* * +* * +* Description: This file contains the LALR(1) grammar for Haskell. * +* * +* Entry Point: module * +* * +* Problems: None known. * +* * +* * +* LALR(1) Syntax for Haskell 1.2 * +* * +**************************************************************************/ + + +%{ +#ifdef HSP_DEBUG +# define YYDEBUG 1 +#endif + +#include <stdio.h> +#include <ctype.h> +#include <string.h> +#include "hspincl.h" +#include "constants.h" +#include "utils.h" + +/********************************************************************** +* * +* * +* Imported Variables and Functions * +* * +* * +**********************************************************************/ + +BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */ + +extern BOOLEAN nonstandardFlag; +extern BOOLEAN etags; + +extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *)); + +extern char *input_filename; +static char *the_module_name; +static char iface_name[MODNAME_SIZE]; +static char interface_filename[FILENAME_SIZE]; + +static list module_exports; /* Exported entities */ +static list prelude_core_import, prelude_imports; + /* Entities imported from the Prelude */ + +extern list all; /* All valid deriving classes */ + +extern tree niltree; +extern list Lnil; + +extern tree root; + +/* For FN, PREVPATT and SAMEFN macros */ +extern tree fns[]; +extern short samefn[]; +extern tree prevpatt[]; +extern short icontexts; + +/* Line Numbers */ +extern int hsplineno, hspcolno; +extern int startlineno; + + +/********************************************************************** +* * +* * +* Fixity and Precedence Declarations * +* * +* * +**********************************************************************/ + +list fixlist; +static int Fixity = 0, Precedence = 0; +struct infix; + +char *ineg PROTO((char *)); + +static BOOLEAN hidden = FALSE; /* Set when HIDING used */ + +extern BOOLEAN inpat; /* True when parsing a pattern */ +extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */ +extern BOOLEAN haskell1_3Flag; /* True if we are attempting (proto)Haskell 1.3 */ + +extern int thisIfacePragmaVersion; + +%} + +%union { + tree utree; + list ulist; + ttype uttype; + atype uatype; + binding ubinding; + pbinding upbinding; + finfot ufinfo; + entidt uentid; + id uid; + literal uliteral; + int uint; + float ufloat; + char *ustring; + hstring uhstring; + hpragma uhpragma; + coresyn ucoresyn; +} + + +/********************************************************************** +* * +* * +* These are lexemes. * +* * +* * +**********************************************************************/ + + +%token VARID CONID + VARSYM CONSYM MINUS + +%token INTEGER FLOAT CHAR STRING + CHARPRIM STRINGPRIM INTPRIM FLOATPRIM + DOUBLEPRIM CLITLIT + + + +/********************************************************************** +* * +* * +* Special Symbols * +* * +* * +**********************************************************************/ + +%token OCURLY CCURLY VCCURLY SEMI +%token OBRACK CBRACK OPAREN CPAREN +%token COMMA BQUOTE + + +/********************************************************************** +* * +* * +* Reserved Operators * +* * +* * +**********************************************************************/ + +%token RARROW +%token VBAR EQUAL DARROW DOTDOT +%token DCOLON LARROW +%token WILDCARD AT LAZY LAMBDA + + +/********************************************************************** +* * +* * +* Reserved Identifiers * +* * +* * +**********************************************************************/ + +%token LET IN +%token WHERE CASE OF +%token TYPE DATA CLASS INSTANCE DEFAULT +%token INFIX INFIXL INFIXR +%token MODULE IMPORT INTERFACE HIDING +%token CCALL CCALL_GC CASM CASM_GC SCC + +%token IF THEN ELSE +%token RENAMING DERIVING TO + +/********************************************************************** +* * +* * +* Special Symbols for the Lexer * +* * +* * +**********************************************************************/ + +%token LEOF +%token GHC_PRAGMA END_PRAGMA NO_PRAGMA NOINFO_PRAGMA +%token ABSTRACT_PRAGMA SPECIALISE_PRAGMA MODNAME_PRAGMA +%token ARITY_PRAGMA UPDATE_PRAGMA STRICTNESS_PRAGMA KIND_PRAGMA +%token UNFOLDING_PRAGMA MAGIC_UNFOLDING_PRAGMA DEFOREST_PRAGMA +%token SPECIALISE_UPRAGMA INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA +%token ABSTRACT_UPRAGMA DEFOREST_UPRAGMA END_UPRAGMA +%token TYLAMBDA COCON COPRIM COAPP COTYAPP FORALL TYVAR_TEMPLATE_ID +%token CO_ALG_ALTS CO_PRIM_ALTS CO_NO_DEFAULT CO_LETREC +%token CO_SDSEL_ID CO_METH_ID CO_DEFM_ID CO_DFUN_ID CO_CONSTM_ID +%token CO_SPEC_ID CO_WRKR_ID CO_ORIG_NM +%token UNFOLD_ALWAYS UNFOLD_IF_ARGS +%token NOREP_INTEGER NOREP_RATIONAL NOREP_STRING +%token CO_PRELUDE_DICTS_CC CO_ALL_DICTS_CC CO_USER_CC CO_AUTO_CC CO_DICT_CC +%token CO_CAF_CC CO_DUPD_CC + +/********************************************************************** +* * +* * +* Precedences of the various tokens * +* * +* * +**********************************************************************/ + + +%left CASE LET IN LAMBDA + IF ELSE CCALL CCALL_GC + CASM CASM_GC SCC AT + +%left VARSYM CONSYM PLUS MINUS BQUOTE + +%left DCOLON + +%left SEMI COMMA + +%left OCURLY OBRACK OPAREN + +%left EQUAL + +%right DARROW +%right RARROW + + + +/********************************************************************** +* * +* * +* Type Declarations * +* * +* * +**********************************************************************/ + + +%type <ulist> alt alts altrest quals vars varsrest cons + tyvars constrs dtypes types atypes + types_and_maybe_ids + list_exps pats context context_list atype_list + maybeexports export_list + impspec maybeimpspec import_list + impdecls maybeimpdecls impdecl + renaming renamings renaming_list + tyclses tycls_list + gdrhs gdpat valrhs valrhs1 + lampats + upto + cexp + idata_pragma_specs idata_pragma_specslist + gen_pragma_list type_pragma_pairs + type_pragma_pairs_maybe name_pragma_pairs + maybe_name_pragma_pairs type_instpragma_pairs + type_maybes + restof_iinst_spec + howto_inline_maybe + core_binders core_tyvars core_tv_templates + core_types core_type_list + core_atoms core_atom_list + core_alg_alts core_prim_alts corec_binds + core_type_maybes + +%type <uliteral> lit_constant + +%type <utree> exp dexp fexp kexp oexp aexp + tuple list sequence comprehension qual qualrest + gd + apat bpat pat apatc conpat dpat fpat opat aapat + dpatk fpatk opatk aapatk + texps + +%type <uid> MINUS VARID CONID VARSYM CONSYM TYVAR_TEMPLATE_ID + var vark con conk varop varop1 conop op op1 + varsym minus plus + tycls tycon modid ccallid modname_pragma + +%type <ubinding> topdecl topdecls + typed datad classd instd defaultd + decl decls valdef instdef instdefs + iimport iimports maybeiimports + ityped idatad iclassd iinstd ivarsd + itopdecl itopdecls + maybe_where + interface readinterface ibody + cbody rinst + impdecl_rest + type_and_maybe_id + +%type <uttype> simple simple_long type atype btype ttype ntatype inst class + tyvar core_type type_maybe core_type_maybe + +%type <uatype> constr + +%type <ustring> FLOAT INTEGER INTPRIM + FLOATPRIM DOUBLEPRIM CLITLIT +%type <uhstring> STRING STRINGPRIM CHAR CHARPRIM +%type <uentid> export import + +%type <uhpragma> idata_pragma idata_pragma_spectypes + itype_pragma iclas_pragma iclasop_pragma + iinst_pragma gen_pragma ival_pragma arity_pragma + update_pragma strictness_pragma worker_info + deforest_pragma + unfolding_pragma unfolding_guidance type_pragma_pair + type_instpragma_pair name_pragma_pair + +%type <ucoresyn> core_expr core_case_alts core_id core_binder core_atom + core_alg_alt core_prim_alt core_default corec_bind + co_primop co_scc co_caf co_dupd + +/********************************************************************** +* * +* * +* Start Symbol for the Parser * +* * +* * +**********************************************************************/ + +%start pmodule + + +%% + +pmodule : readpreludecore readprelude module + ; + +module : modulekey modid maybeexports + { the_module_name = $2; module_exports = $3; } + WHERE body + | { the_module_name = install_literal("Main"); module_exports = Lnil; } + body + ; + + /* all the startlinenos in mkhmodules are bogus (WDP) */ +body : ocurly maybeimpdecls maybefixes topdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4,startlineno); + } + | vocurly maybeimpdecls maybefixes topdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4,startlineno); + } + + | vocurly impdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + | ocurly impdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + +/* Adds 1 S/R, 2 R/R conflicts, alternatives add 3 R/R conflicts */ + | vocurly maybeimpdecls vccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + | ocurly maybeimpdecls ccurly + { + root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno); + } + ; + + +maybeexports : /* empty */ { $$ = Lnil; } + | OPAREN export_list CPAREN { $$ = $2; } + ; + +export_list: + export { $$ = lsing($1); } + | export_list COMMA export { $$ = lapp($1, $3); } + ; + +export : + var { $$ = mkentid($1); } + | tycon { $$ = mkenttype($1); } + | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | tycon OPAREN cons CPAREN + { $$ = mkenttypecons($1,$3); + /* should be a datatype with cons representing all constructors */ + } + | tycon OPAREN vars CPAREN + { $$ = mkentclass($1,$3); + /* should be a class with vars representing all Class operations */ + } + | tycon OPAREN CPAREN + { $$ = mkentclass($1,Lnil); + /* "tycon" should be a class with no operations */ + } + | tycon DOTDOT + { $$ = mkentmod($1); + /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */ + } + ; + + +impspec : OPAREN import_list CPAREN { $$ = $2; hidden = FALSE; } + | HIDING OPAREN import_list CPAREN { $$ = $3; hidden = TRUE; } + | OPAREN CPAREN { $$ = Lnil; hidden = FALSE; } + ; + +maybeimpspec : /* empty */ { $$ = Lnil; } + | impspec { $$ = $1; } + ; + +import_list: + import { $$ = lsing($1); } + | import_list COMMA import { $$ = lapp($1, $3); } + ; + +import : + var { $$ = mkentid($1); } + | tycon { $$ = mkenttype($1); } + | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | tycon OPAREN cons CPAREN + { $$ = mkenttypecons($1,$3); + /* should be a datatype with cons representing all constructors */ + } + | tycon OPAREN vars CPAREN + { $$ = mkentclass($1,$3); + /* should be a class with vars representing all Class operations */ + } + | tycon OPAREN CPAREN + { $$ = mkentclass($1,Lnil); + /* "tycon" should be a class with no operations */ + } + ; + +/* -- interface pragma stuff: ------------------------------------- */ + +idata_pragma: + GHC_PRAGMA constrs idata_pragma_specs END_PRAGMA + { $$ = mkidata_pragma($2, $3); } + | GHC_PRAGMA idata_pragma_specs END_PRAGMA + { $$ = mkidata_pragma(Lnil, $2); } + | /* empty */ { $$ = mkno_pragma(); } + ; + +idata_pragma_specs : + SPECIALISE_PRAGMA idata_pragma_specslist + { $$ = $2; } + | /* empty */ { $$ = Lnil; } + ; + +idata_pragma_specslist: + idata_pragma_spectypes { $$ = lsing($1); } + | idata_pragma_specslist COMMA idata_pragma_spectypes + { $$ = lapp($1, $3); } + ; + +idata_pragma_spectypes: + OBRACK type_maybes CBRACK { $$ = mkidata_pragma_4s($2); } + ; + +itype_pragma: + GHC_PRAGMA ABSTRACT_PRAGMA END_PRAGMA { $$ = mkitype_pragma(); } + | /* empty */ { $$ = mkno_pragma(); } + ; + +iclas_pragma: + GHC_PRAGMA gen_pragma_list END_PRAGMA { $$ = mkiclas_pragma($2); } + | /* empty */ { $$ = mkno_pragma(); } + ; + +iclasop_pragma: + GHC_PRAGMA gen_pragma gen_pragma END_PRAGMA + { $$ = mkiclasop_pragma($2, $3); } + | /* empty */ + { $$ = mkno_pragma(); } + ; + +iinst_pragma: + GHC_PRAGMA modname_pragma gen_pragma END_PRAGMA + { $$ = mkiinst_simpl_pragma($2, $3); } + + | GHC_PRAGMA modname_pragma gen_pragma name_pragma_pairs END_PRAGMA + { $$ = mkiinst_const_pragma($2, $3, $4); } + + | GHC_PRAGMA modname_pragma gen_pragma restof_iinst_spec END_PRAGMA + { $$ = mkiinst_spec_pragma($2, $3, $4); } + + | /* empty */ + { $$ = mkno_pragma(); } + ; + +modname_pragma: + MODNAME_PRAGMA modid + { $$ = $2; } + | /* empty */ + { $$ = install_literal(""); } + ; + +restof_iinst_spec: SPECIALISE_PRAGMA type_instpragma_pairs { $$ = $2; } + ; + +ival_pragma: + GHC_PRAGMA gen_pragma END_PRAGMA + { $$ = $2; } + | /* empty */ + { $$ = mkno_pragma(); } + ; + +gen_pragma: + NOINFO_PRAGMA + { $$ = mkno_pragma(); } + | arity_pragma update_pragma deforest_pragma strictness_pragma unfolding_pragma type_pragma_pairs_maybe + { $$ = mkigen_pragma($1, $2, $3, $4, $5, $6); } + ; + +arity_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | ARITY_PRAGMA INTEGER { $$ = mkiarity_pragma($2); } + ; + +update_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | UPDATE_PRAGMA INTEGER { $$ = mkiupdate_pragma($2); } + ; + +deforest_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | DEFOREST_PRAGMA { $$ = mkideforest_pragma(); } + ; + +strictness_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | STRICTNESS_PRAGMA COCON { $$ = mkistrictness_pragma(installHstring(1, "B"), + /* _!_ = COCON = bottom */ mkno_pragma()); + } + | STRICTNESS_PRAGMA STRING worker_info + { $$ = mkistrictness_pragma($2, $3); } + ; + +worker_info: + OCURLY gen_pragma CCURLY { $$ = $2; } + | /* empty */ { $$ = mkno_pragma(); } + +unfolding_pragma: + NO_PRAGMA { $$ = mkno_pragma(); } + | MAGIC_UNFOLDING_PRAGMA vark + { $$ = mkimagic_unfolding_pragma($2); } + | UNFOLDING_PRAGMA unfolding_guidance core_expr + { $$ = mkiunfolding_pragma($2, $3); } + ; + +unfolding_guidance: + UNFOLD_ALWAYS + { $$ = mkiunfold_always(); } + | UNFOLD_IF_ARGS INTEGER INTEGER CONID INTEGER + { $$ = mkiunfold_if_args($2, $3, $4, $5); } + ; + +gen_pragma_list: + gen_pragma { $$ = lsing($1); } + | gen_pragma_list COMMA gen_pragma { $$ = lapp($1, $3); } + ; + +type_pragma_pairs_maybe: + NO_PRAGMA { $$ = Lnil; } + | SPECIALISE_PRAGMA type_pragma_pairs { $$ = $2; } + ; + +type_pragma_pairs: + type_pragma_pair { $$ = lsing($1); } + | type_pragma_pairs COMMA type_pragma_pair { $$ = lapp($1, $3); } + ; + +type_pragma_pair: + OBRACK type_maybes CBRACK INTEGER worker_info + { $$ = mkitype_pragma_pr($2, $4, $5); } + ; + +type_instpragma_pairs: + type_instpragma_pair { $$ = lsing($1); } + | type_instpragma_pairs COMMA type_instpragma_pair { $$ = lapp($1,$3); } + ; + +type_instpragma_pair: + OBRACK type_maybes CBRACK INTEGER worker_info maybe_name_pragma_pairs + { $$ = mkiinst_pragma_3s($2, $4, $5, $6); } + ; + +type_maybes: + type_maybe { $$ = lsing($1); } + | type_maybes COMMA type_maybe { $$ = lapp($1, $3); } + ; + +type_maybe: + NO_PRAGMA { $$ = mkty_maybe_nothing(); } + | type { $$ = mkty_maybe_just($1); } + ; + +maybe_name_pragma_pairs: + /* empty */ { $$ = Lnil; } + | name_pragma_pairs { $$ = $1; } + ; + +name_pragma_pairs: + name_pragma_pair { $$ = lsing($1); } + | name_pragma_pairs COMMA name_pragma_pair { $$ = lapp($1, $3); } + ; + +name_pragma_pair: + var EQUAL gen_pragma + { $$ = mkiname_pragma_pr($1, $3); } + ; + +/* -- end of interface pragma stuff ------------------------------- */ + +/* -- core syntax stuff ------------------------------------------- */ + +core_expr: + LAMBDA core_binders RARROW core_expr + { $$ = mkcolam($2, $4); } + | TYLAMBDA core_tyvars RARROW core_expr + { $$ = mkcotylam($2, $4); } + | COCON con core_types core_atoms + { $$ = mkcocon(mkco_id($2), $3, $4); } + | COCON CO_ORIG_NM modid con core_types core_atoms + { $$ = mkcocon(mkco_orig_id($3,$4), $5, $6); } + | COPRIM co_primop core_types core_atoms + { $$ = mkcoprim($2, $3, $4); } + | COAPP core_expr core_atoms + { $$ = mkcoapp($2, $3); } + | COTYAPP core_expr OCURLY core_type CCURLY + { $$ = mkcotyapp($2, $4); } + | CASE core_expr OF OCURLY core_case_alts CCURLY + { $$ = mkcocase($2, $5); } + | LET OCURLY core_binder EQUAL core_expr CCURLY IN core_expr + { $$ = mkcolet(mkcononrec($3, $5), $8); } + | CO_LETREC OCURLY corec_binds CCURLY IN core_expr + { $$ = mkcolet(mkcorec($3), $6); } + | SCC OCURLY co_scc CCURLY core_expr + { $$ = mkcoscc($3, $5); } + | lit_constant { $$ = mkcoliteral($1); } + | core_id { $$ = mkcovar($1); } + ; + +core_case_alts : + CO_ALG_ALTS core_alg_alts core_default + { $$ = mkcoalg_alts($2, $3); } + | CO_PRIM_ALTS core_prim_alts core_default + { $$ = mkcoprim_alts($2, $3); } + ; + +core_alg_alts : + /* empty */ { $$ = Lnil; } + | core_alg_alts core_alg_alt { $$ = lapp($1, $2); } + ; + +core_alg_alt: + core_id core_binders RARROW core_expr SEMI { $$ = mkcoalg_alt($1, $2, $4); } + /* core_id is really too generous */ + ; + +core_prim_alts : + /* empty */ { $$ = Lnil; } + | core_prim_alts core_prim_alt { $$ = lapp($1, $2); } + ; + +core_prim_alt: + lit_constant RARROW core_expr SEMI { $$ = mkcoprim_alt($1, $3); } + ; + +core_default: + CO_NO_DEFAULT { $$ = mkconodeflt(); } + | core_binder RARROW core_expr { $$ = mkcobinddeflt($1, $3); } + ; + +corec_binds: + corec_bind { $$ = lsing($1); } + | corec_binds SEMI corec_bind { $$ = lapp($1, $3); } + ; + +corec_bind: + core_binder EQUAL core_expr { $$ = mkcorec_pair($1, $3); } + ; + +co_scc : + CO_PRELUDE_DICTS_CC co_dupd { $$ = mkco_preludedictscc($2); } + | CO_ALL_DICTS_CC STRING STRING co_dupd { $$ = mkco_alldictscc($2,$3,$4); } + | CO_USER_CC STRING STRING STRING co_dupd co_caf + { $$ = mkco_usercc($2,$3,$4,$5,$6); } + | CO_AUTO_CC core_id STRING STRING co_dupd co_caf + { $$ = mkco_autocc($2,$3,$4,$5,$6); } + | CO_DICT_CC core_id STRING STRING co_dupd co_caf + { $$ = mkco_dictcc($2,$3,$4,$5,$6); } + +co_caf : NO_PRAGMA { $$ = mkco_scc_noncaf(); } + | CO_CAF_CC { $$ = mkco_scc_caf(); } + +co_dupd : NO_PRAGMA { $$ = mkco_scc_nondupd(); } + | CO_DUPD_CC { $$ = mkco_scc_dupd(); } + +core_id: /* more to come?? */ + CO_SDSEL_ID tycon tycon { $$ = mkco_sdselid($2, $3); } + | CO_METH_ID tycon var { $$ = mkco_classopid($2, $3); } + | CO_DEFM_ID tycon var { $$ = mkco_defmid($2, $3); } + | CO_DFUN_ID tycon OPAREN core_type CPAREN + { $$ = mkco_dfunid($2, $4); } + | CO_CONSTM_ID tycon var OPAREN core_type CPAREN + { $$ = mkco_constmid($2, $3, $5); } + | CO_SPEC_ID core_id OBRACK core_type_maybes CBRACK + { $$ = mkco_specid($2, $4); } + | CO_WRKR_ID core_id { $$ = mkco_wrkrid($2); } + | CO_ORIG_NM modid var { $$ = mkco_orig_id($2, $3); } + | CO_ORIG_NM modid con { $$ = mkco_orig_id($2, $3); } + | var { $$ = mkco_id($1); } + | con { $$ = mkco_id($1); } + ; + +co_primop : + OPAREN CCALL ccallid OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_ccall($3,0,$5,$6); } + | OPAREN CCALL_GC ccallid OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_ccall($3,1,$5,$6); } + | OPAREN CASM lit_constant OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_casm($3,0,$5,$6); } + | OPAREN CASM_GC lit_constant OCURLY core_types core_type CCURLY CPAREN + { $$ = mkco_casm($3,1,$5,$6); } + | VARID { $$ = mkco_primop($1); } + ; + +core_binders : + /* empty */ { $$ = Lnil; } + | core_binders core_binder { $$ = lapp($1, $2); } + ; + +core_binder : + OPAREN VARID DCOLON core_type CPAREN { $$ = mkcobinder($2, $4); } + +core_atoms : + OBRACK CBRACK { $$ = Lnil; } + | OBRACK core_atom_list CBRACK { $$ = $2; } + ; + +core_atom_list : + core_atom { $$ = lsing($1); } + | core_atom_list COMMA core_atom { $$ = lapp($1, $3); } + ; + +core_atom : + lit_constant { $$ = mkcolit($1); } + | core_id { $$ = mkcolocal($1); } + ; + +core_tyvars : + VARID { $$ = lsing($1); } + | core_tyvars VARID { $$ = lapp($1, $2); } + ; + +core_tv_templates : + TYVAR_TEMPLATE_ID { $$ = lsing($1); } + | core_tv_templates COMMA TYVAR_TEMPLATE_ID { $$ = lapp($1, $3); } + ; + +core_types : + OBRACK CBRACK { $$ = Lnil; } + | OBRACK core_type_list CBRACK { $$ = $2; } + ; + +core_type_list : + core_type { $$ = lsing($1); } + | core_type_list COMMA core_type { $$ = lapp($1, $3); } + ; + +core_type : + type { $$ = $1; } + ; + +/* +core_type : + FORALL core_tv_templates DARROW core_type + { $$ = mkuniforall($2, $4); } + | OCURLY OCURLY CONID core_type CCURLY CCURLY RARROW core_type + { $$ = mktfun(mkunidict($3, $4), $8); } + | OCURLY OCURLY CONID core_type CCURLY CCURLY + { $$ = mkunidict($3, $4); } + | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN RARROW core_type + { $$ = mktfun(mkttuple(mklcons(mkunidict($4, $5), $9)), $12); } + | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN + { $$ = mkttuple(mklcons(mkunidict($4,$5), $9)); } + | type { $$ = $1; } + ; +*/ + +core_type_maybes: + core_type_maybe { $$ = lsing($1); } + | core_type_maybes COMMA core_type_maybe { $$ = lapp($1, $3); } + ; + +core_type_maybe: + NO_PRAGMA { $$ = mkty_maybe_nothing(); } + | core_type { $$ = mkty_maybe_just($1); } + ; + +/* -- end of core syntax stuff ------------------------------------ */ + +readpreludecore : + { + if ( implicitPrelude && !etags ) { + /* we try to avoid reading interfaces when etagging */ + find_module_on_imports_dirlist( + (haskell1_3Flag) ? "PrelCore13" : "PreludeCore", + TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + } + readinterface + { + binding prelude_core = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno); + prelude_core_import = implicitPrelude? lsing(prelude_core): Lnil; + + } + ; + +readprelude : + { + if ( implicitPrelude && !etags ) { + find_module_on_imports_dirlist( + ( haskell1_3Flag ) ? "Prel13" : "Prelude", + TRUE,interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + } + readinterface + { + binding prelude = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno); + prelude_imports = (! implicitPrelude) ? Lnil + : lconc(prelude_core_import,lsing(prelude)); + } + ; + +maybeimpdecls : /* empty */ { $$ = Lnil; } + | impdecls SEMI { $$ = $1; } + ; + +impdecls: impdecl { $$ = $1; } + | impdecls SEMI impdecl { $$ = lconc($1,$3); } + ; + +impdecl : IMPORT modid + { /* filename returned in "interface_filename" */ + char *module_name = id_to_string($2); + if ( ! etags ) { + find_module_on_imports_dirlist( + (haskell1_3Flag && strcmp(module_name, "Prelude") == 0) + ? "Prel13" : module_name, + FALSE, interface_filename); + } else { + find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename); + } + thisIfacePragmaVersion = 0; + setyyin(interface_filename); + enteriscope(); + if (strcmp(module_name,"PreludeCore")==0) { + hsperror("Cannot explicitly import `PreludeCore'"); + + } else if (strcmp(module_name,"Prelude")==0) { + prelude_imports = prelude_core_import; /* unavoidable */ + } + } + impdecl_rest + { + if (hidden) + $4->tag = hiding; + $$ = lsing($4); + } + +impdecl_rest: + readinterface maybeimpspec + { $$ = mkimport(installid(iface_name),$2,Lnil,$1,xstrdup(interface_filename),hsplineno); } + /* WDP: uncertain about those hsplinenos */ + | readinterface maybeimpspec RENAMING renamings + { $$ = mkimport(installid(iface_name),$2,$4,$1,xstrdup(interface_filename),hsplineno); } + ; + +readinterface: + interface LEOF + { + exposeis(); /* partain: expose infix ops at level i+1 to level i */ + $$ = $1; + } + ; + +renamings: OPAREN renaming_list CPAREN { $$ = $2; } + ; + +renaming_list: + renaming { $$ = lsing($1); } + | renaming_list COMMA renaming { $$ = lapp($1, $3); } + ; + +renaming: var TO var { $$ = ldub($1,$3); } + | con TO con { $$ = ldub($1,$3); } + ; + +maybeiimports : /* empty */ { $$ = mknullbind(); } + | iimports SEMI { $$ = $1; } + ; + +iimports : iimport { $$ = $1; } + | iimports SEMI iimport { $$ = mkabind($1,$3); } + ; + +iimport : importkey modid OPAREN import_list CPAREN + { $$ = mkmbind($2,$4,Lnil,startlineno); } + | importkey modid OPAREN import_list CPAREN RENAMING renamings + { $$ = mkmbind($2,$4,$7,startlineno); } + ; + + +interface: + INTERFACE modid + { fixlist = Lnil; + strcpy(iface_name, id_to_string($2)); + } + WHERE ibody + { + /* WDP: not only do we not check the module name + but we take the one in the interface to be what we really want + -- we need this for Prelude jiggery-pokery. (Blech. KH) + ToDo: possibly revert.... + checkmodname(modname,id_to_string($2)); + */ + $$ = $5; + } + ; + + +ibody : ocurly maybeiimports maybefixes itopdecls ccurly + { + $$ = mkabind($2,$4); + } + | ocurly iimports ccurly + { + $$ = $2; + } + | vocurly maybeiimports maybefixes itopdecls vccurly + { + $$ = mkabind($2,$4); + } + | vocurly iimports vccurly + { + $$ = $2; + } + ; + +maybefixes: /* empty */ + | fixes SEMI + ; + + +fixes : fix + | fixes SEMI fix + ; + +fix : INFIXL INTEGER + { Precedence = checkfixity($2); Fixity = INFIXL; } + ops + | INFIXR INTEGER + { Precedence = checkfixity($2); Fixity = INFIXR; } + ops + | INFIX INTEGER + { Precedence = checkfixity($2); Fixity = INFIX; } + ops + | INFIXL + { Fixity = INFIXL; Precedence = 9; } + ops + | INFIXR + { Fixity = INFIXR; Precedence = 9; } + ops + | INFIX + { Fixity = INFIX; Precedence = 9; } + ops + ; + +ops : op { makeinfix(id_to_string($1),Fixity,Precedence); } + | ops COMMA op { makeinfix(id_to_string($3),Fixity,Precedence); } + ; + +topdecls: topdecl + | topdecls SEMI topdecl + { + if($1 != NULL) + if($3 != NULL) + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + else + $$ = $1; + else + $$ = $3; + SAMEFN = 0; + } + ; + +topdecl : typed { $$ = $1; } + | datad { $$ = $1; } + | classd { $$ = $1; } + | instd { $$ = $1; } + | defaultd { $$ = $1; } + | decl { $$ = $1; } + ; + +typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno,mkno_pragma()); } + ; + + +datad : datakey context DARROW simple EQUAL constrs + { $$ = mktbind($2,$4,$6,all,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs + { $$ = mktbind(Lnil,$2,$4,all,startlineno,mkno_pragma()); } + | datakey context DARROW simple EQUAL constrs DERIVING tyclses + { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs DERIVING tyclses + { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); } + ; + +classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,mkno_pragma()); } + | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,mkno_pragma()); } + ; + +cbody : /* empty */ { $$ = mknullbind(); } + | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; } + | WHERE vocurly decls vccurly { checkorder($3); $$ =$3; } + ; + +instd : instkey context DARROW tycls inst rinst { $$ = mkibind($2,$4,$5,$6,startlineno,mkno_pragma()); } + | instkey tycls inst rinst { $$ = mkibind(Lnil,$2,$3,$4,startlineno,mkno_pragma()); } + ; + +rinst : /* empty */ { $$ = mknullbind(); } + | WHERE ocurly instdefs ccurly { $$ = $3; } + | WHERE vocurly instdefs vccurly { $$ = $3; } + ; + +inst : tycon { $$ = mktname($1,Lnil); } + | OPAREN simple_long CPAREN { $$ = $2; } + /* partain?: "simple" requires k >= 0, not k > 0 (hence "simple_long" hack) */ + | OPAREN atype_list CPAREN { $$ = mkttuple($2); } + | OPAREN CPAREN { $$ = mkttuple(Lnil); } + | OBRACK atype CBRACK { $$ = mktllist($2); } + | OPAREN atype RARROW atype CPAREN { $$ = mktfun($2,$4); } + ; + +defaultd: defaultkey dtypes { $$ = mkdbind($2,startlineno); } + ; + +dtypes : OPAREN type COMMA types CPAREN { $$ = mklcons($2,$4); } + | ttype { $$ = lsing($1); } +/* Omitting the next forces () to be the *type* (), which never defaults. + This is a KLUDGE. (Putting this in adds piles of r/r conflicts.) +*/ +/* | OPAREN CPAREN { $$ = Lnil; }*/ + ; + +decls : decl + | decls SEMI decl + { + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + } + ; + +/* partain: this "DCOLON context" vs "DCOLON type" is a problem, + because you can't distinguish between + + foo :: (Baz a, Baz a) + bar :: (Baz a, Baz a) => [a] -> [a] -> [a] + + with one token of lookahead. The HACK is to have "DCOLON ttype" + [tuple type] in the first case, then check that it has the right + form C a, or (C1 a, C2 b, ... Cn z) and convert it into a + context. Blaach! + (FIXED 90/06/06) + + Note: if there is an iclasop_pragma there, then we must be + doing a class-op in an interface -- unless the user is up + to real mischief (ugly, but likely to work). +*/ + +decl : vars DCOLON type DARROW type iclasop_pragma + { /* type2context.c for code */ + $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + | vars DCOLON type iclasop_pragma + { + $$ = mksbind($1,$3,startlineno,$4); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + /* User-specified pragmas come in as "signatures"... + They are similar in that they can appear anywhere in the module, + and have to be "joined up" with their related entity. + + Have left out the case specialising to an overloaded type. + Let's get real, OK? (WDP) + */ + | SPECIALISE_UPRAGMA vark DCOLON types_and_maybe_ids END_UPRAGMA + { + $$ = mkvspec_uprag($2, $4, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | SPECIALISE_UPRAGMA INSTANCE CONID inst END_UPRAGMA + { + $$ = mkispec_uprag($3, $4, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | SPECIALISE_UPRAGMA DATA tycon atypes END_UPRAGMA + { + $$ = mkdspec_uprag($3, $4, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | INLINE_UPRAGMA vark howto_inline_maybe END_UPRAGMA + { + $$ = mkinline_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | MAGIC_UNFOLDING_UPRAGMA vark vark END_UPRAGMA + { + $$ = mkmagicuf_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | DEFOREST_UPRAGMA vark END_UPRAGMA + { + $$ = mkdeforest_uprag($2, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | ABSTRACT_UPRAGMA tycon END_UPRAGMA + { + $$ = mkabstract_uprag($2, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + /* end of user-specified pragmas */ + + | valdef + | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; } + ; + +howto_inline_maybe : + /* empty */ { $$ = Lnil; } + | CONID { $$ = lsing($1); } + +types_and_maybe_ids : + type_and_maybe_id { $$ = lsing($1); } + | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); } + ; + +type_and_maybe_id : + type { $$ = mkvspec_ty_and_id($1,Lnil); } + | type EQUAL vark { $$ = mkvspec_ty_and_id($1,lsing($3)); } + +itopdecls : itopdecl { $$ = $1; } + | itopdecls SEMI itopdecl { $$ = mkabind($1,$3); } + ; + +itopdecl: ityped { $$ = $1; } + | idatad { $$ = $1; } + | iclassd { $$ = $1; } + | iinstd { $$ = $1; } + | ivarsd { $$ = $1; } + | /* empty */ { $$ = mknullbind(); } + ; + + /* partain: see comment elsewhere about why "type", not "context" */ +ivarsd : vars DCOLON type DARROW type ival_pragma + { $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); } + | vars DCOLON type ival_pragma + { $$ = mksbind($1,$3,startlineno,$4); } + ; + +ityped : typekey simple EQUAL type itype_pragma + { $$ = mknbind($2,$4,startlineno,$5); } + ; + +idatad : datakey context DARROW simple idata_pragma + { $$ = mktbind($2,$4,Lnil,Lnil,startlineno,$5); } + | datakey simple idata_pragma + { $$ = mktbind(Lnil,$2,Lnil,Lnil,startlineno,$3); } + | datakey context DARROW simple EQUAL constrs idata_pragma + { $$ = mktbind($2,$4,$6,Lnil,startlineno,$7); } + | datakey simple EQUAL constrs idata_pragma + { $$ = mktbind(Lnil,$2,$4,Lnil,startlineno,$5); } + | datakey context DARROW simple EQUAL constrs DERIVING tyclses + { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); } + | datakey simple EQUAL constrs DERIVING tyclses + { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); } + ; + +iclassd : classkey context DARROW class iclas_pragma cbody + { $$ = mkcbind($2,$4,$6,startlineno,$5); } + | classkey class iclas_pragma cbody + { $$ = mkcbind(Lnil,$2,$4,startlineno,$3); } + ; + +iinstd : instkey context DARROW tycls inst iinst_pragma + { $$ = mkibind($2,$4,$5,mknullbind(),startlineno,$6); } + | instkey tycls inst iinst_pragma + { $$ = mkibind(Lnil,$2,$3,mknullbind(),startlineno,$4); } + ; + + +/* obsolete: "(C a, ...)" cause r/r conflict, resolved in favour of context rather than type */ + +class : tycon tyvar { $$ = mktname($1,lsing($2)); } + /* partain: changed "tycls" to "tycon" */ + ; + +types : type { $$ = lsing($1); } + | types COMMA type { $$ = lapp($1,$3); } + ; + +type : btype { $$ = $1; } + | btype RARROW type { $$ = mktfun($1,$3); } + + | FORALL core_tv_templates DARROW type + { $$ = mkuniforall($2, $4); } + +btype : atype { $$ = $1; } + | tycon atypes { $$ = mktname($1,$2); } + ; + +atypes : atypes atype { $$ = lapp($1,$2); } + | atype { $$ = lsing($1); } + ; + +/* The split with ntatype allows us to use the same syntax for defaults as for types */ +ttype : ntatype { $$ = $1; } + | btype RARROW type { $$ = mktfun($1,$3); } + | tycon atypes { $$ = mktname($1,$2); } + ; + +atype : ntatype + | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); } + ; + +ntatype : tyvar { $$ = $1; } + | tycon { $$ = mktname($1,Lnil); } + | OPAREN CPAREN { $$ = mkttuple(Lnil); } + | OPAREN type CPAREN { $$ = $2; } + | OBRACK type CBRACK { $$ = mktllist($2); } + + | OCURLY OCURLY CONID type CCURLY CCURLY + { $$ = mkunidict($3, $4); } + | TYVAR_TEMPLATE_ID { $$ = mkunityvartemplate($1); } + ; + + +simple : tycon { $$ = mktname($1,Lnil); } + | tycon tyvars { $$ = mktname($1,$2); } + ; + + +simple_long : tycon atypes { $$ = mktname($1,$2); } + ; /* partain: see comment in "inst" */ + /* partain: "atypes" should be "tyvars" if you want to + avoid "extended instances" by syntactic means. */ + + +constrs : constr { $$ = lsing($1); } + | constrs VBAR constr { $$ = lapp($1,$3); } + ; + +/* Using tycon rather than con avoids 5 S/R errors */ +constr : tycon atypes { $$ = mkatc($1,$2,hsplineno); } + | OPAREN CONSYM CPAREN atypes { $$ = mkatc($2,$4,hsplineno); } + | tycon { $$ = mkatc($1,Lnil,hsplineno); } + | OPAREN CONSYM CPAREN { $$ = mkatc($2,Lnil,hsplineno); } + | btype conop btype { $$ = mkatc($2, ldub($1,$3),hsplineno); } + ; + +tyclses : OPAREN tycls_list CPAREN { $$ = $2; } + | OPAREN CPAREN { $$ = Lnil; } + | tycls { $$ = lsing($1); } + ; + +tycls_list: tycls { $$ = lsing($1); } + | tycls_list COMMA tycls { $$ = lapp($1,$3); } + ; + +context : OPAREN context_list CPAREN { $$ = $2; } + | class { $$ = lsing($1); } + ; + +context_list: class { $$ = lsing($1); } + | context_list COMMA class { $$ = lapp($1,$3); } + ; + +instdefs : /* empty */ { $$ = mknullbind(); } + | instdef { $$ = $1; } + | instdefs SEMI instdef + { + if(SAMEFN) + { + extendfn($1,$3); + $$ = $1; + } + else + $$ = mkabind($1,$3); + } + ; + +/* instdef: same as valdef, except certain user-pragmas may appear */ +instdef : + INLINE_UPRAGMA vark howto_inline_maybe END_UPRAGMA + { + $$ = mkinline_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | MAGIC_UNFOLDING_UPRAGMA vark vark END_UPRAGMA + { + $$ = mkmagicuf_uprag($2, $3, startlineno); + PREVPATT = NULL; FN = NULL; SAMEFN = 0; + } + + | valdef + ; + + +vars : vark COMMA varsrest { $$ = mklcons($1,$3); } + | vark { $$ = lsing($1); } + /* right recursion ? WDP */ + ; + +varsrest: var { $$ = lsing($1); } + | varsrest COMMA var { $$ = lapp($1,$3); } + ; + +cons : con { $$ = lsing($1); } + | cons COMMA con { $$ = lapp($1,$3); } + ; + + +valdef : opatk + { + tree fn = function($1); + + PREVPATT = $1; + + if(ttree(fn) == ident) + { + checksamefn(gident((struct Sident *) fn)); + FN = fn; + } + + else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident) + { + checksamefn(gident((struct Sident *) (ginfun((struct Sap *) fn)))); + FN = ginfun((struct Sap *) fn); + } + + else if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tvaldef\n",startlineno); +#endif + } + valrhs + { + if ( lhs_is_patt($1) ) + { + $$ = mkpbind($3, startlineno); + FN = NULL; + SAMEFN = 0; + } + else /* lhs is function */ + $$ = mkfbind($3,startlineno); + + PREVPATT = NULL; + } + ; + +valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); } + ; + +valrhs1 : gdrhs + | EQUAL exp { $$ = lsing(mktruecase($2)); } + ; + +gdrhs : gd EQUAL exp { $$ = lsing(ldub($1,$3)); } + | gd EQUAL exp gdrhs { $$ = mklcons(ldub($1,$3),$4); } + ; + +maybe_where: + WHERE ocurly decls ccurly { $$ = $3; } + | WHERE vocurly decls vccurly { $$ = $3; } + | /* empty */ { $$ = mknullbind(); } + ; + +gd : VBAR oexp { $$ = $2; } + ; + + +lampats : apat lampats { $$ = mklcons($1,$2); } + | apat { $$ = lsing($1); } + ; /* right recursion? (WDP) */ + + +/* + Changed as above to allow for contexts! + KH@21/12/92 +*/ + +exp : oexp DCOLON type DARROW type { $$ = mkrestr($1,mkcontext(type2context($3),$5)); } + | oexp DCOLON type { $$ = mkrestr($1,$3); } + | oexp + ; + +/* + Operators must be left-associative at the same precedence + for prec. parsing to work. +*/ + + /* Infix operator application */ +oexp : dexp + | oexp op oexp %prec PLUS + { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +/* + This comes here because of the funny precedence rules concerning + prefix minus. +*/ + + +dexp : MINUS kexp { $$ = mknegate($2); } + | kexp + ; + +/* + let/if/lambda/case have higher precedence than infix operators. +*/ + +kexp : LAMBDA + { /* enteriscope(); /? I don't understand this -- KH */ + hsincindent(); /* added by partain; push new context for */ + /* FN = NULL; not actually concerned about */ + FN = NULL; /* indenting */ + $<uint>$ = hsplineno; /* remember current line number */ + } + lampats + { hsendindent(); /* added by partain */ + /* exitiscope(); /? Also not understood */ + } + RARROW exp /* lambda abstraction */ + { + $$ = mklambda($3, $6, $<uint>2); + } + + /* Let Expression */ + | LET ocurly decls ccurly IN exp { $$ = mklet($3,$6); } + | LET vocurly decls vccurly IN exp { $$ = mklet($3,$6); } + + /* If Expression */ + | IF exp THEN exp ELSE exp { $$ = mkife($2,$4,$6); } + + /* Case Expression */ + | CASE exp OF ocurly alts ccurly { $$ = mkcasee($2,$5); } + | CASE exp OF vocurly alts vccurly { $$ = mkcasee($2,$5); } + + /* CCALL/CASM Expression */ + | CCALL ccallid cexp { $$ = mkccall($2,installid("n"),$3); } + | CCALL ccallid { $$ = mkccall($2,installid("n"),Lnil); } + | CCALL_GC ccallid cexp { $$ = mkccall($2,installid("p"),$3); } + | CCALL_GC ccallid { $$ = mkccall($2,installid("p"),Lnil); } + | CASM CLITLIT cexp { $$ = mkccall($2,installid("N"),$3); } + | CASM CLITLIT { $$ = mkccall($2,installid("N"),Lnil); } + | CASM_GC CLITLIT cexp { $$ = mkccall($2,installid("P"),$3); } + | CASM_GC CLITLIT { $$ = mkccall($2,installid("P"),Lnil); } + + /* SCC Expression */ + | SCC STRING exp + { extern BOOLEAN ignoreSCC; + extern BOOLEAN warnSCC; + + if (ignoreSCC) { + if (warnSCC) + fprintf(stderr, + "\"%s\", line %d: _scc_ (`set [profiling] cost centre') ignored\n", + input_filename, hsplineno); + $$ = $3; + } else { + $$ = mkscc($2, $3); + } + } + | fexp + ; + + + /* Function application */ +fexp : fexp aexp { $$ = mkap($1,$2); } + | aexp + ; + +cexp : cexp aexp { $$ = lapp($1,$2); } + | aexp { $$ = lsing($1); } + ; + +/* + The mkpars are so that infix parsing doesn't get confused. + + KH. +*/ + + /* Simple Expressions */ +aexp : var { $$ = mkident($1); } + | con { $$ = mkident($1); } + | lit_constant { $$ = mklit($1); } + | OPAREN exp CPAREN { $$ = mkpar($2); } + | OPAREN oexp op CPAREN { checkprec($2,$3,FALSE); $$ = mklsection($2,$3); } + | OPAREN op1 oexp CPAREN { checkprec($3,$2,TRUE); $$ = mkrsection($2,$3); } + + /* structures */ + | tuple + | list { $$ = mkpar($1); } + | sequence { $$ = mkpar($1); } + | comprehension { $$ = mkpar($1); } + + /* These only occur in patterns */ + | var AT aexp { checkinpat(); $$ = mkas($1,$3); } + | WILDCARD { checkinpat(); $$ = mkwildp(); } + | LAZY aexp { checkinpat(); $$ = mklazyp($2); } + ; + + +/* + LHS patterns are parsed in a similar way to + expressions. This avoids the horrible non-LRness + which occurs with the 1.1 syntax. + + The xpatk business is to do with accurately recording + the starting line for definitions. +*/ + +/*TESTTEST +bind : opatk + | vark lampats + { $$ = mkap($1,$2); } + | opatk varop opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + } + ; + +opatk : dpatk + | opatk conop opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + precparse($$); + } + ; + +*/ + +opatk : dpatk + | opatk op opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + + if(isconstr(id_to_string($2))) + precparse($$); + else + { + checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */ + checkprec($3,$2,TRUE); /* then check the right pattern */ + } + } + ; + +opat : dpat + | opat op opat %prec PLUS + { + $$ = mkinfixop($2,$1,$3); + + if(isconstr(id_to_string($2))) + precparse($$); + else + { + checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */ + checkprec($3,$2,TRUE); /* then check the right pattern */ + } + } + ; + +/* + This comes here because of the funny precedence rules concerning + prefix minus. +*/ + + +dpat : MINUS fpat { $$ = mknegate($2); } + | fpat + ; + + /* Function application */ +fpat : fpat aapat { $$ = mkap($1,$2); } + | aapat + ; + +dpatk : minuskey fpat { $$ = mknegate($2); } + | fpatk + ; + + /* Function application */ +fpatk : fpatk aapat { $$ = mkap($1,$2); } + | aapatk + ; + +aapat : con { $$ = mkident($1); } + | var { $$ = mkident($1); } + | var AT apat { $$ = mkas($1,$3); } + | lit_constant { $$ = mklit($1); } + | WILDCARD { $$ = mkwildp(); } + | OPAREN CPAREN { $$ = mktuple(Lnil); } + | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } +/* GHC cannot do these anyway. WDP 93/11/15 + | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } +*/ + | OPAREN opat CPAREN { $$ = mkpar($2); } + | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | OBRACK pats CBRACK { $$ = mkllist($2); } + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } + ; + +aapatk : conk { $$ = mkident($1); } + | vark { $$ = mkident($1); } + | vark AT apat { $$ = mkas($1,$3); } + | lit_constant { $$ = mklit($1); setstartlineno(); } + | WILDCARD { $$ = mkwildp(); setstartlineno(); } + | oparenkey CPAREN { $$ = mktuple(Lnil); } + | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } +/* GHC no cannae do (WDP 95/05) + | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } +*/ + | oparenkey opat CPAREN { $$ = mkpar($2); } + | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | obrackkey pats CBRACK { $$ = mkllist($2); } + | obrackkey CBRACK { $$ = mkllist(Lnil); } + | lazykey apat { $$ = mklazyp($2); } + ; + + +/* + The mkpars are so that infix parsing doesn't get confused. + + KH. +*/ + +tuple : OPAREN exp COMMA texps CPAREN + { if (ttree($4) == tuple) + $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4))); + else + $$ = mktuple(ldub($2, $4)); + } + | OPAREN CPAREN + { $$ = mktuple(Lnil); } + ; + +texps : exp { $$ = mkpar($1); } + | exp COMMA texps + { if (ttree($3) == tuple) + $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3))); + else + $$ = mktuple(ldub($1, $3)); + } + /* right recursion? WDP */ + ; + + +list : OBRACK CBRACK { $$ = mkllist(Lnil); } + | OBRACK list_exps CBRACK { $$ = mkllist($2); } + ; + +list_exps : + exp { $$ = lsing($1); } + | exp COMMA list_exps { $$ = mklcons($1, $3); } + /* right recursion? (WDP) + + It has to be this way, though, otherwise you + may do the wrong thing to distinguish between... + + [ e1 , e2 .. ] -- an enumeration ... + [ e1 , e2 , e3 ] -- a list + + (In fact, if you change the grammar and throw yacc/bison + at it, it *will* do the wrong thing [WDP 94/06]) + */ + ; + + +sequence: OBRACK exp COMMA exp DOTDOT upto CBRACK {$$ = mkeenum($2,lsing($4),$6);} + | OBRACK exp DOTDOT upto CBRACK { $$ = mkeenum($2,Lnil,$4); } + ; + +comprehension: OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); } + ; + +quals : qual { $$ = lsing($1); } + | quals COMMA qual { $$ = lapp($1,$3); } + ; + +qual : { inpat = TRUE; } exp { inpat = FALSE; } qualrest + { if ($4 == NULL) + $$ = mkguard($2); + else + { + checkpatt($2); + if(ttree($4)==def) + { + tree prevpatt_save = PREVPATT; + PREVPATT = $2; + $$ = mkdef((tree) mkpbind(lsing(createpat(lsing(mktruecase(ggdef((struct Sdef *) $4))),mknullbind())),hsplineno)); + PREVPATT = prevpatt_save; + } + else + $$ = mkqual($2,$4); + } + } + ; + +qualrest: LARROW exp { $$ = $2; } + | /* empty */ { $$ = NULL; } + ; + +alts : alt { $$ = $1; } + | alts SEMI alt { $$ = lconc($1,$3); } + ; + +alt : pat + { PREVPATT = $1; } + altrest + { $$ = $3; + PREVPATT = NULL; + } + | /* empty */ { $$ = Lnil; } + ; + +altrest : gdpat maybe_where { $$ = lsing(createpat($1, $2)); } + | RARROW exp maybe_where { $$ = lsing(createpat(lsing(mktruecase($2)), $3)); } + ; + +gdpat : gd RARROW exp gdpat { $$ = mklcons(ldub($1,$3),$4); } + | gd RARROW exp { $$ = lsing(ldub($1,$3)); } + ; + +upto : /* empty */ { $$ = Lnil; } + | exp { $$ = lsing($1); } + ; + +pats : pat COMMA pats { $$ = mklcons($1, $3); } + | pat { $$ = lsing($1); } + /* right recursion? (WDP) */ + ; + +pat : bpat + | pat conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); } + ; + +bpat : apatc + | conpat + | MINUS INTEGER { $$ = mklit(mkinteger(ineg($2))); } + | MINUS FLOAT { $$ = mklit(mkfloatr(ineg($2))); } + ; + +conpat : con { $$ = mkident($1); } + | conpat apat { $$ = mkap($1,$2); } + ; + +apat : con { $$ = mkident($1); } + | apatc + ; + +apatc : var { $$ = mkident($1); } + | var AT apat { $$ = mkas($1,$3); } + | lit_constant { $$ = mklit($1); } + | WILDCARD { $$ = mkwildp(); } + | OPAREN CPAREN { $$ = mktuple(Lnil); } + | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); } +/* GHC no cannae do (WDP 95/05) + | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); } +*/ + | OPAREN pat CPAREN { $$ = mkpar($2); } + | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); } + | OBRACK pats CBRACK { $$ = mkllist($2); } + | OBRACK CBRACK { $$ = mkllist(Lnil); } + | LAZY apat { $$ = mklazyp($2); } + ; + +lit_constant: + INTEGER { $$ = mkinteger($1); } + | FLOAT { $$ = mkfloatr($1); } + | CHAR { $$ = mkcharr($1); } + | STRING { $$ = mkstring($1); } + | CHARPRIM { $$ = mkcharprim($1); } + | STRINGPRIM { $$ = mkstringprim($1); } + | INTPRIM { $$ = mkintprim($1); } + | FLOATPRIM { $$ = mkfloatprim($1); } + | DOUBLEPRIM { $$ = mkdoubleprim($1); } + | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1, ""); } + | CLITLIT KIND_PRAGMA CONID { $$ = mkclitlit($1, $3); } + | NOREP_INTEGER INTEGER { $$ = mknorepi($2); } + | NOREP_RATIONAL INTEGER INTEGER { $$ = mknorepr($2, $3); } + | NOREP_STRING STRING { $$ = mknoreps($2); } + ; + + +/* Keywords which record the line start */ + +importkey: IMPORT { setstartlineno(); } + ; + +datakey : DATA { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tdata\n",startlineno); +#endif + } + ; + +typekey : TYPE { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\ttype\n",startlineno); +#endif + } + ; + +instkey : INSTANCE { setstartlineno(); +#if 1/*etags*/ +/* OUT: if(etags) + printf("%u\n",startlineno); +*/ +#else + fprintf(stderr,"%u\tinstance\n",startlineno); +#endif + } + ; + +defaultkey: DEFAULT { setstartlineno(); } + ; + +classkey: CLASS { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tclass\n",startlineno); +#endif + } + ; + +minuskey: MINUS { setstartlineno(); } + ; + +modulekey: MODULE { setstartlineno(); + if(etags) +#if 1/*etags*/ + printf("%u\n",startlineno); +#else + fprintf(stderr,"%u\tmodule\n",startlineno); +#endif + } + ; + +oparenkey: OPAREN { setstartlineno(); } + ; + +obrackkey: OBRACK { setstartlineno(); } + ; + +lazykey : LAZY { setstartlineno(); } + ; + + + +/* Non "-" op, used in right sections -- KH */ +op1 : conop + | varop1 + ; + +op : conop + | varop + ; + +varop : varsym + | BQUOTE VARID BQUOTE { $$ = $2; } + ; + +/* Non-minus varop, used in right sections */ +varop1 : VARSYM + | plus + | BQUOTE VARID BQUOTE { $$ = $2; } + ; + +conop : CONSYM + | BQUOTE CONID BQUOTE { $$ = $2; } + ; + +varsym : VARSYM + | plus + | minus + ; + +minus : MINUS { $$ = install_literal("-"); } + ; + +plus : PLUS { $$ = install_literal("+"); } + ; + +var : VARID + | OPAREN varsym CPAREN { $$ = $2; } + ; + +vark : VARID { setstartlineno(); $$ = $1; } + | oparenkey varsym CPAREN { $$ = $2; } + ; + +/* tycon used here to eliminate 11 spurious R/R errors -- KH */ +con : tycon + | OPAREN CONSYM CPAREN { $$ = $2; } + ; + +conk : tycon { setstartlineno(); $$ = $1; } + | oparenkey CONSYM CPAREN { $$ = $2; } + ; + +ccallid : VARID + | CONID + ; + +/* partain: "atype_list" must be at least 2 elements long (defn of "inst") */ +atype_list: atype COMMA atype { $$ = mklcons($1,lsing($3)); } + | atype COMMA atype_list { $$ = mklcons($1,$3); } + /* right recursion? WDP */ + ; + +tyvars : tyvar { $$ = lsing($1); } + | tyvars tyvar { $$ = lapp($1, $2); } + ; + +tyvar : VARID { $$ = mknamedtvar($1); } + ; + +tycls : tycon + /* partain: "aconid"->"tycon" got rid of a r/r conflict + (and introduced >= 2 s/r's ...) + */ + ; + +tycon : CONID + ; + +modid : CONID + ; + + +ocurly : layout OCURLY { hsincindent(); } + +vocurly : layout { hssetindent(); } + ; + +layout : { hsindentoff(); } + ; + +ccurly : + CCURLY + { + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + ; + +vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; } + ; + +vccurly1: + VCCURLY + { + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + | error + { + yyerrok; + FN = NULL; SAMEFN = 0; PREVPATT = NULL; + hsendindent(); + } + ; + +%% + +/********************************************************************** +* * +* Error Processing and Reporting * +* * +* (This stuff is here in case we want to use Yacc macros and such.) * +* * +**********************************************************************/ + +/* The parser calls "hsperror" when it sees a + `report this and die' error. It sets the stage + and calls "yyerror". + + There should be no direct calls in the parser to + "yyerror", except for the one from "hsperror". Thus, + the only other calls will be from the error productions + introduced by yacc/bison/whatever. + + We need to be able to recognise the from-error-production + case, because we sometimes want to say, "Oh, never mind", + because the layout rule kicks into action and may save + the day. [WDP] +*/ + +static BOOLEAN error_and_I_mean_it = FALSE; + +void +hsperror(s) + char *s; +{ + error_and_I_mean_it = TRUE; + yyerror(s); +} + +void +yyerror(s) + char *s; +{ + extern char *yytext; + extern int yyleng; + + /* We want to be able to distinguish 'error'-raised yyerrors + from yyerrors explicitly coded by the parser hacker. + */ + if (expect_ccurly && ! error_and_I_mean_it ) { + /*NOTHING*/; + + } else { + fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ", + input_filename, hsplineno, hspcolno + 1, s); + + if (yyleng == 1 && *yytext == '\0') + fprintf(stderr, "<EOF>"); + + else { + fputc('"', stderr); + format_string(stderr, (unsigned char *) yytext, yyleng); + fputc('"', stderr); + } + fputc('\n', stderr); + + /* a common problem */ + if (strcmp(yytext, "#") == 0) + fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n"); + + exit(1); + } +} + +void +format_string(fp, s, len) + FILE *fp; + unsigned char *s; + int len; +{ + while (len-- > 0) { + switch (*s) { + case '\0': fputs("\\NUL", fp); break; + case '\007': fputs("\\a", fp); break; + case '\010': fputs("\\b", fp); break; + case '\011': fputs("\\t", fp); break; + case '\012': fputs("\\n", fp); break; + case '\013': fputs("\\v", fp); break; + case '\014': fputs("\\f", fp); break; + case '\015': fputs("\\r", fp); break; + case '\033': fputs("\\ESC", fp); break; + case '\034': fputs("\\FS", fp); break; + case '\035': fputs("\\GS", fp); break; + case '\036': fputs("\\RS", fp); break; + case '\037': fputs("\\US", fp); break; + case '\177': fputs("\\DEL", fp); break; + default: + if (*s >= ' ') + fputc(*s, fp); + else + fprintf(fp, "\\^%c", *s + '@'); + break; + } + s++; + } +} |