/* "p2c", a Pascal to C translator.
   Copyright (C) 1989 David Gillespie.
   Author's address: daveg@csvax.caltech.edu; 256-80 Caltech/Pasadena CA 91125.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation (any version).

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */

#define PROTO_DECL4_C
#include "trans.h"

#define MAXIMPORTS 100

extern struct ptrdesc {
    struct ptrdesc *next;
    Symbol *sym;
    Type *tp;
} *ptrbase;

extern struct ctxstack {
    struct ctxstack *next;
    Meaning *ctx, *ctxlast;
    struct tempvarlist *tempvars;
    int tempvarcount, importmark;
} *ctxtop;

extern struct tempvarlist {
    struct tempvarlist *next;
    Meaning *tvar;
    int active;
} *tempvars, *stmttempvars;

extern int tempvarcount;

extern int stringtypecachesize;
extern Type **stringtypecache;

extern Meaning *importlist[MAXIMPORTS];
extern int firstimport;

extern Type *tp_special_anyptr;

extern int wasaliased;
extern int deferallptrs;
extern int anydeferredptrs;
extern int silentalreadydef;
extern int nonloclabelcount;

extern Strlist *varstructdecllist;

extern Meaning *enum_tname;

Static Type *p_arraydecl(tname, ispacked, confp)
char *tname;
int ispacked;
Meaning ***confp;
{
    Type *tp, *tp2;
    Meaning *mp;
    long size, smin, smax, bitsize, fullbitsize;
    int issigned, bpower, hasrange;

    tp = maketype(TK_ARRAY);
    if (confp == NULL) {
	tp->indextype = p_type(NULL);
	if (tp->indextype->kind == TK_SUBR) {
	    if (ord_range(tp->indextype, &smin, NULL) &&
		smin > 0 && smin <= skipindices && !ispacked) {
		tp->smin = makeexpr_val(make_ord(tp->indextype->basetype, smin));
		tp->indextype = makesubrangetype(tp->indextype->basetype,
						 makeexpr_val(make_ord(
					             tp->indextype->basetype, 0)),
						 copyexpr(tp->indextype->smax));
	    }
	}
    } else {
	if (modula2) {
	    **confp = mp = addmeaning(findsymbol(format_s(name_ALOW, tname)), MK_PARAM);
	    mp->fakeparam = 1;
	    mp->constqual = 1;
	    mp->xnext = addmeaning(findsymbol(format_s(name_AHIGH, tname)), MK_PARAM);
	    mp->xnext->fakeparam = 1;
	    mp->xnext->constqual = 1;
	    *confp = &mp->xnext->xnext;
	    tp2 = maketype(TK_SUBR);
	    tp2->basetype = tp_integer;
	    mp->type = tp_integer;
	    mp->xnext->type = mp->type;
	    tp2->smin = makeexpr_long(0);
	    tp2->smax = makeexpr_minus(makeexpr_var(mp->xnext),
				       makeexpr_var(mp));
	    tp->indextype = tp2;
	    tp->structdefd = 1;
	} else {
	    wexpecttok(TOK_IDENT);
	    tp2 = maketype(TK_SUBR);
	    if (peeknextchar() != ',' &&
		(!curtokmeaning || curtokmeaning->kind != MK_TYPE)) {
		mp = addmeaning(curtoksym, MK_PARAM);
		gettok();
		wneedtok(TOK_DOTS);
		wexpecttok(TOK_IDENT);
		mp->xnext = addmeaning(curtoksym, MK_PARAM);
		gettok();
		if (wneedtok(TOK_COLON)) {
		    tp2->basetype = p_type(NULL);
		} else {
		    tp2->basetype = tp_integer;
		}
	    } else {
		mp = addmeaning(findsymbol(format_s(name_ALOW, tname)), MK_PARAM);
		mp->xnext = addmeaning(findsymbol(format_s(name_AHIGH, tname)), MK_PARAM);
		tp2->basetype = p_type(NULL);
	    }
	    mp->fakeparam = 1;
	    mp->constqual = 1;
	    mp->xnext->fakeparam = 1;
	    mp->xnext->constqual = 1;
	    **confp = mp;
	    *confp = &mp->xnext->xnext;
	    mp->type = tp2->basetype;
	    mp->xnext->type = tp2->basetype;
	    tp2->smin = makeexpr_var(mp);
	    tp2->smax = makeexpr_var(mp->xnext);
	    tp->indextype = tp2;
	    tp->structdefd = 1;     /* conformant array flag */
	}
    }
    if (curtok == TOK_COMMA || curtok == TOK_SEMI) {
        gettok();
        tp->basetype = p_arraydecl(tname, ispacked, confp);
        return tp;
    } else {
	if (!modula2) {
	    if (!wneedtok(TOK_RBR))
		skiptotoken(TOK_OF);
	}
        if (!wneedtok(TOK_OF))
	    skippasttotoken(TOK_OF, TOK_COMMA);
	checkkeyword(TOK_VARYING);
	if (confp != NULL &&
	    (curtok == TOK_ARRAY || curtok == TOK_PACKED ||
	     curtok == TOK_VARYING)) {
	    tp->basetype = p_conformant_array(tname, confp);
	} else
	    tp->basetype = p_type(NULL);
        if (!ispacked)
            return tp;
        size = 0;
        tp2 = tp->basetype;
        if (!tname)
            tname = "array";
        issigned = packedsize(tname, &tp2, &size, 1);
        if (!size || size > 8 ||
            (issigned && !packsigned) ||
            (size > 4 &&
             (!issigned || (signedchars == 1 || hassignedchar))))
            return tp;
        bpower = 0;
        while ((1<<bpower) < size)
            bpower++;        /* round size up to power of two */
        size = 1<<bpower;    /* size = # bits in an array element */
        tp->escale = bpower;
        tp->issigned = issigned;
        hasrange = ord_range(tp->indextype, &smin, &smax) &&
                   (smax < 100000);    /* don't be confused by giant arrays */
        if (hasrange &&
	    (bitsize = (smax - smin + 1) * size)
	        <= ((sizeof_integer > 0) ? sizeof_integer : 32)) {
            if (bitsize > ((sizeof_short > 0) ? sizeof_short : 16)) {
                tp2 = (issigned) ? tp_integer : tp_unsigned;
                fullbitsize = ((sizeof_integer > 0) ? sizeof_integer : 32);
            } else if (bitsize > ((sizeof_char > 0) ? sizeof_char : 8) ||
                       (issigned && !(signedchars == 1 || hassignedchar))) {
                tp2 = (issigned) ? tp_sshort : tp_ushort;
                fullbitsize = ((sizeof_short > 0) ? sizeof_short : 16);
            } else {
                tp2 = (issigned) ? tp_sbyte : tp_ubyte;
                fullbitsize = ((sizeof_char > 0) ? sizeof_char : 8);
            }
            tp->kind = TK_SMALLARRAY;
            if (ord_range(tp->indextype, &smin, NULL) &&
                smin > 0 && smin <= fullbitsize - bitsize) {
                tp->smin = makeexpr_val(make_ord(tp->indextype->basetype, smin));
                tp->indextype = makesubrangetype(tp->indextype->basetype,
                                                 makeexpr_val(make_ord(
                                                     tp->indextype->basetype, 0)),
                                                 copyexpr(tp->indextype->smax));
            }
        } else {
            if (!issigned)
                tp2 = tp_ubyte;
            else if (signedchars == 1 || hassignedchar)
                tp2 = tp_sbyte;
            else
                tp2 = tp_sshort;
        }
        tp->smax = makeexpr_type(tp->basetype);
        tp->basetype = tp2;
        return tp;
    }
}



