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
166 /**********************************************************************
169 * Special symbols/identifiers which need to be recognised *
172 **********************************************************************/
174 %token MINUS BANG PLUS
175 %token AS HIDING QUALIFIED
178 /**********************************************************************
181 * Special Symbols for the Lexer *
184 **********************************************************************/
186 %token INTERFACE_UPRAGMA SPECIALISE_UPRAGMA
187 %token INLINE_UPRAGMA NOINLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
189 %token SOURCE_UPRAGMA
191 /**********************************************************************
194 * Precedences of the various tokens *
197 **********************************************************************/
202 SCC CASM CCALL CASM_GC CCALL_GC
204 %left VARSYM CONSYM QVARSYM QCONSYM
205 MINUS BQUOTE BANG DARROW PLUS
211 %left OCURLY OBRACK OPAREN
217 /**********************************************************************
220 * Type Declarations *
223 **********************************************************************/
226 %type <ulist> caserest alts alt quals
228 rbinds rbinds1 rpats rpats1 list_exps list_rest
230 constrs constr1 fields
233 pats simple_context simple_context_list
236 impdecls maybeimpdecls impdecl
237 maybefixes fixes fix ops
242 %type <umaybe> maybeexports impspec deriving
244 %type <uliteral> lit_constant
246 %type <utree> exp oexp dexp kexp fexp aexp rbind texps
247 expL oexpL kexpL expLno oexpLno dexpLno kexpLno
248 vallhs funlhs qual leftexp
249 pat cpat bpat apat apatc conpat rpat
250 patk bpatk apatck conpatk
253 %type <uid> MINUS PLUS DARROW AS LAZY
254 VARID CONID VARSYM CONSYM
255 var con varop conop op
256 vark varid varsym varsym_nominus
259 %type <uqid> QVARID QCONID QVARSYM QCONSYM
260 qvarid qconid qvarsym qconsym
261 qvar qcon qvarop qconop qop
262 qvark qconk qtycon qtycls
263 gcon gconk gtycon itycon qop1 qvarop1
266 %type <ubinding> topdecl topdecls letdecls
267 typed datad newtd classd instd defaultd
268 decl decls valdef instdef instdefs
269 maybe_where cbody rinst type_and_maybe_id
271 %type <upbinding> valrhs1 altrest
273 %type <uttype> ctype sigtype sigarrowtype type atype bigatype btype
274 bbtype batype bxtype wierd_atype
275 simple_con_app simple_con_app1 tyvar contype inst_type
277 %type <uconstr> constr constr_after_context field
279 %type <ustring> FLOAT INTEGER INTPRIM
280 FLOATPRIM DOUBLEPRIM CLITLIT
282 %type <uhstring> STRING STRINGPRIM CHAR CHARPRIM
284 %type <uentid> export import
286 %type <ulong> commas importkey get_line_no
288 /**********************************************************************
291 * Start Symbol for the Parser *
294 **********************************************************************/
299 module : modulekey modid maybeexports
301 modulelineno = startlineno;
302 the_module_name = $2;
308 the_module_name = install_literal("Main");
309 module_exports = mknothing();
314 body : ocurly { setstartlineno(); } interface_pragma orestm
315 | vocurly interface_pragma vrestm
318 interface_pragma : /* empty */
319 | INTERFACE_UPRAGMA INTEGER END_UPRAGMA SEMI
321 source_version = atoi($2);
325 orestm : maybeimpdecls maybefixes topdecls ccurly
327 root = mkhmodule(the_module_name,$1,module_exports,
328 $2,$3,source_version,modulelineno);
332 root = mkhmodule(the_module_name,$1,module_exports,
333 Lnil,mknullbind(),source_version,modulelineno);
336 vrestm : maybeimpdecls maybefixes topdecls vccurly
338 root = mkhmodule(the_module_name,$1,module_exports,
339 $2,$3,source_version,modulelineno);
343 root = mkhmodule(the_module_name,$1,module_exports,
344 Lnil,mknullbind(),source_version,modulelineno);
347 maybeexports : /* empty */ { $$ = mknothing(); }
348 | OPAREN export_list CPAREN { $$ = mkjust($2); }
349 | OPAREN export_list COMMA CPAREN { $$ = mkjust($2); }
353 export { $$ = lsing($1); }
354 | export_list COMMA export { $$ = lapp($1, $3); }
357 export : qvar { $$ = mkentid($1); }
358 | gtycon { $$ = mkenttype($1); }
359 | gtycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
360 | gtycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil); }
361 | gtycon OPAREN enames CPAREN { $$ = mkenttypenamed($1,$3); }
362 | MODULE modid { $$ = mkentmod($2); }
365 enames : ename { $$ = lsing($1); }
366 | enames COMMA ename { $$ = lapp($1,$3); }
373 maybeimpdecls : /* empty */ { $$ = Lnil; }
374 | impdecls SEMI { $$ = $1; }
377 impdecls: impdecl { $$ = $1; }
378 | impdecls SEMI impdecl { $$ = lconc($1,$3); }
382 impdecl : importkey modid impspec
383 { $$ = lsing(mkimport($2,0,mknothing(),$3,$1,startlineno)); }
384 | importkey QUALIFIED modid impspec
385 { $$ = lsing(mkimport($3,1,mknothing(),$4,$1,startlineno)); }
386 | importkey QUALIFIED modid AS modid impspec
387 { $$ = lsing(mkimport($3,1,mkjust($5),$6,$1,startlineno)); }
388 | importkey modid AS modid impspec
389 { $$ = lsing(mkimport($3,1,mkjust($4),$5,$1,startlineno)); }
392 impspec : /* empty */ { $$ = mknothing(); }
393 | OPAREN CPAREN { $$ = mkjust(mkleft(Lnil)); }
394 | OPAREN import_list CPAREN { $$ = mkjust(mkleft($2)); }
395 | OPAREN import_list COMMA CPAREN { $$ = mkjust(mkleft($2)); }
396 | HIDING OPAREN import_list CPAREN { $$ = mkjust(mkright($3)); }
397 | HIDING OPAREN import_list COMMA CPAREN { $$ = mkjust(mkright($3)); }
401 import { $$ = lsing($1); }
402 | import_list COMMA import { $$ = lapp($1, $3); }
405 import : var { $$ = mkentid(mknoqual($1)); }
406 | itycon { $$ = mkenttype($1); }
407 | itycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
408 | itycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil);}
409 | itycon OPAREN inames CPAREN { $$ = mkenttypenamed($1,$3); }
412 itycon : tycon { $$ = mknoqual($1); }
413 | OBRACK CBRACK { $$ = creategid(NILGID); }
414 | OPAREN CPAREN { $$ = creategid(UNITGID); }
415 | OPAREN commas CPAREN { $$ = creategid($2); }
418 inames : iname { $$ = lsing($1); }
419 | inames COMMA iname { $$ = lapp($1,$3); }
421 iname : var { $$ = mknoqual($1); }
422 | con { $$ = mknoqual($1); }
425 /**********************************************************************
428 * Fixes and Decls etc *
431 **********************************************************************/
433 maybefixes: /* empty */ { $$ = Lnil; }
434 | fixes SEMI { $$ = $1; }
437 fixes : fix { $$ = $1; }
438 | fixes SEMI fix { $$ = lconc($1,$3); }
441 fix : INFIXL INTEGER { Precedence = checkfixity($2); Fixity = INFIXL; }
443 | INFIXR INTEGER { Precedence = checkfixity($2); Fixity = INFIXR; }
445 | INFIX INTEGER { Precedence = checkfixity($2); Fixity = INFIX; }
447 | INFIXL { Fixity = INFIXL; Precedence = 9; }
449 | INFIXR { Fixity = INFIXR; Precedence = 9; }
451 | INFIX { Fixity = INFIX; Precedence = 9; }
455 ops : op { $$ = lsing(mkfixop(mknoqual($1),infixint(Fixity),Precedence,startlineno)); }
456 | ops COMMA op { $$ = lapp($1,mkfixop(mknoqual($3),infixint(Fixity),Precedence,startlineno)); }
460 | topdecls SEMI topdecl
479 topdecl : typed { $$ = $1; FN = NULL; SAMEFN = 0; }
480 | datad { $$ = $1; FN = NULL; SAMEFN = 0; }
481 | newtd { $$ = $1; FN = NULL; SAMEFN = 0; }
482 | classd { $$ = $1; FN = NULL; SAMEFN = 0; }
483 | instd { $$ = $1; FN = NULL; SAMEFN = 0; }
484 | defaultd { $$ = $1; FN = NULL; SAMEFN = 0; }
488 typed : typekey simple_con_app EQUAL type { $$ = mknbind($2,$4,startlineno); }
492 datad : datakey simple_con_app EQUAL constrs deriving
493 { $$ = mktbind(Lnil,$2,$4,$5,startlineno); }
494 | datakey simple_context DARROW simple_con_app EQUAL constrs deriving
495 { $$ = mktbind($2,$4,$6,$7,startlineno); }
498 newtd : newtypekey simple_con_app EQUAL constr1 deriving
499 { $$ = mkntbind(Lnil,$2,$4,$5,startlineno); }
500 | newtypekey simple_context DARROW simple_con_app EQUAL constr1 deriving
501 { $$ = mkntbind($2,$4,$6,$7,startlineno); }
504 deriving: /* empty */ { $$ = mknothing(); }
505 | DERIVING dtyclses { $$ = mkjust($2); }
508 classd : classkey btype DARROW simple_con_app1 cbody
509 /* Context can now be more than simple_context */
510 { $$ = mkcbind(type2context($2),$4,$5,startlineno); }
511 | classkey btype cbody
512 /* We have to say btype rather than simple_con_app1, else
513 we get reduce/reduce errs */
514 { check_class_decl_head($2);
515 $$ = mkcbind(Lnil,$2,$3,startlineno); }
518 cbody : /* empty */ { $$ = mknullbind(); }
519 | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; }
520 | WHERE vocurly decls vccurly { checkorder($3); $$ = $3; }
523 instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); }
527 inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */
528 $$ = mkcontext(type2context($1),$3); }
529 | btype { is_context_format( $1, 0 ); /* Check the instance head */
534 rinst : /* empty */ { $$ = mknullbind(); }
535 | WHERE ocurly instdefs ccurly { $$ = $3; }
536 | WHERE vocurly instdefs vccurly { $$ = $3; }
539 defaultd: defaultkey OPAREN types CPAREN { $$ = mkdbind($3,startlineno); }
540 | defaultkey OPAREN CPAREN { $$ = mkdbind(Lnil,startlineno); }
557 Note: if there is an iclasop_pragma here, then we must be
558 doing a class-op in an interface -- unless the user is up
559 to real mischief (ugly, but likely to work).
562 decl : qvarsk DCOLON sigtype
563 { $$ = mksbind($1,$3,startlineno);
564 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
567 /* User-specified pragmas come in as "signatures"...
568 They are similar in that they can appear anywhere in the module,
569 and have to be "joined up" with their related entity.
571 Have left out the case specialising to an overloaded type.
572 Let's get real, OK? (WDP)
574 | SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
576 $$ = mkvspec_uprag($2, $4, startlineno);
577 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
580 | SPECIALISE_UPRAGMA INSTANCE gtycon atype END_UPRAGMA
582 $$ = mkispec_uprag($3, $4, startlineno);
583 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
586 | SPECIALISE_UPRAGMA DATA gtycon atypes END_UPRAGMA
588 $$ = mkdspec_uprag($3, $4, startlineno);
589 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
592 | INLINE_UPRAGMA qvark END_UPRAGMA
594 $$ = mkinline_uprag($2, startlineno);
595 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
598 | NOINLINE_UPRAGMA qvark END_UPRAGMA
600 $$ = mknoinline_uprag($2, startlineno);
601 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
604 | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
606 $$ = mkmagicuf_uprag($2, $3, startlineno);
607 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
610 /* end of user-specified pragmas */
613 | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
616 qvarsk : qvark COMMA qvars_list { $$ = mklcons($1,$3); }
617 | qvark { $$ = lsing($1); }
620 qvars_list: qvar { $$ = lsing($1); }
621 | qvars_list COMMA qvar { $$ = lapp($1,$3); }
624 types_and_maybe_ids :
625 type_and_maybe_id { $$ = lsing($1); }
626 | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); }
630 type { $$ = mkvspec_ty_and_id($1,mknothing()); }
631 | type EQUAL qvark { $$ = mkvspec_ty_and_id($1,mkjust($3)); }
634 /**********************************************************************
640 **********************************************************************/
642 /* "DCOLON context => type" vs "DCOLON type" is a problem,
643 because you can't distinguish between
645 foo :: (Baz a, Baz a)
646 bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
648 with one token of lookahead. The HACK is to have "DCOLON ttype"
649 [tuple type] in the first case, then check that it has the right
650 form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
654 /* A sigtype is a rank 2 type; it can have for-alls as function args:
655 f :: All a => (All b => ...) -> Int
657 sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
661 sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); }
662 | btype RARROW sigarrowtype { $$ = mktfun($1,$3); }
666 /* A "big" atype can be a forall-type in brackets. */
667 bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
670 /* 1 S/R conflict at DARROW -> shift */
671 ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); }
675 /* 1 S/R conflict at RARROW -> shift */
676 type : btype RARROW type { $$ = mktfun($1,$3); }
680 btype : btype atype { $$ = mktapp($1,$2); }
684 atype : gtycon { $$ = mktname($1); }
686 | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
687 | OBRACK type CBRACK { $$ = mktllist($2); }
688 | OPAREN type CPAREN { $$ = $2; }
692 | OPAREN RARROW CPAREN { $$ = creategid(ARROWGID); }
693 | OBRACK CBRACK { $$ = creategid(NILGID); }
694 | OPAREN CPAREN { $$ = creategid(UNITGID); }
695 | OPAREN commas CPAREN { $$ = creategid($2); }
698 atypes : atype { $$ = lsing($1); }
699 | atypes atype { $$ = lapp($1,$2); }
702 types : type { $$ = lsing($1); }
703 | types COMMA type { $$ = lapp($1,$3); }
706 commas : COMMA { $$ = 1; }
707 | commas COMMA { $$ = $1 + 1; }
710 /**********************************************************************
713 * Declaration stuff *
716 **********************************************************************/
718 /* C a b c, where a,b,c are type variables */
719 /* C can be a class or tycon */
720 simple_con_app: gtycon { $$ = mktname($1); }
721 | simple_con_app1 { $$ = $1; }
724 simple_con_app1: gtycon tyvar { $$ = mktapp(mktname($1),$2); }
725 | simple_con_app tyvar { $$ = mktapp($1, $2); }
728 simple_context : OPAREN simple_context_list CPAREN { $$ = $2; }
729 | simple_con_app1 { $$ = lsing($1); }
732 simple_context_list: simple_con_app1 { $$ = lsing($1); }
733 | simple_context_list COMMA simple_con_app1 { $$ = lapp($1,$3); }
736 constrs : constr { $$ = lsing($1); }
737 | constrs VBAR constr { $$ = lapp($1,$3); }
740 constr : constr_after_context
741 | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
744 constr_after_context :
746 /* We have to parse the constructor application as a *type*, else we get
747 into terrible ambiguity problems. Consider the difference between
749 data T = S Int Int Int `R` Int
751 data T = S Int Int Int
753 It isn't till we get to the operator that we discover that the "S" is
754 part of a type in the first, but part of a constructor application in the
758 /* Con !Int (Tree a) */
759 contype { qid tyc; list tys;
760 splittyconapp($1, &tyc, &tys);
761 $$ = mkconstrpre(tyc,tys,hsplineno); }
763 /* !Int `Con` Tree a */
764 | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
766 /* (::) (Tree a) Int */
767 | OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
769 /* Con { op1 :: Int } */
770 | qtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
771 | OPAREN qconsym CPAREN OCURLY fields CCURLY { $$ = mkconstrrec($2,$5,hsplineno); }
773 /* 1 S/R conflict on OCURLY -> shift */
776 /* contype has to reduce to a btype unless there are !'s, so that
777 we don't get reduce/reduce conflicts with the second production of constr.
778 But as soon as we see a ! we must switch to using bxtype. */
780 contype : btype { $$ = $1; }
781 | bxtype { $$ = $1; }
784 /* S !Int Bool; at least one ! */
785 bxtype : btype wierd_atype { $$ = mktapp($1, $2); }
786 | bxtype batype { $$ = mktapp($1, $2); }
789 bbtype : btype { $$ = $1; }
790 | wierd_atype { $$ = $1; }
793 batype : atype { $$ = $1; }
794 | wierd_atype { $$ = $1; }
797 /* A wierd atype is one that isn't a regular atype;
798 it starts with a "!", or with a forall. */
799 wierd_atype : BANG bigatype { $$ = mktbang( $2 ); }
800 | BANG atype { $$ = mktbang( $2 ); }
804 batypes : { $$ = Lnil; }
805 | batypes batype { $$ = lapp($1,$2); }
809 fields : field { $$ = lsing($1); }
810 | fields COMMA field { $$ = lapp($1,$3); }
813 field : qvars_list DCOLON ctype { $$ = mkfield($1,$3); }
814 | qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); }
815 | qvars_list DCOLON BANG bigatype { $$ = mkfield($1,mktbang($4)); }
818 constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
822 dtyclses: OPAREN dtycls_list CPAREN { $$ = $2; }
823 | OPAREN CPAREN { $$ = Lnil; }
824 | qtycls { $$ = lsing($1); }
827 dtycls_list: qtycls { $$ = lsing($1); }
828 | dtycls_list COMMA qtycls { $$ = lapp($1,$3); }
831 instdefs : /* empty */ { $$ = mknullbind(); }
832 | instdef { $$ = $1; }
833 | instdefs SEMI instdef
845 /* instdef: same as valdef, except certain user-pragmas may appear */
847 SPECIALISE_UPRAGMA qvark DCOLON types_and_maybe_ids END_UPRAGMA
849 $$ = mkvspec_uprag($2, $4, startlineno);
850 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
853 | INLINE_UPRAGMA qvark END_UPRAGMA
855 $$ = mkinline_uprag($2, startlineno);
856 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
859 | NOINLINE_UPRAGMA qvark END_UPRAGMA
861 $$ = mknoinline_uprag($2, startlineno);
862 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
865 | MAGIC_UNFOLDING_UPRAGMA qvark vark END_UPRAGMA
867 $$ = mkmagicuf_uprag($2, $3, startlineno);
868 PREVPATT = NULL; FN = NULL; SAMEFN = 0;
878 tree fn = function($1);
881 if(ttree(fn) == ident)
883 qid fun_id = gident((struct Sident *) fn);
888 else if (ttree(fn) == infixap)
890 qid fun_id = ginffun((struct Sinfixap *) fn);
897 printf("%u\n",startlineno);
899 fprintf(stderr,"%u\tvaldef\n",startlineno);
906 if ( lhs_is_patt($1) )
908 $$ = mkpbind($4, $3);
913 $$ = mkfbind($4, $3);
919 get_line_no : { $$ = startlineno; }
922 vallhs : patk { $$ = $1; }
923 | patk qvarop pat { $$ = mkinfixap($2,$1,$3); }
924 | funlhs { $$ = $1; }
927 funlhs : qvark apat { $$ = mkap(mkident($1),$2); }
928 | funlhs apat { $$ = mkap($1,$2); }
932 valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); }
935 valrhs1 : gdrhs { $$ = mkpguards($1); }
936 | EQUAL exp { $$ = mkpnoguards($2); }
939 gdrhs : gd EQUAL exp { $$ = lsing(mkpgdexp($1,$3)); }
940 | gd EQUAL exp gdrhs { $$ = mklcons(mkpgdexp($1,$3),$4); }
944 WHERE ocurly decls ccurly { $$ = $3; }
945 | WHERE vocurly decls vccurly { $$ = $3; }
946 /* A where containing no decls is OK */
947 | WHERE SEMI { $$ = mknullbind(); }
948 | /* empty */ { $$ = mknullbind(); }
951 gd : VBAR quals { $$ = $2; }
955 /**********************************************************************
961 **********************************************************************/
963 exp : oexp DCOLON ctype { $$ = mkrestr($1,$3); }
968 Operators must be left-associative at the same precedence for
969 precedence parsing to work.
971 /* 8 S/R conflicts on qop -> shift */
972 oexp : oexp qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
977 This comes here because of the funny precedence rules concerning
980 dexp : MINUS kexp { $$ = mknegate($2); }
985 We need to factor out a leading let expression so we can set
986 pat_check=FALSE when parsing (non let) expressions inside stmts and quals
988 expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); }
991 oexpLno : oexpLno qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
994 dexpLno : MINUS kexp { $$ = mknegate($2); }
998 expL : oexpL DCOLON ctype { $$ = mkrestr($1,$3); }
1001 oexpL : oexpL qop oexp %prec MINUS { $$ = mkinfixap($2,$1,$3); }
1006 let/if/lambda/case have higher precedence than infix operators.
1013 /* kexpL = a let expression */
1014 kexpL : letdecls IN exp { $$ = mklet($1,$3); }
1017 /* kexpLno = any other expression more tightly binding than operator application */
1019 { hsincindent(); /* push new context for FN = NULL; */
1020 FN = NULL; /* not actually concerned about indenting */
1021 $<ulong>$ = hsplineno; /* remember current line number */
1026 RARROW exp /* lambda abstraction */
1028 $$ = mklambda($3, $6, $<ulong>2);
1032 | IF {$<ulong>$ = hsplineno;}
1033 exp THEN exp ELSE exp { $$ = mkife($3,$5,$7,$<ulong>2); }
1035 /* Case Expression */
1036 | CASE {$<ulong>$ = hsplineno;}
1037 exp OF caserest { $$ = mkcasee($3,$5,$<ulong>2); }
1040 | DO {$<ulong>$ = hsplineno;}
1041 dorest { $$ = mkdoe($3,$<ulong>2); }
1043 /* CCALL/CASM Expression */
1044 | CCALL ccallid cexps { $$ = mkccall($2,install_literal("n"),$3); }
1045 | CCALL ccallid { $$ = mkccall($2,install_literal("n"),Lnil); }
1046 | CCALL_GC ccallid cexps { $$ = mkccall($2,install_literal("p"),$3); }
1047 | CCALL_GC ccallid { $$ = mkccall($2,install_literal("p"),Lnil); }
1048 | CASM CLITLIT cexps { $$ = mkccall($2,install_literal("N"),$3); }
1049 | CASM CLITLIT { $$ = mkccall($2,install_literal("N"),Lnil); }
1050 | CASM_GC CLITLIT cexps { $$ = mkccall($2,install_literal("P"),$3); }
1051 | CASM_GC CLITLIT { $$ = mkccall($2,install_literal("P"),Lnil); }
1053 /* SCC Expression */
1058 "\"%s\":%d: _scc_ (`set [profiling] cost centre') ignored\n",
1059 input_filename, hsplineno);
1061 $$ = mkpar($3); /* Note the mkpar(). If we don't have it, then
1062 (x >> _scc_ y >> z) parses as (x >> (y >> z)),
1063 right associated. But the precedence reorganiser expects
1064 the parser to *left* associate all operators unless there
1065 are explicit parens. The _scc_ acts like an explicit paren,
1066 so if we omit it we'd better add explicit parens instead. */
1074 fexp : fexp aexp { $$ = mkap($1,$2); }
1078 /* simple expressions */
1079 aexp : qvar { $$ = mkident($1); }
1080 | gcon { $$ = mkident($1); }
1081 | lit_constant { $$ = mklit($1); }
1082 | OPAREN exp CPAREN { $$ = mkpar($2); } /* mkpar: stop infix parsing at ()'s */
1083 | qcon OCURLY rbinds CCURLY { $$ = mkrecord($1,$3); } /* 1 S/R conflict on OCURLY -> shift */
1084 | OBRACK list_exps CBRACK { $$ = mkllist($2); }
1085 | OPAREN exp COMMA texps CPAREN { if (ttree($4) == tuple)
1086 $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
1088 $$ = mktuple(ldub($2, $4)); }
1090 /* only in expressions ... */
1091 | aexp OCURLY rbinds1 CCURLY { $$ = mkrupdate($1,$3); }
1092 | OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); }
1093 | OBRACK exp COMMA exp DOTDOT exp CBRACK {$$= mkeenum($2,mkjust($4),mkjust($6)); }
1094 | OBRACK exp COMMA exp DOTDOT CBRACK { $$ = mkeenum($2,mkjust($4),mknothing()); }
1095 | OBRACK exp DOTDOT exp CBRACK { $$ = mkeenum($2,mknothing(),mkjust($4)); }
1096 | OBRACK exp DOTDOT CBRACK { $$ = mkeenum($2,mknothing(),mknothing()); }
1097 | OPAREN oexp qop CPAREN { $$ = mklsection($2,$3); }
1098 | OPAREN qop1 oexp CPAREN { $$ = mkrsection($2,$3); }
1100 /* only in patterns ... */
1101 /* these add 2 S/R conflict with with aexp . OCURLY rbinds CCURLY */
1102 | qvar AT aexp { checkinpat(); $$ = mkas($1,$3); }
1103 | LAZY aexp { checkinpat(); $$ = mklazyp($2); }
1104 | WILDCARD { checkinpat(); $$ = mkwildp(); }
1107 /* ccall arguments */
1108 cexps : cexps aexp { $$ = lapp($1,$2); }
1109 | aexp { $$ = lsing($1); }
1112 caserest: ocurly alts ccurly { $$ = $2; }
1113 | vocurly alts vccurly { $$ = $2; }
1115 dorest : ocurly stmts ccurly { checkdostmts($2); $$ = $2; }
1116 | vocurly stmts vccurly { checkdostmts($2); $$ = $2; }
1119 rbinds : /* empty */ { $$ = Lnil; }
1123 rbinds1 : rbind { $$ = lsing($1); }
1124 | rbinds1 COMMA rbind { $$ = lapp($1,$3); }
1127 rbind : qvar { $$ = mkrbind($1,mknothing()); }
1128 | qvar EQUAL exp { $$ = mkrbind($1,mkjust($3)); }
1131 texps : exp { $$ = mkpar($1); } /* mkpar: so we don't flatten last element in tuple */
1133 { if (ttree($3) == tuple)
1134 $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
1135 else if (ttree($3) == par)
1136 $$ = mktuple(ldub($1, gpare((struct Spar *) $3)));
1138 hsperror("hsparser:texps: panic");
1140 /* right recursion? WDP */
1144 exp { $$ = lsing($1); }
1145 | exp COMMA exp { $$ = mklcons( $1, lsing($3) ); }
1146 | exp COMMA exp COMMA list_rest { $$ = mklcons( $1, mklcons( $3, reverse_list( $5 ))); }
1149 /* Use left recusion for list_rest, because we sometimes get programs with
1150 very long explicit lists. */
1151 list_rest : exp { $$ = lsing($1); }
1152 | list_rest COMMA exp { $$ = mklcons( $3, $1 ); }
1156 exp { $$ = lsing($1); }
1157 | exp COMMA list_exps { $$ = mklcons($1, $3); }
1159 /* right recursion? (WDP)
1161 It has to be this way, though, otherwise you
1162 may do the wrong thing to distinguish between...
1164 [ e1 , e2 .. ] -- an enumeration ...
1165 [ e1 , e2 , e3 ] -- a list
1167 (In fact, if you change the grammar and throw yacc/bison
1168 at it, it *will* do the wrong thing [WDP 94/06])
1171 letdecls: LET { pat_check = TRUE; } ocurly decls ccurly { $$ = $4; }
1172 | LET { pat_check = TRUE; } vocurly decls vccurly { $$ = $4; }
1176 When parsing patterns inside do stmt blocks or quals, we have
1177 to tentatively parse them as expressions, since we don't know at
1178 the time of parsing `p' whether it will be part of "p <- e" (pat)
1179 or "p" (expr). When we eventually can tell the difference, the parse
1180 of `p' is examined to see if it consitutes a syntactically legal pattern
1183 The expr rule used to parse the pattern/expression do contain
1184 pattern-special productions (e.g., _ , a@pat, etc.), which are
1185 illegal in expressions. Since we don't know whether what
1186 we're parsing is an expression rather than a pattern, we turn off
1187 the check and instead do it later.
1189 The rather clumsy way that this check is turned on/off is there
1190 to work around a Bison feature/shortcoming. Turning the flag
1191 on/off just around the relevant nonterminal by decorating it
1192 with simple semantic actions, e.g.,
1194 {pat_check = FALSE; } expLNo { pat_check = TRUE; }
1196 causes Bison to generate a parser where in one state it either
1197 has to reduce/perform a semantic action ( { pat_check = FALSE; })
1198 or reduce an error (the error production used to implement
1199 vccurly.) Bison picks the semantic action, which it ideally shouldn't.
1200 The work around is to lift out the setting of { pat_check = FALSE; }
1201 and then later reset pat_check. Not pretty.
1206 quals : { pat_check = FALSE;} qual { pat_check = TRUE; $$ = lsing($2); }
1207 | quals COMMA { pat_check = FALSE; } qual { pat_check = TRUE; $$ = lapp($1,$4); }
1210 qual : letdecls { $$ = mkseqlet($1); }
1211 | expL { expORpat(LEGIT_EXPR,$1); $$ = $1; }
1212 | expLno { pat_check = TRUE; } leftexp
1214 expORpat(LEGIT_EXPR,$1);
1217 expORpat(LEGIT_PATT,$1);
1223 alts : alt { $$ = $1; }
1224 | alts SEMI alt { $$ = lconc($1,$3); }
1227 alt : pat { PREVPATT = $1; } altrest { $$ = lsing($3); PREVPATT = NULL; }
1228 | /* empty */ { $$ = Lnil; }
1231 altrest : gdpat maybe_where { $$ = createpat(mkpguards($1), $2); }
1232 | RARROW exp maybe_where { $$ = createpat(mkpnoguards($2),$3); }
1235 gdpat : gd RARROW exp { $$ = lsing(mkpgdexp($1,$3)); }
1236 | gd RARROW exp gdpat { $$ = mklcons(mkpgdexp($1,$3),$4); }
1239 stmts : {pat_check = FALSE;} stmt {pat_check=TRUE; $$ = $2; }
1240 | stmts SEMI {pat_check=FALSE;} stmt {pat_check=TRUE; $$ = lconc($1,$4); }
1243 stmt : /* empty */ { $$ = Lnil; }
1244 | letdecls { $$ = lsing(mkseqlet($1)); }
1245 | expL { expORpat(LEGIT_EXPR,$1); $$ = lsing(mkdoexp($1,hsplineno)); }
1246 | expLno {pat_check=TRUE;} leftexp
1248 expORpat(LEGIT_EXPR,$1);
1249 $$ = lsing(mkdoexp($1,endlineno));
1251 expORpat(LEGIT_PATT,$1);
1252 $$ = lsing(mkdobind($1,$3,endlineno));
1258 leftexp : LARROW exp { $$ = $2; }
1259 | /* empty */ { $$ = NULL; }
1262 /**********************************************************************
1268 **********************************************************************/
1270 pat : qvar PLUS INTEGER { $$ = mkplusp($1, mkinteger($3)); }
1274 cpat : cpat qconop bpat { $$ = mkinfixap($2,$1,$3); }
1280 | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
1281 | MINUS INTEGER { $$ = mknegate(mklit(mkinteger($2))); }
1282 | MINUS FLOAT { $$ = mknegate(mklit(mkfloatr($2))); }
1285 conpat : gcon { $$ = mkident($1); }
1286 | conpat apat { $$ = mkap($1,$2); }
1289 apat : gcon { $$ = mkident($1); }
1290 | qcon OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
1294 apatc : qvar { $$ = mkident($1); }
1295 | qvar AT apat { $$ = mkas($1,$3); }
1296 | lit_constant { $$ = mklit($1); }
1297 | WILDCARD { $$ = mkwildp(); }
1298 | OPAREN pat CPAREN { $$ = mkpar($2); }
1299 | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
1300 | OBRACK pats CBRACK { $$ = mkllist($2); }
1301 | LAZY apat { $$ = mklazyp($2); }
1305 INTEGER { $$ = mkinteger($1); }
1306 | FLOAT { $$ = mkfloatr($1); }
1307 | CHAR { $$ = mkcharr($1); }
1308 | STRING { $$ = mkstring($1); }
1309 | CHARPRIM { $$ = mkcharprim($1); }
1310 | STRINGPRIM { $$ = mkstringprim($1); }
1311 | INTPRIM { $$ = mkintprim($1); }
1312 | FLOATPRIM { $$ = mkfloatprim($1); }
1313 | DOUBLEPRIM { $$ = mkdoubleprim($1); }
1314 | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1); }
1317 lampats : apat lampats { $$ = mklcons($1,$2); }
1318 | apat { $$ = lsing($1); }
1319 /* right recursion? (WDP) */
1322 pats : pat COMMA pats { $$ = mklcons($1, $3); }
1323 | pat { $$ = lsing($1); }
1324 /* right recursion? (WDP) */
1327 rpats : /* empty */ { $$ = Lnil; }
1331 rpats1 : rpat { $$ = lsing($1); }
1332 | rpats1 COMMA rpat { $$ = lapp($1,$3); }
1335 rpat : qvar { $$ = mkrbind($1,mknothing()); }
1336 | qvar EQUAL pat { $$ = mkrbind($1,mkjust($3)); }
1340 patk : patk qconop bpat { $$ = mkinfixap($2,$1,$3); }
1346 | qconk OCURLY rpats CCURLY { $$ = mkrecord($1,$3); }
1347 | minuskey INTEGER { $$ = mknegate(mklit(mkinteger($2))); }
1348 | minuskey FLOAT { $$ = mknegate(mklit(mkfloatr($2))); }
1351 conpatk : gconk { $$ = mkident($1); }
1352 | conpatk apat { $$ = mkap($1,$2); }
1355 apatck : qvark { $$ = mkident($1); }
1356 | qvark AT apat { $$ = mkas($1,$3); }
1357 | lit_constant { $$ = mklit($1); setstartlineno(); }
1358 | WILDCARD { $$ = mkwildp(); setstartlineno(); }
1359 | oparenkey pat CPAREN { $$ = mkpar($2); }
1360 | oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
1361 | obrackkey pats CBRACK { $$ = mkllist($2); }
1362 | lazykey apat { $$ = mklazyp($2); }
1367 | OBRACK CBRACK { $$ = creategid(NILGID); }
1368 | OPAREN CPAREN { $$ = creategid(UNITGID); }
1369 | OPAREN commas CPAREN { $$ = creategid($2); }
1373 | obrackkey CBRACK { $$ = creategid(NILGID); }
1374 | oparenkey CPAREN { $$ = creategid(UNITGID); }
1375 | oparenkey commas CPAREN { $$ = creategid($2); }
1378 /**********************************************************************
1381 * Keywords which record the line start *
1384 **********************************************************************/
1386 importkey: IMPORT { setstartlineno(); $$ = 0; }
1387 | IMPORT SOURCE_UPRAGMA { setstartlineno(); $$ = 1; }
1390 datakey : DATA { setstartlineno();
1393 printf("%u\n",startlineno);
1395 fprintf(stderr,"%u\tdata\n",startlineno);
1400 typekey : TYPE { setstartlineno();
1403 printf("%u\n",startlineno);
1405 fprintf(stderr,"%u\ttype\n",startlineno);
1410 newtypekey : NEWTYPE { setstartlineno();
1413 printf("%u\n",startlineno);
1415 fprintf(stderr,"%u\tnewtype\n",startlineno);
1420 instkey : INSTANCE { setstartlineno();
1423 printf("%u\n",startlineno);
1426 fprintf(stderr,"%u\tinstance\n",startlineno);
1431 defaultkey: DEFAULT { setstartlineno(); }
1434 classkey: CLASS { setstartlineno();
1437 printf("%u\n",startlineno);
1439 fprintf(stderr,"%u\tclass\n",startlineno);
1444 modulekey: MODULE { setstartlineno();
1447 printf("%u\n",startlineno);
1449 fprintf(stderr,"%u\tmodule\n",startlineno);
1454 oparenkey: OPAREN { setstartlineno(); }
1457 obrackkey: OBRACK { setstartlineno(); }
1460 lazykey : LAZY { setstartlineno(); }
1463 minuskey: MINUS { setstartlineno(); }
1467 /**********************************************************************
1470 * Basic qualified/unqualified ids/ops *
1473 **********************************************************************/
1476 | OPAREN qvarsym CPAREN { $$ = $2; }
1479 | OPAREN qconsym CPAREN { $$ = $2; }
1482 | BQUOTE qvarid BQUOTE { $$ = $2; }
1485 | BQUOTE qconid BQUOTE { $$ = $2; }
1491 /* Non "-" op, used in right sections */
1496 /* Non "-" varop, used in right sections */
1498 | varsym_nominus { $$ = mknoqual($1); }
1499 | BQUOTE qvarid BQUOTE { $$ = $2; }
1504 | OPAREN varsym CPAREN { $$ = $2; }
1506 con : tycon /* using tycon removes conflicts */
1507 | OPAREN CONSYM CPAREN { $$ = $2; }
1510 | BQUOTE varid BQUOTE { $$ = $2; }
1513 | BQUOTE CONID BQUOTE { $$ = $2; }
1519 qvark : qvarid { setstartlineno(); $$ = $1; }
1520 | oparenkey qvarsym CPAREN { $$ = $2; }
1522 qconk : qconid { setstartlineno(); $$ = $1; }
1523 | oparenkey qconsym CPAREN { $$ = $2; }
1525 vark : varid { setstartlineno(); $$ = $1; }
1526 | oparenkey varsym CPAREN { $$ = $2; }
1530 | varid { $$ = mknoqual($1); }
1533 | varsym { $$ = mknoqual($1); }
1536 | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
1539 | CONSYM { $$ = mknoqual($1); }
1542 | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
1545 | tycon { $$ = mknoqual($1); } /* using tycon removes conflicts */
1548 varsym : varsym_nominus
1549 | MINUS { $$ = install_literal("-"); }
1552 /* PLUS, BANG are valid varsyms */
1553 varsym_nominus : VARSYM
1554 | PLUS { $$ = install_literal("+"); }
1555 | BANG { $$ = install_literal("!"); }
1558 /* AS HIDING QUALIFIED are valid varids */
1560 | AS { $$ = install_literal("as"); }
1561 | HIDING { $$ = install_literal("hiding"); }
1562 | QUALIFIED { $$ = install_literal("qualified"); }
1570 tyvar : varid { $$ = mknamedtvar(mknoqual($1)); }
1578 tyvar_list: tyvar { $$ = lsing($1); }
1579 | tyvar_list COMMA tyvar { $$ = lapp($1,$3); }
1583 /**********************************************************************
1586 * Stuff to do with layout *
1589 **********************************************************************/
1591 ocurly : layout OCURLY { hsincindent(); }
1593 vocurly : layout { hssetindent(); }
1596 layout : { hsindentoff(); }
1602 FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1607 vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; }
1613 FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1619 FN = NULL; SAMEFN = 0; PREVPATT = NULL;
1626 /**********************************************************************
1628 * Error Processing and Reporting *
1630 * (This stuff is here in case we want to use Yacc macros and such.) *
1632 **********************************************************************/
1639 hsperror("pattern syntax used in expression");
1642 /* The parser calls "hsperror" when it sees a
1643 `report this and die' error. It sets the stage
1644 and calls "yyerror".
1646 There should be no direct calls in the parser to
1647 "yyerror", except for the one from "hsperror". Thus,
1648 the only other calls will be from the error productions
1649 introduced by yacc/bison/whatever.
1651 We need to be able to recognise the from-error-production
1652 case, because we sometimes want to say, "Oh, never mind",
1653 because the layout rule kicks into action and may save
1657 static BOOLEAN error_and_I_mean_it = FALSE;
1663 error_and_I_mean_it = TRUE;
1667 extern char *yytext;
1674 /* We want to be able to distinguish 'error'-raised yyerrors
1675 from yyerrors explicitly coded by the parser hacker.
1677 if ( expect_ccurly && ! error_and_I_mean_it ) {
1681 fprintf(stderr, "%s:%d:%d: %s on input: ",
1682 input_filename, hsplineno, hspcolno + 1, s);
1684 if (yyleng == 1 && *yytext == '\0')
1685 fprintf(stderr, "<EOF>");
1689 format_string(stderr, (unsigned char *) yytext, yyleng);
1692 fputc('\n', stderr);
1694 /* a common problem */
1695 if (strcmp(yytext, "#") == 0)
1696 fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
1703 format_string(fp, s, len)
1710 case '\0': fputs("\\NUL", fp); break;
1711 case '\007': fputs("\\a", fp); break;
1712 case '\010': fputs("\\b", fp); break;
1713 case '\011': fputs("\\t", fp); break;
1714 case '\012': fputs("\\n", fp); break;
1715 case '\013': fputs("\\v", fp); break;
1716 case '\014': fputs("\\f", fp); break;
1717 case '\015': fputs("\\r", fp); break;
1718 case '\033': fputs("\\ESC", fp); break;
1719 case '\034': fputs("\\FS", fp); break;
1720 case '\035': fputs("\\GS", fp); break;
1721 case '\036': fputs("\\RS", fp); break;
1722 case '\037': fputs("\\US", fp); break;
1723 case '\177': fputs("\\DEL", fp); break;
1728 fprintf(fp, "\\^%c", *s + '@');