[net.sources] dbx update script

linton@ucbvax.UUCP (06/09/84)

From: linton (Mark Linton)
#! /bin/csh -f
#
# csh file to update dbx source
#
# Assumes it is already in the appropriate dbx source directory.
#
# Changes are since 4.2 release corresponding to the following file versions:
#
#	source file	version	date		size
#
#	asm.c		1.2	12/15/82	1812
#	c.c		1.7	8/16/83		14278
#	cerror.s	1.3	9/2/82		554
#	check.c		1.5	8/10/83		3566
#	commands.y	1.9	8/17/83		10288
#	coredump.c	1.4	1/25/83		3547
#	debug.c		1.3	5/18/83		5534
#	eval.c		1.10	8/17/83		23045
#	events.c	1.3	4/8/83		16139
#	fortran.c	1.4	8/16/83		13174
#	keywords.c	1.3	5/18/83		3569
#	languages.c	1.3	5/18/83		1778
#	library.c	1.4	8/13/83		12800
#	lists.c		1.2	12/15/82	4158
#	machine.c	1.9	8/5/83		18051
#	main.c		1.6	8/16/83		7505
#	makedefs.c	1.2	12/15/82	3379
#	mappings.c	1.4	8/10/83		5604
#	mkdate.c	1.2	7/3/83		518
#	names.c		1.3	2/16/83		3374
#	object.c	1.14	10/22/83	23160
#	operators.c	1.4	5/18/83		6704
#	ops.c		1.3	12/18/82	30971
#	pascal.c	1.2	12/15/82	8208
#	printsym.c	1.12	8/10/83		10518
#	process.c	1.12	8/19/83		21467
#	runtime.c	1.9	8/14/83		12706
#	scanner.c	1.8	8/5/83		10559
#	source.c	1.9	8/5/83		6247
#	symbols.c	1.11	8/16/83		26048
#	tree.c		1.5	8/10/83		11800

chmod 664 Makefile [a-x]*.{c,y} cerror.s defs.h

echo Makefile
ex - Makefile <<'endex'
168c
	tar cfv ${TAPE} \
	    Makefile ${SRC} makedefs.c mkdate.c tests/ pchanges ptests
\.
166a
TAPE = tape

\.
160c
testinstall: ${AOUT} test install

test:
	@chdir tests; make

install: ${AOUT}
\.
157,158c
	rm -f ${HDR} ${OBJ} y.tab.c y.tab.h ${AOUT} \
	    mkdate mkdate.o makedefs makedefs.o date.c core mon.out prof.out
\.
146c
	${CC} -g mkdate.c -o mkdate
\.
143c
	${CC} -g makedefs.c library.o cerror.o -o makedefs
\.
139a
	@echo "expect 2 shift/reduce conflicts"
\.
102a
    modula-2.c \
\.
79a
    source.h \
    stabstring.h \
\.
78d
70a
    modula-2.h \
\.
52a
    stabstring.o \
\.
43a
    modula-2.o \
\.
23c
CFLAGS	= -g
\.
17,18c
DEST	= /usr/local/bin/dbx
\.
7,11d
1d
wq
'endex'

echo asm.c
ex - asm.c <<'endex'
98a
}

public boolean asm_hasmodules ()
{
    return false;
}

public boolean asm_passaddr (param, exprtype)
Symbol param, exprtype;
{
    return false;
\.
36a
    language_setop(lang, L_HASMODULES, asm_hasmodules);
    language_setop(lang, L_PASSADDR, asm_passaddr);
\.
4a
static char rcsid[] = "$Header: asm.c,v 1.3 84/03/27 10:19:36 linton Exp $";

\.
wq
'endex'

echo c.c
ex - c.c <<'endex'
748a
}

/*
 * Initialize typetable information.
 */

public c_modinit (typetable)
Symbol typetable[];
{
    /* nothing right now */
}

public boolean c_hasmodules ()
{
    return false;
}