Static Type *p_conformant_array(tname, confp)
char *tname;
Meaning ***confp;
{
    int ispacked;
    Meaning *mp;
    Type *tp, *tp2;

    p_attributes();
    ignore_attributes();
    if (curtok == TOK_PACKED) {
	ispacked = 1;
	gettok();
    } else
	ispacked = 0;
    checkkeyword(TOK_VARYING);
    if (curtok == TOK_VARYING) {
	gettok();
	wneedtok(TOK_LBR);
	wexpecttok(TOK_IDENT);
	mp = addmeaning(curtoksym, MK_PARAM);
	mp->fakeparam = 1;
	mp->constqual = 1;
	**confp = mp;
	*confp = &mp->xnext;
	mp->type = tp_integer;
	tp2 = maketype(TK_SUBR);
	tp2->basetype = tp_integer;
	tp2->smin = makeexpr_long(1);
	tp2->smax = makeexpr_var(mp);
	tp = maketype(TK_STRING);
	tp->indextype = tp2;
	tp->basetype = tp_char;
	tp->structdefd = 1;     /* conformant array flag */
	gettok();
	wneedtok(TOK_RBR);
	skippasttoken(TOK_OF);
	tp->basetype = p_type(NULL);
	return tp;
    }
    if (wneedtok(TOK_ARRAY) &&
	(modula2 || wneedtok(TOK_LBR))) {
	return p_arraydecl(tname, ispacked, confp);
    } else {
	return tp_integer;
    }
}




