lang/m2/comp/declar.g

   1 /*
   2  * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
   3  * See the copyright notice in the ACK home directory, in the file "Copyright".
   4  *
   5  * Author: Ceriel J.H. Jacobs
   6  */
   7
   8 /* D E C L A R A T I O N S */
   9
  10 /* $Id: declar.g,v 1.82 1994/06/24 12:40:18 ceriel Exp $ */
  11
  12 {
  13 #include        "debug.h"
  14
  15 #include        <em_arith.h>
  16 #include        <em_label.h>
  17 #include        <alloc.h>
  18 #include        <assert.h>
  19
  20 #include        "strict3rd.h"
  21 #include        "idf.h"
  22 #include        "LLlex.h"
  23 #include        "def.h"
  24 #include        "type.h"
  25 #include        "scope.h"
  26 #include        "node.h"
  27 #include        "misc.h"
  28 #include        "main.h"
  29 #include        "chk_expr.h"
  30 #include        "warning.h"
  31 #include        "nostrict.h"
  32
  33 int             proclevel = 0;          /* nesting level of procedures */
  34 int             return_occurred;        /* set if a return occurs in a block */
  35
  36 extern t_node   *EmptyStatement;
  37
  38 #define needs_static_link()     (proclevel > 1)
  39 }
  40
  41 /* inline in declaration: need space
  42  * ProcedureDeclaration
  43  * {
  44  *      t_def *df;
  45  * } :
  46  *                      {       ++proclevel; }
  47  *      ProcedureHeading(&df, D_PROCEDURE)
  48  *      ';' block(&(df->prc_body))
  49  *      IDENT
  50  *                      {       EndProc(df, dot.TOK_IDF);
  51  *                              --proclevel;
  52  *                      }
  53  * ;
  54 */
  55
  56 ProcedureHeading(t_def **pdf; int type;)
  57 {
  58         t_type  *tp = 0;
  59         arith   parmaddr = needs_static_link() ? pointer_size : 0;
  60         t_param *pr = 0;
  61 } :
  62         PROCEDURE IDENT
  63                         { *pdf = DeclProc(type, dot.TOK_IDF); }
  64         [
  65                 '('
  66                 [
  67                         FPSection(&pr, &parmaddr)
  68                         [
  69                                 ';' FPSection(&pr, &parmaddr)
  70                         ]*
  71                 |
  72                 ]
  73                 ')'
  74                 [       ':' qualtype(&tp)
  75                 |
  76                 ]
  77         |
  78         ]
  79                         { CheckWithDef(*pdf, proc_type(tp, pr, parmaddr));
  80 #ifndef NOSTRICT
  81                           if (tp && IsConstructed(tp)) {
  82 warning(W_STRICT, "procedure \"%s\" has a constructed result type",
  83         (*pdf)->df_idf->id_text);
  84                           }
  85 #endif
  86                         }
  87 ;
  88
  89 block(t_node **pnd;) :
  90         [       %persistent
  91                 declaration
  92         ]*
  93                         { return_occurred = 0; }
  94         [       %default
  95                 BEGIN
  96                 StatementSequence(pnd)
  97         |
  98                         { *pnd = EmptyStatement; }
  99         ]
 100         END
 101 ;
 102
 103 declaration
 104 {
 105         t_def *df;
 106 } :
 107         CONST [ ConstantDeclaration ';' ]*
 108 |
 109         TYPE [ TypeDeclaration ';' ]*
 110 |
 111         VAR [ VariableDeclaration ';' ]*
 112 |
 113                         {       ++proclevel; }
 114         ProcedureHeading(&df, D_PROCEDURE)
 115                         {
 116                         }
 117         ';'
 118         block(&(df->prc_body))
 119         IDENT
 120                         {
 121                                 EndProc(df, dot.TOK_IDF);
 122                                 --proclevel;
 123                         }
 124         ';'
 125 |
 126         ModuleDeclaration ';'
 127 ;
 128
 129 /* inline in procedureheading: need space
 130  * FormalParameters(t_param **ppr; arith *parmaddr; t_type **ptp;):
 131  *      '('
 132  *      [
 133  *              FPSection(ppr, parmaddr)
 134  *              [
 135  *                      ';' FPSection(ppr, parmaddr)
 136  *              ]*
 137  *      |
 138  *      ]
 139  *      ')'
 140  *      [       ':' qualtype(ptp)
 141  *      |
 142  *      ]
 143  * ;
 144 */
 145
 146 FPSection(t_param **ppr; arith *parmaddr;)
 147 {
 148         t_node  *FPList;
 149         t_type  *tp;
 150         int     VARp;
 151 } :
 152         var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
 153                         { EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
 154 ;
 155
 156 FormalType(t_type **ptp;)
 157                 /* index type of conformant array is "CARDINAL".
 158                    Recognize a conformant array by size 0.
 159                 */
 160 {       register t_type *tp;
 161 } :
 162         ARRAY OF
 163                 { tp = construct_type(T_ARRAY, card_type); }
 164         qualtype(&(tp->arr_elem))
 165                 { ArrayElSize(tp);
 166                   *ptp = tp;
 167                 }
 168 |
 169         qualtype(ptp)
 170 ;
 171
 172 TypeDeclaration
 173 {
 174         t_def *df;
 175         t_type *tp;
 176         register t_node *nd;
 177 }:
 178         IDENT           { df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
 179                           nd = dot2leaf(Name);
 180                         }
 181         '=' type(&tp)
 182                         { DeclareType(nd, df, tp);
 183                           FreeNode(nd);
 184                         }
 185 ;
 186
 187 type(register t_type **ptp;):
 188         %default SimpleType(ptp)
 189 |
 190         ArrayType(ptp)
 191 |
 192         RecordType(ptp)
 193 |
 194         SetType(ptp)
 195 |
 196         PointerType(ptp)
 197 |
 198         ProcedureType(ptp)
 199 ;
 200
 201 SimpleType(register t_type **ptp;) :
 202         qualtype(ptp)
 203         [
 204                 /* nothing */
 205         |
 206                 SubrangeType(ptp)
 207                 /* The subrange type is given a base type by the
 208                    qualident (this is new modula-2).
 209                 */
 210         ]
 211 |
 212         enumeration(ptp)
 213 |                       { *ptp = 0;     /* no qualification */ }
 214         SubrangeType(ptp)
 215 ;
 216
 217 enumeration(t_type **ptp;)
 218 {
 219         t_node *EnumList;
 220 } :
 221         '(' IdentList(&EnumList) ')'
 222                 { *ptp = enum_type(EnumList); }
 223 ;
 224
 225 IdentList(t_node **p;)
 226 {
 227         register t_node *q;
 228 } :
 229         IDENT           { *p = q = dot2leaf(Select); }
 230         [ %persistent
 231                 ',' IDENT
 232                         { q->nd_NEXT = dot2leaf(Select);
 233                           q = q->nd_NEXT;
 234                         }
 235         ]*
 236 ;
 237
 238 SubrangeType(t_type **ptp;)
 239 {
 240         t_node *nd1, *nd2;
 241 }:
 242         /*
 243            This is not exactly the rule in the new report, but see
 244            the rule for "SimpleType".
 245         */
 246         '[' ConstExpression(&nd1)
 247         UPTO ConstExpression(&nd2)
 248         ']'
 249                         { *ptp = subr_type(nd1, nd2, *ptp);
 250                           FreeNode(nd1);
 251                           FreeNode(nd2);
 252                         }
 253 ;
 254
 255 ArrayType(t_type **ptp;)
 256 {
 257         t_type *tp;
 258         register t_type *tp1, *tp2;
 259 } :
 260         ARRAY SimpleType(&tp)
 261                         { tp1 = tp2 = construct_type(T_ARRAY, tp); }
 262         [
 263                 ',' SimpleType(&tp)
 264                         { tp2->arr_elem = construct_type(T_ARRAY, tp);
 265                           tp2 = tp2->arr_elem;
 266                         }
 267         ]* OF type(&tp)
 268                         { tp2->arr_elem = tp;
 269                           ArraySizes(tp1);
 270                           *ptp = tp1;
 271                         }
 272 ;
 273
 274 RecordType(t_type **ptp;)
 275 {
 276         register t_scope *scope;
 277         arith size = 0;
 278         int xalign = struct_align;
 279 }
 280 :
 281         RECORD
 282                 { scope = open_and_close_scope(OPENSCOPE); }
 283         FieldListSequence(scope, &size, &xalign)
 284                 { if (size == 0) {
 285                         warning(W_ORDINARY, "empty record declaration");
 286                         size = 1;
 287                   }
 288                   *ptp = standard_type(T_RECORD, xalign, align(size, xalign));
 289                   (*ptp)->rec_scope = scope;
 290                   Reverse(&(scope->sc_def));
 291                 }
 292         END
 293 ;
 294
 295 FieldListSequence(t_scope *scope; arith *cnt; int *palign;):
 296         FieldList(scope, cnt, palign)
 297         [
 298                 ';' FieldList(scope, cnt, palign)
 299         ]*
 300 ;
 301
 302 FieldList(t_scope *scope; arith *cnt; int *palign;)
 303 {
 304         t_node *FldList;
 305         t_type *tp;
 306         t_node *nd;
 307         register t_def *df;
 308         arith tcnt, max;
 309 } :
 310 [
 311         IdentList(&FldList) ':' type(&tp)
 312                         {
 313                           *palign = lcm(*palign, tp->tp_align);
 314                           EnterFieldList(FldList, tp, scope, cnt);
 315                         }
 316 |
 317         CASE
 318         /* Also accept old fashioned Modula-2 syntax, but give a warning.
 319            Sorry for the complicated code.
 320         */
 321         [ qualident(&nd)
 322           [ ':' qualtype(&tp)
 323                         /* This is correct, in both kinds of Modula-2, if
 324                            the first qualident is a single identifier.
 325                         */
 326                         { if (nd->nd_class != Name) {
 327                                 error("illegal variant tag");
 328                           }
 329                           else {
 330                                 df = define(nd->nd_IDF, scope, D_FIELD);
 331                                 *palign = lcm(*palign, tp->tp_align);
 332                                 if (!(tp->tp_fund & T_DISCRETE)) {
 333                                         error("illegal type in variant");
 334                                 }
 335                                 df->df_type = tp;
 336                                 df->fld_off = align(*cnt, tp->tp_align);
 337                                 *cnt = df->fld_off + tp->tp_size;
 338                                 df->df_flags |= D_QEXPORTED;
 339                           }
 340                           FreeNode(nd);
 341                         }
 342           |             /* Old fashioned! the first qualident now represents
 343                            the type
 344                         */
 345                         {
 346 #ifndef STRICT_3RD_ED
 347                           if (! options['3']) warning(W_OLDFASHIONED,
 348                               "old fashioned Modula-2 syntax; ':' missing");
 349                           else
 350 #endif
 351                           error("':' missing");
 352                           tp = qualified_type(&nd);
 353                         }
 354           ]
 355         | ':' qualtype(&tp)
 356           /* Aha, third edition. Well done! */
 357         ]
 358                         { tcnt = *cnt; }
 359         OF variant(scope, &tcnt, tp, palign)
 360                         { max = tcnt; tcnt = *cnt; }
 361         [
 362           '|' variant(scope, &tcnt, tp, palign)
 363                         { if (tcnt > max) max = tcnt; tcnt = *cnt; }
 364         ]*
 365         [ ELSE FieldListSequence(scope, &tcnt, palign)
 366                         { if (tcnt > max) max = tcnt; }
 367         |
 368         ]
 369         END
 370                         { *cnt = max; }
 371 |
 372 ]
 373 ;
 374
 375 variant(t_scope *scope; arith *cnt; t_type *tp; int *palign;)
 376 {
 377         t_node *nd;
 378 } :
 379         [
 380                 CaseLabelList(&tp, &nd)
 381                         { /* Ignore the cases for the time being.
 382                              Maybe a checking version will be supplied
 383                              later ???
 384                           */
 385                           FreeNode(nd);
 386                         }
 387                 ':' FieldListSequence(scope, cnt, palign)
 388         |
 389         ]
 390                         /* Changed rule in new modula-2 */
 391 ;
 392
 393 CaseLabelList(t_type **ptp; t_node **pnd;):
 394         CaseLabels(ptp, pnd)
 395         [
 396                         { *pnd = dot2node(Link, *pnd, NULLNODE); }
 397                 ',' CaseLabels(ptp, &((*pnd)->nd_RIGHT))
 398                         { pnd = &((*pnd)->nd_RIGHT); }
 399         ]*
 400 ;
 401
 402 CaseLabels(t_type **ptp; register t_node **pnd;)
 403 {
 404         register t_node *nd;
 405 }:
 406         ConstExpression(pnd)
 407                         {
 408                           if (*ptp != 0) {
 409                                 t_type *tp = intorcard(*ptp,
 410                                         BaseType((*pnd)->nd_type));
 411                                 if (tp) *ptp = tp;
 412                                 ChkCompat(pnd, *ptp, "case label");
 413                           }
 414                           nd = *pnd;
 415                           nd->nd_type = BaseType(nd->nd_type);  /* ??? */
 416                           if (! (nd->nd_type->tp_fund & T_DISCRETE) ||
 417                               nd->nd_type->tp_size > word_size) {
 418                                 node_error(nd, "illegal type in case label");
 419                           }
 420                         }
 421         [
 422                 UPTO    { *pnd = nd = dot2node(Link,nd,NULLNODE);
 423                           nd->nd_type = nd->nd_LEFT->nd_type;
 424                         }
 425                 ConstExpression(&(*pnd)->nd_RIGHT)
 426                         { if (!ChkCompat(&((*pnd)->nd_RIGHT), nd->nd_type,
 427                                          "case label")) {
 428                                 nd->nd_type = error_type;
 429                           }
 430                           else if (! chk_bounds(nd->nd_LEFT->nd_INT,
 431                                                 nd->nd_RIGHT->nd_INT,
 432                                                 nd->nd_type->tp_fund)) {
 433                             node_error(nd,
 434                            "lower bound exceeds upper bound in case label range");
 435                           }
 436
 437                         }
 438         |
 439         ]
 440                         {
 441                           *ptp = nd->nd_type;
 442                         }
 443 ;
 444
 445 SetType(t_type **ptp;)
 446 {       t_type *tp;
 447 } :
 448         SET OF SimpleType(&tp)
 449                         { *ptp = set_type(tp); }
 450 ;
 451
 452 /*      In a pointer type definition, the type pointed at does not
 453         have to be declared yet, so be careful about identifying
 454         type-identifiers.
 455 */
 456 PointerType(register t_type **ptp;)
 457 {       register t_type *tp;
 458 } :
 459                         { tp = construct_type(T_POINTER, NULLTYPE); }
 460         POINTER TO
 461         [ %if   (type_or_forward(tp))
 462           type(&(tp->tp_next))
 463         |
 464           IDENT
 465         ]
 466                         { *ptp = tp; }
 467 ;
 468
 469 qualtype(t_type **ptp;)
 470 {
 471         t_node *nd;
 472 } :
 473         qualident(&nd)
 474                 { *ptp = qualified_type(&nd); }
 475 ;
 476
 477 ProcedureType(t_type **ptp;)
 478 {
 479         t_param *pr = 0;
 480         arith parmaddr = 0;
 481         t_type *tp = 0;
 482 } :
 483         PROCEDURE
 484         [
 485                 FormalTypeList(&pr, &parmaddr, &tp)
 486         |
 487         ]
 488                         { *ptp = proc_type(tp, pr, parmaddr); }
 489 ;
 490
 491 FormalTypeList(t_param **ppr; arith *pparmaddr; t_type **ptp;) :
 492         '('
 493         [
 494                 VarFormalType(ppr, pparmaddr)
 495                 [
 496                         ',' VarFormalType(ppr, pparmaddr)
 497                 ]*
 498         |
 499         ]
 500         ')'
 501         [ ':' qualtype(ptp)
 502         |
 503         ]
 504 ;
 505
 506 VarFormalType(t_param **ppr; arith *pparmaddr;)
 507 {
 508         t_type *tp;
 509         int isvar;
 510 } :
 511         var(&isvar)
 512         FormalType(&tp)
 513                         { EnterParamList(ppr,NULLNODE,tp,isvar,pparmaddr); }
 514 ;
 515
 516 var(int *VARp;) :
 517         [
 518                 VAR             { *VARp = D_VARPAR; }
 519         |
 520                 /* empty */     { *VARp = D_VALPAR; }
 521         ]
 522 ;
 523
 524 ConstantDeclaration
 525 {
 526         t_idf *id;
 527         t_node *nd;
 528         register t_def *df;
 529 }:
 530         IDENT           { id = dot.TOK_IDF; }
 531         '=' ConstExpression(&nd)
 532                         { df = define(id,CurrentScope,D_CONST);
 533                           df->con_const = nd->nd_token;
 534                           df->df_type = nd->nd_type;
 535                           FreeNode(nd);
 536                         }
 537 ;
 538
 539 VariableDeclaration
 540 {
 541         t_node *VarList;
 542         register t_node *nd;
 543         t_type *tp;
 544 } :
 545         IdentAddr(&VarList)
 546                         { nd = VarList; }
 547         [ %persistent
 548                 ',' IdentAddr(&(nd->nd_RIGHT))
 549                         { nd = nd->nd_RIGHT; }
 550         ]*
 551         ':' type(&tp)
 552                         { EnterVarList(VarList, tp, proclevel > 0); }
 553 ;
 554
 555 IdentAddr(t_node **pnd;)
 556 {
 557         register t_node *nd;
 558 } :
 559         IDENT           { nd = dot2leaf(Name);
 560                           *pnd = dot2node(Link, nd, NULLNODE);
 561                         }
 562         [       '['
 563                 ConstExpression(&(nd->nd_NEXT))
 564                 ']'
 565         |
 566         ]
 567 ;