home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / original / y / parser
Encoding:
Text File  |  1993-02-12  |  25.7 KB  |  757 lines
  1. /* --------------------------------------------------------------------------
  2.  * parser.y:    Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  *              You should expect 14 shift/reduce conflicts when passing
  7.  *              this grammar through yacc.  Don't worry, they will all be
  8.  *              resolved correctly as shifts.
  9.  *
  10.  *        There will also be 5 reduce/reduce conflicts.  These are
  11.  *        more worrying although they will still be resolved correctly
  12.  *        as long as you keep the two grammar rules concerned (see the
  13.  *        y.output file for details) in the same order as used here.
  14.  *
  15.  * Gofer parser (included as part of input.c)
  16.  * ------------------------------------------------------------------------*/
  17.  
  18. %{
  19. #ifndef lint
  20. #define lint
  21. #endif
  22. #define defTycon(n,l,lhs,rhs,w)     tyconDefn(intOf(l),lhs,rhs,w); sp-=n
  23. #define sigdecl(l,vs,t)         ap(SIGDECL,triple(l,vs,t))
  24. #define grded(gs)         ap(GUARDED,gs)
  25. #define letrec(bs,e)         (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
  26. #define yyerror(s)         /* errors handled elsewhere */
  27. #define YYSTYPE             Cell
  28.  
  29. static Cell   local gcShadow     Args((Int,Cell));
  30. static Void   local syntaxError  Args((String));
  31. static String local unexpected   Args((Void));
  32. static Cell   local checkPrec    Args((Cell));
  33. static Void   local fixDefn      Args((Syntax,Cell,Cell,List));
  34. static Void   local setSyntax    Args((Int,Syntax,Cell));
  35. static Cell   local buildTuple   Args((List));
  36. static Cell   local checkClass   Args((Cell));
  37. static List   local checkContext Args((List));
  38. static Cell   local tidyInfix    Args((Cell));
  39.  
  40. /* For the purposes of reasonably portable garbage collection, it is
  41.  * necessary to simulate the YACC stack on the Gofer stack to keep
  42.  * track of all intermediate constructs.  The lexical analyser
  43.  * pushes a token onto the stack for each token that is found, with
  44.  * these elements being removed as reduce actions are performed,
  45.  * taking account of look-ahead tokens as described by gcShadow()
  46.  * below.
  47.  *
  48.  * Of the non-terminals used below, only start, topDecl & begin do not leave
  49.  * any values on the Gofer stack.  The same is true for the terminals
  50.  * EVALEX and SCRIPT.  At the end of a successful parse, there should only
  51.  * be one element left on the stack, containing the result of the parse.
  52.  */
  53.  
  54. #define gc0(e)             gcShadow(0,e)
  55. #define gc1(e)             gcShadow(1,e)
  56. #define gc2(e)             gcShadow(2,e)
  57. #define gc3(e)             gcShadow(3,e)
  58. #define gc4(e)             gcShadow(4,e)
  59. #define gc5(e)             gcShadow(5,e)
  60. #define gc6(e)             gcShadow(6,e)
  61. #define gc7(e)             gcShadow(7,e)
  62.  
  63. %}
  64.  
  65. %token EVALEX    SCRIPT
  66. %token '='       COCO       INFIXL     INFIXR     INFIX      FUNARROW
  67. %token '-'       ','        '@'        '('        ')'        '|'
  68. %token ';'       UPTO       '['        ']'        CASEXP     OF
  69. %token IF        THEN       ELSE       WHERE      TYPE       DATA
  70. %token FROM      '\\'       '~'        LET        IN         '`'
  71. %token VAROP     VARID      NUMLIT     CHARLIT    STRINGLIT  REPEAT
  72. %token CONOP     CONID
  73. %token TCLASS    IMPLIES    TINSTANCE
  74. %token PRIMITIVE
  75.  
  76.                     /* Haskell keywords, for compatibility */
  77. %token DEFAULT     DERIVING   HIDING     IMPORT      INTERFACE  MODULE
  78. %token RENAMING  TO
  79.  
  80. %%
  81. /*- Top level script/module structure -------------------------------------*/
  82.  
  83. start      : EVALEX exp            {inputExpr = $2;        sp-=1;}
  84.       | EVALEX exp wherePart    {inputExpr = letrec($3,$2); sp-=2;}
  85.       | SCRIPT topModule        {valDefns  = $2;        sp-=1;}
  86.       | error            {syntaxError("input");}
  87.       ;
  88.  
  89. /*- Haskell module header/import parsing: ---------------------------------*/
  90. /*  Syntax for Haskell modules (module headers and imports) is parsed but  */
  91. /*  is otherwise ignored by Gofer.  This is for the benefit of those who   */
  92. /*  use Gofer to develop code which will ultimately be fed into a full       */
  93. /*  Haskell system.  (default and deriving are treated in a similar way.)  */
  94. /*                                       */
  95. /*  Note that we do not make any attempt to provide actions that store       */
  96. /*  the parsed structures in any way for later use.               */
  97. /*-------------------------------------------------------------------------*/
  98.  
  99. topModule : begin topDecls close    {$$ = gc2($2);}
  100.       | modules            {$$ = $1;}
  101.       ;
  102. begin      : error            {yyerrok; goOffside(startColumn);}
  103.       ;
  104. topDecls  : topDecls ';' topDecl    {$$ = gc2($1);}
  105.       | topDecls ';' decl        {$$ = gc3(cons($3,$1));}
  106.       | topDecl            {$$ = gc0(NIL);}
  107.       | decl            {$$ = gc1(cons($1,NIL));}
  108.       | error            {syntaxError("definition");}
  109.       ;
  110. modules      : modules module        {$$ = gc2(appendOnto($2,$1));}
  111.       | module            {$$ = $1;}
  112.       ;
  113. module      : MODULE modid expspec WHERE '{' topDecls close
  114.                     {$$ = gc7($6);}
  115.       | MODULE error        {syntaxError("module definition");}
  116.       ;
  117. topDecl      : IMPORT modid impspec rename    {sp-=4;}
  118.       | IMPORT error        {syntaxError("import declaration");}
  119.       ;
  120. modid      : CONID            {$$ = $1;}
  121.       | STRINGLIT            {$$ = $1;}
  122.       ;
  123. expspec      : /* empty */            {$$ = gc0(NIL);}
  124.       | '(' exports ')'        {$$ = gc3(NIL);}
  125.       ;
  126. exports      : exports ',' export        {$$ = gc3(NIL);}
  127.       | export            {$$ = $1;}
  128.       ;
  129. export      : entity            {$$ = $1;}
  130.       | modid UPTO            {$$ = gc2(NIL);}
  131.       ;
  132. impspec      : /* empty */            {$$ = gc0(NIL);}
  133.       | HIDING '(' imports ')'    {$$ = gc4(NIL);}
  134.       | '(' imports0 ')'        {$$ = gc3(NIL);}
  135.       ;
  136. imports0  : /* empty */            {$$ = gc0(NIL);}
  137.       | imports            {$$ = $1;}
  138.       ;
  139. imports      : imports ',' entity        {$$ = gc3(NIL);}
  140.       | entity            {$$ = $1;}
  141.       ;
  142. rename      : /* empty */            {$$ = gc0(NIL);}
  143.       | RENAMING '(' renamings ')'    {$$ = gc4(NIL);}
  144.       ;
  145. renamings : renamings ',' renaming    {$$ = gc3(NIL);}
  146.       | renaming            {$$ = $1;}
  147.       ;
  148. renaming  : var   TO var        {$$ = gc3(NIL);}
  149.       | conid TO conid        {$$ = gc3(NIL);}
  150.       ;
  151. entity      : var                {$$ = $1;}
  152.       | CONID            {$$ = $1;}
  153.       | CONID '(' UPTO ')'        {$$ = gc4(NIL);}
  154.       | CONID '(' conids ')'    {$$ = gc4(NIL);}
  155.       | CONID '(' vars0 ')'        {$$ = gc4(NIL);}
  156.       ;
  157. conids      : conids ',' conid        {$$ = gc3(NIL);}
  158.       | conid            {$$ = $1;}
  159.       ;
  160. vars0      : /* empty */            {$$ = gc0(NIL);}
  161.       | vars            {$$ = $1;}
  162.       ;
  163.  
  164. /*- Type declarations: ----------------------------------------------------*/
  165.  
  166. topDecl      : TYPE typeLhs '=' type invars{defTycon(5,$3,$2,$4,$5);}
  167.       | DATA typeLhs '=' constrs deriving        /* deriving is IGNORED */
  168.                     {defTycon(5,$3,$2,rev($4),DATATYPE);}
  169.       ;
  170. typeLhs      : typeLhs VARID        {$$ = gc2(ap($1,$2));}
  171.       | CONID            {$$ = $1;}
  172.       | error            {syntaxError("type defn lhs");}
  173.       ;
  174. invars      : IN rsvars            {$$ = gc2($2);}
  175.       | /* empty */            {$$ = gc0(SYNONYM);}
  176.       ;
  177. rsvars      : rsvars ',' rsvar        {$$ = gc3(cons($3,$1));}
  178.       | rsvar            {$$ = gc1(cons($1,NIL));}
  179.       ;
  180. rsvar      : var COCO sigType        {$$ = gc3(sigdecl($2,singleton($1),
  181.                                  $3));}
  182.       | var                {$$ = $1;}
  183.       ;
  184. constrs      : constrs '|' constr        {$$ = gc3(cons($3,$1));}
  185.       | constr            {$$ = gc1(cons($1,NIL));}
  186.       ;
  187. constr      : type CONOP type        {$$ = gc3(ap(ap($2,$1),$3));}
  188.       | type            {if (!isCon(getHead($1)))
  189.                          syntaxError("data constructor");
  190.                      $$ = $1;}
  191.       | error            {syntaxError("data type definition");}
  192.       ;
  193. deriving  : /* empty */            {$$ = gc0(NIL);}
  194.       | DERIVING CONID        {$$ = gc2(singleton($2));}
  195.       | DERIVING '(' derivs0 ')'    {$$ = gc4($3);}
  196.       ;
  197. derivs0   : /* empty */            {$$ = gc0(NIL);}
  198.       | derivs            {$$ = $1;}
  199.       ;
  200. derivs      : derivs ',' CONID        {$$ = gc3(cons($3,$1));}
  201.       | CONID            {$$ = gc1(singleton($1));}
  202.       ;
  203.  
  204. /*- Type expressions: -----------------------------------------------------*/
  205. /*  Parser is not sufficently powerful to distinguish between a predicate
  206.  *  such as "Dual a b" and a type "Sum a b", or between a tuple type and
  207.  *  a context (e.g. (Alpha a, Beta b) is a tuple or context?).  For this
  208.  *  reason, individual predicates and contexts are parsed as types, with
  209.  *  additional code to check for well formed context/classes.
  210.  */
  211.  
  212. sigType      : context IMPLIES type    {$$ = gc3(ap(QUAL,pair($1,$3)));}
  213.       | type            {$$ = $1;}
  214.       ;
  215. context      : type            {$$ = gc1(checkContext($1));}
  216.       ;
  217. type      : ctype            {$$ = $1;}
  218.       | ctype FUNARROW type        {$$ = gc3(ap(ap(ARROW,$1),$3));}
  219.       | error            {syntaxError("type expression");}
  220.       ;
  221. ctype      : ctype atype            {$$ = gc2(ap($1,$2));}
  222.       | atype            {$$ = $1;}
  223.       ;
  224. atype      : VARID            {$$ = $1;}
  225.       | CONID            {$$ = $1;}
  226.       | '(' ')'            {$$ = gc2(UNIT);}
  227.       | '(' FUNARROW ')'        {$$ = gc3(ARROW);}
  228.       | '(' type ')'        {$$ = gc3($2);}
  229.       | '(' tupCommas ')'        {$$ = gc3($2);}
  230.       | '(' typeTuple ')'        {$$ = gc3(buildTuple($2));}
  231.       | '[' type ']'        {$$ = gc3(ap(LIST,$2));}
  232.       | '[' ']'            {$$ = gc2(LIST);}
  233.       ;
  234. tupCommas : tupCommas ','        {$$ = gc3(mkTuple(tupleOf($1)+1));}
  235.       | ','                {$$ = gc1(mkTuple(2));}
  236.       ;
  237. typeTuple : typeTuple ',' type        {$$ = gc3(cons($3,$1));}
  238.       | type ',' type        {$$ = gc3(cons($3,cons($1,NIL)));}
  239.       ;
  240.  
  241. /*- Fixity declarations: --------------------------------------------------*/
  242.  
  243. topDecl      : INFIXL optdigit ops        {fixDefn(LEFT_ASS,$1,$2,$3); sp-=3;}
  244.       | INFIXR optdigit ops        {fixDefn(RIGHT_ASS,$1,$2,$3);sp-=3;}
  245.       | INFIX  optdigit ops        {fixDefn(NON_ASS,$1,$2,$3);  sp-=3;}
  246.       ;
  247. optdigit  : NUMLIT            {$$ = gc1(checkPrec($1));}
  248.       | /* empty */            {$$ = gc0(mkInt(DEF_PREC));}
  249.       ;
  250. ops      : ops ',' op            {$$ = gc3(cons($3,$1));}
  251.       | op                {$$ = gc1(cons($1,NIL));}
  252.       ;
  253. op      : varop            {$$ = $1;}
  254.       | conop            {$$ = $1;}
  255.       | '-'                {$$ = gc1(varMinus);}
  256.       ;
  257. varop      : VAROP            {$$ = $1;}
  258.       | '`' VARID '`'        {$$ = gc3($2);}
  259.       ;
  260. conop      : CONOP            {$$ = $1;}
  261.       | '`' CONID '`'        {$$ = gc3($2);}
  262.       ;
  263.  
  264. /*- Processing definitions of primitives ----------------------------------*/
  265.  
  266. topDecl      : PRIMITIVE prims COCO type    {primDefn(intOf($1),$2,$4); sp-=4;}
  267.       ;
  268. prims      : prims ',' prim        {$$ = gc3(cons($3,$1));}
  269.       | prim            {$$ = gc1(cons($1,NIL));}
  270.       | error            {syntaxError("primitive defn");}
  271.       ;
  272. prim      : var STRINGLIT        {$$ = gc2(pair($1,$2));}
  273.       ;
  274.  
  275. /*- Class declarations: ---------------------------------------------------*/
  276.  
  277. topDecl      : TCLASS classHead classBody    {classDefn(intOf($1),$2,$3); sp-=3;}
  278.       | TINSTANCE classHead instBody{instDefn(intOf($1),$2,$3);  sp-=3;}
  279.       | DEFAULT type        {sp-=2;}    /* default is IGNORED  */
  280.       ;
  281. classHead : context IMPLIES type    {$$ = gc3(pair($1,checkClass($3)));}
  282.       | type            {$$ = gc1(pair(NIL,checkClass($1)));}
  283.       ;
  284. classBody : WHERE '{' csigdecls close    {$$ = gc4($3);}
  285.       | /* empty */            {$$ = gc0(NIL);}
  286.       ;
  287. instBody  : WHERE '{' decls close    {$$ = gc4($3);}
  288.       | /* empty */            {$$ = gc0(NIL);}
  289.       ;
  290. csigdecls : csigdecls ';' csigdecl    {$$ = gc3(cons($3,$1));}
  291.       | csigdecl            {$$ = gc1(cons($1,NIL));}
  292.       ;
  293. csigdecl  : vars COCO type        {$$ = gc3(sigdecl($2,$1,$3));}
  294.       | opExp rhs            {$$ = gc2(pair($1,$2));}
  295.       ;
  296.  
  297. /*- Value declarations: ---------------------------------------------------*/
  298.  
  299. decl      : vars COCO sigType        {$$ = gc3(sigdecl($2,$1,$3));}
  300.       | opExp rhs            {$$ = gc2(pair($1,$2));}
  301.       ;
  302. decls      : decls ';' decl        {$$ = gc3(cons($3,$1));}
  303.       | decl            {$$ = gc1(cons($1,NIL));}
  304.       ;
  305. rhs      : rhs1 wherePart        {$$ = gc2(letrec($2,$1));}
  306.       | rhs1            {$$ = $1;}
  307.       | error            {syntaxError("declaration");}
  308.       ;
  309. rhs1      : '=' exp            {$$ = gc2(pair($1,$2));}
  310.       | gdefs            {$$ = gc1(grded(rev($1)));}
  311.       ;
  312. wherePart : WHERE '{' decls close    {$$ = gc4($3);}
  313.       ;
  314. gdefs      : gdefs gdef            {$$ = gc2(cons($2,$1));}
  315.       | gdef            {$$ = gc1(cons($1,NIL));}
  316.       ;
  317. gdef      : '|' exp '=' exp        {$$ = gc4(pair($3,pair($2,$4)));}
  318.       /* Experimental, undocumented syntax for Orwell style guards     */
  319.       /* The corresponding forms for case definitions are NOT supported*/
  320.       /* because that would require a change to the original syntax for*/
  321.           /* Gofer, rather than a simple extension as is the case here.    */
  322.       /* Perhaps a slight reworking of the grammar might eliminate this*/
  323.       /* problem...                               */
  324.       | '=' exp ',' IF exp        {$$ = gc5(pair($1,pair($5,$2)));}
  325.       | '=' exp ',' exp        {$$ = gc4(pair($1,pair($4,$2)));}
  326.       ;
  327. vars      : vars ',' var        {$$ = gc3(cons($3,$1));}
  328.       | var                {$$ = gc1(cons($1,NIL));}
  329.       ;
  330. var      : varid            {$$ = $1;}
  331.       | '(' '-' ')'            {$$ = gc3(varMinus);}
  332.       ;
  333. varid      : VARID            {$$ = $1;}
  334.       | '(' VAROP ')'        {$$ = gc3($2);}
  335.       ;
  336. conid      : CONID            {$$ = $1;}
  337.       | '(' CONOP ')'        {$$ = gc3($2);}
  338.       ;
  339.  
  340. /*- Expressions: ----------------------------------------------------------*/
  341.  
  342. exp      : opExp COCO sigType        {$$ = gc3(ap(ESIGN,pair($1,$3)));}
  343.       | opExp            {$$ = $1;}
  344.       | error            {syntaxError("expression");}
  345.       ; 
  346. opExp      : pfxExp            {$$ = $1;}
  347.       | pfxExp op pfxExp        {$$ = gc3(ap(ap($2,$1),$3));}
  348.       | opExp0            {$$ = gc1(tidyInfix($1));}
  349.       ;
  350. opExp0      : opExp0 op pfxExp        {$$ = gc3(ap(ap($2,$1),$3));}
  351.       | pfxExp op pfxExp op pfxExp    {$$ = gc5(ap(ap($4,
  352.                             ap(ap($2,singleton($1)),
  353.                                                            $3)),$5));}
  354.       ;
  355. pfxExp      : '-' appExp            {if (isInt($2))
  356.                          $$ = gc2(mkInt(-intOf($2)));
  357.                      else
  358.                          $$ = gc2(ap(varNegate,$2));
  359.                     }
  360.       | '\\' pats FUNARROW exp    {$$ = gc4(ap(LAMBDA,
  361.                              pair(rev($2),
  362.                                   pair($3,$4))));}
  363.       | LET '{' decls close IN exp    {$$ = gc6(letrec($3,$6));}
  364.       | IF exp THEN exp ELSE exp    {$$ = gc6(ap(COND,triple($2,$4,$6)));}
  365.       | CASEXP exp OF '{' alts close{$$ = gc6(ap(CASE,pair($2,rev($5))));}
  366.       | appExp            {$$ = $1;}
  367.       ;
  368. pats      : pats atomic            {$$ = gc2(cons($2,$1));}
  369.       | atomic            {$$ = gc1(cons($1,NIL));}
  370.       ;
  371. appExp      : appExp atomic        {$$ = gc2(ap($1,$2));}
  372.       | atomic            {$$ = $1;}
  373.       ;
  374. atomic      : var                {$$ = $1;}
  375.       | var '@' atomic        {$$ = gc3(ap(ASPAT,pair($1,$3)));}
  376.       | '~' atomic            {$$ = gc2(ap(LAZYPAT,$2));}
  377.       | '_'                {$$ = gc1(WILDCARD);}
  378.       | conid            {$$ = $1;}
  379.       | '(' ')'            {$$ = gc2(UNIT);}
  380.       | NUMLIT            {$$ = $1;}
  381.       | CHARLIT            {$$ = $1;}
  382.       | STRINGLIT            {$$ = $1;}
  383.       | REPEAT            {$$ = $1;}
  384.       | '(' exp ')'            {$$ = gc3($2);}
  385.       | '(' exps2 ')'        {$$ = gc3(buildTuple($2));}
  386.       | '[' list ']'        {$$ = gc3($2);}
  387.       | '(' pfxExp op ')'        {$$ = gc4(ap($3,$2));}
  388.       | '(' varop atomic ')'    {$$ = gc4(ap(ap(varFlip,$2),$3));}
  389.       | '(' conop atomic ')'    {$$ = gc4(ap(ap(varFlip,$2),$3));}
  390.       ;
  391. exps2      : exps2 ',' exp        {$$ = gc3(cons($3,$1));}
  392.       | exp ',' exp            {$$ = gc3(cons($3,cons($1,NIL)));}
  393.       ;
  394. alts      : alts ';' alt        {$$ = gc3(cons($3,$1));}
  395.       | alt                {$$ = gc1(cons($1,NIL));}
  396.       ;
  397. alt      : opExp altRhs        {$$ = gc2(pair($1,$2));}
  398.       ;
  399. altRhs      : altRhs1 wherePart        {$$ = gc2(letrec($2,$1));}
  400.       | altRhs1            {$$ = $1;}
  401.       ;
  402. altRhs1      : guardAlts            {$$ = gc1(grded(rev($1)));}
  403.       | FUNARROW exp        {$$ = gc2(pair($1,$2));}
  404.       | error            {syntaxError("case expression");}
  405.       ;
  406. guardAlts : guardAlts guardAlt        {$$ = gc2(cons($2,$1));}
  407.       | guardAlt            {$$ = gc1(cons($1,NIL));}
  408.       ;
  409. guardAlt  : '|' opExp FUNARROW exp    {$$ = gc4(pair($3,pair($2,$4)));}
  410.       ;
  411.  
  412. /*- List Expressions: -------------------------------------------------------*/
  413.  
  414. list      : /* empty */            {$$ = gc0(nameNil);}
  415.       | exp                {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
  416.       | exps2            {$$ = gc1(ap(FINLIST,rev($1)));}
  417.       | exp '|' quals        {$$ = gc3(ap(COMP,pair($1,rev($3))));}
  418.       | exp         UPTO exp    {$$ = gc3(ap(ap(varFromTo,$1),$3));}
  419.       | exp ',' exp UPTO        {$$ = gc4(ap(ap(varFromThen,$1),$3));}
  420.       | exp         UPTO        {$$ = gc2(ap(varFrom,$1));}
  421.       | exp ',' exp UPTO exp    {$$ = gc5(ap(ap(ap(varFromThenTo,
  422.                                                                $1),$3),$5));}
  423.       ;
  424. quals      : quals ',' qual        {$$ = gc3(cons($3,$1));}
  425.       | qual            {$$ = gc1(cons($1,NIL));}
  426.       ;
  427. qual      : exp FROM exp        {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
  428.       | exp '=' exp            {$$ = gc3(ap(QWHERE,
  429.                              singleton(
  430.                             pair($1,pair($2,
  431.                                      $3)))));}
  432.       | exp                {$$ = gc1(ap(BOOLQUAL,$1));}
  433.       | LET '{' decls close        {$$ = gc4(ap(QWHERE,$3));}
  434.       ;
  435.  
  436. /*- Find closing brace ----------------------------------------------------*/
  437.  
  438.                     /* deal with trailing semicolon    */
  439. close      : ';' close1            {$$ = gc2($2);}
  440.       | close1            {$$ = $1;}
  441.       ;
  442. close1      : '}'                {$$ = $1;}
  443.       | error            {yyerrok;
  444.                                          if (canUnOffside()) {
  445.                                              unOffside();
  446.                          /* insert extra token on stack*/
  447.                          push(NIL);
  448.                          pushed(0) = pushed(1);
  449.                          pushed(1) = mkInt(column);
  450.                      }
  451.                                          else
  452.                                              syntaxError("definition");
  453.                                         }
  454.       ;
  455.  
  456. /*-------------------------------------------------------------------------*/
  457.  
  458. %%
  459.  
  460. static Cell local gcShadow(n,e)        /* keep parsed fragments on stack  */
  461. Int  n;
  462. Cell e; {
  463.     /* If a look ahead token is held then the required stack transformation
  464.      * is:
  465.      *   pushed: n               1     0          1     0
  466.      *           x1  |  ...  |  xn  |  la   ===>  e  |  la
  467.      *                                top()            top()
  468.      *
  469.      * Othwerwise, the transformation is:
  470.      *   pushed: n-1             0        0
  471.      *           x1  |  ...  |  xn  ===>  e
  472.      *                         top()     top()
  473.      */
  474.     if (yychar>=0) {
  475.     pushed(n-1) = top();
  476.         pushed(n)   = e;
  477.     }
  478.     else
  479.     pushed(n-1) = e;
  480.     sp -= (n-1);
  481.     return e;
  482. }
  483.  
  484. static Void local syntaxError(s)       /* report on syntax error           */
  485. String s; {
  486.     ERROR(row) "Syntax error in %s (unexpected %s)", s, unexpected()
  487.     EEND;
  488. }
  489.  
  490. static String local unexpected() {    /* find name for unexpected token  */
  491.     static char buffer[100];
  492.     static char *fmt = "%s \"%s\"";
  493.     static char *kwd = "keyword";
  494.     static char *hkw = "(Haskell) keyword";
  495.  
  496.     switch (yychar) {
  497.     case 0           : return "end of input";
  498.  
  499. #define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
  500.     case INFIXL    : keyword("infixl");
  501.     case INFIXR    : keyword("infixr");
  502.     case INFIX     : keyword("infix");
  503.     case TINSTANCE : keyword("instance");
  504.     case TCLASS    : keyword("class");
  505.     case PRIMITIVE : keyword("primitive");
  506.     case CASEXP    : keyword("case");
  507.     case OF        : keyword("of");
  508.     case IF        : keyword("if");
  509.     case THEN      : keyword("then");
  510.     case ELSE      : keyword("else");
  511.     case WHERE     : keyword("where");
  512.     case TYPE      : keyword("type");
  513.     case DATA      : keyword("data");
  514.     case LET       : keyword("let");
  515.     case IN        : keyword("in");
  516. #undef keyword
  517.  
  518. #define hasword(kw) sprintf(buffer,fmt,hkw,kw); return buffer;
  519.     case DEFAULT   : hasword("default");
  520.     case DERIVING  : hasword("deriving");
  521.     case HIDING    : hasword("hiding");
  522.     case IMPORT    : hasword("import");
  523.     case INTERFACE : hasword("interface");
  524.     case MODULE    : hasword("module");
  525.     case RENAMING  : hasword("renaming");
  526.     case TO           : hasword("to");
  527. #undef hasword
  528.  
  529.     case FUNARROW  : return "`->'";
  530.     case '='       : return "`='";
  531.     case COCO      : return "`::'";
  532.     case '-'       : return "`-'";
  533.     case ','       : return "comma";
  534.     case '@'       : return "`@'";
  535.     case '('       : return "`('";
  536.     case ')'       : return "`)'";
  537.     case '|'       : return "`|'";
  538.     case ';'       : return "`;'";
  539.     case UPTO      : return "`..'";
  540.     case '['       : return "`['";
  541.     case ']'       : return "`]'";
  542.     case FROM      : return "`<-'";
  543.     case '\\'      : return "backslash (lambda)";
  544.     case '~'       : return "tilde";
  545.     case '`'       : return "backquote";
  546.     case VAROP     :
  547.     case VARID     :
  548.     case CONOP     :
  549.     case CONID     : sprintf(buffer,"symbol \"%s\"",
  550.                  textToStr(textOf(yylval)));
  551.              return buffer;
  552.     case NUMLIT    : return "numeric literal";
  553.     case CHARLIT   : return "character literal";
  554.     case STRINGLIT : return "string literal";
  555.     case IMPLIES   : return "`=>";
  556.     default           : return "token";
  557.     }
  558. }
  559.  
  560. static Cell local checkPrec(p)         /* Check for valid precedence value */
  561. Cell p; {
  562.     if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
  563.         ERROR(row) "Precedence value must be an integer in the range [%d..%d]",
  564.                    MIN_PREC, MAX_PREC
  565.         EEND;
  566.     }
  567.     return p;
  568. }
  569.  
  570. static Void local fixDefn(a,line,p,ops)/* Declare syntax of operators      */
  571. Syntax a;
  572. Cell   line;
  573. Cell   p;
  574. List   ops; {
  575.     Int l = intOf(line);
  576.     a     = mkSyntax(a,intOf(p));
  577.     map2Proc(setSyntax,l,a,ops);
  578. }
  579.  
  580. static Void local setSyntax(line,sy,op)/* set syntax of individ. operator  */
  581. Int    line;
  582. Syntax sy;
  583. Cell   op; {
  584.     addSyntax(line,textOf(op),sy);
  585.     opDefns = cons(op,opDefns);
  586. }
  587.  
  588. static Cell local buildTuple(tup)      /* build tuple (x1,...,xn) from list*/
  589. List tup; {                            /* [xn,...,x1]                      */
  590.     Int  n = 0;
  591.     Cell t = tup;
  592.     Cell x;
  593.  
  594.     do {                               /*     .                    .       */
  595.         x      = fst(t);               /*    / \                  / \      */
  596.         fst(t) = snd(t);               /*   xn  .                .   xn    */
  597.         snd(t) = x;                    /*        .    ===>      .          */
  598.         x      = t;                    /*         .            .           */
  599.         t      = fun(x);               /*          .          .            */
  600.         n++;                           /*         / \        / \           */
  601.     } while (nonNull(t));              /*        x1  NIL   (n)  x1         */
  602.     fst(x) = mkTuple(n);
  603.     return tup;
  604. }
  605.  
  606. /* The yacc parser presented above is not sufficiently powerful to
  607.  * determine whether a tuple at the front of a sigType is part of a
  608.  * context:    e.g. (Eq a, Num a) => a -> a -> a
  609.  * or a type:  e.g.  (Tree a, Tree a) -> Tree a
  610.  *
  611.  * Rather than complicate the grammar, both are parsed as tuples of types,
  612.  * using the following checks afterwards to ensure that the correct syntax
  613.  * is used in the case of a tupled context.
  614.  */
  615.  
  616. static List local checkContext(con)    /* validate type class context       */
  617. Type con; {
  618.     if (con==UNIT)            /* allows empty context ()       */
  619.     return NIL;
  620.     else if (whatIs(getHead(con))==TUPLE) {
  621.     List qs = NIL;
  622.  
  623.     while (isAp(con)) {        /* undo work of buildTuple  :-(    */
  624.         Cell temp = fun(con);
  625.         fun(con)  = arg(con);
  626.         arg(con)  = qs;
  627.         qs          = con;
  628.         con       = temp;
  629.         checkClass(hd(qs));
  630.     }
  631.     return qs;
  632.     }
  633.     else                /* single context expression       */
  634.     return singleton(checkClass(con));
  635. }
  636.  
  637. static Cell local checkClass(c)        /* check that type expr is a class */
  638. Cell c; {                /* constrnt of the form C t1 .. tn */
  639.     Cell cn = getHead(c);
  640.  
  641.     if (!isCon(cn))
  642.     syntaxError("class expression");
  643.     else if (argCount<1) {
  644.     ERROR(row) "Class \"%s\" must have at least one argument",
  645.            textToStr(textOf(cn))
  646.     EEND;
  647.     }
  648.     return c;
  649. }
  650.  
  651. /* expressions involving a sequence of two or more infix operator symbols
  652.  * are parsed as elements of type:
  653.  *    InfixExpr ::= [Expr]
  654.  *         |  ap(ap(Operator,InfixExpr),Expr)
  655.  *
  656.  * thus x0 +1 x1 ... +n xn is parsed as: +n (....(+1 [x0] x1)....) xn
  657.  *
  658.  * Once the expression has been completely parsed, this parsed form is
  659.  * `tidied' according to the precedences and associativities declared for
  660.  * each operator symbol.
  661.  *
  662.  * The tidy process uses a `stack' of type:
  663.  *    TidyStack ::= ap(ap(Operator,TidyStack),Expr)
  664.  *         |  NIL
  665.  * when the ith layer of an InfixExpr has been transferred to the stack, the
  666.  * stack is of the form: +i (....(+n NIL xn)....) xi
  667.  *
  668.  * The tidy function is based on a simple shift-reduce parser:
  669.  *
  670.  *  tidy                :: InfixExpr -> TidyStack -> Expr
  671.  *  tidy [m]   ss        = foldl (\x f-> f x) m ss
  672.  *  tidy (m*n) []        = tidy m [(*n)]
  673.  *  tidy (m*n) ((+o):ss)
  674.  *           | amb     = error "Ambiguous"
  675.  *           | shift   = tidy m ((*n):(+o):ss)
  676.  *           | reduce  = tidy (m*(n+o)) ss
  677.  *               where sye     = syntaxOf (*)
  678.  *                 (ae,pe) = sye
  679.  *                 sys     = syntaxOf (+)
  680.  *                 (as,ps) = sys
  681.  *                 amb     = pe==ps && (ae/=as || ae==NON_ASS)
  682.  *                 shift   = pe>ps || (ps==pe && ae==LEFT_ASS)
  683.  *                 reduce  = otherwise
  684.  *
  685.  * N.B. the conditions amb, shift, reduce are NOT mutually exclusive and
  686.  * must be tested in that order.
  687.  *
  688.  * As a concession to efficiency, we lower the number of calls to syntaxOf
  689.  * by keeping track of the values of sye, sys throughout the process.  The
  690.  * value APPLIC is used to indicate that the syntax value is unknown.
  691.  */
  692.  
  693. static Cell local tidyInfix(e)         /* convert InfixExpr to Expr        */
  694. Cell e; {                              /* :: InfixExpr                     */
  695.     Cell   s   = NIL;                  /* :: TidyStack                     */
  696.     Syntax sye = APPLIC;               /* Syntax of op in e (init unknown) */
  697.     Syntax sys = APPLIC;               /* Syntax of op in s (init unknown) */
  698.     Cell   temp;
  699.  
  700.     while (nonNull(tl(e))) {
  701.         if (isNull(s)) {
  702.             s           = e;
  703.             e           = arg(fun(s));
  704.             arg(fun(s)) = NIL;
  705.             sys         = sye;
  706.             sye         = APPLIC;
  707.         }
  708.         else {
  709.             if (sye==APPLIC) {         /* calculate sye (if unknown)       */
  710.                 sye = syntaxOf(textOf(fun(fun(e))));
  711.                 if (sye==APPLIC) sye=DEF_OPSYNTAX;
  712.             }
  713.             if (sys==APPLIC) {         /* calculate sys (if unknown)       */
  714.                 sys = syntaxOf(textOf(fun(fun(s))));
  715.                 if (sys==APPLIC) sys=DEF_OPSYNTAX;
  716.             }
  717.  
  718.             if (precOf(sye)==precOf(sys) &&                      /* amb    */
  719.                    (assocOf(sye)!=assocOf(sys) || assocOf(sye)==NON_ASS)) {
  720.                 ERROR(row) "Ambiguous use of operator \"%s\" with \"%s\"",
  721.                            textToStr(textOf(fun(fun(e)))),
  722.                            textToStr(textOf(fun(fun(s))))
  723.                 EEND;
  724.             }
  725.             else if (precOf(sye)>precOf(sys) ||                  /* shift  */
  726.                        (precOf(sye)==precOf(sys) && assocOf(sye)==LEFT_ASS)) {
  727.                 temp        = arg(fun(e));
  728.                 arg(fun(e)) = s;
  729.                 s           = e;
  730.                 e           = temp;
  731.                 sys         = sye;
  732.                 sye         = APPLIC;
  733.             }
  734.             else {                                               /* reduce */
  735.                 temp        = arg(fun(s));
  736.                 arg(fun(s)) = arg(e);
  737.                 arg(e)      = s;
  738.                 s           = temp;
  739.                 sys         = APPLIC;
  740.                 /* sye unchanged */
  741.             }
  742.         }
  743.     }
  744.  
  745.     e = hd(e);
  746.     while (nonNull(s)) {
  747.         temp        = arg(fun(s));
  748.         arg(fun(s)) = e;
  749.         e           = s;
  750.         s           = temp;
  751.     }
  752.  
  753.     return e;
  754. }
  755.  
  756. /*-------------------------------------------------------------------------*/
  757.