/* VAX Pascal: */
void p_attributes()
{
    Strlist *l1;

    if (modula2)
	return;
    while (curtok == TOK_LBR) {
	implementationmodules = 1;    /* auto-detect VAX Pascal */
	do {
	    gettok();
	    if (!wexpecttok(TOK_IDENT)) {
		skippasttoken(TOK_RBR);
		return;
	    }
	    l1 = strlist_append(&attrlist, strupper(curtokbuf));
	    l1->value = -1;
	    gettok();
	    if (curtok == TOK_LPAR) {
		gettok();
		if (!strcmp(l1->s, "CHECK") ||
		    !strcmp(l1->s, "OPTIMIZE") ||
		    !strcmp(l1->s, "KEY") ||
		    !strcmp(l1->s, "COMMON") ||
		    !strcmp(l1->s, "PSECT") ||
		    !strcmp(l1->s, "EXTERNAL") ||
		    !strcmp(l1->s, "GLOBAL") ||
		    !strcmp(l1->s, "WEAK_EXTERNAL") ||
		    !strcmp(l1->s, "WEAK_GLOBAL")) {
		    l1->value = (long)stralloc(curtokbuf);
		    gettok();
		    while (curtok == TOK_COMMA) {
			gettok();
			gettok();
		    }
		} else if (!strcmp(l1->s, "INHERIT") ||
			   !strcmp(l1->s, "IDENT") ||
			   !strcmp(l1->s, "ENVIRONMENT")) {
		    p_expr(NULL);
		    while (curtok == TOK_COMMA) {
			gettok();
			p_expr(NULL);
		    }
		} else {
		    l1->value = ord_value(p_constant(tp_integer));
		    while (curtok == TOK_COMMA) {
			gettok();
			p_expr(NULL);
		    }
		}
		if (!wneedtok(TOK_RPAR)) {
		    skippasttotoken(TOK_RPAR, TOK_LBR);
		}
	    }
	} while (curtok == TOK_COMMA);
	if (!wneedtok(TOK_RBR)) {
	    skippasttoken(TOK_RBR);
	}
    }
}


void ignore_attributes()
{
    while (attrlist) {
	if (strcmp(attrlist->s, "HIDDEN") &&
	    strcmp(attrlist->s, "INHERIT") &&
	    strcmp(attrlist->s, "ENVIRONMENT"))
	    warning(format_s("Type attribute %s ignored [128]", attrlist->s));
	strlist_eat(&attrlist);
    }
}


int size_attributes()
{
    int size = -1;
    Strlist *l1;

    if ((l1 = strlist_find(attrlist, "BIT")) != NULL)
	size = 1;
    else if ((l1 = strlist_find(attrlist, "BYTE")) != NULL)
	size = 8;
    else if ((l1 = strlist_find(attrlist, "WORD")) != NULL)
	size = 16;
    else if ((l1 = strlist_find(attrlist, "LONG")) != NULL)
	size = 32;
    else if ((l1 = strlist_find(attrlist, "QUAD")) != NULL)
	size = 64;
    else if ((l1 = strlist_find(attrlist, "OCTA")) != NULL)
	size = 128;
    else
	return -1;
    if (l1->value >= 0)
	size *= l1->value;
    strlist_delete(&attrlist, l1);
    return size;
}


