#! /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'
