char *ineg PROTO((char *));
long source_version = 0;
+BOOLEAN pat_check=TRUE;
-BOOLEAN inpat;
%}
%union {
%token SCC
%token CCALL CCALL_GC CASM CASM_GC
-
+%token EXPORT UNSAFE STDCALL C_CALL LABEL
+%token PASCAL FASTCALL FOREIGN DYNAMIC
/**********************************************************************
* *
**********************************************************************/
%token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
-%token INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
-%token DEFOREST_UPRAGMA END_UPRAGMA
+%token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
+%token END_UPRAGMA
%token SOURCE_UPRAGMA
/**********************************************************************
constrs constr1 fields
types atypes batypes
types_and_maybe_ids
- pats context context_list /* tyvar_list */
+ pats simple_context simple_context_list
export_list enames
import_list inames
impdecls maybeimpdecls impdecl
gdrhs gdpat valrhs
lampats cexps gd
-%type <umaybe> maybeexports impspec deriving
+%type <umaybe> maybeexports impspec deriving
+ ext_name
%type <uliteral> lit_constant
qvar qcon qvarop qconop qop
qvark qconk qtycon qtycls
gcon gconk gtycon itycon qop1 qvarop1
- ename iname
+ ename iname
%type <ubinding> topdecl topdecls letdecls
- typed datad newtd classd instd defaultd
+ typed datad newtd classd instd defaultd foreignd
decl decls valdef instdef instdefs
maybe_where cbody rinst type_and_maybe_id
%type <upbinding> valrhs1 altrest
-%type <uttype> simple ctype sigtype sigarrowtype type atype bigatype btype
- gtyconvars
+%type <uttype> ctype sigtype sigarrowtype type atype bigatype btype
bbtype batype bxtype wierd_atype
- class tyvar contype
+ simple_con_app simple_con_app1 tyvar contype inst_type
%type <uconstr> constr constr_after_context field
%type <uentid> export import
-%type <ulong> commas importkey
+%type <ulong> commas importkey get_line_no
+ unsafe_flag callconv
/**********************************************************************
* *
{ $$ = lsing(mkimport($3,1,mknothing(),$4,$1,startlineno)); }
| importkey QUALIFIED modid AS modid impspec
{ $$ = lsing(mkimport($3,1,mkjust($5),$6,$1,startlineno)); }
+ | importkey modid AS modid impspec
+ { $$ = lsing(mkimport($3,1,mkjust($4),$5,$1,startlineno)); }
;
impspec : /* empty */ { $$ = mknothing(); }
;
itycon : tycon { $$ = mknoqual($1); }
- | OBRACK CBRACK { $$ = creategid(-1); }
- | OPAREN CPAREN { $$ = creategid(0); }
+ | OBRACK CBRACK { $$ = creategid(NILGID); }
+ | OPAREN CPAREN { $$ = creategid(UNITGID); }
| OPAREN commas CPAREN { $$ = creategid($2); }
;
ops { $$ = $3; }
;
-ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence)); }
- | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence)); }
+ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence,startlineno)); }
+ | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence,startlineno)); }
;
topdecls: topdecl
| classd { $$ = $1; FN = NULL; SAMEFN = 0; }
| instd { $$ = $1; FN = NULL; SAMEFN = 0; }
| defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
+ | foreignd { $$ = $1; FN = NULL; SAMEFN = 0; }
| decl { $$ = $1; }
;
-typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno); }
+typed : typekey simple_con_app EQUAL type { $$ = mknbind($2,$4,startlineno); }
;
-datad : datakey simple EQUAL constrs deriving
+datad : datakey simple_con_app EQUAL constrs deriving
{ $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
- | datakey context DARROW simple EQUAL constrs deriving
+ | datakey simple_context DARROW simple_con_app EQUAL constrs deriving
{ $$ = mktbind($2,$4,$6,$7,startlineno); }
;
-newtd : newtypekey simple EQUAL constr1 deriving
+newtd : newtypekey simple_con_app EQUAL constr1 deriving
{ $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
- | newtypekey context DARROW simple EQUAL constr1 deriving
+ | newtypekey simple_context DARROW simple_con_app EQUAL constr1 deriving
{ $$ = mkntbind($2,$4,$6,$7,startlineno); }
;
| DERIVING dtyclses { $$ = mkjust($2); }
;
-classd : classkey context DARROW class cbody
- { $$ = mkcbind($2,$4,$5,startlineno); }
- | classkey class cbody
- { $$ = mkcbind(Lnil,$2,$3,startlineno); }
+classd : classkey btype DARROW simple_con_app1 cbody
+ /* Context can now be more than simple_context */
+ { $$ = mkcbind(type2context($2),$4,$5,startlineno); }
+ | classkey btype cbody
+ /* We have to say btype rather than simple_con_app1, else
+ we get reduce/reduce errs */
+ { check_class_decl_head($2);
+ $$ = mkcbind(Lnil,$2,$3,startlineno); }
;
cbody : /* empty */ { $$ = mknullbind(); }
| WHERE vocurly decls vccurly { checkorder($3); $$ = $3; }
;
-instd : instkey context DARROW gtycon atype rinst
- { $$ = mkibind($2,$4,$5,$6,startlineno); }
- | instkey gtycon atype rinst
- { $$ = mkibind(Lnil,$2,$3,$4,startlineno); }
+instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); }
;
+/* Compare ctype */
+inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */
+ $$ = mkcontext(type2context($1),$3); }
+ | btype { is_context_format( $1, 0 ); /* Check the instance head */
+ $$ = $1; }
+ ;
+
+
rinst : /* empty */ { $$ = mknullbind(); }
| WHERE ocurly instdefs ccurly { $$ = $3; }
| WHERE vocurly instdefs vccurly { $$ = $3; }
;
-/* I now allow a general type in instance declarations, relying
- on the type checker to reject instance decls which are ill-formed.
- Some (non-standard) extensions of Haskell may allow more general
- types than the Report syntax permits, and in any case not all things
- can be checked in the syntax (eg repeated type variables).
- SLPJ Jan 97
-
-restrict_inst : gtycon { $$ = mktname($1); }
- | OPAREN gtyconvars CPAREN { $$ = $2; }
- | OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- | OBRACK tyvar CBRACK { $$ = mktllist($2); }
- | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); }
+defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
+ | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
;
-general_inst : gtycon { $$ = mktname($1); }
- | OPAREN gtyconapp1 CPAREN { $$ = $2; }
- | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- | OBRACK type CBRACK { $$ = mktllist($2); }
- | OPAREN btype RARROW type CPAREN { $$ = mktfun($2,$4); }
+/* FFI primitive declarations - GHC/Hugs specific */
+foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON sigtype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
+ | foreignkey EXPORT callconv ext_name qvarid DCOLON sigtype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
+ ;
+ | foreignkey LABEL ext_name qvarid DCOLON sigtype { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
;
-*/
-defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
- | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
+callconv: STDCALL { $$ = CALLCONV_STDCALL; }
+ | C_CALL { $$ = CALLCONV_CCALL; }
+ | PASCAL { $$ = CALLCONV_PASCAL; }
+ | FASTCALL { $$ = CALLCONV_FASTCALL; }
+/* If you leave out the specification of a calling convention, you'll get C's. */
+ | /*empty*/ { $$ = CALLCONV_CCALL; }
;
+ext_name: STRING { $$ = mkjust(lsing($1)); }
+ | STRING STRING { $$ = mkjust(mklcons ($1,lsing($2))); }
+ | DYNAMIC { $$ = mknothing(); }
+
+unsafe_flag: UNSAFE { $$ = 1; }
+ | /*empty*/ { $$ = 0; }
+ ;
+
+
+
decls : decl
| decls SEMI decl
{
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
- | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
+ | NOINLINE_UPRAGMA qvark END_UPRAGMA
{
- $$ = mkmagicuf_uprag($2, $3, startlineno);
+ $$ = mknoinline_uprag($2, startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
- | DEFOREST_UPRAGMA qvark END_UPRAGMA
- {
- $$ = mkdeforest_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
+ {
+ $$ = mkmagicuf_uprag($2, $3, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
/* end of user-specified pragmas */
/* A sigtype is a rank 2 type; it can have for-alls as function args:
f :: All a => (All b => ...) -> Int
*/
-sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
+sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
| sigarrowtype
;
;
/* A "big" atype can be a forall-type in brackets. */
-bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
+bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
;
/* 1 S/R conflict at DARROW -> shift */
-ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); }
+ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); }
| type
;
;
gtycon : qtycon
- | OPAREN RARROW CPAREN { $$ = creategid(-2); }
- | OBRACK CBRACK { $$ = creategid(-1); }
- | OPAREN CPAREN { $$ = creategid(0); }
+ | OPAREN RARROW CPAREN { $$ = creategid(ARROWGID); }
+ | OBRACK CBRACK { $$ = creategid(NILGID); }
+ | OPAREN CPAREN { $$ = creategid(UNITGID); }
| OPAREN commas CPAREN { $$ = creategid($2); }
;
* *
**********************************************************************/
-simple : gtycon { $$ = mktname($1); }
- | gtyconvars { $$ = $1; }
- ;
-
-gtyconvars: gtycon tyvar { $$ = mktapp(mktname($1),$2); }
- | gtyconvars tyvar { $$ = mktapp($1,$2); }
+/* C a b c, where a,b,c are type variables */
+/* C can be a class or tycon */
+simple_con_app: gtycon { $$ = mktname($1); }
+ | simple_con_app1 { $$ = $1; }
;
-
-context : OPAREN context_list CPAREN { $$ = $2; }
- | class { $$ = lsing($1); }
+
+simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),$2); }
+ | simple_con_app tyvar { $$ = mktapp($1, $2); }
;
-context_list: class { $$ = lsing($1); }
- | context_list COMMA class { $$ = lapp($1,$3); }
+simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
+ | simple_con_app1 { $$ = lsing($1); }
;
-class : gtycon tyvar { $$ = mktapp(mktname($1),$2); }
+simple_context_list: simple_con_app1 { $$ = lsing($1); }
+ | simple_context_list COMMA simple_con_app1 { $$ = lapp($1,$3); }
;
constrs : constr { $$ = lsing($1); }
;
constr : constr_after_context
- | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
+ | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
;
constr_after_context :
| OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
/* Con { op1 :: Int } */
- | gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
- /* 1 S/R conflict on OCURLY -> shift */
+ | qtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
+ | OPAREN qconsym CPAREN OCURLY fields CCURLY { $$ = mkconstrrec($2,$5,hsplineno); }
;
+ /* 1 S/R conflict on OCURLY -> shift */
/* contype has to reduce to a btype unless there are !'s, so that
we don't get reduce/reduce conflicts with the second production of constr.
But as soon as we see a ! we must switch to using bxtype. */
-contype : btype { $$ = $1 }
- | bxtype { $$ = $1 }
+contype : btype { $$ = $1; }
+ | bxtype { $$ = $1; }
;
/* S !Int Bool; at least one ! */
/* A wierd atype is one that isn't a regular atype;
it starts with a "!", or with a forall. */
-wierd_atype : BANG bigatype { $$ = mktbang( $2 ) }
- | BANG atype { $$ = mktbang( $2 ) }
+wierd_atype : BANG bigatype { $$ = mktbang( $2 ); }
+ | BANG atype { $$ = mktbang( $2 ); }
| bigatype
;
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
+ | NOINLINE_UPRAGMA qvark END_UPRAGMA
+ {
+ $$ = mknoinline_uprag($2, startlineno);
+ PREVPATT = NULL; FN = NULL; SAMEFN = 0;
+ }
+
| MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
{
$$ = mkmagicuf_uprag($2, $3, startlineno);
valdef : vallhs
+
{
tree fn = function($1);
PREVPATT = $1;
#else
fprintf(stderr,"%u\tvaldef\n",startlineno);
#endif
- }
+ }
+
+ get_line_no
valrhs
{
if ( lhs_is_patt($1) )
{
- $$ = mkpbind($3, startlineno);
+ $$ = mkpbind($4, $3);
FN = NULL;
SAMEFN = 0;
}
else
- $$ = mkfbind($3,startlineno);
+ $$ = mkfbind($4, $3);
PREVPATT = NULL;
}
;
+get_line_no : { $$ = startlineno; }
+ ;
+
vallhs : patk { $$ = $1; }
| patk qvarop pat { $$ = mkinfixap($2,$1,$3); }
| funlhs { $$ = $1; }
/*
We need to factor out a leading let expression so we can set
- inpat=TRUE when parsing (non let) expressions inside stmts and quals
+ pat_check=FALSE when parsing (non let) expressions inside stmts and quals
*/
-expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
- | oexpLno
+expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
+ | oexpLno
;
oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
| dexpLno
/* SCC Expression */
| SCC STRING exp
{ if (ignoreSCC) {
- $$ = $3;
+ if (warnSCC) {
+ fprintf(stderr,
+ "\"%s\":%d: _scc_ (`set [profiling] cost centre') ignored\n",
+ input_filename, hsplineno);
+ }
+ $$ = mkpar($3); /* Note the mkpar(). If we don't have it, then
+ (x >> _scc_ y >> z) parses as (x >> (y >> z)),
+ right associated. But the precedence reorganiser expects
+ the parser to *left* associate all operators unless there
+ are explicit parens. The _scc_ acts like an explicit paren,
+ so if we omit it we'd better add explicit parens instead. */
} else {
$$ = mkscc($2, $3);
}
caserest: ocurly alts ccurly { $$ = $2; }
| vocurly alts vccurly { $$ = $2; }
-dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; }
+dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; }
| vocurly stmts vccurly { checkdostmts($2); $$ = $2; }
;
at it, it *will* do the wrong thing [WDP 94/06])
*/
-letdecls: LET ocurly decls ccurly { $$ = $3 }
- | LET vocurly decls vccurly { $$ = $3 }
+letdecls: LET { pat_check = TRUE; } ocurly decls ccurly { $$ = $4; }
+ | LET { pat_check = TRUE; } vocurly decls vccurly { $$ = $4; }
;
-quals : qual { $$ = lsing($1); }
- | quals COMMA qual { $$ = lapp($1,$3); }
+/*
+ When parsing patterns inside do stmt blocks or quals, we have
+ to tentatively parse them as expressions, since we don't know at
+ the time of parsing `p' whether it will be part of "p <- e" (pat)
+ or "p" (expr). When we eventually can tell the difference, the parse
+ of `p' is examined to see if it consitutes a syntactically legal pattern
+ or expression.
+
+ The expr rule used to parse the pattern/expression do contain
+ pattern-special productions (e.g., _ , a@pat, etc.), which are
+ illegal in expressions. Since we don't know whether what
+ we're parsing is an expression rather than a pattern, we turn off
+ the check and instead do it later.
+
+ The rather clumsy way that this check is turned on/off is there
+ to work around a Bison feature/shortcoming. Turning the flag
+ on/off just around the relevant nonterminal by decorating it
+ with simple semantic actions, e.g.,
+
+ {pat_check = FALSE; } expLNo { pat_check = TRUE; }
+
+ causes Bison to generate a parser where in one state it either
+ has to reduce/perform a semantic action ( { pat_check = FALSE; })
+ or reduce an error (the error production used to implement
+ vccurly.) Bison picks the semantic action, which it ideally shouldn't.
+ The work around is to lift out the setting of { pat_check = FALSE; }
+ and then later reset pat_check. Not pretty.
+
+*/
+
+
+quals : { pat_check = FALSE;} qual { pat_check = TRUE; $$ = lsing($2); }
+ | quals COMMA { pat_check = FALSE; } qual { pat_check = TRUE; $$ = lapp($1,$4); }
;
-qual : letdecls { $$ = mkseqlet($1); }
- | expL { $$ = $1; }
- | {inpat=TRUE;} expLno
- {inpat=FALSE;} leftexp
- { if ($4 == NULL) {
- expORpat(LEGIT_EXPR,$2);
- $$ = mkguard($2);
- } else {
- expORpat(LEGIT_PATT,$2);
- $$ = mkqual($2,$4);
- }
- }
+qual : letdecls { $$ = mkseqlet($1); }
+ | expL { expORpat(LEGIT_EXPR,$1); $$ = $1; }
+ | expLno { pat_check = TRUE; } leftexp
+ { if ($3 == NULL) {
+ expORpat(LEGIT_EXPR,$1);
+ $$ = mkguard($1);
+ } else {
+ expORpat(LEGIT_PATT,$1);
+ $$ = mkqual($1,$3);
+ }
+ }
;
alts : alt { $$ = $1; }
| gd RARROW exp gdpat { $$ = mklcons(mkpgdexp($1,$3),$4); }
;
-stmts : stmt { $$ = $1; }
- | stmts SEMI stmt { $$ = lconc($1,$3); }
+stmts : {pat_check = FALSE;} stmt {pat_check=TRUE; $$ = $2; }
+ | stmts SEMI {pat_check=FALSE;} stmt {pat_check=TRUE; $$ = lconc($1,$4); }
;
-stmt : /* empty */ { $$ = Lnil; }
- | letdecls { $$ = lsing(mkseqlet($1)); }
- | expL { $$ = lsing(mkdoexp($1,hsplineno)); }
- | {inpat=TRUE;} expLno {inpat=FALSE;} leftexp
- { if ($4 == NULL) {
- expORpat(LEGIT_EXPR,$2);
- $$ = lsing(mkdoexp($2,endlineno));
- } else {
- expORpat(LEGIT_PATT,$2);
- $$ = lsing(mkdobind($2,$4,endlineno));
- }
- }
+stmt : /* empty */ { $$ = Lnil; }
+ | letdecls { $$ = lsing(mkseqlet($1)); }
+ | expL { expORpat(LEGIT_EXPR,$1); $$ = lsing(mkdoexp($1,hsplineno)); }
+ | expLno {pat_check=TRUE;} leftexp
+ { if ($3 == NULL) {
+ expORpat(LEGIT_EXPR,$1);
+ $$ = lsing(mkdoexp($1,endlineno));
+ } else {
+ expORpat(LEGIT_PATT,$1);
+ $$ = lsing(mkdobind($1,$3,endlineno));
+ }
+ }
;
+
leftexp : LARROW exp { $$ = $2; }
| /* empty */ { $$ = NULL; }
;
gcon : qcon
- | OBRACK CBRACK { $$ = creategid(-1); }
- | OPAREN CPAREN { $$ = creategid(0); }
+ | OBRACK CBRACK { $$ = creategid(NILGID); }
+ | OPAREN CPAREN { $$ = creategid(UNITGID); }
| OPAREN commas CPAREN { $$ = creategid($2); }
;
gconk : qconk
- | obrackkey CBRACK { $$ = creategid(-1); }
- | oparenkey CPAREN { $$ = creategid(0); }
+ | obrackkey CBRACK { $$ = creategid(NILGID); }
+ | oparenkey CPAREN { $$ = creategid(UNITGID); }
| oparenkey commas CPAREN { $$ = creategid($2); }
;
defaultkey: DEFAULT { setstartlineno(); }
;
+foreignkey: FOREIGN { setstartlineno(); }
+ ;
+
classkey: CLASS { setstartlineno();
if(etags)
#if 1/*etags*/
FN = NULL; SAMEFN = 0; PREVPATT = NULL;
hsendindent();
}
- ;
+ ;
%%
* *
**********************************************************************/
+
void
checkinpat()
{
- if(!inpat)
+ if(pat_check)
hsperror("pattern syntax used in expression");
}
-
/* The parser calls "hsperror" when it sees a
`report this and die' error. It sets the stage
and calls "yyerror".
/* 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 ) {
+ if ( expect_ccurly && ! error_and_I_mean_it ) {
/*NOTHING*/;
} else {
projects / ghc-hetmet.git / blobdiff