void p_mech_spec(doref)
int doref;
{
    if (curtok == TOK_IDENT && doref &&
	!strcicmp(curtokbuf, "%REF")) {
	note("Mechanism specified %REF treated like VAR [107]");
	curtok = TOK_VAR;
	return;
    }
    if (curtok == TOK_IDENT &&
	(!strcicmp(curtokbuf, "%REF") ||
	 !strcicmp(curtokbuf, "%IMMED") ||
	 !strcicmp(curtokbuf, "%DESCR") ||
	 !strcicmp(curtokbuf, "%STDESCR"))) {
	note(format_s("Mechanism specifier %s ignored [108]", curtokbuf));
	gettok();
    }
}


Type *p_modula_subrange(basetype)
Type *basetype;
{
    Type *tp;
    Value val;

    wneedtok(TOK_LBR);
    tp = maketype(TK_SUBR);
    tp->smin = p_ord_expr();
    if (basetype)
	tp->smin = gentle_cast(tp->smin, basetype);
    if (wexpecttok(TOK_DOTS)) {
	gettok();
	tp->smax = p_ord_expr();
	if (tp->smax->val.type->kind == TK_REAL &&
	    tp->smax->kind == EK_CONST &&
	    strlen(tp->smax->val.s) == 12 &&
	    strcmp(tp->smax->val.s, "2147483648.0") >= 0 &&
	    strcmp(tp->smax->val.s, "4294967295.0") <= 0) {
	    tp = tp_unsigned;
	} else if (basetype) {
	    tp->smin = gentle_cast(tp->smin, basetype);
	    tp->basetype = basetype;
	} else {
	    basetype = ord_type(tp->smin->val.type);
	    if (basetype->kind == TK_INTEGER) {
		val = eval_expr(tp->smin);
		if (val.type && val.i >= 0)
		    basetype = tp_unsigned;
		else
		    basetype = tp_integer;
	    }
	    tp->basetype = basetype;
	}
    } else {
	tp = tp_integer;
    }
    if (!wneedtok(TOK_RBR))
	skippasttotoken(TOK_RBR, TOK_SEMI);
    return tp;
}


void makefakestruct(tp, tname)
Type *tp;
Meaning *tname;
{
    Symbol *sym;

    if (!tname)
	return;
    while (tp && (tp->kind == TK_ARRAY || tp->kind == TK_FILE))
	tp = tp->basetype;
    if (tp && tp->kind == TK_RECORD && !tp->meaning) {
	sym = findsymbol(format_s(name_FAKESTRUCT, tname->name));
	silentalreadydef++;
	tp->meaning = addmeaning(sym, MK_TYPE);
	silentalreadydef--;
	tp->meaning->type = tp;
	tp->meaning->refcount++;
	declaretype(tp->meaning);
    }
}


