v21i059: Pascal to C translator, Part14/32
Rich Salz
rsalz at uunet.uu.net
Wed Mar 28 08:16:41 AEST 1990
Submitted-by: Dave Gillespie <daveg at csvax.caltech.edu>
Posting-number: Volume 21, Issue 59
Archive-name: p2c/part14
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 14 (of 32)."
# Contents: src/decl.c.3
# Wrapped by rsalz at litchi.bbn.com on Mon Mar 26 14:29:37 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/decl.c.3' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'src/decl.c.3'\"
else
echo shar: Extracting \"'src/decl.c.3'\" \(38042 characters\)
sed "s/^X//" >'src/decl.c.3' <<'END_OF_FILE'
X strcmp(tp->smax->val.s, "4294967295.0") <= 0) {
X tp = tp_unsigned;
X break;
X }
X tp->basetype = ord_type(tp->smin->val.type);
X } else {
X tp = tp_integer;
X }
X break;
X }
X if (sizespec >= 0)
X note(format_d("Don't know how to interpret size = %d bits [111]", sizespec));
X return tp;
X}
X
X
X
X
X
XType *p_funcdecl(isfunc, istype)
Xint *isfunc, istype;
X{
X Meaning *retmp = NULL, *mp, *firstmp, *lastmp, **prevm, **oldprevm;
X Type *type, *tp;
X enum meaningkind parkind;
X int anyvarflag, constflag, volatileflag, num = 0;
X Symbol *sym;
X Expr *defval;
X Token savetok;
X Strlist *l1;
X
X if (*isfunc || modula2) {
X sym = findsymbol(format_s(name_RETV, curctx->name));
X retmp = addmeaning(sym, MK_VAR);
X retmp->isreturn = 1;
X }
X type = maketype(TK_FUNCTION);
X if (curtok == TOK_LPAR) {
X prevm = &type->fbase;
X do {
X gettok();
X p_mech_spec(1);
X p_attributes();
X checkkeyword(TOK_ANYVAR);
X if (curtok == TOK_VAR || curtok == TOK_ANYVAR) {
X parkind = MK_VARPARAM;
X anyvarflag = (curtok == TOK_ANYVAR);
X gettok();
X } else if (curtok == TOK_PROCEDURE || curtok == TOK_FUNCTION) {
X savetok = curtok;
X gettok();
X wexpecttok(TOK_IDENT);
X *prevm = firstmp = addmeaning(curtoksym, MK_PARAM);
X prevm = &firstmp->xnext;
X firstmp->anyvarflag = 0;
X curtok = savetok; /* rearrange tokens to a proc ptr type! */
X firstmp->type = p_type(firstmp);
X continue;
X } else {
X parkind = MK_PARAM;
X anyvarflag = 0;
X }
X oldprevm = prevm;
X if (modula2 && istype) {
X firstmp = addmeaning(findsymbol(format_d("_A%d", ++num)), parkind);
X } else {
X wexpecttok(TOK_IDENT);
X firstmp = addmeaning(curtoksym, parkind);
X gettok();
X }
X *prevm = firstmp;
X prevm = &firstmp->xnext;
X firstmp->isactive = 0; /* nit-picking Turbo compatibility */
X lastmp = firstmp;
X while (curtok == TOK_COMMA) {
X gettok();
X if (wexpecttok(TOK_IDENT)) {
X *prevm = lastmp = addmeaning(curtoksym, parkind);
X prevm = &lastmp->xnext;
X lastmp->isactive = 0;
X }
X gettok();
X }
X constflag = volatileflag = 0;
X defval = NULL;
X if (curtok != TOK_COLON && !modula2) {
X if (parkind != MK_VARPARAM)
X wexpecttok(TOK_COLON);
X parkind = MK_VARPARAM;
X tp = tp_anyptr;
X anyvarflag = 1;
X } else {
X if (curtok == TOK_COLON)
X gettok();
X if (curtok == TOK_IDENT && !curtokmeaning &&
X !strcicmp(curtokbuf, "UNIV")) {
X if (parkind == MK_PARAM)
X note("UNIV may not work for non-VAR parameters [112]");
X anyvarflag = 1;
X gettok();
X }
X p_attributes();
X if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
X constflag = 1;
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
X volatileflag = 1;
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "UNSAFE")) != NULL &&
X parkind == MK_VARPARAM) {
X anyvarflag = 1;
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "REFERENCE")) != NULL) {
X note("REFERENCE attribute treated like VAR [107]");
X parkind = MK_VARPARAM;
X strlist_delete(&attrlist, l1);
X }
X checkkeyword(TOK_VARYING);
X if (curtok == TOK_IDENT && curtokmeaning == mp_string &&
X !anyvarflag && parkind == MK_VARPARAM) {
X anyvarflag = (varstrings > 0);
X tp = tp_str255;
X gettok();
X if (curtok == TOK_LBR) {
X wexpecttok(TOK_SEMI);
X skipparens();
X }
X } else if (curtok == TOK_ARRAY || curtok == TOK_PACKED ||
X curtok == TOK_VARYING) {
X prevm = oldprevm;
X tp = p_conformant_array(firstmp->name, &prevm);
X *prevm = firstmp;
X while (*prevm)
X prevm = &(*prevm)->xnext;
X } else {
X tp = p_type(firstmp);
X }
X if (!varfiles && isfiletype(tp))
X parkind = MK_PARAM;
X if (parkind == MK_VARPARAM)
X tp = makepointertype(tp);
X }
X if (curtok == TOK_ASSIGN) { /* check for parameter default */
X gettok();
X p_mech_spec(0);
X defval = gentle_cast(p_expr(tp), tp);
X if ((tp->kind == TK_STRING || tp->kind == TK_ARRAY) &&
X tp->basetype->kind == TK_CHAR &&
X tp->structdefd && /* conformant string */
X defval->val.type->kind == TK_STRING) {
X mp = *oldprevm;
X if (tp->kind == TK_ARRAY) {
X mp->constdefn = makeexpr_long(1);
X mp = mp->xnext;
X }
X mp->constdefn = strmax_func(defval);
X }
X }
X while (firstmp) {
X firstmp->type = tp;
X firstmp->kind = parkind; /* in case it changed */
X firstmp->isactive = 1;
X firstmp->anyvarflag = anyvarflag;
X firstmp->constqual = constflag;
X firstmp->volatilequal = volatileflag;
X if (defval) {
X if (firstmp == lastmp)
X firstmp->constdefn = defval;
X else
X firstmp->constdefn = copyexpr(defval);
X }
X if (parkind == MK_PARAM &&
X (tp->kind == TK_STRING ||
X tp->kind == TK_ARRAY ||
X tp->kind == TK_SET ||
X ((tp->kind == TK_RECORD || tp->kind == TK_PROCPTR) && copystructs < 2))) {
X firstmp->othername = stralloc(format_s(name_COPYPAR, firstmp->name));
X firstmp->rectype = makepointertype(tp);
X }
X if (firstmp == lastmp)
X break;
X firstmp = firstmp->xnext;
X }
X } while (curtok == TOK_SEMI || curtok == TOK_COMMA);
X if (!wneedtok(TOK_RPAR))
X skippasttotoken(TOK_RPAR, TOK_SEMI);
X }
X if (modula2) {
X if (curtok == TOK_COLON) {
X *isfunc = 1;
X } else {
X unaddmeaning(retmp);
X }
X }
X if (*isfunc) {
X if (wneedtok(TOK_COLON)) {
X retmp->type = type->basetype = p_type(NULL);
X switch (retmp->type->kind) {
X
X case TK_RECORD:
X case TK_PROCPTR:
X if (copystructs >= 3)
X break;
X
X /* fall through */
X case TK_ARRAY:
X case TK_STRING:
X case TK_SET:
X type->basetype = retmp->type = makepointertype(retmp->type);
X retmp->kind = MK_VARPARAM;
X retmp->anyvarflag = 0;
X retmp->xnext = type->fbase;
X type->fbase = retmp;
X retmp->refcount++;
X break;
X
X default:
X break;
X }
X } else
X retmp->type = type->basetype = tp_integer;
X } else
X type->basetype = tp_void;
X return type;
X}
X
X
X
X
X
XSymbol *findlabelsym()
X{
X if (curtok == TOK_IDENT &&
X curtokmeaning && curtokmeaning->kind == MK_LABEL) {
X#if 0
X if (curtokmeaning->ctx != curctx && curtokmeaning->val.i != 0)
X curtokmeaning->val.i = --nonloclabelcount;
X#endif
X } else if (curtok == TOK_INTLIT) {
X strcpy(curtokcase, curtokbuf);
X curtoksym = findsymbol(curtokbuf);
X curtokmeaning = curtoksym->mbase;
X while (curtokmeaning && !curtokmeaning->isactive)
X curtokmeaning = curtokmeaning->snext;
X if (!curtokmeaning || curtokmeaning->kind != MK_LABEL)
X return NULL;
X#if 0
X if (curtokmeaning->ctx != curctx && curtokmeaning->val.i != 0)
X if (curtokint == 0)
X curtokmeaning->val.i = -1;
X else
X curtokmeaning->val.i = curtokint;
X#endif
X } else
X return NULL;
X return curtoksym;
X}
X
X
Xvoid p_labeldecl()
X{
X Symbol *sp;
X Meaning *mp;
X
X do {
X gettok();
X if (curtok != TOK_IDENT)
X wexpecttok(TOK_INTLIT);
X sp = findlabelsym();
X mp = addmeaning(curtoksym, MK_LABEL);
X mp->val.i = 0;
X mp->xnext = addmeaning(findsymbol(format_s(name_LABVAR,
X mp->name)),
X MK_VAR);
X mp->xnext->type = tp_jmp_buf;
X mp->xnext->refcount = 0;
X gettok();
X } while (curtok == TOK_COMMA);
X if (!wneedtok(TOK_SEMI))
X skippasttoken(TOK_SEMI);
X}
X
X
X
X
X
XMeaning *findfieldname(sym, variants, nvars)
XSymbol *sym;
XMeaning **variants;
Xint *nvars;
X{
X Meaning *mp, *mp0;
X
X mp = variants[*nvars-1];
X while (mp && mp->kind == MK_FIELD) {
X if (mp->sym == sym) {
X return mp;
X }
X mp = mp->cnext;
X }
X while (mp) {
X variants[(*nvars)++] = mp->ctx;
X mp0 = findfieldname(sym, variants, nvars);
X if (mp0)
X return mp0;
X (*nvars)--;
X while (mp->cnext && mp->cnext->ctx == mp->ctx)
X mp = mp->cnext;
X mp = mp->cnext;
X }
X return NULL;
X}
X
X
X
X
XExpr *p_constrecord(type, style)
XType *type;
Xint style; /* 0=HP, 1=Turbo, 2=Oregon+VAX */
X{
X Meaning *mp, *mp0, *variants[20], *newvariants[20], *curfield;
X Symbol *sym;
X Value val;
X Expr *ex, *cex;
X int i, j, nvars, newnvars, varcounts[20];
X
X if (!wneedtok(style ? TOK_LPAR : TOK_LBR))
X return makeexpr_long(0);
X cex = makeexpr(EK_STRUCTCONST, 0);
X nvars = 0;
X varcounts[0] = 0;
X curfield = type->fbase;
X for (;;) {
X if (style == 2) {
X if (curfield) {
X mp = curfield;
X if (mp->kind == MK_VARIANT || mp->isforward) {
X val = p_constant(mp->type);
X if (mp->kind == MK_FIELD) {
X insertarg(&cex, cex->nargs, makeexpr_val(val));
X mp = mp->cnext;
X }
X val.type = mp->val.type;
X if (!valuesame(val, mp->val)) {
X while (mp && !valuesame(val, mp->val))
X mp = mp->cnext;
X if (mp) {
X note("Attempting to initialize union member other than first [113]");
X curfield = mp->ctx;
X } else {
X warning("Tag value does not exist in record [129]");
X curfield = NULL;
X }
X } else
X curfield = mp->ctx;
X goto ignorefield;
X } else {
X i = cex->nargs;
X insertarg(&cex, i, NULL);
X if (mp->isforward && curfield->cnext)
X curfield = curfield->cnext->ctx;
X else
X curfield = curfield->cnext;
X }
X } else {
X warning("Too many fields in record constructor [130]");
X ex = p_expr(NULL);
X freeexpr(ex);
X goto ignorefield;
X }
X } else {
X if (!wexpecttok(TOK_IDENT)) {
X skiptotoken2(TOK_RPAR, TOK_RBR);
X break;
X }
X sym = curtoksym;
X gettok();
X if (!wneedtok(TOK_COLON)) {
X skiptotoken2(TOK_RPAR, TOK_RBR);
X break;
X }
X newnvars = 1;
X newvariants[0] = type->fbase;
X mp = findfieldname(sym, newvariants, &newnvars);
X if (!mp) {
X warning(format_s("Field %s not in record [131]", sym->name));
X ex = p_expr(NULL); /* good enough */
X freeexpr(ex);
X goto ignorefield;
X }
X for (i = 0; i < nvars && i < newnvars; i++) {
X if (variants[i] != newvariants[i]) {
X warning("Fields are members of incompatible variants [132]");
X ex = p_subconst(mp->type, style);
X freeexpr(ex);
X goto ignorefield;
X }
X }
X while (nvars < newnvars) {
X variants[nvars] = newvariants[nvars];
X if (nvars > 0) {
X for (mp0 = variants[nvars-1]; mp0->kind != MK_VARIANT; mp0 = mp0->cnext) ;
X if (mp0->ctx != variants[nvars])
X note("Attempting to initialize union member other than first [113]");
X }
X i = varcounts[nvars];
X for (mp0 = variants[nvars]; mp0 && mp0->kind == MK_FIELD; mp0 = mp0->cnext)
X i++;
X nvars++;
X varcounts[nvars] = i;
X while (cex->nargs < i)
X insertarg(&cex, cex->nargs, NULL);
X }
X i = varcounts[newnvars-1];
X for (mp0 = variants[newnvars-1]; mp0->sym != sym; mp0 = mp0->cnext)
X i++;
X if (cex->args[i])
X warning(format_s("Two constructors for %s [133]", mp->name));
X }
X ex = p_subconst(mp->type, style);
X if (ex->kind == EK_CONST &&
X (ex->val.type->kind == TK_RECORD ||
X ex->val.type->kind == TK_ARRAY))
X ex = (Expr *)ex->val.i;
X cex->args[i] = ex;
Xignorefield:
X if (curtok == TOK_COMMA || curtok == TOK_SEMI)
X gettok();
X else
X break;
X }
X if (!wneedtok(style ? TOK_RPAR : TOK_RBR))
X skippasttoken2(TOK_RPAR, TOK_RBR);
X if (style != 2) {
X j = 0;
X mp = variants[0];
X for (i = 0; i < cex->nargs; i++) {
X while (!mp || mp->kind != MK_FIELD)
X mp = variants[++j];
X if (!cex->args[i]) {
X warning(format_s("No constructor for %s [134]", mp->name));
X cex->args[i] = makeexpr_name("<oops>", mp->type);
X }
X mp = mp->cnext;
X }
X }
X val.type = type;
X val.i = (long)cex;
X val.s = NULL;
X return makeexpr_val(val);
X}
X
X
X
X
XExpr *p_constarray(type, style)
XType *type;
Xint style;
X{
X Value val;
X Expr *ex, *cex;
X int nvals, skipped;
X long smin, smax;
X
X if (type->kind == TK_SMALLARRAY)
X warning("Small-array constructors not yet implemented [135]");
X if (!wneedtok(style ? TOK_LPAR : TOK_LBR))
X return makeexpr_long(0);
X if (type->smin && type->smin->kind == EK_CONST)
X skipped = type->smin->val.i;
X else
X skipped = 0;
X cex = NULL;
X for (;;) {
X if (style && (curtok == TOK_LPAR || curtok == TOK_LBR)) {
X ex = p_subconst(type->basetype, style);
X nvals = 1;
X } else if (curtok == TOK_REPEAT) {
X gettok();
X ex = p_expr(type->basetype);
X if (ord_range(type->indextype, &smin, &smax)) {
X nvals = smax - smin + 1;
X if (cex)
X nvals -= cex->nargs;
X } else {
X nvals = 1;
X note("REPEAT not translatable for non-constant array bounds [114]");
X }
X ex = gentle_cast(ex, type->basetype);
X } else {
X ex = p_expr(type->basetype);
X if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING &&
X ex->val.i > 1 && !skipped && style == 0 && !cex &&
X type->basetype->kind == TK_CHAR &&
X checkconst(type->indextype->smin, 1)) {
X if (!wneedtok(TOK_RBR))
X skippasttoken2(TOK_RBR, TOK_RPAR);
X return ex; /* not quite right, but close enough */
X }
X if (curtok == TOK_OF) {
X ex = gentle_cast(ex, tp_integer);
X val = eval_expr(ex);
X freeexpr(ex);
X if (!val.type)
X warning("Expected a constant [127]");
X nvals = val.i;
X gettok();
X ex = p_expr(type->basetype);
X } else
X nvals = 1;
X ex = gentle_cast(ex, type->basetype);
X }
X nvals += skipped;
X skipped = 0;
X if (ex->kind == EK_CONST &&
X (ex->val.type->kind == TK_RECORD ||
X ex->val.type->kind == TK_ARRAY))
X ex = (Expr *)ex->val.i;
X if (nvals != 1) {
X ex = makeexpr_un(EK_STRUCTOF, type->basetype, ex);
X ex->val.i = nvals;
X }
X if (cex)
X insertarg(&cex, cex->nargs, ex);
X else
X cex = makeexpr_un(EK_STRUCTCONST, type, ex);
X if (curtok == TOK_COMMA)
X gettok();
X else
X break;
X }
X if (!wneedtok(style ? TOK_RPAR : TOK_RBR))
X skippasttoken2(TOK_RPAR, TOK_RBR);
X val.type = type;
X val.i = (long)cex;
X val.s = NULL;
X return makeexpr_val(val);
X}
X
X
X
X
XExpr *p_conststring(type, style)
XType *type;
Xint style;
X{
X Expr *ex;
X Token close = (style ? TOK_RPAR : TOK_RBR);
X
X if (curtok != (style ? TOK_LPAR : TOK_LBR))
X return p_expr(type);
X gettok();
X ex = p_expr(tp_integer); /* should handle "OF" and "," for constructors */
X if (curtok == TOK_OF || curtok == TOK_COMMA) {
X warning("Multi-element string constructors not yet supported [136]");
X skiptotoken(close);
X }
X if (!wneedtok(close))
X skippasttoken(close);
X return ex;
X}
X
X
X
X
XExpr *p_subconst(type, style)
XType *type;
Xint style;
X{
X Value val;
X
X if (curtok == TOK_IDENT && curtokmeaning &&
X curtokmeaning->kind == MK_TYPE) {
X if (curtokmeaning->type != type)
X warning("Type conflict in constant [137]");
X gettok();
X }
X if (curtok == TOK_IDENT && !strcicmp(curtokbuf, "ZERO") &&
X !curtokmeaning) { /* VAX Pascal foolishness */
X gettok();
X if (type->kind == TK_STRING)
X return makeexpr_string("");
X if (type->kind == TK_REAL)
X return makeexpr_real("0.0");
X val.type = type;
X if (type->kind == TK_RECORD || type->kind == TK_ARRAY ||
X type->kind == TK_SET)
X val.i = (long)makeexpr_un(EK_STRUCTCONST, type, makeexpr_long(0));
X else
X val.i = 0;
X val.s = NULL;
X return makeexpr_val(val);
X }
X switch (type->kind) {
X
X case TK_RECORD:
X if (curtok == (style ? TOK_LPAR : TOK_LBR))
X return p_constrecord(type, style);
X break;
X
X case TK_SMALLARRAY:
X case TK_ARRAY:
X if (curtok == (style ? TOK_LPAR : TOK_LBR))
X return p_constarray(type, style);
X break;
X
X case TK_SMALLSET:
X case TK_SET:
X if (curtok == TOK_LBR)
X return p_setfactor(type);
X break;
X
X default:
X break;
X
X }
X return gentle_cast(p_expr(type), type);
X}
X
X
X
Xvoid p_constdecl()
X{
X Meaning *mp;
X Expr *ex, *ex2;
X Type *oldtype;
X char savetokcase[sizeof(curtokcase)];
X Symbol *savetoksym;
X Strlist *sl;
X int i, saveindent, outflag = (blockkind != TOK_IMPORT);
X
X if (outflag)
X outsection(majorspace);
X flushcomments(NULL, -1, -1);
X gettok();
X oldtype = NULL;
X while (curtok == TOK_IDENT) {
X strcpy(savetokcase, curtokcase);
X savetoksym = curtoksym;
X gettok();
X strcpy(curtokcase, savetokcase); /* what a kludge! */
X curtoksym = savetoksym;
X if (curtok == TOK_COLON) { /* Turbo Pascal typed constant */
X mp = addmeaning(curtoksym, MK_VAR);
X decl_comments(mp);
X gettok();
X mp->type = p_type(mp);
X if (wneedtok(TOK_EQ)) {
X if (mp->kind == MK_VARMAC) {
X freeexpr(p_subconst(mp->type, 1));
X note("Initializer ignored for variable with VarMacro [115]");
X } else {
X mp->constdefn = p_subconst(mp->type, 1);
X if (blockkind == TOK_EXPORT) {
X /* nothing */
X } else {
X mp->isforward = 1; /* static variable */
X }
X }
X }
X decl_comments(mp);
X } else {
X sl = strlist_find(constmacros, curtoksym->name);
X if (sl) {
X mp = addmeaning(curtoksym, MK_VARMAC);
X mp->constdefn = (Expr *)sl->value;
X strlist_delete(&constmacros, sl);
X } else {
X mp = addmeaning(curtoksym, MK_CONST);
X }
X decl_comments(mp);
X if (!wexpecttok(TOK_EQ)) {
X skippasttoken(TOK_SEMI);
X continue;
X }
X mp->isactive = 0; /* A fine point indeed (see below) */
X gettok();
X if (curtok == TOK_IDENT &&
X curtokmeaning && curtokmeaning->kind == MK_TYPE &&
X (curtokmeaning->type->kind == TK_RECORD ||
X curtokmeaning->type->kind == TK_SMALLARRAY ||
X curtokmeaning->type->kind == TK_ARRAY)) {
X oldtype = curtokmeaning->type;
X gettok();
X ex = p_subconst(oldtype, (curtok == TOK_LBR) ? 0 : 2);
X } else
X ex = p_expr(NULL);
X mp->isactive = 1; /* Re-enable visibility of the new constant */
X if (mp->kind == MK_CONST)
X mp->constdefn = ex;
X if (ord_type(ex->val.type)->kind == TK_INTEGER) {
X i = exprlongness(ex);
X if (i > 0)
X ex->val.type = tp_integer;
X else if (i < 0)
X ex->val.type = tp_int;
X }
X decl_comments(mp);
X mp->type = ex->val.type;
X mp->val = eval_expr(ex);
X if (mp->kind == MK_CONST) {
X switch (ex->val.type->kind) {
X
X case TK_INTEGER:
X case TK_BOOLEAN:
X case TK_CHAR:
X case TK_ENUM:
X case TK_SUBR:
X case TK_REAL:
X if (foldconsts > 0)
X mp->anyvarflag = 1;
X break;
X
X case TK_STRING:
X if (foldstrconsts > 0)
X mp->anyvarflag = 1;
X break;
X
X default:
X break;
X }
X }
X flushcomments(&mp->comments, CMT_PRE, -1);
X if (ex->val.type->kind == TK_SET) {
X mp->val.type = NULL;
X if (mp->kind == MK_CONST) {
X ex2 = makeexpr(EK_MACARG, 0);
X ex2->val.type = ex->val.type;
X mp->constdefn = makeexpr_assign(ex2, ex);
X }
X } else if (mp->kind == MK_CONST && outflag) {
X if (ex->val.type != oldtype) {
X outsection(minorspace);
X oldtype = ex->val.type;
X }
X switch (ex->val.type->kind) {
X
X case TK_ARRAY:
X case TK_RECORD:
X select_outfile(codef);
X outsection(minorspace);
X if (blockkind == TOK_IMPLEMENT || blockkind == TOK_PROGRAM)
X output("static ");
X if (useAnyptrMacros == 1 || useconsts == 2)
X output("Const ");
X else if (useconsts > 0)
X output("const ");
X outbasetype(mp->type, ODECL_CHARSTAR|ODECL_FREEARRAY);
X output(" ");
X outdeclarator(mp->type, mp->name,
X ODECL_CHARSTAR|ODECL_FREEARRAY);
X output(" = {");
X outtrailcomment(mp->comments, -1, declcommentindent);
X saveindent = outindent;
X moreindent(tabsize);
X moreindent(structinitindent);
X /* if (mp->val.s)
X output(mp->val.s);
X else */
X out_expr((Expr *)mp->val.i);
X outindent = saveindent;
X output("\n};\n");
X outsection(minorspace);
X if (blockkind == TOK_EXPORT) {
X select_outfile(hdrf);
X if (usevextern)
X output("vextern ");
X if (useAnyptrMacros == 1 || useconsts == 2)
X output("Const ");
X else if (useconsts > 0)
X output("const ");
X outbasetype(mp->type, ODECL_CHARSTAR);
X output(" ");
X outdeclarator(mp->type, mp->name, ODECL_CHARSTAR);
X output(";\n");
X }
X break;
X
X default:
X if (foldconsts > 0) break;
X output(format_s("#define %s", mp->name));
X mp->isreturn = 1;
X out_spaces(constindent, 0, 0, 0);
X saveindent = outindent;
X outindent = cur_column();
X out_expr_factor(ex);
X outindent = saveindent;
X outtrailcomment(mp->comments, -1, declcommentindent);
X break;
X
X }
X }
X flushcomments(&mp->comments, -1, -1);
X if (mp->kind == MK_VARMAC)
X freeexpr(ex);
X mp->wasdeclared = 1;
X }
X if (!wneedtok(TOK_SEMI))
X skippasttoken(TOK_SEMI);
X }
X if (outflag)
X outsection(majorspace);
X}
X
X
X
X
Xvoid declaresubtypes(mp)
XMeaning *mp;
X{
X Meaning *mp2;
X Type *tp;
X struct ptrdesc *pd;
X
X while (mp) {
X if (mp->kind == MK_VARIANT) {
X declaresubtypes(mp->ctx);
X } else {
X tp = mp->type;
X while (tp->basetype && !tp->meaning && tp->kind != TK_POINTER)
X tp = tp->basetype;
X if (tp->meaning && !tp->meaning->wasdeclared &&
X (tp->kind == TK_RECORD || tp->kind == TK_ENUM) &&
X tp->meaning->ctx && tp->meaning->ctx != nullctx) {
X pd = ptrbase; /* Do this now, just in case */
X while (pd) {
X if (pd->tp->basetype == tp_abyte) {
X mp2 = pd->sym->mbase;
X while (mp2 && !mp2->isactive)
X mp2 = mp2->snext;
X if (mp2 && mp2->kind == MK_TYPE) {
X pd->tp->basetype = mp2->type;
X if (!mp2->type->pointertype)
X mp2->type->pointertype = pd->tp;
X }
X }
X pd = pd->next;
X }
X declaretype(tp->meaning);
X }
X }
X mp = mp->cnext;
X }
X}
X
X
Xvoid declaretype(mp)
XMeaning *mp;
X{
X int saveindent;
X
X switch (mp->type->kind) {
X
X case TK_RECORD:
X if (mp->type->meaning != mp) {
X output(format_ss("typedef %s %s;",
X mp->type->meaning->name,
X mp->name));
X } else {
X declaresubtypes(mp->type->fbase);
X outsection(minorspace);
X if (record_is_union(mp->type))
X output("typedef union ");
X else
X output("typedef struct ");
X output(format_s("%s {\n", format_s(name_STRUCT, mp->name)));
X saveindent = outindent;
X moreindent(tabsize);
X moreindent(structindent);
X outfieldlist(mp->type->fbase);
X outindent = saveindent;
X output(format_s("} %s;", mp->name));
X }
X outtrailcomment(mp->comments, -1, declcommentindent);
X mp->type->structdefd = 1;
X if (mp->type->meaning == mp)
X outsection(minorspace);
X break;
X
X case TK_ARRAY:
X case TK_SMALLARRAY:
X output("typedef ");
X if (mp->type->meaning != mp) {
X output(format_ss("%s %s",
X mp->type->meaning->name,
X mp->name));
X } else {
X outbasetype(mp->type, 0);
X output(" ");
X outdeclarator(mp->type, mp->name, 0);
X }
X output(";");
X outtrailcomment(mp->comments, -1, declcommentindent);
X break;
X
X case TK_ENUM:
X if (useenum) {
X output("typedef ");
X if (mp->type->meaning != mp)
X output(mp->type->meaning->name);
X else
X outbasetype(mp->type, 0);
X output(" ");
X output(mp->name);
X output(";");
X outtrailcomment(mp->comments, -1,
X declcommentindent);
X }
X break;
X
X default:
X break;
X }
X mp->wasdeclared = 1;
X}
X
X
X
Xvoid declaretypes(outflag)
Xint outflag;
X{
X Meaning *mp;
X
X for (mp = curctx->cbase; mp; mp = mp->cnext) {
X if (mp->kind == MK_TYPE && !mp->wasdeclared) {
X if (outflag) {
X flushcomments(&mp->comments, CMT_PRE, -1);
X declaretype(mp);
X flushcomments(&mp->comments, -1, -1);
X }
X mp->wasdeclared = 1;
X }
X }
X}
X
X
X
Xvoid p_typedecl()
X{
X Meaning *mp;
X int outflag = (blockkind != TOK_IMPORT);
X struct ptrdesc *pd;
X
X if (outflag)
X outsection(majorspace);
X flushcomments(NULL, -1, -1);
X gettok();
X outsection(minorspace);
X deferallptrs = 1;
X anydeferredptrs = 0;
X notephase = 1;
X while (curtok == TOK_IDENT) {
X mp = addmeaning(curtoksym, MK_TYPE);
X mp->type = tp_integer; /* in case of syntax errors */
X gettok();
X decl_comments(mp);
X if (curtok == TOK_SEMI) {
X mp->type = tp_anyptr; /* Modula-2 opaque type */
X } else {
X if (!wneedtok(TOK_EQ)) {
X skippasttoken(TOK_SEMI);
X continue;
X }
X mp->type = p_type(mp);
X decl_comments(mp);
X if (!mp->type->meaning)
X mp->type->meaning = mp;
X if (mp->type->kind == TK_RECORD)
X mp->type->structdefd = 1;
X if (!anydeferredptrs)
X declaretypes(outflag);
X }
X if (!wneedtok(TOK_SEMI))
X skippasttoken(TOK_SEMI);
X }
X notephase = 0;
X deferallptrs = 0;
X while (ptrbase) {
X pd = ptrbase;
X if (pd->tp->basetype == tp_abyte) {
X mp = pd->sym->mbase;
X while (mp && !mp->isactive)
X mp = mp->snext;
X if (!mp || mp->kind != MK_TYPE) {
X warning(format_s("Unsatisfied forward reference to type %s [138]", pd->sym->name));
X } else {
X pd->tp->basetype = mp->type;
X if (!mp->type->pointertype)
X mp->type->pointertype = pd->tp;
X }
X }
X ptrbase = ptrbase->next;
X FREE(pd);
X }
X declaretypes(outflag);
X outsection(minorspace);
X flushcomments(NULL, -1, -1);
X if (outflag)
X outsection(majorspace);
X}
X
X
X
X
X
XStatic void nameexternalvar(mp, name)
XMeaning *mp;
Xchar *name;
X{
X if (!wasaliased) {
X if (*externalias && my_strchr(externalias, '%'))
X strchange(&mp->name, format_s(externalias, name));
X else
X strchange(&mp->name, name);
X }
X}
X
X
XStatic void handlebrackets(mp, skip, wasaliased)
XMeaning *mp;
Xint skip, wasaliased;
X{
X Expr *ex;
X
X checkkeyword(TOK_ORIGIN);
X if (curtok == TOK_ORIGIN) {
X gettok();
X ex = p_expr(tp_integer);
X mp->kind = MK_VARREF;
X mp->constdefn = gentle_cast(ex, tp_integer);
X } else if (curtok == TOK_LBR) {
X gettok();
X ex = p_expr(tp_integer);
X if (!wneedtok(TOK_RBR))
X skippasttotoken(TOK_RBR, TOK_SEMI);
X if (skip) {
X freeexpr(ex);
X return;
X }
X if (ex->kind == EK_CONST && ex->val.type->kind == TK_STRING) {
X nameexternalvar(mp, ex->val.s);
X mp->isfunction = 1; /* make it extern */
X } else {
X note(format_s("Absolute-addressed variable %s was generated [116]", mp->name));
X mp->kind = MK_VARREF;
X mp->constdefn = gentle_cast(ex, tp_integer);
X }
X }
X}
X
X
X
XStatic void handleabsolute(mp, skip)
XMeaning *mp;
Xint skip;
X{
X Expr *ex;
X Value val;
X long i;
X
X checkkeyword(TOK_ABSOLUTE);
X if (curtok == TOK_ABSOLUTE) {
X gettok();
X if (skip) {
X freeexpr(p_expr(tp_integer));
X if (curtok == TOK_COLON) {
X gettok();
X freeexpr(p_expr(tp_integer));
X }
X return;
X }
X note(format_s("Absolute-addressed variable %s was generated [116]", mp->name));
X mp->kind = MK_VARREF;
X if (curtok == TOK_IDENT &&
X curtokmeaning && (curtokmeaning->kind != MK_CONST ||
X ord_type(curtokmeaning->type)->kind != TK_INTEGER)) {
X mp->constdefn = makeexpr_addr(p_expr(NULL));
X mp->isfunction = 1; /* make it extern */
X } else {
X ex = gentle_cast(p_expr(tp_integer), tp_integer);
X if (curtok == TOK_COLON) {
X val = eval_expr(ex);
X if (!val.type)
X warning("Expected a constant [127]");
X i = val.i & 0xffff;
X gettok();
X val = p_constant(tp_integer);
X i = (i<<16) | (val.i & 0xffff); /* as good a notation as any! */
X ex = makeexpr_long(i);
X insertarg(&ex, 0, makeexpr_name("%#lx", tp_integer));
X }
X mp->constdefn = ex;
X }
X }
X}
X
X
X
Xvoid setupfilevar(mp)
XMeaning *mp;
X{
X if (mp->kind != MK_VARMAC && isfiletype(mp->type)) {
X if (storefilenames && *name_FNVAR)
X mp->namedfile = 1;
X if (checkvarinlists(bufferedfiles, unbufferedfiles, 0, mp))
X mp->bufferedfile = 1;
X }
X}
X
X
X
X
Xvoid p_vardecl()
X{
X Meaning *firstmp, *lastmp;
X Type *tp;
X int aliasflag, volatileflag, constflag, staticflag, globalflag, externflag;
X Strlist *l1;
X Expr *initexpr;
X
X gettok();
X notephase = 1;
X while (curtok == TOK_IDENT) {
X firstmp = lastmp = addmeaning(curtoksym, MK_VAR);
X lastmp->type = tp_integer; /* in case of syntax errors */
X aliasflag = wasaliased;
X gettok();
X handlebrackets(lastmp, (lastmp->kind != MK_VAR), aliasflag);
X decl_comments(lastmp);
X while (curtok == TOK_COMMA) {
X gettok();
X if (wexpecttok(TOK_IDENT)) {
X lastmp = addmeaning(curtoksym, MK_VAR);
X lastmp->type = tp_integer;
X aliasflag = wasaliased;
X gettok();
X handlebrackets(lastmp, (lastmp->kind != MK_VAR), aliasflag);
X decl_comments(lastmp);
X }
X }
X if (!wneedtok(TOK_COLON)) {
X skippasttoken(TOK_SEMI);
X continue;
X }
X p_attributes();
X volatileflag = constflag = staticflag = globalflag = externflag = 0;
X if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
X constflag = 1;
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
X volatileflag = 1;
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "STATIC")) != NULL) {
X staticflag = 1;
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "AUTOMATIC")) != NULL) {
X /* This is the default! */
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "AT")) != NULL) {
X note(format_s("Absolute-addressed variable %s was generated [116]", lastmp->name));
X lastmp->kind = MK_VARREF;
X lastmp->constdefn = makeexpr_long(l1->value);
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "GLOBAL")) != NULL ||
X (l1 = strlist_find(attrlist, "WEAK_GLOBAL")) != NULL) {
X globalflag = 1;
X if (l1->value != -1)
X nameexternalvar(lastmp, (char *)l1->value);
X if (l1->s[0] != 'W')
X strlist_delete(&attrlist, l1);
X }
X if ((l1 = strlist_find(attrlist, "EXTERNAL")) != NULL ||
X (l1 = strlist_find(attrlist, "WEAK_EXTERNAL")) != NULL) {
X externflag = 1;
X if (l1->value != -1)
X nameexternalvar(lastmp, (char *)l1->value);
X if (l1->s[0] != 'W')
X strlist_delete(&attrlist, l1);
X }
X tp = p_type(firstmp);
X decl_comments(lastmp);
X handleabsolute(lastmp, (lastmp->kind != MK_VAR));
X initexpr = NULL;
X if (curtok == TOK_ASSIGN) { /* VAX Pascal initializer */
X gettok();
X initexpr = p_subconst(tp, 2);
X if (lastmp->kind == MK_VARMAC) {
X freeexpr(initexpr);
X initexpr = NULL;
X note("Initializer ignored for variable with VarMacro [115]");
X }
X }
X for (;;) {
X if (firstmp->kind == MK_VARREF) {
X firstmp->type = makepointertype(tp);
X firstmp->constdefn = makeexpr_cast(firstmp->constdefn, firstmp->type);
X } else {
X firstmp->type = tp;
X setupfilevar(firstmp);
X if (initexpr) {
X if (firstmp == lastmp)
X firstmp->constdefn = initexpr;
X else
X firstmp->constdefn = copyexpr(initexpr);
X }
X }
X firstmp->volatilequal = volatileflag;
X firstmp->constqual = constflag;
X firstmp->isforward |= staticflag;
X firstmp->isfunction |= externflag;
X firstmp->exported |= globalflag;
X if (globalflag && (curctx->kind != MK_MODULE || mainlocals))
X declarevar(firstmp, -1);
X if (firstmp == lastmp)
X break;
X firstmp = firstmp->cnext;
X }
X if (!wneedtok(TOK_SEMI))
X skippasttoken(TOK_SEMI);
X }
X notephase = 0;
X}
X
X
X
X
Xvoid p_valuedecl()
X{
X Meaning *mp;
X
X gettok();
X while (curtok == TOK_IDENT) {
X if (!curtokmeaning ||
X curtokmeaning->kind != MK_VAR) {
X warning(format_s("Initializer ignored for variable %s [139]",
X curtokmeaning->name));
X skippasttoken(TOK_SEMI);
X } else {
X mp = curtokmeaning;
X gettok();
X if (curtok == TOK_DOT || curtok == TOK_LBR) {
X note("Partial structure initialization not supported [117]");
X skippasttoken(TOK_SEMI);
X } else if (wneedtok(TOK_ASSIGN)) {
X mp->constdefn = p_subconst(mp->type, 2);
X if (!wneedtok(TOK_SEMI))
X skippasttoken(TOK_SEMI);
X } else
X skippasttoken(TOK_SEMI);
X }
X }
X}
X
X
X
X
X
X
X
X/* Make a temporary variable that must be freed manually (or at the end of
X the current function by default) */
X
XMeaning *maketempvar(type, name)
XType *type;
Xchar *name;
X{
X struct tempvarlist *tv, **tvp;
X Symbol *sym;
X Meaning *mp;
X char *fullname;
X
X tvp = &tempvars; /* find a freed but allocated temporary */
X while ((tv = *tvp) && (!similartypes(tv->tvar->type, type) ||
X tv->tvar->refcount == 0 ||
X strcmp(tv->tvar->val.s, name)))
X tvp = &(tv->next);
X if (!tv) {
X tvp = &tempvars; /* take over a now-cancelled temporary */
X while ((tv = *tvp) && (tv->tvar->refcount > 0 ||
X strcmp(tv->tvar->val.s, name)))
X tvp = &(tv->next);
X }
X if (tv) {
X tv->tvar->type = type;
X *tvp = tv->next;
X mp = tv->tvar;
X FREE(tv);
X mp->refcount++;
X if (debug>1) { fprintf(outf,"maketempvar revives %s\n", mp->name); }
X } else {
X tempvarcount = 0; /***/ /* experimental... */
X for (;;) {
X if (tempvarcount)
X fullname = format_s(name, format_d("%d", tempvarcount));
X else
X fullname = format_s(name, "");
X ++tempvarcount;
X sym = findsymbol(fullname);
X mp = sym->mbase;
X while (mp && !mp->isactive)
X mp = mp->snext;
X if (!mp)
X break;
X if (debug>1) { fprintf(outf,"maketempvar rejects %s\n", fullname); }
X }
X mp = addmeaning(sym, MK_VAR);
X mp->istemporary = 1;
X mp->type = type;
X mp->refcount = 1;
X mp->val.s = stralloc(name);
X if (debug>1) { fprintf(outf,"maketempvar creates %s\n", mp->name); }
X }
X return mp;
X}
X
X
X
X/* Make a temporary variable that will be freed at the end of this statement
X (rather than at the end of the function) by default */
X
XMeaning *makestmttempvar(type, name)
XType *type;
Xchar *name;
X{
X struct tempvarlist *tv;
X Meaning *tvar;
X
X tvar = maketempvar(type, name);
X tv = ALLOC(1, struct tempvarlist, tempvars);
X tv->tvar = tvar;
X tv->active = 1;
X tv->next = stmttempvars;
X stmttempvars = tv;
X return tvar;
X}
X
X
X
XMeaning *markstmttemps()
X{
X return (stmttempvars) ? stmttempvars->tvar : NULL;
X}
X
X
Xvoid freestmttemps(mark)
XMeaning *mark;
X{
X struct tempvarlist *tv;
X
X while ((tv = stmttempvars) && tv->tvar != mark) {
X if (tv->active)
X freetempvar(tv->tvar);
X stmttempvars = tv->next;
X FREE(tv);
X }
X}
X
X
X
X/* This temporary variable is no longer used */
X
Xvoid freetempvar(tvar)
XMeaning *tvar;
X{
X struct tempvarlist *tv;
X
X if (debug>1) { fprintf(outf,"freetempvar frees %s\n", tvar->name); }
X tv = stmttempvars;
X while (tv && tv->tvar != tvar)
X tv = tv->next;
X if (tv)
X tv->active = 0;
X tv = ALLOC(1, struct tempvarlist, tempvars);
X tv->tvar = tvar;
X tv->next = tempvars;
X tempvars = tv;
X}
X
X
X
X/* The code that used this temporary variable has been deleted */
X
Xvoid canceltempvar(tvar)
XMeaning *tvar;
X{
X if (debug>1) { fprintf(outf,"canceltempvar cancels %s\n", tvar->name); }
X tvar->refcount--;
X freetempvar(tvar);
X}
X
X
X
X
X
X
X
X
X/* End. */
X
X
END_OF_FILE
if test 38042 -ne `wc -c <'src/decl.c.3'`; then
echo shar: \"'src/decl.c.3'\" unpacked with wrong size!
fi
# end of 'src/decl.c.3'
fi
echo shar: End of archive 14 \(of 32\).
cp /dev/null ark14isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 32 archives.
echo "Now see PACKNOTES and the README"
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list