public boolean c_passaddr (param, exprtype)
Symbol param, exprtype;
{
    boolean b;
    Symbol t;

    t = rtype(exprtype);
    b = (boolean) (t->class == ARRAY);
    return b;
\.
557c
	n = (off + len + BITSPERBYTE - 1) div BITSPERBYTE;
\.
534c
	    printf("[%s]", c_classname(s));
\.
475c
	    if ((t->class == RANGE and istypename(t->type, "char")) or
		t == t_char->type
	    ) {
\.
461c
		i &= ((1 << s->symvalue.field.length) - 1);
\.
452,459c
		i = 0;
		popn(size(s), &i);
\.
438c
    integer i, len;
\.
354c
		printname(stdout, t);
\.
347a
	case FFUNC:
\.
155c
		if (s->level == 1 and s->block != program) {
\.
84a
	    ) or (
		t1->class == PTR and c_typematch(t1->type, t_char) and
		t2->class == ARRAY and c_typematch(t2->type, t_char) and
		t2->language == primlang
\.
78c
		t1->class == RANGE and isdouble(t1) and t2 == t_real->type
\.
76c
		(t2 == t_char->type or t2 == t_int->type)
\.
73c
		(t2 == t_int->type or t2 == t_char->type)
\.
65c
	if (t1 == t_char->type or t1 == t_int->type or t1 == t_real->type) {
\.
38,45c
    langC = language_define("c", ".c");
    language_setop(langC, L_PRINTDECL, c_printdecl);
    language_setop(langC, L_PRINTVAL, c_printval);
    language_setop(langC, L_TYPEMATCH, c_typematch);
    language_setop(langC, L_BUILDAREF, c_buildaref);
    language_setop(langC, L_EVALAREF, c_evalaref);
    language_setop(langC, L_MODINIT, c_modinit);
    language_setop(langC, L_HASMODULES, c_hasmodules);
    language_setop(langC, L_PASSADDR, c_passaddr);
\.
31a
private Language langC;

\.
4a
static char rcsid[] = "$Header: c.c,v 1.3 84/03/27 10:19:40 linton Exp $";

\.
3c
static char sccsid[] = "@(#)c.c 1.6 8/5/83";
\.
wq
'endex'

echo check.c
ex - check.c <<'endex'
148c
	} else if (ismodule(b->value.sym)) {
	    outer = b->value.sym;
	    while (outer != nil) {
		find(p, outer->name) where p->block == outer endfind(p);
		if (p == nil) {
		    outer = nil;
		    error("\"%s\" is not a subprogram", symname(b->value.sym));
		} else if (ismodule(p)) {
		    outer = p;
		} else {
		    outer = nil;
		    b->value.sym = p;
		}
	    }
	} else if (not isblock(b->value.sym)) {
\.
141a
    Symbol p, outer;

\.
129c
	    if (p->op == O_STOP) {
		chkline(place);
	    } else {
		chkaddr(place);
	    }
\.
123,127c
    } else if (place != nil) {
	if (place->op == O_SYM) {
	    chkblock(place);
\.
60a
	case O_CALL:
	    if (not isroutine(p->value.arg[0]->nodetype)) {
		beginerrmsg();
		fprintf(stderr, "\"");
		prtree(stderr, p->value.arg[0]);
		fprintf(stderr, "\" not call-able");
		enderrmsg();
	    }
	    break;

\.
4a
static char rcsid[] = "$Header: check.c,v 1.3 84/03/27 10:19:54 linton Exp $";

\.
wq
'endex'

echo coredump.c
ex - coredump.c <<'endex'
141c
	if (hdr.a_magic == OMAGIC) {
	    error("data address 0x%x too low (lb = 0x%x)", addr, datamap.begin);
	} else {
	    coredump_readtext(buff, addr, nbytes);
	}
\.
7,8d
4a
static char rcsid[] = "$Header: coredump.c,v 1.3 84/03/27 10:20:10 linton Exp $";

\.
wq
'endex'

echo debug.c
ex - debug.c <<'endex'
5a
static char rcsid[] = "$Header: debug.c,v 1.3 84/03/27 10:20:14 linton Exp $";

\.
wq
'endex'

echo eval.c
ex - eval.c <<'endex'
1124d
1119,1121c
    puts("call <proc>            - call a procedure in program");
\.
1115,1116d
1107a
    puts("print <exp>            - print the value of the expression");
    puts("where                  - print currently active procedures");
    puts("stop at <line>         - suspend execution at the line");
    puts("stop in <proc>         - suspend execution when <proc> is called");
\.
1090c
    sprintf(subject, "dbx (version %d) gripe", versionNumber);
    pid = back("Mail", stdin, stdout, "-s", subject, maintainer, nil);
\.
1083c
    extern int versionNumber;
    char subject[100];
\.
1068,1070d
1065,1066c
		default:
		    panic("bad size %d", varsize);
	    }
	} else {
	    if (expsize <= varsize) {
		sp -= expsize;
		dwrite(sp, addr, expsize);
	    } else {
		sp -= expsize;
		dwrite(sp, addr, varsize);
	    }
\.
1060,1063c
		case sizeof(short):
		    svalue = lvalue;
		    dwrite(&svalue, addr, sizeof(svalue));
		    break;
\.
1052,1058c
    expsize = size(exp->nodetype);
    eval(exp);
    if (varsize == sizeof(float) and expsize == sizeof(double)) {
	fvalue = (float) pop(double);
	dwrite(&fvalue, addr, sizeof(fvalue));
    } else {
	if (varsize < sizeof(long)) {
	    lvalue = 0;
	    popn(expsize, &lvalue);
	    switch (varsize) {
		case sizeof(char):
		    cvalue = lvalue;
		    dwrite(&cvalue, addr, sizeof(cvalue));
		    break;
\.
1050d
1044a
    float fvalue;
\.
1041c
    integer varsize, expsize;
\.
953,954c
	if (place == nil or place->op == O_SYM) {
	    if (place == nil) {
		s = program;
	    } else {
		s = place->value.sym;
	    }
\.
513c
	    n1 = p->value.arg[0];
	    while (n1->op == O_COMMA) {
		n2 = n1->value.arg[0];
		assert(n2->op == O_LCON);
		if (not delevent((unsigned int) n2->value.lcon)) {
		    error("unknown event %ld", n2->value.lcon);
		}
		n1 = n1->value.arg[1];
	    }
	    assert(n1->op == O_LCON);
	    if (not delevent((unsigned int) n1->value.lcon)) {
		error("unknown event %ld", n1->value.lcon);
	    }
\.
507a
	case O_UP:
	    checkref(p->value.arg[0]);
	    assert(p->value.arg[0]->op == O_LCON);
	    up(p->value.arg[0]->value.lcon);
	    break;

\.
485a
	case O_RETURN:
	    if (p->value.arg[0] == nil) {
		rtnfunc(nil);
	    } else {
		assert(p->value.arg[0]->op == O_SYM);
		rtnfunc(p->value.arg[0]->value.sym);
	    }
	    break;

\.
469a
	case O_DOWN:
	    checkref(p->value.arg[0]);
	    assert(p->value.arg[0]->op == O_LCON);
	    down(p->value.arg[0]->value.lcon);
	    break;

\.
344d
338,342c
		if (isroutine(s)) {
		    setcurfunc(s);
		} else {
		    find(f, s->name) where isroutine(f) endfind(f);
		    if (f == nil) {
			error("%s is not a procedure or function", symname(s));
		    }
		    setcurfunc(f);
\.
165,166d
59c
	if (size(p->value.arg[n]->nodetype) == sizeof(float)) { \
	    fr = pop(float); \
	} else { \
	    fr = pop(double); \
	} \
\.
38a
#define popn(n, dest) { \
    sp -= n; \
    bcopy(sp, dest, n); \
}

\.
19a
#include "runtime.h"
\.
4a
static char rcsid[] = "$Header: eval.c,v 1.3 84/03/27 10:20:23 linton Exp $";

\.
wq
'endex'

echo events.c
ex - events.c <<'endex'
791c
	    if (not delevent(e->id)) {
		printf("!! dbx.fixbps: can't find event %d\n", e->id);
	    }
\.
753a
	mov(buff, sp, n);
	sp += n;
	printf("after line %d:\t", prevline);
	prtree(stdout, p);
	printf(" = ");
	printval(p->nodetype);
	putchar('\n');
\.
617c
    setcurfunc(whatblock(pc));
\.
514c
	bp = bp_alloc(event, (Address) ret, 0, actions);
\.
512d
494d
471a
	if (found) {
	    printeventid(eventId);
	}
\.
468a
	    if (isstopped) {
		eventId = p->event->id;
	    }
\.
466c
		if (not delevent(p->event->id)) {
		    printf("!! dbx.bpact: can't find event %d\n",
			p->event->id);
		}
\.
462c
		printf("breakpoint for event %d found at location 0x%x\n",
		    p->event->id, pc);
\.
456a
    integer eventId;
\.
443c
	if (not delevent(e->id)) {
	    printf("!! dbx.bpfree: can't delete event %d\n", e->id);
	}
\.
426c
	if (e == nil) {
	    printf("new bp at 0x%x for event ??\n", addr, e->id);
	} else {
	    printf("new bp at 0x%x for event %d\n", addr, e->id);
	}
\.
373a
private printeventid (id)
integer id;
{
    printf("[%d] ", id);
}

\.
350c
	printeventid(e->id);
\.
205c
			if (not delevent(e->id)) {
			    printf("!! dbx.translate: can't undo event %d?\n",
				e->id);
			}
\.
197,198c
			addr = objaddr(line, place->value.arg[0]->value.scon);
\.
171a
    return found;
\.
161a
	    found = true;
\.
155a
	    found = true;
\.
150a
	    list_delete(list_curitem(eventlist), eventlist);
\.
147a
		    if (tracebpts) {
			printf("deleting breakpoint at 0x%x\n", bp->bpaddr);
			fflush(stdout);
		    }
\.
145c
	    found = true;
\.
142a
    found = false;
\.
141a
    boolean found;
\.
136c
public boolean delevent (id)
\.
133a
 * Returns whether it's successful or not.
\.
16a
#include "runtime.h"
\.
4a
static char rcsid[] = "$Header: events.c,v 1.3 84/03/27 10:20:41 linton Exp $";

\.
wq
'endex'

echo fortran.c
ex - fortran.c <<'endex'
586a
}

/*
 * Initialize typetable at beginning of a module.
 */

public fortran_modinit (typetable)
Symbol typetable[];
{
    /* nothing for now */
}

public boolean fortran_hasmodules ()
{
    return false;
}

public boolean fortran_passaddr (param, exprtype)
Symbol param, exprtype;
{
    return false;
\.
203c
	    printf("source file \"%s.c\"", symname(s));
\.
197a
	    else printf(" subroutine");
\.
195,196d
186c
		printf(" %s %s[%s] ",typename(s), symname(s), bounds);
\.
183c
                mksubs(p,s->type);
\.
180a
	case VAR:
	    if (s->type->class == ARRAY &&
		 (not istypename(s->type->type,"char")) ) {
                char bounds[130], *p1, **p;
\.
174,179d
167a
	    
\.
166a

\.
35,42c
    fort = language_define("fortran", ".f");
    language_setop(fort, L_PRINTDECL, fortran_printdecl);
    language_setop(fort, L_PRINTVAL, fortran_printval);
    language_setop(fort, L_TYPEMATCH, fortran_typematch);
    language_setop(fort, L_BUILDAREF, fortran_buildaref);
    language_setop(fort, L_EVALAREF, fortran_evalaref);
    language_setop(fort, L_MODINIT, fortran_modinit);
    language_setop(fort, L_HASMODULES, fortran_hasmodules);
    language_setop(fort, L_PASSADDR, fortran_passaddr);
\.
28a

private Language fort;

\.
4a
static char rcsid[] = "$Header: fortran.c,v 1.3 84/03/27 10:20:53 linton Exp $";

\.
3c
static char sccsid[] = "@(#)fortran.c	1.3	5/20/83";
\.
wq
'endex'

echo keywords.c
ex - keywords.c <<'endex'
161c
	k = kwlookup(newcmd);
	if (k == nil) {
	    keyword(ident(newcmd), t, true);
	} else {
	    k->toknum = t;
	}
\.
155a
    Keyword k;
\.
138a
    return k;
}

/*
 * Return the token associated with a given keyword string.
 * We assume that tokens cannot legitimately be nil (0).
 */

public Token findkeyword(n)
Name n;
{
    Keyword k;
    Token t;

    k = kwlookup(n);
\.
132d
130c
    Hashvalue h;
\.
127c
private Keyword kwlookup (n)
\.
123,124c
 * Find the keyword associated with the given string.
\.
65a
    keyword("c", CONT, true);
    keyword("d", DELETE, true);
    keyword("h", HELP, true);
    keyword("e", EDIT, true);
    keyword("l", LIST, true);
    keyword("n", NEXT, true);
    keyword("p", PRINT, true);
    keyword("q", QUIT, true);
    keyword("r", RUN, true);
    keyword("s", STEP, true);
    keyword("st", STOP, true);
    keyword("j", STATUS, true);
    keyword("t", WHERE, true);
\.
28c
    "stop", "stopi", "trace", "tracei", "up",
\.
26c
    "print", "psym", "quit", "rerun", "return", "run",
\.
23c
    "debug", "delete", "div", "down", "dump", "edit", "file", "func",
\.
4a
static char rcsid[] = "$Header: keywords.c,v 1.3 84/03/27 10:21:05 linton Exp $";

\.
wq
'endex'

echo languages.c
ex - languages.c <<'endex'
92c
    assert(ord(op) < ord(L_ENDOP));
\.
45a
    modula2_init();
\.
42a
    primlang = language_define("$builtin symbols", ".?");
\.
28c
    LanguageOperation *op[20];
\.
22a

Language primlang;

\.
19c
    L_PRINTDECL, L_PRINTVAL, L_TYPEMATCH, L_BUILDAREF, L_EVALAREF,
    L_MODINIT, L_HASMODULES, L_PASSADDR,
    L_ENDOP
\.
15a

\.
12a
#include "modula-2.h"
\.
4a
static char rcsid[] = "$Header: languages.c,v 1.3 84/03/27 10:21:09 linton Exp $";

\.
wq
'endex'

echo library.c
ex - library.c <<'endex'
502c
boolean shouldquit;
\.
484c
    write(2, msg, strlen(msg));
\.
479,481c
    len = strlen(s);
    if (len > 0) {
	write(2, s, len);
\.
475,477c
    if (n >= 0 and n < sys_nsig) {
	msg = sys_siglist[n];
    } else {
	msg = "Unknown signal";
\.
472,473c
    String msg;
    integer len;
\.
470a
integer n;
\.
469c
public psignal(s, n)
\.
429a
    if (errinfo == nil(ERRINFO *)) {
	initErrInfo();
    }
\.
419a
    initErrInfo();
\.
413,414c
 * Catcherrs' purpose is to initialize the errinfo table, get this module
 * loaded, and make sure my cerror is loaded (only applicable when this is
 * in a library).
\.
407,408d
404,405c
	} else if (e->func != ERR_IGNORE) {
	    (*e->func)();
\.
400,402c
    if (errno < 0 or errno > sys_nerr) {
	fatal("errno %d", errno);
    } else {
	if (errinfo == nil(ERRINFO *)) {
	    initErrInfo();
	}
	e = &(errinfo[errno]);
	if (e->func == ERR_CATCH) {
\.
395a
private initErrInfo ()
{
    integer i;

    errinfo = alloc(sys_nerr, ERRINFO);
    for (i = 0; i < sys_nerr; i++) {
	errinfo[i].func = ERR_CATCH;
    }
    errinfo[0].func = ERR_IGNORE;
    errinfo[EPERM].func = ERR_IGNORE;
    errinfo[ENOENT].func = ERR_IGNORE;
    errinfo[ESRCH].func = ERR_IGNORE;
    errinfo[EBADF].func = ERR_IGNORE;
    errinfo[ENOTTY].func = ERR_IGNORE;
    errinfo[EOPNOTSUPP].func = ERR_IGNORE;
}

\.
357,394c
private ERRINFO *errinfo;
\.
354c
 * Initialize error information, setting defaults for handling errors.
\.
266c
    return (boolean) (p != nil(Pidlist *));
\.
257c
private boolean isptraced(pid)
\.
90c
#define MAXNARGS 1000    /* unchecked upper limit on max num of arguments */
\.
30,38d
23c
typedef int integer;
typedef enum { FALSE, TRUE } boolean;
\.
6a
static char sccsid[] = "@(#)library.c 1.3 8/7/83";

static char rcsid[] = "$Header: library.c,v 1.3 84/03/27 10:21:12 linton Exp $";

\.
1,4d
wq
'endex'

echo lists.c
ex - lists.c <<'endex'
4a
static char rcsid[] = "$Header: lists.c,v 1.3 84/03/27 10:21:21 linton Exp $";

\.
wq
'endex'

echo machine.c
ex - machine.c <<'endex'
914c
    pstep(process, DEFSIG);
\.
646c
	    pstep(process, DEFSIG);
\.
633a
	case O_JMP: /* because it may be jmp (r1) */
\.
630c
	    if (addr == pc) {	/* recursive ret to self */
		pstep(process, DEFSIG);
	    } else {
		stepto(addr);
	    }
\.
607c
		setcurfunc(whatblock(pc));
\.
604c
		pstep(process, DEFSIG);
\.
590d
571a
boolean isnext;
{
    Address addr;

    addr = usignal(process);
    if (addr == 0 or addr == 1) {
	addr = findnextaddr(startaddr, isnext);
    }
    return addr;
}

private Address findnextaddr(startaddr, isnext)
Address startaddr;
\.
569a
private Address findnextaddr();

\.
552a
    if (addr == startaddr) {
	stepto(prevaddr);
    }
\.
545a
	    prevaddr = addr;
\.
541a
    startaddr = pc;
    prevaddr = startaddr;
\.
540a
    Address startaddr, prevaddr;
\.
11a
#include "runtime.h"
\.
4a
static char rcsid[] = "$Header: machine.c,v 1.3 84/03/27 10:21:26 linton Exp $";

\.
wq
'endex'

echo main.c
ex - main.c <<'endex'
372a
    pterm(process);
\.
334a
	case 'n':
	    traceblocks = true;
	    break;

\.
251c
    while (i < argc and (not foundfile or corefile == nil)) {
\.
244a
    traceblocks = false;
\.
122c
	setcurfunc(program);
\.
120c
	setcurfunc(whatblock(pc));
\.
88,89c
    if (setjmp(env) != FIRST_TIME) {
	restoretty(stdout, &ttyinfo);
    }
\.
72d
68c
    printf("dbx version %d of %s.\nType 'help' for help.\n",
	versionNumber, date);
\.
62a
    extern integer versionNumber;
\.
61c
    register integer i;
\.
37a
public Boolean traceblocks;		/* trace blocks while reading symbols */
\.
16a
#include "runtime.h"
\.
4a
static char rcsid[] = "$Header: main.c,v 1.3 84/03/27 10:21:40 linton Exp $";

\.
3c
static char sccsid[] = "@(#)main.c 1.5 5/17/83";
\.
wq
'endex'

echo makedefs.c
ex - makedefs.c <<'endex'
4a
static char rcsid[] = "$Header: makedefs.c,v 1.3 84/03/27 10:21:50 linton Exp $";

\.
wq
'endex'

echo mappings.c
ex - mappings.c <<'endex'
4a
static char rcsid[] = "$Header: mappings.c,v 1.3 84/03/27 10:21:54 linton Exp $";

\.
wq
'endex'

echo mkdate.c
ex - mkdate.c <<'endex'
22a
    DoVersionNumber();
}

DoVersionNumber()
{
    FILE *f;
    int n;

    f = fopen("version", "r");
    if (f == NULL) {
	n = 1;
    } else {
	fscanf(f, "%d", &n);
	n = n + 1;
	fclose(f);
    }
    f = fopen("version", "w");
    if (f != NULL) {
	fprintf(f, "%d\n", n);
	fclose(f);
    }
    printf("int versionNumber = %d;\n", n);
\.
3c
static char rcsid[] = "$Header: mkdate.c,v 1.3 84/03/27 10:21:59 linton Exp $";
\.
wq
'endex'

echo modula-2.c
ex - modula-2.c <<'endex'
0a
/*
 * Modula-2 specific symbol routines.
 */

static char rcsid[] = "$Header: modula-2.c,v 1.4 84/03/27 10:22:04 linton Exp $";

#include "defs.h"
#include "symbols.h"
#include "modula-2.h"
#include "languages.h"
#include "tree.h"
#include "eval.h"
#include "mappings.h"
#include "process.h"
#include "runtime.h"
#include "machine.h"

#ifndef public
#endif

private Language mod2;
private boolean initialized;

/*
 * Initialize Modula-2 information.
 */

public modula2_init ()
{
    mod2 = language_define("modula-2", ".mod");
    language_setop(mod2, L_PRINTDECL, modula2_printdecl);
    language_setop(mod2, L_PRINTVAL, modula2_printval);
    language_setop(mod2, L_TYPEMATCH, modula2_typematch);
    language_setop(mod2, L_BUILDAREF, modula2_buildaref);
    language_setop(mod2, L_EVALAREF, modula2_evalaref);
    language_setop(mod2, L_MODINIT, modula2_modinit);
    language_setop(mod2, L_HASMODULES, modula2_hasmodules);
    language_setop(mod2, L_PASSADDR, modula2_passaddr);
    initialized = false;
}

/*
 * Typematch tests if two types are compatible.  The issue
 * is a bit complicated, so several subfunctions are used for
 * various kinds of compatibility.
 */

private boolean nilMatch (t1, t2)
register Symbol t1, t2;
{
    boolean b;

    b = (boolean) (
	(t1 == t_nil and t2->class == PTR) or
	(t1->class == PTR and t2 == t_nil)
    );
    return b;
}

private boolean enumMatch (t1, t2)
register Symbol t1, t2;
{
    boolean b;

    b = (boolean) (
	t1->type == t2->type and (
	    (t1->class == t2->class) or
	    (t1->class == SCAL and t2->class == CONST) or
	    (t1->class == CONST and t2->class == SCAL)
	)
    );
    return b;
}

private boolean openArrayMatch (t1, t2)
register Symbol t1, t2;
{
    boolean b;

    b = (boolean) (
	(
	    t1->class == ARRAY and t1->chain == t_open and
	    t2->class == ARRAY and
	    compatible(rtype(t2->chain)->type, t_int) and
	    compatible(t1->type, t2->type)
	) or (
	    t2->class == ARRAY and t2->chain == t_open and
	    t1->class == ARRAY and
	    compatible(rtype(t1->chain)->type, t_int) and
	    compatible(t1->type, t2->type)
	)
    );
    return b;
}

private boolean isConstString (t)
register Symbol t;
{
    boolean b;

    b = (boolean) (
	t->language == primlang and t->class == ARRAY and t->type == t_char
    );
    return b;
}

private boolean stringArrayMatch (t1, t2)
register Symbol t1, t2;
{
    boolean b;

    b = (boolean) (
	(
	    isConstString(t1) and
	    t2->class == ARRAY and compatible(t2->type, t_char->type)
	) or (
	    isConstString(t2) and
	    t1->class == ARRAY and compatible(t1->type, t_char->type)
	)
    );
    return b;
}

public boolean modula2_typematch (type1, type2)
Symbol type1, type2;
{
    Boolean b;
    Symbol t1, t2, tmp;

    t1 = rtype(type1);
    t2 = rtype(type2);
    if (t1 == t2) {
	b = true;
    } else {
	if (t1 == t_char->type or t1 == t_int->type or t1 == t_real->type) {
	    tmp = t1;
	    t1 = t2;
	    t2 = tmp;
	}
	b = (Boolean) (
	    (
		t2 == t_int->type and
		t1->class == RANGE and (
		    istypename(t1->type, "integer") or
		    istypename(t1->type, "cardinal")
		)
	    ) or (
		t2 == t_char->type and
		t1->class == RANGE and istypename(t1->type, "char")
	    ) or (
		t2 == t_real->type and
		t1->class == RANGE and (
		    istypename(t1->type, "real") or
		    istypename(t1->type, "longreal")
		)
	    ) or (
		nilMatch(t1, t2)
	    ) or (
		enumMatch(t1, t2)
	    ) or (
		openArrayMatch(t1, t2)
	    ) or (
		stringArrayMatch(t1, t2)
	    )
	);
    }
    return b;
}

/*
 * Indent n spaces.
 */

private indent (n)
int n;
{
    if (n > 0) {
	printf("%*c", n, ' ');
    }
}

public modula2_printdecl (s)
Symbol s;
{
    register Symbol t;
    Boolean semicolon;

    semicolon = true;
    if (s->class == TYPEREF) {
	resolveRef(t);
    }
    switch (s->class) {
	case CONST:
	    if (s->type->class == SCAL) {
		printf("(enumeration constant, ord %ld)",
		    s->symvalue.iconval);
	    } else {
		printf("const %s = ", symname(s));
		modula2_printval(s);
	    }
	    break;

	case TYPE:
	    printf("type %s = ", symname(s));
	    printtype(s, s->type, 0);
	    break;

	case TYPEREF:
	    printf("type %s", symname(s));
	    break;

	case VAR:
	    if (isparam(s)) {
		printf("(parameter) %s : ", symname(s));
	    } else {
		printf("var %s : ", symname(s));
	    }
	    printtype(s, s->type, 0);
	    break;

	case REF:
	    printf("(var parameter) %s : ", symname(s));
	    printtype(s, s->type, 0);
	    break;

	case RANGE:
	case ARRAY:
	case RECORD:
	case VARNT:
	case PTR:
	    printtype(s, s, 0);
	    semicolon = false;
	    break;

	case FVAR:
	    printf("(function variable) %s : ", symname(s));
	    printtype(s, s->type, 0);
	    break;

	case FIELD:
	    printf("(field) %s : ", symname(s));
	    printtype(s, s->type, 0);
	    break;

	case PROC:
	    printf("procedure %s", symname(s));
	    listparams(s);
	    break;

	case PROG:
	    printf("program %s", symname(s));
	    listparams(s);
	    break;

	case FUNC:
	    printf("function %s", symname(s));
	    listparams(s);
	    printf(" : ");
	    printtype(s, s->type, 0);
	    break;

	case MODULE:
	    printf("module %s", symname(s));
	    break;

	default:
	    printf("%s : (class %s)", symname(s), classname(s));
	    break;
    }
    if (semicolon) {
	putchar(';');
    }
    putchar('\n');
}

/*
 * Recursive whiz-bang procedure to print the type portion
 * of a declaration.
 *
 * The symbol associated with the type is passed to allow
 * searching for type names without getting "type blah = blah".
 */

private printtype (s, t, n)
Symbol s;
Symbol t;
int n;
{
    register Symbol tmp;

    if (t->class == TYPEREF) {
	resolveRef(t);
    }
    switch (t->class) {
	case VAR:
	case CONST:
	case FUNC:
	case PROC:
	    panic("printtype: class %s", classname(t));
	    break;

	case ARRAY:
	    printf("array[");
	    tmp = t->chain;
	    if (tmp != nil) {
		for (;;) {
		    printtype(tmp, tmp, n);
		    tmp = tmp->chain;
		    if (tmp == nil) {
			break;
		    }
		    printf(", ");
		}
	    }
	    printf("] of ");
	    printtype(t, t->type, n);
	    break;

	case RECORD:
	    printRecordDecl(t, n);
	    break;

	case FIELD:
	    if (t->chain != nil) {
		printtype(t->chain, t->chain, n);
	    }
	    printf("\t%s : ", symname(t));
	    printtype(t, t->type, n);
	    printf(";\n");
	    break;

	case RANGE:
	    printRangeDecl(t);
	    break;

	case PTR:
	    printf("pointer to ");
	    printtype(t, t->type, n);
	    break;

	case TYPE:
	    if (t->name != nil and ident(t->name)[0] != '\0') {
		printname(stdout, t);
	    } else {
		printtype(t, t->type, n);
	    }
	    break;

	case SCAL:
	    printEnumDecl(t, n);
	    break;

	case SET:
	    printf("set of ");
	    printtype(t, t->type, n);
	    break;

	case TYPEREF:
	    break;

	default:
	    printf("(class %d)", t->class);
	    break;
    }
}

/*
 * Print out a record declaration.
 */

private printRecordDecl (t, n)
Symbol t;
int n;
{
    register Symbol f;

    if (t->chain == nil) {
	printf("record end");
    } else {
	printf("record\n");
	for (f = t->chain; f != nil; f = f->chain) {
	    indent(n+4);
	    printf("%s : ", symname(f));
	    printtype(f->type, f->type, n+4);
	    printf(";\n");
	}
	indent(n);
	printf("end");
    }
}

/*
 * Print out the declaration of a range type.
 */

private printRangeDecl (t)
Symbol t;
{
    long r0, r1;

    r0 = t->symvalue.rangev.lower;
    r1 = t->symvalue.rangev.upper;
    if (t == t_char or istypename(t, "char")) {
	if (r0 < 0x20 or r0 > 0x7e) {
	    printf("%ld..", r0);
	} else {
	    printf("'%c'..", (char) r0);
	}
	if (r1 < 0x20 or r1 > 0x7e) {
	    printf("\\%lo", r1);
	} else {
	    printf("'%c'", (char) r1);
	}
    } else if (r0 > 0 and r1 == 0) {
	printf("%ld byte real", r0);
    } else if (r0 >= 0) {
	printf("%lu..%lu", r0, r1);
    } else {
	printf("%ld..%ld", r0, r1);
    }
}

/*
 * Print out an enumeration declaration.
 */

private printEnumDecl (e, n)
Symbol e;
int n;
{
    Symbol t;

    printf("(");
    t = e->chain;
    if (t != nil) {
	printf("%s", symname(t));
	t = t->chain;
	while (t != nil) {
	    printf(", %s", symname(t));
	    t = t->chain;
	}
    }
    printf(")");
}

/*
 * List the parameters of a procedure or function.
 * No attempt is made to combine like types.
 */

private listparams (s)
Symbol s;
{
    Symbol t;

    if (s->chain != nil) {
	putchar('(');
	for (t = s->chain; t != nil; t = t->chain) {
	    switch (t->class) {
		case REF:
		    printf("var ");
		    break;

		case FPROC:
		case FFUNC:
		    printf("procedure ");
		    break;

		case VAR:
		    break;

		default:
		    panic("unexpected class %d for parameter", t->class);
	    }
	    printf("%s", symname(t));
	    if (s->class == PROG) {
		printf(", ");
	    } else {
		printf(" : ");
		printtype(t, t->type, 0);
		if (t->chain != nil) {
		    printf("; ");
		}
	    }
	}
	putchar(')');
    }
}

/*
 * Modula 2 interface to printval.
 */

public modula2_printval (s)
Symbol s;
{
    prval(s, size(s));
}

/*
 * Print out the value on the top of the expression stack
 * in the format for the type of the given symbol, assuming
 * the size of the object is n bytes.
 */

private prval (s, n)
Symbol s;
integer n;
{
    Symbol t;
    Address a;
    integer len;
    double r;
    integer scalar;
    boolean found;

    if (s->class == TYPEREF) {
	resolveRef(s);
    }
    switch (s->class) {
	case CONST:
	case TYPE:
	case VAR:
	case REF:
	case FVAR:
	case TAG:
	case FIELD:
	    prval(s->type, n);
	    break;

	case ARRAY:
	    t = rtype(s->type);
	    if (t->class == RANGE and istypename(t->type, "char")) {
		len = size(s);
		sp -= len;
		printf("'%.*s'", len, sp);
		break;
	    } else {
		printarray(s);
	    }
	    break;

	case RECORD:
	    printrecord(s);
	    break;

	case VARNT:
	    printf("can't print out variant records");
	    break;

	case RANGE:
	    printrange(s, n);
	    break;

	case FILET:
	case PTR:
	    a = pop(Address);
	    if (a == 0) {
		printf("nil");
	    } else {
		printf("0x%x", a);
	    }
	    break;

	case SCAL:
	    popn(n, &scalar);
	    found = false;
	    for (t = s->chain; t != nil; t = t->chain) {
		if (t->symvalue.iconval == scalar) {
		    printf("%s", symname(t));
		    found = true;
		    break;
		}
	    }
	    if (not found) {
		printf("(scalar = %d)", scalar);
	    }
	    break;

	case FPROC:
	case FFUNC:
	    a = pop(long);
	    t = whatblock(a);
	    if (t == nil) {
		printf("(proc 0x%x)", a);
	    } else {
		printf("%s", symname(t));
	    }
	    break;

	case SET:
	    printSet(s);
	    break;

	default:
	    if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
		panic("printval: bad class %d", ord(s->class));
	    }
	    printf("[%s]", classname(s));
	    break;
    }
}

/*
 * Print out the value of a scalar (non-enumeration) type.
 */

private printrange (s, n)
Symbol s;
integer n;
{
    double d;
    float f;
    integer i;

    if (s->symvalue.rangev.upper == 0 and s->symvalue.rangev.lower > 0) {
	if (n == sizeof(float)) {
	    popn(n, &f);
	    d = f;
	} else {
	    popn(n, &d);
	}
	prtreal(d);
    } else {
	i = 0;
	popn(n, &i);
	if (s == t_boolean) {
	    printf(((Boolean) i) == true ? "true" : "false");
	} else if (s == t_char or istypename(s->type, "char")) {
	    printf("'%c'", i);
	} else if (s->symvalue.rangev.lower >= 0) {
	    printf("%lu", i);
	} else {
	    printf("%ld", i);
	}
    }
}

/*
 * Print out a set.
 */

private printSet (s)
Symbol s;
{
    Symbol t;
    integer nbytes;

    nbytes = size(s);
    t = rtype(s->type);
    printf("{");
    sp -= nbytes;
    if (t->class == SCAL) {
	printSetOfEnum(t);
    } else if (t->class == RANGE) {
	printSetOfRange(t);
    } else {
	panic("expected range or enumerated base type for set");
    }
    printf("}");
}

/*
 * Print out a set of an enumeration.
 */

private printSetOfEnum (t)
Symbol t;
{
    register Symbol e;
    register integer i, j, *p;
    boolean first;

    p = (int *) sp;
    i = *p;
    j = 0;
    e = t->chain;
    first = true;
    while (e != nil) {
	if ((i&1) == 1) {
	    if (first) {
		first = false;
		printf("%s", symname(e));
	    } else {
		printf(", %s", symname(e));
	    }
	}
	i >>= 1;
	++j;
	if (j >= sizeof(integer)*BITSPERBYTE) {
	    j = 0;
	    ++p;
	    i = *p;
	}
	e = e->chain;
    }
}

/*
 * Print out a set of a subrange type.
 */

private printSetOfRange (t)
Symbol t;
{
    register integer i, j, *p;
    long v;
    boolean first;

    p = (int *) sp;
    i = *p;
    j = 0;
    v = t->symvalue.rangev.lower;
    first = true;
    while (v <= t->symvalue.rangev.upper) {
	if ((i&1) == 1) {
	    if (first) {
		first = false;
		printf("%ld", v);
	    } else {
		printf(", %ld", v);
	    }
	}
	i >>= 1;
	++j;
	if (j >= sizeof(integer)*BITSPERBYTE) {
	    j = 0;
	    ++p;
	    i = *p;
	}
	++v;
    }
}

/*
 * Construct a node for subscripting.
 */

public Node modula2_buildaref (a, slist)
Node a, slist;
{
    register Symbol t;
    register Node p;
    Symbol etype, atype, eltype;
    Node esub, r;

    r = a;
    t = rtype(a->nodetype);
    eltype = t->type;
    if (t->class != ARRAY) {
	beginerrmsg();
	prtree(stderr, a);
	fprintf(stderr, " is not an array");
	enderrmsg();
    } else {
	p = slist;
	t = t->chain;
	for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) {
	    esub = p->value.arg[0];
	    etype = rtype(esub->nodetype);
	    atype = rtype(t);
	    if (not compatible(atype, etype)) {
		beginerrmsg();
		fprintf(stderr, "subscript ");
		prtree(stderr, esub);
		fprintf(stderr, " is the wrong type");
		enderrmsg();
	    }
	    r = build(O_INDEX, r, esub);
	    r->nodetype = eltype;
	}
	if (p != nil or t != nil) {
	    beginerrmsg();
	    if (p != nil) {
		fprintf(stderr, "too many subscripts for ");
	    } else {
		fprintf(stderr, "not enough subscripts for ");
	    }
	    prtree(stderr, a);
	    enderrmsg();
	}
    }
    return r;
}

/*
 * Evaluate a subscript index.
 */

public int modula2_evalaref (s, i)
Symbol s;
long i;
{
    long lb, ub;

    chkOpenArray(s);
    s = rtype(rtype(s)->chain);
    findbounds(s, &lb, &ub);
    if (i < lb or i > ub) {
	error("subscript %d out of range [%d..%d]", i, lb, ub);
    }
    return (i - lb);
}

/*
 * Initial Modula-2 type information.
 */

#define NTYPES 12

private Symbol inittype[NTYPES + 1];

private addType (n, s, lower, upper)
integer n;
String s;
long lower, upper;
{
    register Symbol t;

    if (n > NTYPES) {
	panic("initial Modula-2 type number too large for '%s'", s);
    }
    t = insert(identname(s, true));
    t->language = mod2;
    t->class = TYPE;
    t->type = newSymbol(nil, 0, RANGE, t, nil);
    t->type->symvalue.rangev.lower = lower;
    t->type->symvalue.rangev.upper = upper;
    t->type->language = mod2;
    inittype[n] = t;
}

private initModTypes ()
{
    addType(1, "integer", 0x80000000L, 0x7fffffffL);
    addType(2, "char", 0L, 255L);
    addType(3, "boolean", 0L, 1L);
    addType(4, "unsigned", 0L, 0xffffffffL);
    addType(5, "real", 4L, 0L);
    addType(6, "longreal", 8L, 0L);
    addType(7, "word", 0L, 0xffffffffL);
    addType(8, "byte", 0L, 255L);
    addType(9, "address", 0L, 0xffffffffL);
    addType(10, "file", 0L, 0xffffffffL);
    addType(11, "process", 0L, 0xffffffffL);
    addType(12, "cardinal", 0L, 0x7fffffffL);
}

/*
 * Initialize typetable.
 */

public modula2_modinit (typetable)
Symbol typetable[];
{
    register integer i;

    if (not initialized) {
	initModTypes();
    }
    for (i = 1; i <= NTYPES; i++) {
	typetable[i] = inittype[i];
    }
}

public boolean modula2_hasmodules ()
{
    return true;
}

public boolean modula2_passaddr (param, exprtype)
Symbol param, exprtype;
{
    return false;
}
\.
wq
'endex'

echo names.c
ex - names.c <<'endex'
4a
static char rcsid[] = "$Header: names.c,v 1.3 84/03/27 10:22:19 linton Exp $";

\.
wq
'endex'

echo object.c
ex - object.c <<'endex'
1098c
private setnfiles ()
\.
1089c
private setnlines ()
\.
1073c
private enterfile (filename, addr)
\.
1049,1050c
private allocmaps (nf, nl)
integer nf, nl;
\.
615,1045d
611c
    initTypeTable();
\.
594,605d
592a
	nn = identname(mname, true);
	if (curmodule == nil or curmodule->name != nn) {
	    s = insert(nn);
	    s->class = MODULE;
	    s->symvalue.funcv.beginaddr = 0;
	    findbeginning(s);
	} else {
	    s = curmodule;
	}
	s->language = curlang;
	enterblock(s);
	curmodule = s;
\.
591a
	    if (curblock->class != PROG) {
		exitblock();
	    }
\.
588,589c
    if (not (*language_op(curlang, L_HASMODULES))()) {
\.
568c
private enterSourceModule (n, addr)
\.
546,555c
    if (nesting > 0 and addrstk[nesting] != NOADDR) {
	startaddr = (linep - 1)->addr;
	++bnum;
	sprintf(buf, "$b%d", bnum);
	s = insert(identname(buf, false));
	s->language = curlang;
	s->class = PROC;
	s->symvalue.funcv.src = false;
	s->symvalue.funcv.inline = true;
	s->symvalue.funcv.beginaddr = startaddr;
	enterblock(s);
	newfunc(s, startaddr);
	addrstk[nesting] = NOADDR;
    }
\.
544a
    Address startaddr;
\.
540c
public chkUnnamedBlock ()
\.
505c
    register integer i;
\.
501c
private check_filename (name)
\.
466c
private check_local (name, np)
\.
457d
455a
	t->block = curblock;
\.
447,449c
    t = findsym(n);
\.
441c
private check_var (np, n)
\.
412,414c
	    if (t->class == VAR) {
		t->symvalue.offset = np->n_value;
	    } else {
		t->symvalue.funcv.beginaddr = np->n_value;
		newfunc(t, codeloc(t));
		findbeginning(t);
	    }
\.
398,401c
	    t = findsym(n);
\.
388c
private check_global (name, np)
\.
383a
 * Try to find the symbol that is referred to by the given name.
 * Since it's an external, we may want to follow a level of indirection.
 */

private Symbol findsym (n)
Name n;
{
    register Symbol r, s;

    find(s, n) where
	s->level == program->level and
	    (s->class == EXTREF or s->class == VAR or
	     s->class == PROC or s->class == FUNC)
    endfind(s);
    if (s != nil and s->class == EXTREF) {
	r = s->symvalue.extref;
	delete(s);
    } else {
	r = s;
    }
    return r;
}

/*
\.
369a
	case N_MOD2:
\.
335a
	    n = identname(name, true);
\.
325d
323a
		addrstk[nesting] = (linep - 1)->addr;
\.
320a
	    --nesting;
\.
296a
	    n = identname(name, true);
\.
282,286d
278,279c
    register Name n;
\.
273c
private enter_nl (name, np)
\.
260c
public objfree ()
\.
253a
    t_boolean = maketype("$boolean", 0L, 1L);
    t_int = maketype("$integer", 0x80000000L, 0x7fffffffL);
    t_char = maketype("$char", 0L, 255L);
    t_real = maketype("$real", 8L, 0L);
    t_nil = maketype("$nil", 0L, 0L);
    t_open = maketype("integer", 0L, -1L);
\.
237,246c
    program = insert(identname("", true));
\.
232c
private initsyms ()
\.
228a
 * Get a continuation entry from the name list.
 * Return the beginning of the name.
 */

public String getcont ()
{
    register integer index;
    register String name;

    ++curnp;
    index = curnp->n_un.n_strx;
    if (index == 0) {
	panic("continuation followed by empty stab");
    }
    name = &stringtab[index - 4];
    return name;
}

/*
\.
220a
	++curnp;
	np = curnp;
\.
193c
	 * Assumptions:
\.
191a

\.
188d
183,186d
177,181c
		lastchar = &name[strlen(name) - 1];
		if (*lastchar == '_') {
		    *lastchar = '\0';
\.
171c
             *  If the program contains any .f files a trailing _ is stripped
\.
166c
    curnp = &namelist[0];
    np = curnp;
    while (np < ub) {
\.
159a
    integer index;
    char *lastchar;
\.
157d
152c
private readsyms (f)
\.
116c
public readobj (file)
\.
105,108d
84c
 * private enterline (linenumber, address)
\.
79a
public exitblock ()
{
    if (curblock->class == FUNC or curblock->class == PROC) {
	if (prevlinep != linep) {
	    curblock->symvalue.funcv.src = true;
	}
    }
    if (curlevel <= 0) {
	panic("nesting depth underflow (%d)", curlevel);
    }
    --curlevel;
    if (traceblocks) {
	printf("exiting block %s\n", symname(curblock));
    }
    curblock = blkstack[curlevel];
}

\.
70,77c
public enterblock (b)
Symbol b;
{
    if (curblock == nil) {
	b->level = 1;
    } else {
	b->level = curblock->level + 1;
    }
    b->block = curblock;
    pushBlock(b);
\.
62,67c
public pushBlock (b)
Symbol b;
{
    if (curlevel >= MAXBLKDEPTH) {
	fatal("nesting depth too large (%d)", curlevel);
    }
    blkstack[curlevel] = curblock;
    ++curlevel;
    curblock = b;
    if (traceblocks) {
	printf("entering block %s\n", symname(b));
    }
\.
58,59c
private integer curlevel;
private integer bnum, nesting;
\.
56c
public Symbol curblock;

\.
48c
public String curfilename ()
{
    return ((filep-1)->filename);
}
\.
41,42d
36,39c
public Language curlang;
public Symbol curmodule;
public Symbol curparam;
public Symbol curcomm;
public Symbol commchain;

private char *stringtab;
private struct nlist *curnp;
\.
33,34c
public integer objsize;
\.
31a
#ifndef N_MOD2
#    define N_MOD2 0x50
#endif

\.
29a
#include "languages.h"
#include "symbols.h"

\.
10a
#include "stabstring.h"
\.
4a
static char rcsid[] = "$Header: object.c,v 1.4 84/03/27 10:22:25 linton Exp $";

\.
wq
'endex'

echo operators.c
ex - operators.c <<'endex'
199a
/* O_RERUN */		0,	null,		"rerun",
/* O_RETURN */		1,	null,		"return",
/* O_UP */		1,	UNARY,		"up",
/* O_DOWN */		1,	UNARY,		"down",
\.
160c
/* O_DELETE */		1,	null,		"delete",
\.
80a
    O_RERUN,		/* re-run program with the same arguments as before */
    O_RETURN,		/* continue execution until procedure returns */
    O_UP,		/* move current function up the call stack */
    O_DOWN,		/* move current function down the call stack */
\.
4a
static char rcsid[] = "$Header: operators.c,v 1.3 84/03/27 10:22:38 linton Exp $";

\.
wq
'endex'

echo ops.c
ex - ops.c <<'endex'
4a
static char rcsid[] = "$Header: ops.c,v 1.3 84/03/27 10:22:43 linton Exp $";

\.
wq
'endex'

echo pascal.c
ex - pascal.c <<'endex'
439a
}

/*
 * Construct a node for subscripting.
 */

public Node pascal_buildaref (a, slist)
Node a, slist;
{
    register Symbol t;
    register Node p;
    Symbol etype, atype, eltype;
    Node esub, r;

    r = a;
    t = rtype(a->nodetype);
    eltype = t->type;
    if (t->class != ARRAY) {
	beginerrmsg();
	prtree(stderr, a);
	fprintf(stderr, " is not an array");
	enderrmsg();
    } else {
	p = slist;
	t = t->chain;
	for (; p != nil and t != nil; p = p->value.arg[1], t = t->chain) {
	    esub = p->value.arg[0];
	    etype = rtype(esub->nodetype);
	    atype = rtype(t);
	    if (not compatible(atype, etype)) {
		beginerrmsg();
		fprintf(stderr, "subscript ");
		prtree(stderr, esub);
		fprintf(stderr, " is the wrong type");
		enderrmsg();
	    }
	    r = build(O_INDEX, r, esub);
	    r->nodetype = eltype;
	}
	if (p != nil or t != nil) {
	    beginerrmsg();
	    if (p != nil) {
		fprintf(stderr, "too many subscripts for ");
	    } else {
		fprintf(stderr, "not enough subscripts for ");
	    }
	    prtree(stderr, a);
	    enderrmsg();
	}
    }
    return r;
}

/*
 * Evaluate a subscript index.
 */

public int pascal_evalaref (s, i)
Symbol s;
long i;
{
    long lb, ub;

    s = rtype(rtype(s)->chain);
    lb = s->symvalue.rangev.lower;
    ub = s->symvalue.rangev.upper;
    if (i < lb or i > ub) {
	error("subscript %d out of range [%d..%d]", i, lb, ub);
    }
    return (i - lb);
}

/*
 * Initial Pascal type information.
 */

#define NTYPES 4

private Symbol inittype[NTYPES];
private integer count;

private addType (s, lower, upper)
String s;
long lower, upper;
{
    register Symbol t;

    if (count > NTYPES) {
	panic("too many initial types");
    }
    t = maketype(s, lower, upper);
    t->language = pasc;
    inittype[count] = t;
    ++count;
}

private initTypes ()
{
    count = 1;
    addType("integer", 0x80000000L, 0x7fffffffL);
    addType("char", 0L, 255L);
    addType("boolean", 0L, 1L);
    addType("real", 4L, 0L);
}

/*
 * Initialize typetable.
 */

public pascal_modinit (typetable)
Symbol typetable[];
{
    register integer i;

    for (i = 1; i < NTYPES; i++) {
	typetable[i] = inittype[i];
    }
}

public boolean pascal_hasmodules ()
{
    return false;
}

public boolean pascal_passaddr (param, exprtype)
Symbol param, exprtype;
{
    return false;
\.
395,397d
358c
	    } else if (s == t_char or istypename(s,"char")) {
\.
336c
	    if (t->class==RANGE and istypename(t->type,"char")) {
\.
330a
	case VAR:
	case REF:
	case FVAR:
	case TAG:
	case FIELD:
\.
329a
	case CONST:
\.
326,328d
251c
	    t = t->chain;
\.
215c
	    if (t == t_char or istypename(t,"char")) {
\.
29,34c
    pasc = language_define("pascal", ".p");
    language_setop(pasc, L_PRINTDECL, pascal_printdecl);
    language_setop(pasc, L_PRINTVAL, pascal_printval);
    language_setop(pasc, L_TYPEMATCH, pascal_typematch);
    language_setop(pasc, L_BUILDAREF, pascal_buildaref);
    language_setop(pasc, L_EVALAREF, pascal_evalaref);
    language_setop(pasc, L_MODINIT, pascal_modinit);
    language_setop(pasc, L_HASMODULES, pascal_hasmodules);
    language_setop(pasc, L_PASSADDR, pascal_passaddr);
    initTypes();
\.
22a
private Language pasc;

\.
4a
static char rcsid[] = "$Header: pascal.c,v 1.3 84/03/27 10:23:04 linton Exp $";

\.
wq
'endex'

echo printsym.c
ex - printsym.c <<'endex'
571a
    } else {
	printf("\\0%o",c);
\.
570c
    } else if (c >= ' ' && c <= '~') {
\.
481,482c
    off = f->symvalue.field.offset;
    len = f->symvalue.field.length;
    sp += ((off + len + BITSPERBYTE - 1) div BITSPERBYTE);
    printval(f);
\.
475,479c
    printf("%s = ", symname(f));
\.
473a
    register int off, len;
\.
470,471c
private printfield(f)
Symbol f;
\.
466,467c
 * Print out a field.
\.
461c
    f = s->chain;
    if (f != nil) {
	for (;;) {
	    printfield(f);
	    f = f->chain;
	if (f == nil) break;
	    printf(", ");
	}
    }
\.
455a
    Symbol f;

\.
441a
	    } else if (t->language == primlang) {
		(*language_op(findlanguage(".c"), L_PRINTVAL))(t);
\.
431a
    if (t->class == TYPEREF) {
	resolveRef(t);
    }
\.
387d
256a
    } else if (s == program) {
	fprintf(f, ".");
\.
244a
 */
\.
243a
/*
 * Matches brace commented out above.
\.
229a
 */
\.
227,228c
/*
 * Not today.
    t = rtype(s->type);
    if (t->class == ARRAY and not istypename(t->type, "char")) {
	printf("ARRAY");
\.
219a
    Symbol t;
\.
130a
    if (isinternal(f)) {
	n = 0;
    }
\.
120a
 *
 * If the procedure or function is internal, the argument count is
 * not valid so we ignore it.
\.
44c
    "procparam", "funcparam", "module", "tag", "common", "extref", "typeref"
\.
4a
static char rcsid[] = "$Header: printsym.c,v 1.3 84/03/27 10:23:14 linton Exp $";

\.
wq
'endex'

echo process.c
ex - process.c <<'endex'
1103,1104c
Fileid oldfd;
Fileid newfd;
\.
1101a
private infrom (filename)
String filename;
{
    Fileid in;

    in = open(filename, 0);
    if (in == -1) {
	write(2, "can't read ", 11);
	write(2, filename, strlen(filename));
	write(2, "\n", 1);
	_exit(1);
    }
    fswap(0, in);
}

/*
 * Redirect standard output.
 * Same assumptions as for "infrom" above.
 */

private outto (filename)
String filename;
{
    Fileid out;

    out = creat(filename, 0666);
    if (out == -1) {
	write(2, "can't write ", 12);
	write(2, filename, strlen(filename));
	write(2, "\n", 1);
	_exit(1);
    }
    fswap(1, out);
}

/*
 * Swap file numbers, useful for redirecting standard input or output.
 */

\.
1099c
 * Redirect input.
 * Assuming this is called from a child, we should be careful to avoid
 * (possibly) shared standard I/O buffers.
\.
933a
 * Return the address associated with the current signal.
 * (Plus two since the address points to the beginning of a procedure).
 */

public Address usignal (p)
Process p;
{
    Address r;

    r = p->sigstatus;
    if (r != 0 and r != 1) {
	r += 2;
    }
    return r;
}

/*
\.
919c
	if (istraced(p) and (p->sigstatus == 0 or p->sigstatus == 1)) {
\.
903a
	addr = (Address) &(((struct user *) 0)->u_signal[p->signo]);
	p->sigstatus = (Address) ptrace(UREAD, p->pid, addr, 0);
\.
893a
	p->reg[PROGCTR] = 0;
\.
887a
    Address addr;
\.
813a
    if (traceexec) {
	printf("!! pstep to pc 0x%x on signal %d\n", p->reg[PROGCTR], p->signo);
	fflush(stdout);
    }
    if (p->status != STOPPED) {
	error("program unexpectedly exited with %d\n", p->exitval);
    }
\.
810c
    if (ptrace(SSTEP, p->pid, p->reg[PROGCTR], p->signo) < 0) {
	panic("error %d trying to step process", errno);
    }
\.
808c
    setinfo(p, signo);
    if (traceexec) {
	printf("!! pstep from pc 0x%x with signal %d (%d)\n",
	    p->reg[PROGCTR], signo, p->signo);
	fflush(stdout);
    }
\.
804a
integer signo;
\.
803c
public pstep(p, signo)
\.
796a
    if (traceexec) {
	printf("!! pcont to 0x%x on signal %d\n", p->reg[PROGCTR], p->signo);
	fflush(stdout);
    }
\.
795a
	if (traceexec and not istraced(p)) {
	    printf("!! ignored signal %d at 0x%x\n", p->signo, p->reg[PROGCTR]);
	    fflush(stdout);
	}
	s = p->signo;
\.
788c
	setinfo(p, s);
	if (traceexec) {
	    printf("!! pcont from 0x%x with signal %d (%d)\n",
		p->reg[PROGCTR], s, p->signo);
	    fflush(stdout);
	}
\.
786a
    s = signo;
\.
782c
    int s, status;
\.
768a
 * Terminate a ptrace'd process.
 */

public pterm (p)
Process p;
{
    integer status;

    if (p != nil and p->pid != 0) {
	ptrace(PKILL, p->pid, 0, 0);
	pwait(p->pid, &status);
	unptraced(p->pid);
    }
}

/*
\.
745,752c
	    outto(outfile);
\.
735,742c
	    infrom(infile);
\.
722,725c
    if (p->pid != 0) {
	pterm(p);
\.
720d
489d
473c
	setcurfunc(whatblock(pc));
\.
458a
    curpc = process->reg[PROGCTR];
    if (addr != curpc) {
	if (traceexec) {
	    printf("!! stepping from 0x%x to 0x%x\n", curpc, addr);
	}
	if (catchbps) {
	    setallbps();
	}
	setbp(addr);
	resume(DEFSIG);
	unsetbp(addr);
	if (catchbps) {
	    unsetallbps();
	}
	if (not isbperr()) {
	    printstatus();
	}
    }
\.
453,457c
    xto(addr, false);
}

private contto (addr)
Address addr;
{
    xto(addr, true);
}

private xto (addr, catchbps)
Address addr;
boolean catchbps;
{
    Address curpc;

    if (catchbps) {
	stepover();
\.
441a
    if (traceexec) {
	printf("!! stepped over to 0x%x\n", process->reg[PROGCTR]);
    }
\.
433a
    if (traceexec) {
	printf("!! stepping over 0x%x\n", process->reg[PROGCTR]);
    }
\.
430c
public stepover()
\.
421a
 * Continue execution until the current function returns, or,
 * if the given argument is non-nil, until execution returns to
 * somewhere within the given function.
 */

public rtnfunc (f)
Symbol f;
{
    Address addr;
    Symbol t;

    if (not isstopped) {
	error("can't continue execution");
    } else if (f != nil and not isactive(f)) {
	error("%s is not active", symname(f));
    } else {
	addr = return_addr();
	if (addr == nil) {
	    error("no place to return to");
	} else {
	    isstopped = false;
	    contto(addr);
	    if (f != nil) {
		for (;;) {
		    t = whatblock(pc);
		    addr = return_addr();
		if (t == f or addr == nil) break;
		    contto(addr);
		}
	    }
	    if (bpact() fails) {
		isstopped = true;
		printstatus();
	    }
	}
    }
}

/*
\.
417c
    oldfrp = reg(FRP);
    do {
	dostep(true);
	pc = reg(PROGCTR);
	newfrp = reg(FRP);
    } while (newfrp < oldfrp and newfrp != 0);
\.
412a
    Address oldfrp, newfrp;

\.
374,378d
368,371d
328a
	    s = DEFSIG;
\.
327c
	    resume(s);
\.
321a
    s = signo;
\.
311a
    integer s;

\.
310c
integer signo;
\.
179c
	setcurfunc(program);
\.
72a
    Address sigstatus;		/* process' handler for current signal */
\.
47,48c
 * A cache of the instruction segment is kept to reduce the number
 * of system calls.  Might be better just to read the entire
 * code space into memory.
\.
26a
#include <sys/dir.h>
#include <sys/user.h>
\.
4a
static char rcsid[] = "$Header: process.c,v 1.3 84/03/27 10:23:24 linton Exp $";

\.
wq
'endex'

echo runtime.c
ex - runtime.c <<'endex'
623a
    curframerec = pop(struct Frame);
    curframe = pop(Frame);
\.
609a
    push(Frame, curframe);
    push(struct Frame, curframerec);
\.
581,583c
    if (chk) {
	if (formal != nil) {
	    sp = savesp;
	    error("not enough parameters to %s", symname(proc));
	}
\.
568,578d
563,566c
	passparam(actual, formal);
	if (formal != nil) {
	    formal = formal->chain;
\.
561c
	    enderrmsg();
\.
556,559c
	assert(p->op == O_COMMA);
	actual = p->value.arg[0];
	if (not chkparam(actual, formal, chk)) {
	    fprintf(stderr, " in call to %s", symname(proc));
\.
554c
    formal = proc->chain;
    chk = (boolean) (not nosource(proc));
\.
550a
    boolean chk;
\.
549d
546,547c
    Node p, actual;
    Symbol formal;
\.
541a
private boolean chkparam (actual, formal, chk)
Node actual;
Symbol formal;
boolean chk;
{
    boolean b;

    b = true;
    if (chk) {
	if (formal == nil) {
	    beginerrmsg();
	    fprintf(stderr, "too many parameters");
	    b = false;
	} else if (not compatible(formal->type, actual->nodetype)) {
	    beginerrmsg();
	    fprintf(stderr, "type mismatch for %s", symname(formal));
	    b = false;
	}
    }
    if (b and formal != nil and isvarparam(formal) and
	not isopenarray(formal->type) and actual->op != O_RVAL)
    {
	beginerrmsg();
	fprintf(stderr, "expected variable, found \"");
	prtree(stderr, actual);
	fprintf(stderr, "\"");
	b = false;
    }
    return b;
}

/*
 * Pass an expression to a particular parameter.
 *
 * Normally we pass either the address or value, but in some cases
 * (such as C strings) we want to copy the value onto the stack and
 * pass its address.
 */

private passparam (actual, formal)
Node actual;
Symbol formal;
{
    boolean b;
    Address addr;
    Stack *savesp;
    integer paramsize;

    if (isvarparam(formal) and not isopenarray(formal->type)) {
	addr = lval(actual->value.arg[0]);
	push(Address, addr);
    } else if (passaddr(formal, actual->nodetype)) {
	savesp = sp;
	eval(actual);
	paramsize = sp - savesp;
	setreg(STKP, reg(STKP) - paramsize);
	dwrite(savesp, reg(STKP), paramsize);
	sp = savesp;
	push(Address, reg(STKP));
	if (formal != nil and isopenarray(formal->type)) {
	    push(integer, paramsize div size(formal->type->type));
	}
    } else {
	eval(actual);
    }
}

/*
 * Evaluate an argument list left-to-right.
 */

\.
539c
 * Check to see if an expression is correct for a given parameter.
 * If the given parameter is false, don't worry about type inconsistencies.
 *
 * Return whether or not it is ok.
\.
512c
    cont(0);
\.
401c
    if (isinternal(f)) {
	f->symvalue.funcv.beginaddr += 15;
    } else {
	f->symvalue.funcv.beginaddr += 2;
    }
\.
394a
 * Set the current function to the given symbol.
 * We must adjust "curframe" so that subsequent operations are
 * not confused; for simplicity we simply clear it.
 */

public setcurfunc (f)
Symbol f;
{
    curfunc = f;
    curframe = nil;
}

/*
 * Set curfunc to be N up/down the stack from its current value.
 */

public up (n)
integer n;
{
    integer i;
    Symbol f;
    Frame frp;
    boolean done;

    if (not isactive(program)) {
	error("program is not active");
    } else if (curfunc == nil) {
	error("no current function");
    } else {
	i = 0;
	f = curfunc;
	if (curframe != nil) {
	    frp = curframe;
	} else {
	    frp = findframe(f);
	}
	done = false;
	do {
	    if (frp == nil) {
		done = true;
		error("not that many levels");
	    } else if (i >= n) {
		done = true;
		curfunc = f;
		curframe = &curframerec;
		*curframe = *frp;
	    } else if (f == program) {
		done = true;
		error("not that many levels");
	    } else {
		frp = nextfunc(frp, &f);
	    }
	    ++i;
	} while (not done);
    }
}

public down (n)
integer n;
{
    integer i, depth;
    register Frame frp;
    Symbol f;
    struct Frame frame;

    if (not isactive(program)) {
	error("program is not active");
    } else if (curfunc == nil) {
	error("no current function");
    } else {
	depth = 0;
	frp = &frame;
	getcurfunc(frp, &f);
	if (curframe == nil) {
	    curframe = &curframerec;
	    *curframe = *(findframe(curfunc));
	}
	while ((f != curfunc or !frameeq(frp, curframe)) and f != nil) {
	    frp = nextfunc(frp, &f);
	    ++depth;
	}
	if (f == nil or n > depth) {
	    error("not that many levels");
	} else {
	    depth -= n;
	    frp = &frame;
	    getcurfunc(frp, &f);
	    for (i = 0; i < depth; i++) {
		frp = nextfunc(frp, &f);
		assert(frp != nil);
	    }
	    curfunc = f;
	    *curframe = *frp;
	}
    }
}

/*
\.
376,383c
	    frp = nextfunc(frp, &f);
\.
358,359c
	getcurfunc(frp, &f);
\.
349a
    Symbol f;
\.
347d
168,169c
	    } while (not done);
	}
\.
166a
		} else if (p == program) {
		    done = true;
		    frp = nil;
		} else {
		    frp = nextfunc(frp, &p);
		    if (frp == nil) {
			done = true;
		    }
\.
158,165c
	    do {
		if (p == f) {
\.
155,156c
	if (f == curfunc and curframe != nil) {
	    *frp = *curframe;
	} else {
	    done = false;
\.
137a
 * Get the current frame information in the given Frame and store the
 * associated function in the given value-result parameter.
 */

private getcurfunc (frp, fp)
Frame frp;
Symbol *fp;
{
    getcurframe(frp);
    *fp = whatblock(frp->save_pc);
}

/*
 * Return the frame associated with the next function up the call stack, or
 * nil if there is none.  The function is returned in a value-result parameter.
 * For "inline" functions the statically outer function and same frame
 * are returned.
 */

private Frame nextfunc (frp, fp)
Frame frp;
Symbol *fp;
{
    Symbol t;
    Frame nfrp;

    t = *fp;
    checkref(t);
    if (isinline(t)) {
	t = container(t);
	nfrp = frp;
    } else {
	nfrp = nextframe(frp);
	if (nfrp == nil) {
	    t = nil;
	} else {
	    t = whatblock(nfrp->save_pc);
	}
    }
    *fp = t;
    return nfrp;
}

/*
\.
42a
#define frameeq(f1, f2) ((f1)->save_fp == (f2)->save_fp)

\.
40a
private Frame curframe = nil;
private struct Frame curframerec;
\.
5a
static char rcsid[] = "$Header: runtime.c,v 1.3 84/03/27 10:23:40 linton Exp $";

\.
4c
static char sccsid[] = "@(#)runtime.c 1.8 8/10/83";
\.
wq
'endex'

echo scanner.c
ex - scanner.c <<'endex'
291c
	} while (index(" \t\n!&<>*[]()'\"", *p) == nil);
\.
255,258c
	    fprintf(stderr, "^ syntax error");
\.
253c
	    fprintf(stderr, "^ unrecognized command");
\.
251a
	fprintf(stderr, "%s", linebuf);
	if (start != 0) {
	    fprintf(stderr, "%*c", start, ' ');
	}
\.
240,246c
	p = prevchar;
	start = p - &linebuf[0];
\.
235,236c
    register char *p;
    register integer start;
\.
128a
    prevchar = curchar;
\.
39c
private Char *curchar, *prevchar;
\.
4a
static char rcsid[] = "$Header: scanner.c,v 1.3 84/03/27 10:23:50 linton Exp $";

\.
wq
'endex'

echo source.c
ex - source.c <<'endex'
4a
static char rcsid[] = "$Header: source.c,v 1.3 84/03/27 10:23:58 linton Exp $";

\.
wq
'endex'

echo tree.c
ex - tree.c <<'endex'
584c
 * A recursive tree search routine to test if two trees are equivalent.
\.
320d
107d
4a
static char rcsid[] = "$Header: tree.c,v 1.3 84/03/27 10:24:40 linton Exp $";

\.
wq
'endex'

echo commands.y
ex - commands.y <<'endex'
878,881c
    DOWN | DUMP | EDIT | FILE | FUNC | GRIPE | HELP | IGNORE | IN | LIST |
    MOD | NEXT | NEXTI | NIL | NOT | OR | PRINT | PSYM | QUIT |
    RERUN | RETURN | RUN | SH | SKIP | SOURCE | STATUS | STEP | STEPI |
    STOP | STOPI | TRACE | TRACEI | UP |
\.
864a
|
    '.' name
{
	$$ = dot(build(O_SYM, program), $2);
}
\.
859a
opt_qual_symbol:
    symbol
{
	$$ = $1;
}
|
    opt_qual_symbol '.' name
{
	$$ = dot($1, $3);
}
;
\.
831a
    '#' '(' exp ')' %prec UNARYSIGN
{
	$$ = concrete($3);
}
|
\.
686c
    exp '\\' opt_qual_symbol
\.
561a
integer_list:
    INT
{
	$$ = build(O_LCON, $1);
}
|
    INT integer_list
{
	$$ = build(O_COMMA, build(O_LCON, $1), $2);
}
;
\.
557c
    LIST opt_qual_symbol
\.
427c
	$$ = build(O_CALL, $2, $4);
\.
425c
    CALL term '(' opt_exp_list ')'
\.
332a
    STRING
{
	newarg($1);
}
|
\.
320a
|
    RERUN shellmode
{
	fflush(stdout);
}
\.
318a
	arginit();
\.
312c
    run arglist
\.
309a
|
    WHATIS term
{
	$$ = build(O_WHATIS, $2);
}
|
    WHEN event '{' actions '}'
{
	$$ = build(O_ADDEVENT, $2, $4);
}
|
    WHEREIS symbol
{
	$$ = build(O_WHEREIS, $2);
}
|
    WHICH symbol
{
	$$ = build(O_WHICH, $2);
}
\.
283,292d
280c
	$$ = build(O_UP, build(O_LCON, (long) $2));
\.
278c
    UP INT
\.
275c
	$$ = build(O_UP, build(O_LCON, (long) 1));
\.
273c
    UP
\.
215a
    RETURN
{
	$$ = build(O_RETURN, nil);
}
|
    RETURN opt_qual_symbol
{
	$$ = build(O_RETURN, $2);
}
|
\.
177c
    FUNC opt_qual_symbol
\.
161a
    DOWN
{
	$$ = build(O_DOWN, build(O_LCON, (long) 1));
}
|
    DOWN INT
{
	$$ = build(O_DOWN, build(O_LCON, (long) $2));
}
|
\.
157c
    DELETE integer_list
\.
73c
%type <y_node>	    integer_list alias_command list_command line_number
\.
69c
%type <y_node>      opt_qual_symbol symbol
\.
65,67c
%type <y_name>	    PRINT PSYM QUIT RERUN RETURN RUN SH SKIP SOURCE STATUS
%type <y_name>	    STEP STEPI STOP STOPI TRACE TRACEI
%type <y_name>	    UP USE WHATIS WHEN WHERE WHEREIS WHICH
\.
62c
%type <y_name>	    ALIAS AND ASSIGN AT CALL CATCH CONT
%type <y_name>	    DEBUG DELETE DIV DOWN DUMP
\.
28,29c
    PRINT PSYM QUIT RERUN RETURN RUN SH SKIP SOURCE STATUS STEP STEPI
    STOP STOPI TRACE TRACEI UP
\.
26c
    ALIAS AND ASSIGN AT CALL CATCH CONT DEBUG DELETE DIV DOWN DUMP
\.
6a
static char rcsid[] = "$Header: commands.y,v 1.3 84/03/27 10:19:59 linton Exp $";

\.
wq
'endex'

echo stabstring.c
ex - stabstring.c <<'endex'
0a
/*
 * String information interpretation
 *
 * The string part of a stab entry is broken up into name and type information.
 */

static char rcsid[] = "$Header: stabstring.c,v 1.4 84/03/27 10:24:04 linton Exp $";

#include "defs.h"
#include "stabstring.h"
#include "object.h"
#include "main.h"
#include "symbols.h"
#include "names.h"
#include "languages.h"
#include <a.out.h>
#include <ctype.h>

#ifndef public
#endif

/*
 * Special characters in symbol table information.
 */

#define TYPENAME 't'
#define TAGNAME 'T'
#define MODULEBEGIN 'm'
#define EXTPROCEDURE 'P'
#define PRIVPROCEDURE 'Q'
#define INTPROCEDURE 'I'
#define EXTFUNCTION 'F'
#define PRIVFUNCTION 'f'
#define INTFUNCTION 'J'
#define EXTVAR 'G'
#define MODULEVAR 'S'
#define OWNVAR 'V'
#define REGVAR 'r'
#define VALUEPARAM 'p'
#define VARIABLEPARAM 'v'
#define LOCALVAR /* default */

/*
 * Type information special characters.
 */

#define T_SUBRANGE 'r'
#define T_ARRAY 'a'
#define T_OPENARRAY 'A'
#define T_RECORD 's'
#define T_UNION 'u'
#define T_ENUM 'e'
#define T_PTR '*'
#define T_FUNCVAR 'f'
#define T_PROCVAR 'p'
#define T_IMPORTED 'i'
#define T_SET 'S'
#define T_OPAQUE 'o'

/*
 * Table of types indexed by per-file unique identification number.
 */

#define NTYPES 1000

private Symbol typetable[NTYPES];

public initTypeTable ()
{
    bzero(typetable, sizeof(typetable));
    (*language_op(curlang, L_MODINIT))(typetable);
}

/*
 * Put an nlist entry into the symbol table.
 * If it's already there just add the associated information.
 *
 * Type information is encoded in the name following a ":".
 */

private Symbol constype();
private Char *curchar;

#define skipchar(ptr, ch) \
{ \
    if (*ptr != ch) { \
	panic("expected char '%c', found '%s'", ch, ptr); \
    } \
    ++ptr; \
}

#define optchar(ptr, ch) \
{ \
    if (*ptr == ch) { \
	++ptr; \
    } \
}

#define chkcont(ptr) \
{ \
    if (*ptr == '?') { \
	ptr = getcont(); \
    } \
}

#define newSym(s, n) \
{ \
    s = insert(n); \
    s->level = curblock->level + 1; \
    s->language = curlang; \
    s->block = curblock; \
}

#define makeVariable(s, n, off) \
{ \
    newSym(s, n); \
    s->class = VAR; \
    s->symvalue.offset = off; \
    getType(s); \
}

#define makeParameter(s, n, cl, off) \
{ \
    newSym(s, n); \
    s->class = cl; \
    s->symvalue.offset = off; \
    curparam->chain = s; \
    curparam = s; \
    getType(s); \
}

public entersym (name, np)
String name;
struct nlist *np;
{
    Symbol s;
    char *p;
    register Name n;
    char c;

    p = index(name, ':');
    *p = '\0';
    c = *(p+1);
    n = identname(name, true);
    chkUnnamedBlock();
    curchar = p + 2;
    switch (c) {
	case TYPENAME:
	    newSym(s, n);
	    typeName(s);
	    break;

	case TAGNAME:
	    newSym(s, n);
	    tagName(s);
	    break;

	case MODULEBEGIN:
	    newSym(s, n);
	    publicRoutine(s, MODULE, np->n_value);
	    curmodule = s;
	    break;

	case EXTPROCEDURE:
	    newSym(s, n);
	    publicRoutine(s, PROC, np->n_value);
	    break;

	case PRIVPROCEDURE:
	    privateRoutine(&s, n, PROC, np->n_value);
	    break;

	case INTPROCEDURE:
	    newSym(s, n);
	    markInternal(s);
	    publicRoutine(s, PROC, np->n_value);
	    break;

	case EXTFUNCTION:
	    newSym(s, n);
	    publicRoutine(s, FUNC, np->n_value);
	    break;

	case PRIVFUNCTION:
	    privateRoutine(&s, n, FUNC, np->n_value);
	    break;

	case INTFUNCTION:
	    newSym(s, n);
	    markInternal(s);
	    publicRoutine(s, FUNC, np->n_value);
	    break;

	case EXTVAR:
	    find(s, n) where
		s->level == program->level and s->class == VAR
	    endfind(s);
	    if (s == nil) {
		makeVariable(s, n, np->n_value);
		s->level = program->level;
		s->block = program;
		getExtRef(s);
	    }
	    break;

	case MODULEVAR:
	    if (curblock->class != MODULE) {
		exitblock();
	    }
	    makeVariable(s, n, np->n_value);
	    s->level = program->level;
	    s->block = curmodule;
	    getExtRef(s);
	    break;

	case OWNVAR:
	    makeVariable(s, n, np->n_value);
	    ownVariable(s, np->n_value);
	    getExtRef(s);
	    break;

	case REGVAR:
	    makeVariable(s, n, np->n_value);
	    s->level = -(s->level);
	    break;

	case VALUEPARAM:
	    makeParameter(s, n, VAR, np->n_value);
	    break;

	case VARIABLEPARAM:
	    makeParameter(s, n, REF, np->n_value);
	    break;

	default:	/* local variable */
	    --curchar;
	    makeVariable(s, n, np->n_value);
	    break;
    }
    if (tracesyms) {
	printdecl(s);
	fflush(stdout);
    }
}

/*
 * Enter a type name.
 */

private typeName (s)
Symbol s;
{
    register integer i;

    s->class = TYPE;
    s->language = curlang;
    s->block = curblock;
    s->level = curblock->level + 1;
    i = getint();
    if (i == 0) {
	panic("bad input on type \"%s\" at \"%s\"", symname(s), curchar);
    } else if (i >= NTYPES) {
	panic("too many types in file \"%s\"", curfilename());
    }
    /*
     * A hack for C typedefs that don't create new types,
     * e.g. typedef unsigned int Hashvalue;
     *  or  typedef struct blah BLAH;
     */
    if (*curchar != '=') {
	s->type = typetable[i];
	if (s->type == nil) {
	    s->type = symbol_alloc();
	    typetable[i] = s->type;
	}
    } else {
	if (typetable[i] != nil) {
	    typetable[i]->language = curlang;
	    typetable[i]->class = TYPE;
	    typetable[i]->type = s;
	} else {
	    typetable[i] = s;
	}
	skipchar(curchar, '=');
	getType(s);
    }
}

/*
 * Enter a tag name.
 */

private tagName (s)
Symbol s;
{
    register integer i;

    s->class = TAG;
    i = getint();
    if (i == 0) {
	panic("bad input on tag \"%s\" at \"%s\"", symname(s), curchar);
    } else if (i >= NTYPES) {
	panic("too many types in file \"%s\"", curfilename());
    }
    if (typetable[i] != nil) {
	typetable[i]->language = curlang;
	typetable[i]->class = TYPE;
	typetable[i]->type = s;
    } else {
	typetable[i] = s;
    }
    skipchar(curchar, '=');
    getType(s);
}

/*
 * Setup a symbol entry for a public procedure or function.
 */

private publicRoutine (s, class, addr)
Symbol s;
Symclass class;
Address addr;
{
    enterRoutine(s, class);
    s->level = program->level;
}

/*
 * Setup a symbol entry for a private procedure or function.
 */

private privateRoutine (s, n, class, addr)
Symbol *s;
Name n;
Symclass class;
Address addr;
{
    Symbol t;
    boolean isnew;

    find(t, n) where
	t->level == curmodule->level and t->class == class
    endfind(t);
    if (t == nil) {
	isnew = true;
	t = insert(n);
    } else {
	isnew = false;
    }
    t->language = curlang;
    enterRoutine(t, class);
    if (isnew) {
	t->symvalue.funcv.src = false;
	t->symvalue.funcv.inline = false;
	t->symvalue.funcv.beginaddr = addr;
	newfunc(t, codeloc(t));
	findbeginning(t);
    }
    *s = t;
}

/*
 * Set up for beginning a new procedure, function, or module.
 * If it's a function, then read the type.
 *
 * If the next character is a ",", then read the name of the enclosing block.
 * Otherwise assume the previous function, if any, is over, and the current
 * routine is at the same level.
 */

private enterRoutine (s, class)
Symbol s;
Symclass class;
{
    s->class = class;
    if (class == FUNC) {
	getType(s);
    }
    if (s->class != MODULE) {
	getExtRef(s);
    } else if (*curchar == ',') {
	++curchar;
    }
    if (*curchar != '\0') {
	exitblock();
	enterNestedBlock(s);
    } else {
	if (curblock->class == FUNC or curblock->class == PROC) {
	    exitblock();
	}
	if (class == MODULE) {
	    exitblock();
	}
	enterblock(s);
    }
    curparam = s;
}

/*
 * Check to see if the stab string contains the name of the external
 * reference.  If so, we create a symbol with that name and class EXTREF, and
 * connect it to the given symbol.  This link is created so that when
 * we see the linker symbol we can resolve it to the given symbol.
 */

private getExtRef (s)
Symbol s;
{
    char *p;
    Name n;
    Symbol t;

    if (*curchar == ',' and *(curchar + 1) != '\0') {
	p = index(curchar + 1, ',');
	*curchar = '\0';
	if (p != nil) {
	    *p = '\0';
	    n = identname(curchar + 1, false);
	    curchar = p + 1;
	} else {
	    n = identname(curchar + 1, true);
	}
	t = insert(n);
	t->language = s->language;
	t->class = EXTREF;
	t->block = program;
	t->level = program->level;
	t->symvalue.extref = s;
    }
}

/*
 * Find a block with the given identifier in the given outer block.
 * If not there, then create it.
 */

private Symbol findBlock (id, m)
String id;
Symbol m;
{
    Name n;
    Symbol s;

    n = identname(id, true);
    find(s, n) where s->block == m and isblock(s) endfind(s);
    if (s == nil) {
	s = insert(n);
	s->block = m;
	s->language = curlang;
	s->class = MODULE;
	s->level = m->level + 1;
    }
    return s;
}

/*
 * Enter a nested block.
 * The block within which it is nested is described
 * by "module{:module}[:proc]".
 */

private enterNestedBlock (b)
Symbol b;
{
    register char *p, *q;
    Symbol m, s;
    Name n;

    q = curchar;
    p = index(q, ':');
    m = program;
    while (p != nil) {
	*p = '\0';
	m = findBlock(q, m);
	q = p + 1;
	p = index(q, ':');
    }
    if (*q != '\0') {
	m = findBlock(q, m);
    }
    b->level = m->level + 1;
    b->block = m;
    pushBlock(b);
}

/*
 * Enter a statically-allocated variable defined within a routine.
 *
 * Global BSS variables are chained together so we can resolve them
 * when the start of common is determined.  The list is kept in order
 * so that f77 can display all vars in a COMMON.
 */

private ownVariable (s, addr)
Symbol s;
Address addr;
{
    s->level = 1;
    if (curcomm) {
	if (commchain != nil) {
	    commchain->symvalue.common.chain = s;
	} else {
	    curcomm->symvalue.common.offset = (integer) s;
	}			  
	commchain = s;
	s->symvalue.common.offset = addr;
	s->symvalue.common.chain = nil;
    }
}

/*
 * Get a type from the current stab string for the given symbol.
 */

private getType (s)
Symbol s;
{
    s->type = constype(nil);
    if (s->class == TAG) {
	addtag(s);
    }
}

/*
 * Construct a type out of a string encoding.
 *
 * The forms of the string are
 *
 *	<number>
 *	<number>=<type>
 *	r<type>;<number>;<number>		-- subrange
 *	a<type>;<type>				-- array[index] of element
 *      A<type>					-- open array
 *	s<size>{<name>:<type>;<number>;<number>}-- record
 *	u<size>{<name>:<type>;<number>;<number>}-- union
 *	*<type>					-- pointer
 *	f<type>,<integer>;<paramlist>		-- function variable
 *	p<integer>;<paramlist>			-- procedure variable
 *	S<type>					-- set of type
 *	o<name>[,<type>]			-- opaque type
 *	i<name>,<type>				-- imported type
 */

private Rangetype getRangeBoundType();

private Symbol constype (type)
Symbol type;
{
    register Symbol t;
    register integer n;
    char class;

    if (isdigit(*curchar)) {
	n = getint();
	if (n >= NTYPES) {
	    panic("too many types in file \"%s\"", curfilename());
	}
	if (*curchar == '=') {
	    if (typetable[n] != nil) {
		t = typetable[n];
	    } else {
		t = symbol_alloc();
		typetable[n] = t;
	    }
	    ++curchar;
	    constype(t);
	} else {
	    t = typetable[n];
	    if (t == nil) {
		t = symbol_alloc();
		typetable[n] = t;
	    }
	}
    } else {
	if (type == nil) {
	    t = symbol_alloc();
	} else {
	    t = type;
	}
	t->language = curlang;
	t->level = curblock->level + 1;
	t->block = curblock;
	class = *curchar++;
	switch (class) {
	    case T_SUBRANGE:
		consSubrange(t);
		break;

	    case T_ARRAY:
		t->class = ARRAY;
		t->chain = constype(nil);
		skipchar(curchar, ';');
		chkcont(curchar);
		t->type = constype(nil);
		break;

	    case T_OPENARRAY:
		t->class = ARRAY;
		t->chain = t_open;
		t->type = constype(nil);
		break;

	    case T_RECORD:
		consRecord(t, RECORD);
		break;

	    case T_UNION:
		consRecord(t, VARNT);
		break;

	    case T_ENUM:
		consEnum(t);
		break;

	    case T_PTR:
		t->class = PTR;
		t->type = constype(nil);
		break;

	    /*
	     * C function variables are different from Modula-2's.
	     */
	    case T_FUNCVAR:
		t->class = FFUNC;
		t->type = constype(nil);
		if (not streq(language_name(curlang), "c")) {
		    skipchar(curchar, ',');
		    consParamlist(t);
		}
		break;

	    case T_PROCVAR:
		t->class = FPROC;
		consParamlist(t);
		break;

	    case T_IMPORTED:
		consImpType(t);
		break;

	    case T_SET:
		t->class = SET;
		t->type = constype(nil);
		break;

	    case T_OPAQUE:
		consOpaqType(t);
		break;

	    default:
		badcaseval(class);
	}
    }
    return t;
}

/*
 * Construct a subrange type.
 */

private consSubrange (t)
Symbol t;
{
    t->class = RANGE;
    t->type = constype(nil);
    skipchar(curchar, ';');
    chkcont(curchar);
    t->symvalue.rangev.lowertype = getRangeBoundType();
    t->symvalue.rangev.lower = getint();
    skipchar(curchar, ';');
    chkcont(curchar);
    t->symvalue.rangev.uppertype = getRangeBoundType();
    t->symvalue.rangev.upper = getint();
}

/*
 * Figure out the bound type of a range.
 *
 * Some letters indicate a dynamic bound, ie what follows
 * is the offset from the fp which contains the bound; this will
 * need a different encoding when pc a['A'..'Z'] is
 * added; J is a special flag to handle fortran a(*) bounds
 */

private Rangetype getRangeBoundType ()
{
    Rangetype r;

    switch (*curchar) {
	case 'A':
	    r = R_ARG;
	    curchar++;
	    break;

	case 'T':
	    r = R_TEMP;
	    curchar++;
	    break;

	case 'J': 
	    r = R_ADJUST;
	    curchar++;
	    break;

	default:
	    r = R_CONST;
	    break;
    }
    return r;
}

/*
 * Construct a record or union type.
 */

private consRecord (t, class)
Symbol t;
Symclass class;
{
    register Symbol u;
    register char *cur, *p;
    Name name;
    integer d;

    t->class = class;
    t->symvalue.offset = getint();
    d = curblock->level + 1;
    u = t;
    cur = curchar;
    while (*cur != ';' and *cur != '\0') {
	p = index(cur, ':');
	if (p == nil) {
	    panic("index(\"%s\", ':') failed", curchar);
	}
	*p = '\0';
	name = identname(cur, true);
	u->chain = newSymbol(name, d, FIELD, nil, nil);
	cur = p + 1;
	u = u->chain;
	u->language = curlang;
	curchar = cur;
	u->type = constype(nil);
	skipchar(curchar, ',');
	u->symvalue.field.offset = getint();
	skipchar(curchar, ',');
	u->symvalue.field.length = getint();
	skipchar(curchar, ';');
	chkcont(curchar);
	cur = curchar;
    }
    if (*cur == ';') {
	++cur;
    }
    curchar = cur;
}

/*
 * Construct an enumeration type.
 */

private consEnum (t)
Symbol t;
{
    register Symbol u;
    register char *p;
    register integer count;

    t->class = SCAL;
    count = 0;
    u = t;
    while (*curchar != ';' and *curchar != '\0') {
	p = index(curchar, ':');
	assert(p != nil);
	*p = '\0';
	u->chain = insert(identname(curchar, true));
	curchar = p + 1;
	u = u->chain;
	u->language = curlang;
	u->class = CONST;
	u->level = curblock->level + 1;
	u->block = curblock;
	u->type = t;
	u->symvalue.iconval = getint();
	++count;
	skipchar(curchar, ',');
	chkcont(curchar);
    }
    if (*curchar == ';') {
	++curchar;
    }
    t->symvalue.iconval = count;
}

/*
 * Construct a parameter list for a function or procedure variable.
 */

private consParamlist (t)
Symbol t;
{
    Symbol p;
    integer i, d, n, paramclass;

    n = getint();
    skipchar(curchar, ';');
    p = t;
    d = curblock->level + 1;
    for (i = 0; i < n; i++) {
	p->chain = newSymbol(nil, d, VAR, nil, nil);
	p = p->chain;
	p->type = constype(nil);
	skipchar(curchar, ',');
	paramclass = getint();
	if (paramclass == 0) {
	    p->class = REF;
	}
	skipchar(curchar, ';');
	chkcont(curchar);
    }
}

/*
 * Construct an imported type.
 * Add it to a list of symbols to get fixed up.
 */

private consImpType (t)
Symbol t;
{
    register char *p;
    Symbol tmp;

    p = curchar;
    while (*p != ',' and *p != ';' and *p != '\0') {
	++p;
    }
    if (*p == '\0') {
	panic("bad import symbol entry '%s'", curchar);
    }
    t->class = TYPEREF;
    t->symvalue.typeref = curchar;
    curchar = p + 1;
    if (*p == ',') {
	curchar = p + 1;
	tmp = constype(nil);
    }
    skipchar(curchar, ';');
    *p = '\0';
}

/*
 * Construct an opaque type entry.
 */

private consOpaqType (t)
Symbol t;
{
    register char *p;
    register Symbol s;
    register Name n;
    boolean def;

    p = curchar;
    while (*p != ';' and *p != ',') {
	if (*p == '\0') {
	    panic("bad opaque symbol entry '%s'", curchar);
	}
	++p;
    }
    def = (Boolean) (*p == ',');
    *p = '\0';
    n = identname(curchar, true);
    find(s, n) where s->class == TYPEREF endfind(s);
    if (s == nil) {
	s = insert(n);
	s->class = TYPEREF;
	s->type = nil;
    }
    curchar = p + 1;
    if (def) {
	s->type = constype(nil);
	skipchar(curchar, ';');
    }
    t->class = TYPE;
    t->type = s;
}

/*
 * Read an integer from the current position in the type string.
 */

private integer getint ()
{
    register integer n;
    register char *p;
    register Boolean isneg;

    n = 0;
    p = curchar;
    if (*p == '-') {
	isneg = true;
	++p;
    } else {
	isneg = false;
    }
    while (isdigit(*p)) {
	n = 10*n + (*p - '0');
	++p;
    }
    curchar = p;
    return isneg ? (-n) : n;
}

/*
 * Add a tag name.  This is a kludge to be able to refer
 * to tags that have the same name as some other symbol
 * in the same block.
 */

private addtag (s)
register Symbol s;
{
    register Symbol t;
    char buf[100];

    sprintf(buf, "$$%.90s", ident(s->name));
    t = insert(identname(buf, false));
    t->language = s->language;
    t->class = TAG;
    t->type = s->type;
    t->block = s->block;
}
\.
wq
'endex'

echo symbols.c
ex - symbols.c <<'endex'
1200,1205c
    len = p - str;
    if (len == 1) {
	s = t_char;
    } else {
	s = newSymbol(nil, 0, ARRAY, t_char, nil);
	s->language = primlang;
	s->chain = newSymbol(nil, 0, RANGE, t_int, nil);
	s->chain->language = s->language;
	s->chain->symvalue.rangev.lower = 1;
	s->chain->symvalue.rangev.upper = len + 1;
    }
\.
1187a
    integer len;
\.
1179,1180c
 * Construct a node for the type of a string.
\.
1134,1139c
    } else {
	return ((*language_op(t->language, L_EVALAREF)) (s, i));
    }
\.
1131,1132c
    t = rtype(s);
    if (t->language == nil) {
\.
1129c
    Symbol t;
\.
1113,1118c
    } else {
	return (Node) (*language_op(t->language, L_BUILDAREF))(a, slist);
    }
\.
1110,1111c
    t = rtype(a->nodetype);
    if (t->language == nil) {
\.
1108c
    Symbol t;
\.
1043,1044c
    *tp = tree;
\.
1040c
    } else if (op != O_NOP and s != t) {
\.
1037,1038c
	fprintf(stderr, "expected integer or real, found \"");
	prtree(stderr, tree);
	fprintf(stderr, "\"");
\.
1035c
    } else if (not compatible(s, t)) {
\.
1032,1033c
    t = rtype(typeto);
    if (compatible(t, t_real) and compatible(s, t_int)) {
\.
1029,1030c
    tree = *tp;
\.
1027c
    Node tree;
    Symbol s, t;
\.
981a
 * Process a binary arithmetic or relational operator.
 * Convert from integer to real if necessary.
 */

private binaryop (p, t)
Node p;
Symbol t;
{
    Node p1, p2;
    Boolean t1real, t2real;
    Symbol t1, t2;

    p1 = p->value.arg[0];
    p2 = p->value.arg[1];
    t1 = rtype(p1->nodetype);
    t2 = rtype(p2->nodetype);
    t1real = compatible(t1, t_real);
    t2real = compatible(t2, t_real);
    if (t1real or t2real) {
	p->op = (Operator) (ord(p->op) + 1);
	if (not t1real) {
	    p->value.arg[0] = build(O_ITOF, p1);
	} else if (not t2real) {
	    p->value.arg[1] = build(O_ITOF, p2);
	}
	p->nodetype = t_real;
    } else {
	if (size(p1->nodetype) > sizeof(integer)) {
	    beginerrmsg();
	    fprintf(stderr, "operation not defined on \"");
	    prtree(stderr, p1);
	    fprintf(stderr, "\"");
	    enderrmsg();
	} else if (size(p2->nodetype) > sizeof(integer)) {
	    beginerrmsg();
	    fprintf(stderr, "operation not defined on \"");
	    prtree(stderr, p2);
	    fprintf(stderr, "\"");
	    enderrmsg();
	}
	p->nodetype = t_int;
    }
    if (t != nil) {
	p->nodetype = t;
    }
}

/*
\.
949d
916,947c
	    binaryop(p, t_boolean);
\.
909a
	    binaryop(p, nil);
	    break;

\.
898c
		    fprintf(stderr, "\" is improper type");
\.
896a
		    fprintf(stderr, "\"");
\.
878a
	/*
	 * Perform a cast if the call is of the form "type(expr)".
	 */
\.
779a
 * Determine if a (value) parameter should actually be passed by address.
 */

public boolean passaddr (p, exprtype)
Symbol p, exprtype;
{
    boolean b;
    Language def;

    if (p == nil) {
	def = findlanguage(".c");
	b = (boolean) (*language_op(def, L_PASSADDR))(p, exprtype);
    } else if (p->language == nil or p->language == primlang) {
	b = false;
    } else if (isopenarray(p->type)) {
	b = true;
    } else {
	b = (boolean) (*language_op(p->language, L_PASSADDR))(p, exprtype);
    }
    return b;
}

/*
\.
774c
	t->class == TYPE and streq(ident(t->name), name)
\.
755c
	b = (boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2);
\.
751,753c
	b = (boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2);
    } else if (isbuiltin(t1) or isbuiltin(t1->type)) {
	b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2);
\.
748,749c
	if (t2->language == nil) {
	    b = false;
	} else {
	    b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2);
	}
\.
746a
    } else if (t1->language == primlang) {
	if (t2->language == primlang) {
	    rt1 = rtype(t1);
	    rt2 = rtype(t2);
	    b = (boolean) (
		(rt1->type == t_open and rt2->type == t_int) or
		(rt2->type == t_open and rt1->type == t_int) or
		rt1 == rt2
	    );
	} else {
	    b = (boolean) (*language_op(t2->language, L_TYPEMATCH))(t1, t2);
	}
    } else if (t2->language == primlang) {
	b = (boolean) (*language_op(t1->language, L_TYPEMATCH))(t1, t2);
\.
737a
    Symbol rt1, rt2;
\.
727a
 * Mark a procedure or function as internal, meaning that it is called
 * with a different calling sequence.
 */

public markInternal (s)
Symbol s;
{
    s->symvalue.funcv.intern = true;
}

public boolean isinternal (s)
Symbol s;
{
    return s->symvalue.funcv.intern;
}

/*
\.
671a
public Boolean isopenarray (t)
Symbol t;
{
    return (Boolean) (t->class == ARRAY and t->chain == t_open);
}

/*
 * Test if a symbol is a var parameter, i.e. has class REF but
 * is not an open array parameter (those are treated special).
 */

\.
669c
 * Test if a type is an open array parameter type.
\.
646c
	    r = 0;
	    break;
\.
644c
		fprintf(stderr, "!! size(%s) ??", classname(t));
\.
639a
	case SET:
	    u = rtype(t->type);
	    switch (u->class) {
		case RANGE:
		    r = u->symvalue.rangev.upper - u->symvalue.rangev.lower + 1;
		    break;

		case SCAL:
		    r = u->symvalue.iconval;
		    break;

		default:
		    error("expected range for set base type");
		    break;
	    }
	    r = (r + BITSPERBYTE - 1) div BITSPERBYTE;
	    break;

\.
599c
	    off = t->symvalue.field.offset;
	    len = t->symvalue.field.length;
	    r = (off + len + 7) div 8 - (off div 8);
	    /* r = (t->symvalue.field.length + 7) div 8; */
\.
573a
	    chkOpenArray(t);
\.
548,565c
		u = rtype(t);
		findbounds(u, &lower, &upper);
\.
528a
	    } else if (lower > upper) {
		/* unsigned long */
		r = sizeof(long);
\.
527c
	    if (upper == 0 and lower > 0) {
		/* real */
\.
522a
    if (t->class == TYPEREF) {
	resolveRef(t);
    }
\.
519c
    integer r, off, len;
\.
516,517c
    Symbol t;
    Address a;
    integer n;

    if (sym->class == REF or sym->class == VAR) {
	t = rtype(sym->type);
	if (t->class == ARRAY and t->chain == t_open) {
	    a = address(sym, nil);
	    dread(&n, a + sizeof(Word), sizeof(n));
	    t->chain->type->symvalue.rangev.upper = n - 1;
	}
    }
}

public findbounds (u, lower, upper)
Symbol u;
long *lower, *upper;
{
    Rangetype lbt, ubt;
    long lb, ub;

    if (u->class == RANGE) {
	lbt = u->symvalue.rangev.lowertype;
	ubt = u->symvalue.rangev.uppertype;
	lb = u->symvalue.rangev.lower;
	ub = u->symvalue.rangev.upper;
	if (lbt == R_ARG or lbt == R_TEMP) {
	    if (not getbound(u, lb, lbt, lower)) {
		error("dynamic bounds not currently available");
	    }
	} else {
	    *lower = lb;
	}
	if (ubt == R_ARG or ubt == R_TEMP) {
	    if (not getbound(u, ub, ubt, upper)) {
		error("dynamic bounds not currently available");
	    }
	} else {
	    *upper = ub;
	}
    } else if (u->class == SCAL) {
	*lower = 0;
	*upper = u->symvalue.iconval - 1;
    } else {
	panic("unexpected array bound type");
    }
}

public integer size(sym)
Symbol sym;
{
    register Symbol s, t, u;
    register integer nel, elsize;
\.
513c
/*
 * When necessary, compute the upper bound for an open array (Modula-2 style).
 */

public chkOpenArray (sym)
\.
488,489c
	t != prev and t->block->class == MODULE and t->class == prev->class and
	t->type != nil and t->type->type != nil and
	t->type->type->class != BADUSE
\.
453c
    t->language = primlang;
\.
395,397c
#define isglobal(s)		(s->level == 1)
#define islocaloff(s)		(s->level >= 2 and s->symvalue.offset < 0)
#define isparamoff(s)		(s->level >= 2 and s->symvalue.offset >= 0)
\.
369a
/*
 * Find the end of a module name.  Return nil if there is none
 * in the given string.
 */

private String findModuleMark (s)
String s;
{
    register char *p, *r;
    register boolean done;

    p = s;
    done = false;
    do {
	if (*p == ':') {
	    done = true;
	    r = p;
	} else if (*p == '\0') {
	    done = true;
	    r = nil;
	} else {
	    ++p;
	}
    } while (not done);
    return r;
}

/*
 * Resolve a type reference by modifying to be the appropriate type.
 *
 * If the reference has a name, then it refers to an opaque type and
 * the actual type is directly accessible.  Otherwise, we must use
 * the type reference string, which is of the form "module:{module:}name".
 */

public resolveRef (t)
Symbol t;
{
    register char *p;
    char *start;
    Symbol s, m, outer;
    Name n;

    if (t->name != nil) {
	s = t;
    } else {
	start = t->symvalue.typeref;
	outer = program;
	p = findModuleMark(start);
	while (p != nil) {
	    *p = '\0';
	    n = identname(start, true);
	    find(m, n) where m->block == outer endfind(m);
	    if (m == nil) {
		p = nil;
		outer = nil;
		s = nil;
	    } else {
		outer = m;
		start = p + 1;
		p = findModuleMark(start);
	    }
	}
	if (outer != nil) {
	    n = identname(start, true);
	    find(s, n) where s->block == outer endfind(s);
	}
    }
    if (s != nil and s->type != nil) {
	t->name = s->type->name;
	t->class = s->type->class;
	t->type = s->type->type;
	t->chain = s->type->chain;
	t->symvalue = s->type->symvalue;
	t->block = s->type->block;
    }
}

\.
364a
	    if (t->class == TYPEREF) {
		resolveRef(t);
	    }
\.
362a
	if (t->class == TYPEREF) {
	    resolveRef(t);
	}
\.
320a
    s->type->language = s->language;
\.
319c
    s->language = primlang;
\.
294,306d
263a
 * Delete a symbol from the symbol table.
 */

public delete (s)
Symbol s;
{
    register Symbol t;
    register unsigned int h;

    h = hash(s->name);
    t = hashtab[h];
    if (t == nil) {
	panic("delete of non-symbol '%s'", symname(s));
    } else if (t == s) {
	hashtab[h] = s->next_sym;
    } else {
	while (t->next_sym != s) {
	    t = t->next_sym;
	    if (t == nil) {
		panic("delete of non-symbol '%s'", symname(s));
	    }
	}
	t->next_sym = s->next_sym;
    }
}

/*
\.
186d
173,180c
	printf(" symbols in %s \n",symname(func));
	for(i=0; i< HASHTABLESIZE; i++)
	   for(s=hashtab[i]; s != nil; s=s->next_sym)  {
		if (s->block == func) psym(s);
		}
\.
170,171c
  register Symbol s;
  register Integer i;
\.
102a
#define isroutine(s) (Boolean) ( \
    s->class == FUNC or s->class == PROC \
)
\.
92a
Symbol t_open;
\.
78a
	String typeref;		/* type defined by "<module>:<type>" */
	Symbol extref;		/* indirect symbol for external reference */
\.
70,71c
	    Boolean src : 1;	/* true if there is source line info */
	    Boolean inline : 1;	/* true if no separate act. rec. */
	    Boolean intern : 1; /* internal calling sequence */
	    int unused : 13;
\.
38c
    FPROC, FFUNC, MODULE, TAG, COMMON, EXTREF, TYPEREF
\.
4a
static char rcsid[] = "$Header: symbols.c,v 1.4 84/03/27 10:24:18 linton Exp $";

\.
3c
static char sccsid[] = "@(#)symbols.c 1.10 8/10/83";
\.
wq
'endex'

echo cerror.s
ex - cerror.s <<'endex'
4a
# static char rcsid[] = "$Header: cerror.s,v 1.3 84/03/27 10:19:51 linton Exp $";
#
\.
wq
'endex'

echo defs.h
ex - defs.h <<'endex'
46a
typedef Boolean boolean;
\.
45a
typedef double real;
\.
43a
typedef int integer;
\.
1,2d
wq
'endex'