Type *p_type(tname)
Meaning *tname;
{
    Type *tp;
    int ispacked = 0;
    Meaning **flast;
    Meaning *mp;
    Strlist *sl;
    int num, isfunc, saveind, savenotephase, sizespec;
    Expr *ex;
    Value val;
    static int proctypecount = 0;

    p_attributes();
    sizespec = size_attributes();
    ignore_attributes();
    tp = tp_integer;
    if (curtok == TOK_PACKED) {
        ispacked = 1;
        gettok();
    }
    checkkeyword(TOK_VARYING);
    if (modula2)
	checkkeyword(TOK_POINTER);
    switch (curtok) {

        case TOK_RECORD:
            gettok();
	    savenotephase = notephase;
	    notephase = 1;
            tp = maketype(TK_RECORD);
            p_fieldlist(tp, &(tp->fbase), ispacked, tname);
	    notephase = savenotephase;
            if (!wneedtok(TOK_END)) {
		skippasttoken(TOK_END);
	    }
            break;

        case TOK_ARRAY:
            gettok();
	    if (!modula2) {
		if (!wneedtok(TOK_LBR))
		    break;
	    }
	    tp = p_arraydecl(tname ? tname->name : NULL, ispacked, NULL);
	    makefakestruct(tp, tname);
            break;

	case TOK_VARYING:
	    gettok();
	    tp = maketype(TK_STRING);
	    if (wneedtok(TOK_LBR)) {
		ex = p_ord_expr();
		if (!wneedtok(TOK_RBR))
		    skippasttoken(TOK_RBR);
	    } else
		ex = makeexpr_long(stringdefault);
	    if (wneedtok(TOK_OF))
		tp->basetype = p_type(NULL);
	    else
		tp->basetype = tp_char;
	    val = eval_expr(ex);
	    if (val.type) {
		if (val.i > 255 && val.i > stringceiling) {
		    note(format_d("Strings longer than %d may have problems [109]",
				  stringceiling));
		}
		if (stringceiling != 255 &&
		    (val.i >= 255 || val.i > stringceiling)) {
		    freeexpr(ex);
		    ex = makeexpr_long(stringceiling);
		}
	    }
	    tp->indextype = makesubrangetype(tp_integer, makeexpr_long(0), ex);
	    break;

        case TOK_SET:
            gettok();
            if (!wneedtok(TOK_OF))
		break;
	    tp = p_type(NULL);
	    if (tp == tp_integer || tp == tp_unsigned)
		tp = makesubrangetype(tp, makeexpr_long(0),
				      makeexpr_long(defaultsetsize-1));
            tp = makesettype(tp);
            break;

        case TOK_FILE:
            gettok();
	    tp = maketype(TK_FILE);
            if (curtok == TOK_OF) {
                gettok();
                tp->basetype = p_type(NULL);
            } else {
                tp->basetype = tp_abyte;
            }
	    if (tp->basetype->kind == TK_CHAR && charfiletext) {
		tp = tp_text;
	    } else {
		makefakestruct(tp, tname);
		tp = makepointertype(tp);
	    }
            break;

        case TOK_PROCEDURE:
	case TOK_FUNCTION:
	    isfunc = (curtok == TOK_FUNCTION);
            gettok();
	    if (curtok != TOK_LPAR && !isfunc && hasstaticlinks == 1) {
		tp = tp_proc;
		break;
	    }
	    proctypecount++;
	    mp = addmeaning(findsymbol(format_d("__PROCPTR%d",
						proctypecount)),
			    MK_FUNCTION);
	    pushctx(mp);
	    tp = maketype((hasstaticlinks != 0) ? TK_PROCPTR : TK_CPROCPTR);
	    tp->basetype = p_funcdecl(&isfunc, 1);
	    tp->fbase = mp;   /* (saved, but not currently used) */
	    tp->escale = hasstaticlinks;
	    popctx();
            break;

        case TOK_HAT:
	case TOK_ADDR:
	case TOK_POINTER:
	    if (curtok == TOK_POINTER) {
		gettok();
		wneedtok(TOK_TO);
		if (curtok == TOK_IDENT && !strcmp(curtokbuf, "WORD")) {
		    tp = tp_anyptr;
		    gettok();
		    break;
		}
	    } else
		gettok();
	    p_attributes();
	    ignore_attributes();
            tp = maketype(TK_POINTER);
            if (curtok == TOK_IDENT &&
		(!curtokmeaning || curtokmeaning->kind != MK_TYPE ||
		 (deferallptrs && curtokmeaning->ctx != curctx))) {
                struct ptrdesc *pd;
                pd = ALLOC(1, struct ptrdesc, ptrdescs);
                pd->sym = curtoksym;
                pd->tp = tp;
                pd->next = ptrbase;
                ptrbase = pd;
                tp->basetype = tp_abyte;
		anydeferredptrs = 1;
                gettok();
            } else {
                tp->basetype = p_type(NULL);
                if (!tp->basetype->pointertype)
                    tp->basetype->pointertype = tp;
            }
            break;

        case TOK_LPAR:
            if (!useenum)
                outsection(minorspace);
	    enum_tname = tname;
            tp = maketype(TK_ENUM);
            flast = &(tp->fbase);
            num = 0;
            do {
                gettok();
                if (!wexpecttok(TOK_IDENT)) {
		    skiptotoken(TOK_RPAR);
		    break;
		}
                sl = strlist_find(constmacros, curtoksym->name);
                mp = addmeaningas(curtoksym, MK_CONST,
				  (*enumformat) ? MK_VARIANT :
                                  (useenum) ? MK_VAR : MK_CONST);
                mp->val.type = tp;
                mp->val.i = num++;
                mp->type = tp;
                if (sl) {
                    mp->constdefn = (Expr *)sl->value;
                    mp->anyvarflag = 1;    /* Make sure constant is folded */
                    strlist_delete(&constmacros, sl);
                    if (mp->constdefn->kind == EK_NAME)
                        strchange(&mp->name, mp->constdefn->val.s);
                } else {
                    if (!useenum) {
			output(format_s("#define %s", mp->name));
			mp->isreturn = 1;
			out_spaces(constindent, 0, 0, 0);
			saveind = outindent;
			outindent = cur_column();
			output(format_d("%d\n", mp->val.i));
			outindent = saveind;
		    }
		}
                *flast = mp;
                flast = &(mp->xnext);
                gettok();
            } while (curtok == TOK_COMMA);
	    if (!wneedtok(TOK_RPAR))
		skippasttoken(TOK_RPAR);
            tp->smin = makeexpr_long(0);
            tp->smax = makeexpr_long(num-1);
            if (!useenum)
                outsection(minorspace);
            break;

	case TOK_LBR:
	    tp = p_modula_subrange(NULL);
	    break;

        case TOK_IDENT:
            if (!curtokmeaning) {
                undefsym(curtoksym);
                tp = tp_integer;
                mp = addmeaning(curtoksym, MK_TYPE);
                mp->type = tp;
                gettok();
                break;
            } else if (curtokmeaning == mp_string) {
                gettok();
                tp = maketype(TK_STRING);
                tp->basetype = tp_char;
                if (curtok == TOK_LBR) {
                    gettok();
                    ex = p_ord_expr();
                    if (!wneedtok(TOK_RBR))
			skippasttoken(TOK_RBR);
                } else {
		    ex = makeexpr_long(stringdefault);
                }
                val = eval_expr(ex);
                if (val.type && stringceiling != 255 &&
                    (val.i >= 255 || val.i > stringceiling)) {
                    freeexpr(ex);
                    ex = makeexpr_long(stringceiling);
                }
                tp->indextype = makesubrangetype(tp_integer, makeexpr_long(0), ex);
                break;
            } else if (curtokmeaning->kind == MK_TYPE) {
                tp = curtokmeaning->type;
		if (sizespec > 0) {
		    if (ord_type(tp)->kind == TK_INTEGER && sizespec <= 32) {
			if (checkconst(tp->smin, 0)) {
			    if (sizespec == 32)
				tp = tp_unsigned;
			    else
				tp = makesubrangetype(tp_unsigned,
					 makeexpr_long(0),
				         makeexpr_long((1L << sizespec) - 1));
			} else {
			    tp = makesubrangetype(tp_integer,
				     makeexpr_long(- ((1L << (sizespec-1)))),
				     makeexpr_long((1L << (sizespec-1)) - 1));
			}
			sizespec = -1;
		    }
		}
                gettok();
		if (curtok == TOK_LBR) {
		    if (modula2) {
			tp = p_modula_subrange(tp);
		    } else {
			gettok();
			ex = p_expr(tp_integer);
			note("UCSD size spec ignored; using 'long int' [110]");
			if (ord_type(tp)->kind == TK_INTEGER)
			    tp = tp_integer;
			if (!wneedtok(TOK_RBR))
			    skippasttotoken(TOK_RBR, TOK_SEMI);
		    }
		}
                break;
            }

        /* fall through */
        default:
            tp = maketype(TK_SUBR);
            tp->smin = p_ord_expr();
	    if (wexpecttok(TOK_DOTS)) {
		gettok();
		tp->smax = p_ord_expr();
		if (tp->smax->val.type->kind == TK_REAL &&
		    tp->smax->kind == EK_CONST &&
		    strlen(tp->smax->val.s) == 12 &&
		    strcmp(tp->smax->val.s, "2147483648.0") >= 0 &&
		    strcmp(tp->smax->val.s, "4294967295.0") <= 0) {
		    tp = tp_unsigned;
		    break;
		}
		tp->basetype = ord_type(tp->smin->val.type);
	    } else {
		tp = tp_integer;
	    }
            break;
    }
    if (sizespec >= 0)
	note(format_d("Don't know how to interpret size = %d bits [111]", sizespec));
    return tp;
}





