/* -------------------------------------------------------------------------- * parser.y: Copyright (c) Mark P Jones 1991-1998. All rights reserved. * See NOTICE for details and conditions of use etc... * Hugs version 1.3b, January 1998 * * Expect 23 shift/reduce conflicts when passing this grammar * through yacc, but don't worry; they will all be resolved in * an appropriate manner. * * Hugs parser (included as part of input.c) * ------------------------------------------------------------------------*/ %{ #ifndef lint #define lint #endif #define defTycon(n,l,lhs,rhs,w,ax) tyconDefn(intOf(l),lhs,rhs,w,ax); sp-=n #define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t)) #define grded(gs) ap(GUARDED,gs) #define bang(t) ap(BANG,t) #define only(t) ap(ONLY,t) #define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e) #define yyerror(s) /* errors handled elsewhere */ #define YYSTYPE Cell static Cell local gcShadow Args((Int,Cell)); static Void local syntaxError Args((String)); static String local unexpected Args((Void)); static Cell local checkPrec Args((Cell)); static Void local fixDefn Args((Syntax,Cell,Cell,List)); static Void local setSyntax Args((Int,Syntax,Cell)); static Cell local buildTuple Args((List)); static List local checkContext Args((List)); static Cell local checkClass Args((Cell)); static Cell local checkInst Args((Cell)); static Pair local checkDo Args((List)); static Cell local checkTyLhs Args((Cell)); static Cell local tidyInfix Args((Cell)); /* For the purposes of reasonably portable garbage collection, it is * necessary to simulate the YACC stack on the Hugs stack to keep * track of all intermediate constructs. The lexical analyser * pushes a token onto the stack for each token that is found, with * these elements being removed as reduce actions are performed, * taking account of look-ahead tokens as described by gcShadow() * below. * * Of the non-terminals used below, only start, topDecl, fixDecl & begin * do not leave any values on the Hugs stack. The same is true for the * terminals EXPR and SCRIPT. At the end of a successful parse, there * should only be one element left on the stack, containing the result * of the parse. */ #define gc0(e) gcShadow(0,e) #define gc1(e) gcShadow(1,e) #define gc2(e) gcShadow(2,e) #define gc3(e) gcShadow(3,e) #define gc4(e) gcShadow(4,e) #define gc5(e) gcShadow(5,e) #define gc6(e) gcShadow(6,e) #define gc7(e) gcShadow(7,e) #define gc8(e) gcShadow(8,e) #define gc9(e) gcShadow(9,e) %} %token EXPR SCRIPT %token CASEXP OF DATA TYPE IF %token THEN ELSE WHERE LET IN %token INFIX INFIXL INFIXR PRIMITIVE TNEWTYPE %token DEFAULT DERIVING DO TCLASS TINSTANCE %token TRUNST REPEAT %token VAROP VARID NUMLIT CHARLIT STRINGLIT %token CONOP CONID %token STRUCT SELDOT '<' '>' %token TEMPLATE ACTION REQUEST ASSIGN HANDLE %token FORALL WHILE ELSIF FIX %token COCO '=' UPTO '@' '\\' %token '|' '-' FROM ARROW '~' %token '!' IMPLIES '(' ',' ')' %token '[' ';' ']' '`' %token MODULE IMPORT HIDING QUALIFIED ASMOD %% /*- Top level script/module structure -------------------------------------*/ start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;} | SCRIPT topModule {valDefns = $2; sp-=1;} | error {syntaxError("input");} ; /*- Haskell module header/import parsing: ----------------------------------- * Syntax for Haskell modules (module headers and imports) is parsed but * most of it is ignored. However, module names in import declarations * are used, of course, if import chasing is turned on. *-------------------------------------------------------------------------*/ topModule : begin modBody end {$$ = gc2($2);} | modules {$$ = $1;} ; modules : modules module {$$ = gc2(appendOnto($2,$1));} | module {$$ = $1;} ; module : MODULE modid expspec WHERE beg modBody end {$$ = gc7($6);} | MODULE error {syntaxError("module definition");} ; modid : CONID {$$ = $1;} | VARID {$$ = $1;} | STRINGLIT {$$ = $1;} ; modBody : topDecls {$$ = $1;} | fixDecls ';' topDecls {$$ = gc3($3);} | impDecls chase {$$ = gc2(NIL);} | impDecls ';' chase topDecls {$$ = gc4($4);} | impDecls ';' chase fixDecls ';' topDecls {$$ = gc6($6);} ; /*- Exports: --------------------------------------------------------------*/ expspec : /* empty */ {$$ = gc0(NIL);} | '(' exports ')' {$$ = gc3(NIL);} | '(' exports ',' ')' {$$ = gc4(NIL);} ; exports : exports ',' export {$$ = gc3(NIL);} | export {$$ = $1;} ; export : import {$$ = $1;} | MODULE modid {$$ = gc2(NIL);} ; /*- Import declarations: --------------------------------------------------*/ impDecls : impDecls ';' impDecl {imps = cons($3,imps); $$=gc3(NIL);} | impDecl {imps = singleton($1); $$=gc1(NIL);} ; chase : /* empty */ {if (chase(imps)) { clearStack(); onto(imps); done(); closeAnyInput(); return 0; } $$ = gc0(NIL); } ; impDecl : IMPORT modid impspec {$$ = gc3($2);} | IMPORT QUALIFIED modid ASMOD modid impspec {$$ = gc6($3);} | IMPORT QUALIFIED modid impspec {$$ = gc4($3);} | IMPORT error {syntaxError("import declaration");} ; impspec : /* empty */ {$$ = gc0(NIL);} | HIDING '(' imports ')' {$$ = gc4(NIL);} | '(' imports ')' {$$ = gc3(NIL);} ; imports : /* empty */ {$$ = gc0(NIL);} | ',' {$$ = gc1(NIL);} | imports1 {$$ = $1;} | imports1 ',' {$$ = gc2($1);} ; imports1 : imports1 ',' import {$$ = gc3(NIL);} | import {$$ = $1;} ; import : var {$$ = $1;} | CONID {$$ = $1;} | CONID '(' UPTO ')' {$$ = gc4(NIL);} | CONID '(' cnames ')' {$$ = gc4(NIL);} ; cnames : /* empty */ {$$ = gc0(NIL);} | ',' {$$ = gc1(NIL);} | cnames1 {$$ = $1;} | cnames1 ',' {$$ = gc2($1);} ; cnames1 : cnames1 ',' cname {$$ = gc3(NIL);} | cname {$$ = gc1(NIL);} ; cname : var {$$ = $1;} | conid {$$ = $1;} ; /*- Fixity declarations: --------------------------------------------------*/ fixDecls : fixDecls ';' fixDecl {$$ = gc2(NIL);} | fixDecl {$$ = gc0(NIL);} ; fixDecl : INFIXL optdigit ops {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;} | INFIXR optdigit ops {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;} | INFIX optdigit ops {fixDefn(NON_ASS,$1,$2,$3); sp-=3;} ; optdigit : NUMLIT {$$ = gc1(checkPrec($1));} | /* empty */ {$$ = gc0(mkInt(DEF_PREC));} ; ops : ops ',' op {$$ = gc3(cons($3,$1));} | op {$$ = gc1(cons($1,NIL));} ; op : varop {$$ = $1;} | conop {$$ = $1;} | '-' {$$ = gc1(varMinus);} ; varop : VAROP {$$ = $1;} | '!' {$$ = gc1(varBang);} | '<' {$$ = gc1(varLT);} | '>' {$$ = gc1(varGT);} | '`' varid1 '`' {$$ = gc3($2);} ; conop : CONOP {$$ = $1;} | '`' CONID '`' {$$ = gc3($2);} ; /*- Top-level declarations: -----------------------------------------------*/ topDecls : /* empty */ {$$ = gc0(NIL);} | ';' {$$ = gc1(NIL);} | topDecls1 {$$ = $1;} | topDecls1 ';' {$$ = gc2($1);} ; topDecls1 : topDecls1 ';' topDecl {$$ = gc2($1);} | topDecls1 ';' decl {$$ = gc3(cons($3,$1));} | topDecl {$$ = gc0(NIL);} | decl {$$ = gc1(cons($1,NIL));} ; /*- Type declarations: ----------------------------------------------------*/ topDecl : TYPE tyLhs '=' type {defTycon(4,$3,$2,$4,SYNONYM,NIL);} | TYPE tyLhs '=' type IN invars {defTycon(6,$3,$2,ap($4,$6),RESTRICTSYN,NIL);} | DATA tyLhs subs '=' constrs deriving {defTycon(6,$4,$2,ap(rev($5),$6),DATATYPE,$3);} | DATA tyLhs subs {defTycon(3,$1,$2,ap(NIL,NIL),DATATYPE,$3);} | TNEWTYPE tyLhs '=' nconstr deriving {defTycon(5,$3,$2,ap($4,$5),NEWTYPE,NIL);} | STRUCT tyLhs sups '=' decllist {defTycon(5,$1,$2,rev($5),STRUCTTYPE,$3);} | STRUCT tyLhs sups {defTycon(3,$1,$2,NIL,STRUCTTYPE,$3);} ; subs : /* empty */ {$$ = gc0(NIL);} | '>' stypes {$$ = gc2($2);} ; sups : /* empty */ {$$ = gc0(NIL);} | '<' stypes {$$ = gc2($2);} ; stypes : stype ',' stypes {$$ = gc3(cons($1,$3));} | stype {$$ = gc1(cons($1,NIL));} ; stype : btype2 {$$ = $1;} | '[' type ']' {$$ = gc3(ap(typeList,$2));} ; tyLhs : tyLhs varid1 {$$ = gc2(ap($1,$2));} | CONID {$$ = $1;} | error {syntaxError("type defn lhs");} ; invars : invars ',' invar {$$ = gc3(cons($3,$1));} | invar {$$ = gc1(cons($1,NIL));} ; invar : var COCO sigType {$$ = gc3(sigdecl($2,singleton($1), $3));} | var {$$ = $1;} ; constrs : constrs '|' constr {$$ = gc3(cons($3,$1));} | constr {$$ = gc1(cons($1,NIL));} ; constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));} | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));} | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));} | btype2 {$$ = $1;} | btype3 {$$ = $1;} | error {syntaxError("data type definition");} ; btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));} | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));} | btype3 atype {$$ = gc2(ap($1,$2));} ; bbtype : '!' btype {$$ = gc2(bang($2));} | btype {$$ = $1;} ; nconstr : conid atype {$$ = gc2(singleton(ap($1,$2)));} ; deriving : /* empty */ {$$ = gc0(NIL);} | DERIVING CONID {$$ = gc2(singleton($2));} | DERIVING '(' derivs0 ')' {$$ = gc4($3);} ; derivs0 : /* empty */ {$$ = gc0(NIL);} | derivs {$$ = gc1(rev($1));} ; derivs : derivs ',' CONID {$$ = gc3(cons($3,$1));} | CONID {$$ = gc1(singleton($1));} ; /*- Processing definitions of primitives ----------------------------------*/ topDecl : PRIMITIVE prims COCO sigType{primDefn($1,$2,$4); sp-=4;} ; prims : prims ',' prim {$$ = gc3(cons($3,$1));} | prim {$$ = gc1(cons($1,NIL));} | error {syntaxError("primitive defn");} ; prim : var STRINGLIT {$$ = gc2(pair($1,$2));} | var {$$ = $1;} ; /*- Class declarations: ---------------------------------------------------*/ topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;} | TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;} | DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;} ; crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkClass($3)));} | btype2 {$$ = gc1(pair(NIL,checkClass($1)));} ; irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkInst($3)));} | btype2 {$$ = gc1(pair(NIL,checkInst($1)));} ; dtypes : /* empty */ {$$ = gc0(NIL);} | dtypes1 {$$ = gc1(rev($1));} ; dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));} | type {$$ = gc1(cons($1,NIL));} ; /*- Type expressions: -----------------------------------------------------*/ sigType : context IMPLIES type {$$ = gc3(ap(QUAL,pair($1,$3)));} | type {$$ = $1;} ; context : '(' ')' {$$ = gc2(NIL);} | btype2 {$$ = gc1(singleton(checkClass($1)));} | '(' btype2 ')' {$$ = gc3(singleton(checkClass($2)));} | '(' btypes2 ')' {$$ = gc3(checkContext($2));} ; type : type1 {$$ = $1;} | btype2 {$$ = $1;} ; type1 : btype1 {$$ = $1;} | btype1 ARROW type {$$ = gc3(ap(ap(typeArrow,$1),$3));} | btype2 ARROW type {$$ = gc3(ap(ap(typeArrow,$1),$3));} | error {syntaxError("type expression");} ; btype : btype1 {$$ = $1;} | btype2 {$$ = $1;} ; btype1 : btype1 atype {$$ = gc2(ap($1,$2));} | atype1 {$$ = $1;} ; btype2 : btype2 atype {$$ = gc2(ap($1,$2));} | CONID {$$ = $1;} ; atype : atype1 {$$ = $1;} | CONID {$$ = $1;} ; atype1 : varid1 {$$ = $1;} | '(' ')' {$$ = gc2(typeUnit);} | '(' ARROW ')' {$$ = gc3(typeArrow);} | '(' type1 ')' {$$ = gc3($2);} | '(' btype2 ')' {$$ = gc3($2);} | '(' tupCommas ')' {$$ = gc3($2);} | '(' btypes2 ')' {$$ = gc3(buildTuple($2));} | '(' typeTuple ')' {$$ = gc3(buildTuple($2));} | '[' type ']' {$$ = gc3(ap(typeList,$2));} | '[' ']' {$$ = gc2(typeList);} | '_' {$$ = gc1(WILDCARD);} ; tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));} | ',' {$$ = gc1(mkTuple(2));} ; btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));} | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));} ; typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));} | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));} | btypes2 ',' type1 {$$ = gc3(cons($3,$1));} | typeTuple ',' type {$$ = gc3(cons($3,$1));} ; /*- Value declarations: ---------------------------------------------------*/ decllist : beg decls end {$$ = gc3($2);} ; decls : /* empty */ {$$ = gc0(NIL);} | ';' {$$ = gc1(NIL);} | decls1 {$$ = $1;} | decls1 ';' {$$ = gc2($1);} ; decls1 : decls1 ';' decl {$$ = gc3(cons($3,$1));} | decl {$$ = gc1(cons($1,NIL));} ; decl : vars COCO sigType {$$ = gc3(sigdecl($2,$1,$3));} | opExp rhs {$$ = gc2(pair($1,$2));} ; rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));} | error {syntaxError("declaration");} ; rhs1 : '=' exp {$$ = gc2(pair($1,$2));} | gdefs {$$ = gc1(grded(rev($1)));} ; wherePart : WHERE decllist {$$ = gc2($2);} | /*empty*/ {$$ = gc0(NIL);} ; gdefs : gdefs gdef {$$ = gc2(cons($2,$1));} | gdef {$$ = gc1(cons($1,NIL));} ; gdef : '|' exp '=' exp {$$ = gc4(pair($3,pair($2,$4)));} ; vars : vars ',' var {$$ = gc3(cons($3,$1));} | var {$$ = gc1(cons($1,NIL));} ; var : varid {$$ = $1;} | '(' '-' ')' {$$ = gc3(varMinus);} ; varid : varid1 {$$ = $1;} | '(' VAROP ')' {$$ = gc3($2);} | '(' '!' ')' {$$ = gc3(varBang);} | '(' '<' ')' {$$ = gc3(varLT);} | '(' '>' ')' {$$ = gc3(varGT);} ; varid1 : VARID {$$ = $1;} | HIDING {$$ = gc1(varHiding);} | QUALIFIED {$$ = gc1(varQualified);} | ASMOD {$$ = gc1(varAsMod);} ; conid : CONID {$$ = $1;} | '(' CONOP ')' {$$ = gc3($2);} ; /*- Expressions: ----------------------------------------------------------*/ exp : exp1 {$$ = $1;} | error {syntaxError("expression");} ; exp1 : opExp COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));} | opExp {$$ = $1;} ; opExp : opExp0 {$$ = gc1(tidyInfix($1));} | pfxExp {$$ = $1;} ; opExp0 : opExp0 op '-' pfxExp {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} | opExp0 op pfxExp {$$ = gc3(ap(ap($2,$1),$3));} | '-' pfxExp {$$ = gc2(ap(NEG,only($2)));} | pfxExp op pfxExp {$$ = gc3(ap(ap($2,only($1)),$3));} | pfxExp op '-' pfxExp {$$ = gc4(ap(NEG, ap(ap($2,only($1)),$4)));} ; pfxExp : IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));} | CASEXP exp OF beg alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));} | pfxExp1 {$$ = $1;} ; pfxExp1 : LET decllist IN exp {$$ = gc4(letrec($2,$4));} | '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA, pair(rev($2), pair($3,$4))));} | DO do {$$ = gc2($2);} | ACTION do {$$ = gc2(ap(ACTEXP,$2));} | REQUEST do {$$ = gc2(ap(REQEXP,$2));} | TEMPLATE tdecllist IN exp ohandle {$$ = gc5(ap(TEMPLEXP,pair(pair($2,NIL),pair($4,$5))));} | STRUCT sdecllist {$$ = gc2(ap(STRUCTVAL,pair($1,$2)));} | appExp {$$ = $1;} ; sdecllist : beg decls end UPTO conid {$$ = gc5(cons($5,$2));} | beg decls end {$$ = gc3($2);} ; pats : pats atomic {$$ = gc2(cons($2,$1));} | atomic {$$ = gc1(cons($1,NIL));} ; appExp : appExp atomic {$$ = gc2(ap($1,$2));} | TRUNST atomic {$$ = gc2(ap(RUNST,$2));} | atomic {$$ = $1;} ; atomic : var {$$ = $1;} | var '@' atomic {$$ = gc3(ap(ASPAT,pair($1,$3)));} | '~' atomic {$$ = gc2(ap(LAZYPAT,$2));} | '_' {$$ = gc1(WILDCARD);} | conid {$$ = $1;} | '(' ')' {$$ = gc2(nameUnit);} | NUMLIT {$$ = $1;} | CHARLIT {$$ = $1;} | STRINGLIT {$$ = $1;} | REPEAT {$$ = $1;} | '(' exp ')' {$$ = gc3($2);} | '(' exps2 ')' {$$ = gc3(buildTuple($2));} | '{' decls end {$$ = gc3(ap(STRUCTVAL,pair($1,$2)));} | atomic SELDOT varid1 {$$ = gc3(ap(SELECTION,pair($1,$3)));} | '(' SELDOT varid1 ')' {$$ = gc4(ap(SELECTION,$3));} | '[' list ']' {$$ = gc3($2);} | '(' pfxExp op ')' {$$ = gc4(ap($3,$2));} | '(' varop atomic ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));} | '(' conop atomic ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));} | '(' tupCommas ')' {$$ = gc3($2);} ; exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));} | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));} ; alts : alts1 {$$ = $1;} | alts1 ';' {$$ = gc2($1);} ; alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));} | alt {$$ = gc1(cons($1,NIL));} ; alt : opExp altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));} ; altRhs : guardAlts {$$ = gc1(grded(rev($1)));} | ARROW exp {$$ = gc2(pair($1,$2));} | error {syntaxError("case expression");} ; guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));} | guardAlt {$$ = gc1(cons($1,NIL));} ; guardAlt : '|' opExp ARROW exp {$$ = gc4(pair($3,pair($2,$4)));} ; do : stmts {$$ = gc1($1);} | stmts handle {$$ = gc2(ap(HNDLEXP,pair($2,$1)));} ; stmts : beg stmts1 end {$$ = gc3(ap(DOCOMP,checkDo($2)));} | beg stmts1 ';' end {$$ = gc4(ap(DOCOMP,checkDo($2)));} ; stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));} | stmt {$$ = gc1(cons($1,NIL));} ; stmt : mexp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));} | LET decllist {$$ = gc2(ap(QWHERE,$2));} | IF exp THEN stmts ELSE stmts{$$ = gc6(ap(DOQUAL,ap(COND,triple($2,$4,$6))));} | IF exp THEN stmts {$$ = gc4(ap(IFHACK,pair($2,$4)));} | ELSIF exp THEN stmts {$$ = gc4(ap(ELSIFHACK,pair($2,$4)));} | ELSE stmts {$$ = gc2(ap(ELSEHACK,$2));} | CASEXP exp OF beg malts end {$$ = gc6(ap(DOQUAL,ap(CASE,pair($2,rev($5)))));} | FORALL exp FROM exp DO stmts{$$ = gc6(ap(FORALLDO,triple($2,$4,$6)));} | WHILE exp DO stmts {$$ = gc4(ap(WHILEDO,pair($2,$4)));} | FIX genlist {$$ = gc2(ap(FIXDO,$2));} | assign {$$ = gc1(ap(ASSIGNQ,$1));} | mexp {$$ = gc1(ap(DOQUAL,$1));} ; assign : mopExp ASSIGN exp {$$ = gc3(pair($1,pair($2,$3)));} ; tdecllist : beg tdecls end {$$ = gc3($2);} ; tdecls : /* empty */ {$$ = gc0(NIL);} | ';' {$$ = gc1(NIL);} | tdecls1 {$$ = $1;} | tdecls1 ';' {$$ = gc2($1);} ; tdecls1 : tdecls1 ';' tdecl {$$ = gc3(cons($3,$1));} | tdecl {$$ = gc1(cons($1,NIL));} ; tdecl : assign {$$ = $1;} /* | vars COCO sigType {$$ = gc3(sigdecl($2,$1,$3));} */ | mexp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));} ; genlist : beg gens end {$$ = gc3($2);} ; gens : /* empty */ {$$ = gc0(NIL);} | ';' {$$ = gc1(NIL);} | gens1 {$$ = $1;} | gens1 ';' {$$ = gc2($1);} ; gens1 : gens1 ';' gen {$$ = gc3(cons($3,$1));} | gen {$$ = gc1(cons($1,NIL));} ; gen : mexp FROM exp {$$ = gc3(pair($1,$3));} ; handle : HANDLE beg malts end {$$ = gc4(rev($3));} ; ohandle : handle {$$ = $1;} | /*empty*/ {$$ = gc0(NIL);}; mexp : mopExp COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));} | mopExp {$$ = $1;} ; mopExp : mopExp0 {$$ = gc1(tidyInfix($1));} | pfxExp1 {$$ = $1;} ; mopExp0 : mopExp0 op '-' pfxExp {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));} | mopExp0 op pfxExp {$$ = gc3(ap(ap($2,$1),$3));} | '-' pfxExp {$$ = gc2(ap(NEG,only($2)));} | pfxExp1 op pfxExp {$$ = gc3(ap(ap($2,only($1)),$3));} | pfxExp1 op '-' pfxExp {$$ = gc4(ap(NEG, ap(ap($2,only($1)),$4)));} ; malts : malts1 {$$ = $1;} | malts1 ';' {$$ = gc2($1);} ; malts1 : malts1 ';' malt {$$ = gc3(cons($3,$1));} | malt {$$ = gc1(cons($1,NIL));} ; malt : opExp maltRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));} ; maltRhs : mguardAlts {$$ = gc1(grded(rev($1)));} | ARROW stmts {$$ = gc2(pair($1,$2));} | error {syntaxError("case command");} ; mguardAlts: mguardAlts mguardAlt {$$ = gc2(cons($2,$1));} | mguardAlt {$$ = gc1(cons($1,NIL));} ; mguardAlt : '|' opExp ARROW stmts {$$ = gc4(pair($3,pair($2,$4)));} ; /*- List Expressions: -------------------------------------------------------*/ list : /* empty */ {$$ = gc0(nameNil);} | exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));} | exps2 {$$ = gc1(ap(FINLIST,rev($1)));} | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));} | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));} | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));} | exp UPTO {$$ = gc2(ap(nameFrom,$1));} | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo, $1),$3),$5));} ; quals : quals ',' qual {$$ = gc3(cons($3,$1));} | qual {$$ = gc1(cons($1,NIL));} ; qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));} | exp {$$ = gc1(ap(BOOLQUAL,$1));} | LET decllist {$$ = gc2(ap(QWHERE,$2));} ; /*- Tricks to force insertion of leading and closing braces ---------------*/ begin : '{' {$$ = $1;} | error {yyerrok; goOffside(startColumn);} ; /* deal with trailing semicolon */ end : '}' {$$ = $1;} | error {yyerrok; if (canUnOffside()) { unOffside(); /* insert extra token on stack*/ push(NIL); pushed(0) = pushed(1); pushed(1) = mkInt(column); } else syntaxError("definition"); } ; beg : {useLayout();} '{' {$$ = $1;} ; /*-------------------------------------------------------------------------*/ %% static Cell local gcShadow(n,e) /* keep parsed fragments on stack */ Int n; Cell e; { /* If a look ahead token is held then the required stack transformation * is: * pushed: n 1 0 1 0 * x1 | ... | xn | la ===> e | la * top() top() * * Othwerwise, the transformation is: * pushed: n-1 0 0 * x1 | ... | xn ===> e * top() top() */ if (yychar>=0) { pushed(n-1) = top(); pushed(n) = e; } else pushed(n-1) = e; sp -= (n-1); return e; } static Void local syntaxError(s) /* report on syntax error */ String s; { ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected() EEND; } static String local unexpected() { /* find name for unexpected token */ static char buffer[100]; static char *fmt = "%s \"%s\""; static char *kwd = "keyword"; switch (yychar) { case 0 : return "end of input"; #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer; case INFIXL : keyword("infixl"); case INFIXR : keyword("infixr"); case INFIX : keyword("infix"); case TINSTANCE : keyword("instance"); case TCLASS : keyword("class"); case PRIMITIVE : keyword("primitive"); case CASEXP : keyword("case"); case OF : keyword("of"); case IF : keyword("if"); case TRUNST : keyword("runST"); case THEN : keyword("then"); case ELSE : keyword("else"); case WHERE : keyword("where"); case TYPE : keyword("type"); case DATA : keyword("data"); case TNEWTYPE : keyword("newtype"); case LET : keyword("let"); case IN : keyword("in"); case DERIVING : keyword("deriving"); case DEFAULT : keyword("default"); case IMPORT : keyword("import"); case MODULE : keyword("module"); case STRUCT : keyword("struct"); case TEMPLATE : keyword("template"); case ACTION : keyword("action"); case REQUEST : keyword("request"); case HANDLE : keyword("handle"); case FORALL : keyword("forall"); case WHILE : keyword("while"); case ELSIF : keyword("elsif"); #undef keyword case ASSIGN : return "`:='"; case '<' : return "`<'"; case '>' : return "`>'"; case ARROW : return "`->'"; case '=' : return "`='"; case COCO : return "`::'"; case '-' : return "`-'"; case '!' : return "`!'"; case ',' : return "comma"; case '@' : return "`@'"; case '(' : return "`('"; case ')' : return "`)'"; case '{' : return "`{'"; case '}' : return "`}'"; case '|' : return "`|'"; case ';' : return "`;'"; case UPTO : return "`..'"; case '[' : return "`['"; case ']' : return "`]'"; case '_' : return "`_'"; case FROM : return "`<-'"; case '\\' : return "backslash (lambda)"; case '~' : return "tilde"; case '`' : return "backquote"; case SELDOT : return "`.'"; case VAROP : case VARID : case CONOP : case CONID : sprintf(buffer,"symbol \"%s\"", textToStr(textOf(yylval))); return buffer; case HIDING : return "symbol \"hiding\""; case QUALIFIED : return "symbol \"qualified\""; case ASMOD : return "symbol \"as\""; case NUMLIT : return "numeric literal"; case CHARLIT : return "character literal"; case STRINGLIT : return "string literal"; case IMPLIES : return "`=>'"; default : return "token"; } } static Cell local checkPrec(p) /* Check for valid precedence value */ Cell p; { if (!isInt(p) || intOf(p)MAX_PREC) { ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]", MIN_PREC, MAX_PREC EEND; } return p; } static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators */ Syntax a; Cell line; Cell p; List ops; { Int l = intOf(line); a = mkSyntax(a,intOf(p)); map2Proc(setSyntax,l,a,ops); } static Void local setSyntax(line,sy,op)/* set syntax of individ. operator */ Int line; Syntax sy; Cell op; { addSyntax(line,textOf(op),sy); opDefns = cons(op,opDefns); } static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from list*/ List tup; { /* [xn,...,x1] */ Int n = 0; Cell t = tup; Cell x; do { /* . . */ x = fst(t); /* / \ / \ */ fst(t) = snd(t); /* xn . . xn */ snd(t) = x; /* . ===> . */ x = t; /* . . */ t = fun(x); /* . . */ n++; /* / \ / \ */ } while (nonNull(t)); /* x1 NIL (n) x1 */ fst(x) = mkTuple(n); return tup; } static List local checkContext(con) /* validate type class context */ Type con; { mapOver(checkClass,con); return con; } static Cell local checkClass(c) /* check that type expr is a class */ Cell c; { /* constrnt of the form Class var */ Cell cn = getHead(c); if (!isCon(cn)) syntaxError("class expression"); else if (argCount!=1) { ERRMSG(row) "Class \"%s\" must have exactly one argument", textToStr(textOf(cn)) EEND; } else if (whatIs(arg(c))!=VARIDCELL) { ERRMSG(row) "Argument of class \"%s\" must be a variable", /* Ha! What do you think this is? Gofer!? :-) */ textToStr(textOf(cn)) EEND; } return c; } static Cell local checkInst(c) /* check that type expr is a class */ Cell c; { /* constr of the form Class simple */ Cell cn = getHead(c); if (!isCon(cn)) syntaxError("class expression"); else if (argCount!=1) { ERRMSG(row) "Class \"%s\" must have exactly one argument", textToStr(textOf(cn)) EEND; } else { Cell a = arg(c); Cell tn = getHead(a); if (isCon(tn) || isTycon(tn) || isTuple(tn)) { for (; isAp(a); a=fun(a)) if (whatIs(arg(a))!=VARIDCELL) { ERRMSG(row) "Type variable expected in instance type" EEND; } } else { ERRMSG(row) "Illegal type expression in instance declaration" EEND; } } return c; } static Pair local checkDo(dqs) /* convert reversed list of dquals */ List dqs; { /* to an (expr,quals) pair */ static String ElseErr = "Badly formed \"if/elsif/else\" sequence"; static String LastErr = "Last statement in a sequence must be an expression or an assignment"; List qs = dqs, revqs = NIL; Cell exp = NIL; while (nonNull(qs)) { Cell ifexp = nameDone; if (whatIs(hd(qs))==ELSEHACK) { ifexp = snd(hd(qs)); qs = tl(qs); } while (nonNull(qs) && whatIs(hd(qs))==ELSIFHACK) { ifexp = ap(COND,triple(fst(snd(hd(qs))),snd(snd(hd(qs))),ifexp)); qs = tl(qs); } if (nonNull(qs) && whatIs(hd(qs))==IFHACK) { ifexp = ap(COND,triple(fst(snd(hd(qs))),snd(snd(hd(qs))),ifexp)); hd(qs) = ap(DOQUAL,ifexp); ifexp = nameDone; } if (isNull(qs) || ifexp != nameDone) { ERRMSG(row) ElseErr EEND; } switch (whatIs(hd(qs))) { case IFHACK : case ELSEHACK : case ELSIFHACK : ERRMSG(row) ElseErr EEND; break; case FORALLDO : case WHILEDO : case ASSIGNQ : if (exp==NIL) exp = nameDone; break; case DOQUAL : if (exp==NIL) { exp = snd(hd(qs)); qs = tl(qs); continue; } break; default : if (exp==NIL) { ERRMSG(row) LastErr EEND; } break; } revqs = cons(hd(qs),revqs); qs = tl(qs); } fst(dqs) = exp; /* put expression in fst of pair */ snd(dqs) = revqs; /* & reversed list of quals in snd */ return dqs; } /* if a then xxx elsif b then yyy elsif c then zzz else www ==> if a then xxx else if b then yyy else if c then zzz else www */ static Cell local checkTyLhs(c) /* check that lhs is of the form */ Cell c; { /* T a1 ... a */ Cell tlhs = c; while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) tlhs = fun(tlhs); if (whatIs(tlhs)!=CONIDCELL) { ERRMSG(row) "Illegal left hand side in type definition" EEND; } return c; } /* Expressions involving infix operators or unary minus are parsed as elements * of the following type: * * data OpExp = Only Exp | Neg OpExp | Infix OpExp Op Exp * * (The algorithms here do not assume that negation can be applied only once, * i.e., that - - x is a syntax error, as required by the Haskell report. * Instead, that restriction is captured by the grammar itself, given above.) * * There are rules of precedence and grouping, expressed by two functions: * * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R}) * * OpExp values are rearranged accordingly when a complete expression has * been read using a simple shift-reduce parser whose result may be taken * to be a value of the following type: * * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String * * The machine on which this parser is based can be defined as follows: * * tidy :: OpExp -> [(Op,Exp)] -> Exp * tidy (Only a) [] = a * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss * tidy (Infix a o b) [] = tidy a [(o,b)] * tidy (Infix a o b) ((p,c):ss) * | shift o p = tidy a ((o,b):(p,c):ss) * | red o p = tidy (Infix a o (Apply p b c)) ss * | ambig o p = Error "ambiguous use of operators" * tidy (Neg e) [] = tidy (tidyNeg e) [] * tidy (Neg e) ((o,b):ss) * | nshift o = tidy (Neg (underNeg o b e)) ss * | nred o = tidy (tidyNeg e) ((o,b):ss) * | nambig o = Error "illegal use of negation" * * At each stage, the parser can either shift, reduce, accept, or error. * The transitions when dealing with juxtaposed operators o and p are * determined by the following rules: * * shift o p = (prec o > prec p) * || (prec o == prec p && assoc o == L && assoc p == L) * * red o p = (prec o < prec p) * || (prec o == prec p && assoc o == R && assoc p == R) * * ambig o p = (prec o == prec p) * && (assoc o == N || assoc p == N || assoc o /= assoc p) * * The transitions when dealing with juxtaposed unary minus and infix operators * are as follows. The precedence of unary minus (infixl 6) is hardwired in * to these definitions, as it is to the definitions of the Haskell grammar * in the official report. * * nshift o = (prec o > 6) * nred o = (prec o < 6) || (prec o == 6 && assoc o == L) * nambig o = prec o == 6 && (assoc o == R || assoc o == N) * * An OpExp of the form (Neg e) means negate the last thing in the OpExp e; * we can force this negation using: * * tidyNeg :: OpExp -> OpExp * tidyNeg (Only e) = Only (Negate e) * tidyNeg (Infix a o b) = Infix a o (Negate b) * tidyNeg (Neg e) = tidyNeg (tidyNeg e) * * On the other hand, if we want to sneak application of an infix operator * under a negation, then we use: * * underNeg :: Op -> Exp -> OpExp -> OpExp * underNeg o b (Only e) = Only (Apply o e b) * underNeg o b (Neg e) = Neg (underNeg o b e) * underNeg o b (Infix e p f) = Infix e p (Apply o f b) * * As a concession to efficiency, we lower the number of calls to syntaxOf * by keeping track of the values of sye, sys throughout the process. The * value APPLIC is used to indicate that the syntax value is unknown. */ static Cell local tidyInfix(e) /* convert OpExp to Expr */ Cell e; { /* :: OpExp */ Cell s = NIL; /* :: [(Op,Exp)] */ Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/ Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/ for (;;) { switch (whatIs(e)) { case ONLY : e = snd(e); while (nonNull(s)) { Cell next = arg(fun(s)); arg(fun(s)) = e; e = s; s = next; } return e; case NEG : if (nonNull(s)) { if (sys==APPLIC) { /* calculate sys */ sys = syntaxOf(textOf(fun(fun(s)))); if (sys==APPLIC) sys=DEF_OPSYNTAX; } if (precOf(sys)==UMINUS_PREC && /* nambig */ assocOf(sys)!=UMINUS_ASSOC) { ERRMSG(row) "Ambiguous use of unary minus with \"%s\"", textToStr(textOf(fun(fun(s)))) EEND; } if (precOf(sys)>UMINUS_PREC) { /* nshift */ Cell e1 = snd(e); Cell t = s; s = arg(fun(s)); while (whatIs(e1)==NEG) e1 = snd(e1); arg(fun(t)) = arg(e1); arg(e1) = t; sys = APPLIC; continue; } } /* Intentional fall-thru for nreduce and isNull(s) */ { Cell prev = e; /* e := tidyNeg e */ Cell temp = arg(prev); Int nneg = 1; for (; whatIs(temp)==NEG; nneg++) { fun(prev) = nameNegate; prev = temp; temp = arg(prev); } if (isInt(arg(temp))) { /* special cases */ if (nneg&1) /* for literals */ arg(temp) = mkInt(-intOf(arg(temp))); } #if BIGNUMS else if (isBignum(arg(temp))) { if (nneg&1) arg(temp) = bigNeg(arg(temp)); } #endif else if (isFloat(arg(temp))) { if (nneg&1) arg(temp) = mkFloat(-floatOf(arg(temp))); } else { fun(prev) = nameNegate; arg(prev) = arg(temp); arg(temp) = e; } e = temp; } continue; default : if (isNull(s)) {/* Move operation onto empty stack */ Cell next = arg(fun(e)); s = e; arg(fun(s)) = NIL; e = next; sys = sye; sye = APPLIC; } else { /* deal with pair of operators */ if (sye==APPLIC) { /* calculate sys and sye */ sye = syntaxOf(textOf(fun(fun(e)))); if (sye==APPLIC) sye=DEF_OPSYNTAX; } if (sys==APPLIC) { sys = syntaxOf(textOf(fun(fun(s)))); if (sys==APPLIC) sys=DEF_OPSYNTAX; } if (precOf(sye)==precOf(sys) && /* ambig */ (assocOf(sye)!=assocOf(sys) || assocOf(sye)==NON_ASS)) { ERRMSG(row) "Ambiguous use of operator \"%s\" with \"%s\"", textToStr(textOf(fun(fun(e)))), textToStr(textOf(fun(fun(s)))) EEND; } if (precOf(sye)>precOf(sys) || /* shift */ (precOf(sye)==precOf(sys) && assocOf(sye)==LEFT_ASS && assocOf(sys)==LEFT_ASS)) { Cell next = arg(fun(e)); arg(fun(e)) = s; s = e; e = next; sys = sye; sye = APPLIC; } else { /* reduce */ Cell next = arg(fun(s)); arg(fun(s)) = arg(e); arg(e) = s; s = next; sys = APPLIC; /* sye unchanged */ } } continue; } } } /*-------------------------------------------------------------------------*/