开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 编译器/解释器 > 查看源码
decl.c.2
资源名称：pascal2c.tar.Z　[点击查看]
上传用户：upcnvip
上传日期：2007-01-06
资源大小：474k
文件大小：48k
源码类别：

编译器/解释器

开发平台：

C/C++

decl.c.2：源码内容
  1.             return 0;
  2.     }
  3.     if (args) {
  4.         if (mp1->kind == MK_PARAM && mp1->othername)
  5.             tp1 = mp1->rectype;
  6.         if (mp2->kind == MK_PARAM && mp2->othername)
  7.             tp2 = mp2->rectype;
  8.     }
  9.     if (tp1 == tp2)
  10.         return 1;
  11.     switch (mixtypes) {
  12.         case 0:
  13.             return 0;
  14.         case 1:
  15.             return (findbasetype(tp1, flags) == findbasetype(tp2, flags));
  16.         default:
  17.             if (findbasetype(tp1, flags) != findbasetype(tp2, flags))
  18. return 0;
  19.             while (tp1->kind == TK_POINTER && tp1->basetype)
  20.                 tp1 = tp1->basetype;
  21.             while (tp2->kind == TK_POINTER && tp2->basetype)
  22.                 tp2 = tp2->basetype;
  23.             return (tp1 == tp2);
  24.     }
  25. }
  29. void declarefiles(fnames)
  30. Strlist *fnames;
  31. {
  32.     Meaning *mp;
  33.     char *cp;
  35.     while (fnames) {
  36. mp = (Meaning *)fnames->value;
  37. if (mp->kind == MK_VAR || mp->kind == MK_FIELD) {
  38.     if (mp->namedfile) {
  39. output(storageclassname(varstorageclass(mp)));
  40. output(format_ss("%s %s", charname,
  41.  format_s(name_FNVAR, fnames->s)));
  42. output(format_s("[%s];n", *name_FNSIZE ? name_FNSIZE : "80"));
  43.     }
  44.     if (mp->bufferedfile && *declbufname) {
  45. cp = format_s("%s", storageclassname(varstorageclass(mp)));
  46. if (*cp && isspace(cp[strlen(cp)-1]))
  47.   cp[strlen(cp)-1] = 0;
  48. if (*cp || !*declbufncname) {
  49.     output(declbufname);
  50.     output("(");
  51.     output(fnames->s);
  52.     output(",");
  53.     output(cp);
  54. } else {
  55.     output(declbufncname);
  56.     output("(");
  57.     output(fnames->s);
  58. }
  59. output(",");
  60. out_type(mp->type->basetype->basetype, 1);
  61. output(");n");
  62.     }
  63. }
  64. strlist_eat(&fnames);
  65.     }
  66. }
  70. char *variantfieldname(num)
  71. int num;
  72. {
  73.     if (num >= 0)
  74.         return format_d("U%d", num);
  75.     else
  76.         return format_d("UM%d", -num);
  77. }
  80. int record_is_union(tp)
  81. Type *tp;
  82. {
  83.     return (tp->fbase && tp->fbase->kind == MK_VARIANT);
  84. }
  87. void outfieldlist(mp)
  88. Meaning *mp;
  89. {
  90.     Meaning *mp0;
  91.     int num, only_union, empty, saveindent, saveindent2;
  92.     Strlist *fnames, *fn;
  94.     if (!mp) {
  95. output("int empty_struct;   /* Pascal record was empty */n");
  96. return;
  97.     }
  98.     only_union = (mp && mp->kind == MK_VARIANT);
  99.     fnames = NULL;
  100.     while (mp && mp->kind == MK_FIELD) {
  101. flushcomments(&mp->comments, CMT_PRE, -1);
  102. output(storageclassname(varstorageclass(mp) & 0x10));
  103.         outbasetype(mp->type, 0);
  104.         output(" 05");
  105. for (;;) {
  106.     outdeclarator(mp->type, mp->name, 0);
  107.     if (mp->val.i && (mp->type != tp_abyte || mp->val.i != 8))
  108. output(format_d(" : %d", mp->val.i));
  109.     if (isfiletype(mp->type)) {
  110. fn = strlist_append(&fnames, mp->name);
  111. fn->value = (long)mp;
  112.     }
  113.     mp->wasdeclared = 1;
  114.     if (!mp->cnext || mp->cnext->kind != MK_FIELD ||
  115. varstorageclass(mp) != varstorageclass(mp->cnext) ||
  116. !mixable(mp, mp->cnext, 0, 0))
  117. break;
  118.             mp = mp->cnext;
  119.             output(",01 ");
  120.         }
  121.         output(";");
  122. outtrailcomment(mp->comments, -1, declcommentindent);
  123. flushcomments(&mp->comments, -1, -1);
  124.         mp = mp->cnext;
  125.     }
  126.     declarefiles(fnames);
  127.     if (mp) {
  128. saveindent = outindent;
  129. empty = 1;
  130.         if (!only_union) {
  131.             output("union {n");
  132.     moreindent(tabsize);
  133.     moreindent(structindent);
  134.         }
  135.         while (mp) {
  136.             mp0 = mp->ctx;
  137.             num = ord_value(mp->val);
  138.             while (mp && mp->ctx == mp0)
  139.                 mp = mp->cnext;
  140.             if (mp0) {
  141. empty = 0;
  142.                 if (!mp0->cnext && mp0->kind == MK_FIELD) {
  143.                     outfieldlist(mp0);
  144.                 } else {
  145.                     if (mp0->kind == MK_VARIANT)
  146.                         output("union {n");
  147.                     else
  148.                         output("struct {n");
  149.     saveindent2 = outindent;
  150.     moreindent(tabsize);
  151.     moreindent(structindent);
  152.                     outfieldlist(mp0);
  153.     outindent = saveindent2;
  154.                     output("} ");
  155.                     output(format_s(name_VARIANT, variantfieldname(num)));
  156.                     output(";n");
  157.                 }
  158. flushcomments(&mp0->comments, -1, -1);
  159.             }
  160.         }
  161. if (empty)
  162.     output("int empty_union;   /* Pascal variant record was empty */n");
  163.         if (!only_union) {
  164.             outindent = saveindent;
  165.             output("} ");
  166.             output(format_s(name_UNION, ""));
  167.             output(";n");
  168.         }
  169.     }
  170. }
  174. void outbasetype(type, flags)
  175. Type *type;
  176. int flags;
  177. {
  178.     Meaning *mp;
  179.     int saveindent;
  181.     type = findbasetype(type, flags);
  182.     switch (type->kind) {
  184.         case TK_INTEGER:
  185.             if (type == tp_uint) {
  186.                 output("unsigned");
  187.             } else if (type == tp_sint) {
  188.                 if (useAnyptrMacros == 1)
  189.                     output("Signed int");
  190.                 else if (hassignedchar)
  191.                     output("signed int");
  192.                 else
  193.                     output("int");   /* will sign-extend by hand */
  194.             } else if (type == tp_unsigned) {
  195.                 output("unsigned long");
  196.             } else if (type != tp_int)
  197.                 output(integername);
  198.             else
  199.                 output("int");
  200.             break;
  202.         case TK_SUBR:
  203.             if (type == tp_special_anyptr) {
  204.                 output("Anyptr");
  205.             } else if (type == tp_abyte) {
  206.                 output("char");
  207.             } else if (type == tp_ubyte) {
  208.                 output(ucharname);
  209.             } else if (type == tp_sbyte) {
  210.                 output(scharname);
  211.                 if (signedchars != 1 && !hassignedchar)
  212.                     note("'signed char' may not be valid in all compilers [102]");
  213.             } else {
  214.                 if (type == tp_ushort)
  215.                     output("unsigned ");
  216.                 output("short");
  217.             }
  218.             break;
  220.         case TK_CHAR:
  221.             if (type == tp_uchar) {
  222.                 output(ucharname);
  223.             } else if (type == tp_schar) {
  224.                 output(scharname);
  225.                 if (signedchars != 1 && !hassignedchar)
  226.                     note("'signed char' may not be valid in all compilers [102]");
  227.     } else
  228. output(charname);
  229.             break;
  231.         case TK_BOOLEAN:
  232.             output((*name_BOOLEAN) ? name_BOOLEAN : ucharname);
  233.             break;
  235.         case TK_REAL:
  236.     if (type == tp_longreal)
  237. output("double");
  238.     else
  239. output("float");
  240.             break;
  242.         case TK_VOID:
  243.             if (ansiC == 0)
  244.                 output("int");
  245.             else if (useAnyptrMacros == 1)
  246.                 output("Void");
  247.             else
  248.                 output("void");
  249.             break;
  251.         case TK_PROCPTR:
  252.     output(name_PROCEDURE);
  253.     break;
  255.         case TK_FILE:
  256.             output("FILE");
  257.             break;
  259. case TK_SPECIAL:
  260.     if (type == tp_jmp_buf)
  261. output("jmp_buf");
  262.     break;
  264.         default:
  265.             if (type->meaning && type->meaning->kind == MK_TYPE &&
  266.                 type->meaning->wasdeclared) {
  267.                 output(type->meaning->name);
  268.             } else {
  269.                 switch (type->kind) {
  271.                     case TK_ENUM:
  272.                         output("enum {n");
  273. saveindent = outindent;
  274. moreindent(tabsize);
  275. moreindent(structindent);
  276.                         mp = type->fbase;
  277.                         while (mp) {
  278.                             output(mp->name);
  279.                             mp = mp->xnext;
  280.                             if (mp)
  281. output(",01 ");
  282.                         }
  283.                         outindent = saveindent;
  284.                         output("n}");
  285.                         break;
  287.                     case TK_RECORD:
  288.                         if (record_is_union(type))
  289.                             output("union ");
  290.                         else
  291.                             output("struct ");
  292.                         if (type->meaning)
  293.                             output(format_s(name_STRUCT, type->meaning->name));
  294. if (!type->structdefd) {
  295.     if (type->meaning) {
  296. type->structdefd = 1;
  297. output(" ");
  298.     }
  299.                             output("{n");
  300.     saveindent = outindent;
  301.     moreindent(tabsize);
  302.     moreindent(structindent);
  303.                             outfieldlist(type->fbase);
  304.                             outindent = saveindent;
  305.                             output("}");
  306.                         }
  307. break;
  309.     default:
  310. break;
  312.                 }
  313.             }
  314.             break;
  315.     }
  316. }
  320. void out_type(type, witharrays)
  321. Type *type;
  322. int witharrays;
  323. {
  324.     if (!witharrays && type->kind == TK_ARRAY)
  325.         type = makepointertype(type->basetype);
  326.     outbasetype(type, 0);
  327.     outdeclarator(type, "", 0);    /* write an "abstract declarator" */
  328. }
  333. int varstorageclass(mp)
  334. Meaning *mp;
  335. {
  336.     int sclass;
  338.     if (mp->kind == MK_PARAM || mp->kind == MK_VARPARAM ||
  339. mp->kind == MK_FIELD)
  340. sclass = 0;
  341.     else if (blockkind == TOK_EXPORT)
  342.         if (usevextern)
  343.     if (mp->constdefn &&
  344. (mp->kind == MK_VAR ||
  345.  mp->kind == MK_VARREF))
  346. sclass = 2;    /* extern */
  347.     else
  348. sclass = 1;    /* vextern */
  349.         else
  350.             sclass = 0;                         /* (plain) */
  351.     else if (mp->isfunction && mp->kind != MK_FUNCTION)
  352. sclass = 2;   /* extern */
  353.     else if (mp->ctx->kind == MK_MODULE &&
  354.      (var_static != 0 ||
  355.       (findsymbol(mp->name)->flags & NEEDSTATIC)) &&
  356.      !mp->exported && !mp->istemporary && blockkind != TOK_END)
  357.         sclass = (useAnyptrMacros) ? 4 : 3;     /* (private) */
  358.     else if (mp->isforward)
  359.         sclass = 3;   /* static */
  360.     else
  361. sclass = 0;   /* (plain) */
  362.     if (mp->volatilequal)
  363. sclass |= 0x10;
  364.     if (mp->constqual)
  365. sclass |= 0x20;
  366.     if (debug>2) fprintf(outf, "varstorageclass(%s) = %dn", mp->name, sclass);
  367.     return sclass;
  368. }
  371. char *storageclassname(i)
  372. int i;
  373. {
  374.     char *scname;
  376.     switch (i & 0xf) {
  377.         case 1:
  378.             scname = "vextern ";
  379.     break;
  380.         case 2:
  381.             scname = "extern ";
  382.     break;
  383.         case 3:
  384.             scname = "static ";
  385.     break;
  386.         case 4:
  387.             scname = "Static ";
  388.     break;
  389.         default:
  390.             scname = "";
  391.     break;
  392.     }
  393.     if (i & 0x10)
  394. if (useAnyptrMacros == 1)
  395.     scname = format_s("%sVolatile ", scname);
  396. else if (ansiC > 0)
  397.     scname = format_s("%svolatile ", scname);
  398.     if (i & 0x20)
  399. if (useAnyptrMacros == 1)
  400.     scname = format_s("%sConst ", scname);
  401. else if (ansiC > 0)
  402.     scname = format_s("%sconst ", scname);
  403.     return scname;
  404. }
  408. void declarevar(mp, which)
  409. Meaning *mp;
  410. int which;    /* 0x1=header, 0x2=body, 0x4=trailer, 0x8=in varstruct */
  411. {
  412.     int isstatic, isstructconst, saveindent;
  414.     isstructconst = checkstructconst(mp);
  415.     isstatic = varstorageclass(mp);
  416.     if (which & 0x8)
  417. isstatic &= 0x10;   /* clear all but Volatile flags */
  418.     flushcomments(&mp->comments, CMT_PRE, -1);
  419.     if (which & 0x1) {
  420.         if (isstructconst)
  421.             outsection(minorspace);
  422.         output(storageclassname(isstatic));
  423.         outbasetype(mp->type, 0);
  424.         output(" 05");
  425.     }
  426.     if (which & 0x2) {
  427.         outdeclarator(mp->type, mp->name, 0);
  428.         if (mp->constdefn && blockkind != TOK_EXPORT &&
  429.     (mp->kind == MK_VAR || mp->kind == MK_VARREF)) {
  430.             if (mp->varstructflag) {    /* move init code into function body */
  431.                 intwarning("declarevar",
  432.                     format_s("Variable %s initializer not removed [125]", mp->name));
  433.             } else {
  434.                 output(" = ");
  435.                 if (isstructconst) {
  436.                     output("{n");
  437.     saveindent = outindent;
  438.     moreindent(tabsize);
  439.     moreindent(structinitindent);
  440.                     out_expr((Expr *)mp->constdefn->val.i);
  441.                     outindent = saveindent;
  442.                     output("n}");
  443.                 } else
  444.                     out_expr(mp->constdefn);
  445.             }
  446.         }
  447.     }
  448.     if (which & 0x4) {
  449.         output(";");
  450. outtrailcomment(mp->comments, -1, declcommentindent);
  451. flushcomments(&mp->comments, -1, -1);
  452.         if (isstructconst)
  453.             outsection(minorspace);
  454.     }
  455. }
  460. Static int checkvarmacdef(ex, mp)
  461. Expr *ex;
  462. Meaning *mp;
  463. {
  464.     int i;
  466.     if ((ex->kind == EK_NAME || ex->kind == EK_BICALL) &&
  467. !strcmp(ex->val.s, mp->name)) {
  468. ex->kind = EK_VAR;
  469. ex->val.i = (long)mp;
  470. ex->val.type = mp->type;
  471. return 1;
  472.     }
  473.     if (ex->kind == EK_VAR && ex->val.i == (long)mp)
  474. return 1;
  475.     i = ex->nargs;
  476.     while (--i >= 0)
  477. if (checkvarmacdef(ex->args[i], mp))
  478.     return 1;
  479.     return 0;
  480. }
  483. int checkvarmac(mp)
  484. Meaning *mp;
  485. {
  486.     if (mp->kind != MK_VARMAC && mp->kind != MK_FUNCTION)
  487. return 0;
  488.     if (!mp->constdefn)
  489. return 0;
  490.     return checkvarmacdef(mp->constdefn, mp);
  491. }
  495. #define varkind(k) ((k)==MK_VAR||(k)==MK_VARREF||(k)==MK_PARAM||(k)==MK_VARPARAM)
  497. int declarevars(ctx, invarstruct)
  498. Meaning *ctx;
  499. int invarstruct;
  500. {
  501.     Meaning *mp, *mp0, *mp2;
  502.     Strlist *fnames, *fn;
  503.     int flag, first;
  505.     if (ctx->kind == MK_FUNCTION && ctx->varstructflag && !invarstruct) {
  506.         output("struct ");
  507.         output(format_s(name_LOC, ctx->name));
  508.         output(" ");
  509.         output(format_s(name_VARS, ctx->name));
  510.         output(";n");
  511.         flag = 1;
  512.     } else
  513.         flag = 0;
  514.     if (debug>2) {
  515.         fprintf(outf,"declarevars:n");
  516.         for (mp = ctx->cbase; mp; mp = mp->xnext) {
  517.             fprintf(outf, "  %-22s%-15s%3d", mp->name,
  518.                                              meaningkindname(mp->kind),
  519.                                              mp->refcount);
  520.             if (mp->wasdeclared)
  521.                 fprintf(outf, " [decl]");
  522.             if (mp->varstructflag)
  523.                 fprintf(outf, " [struct]");
  524.             fprintf(outf, "n");
  525.         }
  526.     }
  527.     fnames = NULL;
  528.     for (;;) {
  529.         mp = ctx->cbase;
  530.         while (mp && (!(varkind(mp->kind) || checkvarmac(mp)) ||
  531.       mp->wasdeclared || mp->varstructflag != invarstruct ||
  532.       mp->refcount <= 0))
  533.             mp = mp->cnext;
  534.         if (!mp)
  535.             break;
  536.         flag = 1;
  537.         first = 1;
  538.         mp0 = mp2 = mp;
  539.         while (mp) {
  540.             if ((varkind(mp->kind) || checkvarmac(mp)) &&
  541. !mp->wasdeclared &&
  542.                 varstorageclass(mp) == varstorageclass(mp0) &&
  543.                 mp->varstructflag == invarstruct && mp->refcount > 0) {
  544.                 if (mixable(mp2, mp, 0, 0) || first) {
  545.                     if (!first)
  546.                         output(",01 ");
  547.                     declarevar(mp, (first ? 0x3 : 0x2) |
  548.            (invarstruct ? 0x8 : 0));
  549.     mp2 = mp;
  550.                     mp->wasdeclared = 1;
  551.                     if (isfiletype(mp->type)) {
  552.                         fn = strlist_append(&fnames, mp->name);
  553.                         fn->value = (long)mp;
  554.                     }
  555.                     first = 0;
  556.                 } else
  557.                     if (mixvars != 1)
  558.                         break;
  559.             }
  560.     if (first) {
  561. intwarning("declarevars",
  562.    format_s("Unable to declare %s [126]", mp->name));
  563. mp->wasdeclared = 1;
  564. first = 0;
  565.     }
  566.             if (mixvars == 0)
  567.                 break;
  568.             mp = mp->cnext;
  569.         }
  570.         declarevar(mp2, 0x4);
  571.     }
  572.     declarefiles(fnames);
  573.     return flag;
  574. }
  578. void redeclarevars(ctx)
  579. Meaning *ctx;
  580. {
  581.     Meaning *mp;
  583.     for (mp = ctx->cbase; mp; mp = mp->cnext) {
  584.         if ((mp->kind == MK_VAR || mp->kind == MK_VARREF) &&
  585.             mp->constdefn) {
  586.             mp->wasdeclared = 0;    /* mark for redeclaration, this time */
  587.         }                           /*  with its initializer */
  588.     }
  589. }
  595. void out_argdecls(ftype)
  596. Type *ftype;
  597. {
  598.     Meaning *mp, *mp0;
  599.     Type *tp;
  600.     int done;
  601.     int flag = 1;
  602.     char *name;
  604.     done = 0;
  605.     do {
  606.         mp = ftype->fbase;
  607.         while (mp && mp->wasdeclared)
  608.             mp = mp->xnext;
  609.         if (mp) {
  610.             if (flag)
  611.                 output("n");
  612.             flag = 0;
  613.             mp0 = mp;
  614.             outbasetype(mp->othername ? mp->rectype : mp->type,
  615. ODECL_CHARSTAR|ODECL_FREEARRAY);
  616.             output(" 05");
  617.             while (mp) {
  618.                 if (!mp->wasdeclared) {
  619.                     if (mp == mp0 ||
  620. mixable(mp0, mp, 1, ODECL_CHARSTAR|ODECL_FREEARRAY)) {
  621.                         if (mp != mp0)
  622.                             output(",01 ");
  623.                         name = (mp->othername) ? mp->othername : mp->name;
  624.                         tp = (mp->othername) ? mp->rectype : mp->type;
  625.                         outdeclarator(tp, name,
  626.       ODECL_CHARSTAR|ODECL_FREEARRAY);
  627.                         mp->wasdeclared = 1;
  628.                     } else
  629.                         if (mixvars != 1)
  630.                             break;
  631.                 }
  632.                 mp = mp->xnext;
  633.             }
  634.             output(";n");
  635.         } else
  636.             done = 1;
  637.     } while (!done);
  638.     for (mp0 = ftype->fbase; mp0 && (mp0->type != tp_strptr ||
  639.                                      !mp0->anyvarflag); mp0 = mp0->xnext) ;
  640.     if (mp0) {
  641.         output("int ");
  642.         for (mp = mp0; mp; mp = mp->xnext) {
  643.             if (mp->type == tp_strptr && mp->anyvarflag) {
  644.                 if (mp != mp0) {
  645.                     if (mixvars == 0)
  646.                         output(";nint ");
  647.                     else
  648.                         output(",01 ");
  649.                 }
  650.                 output(format_s(name_STRMAX, mp->name));
  651.             }
  652.         }
  653.         output(";n");
  654.     }
  655.     if (ftype->meaning && ftype->meaning->ctx->kind == MK_FUNCTION &&
  656.                           ftype->meaning->ctx->varstructflag) {
  657.         if (flag)
  658.             output("n");
  659.         output("struct ");
  660.         output(format_s(name_LOC, ftype->meaning->ctx->name));
  661.         output(" *");
  662.         output(format_s(name_LINK, ftype->meaning->ctx->name));
  663.         output(";n");
  664.     }
  665. }
  670. void makevarstruct(func)
  671. Meaning *func;
  672. {
  673.     int flag = 0;
  674.     int saveindent;
  676.     outsection(minfuncspace);
  677.     output(format_s("n/* Local variables for %s: */n", func->name));
  678.     output("struct ");
  679.     output(format_s(name_LOC, func->name));
  680.     output(" {n");
  681.     saveindent = outindent;
  682.     moreindent(tabsize);
  683.     moreindent(structindent);
  684.     if (func->ctx->kind == MK_FUNCTION && func->ctx->varstructflag) {
  685.         output("struct ");
  686.         output(format_s(name_LOC, func->ctx->name));
  687.         output(" *");
  688.         output(format_s(name_LINK, func->ctx->name));
  689.         output(";n");
  690.         flag++;
  691.     }
  692.     flag += declarevars(func, 1);
  693.     if (!flag)                       /* Avoid generating an empty struct */
  694.         output("int _meef_;n");     /* (I don't think this will ever happen) */
  695.     outindent = saveindent;
  696.     output("} ;n");
  697.     outsection(minfuncspace);
  698.     strlist_insert(&varstructdecllist, func->name);
  699. }
  706. Type *maketype(kind)
  707. enum typekind kind;
  708. {
  709.     Type *tp;
  710.     tp = ALLOC(1, Type, types);
  711.     tp->kind = kind;
  712.     tp->basetype = NULL;
  713.     tp->indextype = NULL;
  714.     tp->pointertype = NULL;
  715.     tp->meaning = NULL;
  716.     tp->fbase = NULL;
  717.     tp->smin = NULL;
  718.     tp->smax = NULL;
  719.     tp->issigned = 0;
  720.     tp->dumped = 0;
  721.     tp->structdefd = 0;
  722.     return tp;
  723. }
  728. Type *makesubrangetype(type, smin, smax)
  729. Type *type;
  730. Expr *smin, *smax;
  731. {
  732.     Type *tp;
  734.     if (type->kind == TK_SUBR)
  735.         type = type->basetype;
  736.     tp = maketype(TK_SUBR);
  737.     tp->basetype = type;
  738.     tp->smin = smin;
  739.     tp->smax = smax;
  740.     return tp;
  741. }
  745. Type *makesettype(setof)
  746. Type *setof;
  747. {
  748.     Type *tp;
  749.     long smax;
  751.     if (ord_range(setof, NULL, &smax) && smax < setbits && smallsetconst >= 0)
  752.         tp = maketype(TK_SMALLSET);
  753.     else
  754.         tp = maketype(TK_SET);
  755.     tp->basetype = tp_integer;
  756.     tp->indextype = setof;
  757.     return tp;
  758. }
  762. Type *makestringtype(len)
  763. int len;
  764. {
  765.     Type *type;
  766.     int index;
  768.     len |= 1;
  769.     if (len >= stringceiling)
  770.         type = tp_str255;
  771.     else {
  772.         index = (len-1) / 2;
  773.         if (stringtypecache[index])
  774.             return stringtypecache[index];
  775.         type = maketype(TK_STRING);
  776.         type->basetype = tp_char;
  777.         type->indextype = makesubrangetype(tp_integer, 
  778.                                            makeexpr_long(0), 
  779.                                            makeexpr_long(len));
  780.         stringtypecache[index] = type;
  781.     }
  782.     return type;
  783. }
  787. Type *makepointertype(type)
  788. Type *type;
  789. {
  790.     Type *tp;
  792.     if (type->pointertype)
  793.         return type->pointertype;
  794.     tp = maketype(TK_POINTER);
  795.     tp->basetype = type;
  796.     type->pointertype = tp;
  797.     return tp;
  798. }
  804. Value p_constant(type)
  805. Type *type;
  806. {
  807.     Value val;
  808.     Expr *ex;
  810.     ex = p_expr(type);
  811.     if (type)
  812.         ex = gentle_cast(ex, type);
  813.     val = eval_expr(ex);
  814.     freeexpr(ex);
  815.     if (!val.type) {
  816.         warning("Expected a constant [127]");
  817.         val.type = (type) ? type : tp_integer;
  818.     }
  819.     return val;
  820. }
  825. int typebits(smin, smax)
  826. long smin, smax;
  827. {
  828.     unsigned long size;
  829.     int bits;
  831.     if (smin >= 0 || (smin == -1 && smax == 0)) {
  832.         bits = 1;
  833.         size = smax;
  834.     } else {
  835.         bits = 2;
  836.         smin = -1L - smin;
  837.         if (smin >= smax)
  838.             size = smin;
  839.         else
  840.             size = smax;
  841.     }
  842.     while (size > 1) {
  843.         bits++;
  844.         size >>= 1;
  845.     }
  846.     return bits;
  847. }
  850. int packedsize(fname, typep, sizep, mode)
  851. char *fname;
  852. Type **typep;
  853. long *sizep;
  854. int mode;
  855. {
  856.     Type *tp = *typep;
  857.     long smin, smax;
  858.     int res, issigned;
  859.     short savefold;
  860.     long size;
  862.     if (packing == 0)   /* suppress packing */
  863.         return 0;
  864.     if (tp->kind != TK_SUBR && tp->kind != TK_INTEGER && tp->kind != TK_ENUM &&
  865.         tp->kind != TK_CHAR && tp->kind != TK_BOOLEAN)
  866.         return 0;
  867.     if (tp == tp_unsigned)
  868. return 0;
  869.     if (!ord_range(tp, &smin, &smax)) {
  870.         savefold = foldconsts;
  871.         foldconsts = 1;
  872.         res = ord_range(tp, &smin, &smax);
  873.         foldconsts = savefold;
  874.         if (res) {
  875.             note(format_s("Field width for %s is based on expansion of #defines [103]",
  876.                           fname));
  877.         } else {
  878.             note(format_ss("Cannot compute size of field %s; assuming %s [104]",
  879.                            fname, integername));
  880.             return 0;
  881.         }
  882.     } else {
  883.         if (tp->kind == TK_ENUM)
  884.             note(format_ssd("Field width for %s assumes enum%s has %d elements [105]",
  885.                             fname,
  886.                             (tp->meaning) ? format_s(" %s", tp->meaning->name) : "",
  887.                             smax + 1));
  888.     }
  889.     issigned = (smin < 0);
  890.     size = typebits(smin, smax);
  891.     if (size >= ((sizeof_long > 0) ? sizeof_long : 32))
  892.         return 0;
  893.     if (packing != 1) {
  894.         if (size <= 8)
  895.             size = 8;
  896.         else if (size <= 16)
  897.             size = 16;
  898.         else
  899.             return 0;
  900.     }
  901.     if (!issigned) {
  902.         *typep = (mode == 0) ? tp_int : tp_uint;
  903.     } else {
  904.         if (mode == 2 && !hassignedchar && !*signextname)
  905.             return 0;
  906.         *typep = (mode == 1) ? tp_int : tp_sint;
  907.     }
  908.     *sizep = size;
  909.     return issigned;
  910. }
  914. Static void fielddecl(mp, type, tp2, val, ispacked, aligned)
  915. Meaning *mp;
  916. Type **type, **tp2;
  917. long *val;
  918. int ispacked, *aligned;
  919. {
  920.     long smin, smax, smin2, smax2;
  922.     *tp2 = *type;
  923.     *val = 0;
  924.     if (ispacked && !mp->constdefn && *type != tp_unsigned) {
  925.         (void)packedsize(mp->sym->name, tp2, val, signedfield);
  926.         if (*aligned && *val &&
  927.             (ord_type(*type)->kind == TK_CHAR ||
  928.              ord_type(*type)->kind == TK_INTEGER) &&
  929.             ord_range(findbasetype(*type, 0), &smin, &smax)) {
  930.     if (ord_range(*type, &smin2, &smax2)) {
  931. if (typebits(smin, smax) == 16 &&
  932.     typebits(smin2, smax2) == 8 && *val == 8) {
  933.     *tp2 = tp_abyte;
  934. }
  935.     }
  936.     if (typebits(smin, smax) == *val &&
  937. *val != 7) {    /* don't be fooled by tp_abyte */
  938. /* don't need to use a bit-field for this field */
  939. /* so not specifying one may make it more efficient */
  940. /* (and also helps to simulate HP's $allow_packed$ mode) */
  941. *val = 0;
  942. *tp2 = *type;
  943.     } 
  944.         }
  945.         if (*aligned && *val == 8 &&
  946.             (ord_type(*type)->kind == TK_BOOLEAN ||
  947.              ord_type(*type)->kind == TK_ENUM)) {
  948.             *val = 0;
  949.             *tp2 = tp_ubyte;
  950.         }
  951.     }
  952.     if (*val != 8 && *val != 16)
  953. *aligned = (*val == 0);
  954. }
  958. /* This function locates byte-sized fields which were unaligned, but which
  959.    are followed by aligned quantities so that they can be made aligned
  960.    with no loss in storage efficiency. */
  962. Static void realignfields(firstmp, stopmp)
  963. Meaning *firstmp, *stopmp;
  964. {
  965.     Meaning *mp;
  967.     for (mp = firstmp; mp && mp != stopmp; mp = mp->cnext) {
  968. if (mp->kind == MK_FIELD) {
  969.     if (mp->val.i == 16) {
  970. if (mp->type == tp_uint)
  971.     mp->type = tp_ushort;
  972. else
  973.     mp->type = tp_sshort;
  974. mp->val.i = 0;
  975.     } else if (mp->val.i == 8) {
  976. if (mp->type == tp_uint) {
  977.     mp->type = tp_ubyte;
  978.     mp->val.i = 0;
  979. } else if (hassignedchar || signedchars == 1) {
  980.     mp->type = tp_sbyte;
  981.     mp->val.i = 0;
  982. } else
  983.     mp->type = tp_abyte;
  984.     }
  985. }
  986.     }
  987. }
  989. static void tryrealignfields(firstmp)
  990. Meaning *firstmp;
  991. {
  992.     Meaning *mp, *head;
  994.     head = NULL;
  995.     for (mp = firstmp; mp; mp = mp->cnext) {
  996. if (mp->kind == MK_FIELD) {
  997.     if (mp->val.i == 8 || mp->val.i == 16) {
  998. if (!head)
  999.     head = mp;
  1000.     } else {
  1001. if (mp->val.i == 0)
  1002.     realignfields(head, mp);
  1003. head = NULL;
  1004.     }
  1005. }
  1006.     }
  1007.     realignfields(head, NULL);
  1008. }
  1012. void decl_comments(mp)
  1013. Meaning *mp;
  1014. {
  1015.     Strlist *cmt;
  1017.     if (spitcomments != 1) {
  1018. changecomments(curcomments, -1, -1, CMT_PRE, 0);
  1019. strlist_mix(&mp->comments, curcomments);
  1020. curcomments = NULL;
  1021. cmt = grabcomment(CMT_TRAIL);
  1022. if (cmt) {
  1023.     changecomments(mp->comments, CMT_TRAIL, -1, CMT_PRE, -1);
  1024.     strlist_mix(&mp->comments, cmt);
  1025. }
  1026. if (mp->comments)
  1027.     mp->refcount++;   /* force it to be included if it has comments */
  1028.     }
  1029. }
  1035. Static void p_fieldlist(tp, flast, ispacked, tname)
  1036. Type *tp;
  1037. Meaning **flast;
  1038. int ispacked;
  1039. Meaning *tname;
  1040. {
  1041.     Meaning *firstm, *lastm, *veryfirstm;
  1042.     Symbol *sym;
  1043.     Type *type, *tp2;
  1044.     long li1, li2;
  1045.     int aligned, constflag, volatileflag;
  1046.     short saveskipind;
  1047.     Strlist *l1;
  1049.     saveskipind = skipindices;
  1050.     skipindices = 0;
  1051.     aligned = 1;
  1052.     lastm = NULL;
  1053.     veryfirstm = NULL;
  1054.     while (curtok == TOK_IDENT) {
  1055.         firstm = addfield(curtoksym, &flast, tp, tname);
  1056. if (!veryfirstm)
  1057.     veryfirstm = firstm;
  1058.         lastm = firstm;
  1059.         gettok();
  1060. decl_comments(lastm);
  1061.         while (curtok == TOK_COMMA) {
  1062.             gettok();
  1063.             if (wexpecttok(TOK_IDENT))
  1064. lastm = addfield(curtoksym, &flast, tp, tname);
  1065.             gettok();
  1066.     decl_comments(lastm);
  1067.         }
  1068.         if (wneedtok(TOK_COLON)) {
  1069.     constflag = volatileflag = 0;
  1070.     p_attributes();
  1071.     if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
  1072. constflag = 1;
  1073. strlist_delete(&attrlist, l1);
  1074.     }
  1075.     if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
  1076. volatileflag = 1;
  1077. strlist_delete(&attrlist, l1);
  1078.     }
  1079.     type = p_type(firstm);
  1080.     decl_comments(lastm);
  1081.     fielddecl(firstm, &type, &tp2, &li1, ispacked, &aligned);
  1082.     for (;;) {
  1083. firstm->type = tp2;
  1084. firstm->val.type = type;
  1085. firstm->val.i = li1;
  1086. firstm->constqual = constflag;
  1087. firstm->volatilequal = volatileflag;
  1088. tp->meaning = tname;
  1089. setupfilevar(firstm);
  1090. tp->meaning = NULL;
  1091. if (firstm == lastm)
  1092.     break;
  1093. firstm = firstm->cnext;
  1094.     }
  1095. } else
  1096.     skiptotoken2(TOK_SEMI, TOK_CASE);
  1097.         if (curtok == TOK_SEMI)
  1098.             gettok();
  1099.     }
  1100.     if (curtok == TOK_CASE) {
  1101.         gettok();
  1102. if (curtok == TOK_COLON)
  1103.     gettok();
  1104. wexpecttok(TOK_IDENT);
  1105. sym = curtoksym;
  1106. if (curtokmeaning)
  1107.     type = curtokmeaning->type;
  1108. gettok();
  1109.         if (curtok == TOK_COLON) {
  1110.             firstm = addfield(sym, &flast, tp, tname);
  1111.     if (!veryfirstm)
  1112. veryfirstm = firstm;
  1113.             gettok();
  1114.     firstm->isforward = 1;
  1115.             firstm->val.type = type = p_type(firstm);
  1116.             fielddecl(firstm, &firstm->val.type, &firstm->type, &firstm->val.i, 
  1117.                       ispacked, &aligned);
  1118.         } else {
  1119.     firstm = NULL;
  1120. }
  1121.         if (!wneedtok(TOK_OF)) {
  1122.     skiptotoken2(TOK_END, TOK_RPAR);
  1123.     goto bounce;
  1124. }
  1125. if (firstm)
  1126.     decl_comments(firstm);
  1127. while (curtok == TOK_VBAR)
  1128.     gettok();
  1129.         while (curtok != TOK_END && curtok != TOK_RPAR) {
  1130.             firstm = NULL;
  1131.             for (;;) {
  1132. lastm = addfield(NULL, &flast, tp, tname);
  1133. if (!firstm)
  1134.     firstm = lastm;
  1135. checkkeyword(TOK_OTHERWISE);
  1136. if (curtok == TOK_ELSE || curtok == TOK_OTHERWISE) {
  1137.     lastm->val = make_ord(type, 999);
  1138.     break;
  1139. } else {
  1140.     lastm->val = p_constant(type);
  1141.     if (curtok == TOK_DOTS) {
  1142. gettok();
  1143. li1 = ord_value(lastm->val);
  1144. li2 = ord_value(p_constant(type));
  1145. while (++li1 <= li2) {
  1146.     lastm = addfield(NULL, &flast, tp, tname);
  1147.     lastm->val = make_ord(type, li1);
  1148. }
  1149.     }
  1150. }
  1151.                 if (curtok == TOK_COMMA)
  1152.                     gettok();
  1153.                 else
  1154.                     break;
  1155.             }
  1156.     if (curtok == TOK_ELSE || curtok == TOK_OTHERWISE) {
  1157. gettok();
  1158.             } else if (!wneedtok(TOK_COLON) ||
  1159.      (!modula2 && !wneedtok(TOK_LPAR))) {
  1160. skiptotoken2(TOK_END, TOK_RPAR);
  1161. goto bounce;
  1162.     }
  1163.             p_fieldlist(tp, &lastm->ctx, ispacked, tname);
  1164.             while (firstm != lastm) {
  1165.                 firstm->ctx = lastm->ctx;
  1166.                 firstm = firstm->cnext;
  1167.             }
  1168.     if (modula2) {
  1169. while (curtok == TOK_VBAR)
  1170.     gettok();
  1171.     } else {
  1172. if (!wneedtok(TOK_RPAR))
  1173.     skiptotoken(TOK_RPAR);
  1174.     }
  1175.             if (curtok == TOK_SEMI)
  1176.                 gettok();
  1177.         }
  1178. if (modula2) {
  1179.     wneedtok(TOK_END);
  1180.     if (curtok == TOK_IDENT) {
  1181. note("Record variants supported only at end of record [106]");
  1182. p_fieldlist(tp, &lastm->ctx, ispacked, tname);
  1183.     }
  1184. }
  1185.     }
  1186.     tryrealignfields(veryfirstm);
  1187.     if (lastm && curtok == TOK_END) {
  1188. strlist_mix(&lastm->comments, curcomments);
  1189. curcomments = NULL;
  1190.     }
  1192.   bounce:
  1193.     skipindices = saveskipind;
  1194. }
  1198. Static Type *p_arraydecl(tname, ispacked, confp)
  1199. char *tname;
  1200. int ispacked;
  1201. Meaning ***confp;
  1202. {
  1203.     Type *tp, *tp2;
  1204.     Meaning *mp;
  1205.     long size, smin, smax, bitsize, fullbitsize;
  1206.     int issigned, bpower, hasrange;
  1208.     tp = maketype(TK_ARRAY);
  1209.     if (confp == NULL) {
  1210. tp->indextype = p_type(NULL);
  1211. if (tp->indextype->kind == TK_SUBR) {
  1212.     if (ord_range(tp->indextype, &smin, NULL) &&
  1213. smin > 0 && smin <= skipindices && !ispacked) {
  1214. tp->smin = makeexpr_val(make_ord(tp->indextype->basetype, smin));
  1215. tp->indextype = makesubrangetype(tp->indextype->basetype,
  1216.  makeexpr_val(make_ord(
  1217.              tp->indextype->basetype, 0)),
  1218.  copyexpr(tp->indextype->smax));
  1219.     }
  1220. }
  1221.     } else {
  1222. if (modula2) {
  1223.     **confp = mp = addmeaning(findsymbol(format_s(name_ALOW, tname)), MK_PARAM);
  1224.     mp->fakeparam = 1;
  1225.     mp->constqual = 1;
  1226.     mp->xnext = addmeaning(findsymbol(format_s(name_AHIGH, tname)), MK_PARAM);
  1227.     mp->xnext->fakeparam = 1;
  1228.     mp->xnext->constqual = 1;
  1229.     *confp = &mp->xnext->xnext;
  1230.     tp2 = maketype(TK_SUBR);
  1231.     tp2->basetype = tp_integer;
  1232.     mp->type = tp_integer;
  1233.     mp->xnext->type = mp->type;
  1234.     tp2->smin = makeexpr_long(0);
  1235.     tp2->smax = makeexpr_minus(makeexpr_var(mp->xnext),
  1236.        makeexpr_var(mp));
  1237.     tp->indextype = tp2;
  1238.     tp->structdefd = 1;
  1239. } else {
  1240.     wexpecttok(TOK_IDENT);
  1241.     tp2 = maketype(TK_SUBR);
  1242.     if (peeknextchar() != ',' &&
  1243. (!curtokmeaning || curtokmeaning->kind != MK_TYPE)) {
  1244. mp = addmeaning(curtoksym, MK_PARAM);
  1245. gettok();
  1246. wneedtok(TOK_DOTS);
  1247. wexpecttok(TOK_IDENT);
  1248. mp->xnext = addmeaning(curtoksym, MK_PARAM);
  1249. gettok();
  1250. if (wneedtok(TOK_COLON)) {
  1251.     tp2->basetype = p_type(NULL);
  1252. } else {
  1253.     tp2->basetype = tp_integer;
  1254. }
  1255.     } else {
  1256. mp = addmeaning(findsymbol(format_s(name_ALOW, tname)), MK_PARAM);
  1257. mp->xnext = addmeaning(findsymbol(format_s(name_AHIGH, tname)), MK_PARAM);
  1258. tp2->basetype = p_type(NULL);
  1259.     }
  1260.     mp->fakeparam = 1;
  1261.     mp->constqual = 1;
  1262.     mp->xnext->fakeparam = 1;
  1263.     mp->xnext->constqual = 1;
  1264.     **confp = mp;
  1265.     *confp = &mp->xnext->xnext;
  1266.     mp->type = tp2->basetype;
  1267.     mp->xnext->type = tp2->basetype;
  1268.     tp2->smin = makeexpr_var(mp);
  1269.     tp2->smax = makeexpr_var(mp->xnext);
  1270.     tp->indextype = tp2;
  1271.     tp->structdefd = 1;     /* conformant array flag */
  1272. }
  1273.     }
  1274.     if (curtok == TOK_COMMA || curtok == TOK_SEMI) {
  1275.         gettok();
  1276.         tp->basetype = p_arraydecl(tname, ispacked, confp);
  1277.         return tp;
  1278.     } else {
  1279. if (!modula2) {
  1280.     if (!wneedtok(TOK_RBR))
  1281. skiptotoken(TOK_OF);
  1282. }
  1283.         if (!wneedtok(TOK_OF))
  1284.     skippasttotoken(TOK_OF, TOK_COMMA);
  1285. checkkeyword(TOK_VARYING);
  1286. if (confp != NULL &&
  1287.     (curtok == TOK_ARRAY || curtok == TOK_PACKED ||
  1288.      curtok == TOK_VARYING)) {
  1289.     tp->basetype = p_conformant_array(tname, confp);
  1290. } else
  1291.     tp->basetype = p_type(NULL);
  1292.         if (!ispacked)
  1293.             return tp;
  1294.         size = 0;
  1295.         tp2 = tp->basetype;
  1296.         if (!tname)
  1297.             tname = "array";
  1298.         issigned = packedsize(tname, &tp2, &size, 1);
  1299.         if (!size || size > 8 ||
  1300.             (issigned && !packsigned) ||
  1301.             (size > 4 &&
  1302.              (!issigned || (signedchars == 1 || hassignedchar))))
  1303.             return tp;
  1304.         bpower = 0;
  1305.         while ((1<<bpower) < size)
  1306.             bpower++;        /* round size up to power of two */
  1307.         size = 1<<bpower;    /* size = # bits in an array element */
  1308.         tp->escale = bpower;
  1309.         tp->issigned = issigned;
  1310.         hasrange = ord_range(tp->indextype, &smin, &smax) &&
  1311.                    (smax < 100000);    /* don't be confused by giant arrays */
  1312.         if (hasrange &&
  1313.     (bitsize = (smax - smin + 1) * size)
  1314.         <= ((sizeof_integer > 0) ? sizeof_integer : 32)) {
  1315.             if (bitsize > ((sizeof_short > 0) ? sizeof_short : 16)) {
  1316.                 tp2 = (issigned) ? tp_integer : tp_unsigned;
  1317.                 fullbitsize = ((sizeof_integer > 0) ? sizeof_integer : 32);
  1318.             } else if (bitsize > ((sizeof_char > 0) ? sizeof_char : 8) ||
  1319.                        (issigned && !(signedchars == 1 || hassignedchar))) {
  1320.                 tp2 = (issigned) ? tp_sshort : tp_ushort;
  1321.                 fullbitsize = ((sizeof_short > 0) ? sizeof_short : 16);
  1322.             } else {
  1323.                 tp2 = (issigned) ? tp_sbyte : tp_ubyte;
  1324.                 fullbitsize = ((sizeof_char > 0) ? sizeof_char : 8);
  1325.             }
  1326.             tp->kind = TK_SMALLARRAY;
  1327.             if (ord_range(tp->indextype, &smin, NULL) &&
  1328.                 smin > 0 && smin <= fullbitsize - bitsize) {
  1329.                 tp->smin = makeexpr_val(make_ord(tp->indextype->basetype, smin));
  1330.                 tp->indextype = makesubrangetype(tp->indextype->basetype,
  1331.                                                  makeexpr_val(make_ord(
  1332.                                                      tp->indextype->basetype, 0)),
  1333.                                                  copyexpr(tp->indextype->smax));
  1334.             }
  1335.         } else {
  1336.             if (!issigned)
  1337.                 tp2 = tp_ubyte;
  1338.             else if (signedchars == 1 || hassignedchar)
  1339.                 tp2 = tp_sbyte;
  1340.             else
  1341.                 tp2 = tp_sshort;
  1342.         }
  1343.         tp->smax = makeexpr_type(tp->basetype);
  1344.         tp->basetype = tp2;
  1345.         return tp;
  1346.     }
  1347. }
  1351. Static Type *p_conformant_array(tname, confp)
  1352. char *tname;
  1353. Meaning ***confp;
  1354. {
  1355.     int ispacked;
  1356.     Meaning *mp;
  1357.     Type *tp, *tp2;
  1359.     p_attributes();
  1360.     ignore_attributes();
  1361.     if (curtok == TOK_PACKED) {
  1362. ispacked = 1;
  1363. gettok();
  1364.     } else
  1365. ispacked = 0;
  1366.     checkkeyword(TOK_VARYING);
  1367.     if (curtok == TOK_VARYING) {
  1368. gettok();
  1369. wneedtok(TOK_LBR);
  1370. wexpecttok(TOK_IDENT);
  1371. mp = addmeaning(curtoksym, MK_PARAM);
  1372. mp->fakeparam = 1;
  1373. mp->constqual = 1;
  1374. **confp = mp;
  1375. *confp = &mp->xnext;
  1376. mp->type = tp_integer;
  1377. tp2 = maketype(TK_SUBR);
  1378. tp2->basetype = tp_integer;
  1379. tp2->smin = makeexpr_long(1);
  1380. tp2->smax = makeexpr_var(mp);
  1381. tp = maketype(TK_STRING);
  1382. tp->indextype = tp2;
  1383. tp->basetype = tp_char;
  1384. tp->structdefd = 1;     /* conformant array flag */
  1385. gettok();
  1386. wneedtok(TOK_RBR);
  1387. skippasttoken(TOK_OF);
  1388. tp->basetype = p_type(NULL);
  1389. return tp;
  1390.     }
  1391.     if (wneedtok(TOK_ARRAY) &&
  1392. (modula2 || wneedtok(TOK_LBR))) {
  1393. return p_arraydecl(tname, ispacked, confp);
  1394.     } else {
  1395. return tp_integer;
  1396.     }
  1397. }
  1402. /* VAX Pascal: */
  1403. void p_attributes()
  1404. {
  1405.     Strlist *l1;
  1407.     if (modula2)
  1408. return;
  1409.     while (curtok == TOK_LBR) {
  1410. implementationmodules = 1;    /* auto-detect VAX Pascal */
  1411. do {
  1412.     gettok();
  1413.     if (!wexpecttok(TOK_IDENT)) {
  1414. skippasttoken(TOK_RBR);
  1415. return;
  1416.     }
  1417.     l1 = strlist_append(&attrlist, strupper(curtokbuf));
  1418.     l1->value = -1;
  1419.     gettok();
  1420.     if (curtok == TOK_LPAR) {
  1421. gettok();
  1422. if (!strcmp(l1->s, "CHECK") ||
  1423.     !strcmp(l1->s, "OPTIMIZE") ||
  1424.     !strcmp(l1->s, "KEY") ||
  1425.     !strcmp(l1->s, "COMMON") ||
  1426.     !strcmp(l1->s, "PSECT") ||
  1427.     !strcmp(l1->s, "EXTERNAL") ||
  1428.     !strcmp(l1->s, "GLOBAL") ||
  1429.     !strcmp(l1->s, "WEAK_EXTERNAL") ||
  1430.     !strcmp(l1->s, "WEAK_GLOBAL")) {
  1431.     l1->value = (long)stralloc(curtokbuf);
  1432.     gettok();
  1433.     while (curtok == TOK_COMMA) {
  1434. gettok();
  1435. gettok();
  1436.     }
  1437. } else if (!strcmp(l1->s, "INHERIT") ||
  1438.    !strcmp(l1->s, "IDENT") ||
  1439.    !strcmp(l1->s, "ENVIRONMENT")) {
  1440.     p_expr(NULL);
  1441.     while (curtok == TOK_COMMA) {
  1442. gettok();
  1443. p_expr(NULL);
  1444.     }
  1445. } else {
  1446.     l1->value = ord_value(p_constant(tp_integer));
  1447.     while (curtok == TOK_COMMA) {
  1448. gettok();
  1449. p_expr(NULL);
  1450.     }
  1451. }
  1452. if (!wneedtok(TOK_RPAR)) {
  1453.     skippasttotoken(TOK_RPAR, TOK_LBR);
  1454. }
  1455.     }
  1456. } while (curtok == TOK_COMMA);
  1457. if (!wneedtok(TOK_RBR)) {
  1458.     skippasttoken(TOK_RBR);
  1459. }
  1460.     }
  1461. }
  1464. void ignore_attributes()
  1465. {
  1466.     while (attrlist) {
  1467. if (strcmp(attrlist->s, "HIDDEN") &&
  1468.     strcmp(attrlist->s, "INHERIT") &&
  1469.     strcmp(attrlist->s, "ENVIRONMENT"))
  1470.     warning(format_s("Type attribute %s ignored [128]", attrlist->s));
  1471. strlist_eat(&attrlist);
  1472.     }
  1473. }
  1476. int size_attributes()
  1477. {
  1478.     int size = -1;
  1479.     Strlist *l1;
  1481.     if ((l1 = strlist_find(attrlist, "BIT")) != NULL)
  1482. size = 1;
  1483.     else if ((l1 = strlist_find(attrlist, "BYTE")) != NULL)
  1484. size = 8;
  1485.     else if ((l1 = strlist_find(attrlist, "WORD")) != NULL)
  1486. size = 16;
  1487.     else if ((l1 = strlist_find(attrlist, "LONG")) != NULL)
  1488. size = 32;
  1489.     else if ((l1 = strlist_find(attrlist, "QUAD")) != NULL)
  1490. size = 64;
  1491.     else if ((l1 = strlist_find(attrlist, "OCTA")) != NULL)
  1492. size = 128;
  1493.     else
  1494. return -1;
  1495.     if (l1->value >= 0)
  1496. size *= l1->value;
  1497.     strlist_delete(&attrlist, l1);
  1498.     return size;
  1499. }
  1502. void p_mech_spec(doref)
  1503. int doref;
  1504. {
  1505.     if (curtok == TOK_IDENT && doref &&
  1506. !strcicmp(curtokbuf, "%REF")) {
  1507. note("Mechanism specified %REF treated like VAR [107]");
  1508. curtok = TOK_VAR;
  1509. return;
  1510.     }
  1511.     if (curtok == TOK_IDENT &&
  1512. (!strcicmp(curtokbuf, "%REF") ||
  1513.  !strcicmp(curtokbuf, "%IMMED") ||
  1514.  !strcicmp(curtokbuf, "%DESCR") ||
  1515.  !strcicmp(curtokbuf, "%STDESCR"))) {
  1516. note(format_s("Mechanism specifier %s ignored [108]", curtokbuf));
  1517. gettok();
  1518.     }
  1519. }
  1522. Type *p_modula_subrange(basetype)
  1523. Type *basetype;
  1524. {
  1525.     Type *tp;
  1526.     Value val;
  1528.     wneedtok(TOK_LBR);
  1529.     tp = maketype(TK_SUBR);
  1530.     tp->smin = p_ord_expr();
  1531.     if (basetype)
  1532. tp->smin = gentle_cast(tp->smin, basetype);
  1533.     if (wexpecttok(TOK_DOTS)) {
  1534. gettok();
  1535. tp->smax = p_ord_expr();
  1536. if (tp->smax->val.type->kind == TK_REAL &&
  1537.     tp->smax->kind == EK_CONST &&
  1538.     strlen(tp->smax->val.s) == 12 &&
  1539.     strcmp(tp->smax->val.s, "2147483648.0") >= 0 &&
  1540.     strcmp(tp->smax->val.s, "4294967295.0") <= 0) {
  1541.     tp = tp_unsigned;
  1542. } else if (basetype) {
  1543.     tp->smin = gentle_cast(tp->smin, basetype);
  1544.     tp->basetype = basetype;
  1545. } else {
  1546.     basetype = ord_type(tp->smin->val.type);
  1547.     if (basetype->kind == TK_INTEGER) {
  1548. val = eval_expr(tp->smin);
  1549. if (val.type && val.i >= 0)
  1550.     basetype = tp_unsigned;
  1551. else
  1552.     basetype = tp_integer;
  1553.     }
  1554.     tp->basetype = basetype;
  1555. }
  1556.     } else {
  1557. tp = tp_integer;
  1558.     }
  1559.     if (!wneedtok(TOK_RBR))
  1560. skippasttotoken(TOK_RBR, TOK_SEMI);
  1561.     return tp;
  1562. }
  1565. void makefakestruct(tp, tname)
  1566. Type *tp;
  1567. Meaning *tname;
  1568. {
  1569.     Symbol *sym;
  1571.     if (!tname)
  1572. return;
  1573.     while (tp && (tp->kind == TK_ARRAY || tp->kind == TK_FILE))
  1574. tp = tp->basetype;
  1575.     if (tp && tp->kind == TK_RECORD && !tp->meaning) {
  1576. sym = findsymbol(format_s(name_FAKESTRUCT, tname->name));
  1577. silentalreadydef++;
  1578. tp->meaning = addmeaning(sym, MK_TYPE);
  1579. silentalreadydef--;
  1580. tp->meaning->type = tp;
  1581. tp->meaning->refcount++;
  1582. declaretype(tp->meaning);
  1583.     }
  1584. }
  1587. Type *p_type(tname)
  1588. Meaning *tname;
  1589. {
  1590.     Type *tp;
  1591.     int ispacked = 0;
  1592.     Meaning **flast;
  1593.     Meaning *mp;
  1594.     Strlist *sl;
  1595.     int num, isfunc, saveind, savenotephase, sizespec;
  1596.     Expr *ex;
  1597.     Value val;
  1598.     static int proctypecount = 0;
  1600.     p_attributes();
  1601.     sizespec = size_attributes();
  1602.     ignore_attributes();
  1603.     tp = tp_integer;
  1604.     if (curtok == TOK_PACKED) {
  1605.         ispacked = 1;
  1606.         gettok();
  1607.     }
  1608.     checkkeyword(TOK_VARYING);
  1609.     if (modula2)
  1610. checkkeyword(TOK_POINTER);
  1611.     switch (curtok) {
  1613.         case TOK_RECORD:
  1614.             gettok();
  1615.     savenotephase = notephase;
  1616.     notephase = 1;
  1617.             tp = maketype(TK_RECORD);
  1618.             p_fieldlist(tp, &(tp->fbase), ispacked, tname);
  1619.     notephase = savenotephase;
  1620.             if (!wneedtok(TOK_END)) {
  1621. skippasttoken(TOK_END);
  1622.     }
  1623.             break;
  1625.         case TOK_ARRAY:
  1626.             gettok();
  1627.     if (!modula2) {
  1628. if (!wneedtok(TOK_LBR))
  1629.     break;
  1630.     }
  1631.     tp = p_arraydecl(tname ? tname->name : NULL, ispacked, NULL);
  1632.     makefakestruct(tp, tname);
  1633.             break;
  1635. case TOK_VARYING:
  1636.     gettok();
  1637.     tp = maketype(TK_STRING);
  1638.     if (wneedtok(TOK_LBR)) {
  1639. ex = p_ord_expr();
  1640. if (!wneedtok(TOK_RBR))
  1641.     skippasttoken(TOK_RBR);
  1642.     } else
  1643. ex = makeexpr_long(stringdefault);
  1644.     if (wneedtok(TOK_OF))
  1645. tp->basetype = p_type(NULL);
  1646.     else
  1647. tp->basetype = tp_char;
  1648.     val = eval_expr(ex);
  1649.     if (val.type) {
  1650. if (val.i > 255 && val.i > stringceiling) {
  1651.     note(format_d("Strings longer than %d may have problems [109]",
  1652.   stringceiling));
  1653. }
  1654. if (stringceiling != 255 &&
  1655.     (val.i >= 255 || val.i > stringceiling)) {
  1656.     freeexpr(ex);
  1657.     ex = makeexpr_long(stringceiling);
  1658. }
  1659.     }
  1660.     tp->indextype = makesubrangetype(tp_integer, makeexpr_long(0), ex);
  1661.     break;
  1663.         case TOK_SET:
  1664.             gettok();
  1665.             if (!wneedtok(TOK_OF))
  1666. break;
  1667.     tp = p_type(NULL);
  1668.     if (tp == tp_integer || tp == tp_unsigned)
  1669. tp = makesubrangetype(tp, makeexpr_long(0),
  1670.       makeexpr_long(defaultsetsize-1));
  1671.     if (tp->kind == TK_ENUM && !tp->meaning && useenum) {
  1672. outbasetype(tp, 0);
  1673. output(";");
  1674.     }
  1675.             tp = makesettype(tp);
  1676.             break;
  1678.         case TOK_FILE:
  1679.             gettok();
  1680.     tp = maketype(TK_FILE);
  1681.             if (curtok == TOK_OF) {
  1682.                 gettok();
  1683.                 tp->basetype = p_type(NULL);
  1684.             } else {
  1685.                 tp->basetype = tp_abyte;
  1686.             }
  1687.     if (tp->basetype->kind == TK_CHAR && charfiletext) {
  1688. tp = tp_text;
  1689.     } else {
  1690. makefakestruct(tp, tname);
  1691. tp = makepointertype(tp);
  1692.     }
  1693.             break;
  1695.         case TOK_PROCEDURE:
  1696. case TOK_FUNCTION:
  1697.     isfunc = (curtok == TOK_FUNCTION);
  1698.             gettok();
  1699.     if (curtok != TOK_LPAR && !isfunc && hasstaticlinks == 1) {
  1700. tp = tp_proc;
  1701. break;
  1702.     }
  1703.     proctypecount++;
  1704.     mp = addmeaning(findsymbol(format_d("__PROCPTR%d",
  1705. proctypecount)),
  1706.     MK_FUNCTION);
  1707.     pushctx(mp);
  1708.     tp = maketype((hasstaticlinks != 0) ? TK_PROCPTR : TK_CPROCPTR);
  1709.     tp->basetype = p_funcdecl(&isfunc, 1);
  1710.     tp->fbase = mp;   /* (saved, but not currently used) */
  1711.     tp->escale = hasstaticlinks;
  1712.     popctx();
  1713.             break;
  1715.         case TOK_HAT:
  1716. case TOK_ADDR:
  1717. case TOK_POINTER:
  1718.     if (curtok == TOK_POINTER) {
  1719. gettok();
  1720. wneedtok(TOK_TO);
  1721. if (curtok == TOK_IDENT && !strcmp(curtokbuf, "WORD")) {
  1722.     tp = tp_anyptr;
  1723.     gettok();
  1724.     break;
  1725. }
  1726.     } else
  1727. gettok();
  1728.     p_attributes();
  1729.     ignore_attributes();
  1730.             tp = maketype(TK_POINTER);
  1731.             if (curtok == TOK_IDENT &&
  1732. (!curtokmeaning || curtokmeaning->kind != MK_TYPE ||
  1733.  (deferallptrs && curtokmeaning->ctx != curctx))) {
  1734.                 struct ptrdesc *pd;
  1735.                 pd = ALLOC(1, struct ptrdesc, ptrdescs);
  1736.                 pd->sym = curtoksym;
  1737.                 pd->tp = tp;
  1738.                 pd->next = ptrbase;
  1739.                 ptrbase = pd;
  1740.                 tp->basetype = tp_abyte;
  1741. anydeferredptrs = 1;
  1742.                 gettok();
  1743.             } else {
  1744.                 tp->basetype = p_type(NULL);
  1745.                 if (!tp->basetype->pointertype)
  1746.                     tp->basetype->pointertype = tp;
  1747.             }
  1748.             break;
  1750.         case TOK_LPAR:
  1751.             if (!useenum)
  1752.                 outsection(minorspace);
  1753.     enum_tname = tname;
  1754.             tp = maketype(TK_ENUM);
  1755.             flast = &(tp->fbase);
  1756.             num = 0;
  1757.             do {
  1758.                 gettok();
  1759.                 if (!wexpecttok(TOK_IDENT)) {
  1760.     skiptotoken(TOK_RPAR);
  1761.     break;
  1762. }
  1763.                 sl = strlist_find(constmacros, curtoksym->name);
  1764.                 mp = addmeaningas(curtoksym, MK_CONST,
  1765.   (*enumformat) ? MK_VARIANT :
  1766.                                   (useenum) ? MK_VAR : MK_CONST);
  1767.                 mp->val.type = tp;
  1768.                 mp->val.i = num++;
  1769.                 mp->type = tp;
  1770.                 if (sl) {
  1771.                     mp->constdefn = (Expr *)sl->value;
  1772.                     mp->anyvarflag = 1;    /* Make sure constant is folded */
  1773.                     strlist_delete(&constmacros, sl);
  1774.                     if (mp->constdefn->kind == EK_NAME)
  1775.                         strchange(&mp->name, mp->constdefn->val.s);
  1776.                 } else {
  1777.                     if (!useenum) {
  1778. output(format_s("#define %s", mp->name));
  1779. mp->isreturn = 1;
  1780. out_spaces(constindent, 0, 0, 0);
  1781. saveind = outindent;
  1782. outindent = cur_column();
  1783. output(format_d("%dn", mp->val.i));
  1784. outindent = saveind;
  1785.     }
  1786. }
  1787.                 *flast = mp;
  1788.                 flast = &(mp->xnext);
  1789.                 gettok();
  1790.             } while (curtok == TOK_COMMA);
  1791.     if (!wneedtok(TOK_RPAR))
  1792. skippasttoken(TOK_RPAR);
  1793.             tp->smin = makeexpr_long(0);
  1794.             tp->smax = makeexpr_long(num-1);
  1795.             if (!useenum)
  1796.                 outsection(minorspace);
  1797.             break;
  1799. case TOK_LBR:
  1800.     tp = p_modula_subrange(NULL);
  1801.     break;
  1803.         case TOK_IDENT:
  1804.             if (!curtokmeaning) {
  1805.                 undefsym(curtoksym);
  1806.                 tp = tp_integer;
  1807.                 mp = addmeaning(curtoksym, MK_TYPE);
  1808.                 mp->type = tp;
  1809.                 gettok();
  1810.                 break;
  1811.             } else if (curtokmeaning == mp_string) {
  1812.                 gettok();
  1813.                 tp = maketype(TK_STRING);
  1814.                 tp->basetype = tp_char;
  1815.                 if (curtok == TOK_LBR) {
  1816.                     gettok();
  1817.                     ex = p_ord_expr();
  1818.                     if (!wneedtok(TOK_RBR))
  1819. skippasttoken(TOK_RBR);
  1820.                 } else {
  1821.     ex = makeexpr_long(stringdefault);
  1822.                 }
  1823.                 val = eval_expr(ex);
  1824.                 if (val.type && stringceiling != 255 &&
  1825.                     (val.i >= 255 || val.i > stringceiling)) {
  1826.                     freeexpr(ex);
  1827.                     ex = makeexpr_long(stringceiling);
  1828.                 }
  1829.                 tp->indextype = makesubrangetype(tp_integer, makeexpr_long(0), ex);
  1830.                 break;
  1831.             } else if (curtokmeaning->kind == MK_TYPE) {
  1832.                 tp = curtokmeaning->type;
  1833. if (sizespec > 0) {
  1834.     if (ord_type(tp)->kind == TK_INTEGER && sizespec <= 32) {
  1835. if (checkconst(tp->smin, 0)) {
  1836.     if (sizespec == 32)
  1837. tp = tp_unsigned;
  1838.     else
  1839. tp = makesubrangetype(tp_unsigned,
  1840.  makeexpr_long(0),
  1841.          makeexpr_long((1L << sizespec) - 1));
  1842. } else {
  1843.     tp = makesubrangetype(tp_integer,
  1844.      makeexpr_long(- ((1L << (sizespec-1)))),
  1845.      makeexpr_long((1L << (sizespec-1)) - 1));
  1846. }
  1847. sizespec = -1;
  1848.     }
  1849. }
  1850.                 gettok();
  1851. if (curtok == TOK_LBR) {
  1852.     if (modula2) {
  1853. tp = p_modula_subrange(tp);
  1854.     } else {
  1855. gettok();
  1856. ex = p_expr(tp_integer);
  1857. note("UCSD size spec ignored; using 'long int' [110]");
  1858. if (ord_type(tp)->kind == TK_INTEGER)
  1859.     tp = tp_integer;
  1860. if (!wneedtok(TOK_RBR))
  1861.     skippasttotoken(TOK_RBR, TOK_SEMI);
  1862.     }
  1863. }
  1864.                 break;
  1865.             }
  1867.         /* fall through */
  1868.         default:
  1869.             tp = maketype(TK_SUBR);
  1870.             tp->smin = p_ord_expr();
  1871.     if (wexpecttok(TOK_DOTS)) {
  1872. gettok();
  1873. tp->smax = p_ord_expr();
  1874. if (tp->smax->val.type->kind == TK_REAL &&
  1875.     tp->smax->kind == EK_CONST &&
  1876.     strlen(tp->smax->val.s) == 12 &&
  1877.     strcmp(tp->smax->val.s, "2147483648.0") >= 0 &&