1 /**************************************************************************
4 * Author: Maria M. Gutierrez *
5 * Modified by: Kevin Hammond *
6 * Last date revised: December 13 1991. KH. *
7 * Modification: Haskell 1.1 Syntax. *
10 * Description: This file contains the LALR(1) grammar for Haskell. *
12 * Entry Point: module *
14 * Problems: None known. *
17 * LALR(1) Syntax for Haskell 1.2 *
19 **************************************************************************/
31 #include "constants.h"
34 /**********************************************************************
37 * Imported Variables and Functions *
40 **********************************************************************/
42 static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
45 extern char *input_filename;
46 static char *the_module_name;
47 static maybe module_exports;
50 extern list reverse_list();
53 /* For FN, PREVPATT and SAMEFN macros */
55 extern BOOLEAN samefn[];
56 extern tree prevpatt[];
57 extern short icontexts;
60 extern int hsplineno, hspcolno;
61 extern int modulelineno;
62 extern int startlineno;
65 /**********************************************************************
68 * Fixity and Precedence Declarations *
71 **********************************************************************/
73 static int Fixity = 0, Precedence = 0;
75 char *ineg PROTO((char *));
77 long source_version = 0;
78 BOOLEAN pat_check=TRUE;
102 /**********************************************************************
105 * These are lexemes. *
108 **********************************************************************/
111 %token VARID CONID QVARID QCONID
112 VARSYM CONSYM QVARSYM QCONSYM
114 %token INTEGER FLOAT CHAR STRING
115 CHARPRIM STRINGPRIM INTPRIM FLOATPRIM
120 /**********************************************************************
126 **********************************************************************/
128 %token OCURLY CCURLY VCCURLY
129 %token COMMA SEMI OBRACK CBRACK
130 %token WILDCARD BQUOTE OPAREN CPAREN
133 /**********************************************************************
136 * Reserved Operators *
139 **********************************************************************/
141 %token DOTDOT DCOLON EQUAL LAMBDA
142 %token VBAR RARROW LARROW
143 %token AT LAZY DARROW
146 /**********************************************************************
149 * Reserved Identifiers *
152 **********************************************************************/
154 %token CASE CLASS DATA
155 %token DEFAULT DERIVING DO
156 %token ELSE IF IMPORT
157 %token IN INFIX INFIXL
158 %token INFIXR INSTANCE LET
159 %token MODULE NEWTYPE OF
160 %token THEN TYPE WHERE
163 %token CCALL CCALL_GC CASM CASM_GC
164 %token EXPORT UNSAFE STDCALL C_CALL LABEL
165 %token PASCAL FASTCALL FOREIGN DYNAMIC
167 /**********************************************************************
170 * Special symbols/identifiers which need to be recognised *
173 **********************************************************************/
175 %token MINUS BANG PLUS
176 %token AS HIDING QUALIFIED
179 /**********************************************************************
182 * Special Symbols for the Lexer *
185 **********************************************************************/
187 %token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
188 %token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
190 %token SOURCE_UPRAGMA
192 /**********************************************************************
195 * Precedences of the various tokens *
198 **********************************************************************/
203 SCC CASM CCALL CASM_GC CCALL_GC
205 %left VARSYM CONSYM QVARSYM QCONSYM
206 MINUS BQUOTE BANG DARROW PLUS
212 %left OCURLY OBRACK OPAREN
218 /**********************************************************************
221 * Type Declarations *
224 **********************************************************************/
227 %type <ulist> caserest alts alt quals
229 rbinds rbinds1 rpats rpats1 list_exps list_rest
231 constrs constr1 fields
234 pats simple_context simple_context_list
237 impdecls maybeimpdecls impdecl
238 maybefixes fixes fix ops
243 %type <umaybe> maybeexports impspec deriving
246 %type <uliteral> lit_constant
248 %type <utree> exp oexp dexp kexp fexp aexp rbind texps
249 expL oexpL kexpL expLno oexpLno dexpLno kexpLno
250 vallhs funlhs qual leftexp
251 pat cpat bpat apat apatc conpat rpat
252 patk bpatk apatck conpatk
255 %type <uid> MINUS PLUS DARROW AS LAZY
256 VARID CONID VARSYM CONSYM
257 var con varop conop op
258 vark varid varsym varsym_nominus
261 %type <uqid> QVARID QCONID QVARSYM QCONSYM
262 qvarid qconid qvarsym qconsym
263 qvar qcon qvarop qconop qop
264 qvark qconk qtycon qtycls
265 gcon gconk gtycon itycon qop1 qvarop1
268 %type <ubinding> topdecl topdecls letdecls
269 typed datad newtd classd instd defaultd foreignd
270 decl decls valdef instdef instdefs
271 maybe_where cbody rinst type_and_maybe_id
273 %type <upbinding> valrhs1 altrest
275 %type <uttype> ctype sigtype sigarrowtype type atype bigatype btype
276 bbtype batype bxtype wierd_atype
277 simple_con_app simple_con_app1 tyvar contype inst_type
279 %type <uconstr> constr constr_after_context field
281 %type <ustring> FLOAT INTEGER INTPRIM
282 FLOATPRIM DOUBLEPRIM CLITLIT
284 %type <uhstring> STRING STRINGPRIM CHAR CHARPRIM
286 %type <uentid> export import
288 %type <ulong> commas importkey get_line_no
291 /**********************************************************************
294 * Start Symbol for the Parser *
297 **********************************************************************/
302 module : modulekey modid maybeexports
304 modulelineno = startlineno;
305 the_module_name = $2;
311 the_module_name = install_literal("Main");
312 module_exports = mknothing();
317 body : ocurly { setstartlineno(); } interface_pragma orestm
318 | vocurly interface_pragma vrestm
321 interface_pragma : /* empty */
322 | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
324 source_version = atoi($2);
328 orestm : maybeimpdecls maybefixes topdecls ccurly
330 root = mkhmodule(the_module_name,$1,module_exports,
331 $2,$3,source_version,modulelineno);
335 root = mkhmodule(the_module_name,$1,module_exports,
336 Lnil,mknullbind(),source_version,modulelineno);
339 vrestm : maybeimpdecls maybefixes topdecls vccurly
341 root = mkhmodule(the_module_name,$1,module_exports,
342 $2,$3,source_version,modulelineno);
346 root = mkhmodule(the_module_name,$1,module_exports,
347 Lnil,mknullbind(),source_version,modulelineno);
350 maybeexports : /* empty */ { $$ = mknothing(); }
351 | OPAREN export_list CPAREN { $$ = mkjust($2); }
352 | OPAREN export_list COMMA CPAREN { $$ = mkjust($2); }
356 export { $$ = lsing($1); }
357 | export_list COMMA export { $$ = lapp($1, $3); }
360 export : qvar { $$ = mkentid($1); }
361 | gtycon { $$ = mkenttype($1); }
362 | gtycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
363 | gtycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil); }
364 | gtycon OPAREN enames CPAREN { $$ = mkenttypenamed($1,$3); }
365 | MODULE modid { $$ = mkentmod($2); }
368 enames : ename { $$ = lsing($1); }
369 | enames COMMA ename { $$ = lapp($1,$3); }
376 maybeimpdecls : /* empty */ { $$ = Lnil; }
377 | impdecls SEMI { $$ = $1; }
380 impdecls: impdecl { $$ = $1; }
381 | impdecls SEMI impdecl { $$ = lconc($1,$3); }
385 impdecl : importkey modid impspec
386 { $$ = lsing(mkimport($2,0,mknothing(),$3,$1,startlineno)); }
387 | importkey QUALIFIED modid impspec
388 { $$ = lsing(mkimport($3,1,mknothing(),$4,$1,startlineno)); }
389 | importkey QUALIFIED modid AS modid impspec
390 { $$ = lsing(mkimport($3,1,mkjust($5),$6,$1,startlineno)); }
391 | importkey modid AS modid impspec
392 { $$ = lsing(mkimport($3,1,mkjust($4),$5,$1,startlineno)); }
395 impspec : /* empty */ { $$ = mknothing(); }
396 | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); }
397 | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); }
398 | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); }
399 | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); }
400 | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); }
404 import { $$ = lsing($1); }
405 | import_list COMMA import { $$ = lapp($1, $3); }
408 import : var { $$ = mkentid(mknoqual($1)); }
409 | itycon { $$ = mkenttype($1); }
410 | itycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
411 | itycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil);}
412 | itycon OPAREN inames CPAREN { $$ = mkenttypenamed($1,$3); }
415 itycon : tycon { $$ = mknoqual($1); }
416 | OBRACK CBRACK { $$ = creategid(NILGID); }
417 | OPAREN CPAREN { $$ = creategid(UNITGID); }
418 | OPAREN commas CPAREN { $$ = creategid($2); }
421 inames : iname { $$ = lsing($1); }
422 | inames COMMA iname { $$ = lapp($1,$3); }
424 iname : var { $$ = mknoqual($1); }
425 | con { $$ = mknoqual($1); }
428 /**********************************************************************
431 * Fixes and Decls etc *
434 **********************************************************************/
436 maybefixes: /* empty */ { $$ = Lnil; }
437 | fixes SEMI { $$ = $1; }
440 fixes : fix { $$ = $1; }
441 | fixes SEMI fix { $$ = lconc($1,$3); }
444 fix : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
446 | INFIXR INTEGER { Precedence = checkfixity($2); Fixity = INFIXR; }
448 | INFIX INTEGER { Precedence = checkfixity($2); Fixity = INFIX; }
450 | INFIXL { Fixity = INFIXL; Precedence = 9; }
452 | INFIXR { Fixity = INFIXR; Precedence = 9; }
454 | INFIX { Fixity = INFIX; Precedence = 9; }
458 ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence,startlineno)); }
459 | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence,startlineno)); }
463 | topdecls SEMI topdecl
482 topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; }
483 | datad { $$ = $1; FN = NULL; SAMEFN = 0; }
484 | newtd { $$ = $1; FN = NULL; SAMEFN = 0; }
485 | classd { $$ = $1; FN = NULL; SAMEFN = 0; }
486 | instd { $$ = $1; FN = NULL; SAMEFN = 0; }
487 | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
488 | foreignd { $$ = $1; FN = NULL; SAMEFN = 0; }
492 typed : typekey simple_con_app EQUAL type { $$ = mknbind($2,$4,startlineno); }
496 datad : datakey simple_con_app EQUAL constrs deriving
497 { $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
498 | datakey simple_context DARROW simple_con_app EQUAL constrs deriving
499 { $$ = mktbind($2,$4,$6,$7,startlineno); }
502 newtd : newtypekey simple_con_app EQUAL constr1 deriving
503 { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
504 | newtypekey simple_context DARROW simple_con_app EQUAL constr1 deriving
505 { $$ = mkntbind($2,$4,$6,$7,startlineno); }
508 deriving: /* empty */ { $$ = mknothing(); }
509 | DERIVING dtyclses { $$ = mkjust($2); }
512 classd : classkey btype DARROW simple_con_app1 cbody
513 /* Context can now be more than simple_context */
514 { $$ = mkcbind(type2context($2),$4,$5,startlineno); }
515 | classkey btype cbody
516 /* We have to say btype rather than simple_con_app1, else
517 we get reduce/reduce errs */
518 { check_class_decl_head($2);
519 $$ = mkcbind(Lnil,$2,$3,startlineno); }
522 cbody : /* empty */ { $$ = mknullbind(); }
523 | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; }
524 | WHERE vocurly decls vccurly { checkorder($3); $$ = $3; }
527 instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); }
531 inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */
532 $$ = mkcontext(type2context($1),$3); }
533 | btype { is_context_format( $1, 0 ); /* Check the instance head */
538 rinst : /* empty */ { $$ = mknullbind(); }
539 | WHERE ocurly instdefs ccurly { $$ = $3; }
540 | WHERE vocurly instdefs vccurly { $$ = $3; }
543 defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
544 | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
547 /* FFI primitive declarations - GHC/Hugs specific */
548 foreignd: foreignkey IMPORT callconv ext_name unsafe_flag qvarid DCOLON sigtype { $$ = mkfobind($6,$8,$4,$5,$3,FOREIGN_IMPORT,startlineno); }
549 | foreignkey EXPORT callconv ext_name qvarid DCOLON sigtype { $$ = mkfobind($5,$7,$4,0,$3,FOREIGN_EXPORT,startlineno); }
551 | foreignkey LABEL ext_name qvarid DCOLON sigtype { $$ = mkfobind($4,$6,$3,0,-1,FOREIGN_LABEL,startlineno); }
554 callconv: STDCALL { $$ = CALLCONV_STDCALL; }
555 | C_CALL { $$ = CALLCONV_CCALL; }
556 | PASCAL { $$ = CALLCONV_PASCAL; }
557 | FASTCALL { $$ = CALLCONV_FASTCALL; }
558 /* If you leave out the specification of a calling convention, you'll get C's. */
559 | /*empty*/ { $$ = CALLCONV_CCALL; }
562 ext_name: STRING { $$ = mkjust(lsing($1)); }
563 | STRING STRING { $$ = mkjust(mklcons ($1,lsing($2))); }
564 | DYNAMIC { $$ = mknothing(); }
566 unsafe_flag: UNSAFE { $$ = 1; }
567 | /*empty*/ { $$ = 0; }
586 Note: if there is an iclasop_pragma here, then we must be
587 doing a class-op in an interface -- unless the user is up
588 to real mischief (ugly, but likely to work).
591 decl : qvarsk DCOLON sigtype
592 { $$ = mksbind($1,$3,startlineno);
593 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
596 /* User-specified pragmas come in as "signatures"...
597 They are similar in that they can appear anywhere in the module,
598 and have to be "joined up" with their related entity.
600 Have left out the case specialising to an overloaded type.
601 Let's get real, OK? (WDP)
603 | SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
605 $$ = mkvspec_uprag($2, $4, startlineno);
606 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
609 | SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
611 $$ = mkispec_uprag($3, $4, startlineno);
612 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
615 | SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
617 $$ = mkdspec_uprag($3, $4, startlineno);
618 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
621 | INLINE_UPRAGMA qvark END_UPRAGMA
623 $$ = mkinline_uprag($2, startlineno);
624 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
627 | NOINLINE_UPRAGMA qvark END_UPRAGMA
629 $$ = mknoinline_uprag($2, startlineno);
630 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
633 | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
635 $$ = mkmagicuf_uprag($2, $3, startlineno);
636 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
639 /* end of user-specified pragmas */
642 | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
645 qvarsk : qvark COMMA qvars_list { $$ = mklcons($1,$3); }
646 | qvark { $$ = lsing($1); }
649 qvars_list: qvar { $$ = lsing($1); }
650 | qvars_list COMMA qvar { $$ = lapp($1,$3); }
653 types_and_maybe_ids :
654 type_and_maybe_id { $$ = lsing($1); }
655 | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); }
659 type { $$ = mkvspec_ty_and_id($1,mknothing()); }
660 | type EQUAL qvark { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
663 /**********************************************************************
669 **********************************************************************/
671 /* "DCOLON context => type" vs "DCOLON type" is a problem,
672 because you can't distinguish between
674 foo :: (Baz a, Baz a)
675 bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
677 with one token of lookahead. The HACK is to have "DCOLON ttype"
678 [tuple type] in the first case, then check that it has the right
679 form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
683 /* A sigtype is a rank 2 type; it can have for-alls as function args:
684 f :: All a => (All b => ...) -> Int
686 sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
690 sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); }
691 | btype RARROW sigarrowtype { $$ = mktfun($1,$3); }
695 /* A "big" atype can be a forall-type in brackets. */
696 bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
699 /* 1 S/R conflict at DARROW -> shift */
700 ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); }
704 /* 1 S/R conflict at RARROW -> shift */
705 type : btype RARROW type { $$ = mktfun($1,$3); }
709 btype : btype atype { $$ = mktapp($1,$2); }
713 atype : gtycon { $$ = mktname($1); }
715 | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
716 | OBRACK type CBRACK { $$ = mktllist($2); }
717 | OPAREN type CPAREN { $$ = $2; }
721 | OPAREN RARROW CPAREN { $$ = creategid(ARROWGID); }
722 | OBRACK CBRACK { $$ = creategid(NILGID); }
723 | OPAREN CPAREN { $$ = creategid(UNITGID); }
724 | OPAREN commas CPAREN { $$ = creategid($2); }
727 atypes : atype { $$ = lsing($1); }
728 | atypes atype { $$ = lapp($1,$2); }
731 types : type { $$ = lsing($1); }
732 | types COMMA type { $$ = lapp($1,$3); }
735 commas : COMMA { $$ = 1; }
736 | commas COMMA { $$ = $1 + 1; }
739 /**********************************************************************
742 * Declaration stuff *
745 **********************************************************************/
747 /* C a b c, where a,b,c are type variables */
748 /* C can be a class or tycon */
749 simple_con_app: gtycon { $$ = mktname($1); }
750 | simple_con_app1 { $$ = $1; }
753 simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),$2); }
754 | simple_con_app tyvar { $$ = mktapp($1, $2); }
757 simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
758 | simple_con_app1 { $$ = lsing($1); }
761 simple_context_list: simple_con_app1 { $$ = lsing($1); }
762 | simple_context_list COMMA simple_con_app1 { $$ = lapp($1,$3); }
765 constrs : constr { $$ = lsing($1); }
766 | constrs VBAR constr { $$ = lapp($1,$3); }
769 constr : constr_after_context
770 | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
773 constr_after_context :
775 /* We have to parse the constructor application as a *type*, else we get
776 into terrible ambiguity problems. Consider the difference between
778 data T = S Int Int Int `R` Int
780 data T = S Int Int Int
782 It isn't till we get to the operator that we discover that the "S" is
783 part of a type in the first, but part of a constructor application in the
787 /* Con !Int (Tree a) */
788 contype { qid tyc; list tys;
789 splittyconapp($1, &tyc, &tys);
790 $$ = mkconstrpre(tyc,tys,hsplineno); }
792 /* !Int `Con` Tree a */
793 | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
795 /* (::) (Tree a) Int */
796 | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
798 /* Con { op1 :: Int } */
799 | qtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
800 | OPAREN qconsym CPAREN OCURLY fields CCURLY { $$ = mkconstrrec($2,$5,hsplineno); }
802 /* 1 S/R conflict on OCURLY -> shift */
805 /* contype has to reduce to a btype unless there are !'s, so that
806 we don't get reduce/reduce conflicts with the second production of constr.
807 But as soon as we see a ! we must switch to using bxtype. */
809 contype : btype { $$ = $1; }
810 | bxtype { $$ = $1; }
813 /* S !Int Bool; at least one ! */
814 bxtype : btype wierd_atype { $$ = mktapp($1, $2); }
815 | bxtype batype { $$ = mktapp($1, $2); }
818 bbtype : btype { $$ = $1; }
819 | wierd_atype { $$ = $1; }
822 batype : atype { $$ = $1; }
823 | wierd_atype { $$ = $1; }
826 /* A wierd atype is one that isn't a regular atype;
827 it starts with a "!", or with a forall. */
828 wierd_atype : BANG bigatype { $$ = mktbang( $2 ); }
829 | BANG atype { $$ = mktbang( $2 ); }
833 batypes : { $$ = Lnil; }
834 | batypes batype { $$ = lapp($1,$2); }
838 fields : field { $$ = lsing($1); }
839 | fields COMMA field { $$ = lapp($1,$3); }
842 field : qvars_list DCOLON ctype { $$ = mkfield($1,$3); }
843 | qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); }
844 | qvars_list DCOLON BANG bigatype { $$ = mkfield($1,mktbang($4)); }
847 constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
851 dtyclses: OPAREN dtycls_list CPAREN { $$ = $2; }
852 | OPAREN CPAREN { $$ = Lnil; }
853 | qtycls { $$ = lsing($1); }
856 dtycls_list: qtycls { $$ = lsing($1); }
857 | dtycls_list COMMA qtycls { $$ = lapp($1,$3); }
860 instdefs : /* empty */ { $$ = mknullbind(); }
861 | instdef { $$ = $1; }
862 | instdefs SEMI instdef
874 /* instdef: same as valdef, except certain user-pragmas may appear */
876 SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
878 $$ = mkvspec_uprag($2, $4, startlineno);
879 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
882 | INLINE_UPRAGMA qvark END_UPRAGMA
884 $$ = mkinline_uprag($2, startlineno);
885 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
888 | NOINLINE_UPRAGMA qvark END_UPRAGMA
890 $$ = mknoinline_uprag($2, startlineno);
891 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
894 | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
896 $$ = mkmagicuf_uprag($2, $3, startlineno);
897 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
907 tree fn = function($1);
910 if(ttree(fn) == ident)
912 qid fun_id = gident((struct Sident *) fn);
917 else if (ttree(fn) == infixap)
919 qid fun_id = ginffun((struct Sinfixap *) fn);
926 printf("%u\n",startlineno);
928 fprintf(stderr,"%u\tvaldef\n",startlineno);
935 if ( lhs_is_patt($1) )
937 $$ = mkpbind($4, $3);
942 $$ = mkfbind($4, $3);
948 get_line_no : { $$ = startlineno; }
951 vallhs : patk { $$ = $1; }
952 | patk qvarop pat { $$ = mkinfixap($2,$1,$3); }
953 | funlhs { $$ = $1; }
956 funlhs : qvark apat { $$ = mkap(mkident($1),$2); }
957 | funlhs apat { $$ = mkap($1,$2); }
961 valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); }
964 valrhs1 : gdrhs { $$ = mkpguards($1); }
965 | EQUAL exp { $$ = mkpnoguards($2); }
968 gdrhs : gd EQUAL exp { $$ = lsing(mkpgdexp($1,$3)); }
969 | gd EQUAL exp gdrhs { $$ = mklcons(mkpgdexp($1,$3),$4); }
973 WHERE ocurly decls ccurly { $$ = $3; }
974 | WHERE vocurly decls vccurly { $$ = $3; }
975 /* A where containing no decls is OK */
976 | WHERE SEMI { $$ = mknullbind(); }
977 | /* empty */ { $$ = mknullbind(); }
980 gd : VBAR quals { $$ = $2; }
984 /**********************************************************************
990 **********************************************************************/
992 exp : oexp DCOLON ctype { $$ = mkrestr($1,$3); }
997 Operators must be left-associative at the same precedence for
998 precedence parsing to work.
1000 /* 8 S/R conflicts on qop -> shift */
1001 oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
1006 This comes here because of the funny precedence rules concerning
1009 dexp : MINUS kexp { $$ = mknegate($2); }
1014 We need to factor out a leading let expression so we can set
1015 pat_check=FALSE when parsing (non let) expressions inside stmts and quals
1017 expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
1020 oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
1023 dexpLno : MINUS kexp { $$ = mknegate($2); }
1027 expL : oexpL DCOLON ctype { $$ = mkrestr($1,$3); }
1030 oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
1035 let/if/lambda/case have higher precedence than infix operators.
1042 /* kexpL = a let expression */
1043 kexpL : letdecls IN exp { $$ = mklet($1,$3); }
1046 /* kexpLno = any other expression more tightly binding than operator application */
1048 { hsincindent(); /* push new context for FN = NULL; */
1049 FN = NULL; /* not actually concerned about indenting */
1050 $<ulong>$ = hsplineno; /* remember current line number */
1055 RARROW exp /* lambda abstraction */
1057 $$ = mklambda($3, $6, $<ulong>2);
1061 | IF {$<ulong>$ = hsplineno;}
1062 exp THEN exp ELSE exp { $$ = mkife($3,$5,$7,$<ulong>2); }
1064 /* Case Expression */
1065 | CASE {$<ulong>$ = hsplineno;}
1066 exp OF caserest { $$ = mkcasee($3,$5,$<ulong>2); }
1069 | DO {$<ulong>$ = hsplineno;}
1070 dorest { $$ = mkdoe($3,$<ulong>2); }
1072 /* CCALL/CASM Expression */
1073 | CCALL ccallid cexps { $$ = mkccall($2,install_literal("n"),$3); }
1074 | CCALL ccallid { $$ = mkccall($2,install_literal("n"),Lnil); }
1075 | CCALL_GC ccallid cexps { $$ = mkccall($2,install_literal("p"),$3); }
1076 | CCALL_GC ccallid { $$ = mkccall($2,install_literal("p"),Lnil); }
1077 | CASM CLITLIT cexps { $$ = mkccall($2,install_literal("N"),$3); }
1078 | CASM CLITLIT { $$ = mkccall($2,install_literal("N"),Lnil); }
1079 | CASM_GC CLITLIT cexps { $$ = mkccall($2,install_literal("P"),$3); }
1080 | CASM_GC CLITLIT { $$ = mkccall($2,install_literal("P"),Lnil); }
1082 /* SCC Expression */
1087 "\"%s\":%d: _scc_ (`set [profiling] cost centre') ignored\n",
1088 input_filename, hsplineno);
1090 $$ = mkpar($3); /* Note the mkpar(). If we don't have it, then
1091 (x >> _scc_ y >> z) parses as (x >> (y >> z)),
1092 right associated. But the precedence reorganiser expects
1093 the parser to *left* associate all operators unless there
1094 are explicit parens. The _scc_ acts like an explicit paren,
1095 so if we omit it we'd better add explicit parens instead. */
1103 fexp : fexp aexp { $$ = mkap($1,$2); }
1107 /* simple expressions */
1108 aexp : qvar { $$ = mkident($1); }
1109 | gcon { $$ = mkident($1); }
1110 | lit_constant { $$ = mklit($1); }
1111 | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
1112 | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
1113 | OBRACK list_exps CBRACK { $$ = mkllist($2); }
1114 | OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple)
1115 $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1117 $$ = mktuple(ldub($2, $4)); }
1119 /* only in expressions ... */
1120 | aexp OCURLY rbinds1 CCURLY { $$ = mkrupdate($1,$3); }
1121 | OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); }
1122 | OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1123 | OBRACK exp COMMA exp DOTDOT CBRACK { $$ = mkeenum($2,mkjust($4),mknothing()); }
1124 | OBRACK exp DOTDOT exp CBRACK { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1125 | OBRACK exp DOTDOT CBRACK { $$ = mkeenum($2,mknothing(),mknothing()); }
1126 | OPAREN oexp qop CPAREN { $$ = mklsection($2,$3); }
1127 | OPAREN qop1 oexp CPAREN { $$ = mkrsection($2,$3); }
1129 /* only in patterns ... */
1130 /* these add 2 S/R conflict with with aexp . OCURLY rbinds CCURLY */
1131 | qvar AT aexp { checkinpat(); $$ = mkas($1,$3); }
1132 | LAZY aexp { checkinpat(); $$ = mklazyp($2); }
1133 | WILDCARD { checkinpat(); $$ = mkwildp(); }
1136 /* ccall arguments */
1137 cexps : cexps aexp { $$ = lapp($1,$2); }
1138 | aexp { $$ = lsing($1); }
1141 caserest: ocurly alts ccurly { $$ = $2; }
1142 | vocurly alts vccurly { $$ = $2; }
1144 dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; }
1145 | vocurly stmts vccurly { checkdostmts($2); $$ = $2; }
1148 rbinds : /* empty */ { $$ = Lnil; }
1152 rbinds1 : rbind { $$ = lsing($1); }
1153 | rbinds1 COMMA rbind { $$ = lapp($1,$3); }
1156 rbind : qvar { $$ = mkrbind($1,mknothing()); }
1157 | qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
1160 texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in tuple */
1162 { if (ttree($3) == tuple)
1163 $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1164 else if (ttree($3) == par)
1165 $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1167 hsperror("hsparser:texps: panic");
1169 /* right recursion? WDP */
1173 exp { $$ = lsing($1); }
1174 | exp COMMA exp { $$ = mklcons( $1, lsing($3) ); }
1175 | exp COMMA exp COMMA list_rest { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); }
1178 /* Use left recusion for list_rest, because we sometimes get programs with
1179 very long explicit lists. */
1180 list_rest : exp { $$ = lsing($1); }
1181 | list_rest COMMA exp { $$ = mklcons( $3, $1 ); }
1185 exp { $$ = lsing($1); }
1186 | exp COMMA list_exps { $$ = mklcons($1, $3); }
1188 /* right recursion? (WDP)
1190 It has to be this way, though, otherwise you
1191 may do the wrong thing to distinguish between...
1193 [ e1 , e2 .. ] -- an enumeration ...
1194 [ e1 , e2 , e3 ] -- a list
1196 (In fact, if you change the grammar and throw yacc/bison
1197 at it, it *will* do the wrong thing [WDP 94/06])
1200 letdecls: LET { pat_check = TRUE; } ocurly decls ccurly { $$ = $4; }
1201 | LET { pat_check = TRUE; } vocurly decls vccurly { $$ = $4; }
1205 When parsing patterns inside do stmt blocks or quals, we have
1206 to tentatively parse them as expressions, since we don't know at
1207 the time of parsing `p' whether it will be part of "p <- e" (pat)
1208 or "p" (expr). When we eventually can tell the difference, the parse
1209 of `p' is examined to see if it consitutes a syntactically legal pattern
1212 The expr rule used to parse the pattern/expression do contain
1213 pattern-special productions (e.g., _ , a@pat, etc.), which are
1214 illegal in expressions. Since we don't know whether what
1215 we're parsing is an expression rather than a pattern, we turn off
1216 the check and instead do it later.
1218 The rather clumsy way that this check is turned on/off is there
1219 to work around a Bison feature/shortcoming. Turning the flag
1220 on/off just around the relevant nonterminal by decorating it
1221 with simple semantic actions, e.g.,
1223 {pat_check = FALSE; } expLNo { pat_check = TRUE; }
1225 causes Bison to generate a parser where in one state it either
1226 has to reduce/perform a semantic action ( { pat_check = FALSE; })
1227 or reduce an error (the error production used to implement
1228 vccurly.) Bison picks the semantic action, which it ideally shouldn't.
1229 The work around is to lift out the setting of { pat_check = FALSE; }
1230 and then later reset pat_check. Not pretty.
1235 quals : { pat_check = FALSE;} qual { pat_check = TRUE; $$ = lsing($2); }
1236 | quals COMMA { pat_check = FALSE; } qual { pat_check = TRUE; $$ = lapp($1,$4); }
1239 qual : letdecls { $$ = mkseqlet($1); }
1240 | expL { expORpat(LEGIT_EXPR,$1); $$ = $1; }
1241 | expLno { pat_check = TRUE; } leftexp
1243 expORpat(LEGIT_EXPR,$1);
1246 expORpat(LEGIT_PATT,$1);
1252 alts : alt { $$ = $1; }
1253 | alts SEMI alt { $$ = lconc($1,$3); }
1256 alt : pat { PREVPATT = $1; } altrest { $$ = lsing($3); PREVPATT = NULL; }
1257 | /* empty */ { $$ = Lnil; }
1260 altrest : gdpat maybe_where { $$ = createpat(mkpguards($1), $2); }
1261 | RARROW exp maybe_where { $$ = createpat(mkpnoguards($2),$3); }
1264 gdpat : gd RARROW exp { $$ = lsing(mkpgdexp($1,$3)); }
1265 | gd RARROW exp gdpat { $$ = mklcons(mkpgdexp($1,$3),$4); }
1268 stmts : {pat_check = FALSE;} stmt {pat_check=TRUE; $$ = $2; }
1269 | stmts SEMI {pat_check=FALSE;} stmt {pat_check=TRUE; $$ = lconc($1,$4); }
1272 stmt : /* empty */ { $$ = Lnil; }
1273 | letdecls { $$ = lsing(mkseqlet($1)); }
1274 | expL { expORpat(LEGIT_EXPR,$1); $$ = lsing(mkdoexp($1,hsplineno)); }
1275 | expLno {pat_check=TRUE;} leftexp
1277 expORpat(LEGIT_EXPR,$1);
1278 $$ = lsing(mkdoexp($1,endlineno));
1280 expORpat(LEGIT_PATT,$1);
1281 $$ = lsing(mkdobind($1,$3,endlineno));
1287 leftexp : LARROW exp { $$ = $2; }
1288 | /* empty */ { $$ = NULL; }
1291 /**********************************************************************
1297 **********************************************************************/
1299 pat : qvar PLUS INTEGER { $$ = mkplusp($1, mkinteger($3)); }
1303 cpat : cpat qconop bpat { $$ = mkinfixap($2,$1,$3); }
1309 | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
1310 | MINUS INTEGER { $$ = mknegate(mklit(mkinteger($2))); }
1311 | MINUS FLOAT { $$ = mknegate(mklit(mkfloatr($2))); }
1314 conpat : gcon { $$ = mkident($1); }
1315 | conpat apat { $$ = mkap($1,$2); }
1318 apat : gcon { $$ = mkident($1); }
1319 | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
1323 apatc : qvar { $$ = mkident($1); }
1324 | qvar AT apat { $$ = mkas($1,$3); }
1325 | lit_constant { $$ = mklit($1); }
1326 | WILDCARD { $$ = mkwildp(); }
1327 | OPAREN pat CPAREN { $$ = mkpar($2); }
1328 | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
1329 | OBRACK pats CBRACK { $$ = mkllist($2); }
1330 | LAZY apat { $$ = mklazyp($2); }
1334 INTEGER { $$ = mkinteger($1); }
1335 | FLOAT { $$ = mkfloatr($1); }
1336 | CHAR { $$ = mkcharr($1); }
1337 | STRING { $$ = mkstring($1); }
1338 | CHARPRIM { $$ = mkcharprim($1); }
1339 | STRINGPRIM { $$ = mkstringprim($1); }
1340 | INTPRIM { $$ = mkintprim($1); }
1341 | FLOATPRIM { $$ = mkfloatprim($1); }
1342 | DOUBLEPRIM { $$ = mkdoubleprim($1); }
1343 | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1); }
1346 lampats : apat lampats { $$ = mklcons($1,$2); }
1347 | apat { $$ = lsing($1); }
1348 /* right recursion? (WDP) */
1351 pats : pat COMMA pats { $$ = mklcons($1, $3); }
1352 | pat { $$ = lsing($1); }
1353 /* right recursion? (WDP) */
1356 rpats : /* empty */ { $$ = Lnil; }
1360 rpats1 : rpat { $$ = lsing($1); }
1361 | rpats1 COMMA rpat { $$ = lapp($1,$3); }
1364 rpat : qvar { $$ = mkrbind($1,mknothing()); }
1365 | qvar EQUAL pat { $$ = mkrbind($1,mkjust($3)); }
1369 patk : patk qconop bpat { $$ = mkinfixap($2,$1,$3); }
1375 | qconk OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
1376 | minuskey INTEGER { $$ = mknegate(mklit(mkinteger($2))); }
1377 | minuskey FLOAT { $$ = mknegate(mklit(mkfloatr($2))); }
1380 conpatk : gconk { $$ = mkident($1); }
1381 | conpatk apat { $$ = mkap($1,$2); }
1384 apatck : qvark { $$ = mkident($1); }
1385 | qvark AT apat { $$ = mkas($1,$3); }
1386 | lit_constant { $$ = mklit($1); setstartlineno(); }
1387 | WILDCARD { $$ = mkwildp(); setstartlineno(); }
1388 | oparenkey pat CPAREN { $$ = mkpar($2); }
1389 | oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
1390 | obrackkey pats CBRACK { $$ = mkllist($2); }
1391 | lazykey apat { $$ = mklazyp($2); }
1396 | OBRACK CBRACK { $$ = creategid(NILGID); }
1397 | OPAREN CPAREN { $$ = creategid(UNITGID); }
1398 | OPAREN commas CPAREN { $$ = creategid($2); }
1402 | obrackkey CBRACK { $$ = creategid(NILGID); }
1403 | oparenkey CPAREN { $$ = creategid(UNITGID); }
1404 | oparenkey commas CPAREN { $$ = creategid($2); }
1407 /**********************************************************************
1410 * Keywords which record the line start *
1413 **********************************************************************/
1415 importkey: IMPORT { setstartlineno(); $$ = 0; }
1416 | IMPORT SOURCE_UPRAGMA { setstartlineno(); $$ = 1; }
1419 datakey : DATA { setstartlineno();
1422 printf("%u\n",startlineno);
1424 fprintf(stderr,"%u\tdata\n",startlineno);
1429 typekey : TYPE { setstartlineno();
1432 printf("%u\n",startlineno);
1434 fprintf(stderr,"%u\ttype\n",startlineno);
1439 newtypekey : NEWTYPE { setstartlineno();
1442 printf("%u\n",startlineno);
1444 fprintf(stderr,"%u\tnewtype\n",startlineno);
1449 instkey : INSTANCE { setstartlineno();
1452 printf("%u\n",startlineno);
1455 fprintf(stderr,"%u\tinstance\n",startlineno);
1460 defaultkey: DEFAULT { setstartlineno(); }
1463 foreignkey: FOREIGN { setstartlineno(); }
1466 classkey: CLASS { setstartlineno();
1469 printf("%u\n",startlineno);
1471 fprintf(stderr,"%u\tclass\n",startlineno);
1476 modulekey: MODULE { setstartlineno();
1479 printf("%u\n",startlineno);
1481 fprintf(stderr,"%u\tmodule\n",startlineno);
1486 oparenkey: OPAREN { setstartlineno(); }
1489 obrackkey: OBRACK { setstartlineno(); }
1492 lazykey : LAZY { setstartlineno(); }
1495 minuskey: MINUS { setstartlineno(); }
1499 /**********************************************************************
1502 * Basic qualified/unqualified ids/ops *
1505 **********************************************************************/
1508 | OPAREN qvarsym CPAREN { $$ = $2; }
1511 | OPAREN qconsym CPAREN { $$ = $2; }
1514 | BQUOTE qvarid BQUOTE { $$ = $2; }
1517 | BQUOTE qconid BQUOTE { $$ = $2; }
1523 /* Non "-" op, used in right sections */
1528 /* Non "-" varop, used in right sections */
1530 | varsym_nominus { $$ = mknoqual($1); }
1531 | BQUOTE qvarid BQUOTE { $$ = $2; }
1536 | OPAREN varsym CPAREN { $$ = $2; }
1538 con : tycon /* using tycon removes conflicts */
1539 | OPAREN CONSYM CPAREN { $$ = $2; }
1542 | BQUOTE varid BQUOTE { $$ = $2; }
1545 | BQUOTE CONID BQUOTE { $$ = $2; }
1551 qvark : qvarid { setstartlineno(); $$ = $1; }
1552 | oparenkey qvarsym CPAREN { $$ = $2; }
1554 qconk : qconid { setstartlineno(); $$ = $1; }
1555 | oparenkey qconsym CPAREN { $$ = $2; }
1557 vark : varid { setstartlineno(); $$ = $1; }
1558 | oparenkey varsym CPAREN { $$ = $2; }
1562 | varid { $$ = mknoqual($1); }
1565 | varsym { $$ = mknoqual($1); }
1568 | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
1571 | CONSYM { $$ = mknoqual($1); }
1574 | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
1577 | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
1580 varsym : varsym_nominus
1581 | MINUS { $$ = install_literal("-"); }
1584 /* PLUS, BANG are valid varsyms */
1585 varsym_nominus : VARSYM
1586 | PLUS { $$ = install_literal("+"); }
1587 | BANG { $$ = install_literal("!"); }
1590 /* AS HIDING QUALIFIED are valid varids */
1592 | AS { $$ = install_literal("as"); }
1593 | HIDING { $$ = install_literal("hiding"); }
1594 | QUALIFIED { $$ = install_literal("qualified"); }
1602 tyvar : varid { $$ = mknamedtvar(mknoqual($1)); }
1610 tyvar_list: tyvar { $$ = lsing($1); }
1611 | tyvar_list COMMA tyvar { $$ = lapp($1,$3); }
1615 /**********************************************************************
1618 * Stuff to do with layout *
1621 **********************************************************************/
1623 ocurly : layout OCURLY { hsincindent(); }
1625 vocurly : layout { hssetindent(); }
1628 layout : { hsindentoff(); }
1634 FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1639 vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; }
1645 FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1651 FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1658 /**********************************************************************
1660 * Error Processing and Reporting *
1662 * (This stuff is here in case we want to use Yacc macros and such.) *
1664 **********************************************************************/
1671 hsperror("pattern syntax used in expression");
1674 /* The parser calls "hsperror" when it sees a
1675 `report this and die' error. It sets the stage
1676 and calls "yyerror".
1678 There should be no direct calls in the parser to
1679 "yyerror", except for the one from "hsperror". Thus,
1680 the only other calls will be from the error productions
1681 introduced by yacc/bison/whatever.
1683 We need to be able to recognise the from-error-production
1684 case, because we sometimes want to say, "Oh, never mind",
1685 because the layout rule kicks into action and may save
1689 static BOOLEAN error_and_I_mean_it = FALSE;
1695 error_and_I_mean_it = TRUE;
1699 extern char *yytext;
1706 /* We want to be able to distinguish 'error'-raised yyerrors
1707 from yyerrors explicitly coded by the parser hacker.
1709 if ( expect_ccurly && ! error_and_I_mean_it ) {
1713 fprintf(stderr, "%s:%d:%d: %s on input: ",
1714 input_filename, hsplineno, hspcolno + 1, s);
1716 if (yyleng == 1 && *yytext == '\0')
1717 fprintf(stderr, "<EOF>");
1721 format_string(stderr, (unsigned char *) yytext, yyleng);
1724 fputc('\n', stderr);
1726 /* a common problem */
1727 if (strcmp(yytext, "#") == 0)
1728 fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1735 format_string(fp, s, len)
1742 case '\0': fputs("\\NUL", fp); break;
1743 case '\007': fputs("\\a", fp); break;
1744 case '\010': fputs("\\b", fp); break;
1745 case '\011': fputs("\\t", fp); break;
1746 case '\012': fputs("\\n", fp); break;
1747 case '\013': fputs("\\v", fp); break;
1748 case '\014': fputs("\\f", fp); break;
1749 case '\015': fputs("\\r", fp); break;
1750 case '\033': fputs("\\ESC", fp); break;
1751 case '\034': fputs("\\FS", fp); break;
1752 case '\035': fputs("\\GS", fp); break;
1753 case '\036': fputs("\\RS", fp); break;
1754 case '\037': fputs("\\US", fp); break;
1755 case '\177': fputs("\\DEL", fp); break;
1760 fprintf(fp, "\\^%c", *s + '@');