Type *p_funcdecl(isfunc, istype)
int *isfunc, istype;
{
    Meaning *retmp = NULL, *mp, *firstmp, *lastmp, **prevm, **oldprevm;
    Type *type, *tp;
    enum meaningkind parkind;
    int anyvarflag, constflag, volatileflag, num = 0;
    Symbol *sym;
    Expr *defval;
    Token savetok;
    Strlist *l1;

    if (*isfunc || modula2) {
        sym = findsymbol(format_s(name_RETV, curctx->name));
        retmp = addmeaning(sym, MK_VAR);
	retmp->isreturn = 1;
    }
    type = maketype(TK_FUNCTION);
    if (curtok == TOK_LPAR) {
        prevm = &type->fbase;
        do {
            gettok();
	    p_mech_spec(1);
	    p_attributes();
	    checkkeyword(TOK_ANYVAR);
            if (curtok == TOK_VAR || curtok == TOK_ANYVAR) {
                parkind = MK_VARPARAM;
                anyvarflag = (curtok == TOK_ANYVAR);
                gettok();
            } else if (curtok == TOK_PROCEDURE || curtok == TOK_FUNCTION) {
		savetok = curtok;
		gettok();
		wexpecttok(TOK_IDENT);
		*prevm = firstmp = addmeaning(curtoksym, MK_PARAM);
		prevm = &firstmp->xnext;
		firstmp->anyvarflag = 0;
		curtok = savetok;   /* rearrange tokens to a proc ptr type! */
		firstmp->type = p_type(firstmp);
		continue;
            } else {
                parkind = MK_PARAM;
                anyvarflag = 0;
            }
	    oldprevm = prevm;
	    if (modula2 && istype) {
		firstmp = addmeaning(findsymbol(format_d("_A%d", ++num)), parkind);
	    } else {
		wexpecttok(TOK_IDENT);
		firstmp = addmeaning(curtoksym, parkind);
		gettok();
	    }
            *prevm = firstmp;
            prevm = &firstmp->xnext;
            firstmp->isactive = 0;   /* nit-picking Turbo compatibility */
	    lastmp = firstmp;
            while (curtok == TOK_COMMA) {
                gettok();
                if (wexpecttok(TOK_IDENT)) {
		    *prevm = lastmp = addmeaning(curtoksym, parkind);
		    prevm = &lastmp->xnext;
		    lastmp->isactive = 0;
		}
                gettok();
            }
	    constflag = volatileflag = 0;
	    defval = NULL;
            if (curtok != TOK_COLON && !modula2) {
		if (parkind != MK_VARPARAM)
		    wexpecttok(TOK_COLON);
		parkind = MK_VARPARAM;
                tp = tp_anyptr;
                anyvarflag = 1;
            } else {
		if (curtok == TOK_COLON)
		    gettok();
		if (curtok == TOK_IDENT && !curtokmeaning &&
		    !strcicmp(curtokbuf, "UNIV")) {
		    if (parkind == MK_PARAM)
			note("UNIV may not work for non-VAR parameters [112]");
		    anyvarflag = 1;
		    gettok();
		}
		p_attributes();
		if ((l1 = strlist_find(attrlist, "READONLY")) != NULL) {
		    constflag = 1;
		    strlist_delete(&attrlist, l1);
		}
		if ((l1 = strlist_find(attrlist, "VOLATILE")) != NULL) {
		    volatileflag = 1;
		    strlist_delete(&attrlist, l1);
		}
		if ((l1 = strlist_find(attrlist, "UNSAFE")) != NULL &&
		    parkind == MK_VARPARAM) {
		    anyvarflag = 1;
		    strlist_delete(&attrlist, l1);
		}
		if ((l1 = strlist_find(attrlist, "REFERENCE")) != NULL) {
		    note("REFERENCE attribute treated like VAR [107]");
		    parkind = MK_VARPARAM;
		    strlist_delete(&attrlist, l1);
		}
		checkkeyword(TOK_VARYING);
                if (curtok == TOK_IDENT && curtokmeaning == mp_string &&
                    !anyvarflag && parkind == MK_VARPARAM) {
                    anyvarflag = (varstrings > 0);
                    tp = tp_str255;
                    gettok();
		    if (curtok == TOK_LBR) {
			wexpecttok(TOK_SEMI);
			skipparens();
		    }
		} else if (curtok == TOK_ARRAY || curtok == TOK_PACKED ||
			   curtok == TOK_VARYING) {
		    prevm = oldprevm;
		    tp = p_conformant_array(firstmp->name, &prevm);
		    *prevm = firstmp;
		    while (*prevm)
			prevm = &(*prevm)->xnext;
                } else {
                    tp = p_type(firstmp);
                }
                if (!varfiles && isfiletype(tp))
                    parkind = MK_PARAM;
                if (parkind == MK_VARPARAM)
                    tp = makepointertype(tp);
            }
	    if (curtok == TOK_ASSIGN) {    /* check for parameter default */
		gettok();
		p_mech_spec(0);
		defval = gentle_cast(p_expr(tp), tp);
		if ((tp->kind == TK_STRING || tp->kind == TK_ARRAY) &&
		    tp->basetype->kind == TK_CHAR &&
		    tp->structdefd &&     /* conformant string */
		    defval->val.type->kind == TK_STRING) {
		    mp = *oldprevm;
		    if (tp->kind == TK_ARRAY) {
			mp->constdefn = makeexpr_long(1);
			mp = mp->xnext;
		    }
		    mp->constdefn = strmax_func(defval);
		}
	    }
            while (firstmp) {
                firstmp->type = tp;
                firstmp->kind = parkind;    /* in case it changed */
                firstmp->isactive = 1;
                firstmp->anyvarflag = anyvarflag;
		firstmp->constqual = constflag;
		firstmp->volatilequal = volatileflag;
		if (defval) {
		    if (firstmp == lastmp)
			firstmp->constdefn = defval;
		    else
			firstmp->constdefn = copyexpr(defval);
		}
                if (parkind == MK_PARAM &&
                    (tp->kind == TK_STRING ||
                     tp->kind == TK_ARRAY ||
                     tp->kind == TK_SET ||
                     ((tp->kind == TK_RECORD || tp->kind == TK_PROCPTR) && copystructs < 2))) {
                    firstmp->othername = stralloc(format_s(name_COPYPAR, firstmp->name));
                    firstmp->rectype = makepointertype(tp);
                }
		if (firstmp == lastmp)
		    break;
                firstmp = firstmp->xnext;
            }
        } while (curtok == TOK_SEMI || curtok == TOK_COMMA);
        if (!wneedtok(TOK_RPAR))
	    skippasttotoken(TOK_RPAR, TOK_SEMI);
    }
    if (modula2) {
	if (curtok == TOK_COLON) {
	    *isfunc = 1;
	} else {
	    unaddmeaning(retmp);
	}
    }
    if (*isfunc) {
        if (wneedtok(TOK_COLON)) {
	    retmp->type = type->basetype = p_type(NULL);
	    switch (retmp->type->kind) {
		
	      case TK_RECORD:
	      case TK_PROCPTR:
                if (copystructs >= 3)
                    break;
		
		/* fall through */
	      case TK_ARRAY:
	      case TK_STRING:
	      case TK_SET:
                type->basetype = retmp->type = makepointertype(retmp->type);
                retmp->kind = MK_VARPARAM;
                retmp->anyvarflag = 0;
                retmp->xnext = type->fbase;
                type->fbase = retmp;
                retmp->refcount++;
                break;

	      default:
		break;
	    }
	} else
	    retmp->type = type->basetype = tp_integer;
    } else
        type->basetype = tp_void;
    return type;
}





Symbol *findlabelsym()
{
    if (curtok == TOK_IDENT && 
        curtokmeaning && curtokmeaning->kind == MK_LABEL) {
#if 0
	if (curtokmeaning->ctx != curctx && curtokmeaning->val.i != 0)
	    curtokmeaning->val.i = --nonloclabelcount;
#endif
    } else if (curtok == TOK_INTLIT) {
        strcpy(curtokcase, curtokbuf);
        curtoksym = findsymbol(curtokbuf);
        curtokmeaning = curtoksym->mbase;
        while (curtokmeaning && !curtokmeaning->isactive)
            curtokmeaning = curtokmeaning->snext;
        if (!curtokmeaning || curtokmeaning->kind != MK_LABEL)
            return NULL;
#if 0
	if (curtokmeaning->ctx != curctx && curtokmeaning->val.i != 0)
	    if (curtokint == 0)
		curtokmeaning->val.i = -1;
	    else
		curtokmeaning->val.i = curtokint;
#endif
    } else
	return NULL;
    return curtoksym;
}