page@swan.ulowell.edu (Bob Page) (03/08/89)
Submitted-by: monty@brahms.Berkeley.EDU (Joe Montgomery)
Posting-number: Volume 89, Issue 31
Archive-name: languages/zc.4
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
#----cut here-----cut here-----cut here-----cut here----#
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# out.c
# p2.c
# pre.c
# subs.c
# tok.c
# This archive created: Tue Mar 7 21:51:34 1989
cat << \SHAR_EOF > out.c
/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
*
* Permission is granted to anyone to use this software for any purpose
* on any computer system, and to redistribute it freely, with the
* following restrictions:
* 1) No charge may be made other than reasonable charges for reproduction.
* 2) Modified versions must be clearly marked as such.
* 3) The authors are not responsible for any harmful consequences
* of using this software, even if they result from defects in it.
*
* out.c
*
* Revised: Dec 1988 Joe Montgomery
*
* Revised out.c to use MOTOROLA assembly directives in order
* to be compatible with C.Gibbs a68k assembler & blink
* Added END statement
* Changed .comm label,size to label DC.x 0
*
* other modules:
* Revised main.c to use Amiga File System Naming Conventions
* Added ?,C,F switches. ? help
* C force data,bss into Chip memory
* F force data,bss into Fast memory
* Revised d2.c so that externs are declared as XREF -----
*
* Revised g2.c & gen.c to declare all called functions XREF
* (will need to change this to declare only external functions)
*
* All changes labeled JMM
*
* Code generation output routines.
*/
#include <stdio.h>
#include "param.h"
#include "nodes.h"
#include "flags.h"
#include "bstok.h"
#include "tytok.h"
#include "gen.h"
#ifdef dLibs
#include <ctype.h>
#endif
#if MMCC
overlay "pass2"
#endif
#if CC68
FILE *fopen();
#endif
#if NEEDBUF
char my_obuf[BUFSIZ];
#endif
#define T_SEG 0
#define D_SEG 1
#define B_SEG 2
#define TO_TEXT to_seg(T_SEG)
#define TO_DATA to_seg(D_SEG)
#define TO_BSS to_seg(B_SEG)
#define isareg(np) ((np)->g_token == REGVAR && (np)->g_rno >= AREG)
extern FILE *output;
/*JMM added -O switch to allow user to specify output file */
char *outfilename,*errorfile;
extern int nmerrors;
static int in_seg;
static int lblnum;
static int dat_size;
/* called to open output file. We've only just begun */
out_start(s)
char *s;
{
char *scopy(), *outs;
register int len;
/* JMM added -O switch to allow user to specify output file */
if(outfilename) outs = scopy(outfilename);
else outs = scopy(s);
len = strlen(outs);
/* JMM add -O switch */
if(outfilename){
output = fopen(outs,"w");
if(output == NULL )
fatals("Cant open",outs);
} else if ( len >= 2 && outs[len-2] == '.' &&
tolower(outs[len-1]) == 'c' ) {
outs[len-1] = 's';
output = fopen(outs, "w");
if (output == NULL)
fatals("Cant open", outs);
#if NEEDBUF
setbuf(output, my_obuf);
#endif
} else
output = stdout;
sfree(outs);
in_seg = -1;
lblnum = 0;
dat_size = 0;
}
/* closes output file. All done */
static char seterrorbuf[50];
out_end()
{
char *outs;
extern char *scopy();
FILE *err;
fprintf(output, "\tEND \n");
if (output != stdout)
fclose(output);
if( ( errorfile != NULL) ){
outs = scopy((char *) errorfile );
err = fopen(outs,"w");
if(err == NULL )
fatals("Cant open",outs);
fprintf(err,"%d",nmerrors);
close(err);
sfree(outs);
}
}
/* Assembler segment Directives */
static char *sg_go[] = {
"CODE CODE", /* .text segment ?same as code segment? */
"DATA DATA", /* .data segment */
"BSS BSS" /* .bss segment */
};
/* JMM added ability to force Data,BSS into either Chip or Fast */
short usefastmemory,usechipmemory;
static char *chipsg_go[] = {
"CODE CODE", /* .text segment ?same as code segment? */
"DATA CHIPDATA CHIP", /* .data segment */
"BSS CHIPBSS CHIP" /* .bss segment */
};
static char *fastsg_go[] = {
"CODE CODE", /* .text segment ?same as code segment? */
"DATA FASTDATA FAST", /* .data segment */
"BSS FASTBSS FAST" /* .bss segment */
};
/* extern directive, global directive */
char externdir[]="\tXREF \t";
char globaldir[]="\tXDEF \t";
char externfuncdir[]="\tXREF \t";
to_text()
{
TO_TEXT; /* to_seg(0) *//* fprintf(output," .text ") */
}
to_seg(sg)
{
char *segment;
/* JMM modified to_seg to force data,bss into either CHIP or FAST */
if (sg == in_seg)
return;
if(usechipmemory)segment =(char *) chipsg_go[sg];
else if(usefastmemory) segment = (char *)fastsg_go[sg];
else segment =(char *) sg_go[sg];
fprintf(output, "\t%s\n", segment);
in_seg = sg;
}
/* JMM ? output a long ? */
o_aln(x)
{
if (x && (dat_size & 1)) {
dat_size++;
TO_DATA; /* data segment */
fprintf(output, "\tCNOP 0,2\n");/* was .even */
}
}
char *rnms[] = {
"d0", "d1", "d2", "d3", "d4", "d5", "d6", "d7",
"a0", "a1", "a2", "a3", "a4", "a5", "a6", "sp",
};
/* return string containing register name */
char *regnm(n)
{
return rnms[n];
}
/* define constant of length n */
char *
init_str(n)
int n;
{
char *s;
switch (n) {
case 1:
s = "DC.B"; break;
case 2:
s = "DC.W"; break;
default:
s = "DC.L"; break;
}
return s;
}
tlen(n)
{
switch (n) {
case 1:
return 'b';
case 2:
return 'w';
default:
return 'l';
}
}
/* JMM ? output init node pointer *
* output predefined values for variable ? */
o_vinit(tp, xp)
NODEP tp, xp; /* Node pointers */
{
/* .dc.b t_size 1
* .dc.w 2
* .dc.l 3 or greater
*/
fprintf(output, "\t%s\t", init_str((int)tp->t_size));
dat_size += tp->t_size;
p2_expr(&xp);
asn_chk(tp, xp);
to_init(xp, tp);
fputc('\n', output);
}
to_init(np, typ)
NODEP np, typ;
{
NODEP tp;
tp = allocnode();
tp->e_token = TCONV;
tp->n_tptr = typ;
tp->n_flags |= N_COPYT;
tp->n_left = np;
tp->e_type = E_UNARY;
strcpy(tp->n_name, "i cast");
genx(tp, FORINIT);
}
/* output move.x #(a6),rn where x=b,w,l , rn=a0-a7 or d0-d7*/
out_argreg(np)
NODEP np;
{
fprintf(output, "\tmove.%c\t%d(a6),%s\n",
tlen((int)np->n_tptr->t_size), (int)np->e_offs,
regnm(np->e_rno));
}
extern int pflag;
/* JMM ? output label ? makes function labels etc */
out_fstart(np)
NODEP np;
{
TO_TEXT; /* code segment */
if (np->e_sc != K_STATIC) {
/* JMM changed to output XDEF name */
fprintf(output, globaldir);
und_nnm(np); /* output _XXXXX where XXXXX is name of variable */
fputc('\n', output);
}
und_nnm(np);
fprintf(output, ":\n");
if (pflag) {
int tlab = new_lbl();
TO_BSS;
fprintf(output, "L%d:\tDS.L\t1\n", tlab);
TO_TEXT;
fprintf(output, "\tmove.l\t#");
und_nnm(np);
fprintf(output, ",a0\n");
fprintf(output, "\tmove.l\t#L%d,a1\n", tlab);
fprintf(output,"\tXREF \tmcount\n");
fprintf(output,"; Calling profiler \n");
fprintf(output, "\tjsr\tmcount\n");
}
}
static char rbuf[30];
char *
regstr(regs)
{
int lod, hid, loa, hia;
register i;
char *bp = rbuf;
lod = 999;
hid = -1;
for (i=DRV_START; i<=DRV_END; i++)
if (regs & (1<<i)) {
if (i < lod) lod = i;
if (i > hid) hid = i;
}
loa = 999;
hia = -1;
for (i=ARV_START; i<=ARV_END; i++)
if (regs & (1<<i)) {
if (i < loa) loa = i;
if (i > hia) hia = i;
}
if (lod < 999) {
if (lod != hid)
sprintf(bp, "d%d-d%d", lod, hid);
else
sprintf(bp, "d%d", lod);
if (loa < 999) {
bp += strlen(rbuf);
*bp++ = '/';
}
}
if (loa < 999) {
if (loa != hia)
sprintf(bp, "a%d-a%d", loa-AREG, hia-AREG);
else
sprintf(bp, "a%d", loa-AREG);
}
return rbuf;
}
out_fend(regs, lsize)
long lsize;
{
if (lsize < 0x7fff)
fprintf(output, "\tlink\ta6,#-%d\n", (int)lsize);
else
fprintf(output, "\tlink\ta6,#0\n\tsub.l\t#%ld,sp\n",
lsize);
if (regs)
fprintf(output, "\tmovem.l\t%s,-(sp)\n", regstr(regs));
}
out_fret(regs, strl)
{
if (regs)
fprintf(output, "\tmovem.l\t(sp)+,%s\n", regstr(regs));
if (strl)
fprintf(output, "\tmove.l\t#L%d,a0\n", strl);
fprintf(output, "\tunlk\ta6\n\trts\n");
}
out_fs(strl, size)
long size;
{
TO_BSS;
def_lbl(strl);
fprintf(output, "\tDS.W \t%ld\n", size/2);
}
/* ? output global variables ? */
out_gv(np, isbss)
register NODEP np;
{
long sz;
char c;
if (np->e_sc == K_STATIC) {
np->e_offs = lblnum++;
}
/* JMM ? added part to print out XREF statement for a68k ? */
if (np->e_sc == K_EXTERN) {
to_seg(isbss ? B_SEG : D_SEG);
/*if (np->e_sc != K_STATIC) { */
fprintf(output, externdir);
out_nm(np);
fputc('\n', output);
/* } */
}
if (np->e_sc != K_EXTERN) {
to_seg(isbss ? B_SEG : D_SEG);
if (np->e_sc != K_STATIC) {
fprintf(output, globaldir);
out_nm(np);
fputc('\n', output);
}
if (isbss) {
if (np->e_sc == K_STATIC) {
out_nm(np);
sz = np->n_tptr->t_size;
c = 'b';
if (np->n_tptr->t_aln) {
c = 'w';
sz /= 2;
}
fprintf(output, ":\tDS.%c\t%ld\n", c, sz);
} else {
out_nm(np);
sz = np->n_tptr->t_size;
if (sz & 1) sz++; /* ALCYON hack */
fprintf(output, ":\t DS.%c 0 \n", tlen(sz) );
sz -= 4;
while (sz > 0){
fprintf(output,"\t DS.W 0\n");
sz -= 2;
}
/* fprintf(output, "\t.comm\t");
* out_nm(np);
* sz = np->n_tptr->t_size;
* if (sz & 1) sz++; /* ALCYON hack * /
* fprintf(output, ",%ld\n", sz);
*/
}
} else {
out_nm(np);
fprintf(output, ":\n");
}
}
}
new_lbl()
{
return lblnum++;
}
def_lbl(l)
{
fprintf(output, "L%d:\n", l);
}
out_br(l)
{
if (l < 0)
error("bad branch");
else
fprintf(output, "\tbra\tL%d\n", l);
}
static char *bnm[] = {
"",
"beq",
"bne",
"blt",
"bge",
"ble",
"bgt",
"bra",
"nop",
"bcs",
"bcc",
"bls",
"bhi"
};
out_b(key, l)
{
if (key != B_NO)
fprintf(output, "\t%s\tL%d\n", bnm[key], l);
}
out_bnol(key)
{
fprintf(output, "\t%s\t", bnm[key]);
}
out_d0cmp(x)
{
fprintf(output, "\tcmp.w\t#%d,d0\n", x);
}
out_d0sub(x)
{
fprintf(output, "\tsub.w\t#%d,d0\n", x);
}
out_tlbl(l)
{
fprintf(output, "\tDC.L\tL%d\n", l);
}
out_tsw()
{
fprintf(output, "\text.l\td0\n");
fprintf(output, "\tasl.l\t#2,d0\n");
fprintf(output, "\tmove.l\t4(pc,d0.l),a0\n");
fprintf(output, "\tjmp\t(a0)\n");
}
out_nm(np)
NODEP np;
{
if (np->e_sc == K_STATIC)
fprintf(output, "L%d", (int)np->e_offs);
else
und_nnm(np);
}
externfuncref(np)
NODEP np;
{
if ( np->e_sc != K_STATIC){
fprintf(output, externfuncdir);
fput_nnm(np->n_left);
fprintf(output,"\n");
}
}
out_zi(tp)
NODEP tp;
{
char *s;
/*
switch (tp->t_token) {
case K_FLOAT:
fprintf(output, "\t.float\t0.0\n"); return;
case K_DOUBLE:
fprintf(output, "\t.double\t0.0\n"); return;
}
*/
dat_size += tp->t_size;
s = init_str((int)tp->t_size);
fprintf(output, "\t%s\t0\n", s);
}
o_nz(sz, aln)
long sz;
{
dat_size += sz;
if (aln) {
if (sz & 1)
fprintf(output, "\tDS.B\t1\n");
sz >>= 1;
fprintf(output, "\tDS.W\t%ld\n", sz);
} else {
fprintf(output, "\tDS.B\t%ld\n", sz);
}
}
dumpstrs(np)
NODEP np;
{
TO_DATA;
more:
if (np == NULL)
return;
fprintf(output, "L%d:", (int)np->g_offs);
out_scon(np);
np = np->n_next;
goto more;
}
int see_esc;
out_scon(np)
NODEP np;
{
int len = 0;
if (np == NULL)
return 0;
see_esc = 0;
more:
if (np->n_name[0]) {
fprintf(output, "\tDC.B\t");
len += out_str(np->n_name);
putc('\n', output);
}
np = np->n_nmx;
if (np)
goto more;
fprintf(output, "\tDC.B\t0\n");
len++;
dat_size += len;
return len;
}
out_str(s)
char *s;
{
int len;
register c;
len = 0;
for ( ; c = *s; s++) {
if (see_esc) { /* allow null */
c--;
see_esc = 0;
} else if (c == 1) {
see_esc = 1;
continue;
}
if (len)
putc(',', output);
out_1c(c);
len++;
}
return len;
}
out_asm(np)
NODEP np;
{
putc('\t', output);
more:
fprintf(output, "%s", np->n_name); /* no \0 or \1 please! */
np = np->n_nmx;
if (np)
goto more;
putc('\n', output);
}
/* Output underscore name */
und_nnm(np)
NODEP np;
{
fputc('_', output);
fput_nnm(np);
}
out_1c(c)
char c;
{
fprintf(output, "$%x", c & 0xff);
}
outcode(np)
register NODEP np;
{
NODEP tp;
if (np == NULL) return;
switch (np->g_type) {
case EV_NONE:
break;
case EV_RL:
outcode(np->n_right);
outsub(np->g_betw, np);
/* fall through */
case EV_LEFT:
outcode(np->n_left);
break;
case EV_LR:
case EV_LRSEP:
outcode(np->n_left);
outsub(np->g_betw, np);
/* fall through */
case EV_RIGHT:
outcode(np->n_right);
break;
default:
printf("bad eval %d ", np->g_type);
}
if (np->n_flags & N_COPYT) /* g_code is a char * */
outsub(np->g_code, np);
else /* g_code is a list of nodes */
for (tp=np->g_code; tp != NULL; tp = tp->g_code)
outsub(tp->n_name, np);
}
outsub(cp, np)
register char *cp;
register NODEP np;
{
register char c;
if (cp == NULL) return;
while (c = *cp++)
if (c == '<')
out_let(*cp++, np->n_left);
else if (c == '>')
out_let(*cp++, np->n_right);
else if (c == '\'') {
c = *cp++;
fputc(c, output);
} else if (c == 'L')
seelab(*cp++, np);
else if (c == 'R')
seereg(np, *cp++);
else if (c >= 'A' && c <= 'Z') {
out_let(c, np);
} else
fputc(c, output);
}
seereg(np, c)
NODEP np;
{
int i;
switch (c) {
case '0': i = np->g_rno; break;
case '1': i = np->g_r1; break;
case '2': i = np->g_r2; break;
}
fprintf(output, regnm(i));
}
out_let(c, np)
register NODEP np;
{
int i;
switch (c) {
case 'A':
if (np->g_flags & IMMEDID)
fputc('#', output);
out_a(np, output);
break;
case 'F': /* branch if false */
i = cctok(np);
i = (i&1) ? i+1 : i-1; /* reverse truth */
out_bnol(i);
break;
case 'K':
fprintf(output, "%ld", np->g_bsize);
break;
case 'N':
fprintf(output, "%s", np->n_name);
break;
case 'O':
fprintf(output, "%ld", np->g_offs);
break;
case 'Q':
if (np->g_flags & IMMEDID) {
warn("constant test expr");
if (np->g_token == ICON && np->g_offs == 0)
fprintf(output, "\tor\t#$FF,ccr\n");
else
fprintf(output, "\tand\t#0,ccr\n");
return;
}
fprintf(output, "\t%s.%c\t", isareg(np) ? "cmp" : "tst",
tlen(np->g_sz));
if (isareg(np))
fprintf(output, "#0,");
out_let('A', np);
fputc('\n', output);
break;
case 'S':
fputc(tlen(np->g_sz), output);
break;
case 'T': /* branch if true */
out_bnol(cctok(np));
break;
case 'U':
fputc(np->g_ty == ET_U ? 'u' : 's', output);
break;
case 'W': /* field width 1's */
fprintf(output, "$%x", ones(np->g_fldw));
break;
case 'X': /* ~(W << offset) */
fprintf(output, "$%x", ~(ones(np->g_fldw)<<np->g_fldo));
break;
case 'Y': /* field offset */
fprintf(output, "%d", np->g_fldo);
break;
case 'Z': /* field offset - 8 */
fprintf(output, "%d", np->g_fldo - 8);
break;
default:
printf("bad out_let %c ", c);
}
}
out_a(np, fd)
register NODEP np;
FILE *fd;
{
int offs = np->g_offs;
switch (np->g_token) {
case ICON:
fprintf(fd, "%ld", np->g_offs);
break;
case FCON:
/* works for ALCYON C */
/* otherwise depends on floating internal format */
fprintf(fd, "$%lx", np->g_offs);
break;
case ONAME:
while (np->g_flags & (CHILDNM|RCHILDNM)) {
np = (np->g_flags & CHILDNM) ?
np->n_left : np->n_right;
}
qput_nnm(np, fd);
if (offs)
fprintf(fd, offs > 0 ? "+%d" : "%d", offs);
break;
case PUSHER:
fprintf(fd, "(sp)+");
break;
case OREG:
if (offs)
fprintf(fd, "%d", offs);
fprintf(fd, "(%s)", regnm(np->g_rno));
break;
case REGVAR:
fprintf(fd, regnm(np->g_rno));
break;
case ',':
fputc(',', fd); /* for debug */
break;
default:
if (np->g_token >= BR_TOK) {
fprintf(fd, "B_%s", bnm[np->g_token - BR_TOK]);
break;
}
printf("? tok %d ", np->g_token);
}
}
seelab(c, np)
char c;
NODEP np;
{
c -= '1';
fprintf(output, "L%d", (int)np->g_bsize+c);
}
ones(n)
{
return (1 << n) - 1;
}
SHAR_EOF
cat << \SHAR_EOF > p2.c
/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
*
* Permission is granted to anyone to use this software for any purpose
* on any computer system, and to redistribute it freely, with the
* following restrictions:
* 1) No charge may be made other than reasonable charges for reproduction.
* 2) Modified versions must be clearly marked as such.
* 3) The authors are not responsible for any harmful consequences
* of using this software, even if they result from defects in it.
*
* p2.c
*
* Expression tree routines.
*
* Constant folding, typing of nodes, simple transformations.
*/
#include <stdio.h>
#include "param.h"
#include "tok.h"
#include "nodes.h"
#include "cookie.h"
#if MMCC
overlay "pass2"
#endif
extern int xflags[];
#define debug xflags['t'-'a']
extern nmerrors;
NODEP bas_type();
do_expr(np, cookie)
NODE *np;
{
if (np == NULL)
return;
/* include if want only one error at a time
if (nmerrors) {
freenode(np);
return;
}
*/
p2_expr(&np);
genx(np, cookie);
}
p2_expr(npp)
NODEP *npp;
{
NODEP np = *npp;
if (np == NULL) return;
if (debug > 1) {
printf("P2 enter");
printnode(np);
}
confold(npp,0);
np = *npp;
form_types(np);
if (debug) {
printf("p2_expr");
printnode(np);
}
return;
}
form_types(np)
NODEP np;
{
if (np == NULL) return;
switch (np->e_type) {
case E_SPEC:
switch (np->e_token) { /* special cases */
case '.':
case ARROW:
form_types(np->n_left);
sel_type(np);
return;
case '(':
if (np->n_right) {
form_types(np->n_right); /* args */
np->e_type = E_BIN;
} else
np->e_type = E_UNARY;
fun_type(np);
return;
}
/* fall through */
case E_BIN:
form_types(np->n_left);
form_types(np->n_right);
b_types(np);
break;
case E_UNARY:
form_types(np->n_left);
u_types(np);
break;
case E_LEAF:
l_types(np);
break;
}
}
/* (fun) (args) */
fun_type(np)
NODEP np;
{
NODEP lp, typ;
NODEP allsyms(), new_fun();
lp = np->n_left;
if (lp->e_token == ID) { /* may be new ID */
typ = allsyms(lp);
if (typ == NULL)
typ = new_fun(lp);
typ = typ->n_tptr;
lp->n_tptr = typ;
lp->n_flags |= N_COPYT;
} else {
form_types(lp);
typ = lp->n_tptr;
}
if (typ->t_token != '(') { /* fun ret ? */
error("call non-fun");
goto bad;
}
typ = typ->n_tptr;
goto good;
bad:
typ = bas_type(K_INT);
good:
np->n_tptr = typ;
np->n_flags |= N_COPYT;
}
/* (struct|union) (. or ->) ID */
sel_type(xp)
NODEP xp;
{
NODEP np, sup;
int tok;
NODEP rv;
NODEP llook();
np = xp->n_right;
sup = xp->n_left->n_tptr;
tok = xp->e_token;
/* already checked that np->e_token == ID */
if (tok == ARROW) {
if (sup->t_token != STAR) {
error("(non pointer)->");
goto bad;
}
sup = sup->n_tptr;
}
if (sup->t_token != K_STRUCT && sup->t_token != K_UNION) {
error("select non-struct");
goto bad;
}
rv = llook(sup->n_right, np);
if (rv == NULL) {
error("? member ID");
goto bad;
}
xp->e_offs = rv->e_offs;
if (rv->e_fldw) {
xp->e_fldw = rv->e_fldw;
xp->e_fldo = rv->e_fldo;
}
rv = rv->n_tptr;
goto good;
bad:
rv = bas_type(K_INT);
good:
xp->n_tptr = rv;
xp->n_flags |= N_COPYT;
/* change to UNARY op */
xp->e_type = E_UNARY;
freenode(np);
xp->n_right = NULL;
/* change ARY OF to PTR TO */
if (rv->t_token == '[')
see_array(xp);
}
l_types(np)
register NODE *np;
{
NODEP allsyms();
register NODE *tp;
switch (np->e_token) {
case ID: /* already did see_id */
if (np->n_tptr->t_token == '[') /* change to &ID */
see_array(np);
return;
case ICON:
tp = bas_type(icon_ty(np));
break;
case FCON:
tp = bas_type(K_DOUBLE);
break;
case SCON:
tp = bas_type(SCON);
break;
default:
errors("Weird leaf",np->n_name);
bad:
tp = bas_type(K_INT);
}
np->n_tptr = tp;
np->n_flags |= N_COPYT;
}
u_types(np)
NODEP np;
{
NODEP tp;
NODEP lp = np->n_left;
NODEP normalty();
tp = lp->n_tptr; /* default */
switch (np->e_token) {
case DOUBLE '+':
case DOUBLE '-':
case POSTINC:
case POSTDEC:
mustlval(lp);
mustty(lp, R_SCALAR);
if (tp->t_token == STAR)
np->e_offs = tp->n_tptr->t_size;
else
np->e_offs = 1;
break;
case STAR:
if (mustty(lp, R_POINTER)) goto bad;
tp = tp->n_tptr;
np->n_tptr = tp;
np->n_flags |= N_COPYT;
/* Ary of to Ptr to */
if (tp->t_token == '[')
see_array(np);
return;
case UNARY '&':
mustlval(lp);
tp = allocnode();
tp->n_tptr = lp->n_tptr;
tp->n_flags |= N_COPYT;
tp->t_token = STAR;
sprintf(tp->n_name, "Ptr to");
tp->t_size = SIZE_P;
np->n_tptr = tp;
return; /* no COPYT */
case UNARY '-':
mustty(lp, R_ARITH);
tp = normalty(lp, NULL);
break;
case TCONV:
mustty(lp, R_SCALAR);
if (np->n_tptr->t_token != K_VOID)
mustty(np, R_SCALAR);
return; /* type already specified */
case '!':
mustty(lp, R_SCALAR);
tp = bas_type(K_INT);
break;
case '~':
mustty(lp, R_INTEGRAL);
tp = normalty(lp, NULL);
break;
default:
error("bad unary type");
bad:
tp = bas_type(K_INT);
}
np->n_tptr = tp;
np->n_flags |= N_COPYT;
}
b_types(np)
NODEP np;
{
NODEP tp;
NODEP lp, rp;
NODEP normalty(), addty(), colonty();
int op;
op = np->e_token;
if (isassign(op)) {
mustlval(np->n_left);
op -= (ASSIGN 0);
}
lp = np->n_left;
rp = np->n_right;
tp = bas_type(K_INT);
switch (op) {
case '*':
case '/':
mustty(lp, R_ARITH);
mustty(rp, R_ARITH);
tp = normalty(lp,rp);
break;
case '%':
case '&':
case '|':
case '^':
mustty(lp, R_INTEGRAL);
mustty(rp, R_INTEGRAL);
tp = normalty(lp,rp);
break;
case '+':
case '-':
mustty(lp, R_SCALAR);
mustty(rp, R_SCALAR);
tp = addty(np);
break;
case DOUBLE '<':
case DOUBLE '>':
mustty(lp, R_INTEGRAL);
mustty(rp, R_INTEGRAL);
tp = normalty(lp, NULL);
break;
case '<':
case '>':
case LTEQ:
case GTEQ:
case DOUBLE '=':
case NOTEQ:
mustty(lp, R_SCALAR);
mustty(rp, R_SCALAR);
chkcmp(np);
break; /* INT */
case DOUBLE '&':
case DOUBLE '|':
mustty(lp, R_SCALAR);
mustty(rp, R_SCALAR);
break; /* INT */
case '?':
mustty(lp, R_SCALAR);
tp = rp->n_tptr;
break;
case ':':
if (same_type(lp->n_tptr, rp->n_tptr)) {
tp = lp->n_tptr;
break;
}
mustty(lp, R_SCALAR);
mustty(rp, R_SCALAR);
tp = colonty(np);
break;
case '=':
mustlval(lp);
mustty(lp, R_ASSN);
asn_chk(lp->n_tptr, rp);
tp = lp->n_tptr;
break;
case ',':
tp = rp->n_tptr;
break;
default:
error("bad binary type");
bad:
tp = bas_type(K_INT);
}
if (isassign(np->e_token)) {
/* ignore normal result -- result is left type */
tp = lp->n_tptr;
}
np->n_tptr = tp;
np->n_flags |= N_COPYT;
}
long
conlval(np)
NODEP np;
{
long i;
confold(&np,0);
if (np->e_token == ICON) {
i = np->e_ival;
freenode(np);
return i;
}
error("need const expr");
return 0;
}
conxval(np)
NODEP np;
{
return (int)conlval(np);
}
confold(npp,spec)
NODEP *npp;
{
NODEP np;
NODEP tp, onp;
int tok,spl,spr;
long l;
np = *npp;
if (np == NULL) return;
switch (np->e_type) {
case E_LEAF:
lcanon(np,spec);
return;
case E_UNARY:
confold(&np->n_left,0);
ucanon(np);
return;
case E_BIN:
confold(&np->n_left,0);
confold(&np->n_right,0);
if (np->e_token == '?') {
tok = np->n_left->e_token;
if (tok != ICON)
return;
l = np->n_left->e_ival;
onp = np;
tp = np->n_right; /* ':' node */
if (l) { /* take true side */
np = tp->n_left;
tp->n_left = NULL;
} else { /* take false side */
np = tp->n_right;
tp->n_right = NULL;
}
freenode(onp);
*npp = np;
return;
}
bcanon(np);
if (np->e_flags & C_AND_A)
b_assoc(np);
return;
case E_SPEC:
tok = np->e_token;
spl = spr = 0;
switch (tok) {
case '(':
spl = tok; /* new name allowed */
break;
case '.':
case ARROW:
spr = tok; /* look in struct sym.tab. */
break;
}
confold(&np->n_left,spl);
confold(&np->n_right,spr);
return;
}
}
newicon(np,x,nf)
NODE *np;
long x;
{
np->e_token = ICON;
np->e_ival = x;
np->e_flags = nf;
sprintf(np->n_name, "%ld", x);
np->e_type = E_LEAF;
if (np->n_left) {
freenode(np->n_left);
np->n_left = NULL;
}
if (np->n_right) {
freenode(np->n_right);
np->n_right = NULL;
}
}
newfcon(np,x,nf)
NODE *np;
double x;
{
np->e_token = FCON;
np->e_fval = x;
np->e_flags = nf;
sprintf(np->n_name, FLTFORM, x);
np->e_type = E_LEAF;
if (np->n_left) {
freenode(np->n_left);
np->n_left = NULL;
}
if (np->n_right) {
freenode(np->n_right);
np->n_right = NULL;
}
}
/* LEAF */
/* sptok is token if E_SPEC node is parent
and dont want to look at ID yet */
lcanon(np,sptok)
NODE *np;
{
NODE *tp;
NODEP allsyms();
long x;
if (np->e_token == ID) {
if (sptok)
return;
see_id(np);
return;
}
if (np->e_token == TSIZEOF) {
tp = np->n_tptr;
x = tp->t_size;
np->n_tptr = NULL;
if ((np->n_flags & N_COPYT) == 0)
freenode(tp);
newicon(np, x, 0);
}
}
/* UNARY */
ucanon(np)
NODE *np;
{
NODE *tp;
long x,l;
int lflags = 0;
if (np->e_token == K_SIZEOF) {
tp = np->n_left;
confold(&tp,0);
form_types(tp);
tp = tp->n_tptr;
x = tp->t_size;
goto out;
}
if (np->n_left->e_token == FCON) {
if (np->e_token == UNARY '-')
newfcon(np, -(np->n_left->e_fval));
return;
}
if (np->n_left->e_token != ICON)
return;
l = np->n_left->e_ival;
lflags = np->n_left->e_flags;
switch (np->e_token) {
case UNARY '-':
x = -l; break;
case '~':
x = ~l; break;
case '!':
x = !l; break;
default:
return;
}
out:
newicon(np, x, lflags);
}
bcanon(np)
register NODE *np;
{
int ltok, rtok;
double l,r;
NODEP tp;
ltok = np->n_left->e_token;
rtok = np->n_right->e_token;
if (ltok != ICON && ltok != FCON)
return;
if (rtok != ICON && rtok != FCON) {
/* left is ?CON, right is not */
if (np->e_flags & (C_AND_A|C_NOT_A)) {
/* reverse sides - put CON on right */
tp = np->n_left;
np->n_left = np->n_right;
np->n_right = tp;
if (np->e_flags & C_NOT_A)
swt_op(np);
}
return;
}
if (ltok == ICON && rtok == ICON) {
b2i(np);
return;
}
if (ltok == FCON)
l = np->n_left->e_fval;
else
l = (double)np->n_left->e_ival;
if (rtok == FCON)
r = np->n_right->e_fval;
else
r = (double)np->n_right->e_ival;
b2f(np,l,r);
}
/* canon for assoc. & comm. op */
/* this code will almost never be executed, but it was fun. */
b_assoc(np)
NODEP np;
{
NODEP lp, rp;
int tok;
lp = np->n_left;
if (lp->e_token != np->e_token)
return;
/* left is same op as np */
rp = np->n_right;
tok = lp->n_right->e_token;
if (tok != ICON && tok != FCON)
return;
/* left.right is ?CON */
tok = rp->e_token;
if (tok == ICON || tok == FCON) {
/* have 2 CONS l.r and r -- put together on r */
NODEP ep;
ep = lp->n_left;
np->n_left = ep;
np->n_right = lp;
lp->n_left = rp;
/* can now fold 2 CONS */
bcanon(lp);
} else {
/* have 1 CON at l.r -- move to top right */
NODEP kp;
kp = lp->n_right;
lp->n_right = rp;
np->n_right = kp;
}
}
/* switch pseudo-commutative op */
swt_op(np)
NODEP np;
{
int newtok;
switch (np->e_token) {
case LTEQ: newtok = '>'; break;
case GTEQ: newtok = '<'; break;
case '<': newtok = GTEQ; break;
case '>': newtok = LTEQ; break;
default:
return;
}
np->e_token = newtok;
}
/* BINARY 2 ICON's */
b2i(np)
register NODE *np;
{
register long l,r,x;
int newflags,lflags;
newflags = 0;
r = np->n_right->e_ival;
newflags = np->n_right->e_flags;
l = np->n_left->e_ival;
lflags = np->n_left->e_flags;
newflags = newflags>lflags ? newflags : lflags;
switch (np->e_token) {
case '+':
x = l+r; break;
case '-':
x = l-r; break;
case '*':
x = l*r; break;
case '/':
x = l/r; break;
case '%':
x = l%r; break;
case '>':
x = l>r; break;
case '<':
x = l<r; break;
case LTEQ:
x = l>=r; break;
case GTEQ:
x = l<=r; break;
case DOUBLE '=':
x = l==r; break;
case NOTEQ:
x = l!=r; break;
case '&':
x = l&r; break;
case '|':
x = l|r; break;
case '^':
x = l^r; break;
case DOUBLE '<':
x = l<<r; break;
case DOUBLE '>':
x = l>>r; break;
default:
return;
}
newicon(np, x, newflags);
}
/* BINARY 2 FCON's */
b2f(np,l,r)
register NODE *np;
double l,r;
{
register double x;
int ix, isint;
isint = 0;
switch (np->e_token) {
case '+':
x = l+r; break;
case '-':
x = l-r; break;
case '*':
x = l*r; break;
case '/':
x = l/r; break;
case '>':
ix = l>r; isint++; break;
case '<':
ix = l<r; isint++; break;
case LTEQ:
ix = l>=r; isint++; break;
case GTEQ:
ix = l<=r; isint++; break;
case DOUBLE '=':
ix = l==r; isint++; break;
case NOTEQ:
ix = l!=r; isint++; break;
default:
return;
}
if (isint)
newicon(np, (long)ix, 0);
else
newfcon(np, x);
}
same_type(a,b)
register NODE *a, *b;
{
more:
if (a == b)
return 1;
if (a == NULL || b == NULL)
return 0;
if (a->t_token != b->t_token)
return 0;
if (a->t_token != STAR && a->t_size != b->t_size)
return 0;
a = a->n_tptr;
b = b->n_tptr;
goto more;
}
see_id(np)
NODEP np;
{
NODEP tp;
NODEP allsyms(), def_type();
tp = allsyms(np);
if (tp == NULL) {
errorn("undefined:", np);
tp = def_type();
goto out;
}
switch (tp->e_sc) {
case ENUM_SC:
newicon(np, tp->e_ival, 0);
return;
case K_REGISTER:
np->e_rno = tp->e_rno;
/* fall through */
default:
np->e_sc = tp->e_sc;
np->e_offs = tp->e_offs;
tp = tp->n_tptr;
}
out:
np->n_tptr = tp;
np->n_flags |= N_COPYT;
/* special conversions */
if (tp->t_token == '(')
insptrto(np);
}
insptrto(np)
NODEP np;
{
NODEP op, copyone();
op = copyone(np);
np->n_left = op;
np->e_token = UNARY '&';
np->e_type = E_UNARY;
strcpy(np->n_name, "&fun");
np->n_flags &= ~N_COPYT;
}
/* np points to ID or STAR or '.' node
tptr is a COPY
tptr token is '[' */
see_array(np)
NODEP np;
{
NODEP tp, copyone();
tp = copyone(np);
tp->n_left = np->n_left;
tp->n_tptr = tp->n_tptr->n_tptr;
np->n_left = tp;
np->e_token = UNARY '&';
np->e_type = E_UNARY;
strcpy(np->n_name, "&ary");
arytoptr(np);
/* leave old size
np->n_tptr->t_size = SIZE_P;
*/
}
SHAR_EOF
cat << \SHAR_EOF > pre.c
/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
*
* Permission is granted to anyone to use this software for any purpose
* on any computer system, and to redistribute it freely, with the
* following restrictions:
* 1) No charge may be made other than reasonable charges for reproduction.
* 2) Modified versions must be clearly marked as such.
* 3) The authors are not responsible for any harmful consequences
* of using this software, even if they result from defects in it.
*
* pre.c
*
* preprocessor for the compiler
*
* Handles all preprocessor (#) commands and
* looks up keywords
*
* Interface:
* getnode() returns next "token node"
*/
#include <stdio.h>
#include "param.h"
#include "tok.h"
#include "nodes.h"
#if CC68
FILE *fopenb();
#define fopen fopenb
#endif
NODE *deflist[NHASH];
extern struct tok curtok;
extern char curstr[];
#define TK_SEENL 1 /* want to see NL token */
#define TK_SEEWS 2 /* want to see WS token */
#define TK_ONLY1 4 /* only want 1st token on line */
#define TK_LTSTR 8 /* '<' starts a string */
#define TK_NOESC 16 /* dont do '\' escapes in string */
extern int tk_flags, sawnl;
NODE *holdtok;
extern lineno;
extern char *inname;
extern FILE *input;
int iflevel, iftruth, ifnest;
NODE *hlook(), *llook();
NODEP tok_to_node();
NODE *copylist();
#ifdef DEBUG
extern int oflags[];
#define debugd oflags['d'-'a']
#define debugt oflags['t'-'a']
#endif
NODEP
hi_node()
{
register NODEP rv;
/* node from hold queue ? */
if (holdtok) {
#ifdef DEBUG
if (debugd > 2) {
printf("Holdqueue");
printnode(holdtok);
}
#endif
rv = holdtok;
holdtok = rv->n_next;
rv->n_next = NULL;
return rv;
}
/* node from input */
again:
while (iflevel && !iftruth)
skiplines();
if (nxttok()==0)
return NULL;
if (curtok.tnum == '#') {
dopound(0);
goto again;
}
rv = tok_to_node();
return rv;
}
NODEP
getnode()
{
register NODEP rv;
NODEP dp;
again:
rv = hi_node();
if (rv == NULL) {
rv = allocnode();
rv->e_token = EOFTOK;
strcpy(rv->n_name, "*EOF*");
} else
if (rv->e_token == ID) {
if ((dp = hlook(deflist, rv)) != NULL) {
expand(dp);
freenode(rv);
goto again;
} else
kw_tok(rv);
}
#ifdef DEBUG
if (debugt) {
putchar('[');
put_nnm(rv);
printf("] ");
}
#endif
return rv;
}
skiplines()
{
for (;;) {
if (nxttok()== 0)
return;
if (curtok.tnum == '#') {
dopound(1);
return;
}
tk_flags |= TK_ONLY1;
}
}
static defnargs;
p_def()
{
NODE *args;
NODE *val;
NODE *def;
NODE *def_rgs(), *def_val();
defnargs = -1;
args = NULL;
val = NULL;
nxttok();
if (curtok.tnum != ID) {
error("bad #define");
goto flush;
}
def = tok_to_node();
tk_flags |= TK_SEEWS;
nxttok();
switch (curtok.tnum) {
case '(':
defnargs = 0;
args = def_rgs();
case WS:
goto getval;
case NL:
goto dodef;
default:
error("bad #define");
goto flush;
}
getval:
val = def_val();
dodef:
def->e_ival = defnargs;
define(def, val, args);
flush:
;
}
optdef(s)
char *s;
{
NODEP val;
NODEP def;
NODEP id_tok(), def_val();
char *as, *strchr();
as = strchr(s, '=');
if (as)
*as++ = 0;
else
as = "1";
defnargs = -1;
val = NULL;
def = id_tok(s);
chr_push(as);
tk_flags |= TK_SEENL;
val = def_val();
tk_flags = 0;
def->e_ival = defnargs;
define(def, val, NULL);
}
optundef(s)
char *s;
{
NODEP np, tp, id_tok();
np = id_tok(s);
tp = hlook(deflist, np);
if (tp != NULL)
tp->n_name[0] = '#';
freenode(np);
}
samedef(p1, p2)
NODEP p1, p2;
{
if (p1->e_ival != p2->e_ival)
return 0;
return same_list(p1->n_right, p2->n_right);
}
same_list(p1, p2)
NODEP p1, p2;
{
if (p1 == NULL)
return p2 == NULL;
if (p2 == NULL)
return 0;
if (l_cmp(p1, p2, sizeof(*p1)/sizeof(long)) != 0)
return 0;
return same_list(p1->n_left, p2->n_left);
}
l_cmp(p1, p2, n)
NODE *p1, *p2;
{
if (xstrcmp(p1,p2) != 0)
return 1;
if (p1->e_token != p2->e_token ||
p1->e_ival != p2->e_ival)
return 1;
return 0;
}
define(def, val, args)
NODEP def, val, args;
{
NODEP oldp;
if (args != NULL) {
argsmod(val, args);
freenode(args);
}
def->n_right = val;
if ((oldp = hlook(deflist, def)) != NULL) {
if (!samedef(oldp, def))
warnn("redefined", def);
}
#ifdef DEBUG
if (debugd) {
printf("define (%d args)", (int)def->e_ival);
printnode(def);
}
#endif
puthlist(deflist, def);
}
argsmod(toks, args)
NODEP toks, args;
{
register NODE *np, *vp;
for (np=toks; np != NULL; np = np->n_next)
if (np->e_token == ID) {
vp = llook(args,np);
if (vp != NULL) {
np->e_token = DPARAM;
np->e_ival = vp->e_ival;
sprintf(np->n_name, "\\%d", (int)np->e_ival);
}
}
}
NODE *
def_rgs()
{
NODE *rv;
NODE *tail;
NODE *np;
rv = NULL;
tail = NULL;
nxttok();
if (curtok.tnum == ')') {
goto out;
}
more:
if (curtok.tnum != ID) {
error("expect ID");
goto bad;
}
np = tok_to_node();
np->e_ival = defnargs; /* hold sequence number */
defnargs++;
if (tail == NULL) { /* first one */
rv = np;
tail = np;
} else { /* more */
tail->n_next = np;
tail = np;
}
nxttok();
if (curtok.tnum == ',') {
nxttok();
goto more;
}
if (curtok.tnum == ')')
goto out;
error("define arg syntax");
bad:
freenode(rv);
rv = NULL;
defnargs = 0;
out:
return rv;
}
NODE *
def_val()
{
NODE *rv;
NODE *tail;
NODE *np;
rv = NULL;
tail = NULL;
more:
nxttok();
if (curtok.tnum == NL) {
goto out;
/*
} else if (curtok.tnum == '\\') {
nxttok();
if (curtok.tnum != NL)
goto bad;
goto more;
*/
}
np = tok_to_node();
if (tail == NULL) { /* first one */
rv = np;
tail = np;
} else { /* more */
tail->n_next = np;
tail = np;
}
goto more;
bad:
freenode(rv);
rv = NULL;
out:
return rv;
}
NODE *
gath1(sep)
int *sep;
{
NODE *np, *rv, *tail;
int inparen;
inparen = 0;
rv = NULL;
tail = NULL;
more:
np = hi_node();
if (np == NULL) {
goto bad;
}
switch (np->e_token) {
case ')':
case ',':
if (inparen) { /* dont end, part of subexpr */
if (np->e_token == ')')
inparen--;
break;
}
*sep = np->e_token;
freenode(np);
goto out;
case '(':
inparen++;
break;
}
if (tail == NULL) { /* first one */
rv = np;
tail = np;
} else { /* more */
tail->n_next = np;
tail = np;
}
goto more;
bad:
freenode(rv);
rv = NULL;
*sep = 0;
out:
return rv;
}
NODE *
gath_args(n)
{
NODE *rv;
NODE *tail;
NODE *np;
int sep;
int getn;
getn = 0;
rv = NULL;
tail = NULL;
np = hi_node();
if (np->e_token != '(') {
error("expect (");
goto bad;
}
freenode(np);
if (n == 0) {
np = hi_node();
if (np->e_token != ')') {
error("expect )");
goto bad;
}
freenode(np);
return NULL;
}
more:
np = gath1(&sep);
if (np == NULL) {
error("expect arg");
goto bad;
}
getn++;
if (tail == NULL) { /* first one */
rv = np;
tail = np;
} else { /* more */
tail->n_right = np;
tail = np;
}
if (sep) switch (sep) {
case ',':
goto more;
case ')':
if (getn != n) {
error("arg num mismatch");
goto bad;
}
goto out;
}
error("expand arg syntax");
bad:
freenode(rv);
rv = NULL;
out:
return rv;
}
NODE *
argfix(val, args, rt)
NODE *val, *args;
NODE **rt;
{
register NODE *scan, *sub;
NODE *head;
NODE *tail, *back;
NODE *rthnode();
NODE *copylist();
head = val;
back = NULL;
for (scan = val; scan != NULL; back=scan, scan=scan->n_next)
if (scan->e_token == DPARAM) {
sub = rthnode(args, (int)scan->e_ival);
sub = copylist(sub,&tail);
if (back) {
back->n_next = sub;
tail->n_next = scan->n_next;
} else {
head = sub;
tail->n_next = scan->n_next;
}
scan->n_next = NULL;
freenode(scan);
scan = tail;
}
*rt = back;
return head;
}
expand(dp)
NODEP dp;
{
int nargs;
NODEP args;
register NODEP val;
NODEP tail;
val = dp->n_right;
if (val)
val = copylist(val, &tail);
nargs = dp->e_ival;
if (nargs >= 0) {
args = gath_args(nargs);
if (args) {
if (val)
val = argfix(val,args,&tail);
freenode(args);
}
}
if (val == NULL)
return;
#ifdef DEBUG
if (debugd > 1) {
printf("Expand");
printnode(val);
}
#endif
tail->n_next = holdtok;
holdtok = val;
}
p_undef()
{
NODEP np, tp;
nxttok();
if (curtok.tnum != ID) {
error("bad #undef");
goto out;
}
tp = tok_to_node();
if ((np = hlook(deflist, tp)) != NULL)
/* quick and dirty */
np->n_name[0] = '#';
freenode(tp);
out:
;
}
p_inc()
{
int chkhere;
FILE *newf, *srch_open();
char *scopy(), *newnm;
tk_flags |= TK_NOESC|TK_LTSTR;
nxttok();
switch (curtok.tnum) {
case SCON:
chkhere = 1;
break;
case SCON2:
chkhere = 0;
break;
case NL:
case EOF:
error("bad #include");
return;
}
newf = srch_open(curstr, chkhere);
if (newf == NULL) {
fatals("Cant open ", curstr);
return;
}
newnm = scopy(curstr);
do
nxttok();
while (curtok.tnum != NL);
newfile(newf,newnm);
}
int inclvl;
struct svinc {
int lineno;
FILE *fd;
char *filenm;
} svincs[MAXINCL];
#if NEEDBUF
char p_buf[MAXINCL][BUFSIZ];
#endif
static char obuf[MAXSTR];
newfile(fd,s)
FILE *fd;
char *s;
{
register struct svinc *p;
inclvl++;
if (inclvl > MAXINCL) {
inclvl--;
fclose(fd);
error("too many includes");
return;
}
p = &svincs[inclvl-1];
p->lineno = lineno;
p->fd = input;
p->filenm = inname;
input = fd;
lineno = 1;
inname = s;
#if NEEDBUF
setbuf(input, p_buf[inclvl-1]);
#endif
}
endfile()
{
register struct svinc *p;
if (inclvl == 0)
return 0;
fclose(input);
inclvl--;
p = &svincs[inclvl];
sfree(inname);
input = p->fd;
lineno = p->lineno;
inname = p->filenm;
return 1;
}
#define MAXIDIR 10
char *srchlist[MAXIDIR] = {
"",
"\\include\\",
"\\sozobon\\include\\",
"",
0
};
static int idir_n = 4; /* number of entries in above table */
static int idir_put = 1; /* where to put -I dirs */
optincl(s)
char *s;
{
register char **pp;
if (idir_n >= MAXIDIR-1) {
warn("too many -I dirs");
return;
}
for (pp = &srchlist[idir_n]; pp > &srchlist[idir_put]; ) {
pp--;
pp[1] = pp[0];
}
*pp = s;
idir_put++;
idir_n++;
}
FILE *
srch_open(s, chkhere)
char *s;
{
char **dir;
FILE *fd;
dir = srchlist;
if (chkhere == 0) dir++;
while (*dir) {
strcpy(obuf, *dir);
strcat(obuf, s);
fd = fopen(obuf, ROPEN);
if (fd != NULL) {
return fd;
}
dir++;
}
return NULL;
}
p_if(kind,skipping)
{
int truth;
NODEP tp;
if (skipping) {
ifnest++;
return;
}
switch (kind) {
case 0:
truth = if_expr();
break;
case 1:
case 2:
nxttok();
if (curtok.tnum != ID) {
error("bad #if(n)def");
goto flush;
}
tp = tok_to_node();
truth = (hlook(deflist, tp) != NULL);
freenode(tp);
if (kind == 2)
truth = !truth;
}
iflevel++;
iftruth = truth;
flush:
;
}
extern NODE *cur;
if_expr()
{
NODE *tp, *questx();
int rv;
advnode();
tp = questx();
if (tp) {
rv = conxval(tp);
} else
rv = 0;
if (cur->e_token != NL) {
error("bad #if");
} else
freenode(cur);
return rv;
}
p_swit(kind,skipping)
{
if (skipping && ifnest) {
if (kind == 1)
ifnest--;
return;
}
if (iflevel == 0) {
error("not in #if");
goto out;
}
switch (kind) {
case 0: /* else */
iftruth = !iftruth;
break;
case 1: /* endif */
iflevel--;
iftruth = 1;
break;
}
out:
;
}
p_line()
{
char *scopy();
nxttok();
if (curtok.tnum != ICON) {
error("bad #line");
goto flush;
}
tk_flags |= TK_NOESC;
nxttok();
if (curtok.tnum == SCON) {
sfree(inname);
inname = scopy(curtok.name);
}
lineno = curtok.ival;
flush:
;
}
struct cmds {
char *name;
int (*fun)();
int arg;
int skip;
} pcmds[] = {
{"define", p_def, 0, 1},
{"undef", p_undef, 0, 1},
{"include", p_inc, 0, 1},
{"if", p_if, 0, 0},
{"ifdef", p_if, 1, 0},
{"ifndef", p_if, 2, 0},
{"else", p_swit, 0, 0},
{"endif", p_swit, 1, 0},
{"line", p_line, 0, 1},
{0}
};
dopound(skipping)
{
register struct cmds *p;
register char *cname;
tk_flags |= TK_SEENL;
sawnl = 0;
nxttok();
if (curtok.tnum != ID) {
error("expect name");
return;
}
cname = curtok.name;
for (p=pcmds; p->name; p++)
if (strcmp(p->name, cname) == 0) {
if (!skipping || !p->skip)
(*p->fun)(p->arg, skipping);
tk_flags = 0;
if (sawnl == 0)
tk_flags |= TK_ONLY1;
return;
}
error("bad # command");
}
NODEP
tok_to_node()
{
register struct tok *tp;
register NODEP np;
tp = &curtok;
np = allocnode();
np->e_token = tp->tnum;
np->e_flags = tp->flags;
if (tp->prec) /* binary op */
np->e_prec = tp->prec;
else
switch (np->e_token) {
case ICON:
np->e_ival = tp->ival;
break;
case FCON:
np->e_fval = tp->fval;
break;
}
nscpy(np, tp->name);
return np;
}
NODEP
id_tok(s)
char *s;
{
NODEP np;
np = allocnode();
np->e_token = ID;
nscpy(np, s);
return np;
}
SHAR_EOF
cat << \SHAR_EOF > subs.c
/*
* Replace non-portable assembly assist routines lclr()
* and lcpy() with portable, albeit possibly slightly slower
* versions.
*/
void lclr (ptr, lcount)
long *ptr;
int lcount;
{
while (lcount-- > 0) {
*ptr++ = 0;
}
}
void lcpy (out, in, lcount)
long *out;
long *in;
int lcount;
{
while (lcount-- > 0) {
*out++ = *in++;
}
}
SHAR_EOF
cat << \SHAR_EOF > tok.c
/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
*
* Permission is granted to anyone to use this software for any purpose
* on any computer system, and to redistribute it freely, with the
* following restrictions:
* 1) No charge may be made other than reasonable charges for reproduction.
* 2) Modified versions must be clearly marked as such.
* 3) The authors are not responsible for any harmful consequences
* of using this software, even if they result from defects in it.
*
* tok.c
*
* Basic level token routines
*
* At this level, we return the following things:
* id's - strings of alpha-alnum
* integer constants
* float constants
* string constants
* multi-char tokens
*
* We DONT know about:
* keywords
* #defined id's
* any other meaning of a name
*
* Interface:
* call nxttok() to get next token
* look at 'curtok' for current token
* note that curtok.name points to a static area
* for ID or SCON
*
* if EOF is seen, we call endfile() before
* giving up
*
* Special flags: (tk_flags)
* These special flags are needed for the pre-processor.
* All but TK_SEENL are 1-shot.
*
* TK_SEENL - want to see \n
* TK_WS - want to see white space (for #define)
* TK_NOESC - dont do '\' escapes in strings
* TK_LTSTR - '<' is a string starter
* TK_ONLY1 - skip to token after \n (for #if--)
*/
#include <stdio.h>
#include "param.h"
#include "tok.h"
#ifdef dLibs
#include <ctype.h>
#endif
struct tok curtok;
char curstr[MAXSTR+1];
#define TK_SEENL 1 /* want to see NL token */
#define TK_SEEWS 2 /* want to see WS token */
#define TK_ONLY1 4 /* only want 1st token on line */
#define TK_LTSTR 8 /* '<' starts a string */
#define TK_NOESC 16 /* dont do '\' escapes in string */
int tk_flags, sawnl;
extern FILE *input;
extern int lineno;
#define NOCHAR 0x100
#ifdef DEBUG
extern int oflags[];
#define debug oflags['b'-'a']
#endif
nxttok()
{
register struct tok *t;
char *getname();
long getnumber();
register int c;
double getfrac();
t = &curtok;
t->name = curstr;
t->name[0] = 0;
t->prec = 0;
t->flags = 0;
more:
c = mygetchar();
if (c == EOF) {
tk_flags = 0;
return 0;
}
if (c == '\n') {
tk_flags &= ~TK_ONLY1;
if ((tk_flags & TK_SEENL) == 0)
goto more;
t->tnum = NL;
t->name = "\n";
goto out;
}
if (tk_flags & TK_ONLY1)
goto more;
if (c <= ' ') {
if ((tk_flags & TK_SEEWS) == 0)
goto more;
t->tnum = WS;
t->name = " ";
goto out;
}
if (c >= '0' && c <= '9') {
t->tnum = ICON;
t->ival = getnumber(c);
if (lookfrac(t->ival) || lookexp(t->ival,0.0))
goto out;
moresuf:
c = mygetchar();
if (tolower(c) == 'l') {
t->flags |= SEE_L;
goto moresuf;
} else if (tolower(c) == 'u') {
t->flags |= SEE_U;
goto moresuf;
} else {
myungetc(c);
}
sprintf(curstr, "%ld",
t->ival);
goto out;
}
if (isalpha(c) || c == '_') {
t->tnum = ID;
t->name = getname(c);
goto out;
}
if (c == '.') {
c = mygetchar();
if (c >= '0' && c <= '9') {
gotfrac(0L, getfrac(c));
goto out;
} else {
myungetc(c);
matchop('.');
goto out;
}
}
if(matchop(c) == 0)
goto more;
out:
if (debug) printf("<%s>", t->name);
tk_flags &= TK_SEENL; /* all but SEENL are 1-shot */
return 1;
}
long
getnumber(c)
register int c;
{
register long val = 0;
int base, i;
if (c == '0') {
base = 8;
} else {
base = 10;
val = c - '0';
}
more:
c = mygetchar();
if (c == EOF)
return val;
if (tolower(c) == 'x' && val == 0) {
base = 16;
goto more;
}
if (c >= '0' && c <= '9') {
val = base*val + (c - '0');
goto more;
}
if (base == 16 && (i = ishexa(c))) {
val = 16*val + i;
goto more;
}
myungetc(c);
return val;
}
double
getfrac(c)
register c;
{
register double val;
register double dig = 0.1;
val = dig * (c - '0');
more:
c = mygetchar();
if (c >= '0' && c <= '9') {
dig = .1 * dig;
val += dig * (c - '0');
goto more;
}
myungetc(c);
return val;
}
lookfrac(intpart)
long intpart;
{
int c;
double frac;
c = mygetchar();
if (c != '.') {
myungetc(c);
return 0;
}
c = mygetchar();
if (c >= '0' && c <= '9') {
frac = getfrac(c);
} else {
myungetc(c);
frac = 0.0;
}
gotfrac(intpart, frac);
return 1;
}
gotfrac(intpart, frac)
long intpart;
double frac;
{
if (lookexp(intpart, frac) == 0)
makeflt(intpart, frac, 0);
}
lookexp(intpart, frac)
long intpart;
double frac;
{
int c;
int minus;
int exp;
minus = 0;
c = mygetchar();
if (tolower(c) != 'e') {
myungetc(c);
return 0;
}
c = mygetchar();
if (c == '-') {
minus = 1;
c = mygetchar();
} else if (c == '+')
c = mygetchar();
if (c >= '0' && c <= '9') {
exp = getnumber(c);
} else {
exp = 0;
myungetc(c);
}
if (minus)
exp = -exp;
makeflt(intpart, frac, exp);
return 1;
}
makeflt(intpart, frac, exp)
long intpart;
double frac;
{
register double val;
double mod, mod10, mod100;
register struct tok *t;
val = intpart + frac;
if (exp > 0) {
mod = 1e1;
mod10 = 1e10;
#if IEEE_FP
mod100 = 1e100;
#endif
} else if (exp < 0) {
mod = 1e-1;
mod10 = 1e-10;
#if IEEE_FP
mod100 = 1e-100;
#endif
exp = -exp;
}
#if IEEE_FP
while (exp >= 100) {
val *= mod100;
exp -= 100;
}
#endif
while (exp >= 10) {
val *= mod10;
exp -= 10;
}
while (exp--)
val *= mod; /* slow and dirty */
t = &curtok;
t->tnum = FCON;
t->fval = val;
sprintf(t->name, FLTFORM, val);
}
char *
getname(c)
register int c;
{
register int nhave;
nhave = 0;
do {
if (nhave < MAXSTR)
curstr[nhave++] = c;
c = mygetchar();
} while (isalnum(c) || c == '_');
myungetc(c);
curstr[nhave] = 0;
return curstr;
}
static char *holdstr;
chr_push(s)
char *s;
{
holdstr = s;
}
static int holdchar, xholdchar;
mygetchar()
{
register int c;
int c2;
if (holdchar) {
c = holdchar;
holdchar = 0;
goto out;
}
if (holdstr) { /* used for -D args */
c = *holdstr++;
if (c == 0) {
holdstr = NULL;
return '\n';
}
return c;
}
retry:
c = xgetc();
if (c == EOF) {
if (endfile())
goto retry;
} else if (c == '\\') { /* ansi handling of backslash nl */
c2 = xgetc();
if (c2 == '\n') {
lineno++;
goto retry;
} else
xholdchar = c2;
}
out:
if (c == '\n') {
sawnl++; /* for pre.c */
lineno++;
}
return c;
}
xgetc()
{
register int c;
if (xholdchar) {
c = xholdchar;
xholdchar = 0;
return c;
}
#if CC68|dLibs
if (input == stdin) /* bypass stupid input */
c = hackgetc();
else
#endif
c = getc(input);
if (c != EOF)
c &= 0x7f;
return c;
}
myungetc(c)
char c;
{
if (c != EOF)
holdchar = c;
if (c == '\n')
lineno--;
}
struct op {
char *name;
char *asname;
int flags;
char prec;
char value;
} ops[] = {
{"{"},
{"}"},
{"["},
{"]"},
{"("},
{")"},
{"#"},
{"\\"},
{";"},
{","},
{":"},
{"."},
{"\"", 0, SPECIAL},
{"'", 0, SPECIAL},
{"==", 0, C_NOT_A, 5},
{"=", 0, 0},
{"++", 0, CAN_U},
{"+", "+=", CAN_AS|C_AND_A, 2},
{"--", 0, CAN_U},
{"->", 0, 0, 0, ARROW},
{"-", "-=", CAN_U|CAN_AS, 2},
{"*", "*=", CAN_U|CAN_AS|C_AND_A, 1},
{"%", "%=", CAN_AS, 1},
{"/*", 0, SPECIAL},
{"/", "/=", CAN_AS, 1},
{"&&", 0, 0, 9},
{"&", "&=", CAN_U|CAN_AS|C_AND_A, 6},
{"||", 0, 0, 10},
{"|", "|=", CAN_AS|C_AND_A, 8},
{"!=", 0, C_NOT_A, 5, NOTEQ},
{"!", 0, CAN_U},
{"~", 0, CAN_U},
{"^", "^=", CAN_AS|C_AND_A, 7},
{"<<", "<<=", CAN_AS, 3},
{"<=", 0, C_NOT_A, 4, LTEQ},
{"<", 0, SPECIAL|C_NOT_A, 4},
{">>", ">>=", CAN_AS, 3},
{">=", 0, C_NOT_A, 4, GTEQ},
{">", 0, C_NOT_A, 4},
{"?", 0, 0},
{0, 0, 0}
};
#define FIRST_C '!'
#define LAST_C 0177
struct op *opstart[LAST_C-FIRST_C+1];
mo_init()
{
register struct op *p;
register c;
for (p=ops; p->name; p++) {
c = p->name[0];
if (opstart[c-FIRST_C] == 0)
opstart[c-FIRST_C] = p;
}
}
matchop(c)
{
register struct tok *t;
register struct op *p;
int nxt;
int value;
static first = 0;
t = &curtok;
nxt = mygetchar();
value = c;
if (first == 0) {
mo_init();
first = 1;
}
p = opstart[c-FIRST_C];
if (p)
for (; p->name; p++)
if (p->name[0] == c)
if (p->name[1] == 0 || p->name[1] == nxt) {
if (p->name[1] == 0)
myungetc(nxt);
else {
value = p->value ? p->value :
DOUBLE value;
}
if (p->flags & SPECIAL)
if (c != '<' ||
tk_flags & TK_LTSTR)
return dospec(p);
t->flags = p->flags;
if (p->flags & CAN_AS) {
nxt = mygetchar();
if (nxt != '=') {
myungetc(nxt);
} else {
value = ASSIGN value;
t->flags = 0;
}
}
t->name = isassign(value)?p->asname:p->name;
t->tnum = value;
t->prec = isassign(value)? 0 : p->prec;
return 1;
}
myungetc(nxt);
t->name = "???";
t->tnum = BADTOK;
return 0;
}
dospec(p)
struct op *p;
{
register struct tok *t;
register int c;
int nhave;
int endc;
t = &curtok;
switch (p->name[0]) {
case '/': /* slash-star */
look:
do {
c = mygetchar();
} while (c != '*');
c = mygetchar();
if (c == '/')
return 0;
myungetc(c);
goto look;
case '\'':
t->tnum = ICON;
t->ival = getschar('\''); /* allow only 1 for now*/
while (getschar('\'') != NOCHAR)
;
sprintf(curstr, "%d", (int)t->ival);
return 1;
case '<':
endc = '>';
t->tnum = SCON2;
goto strs;
case '"':
endc = '"';
t->tnum = SCON;
strs:
t->name = curstr;
nhave = 0;
c = getschar(endc);
while (c != NOCHAR) {
if (c >= 0 && c <= 1 && nhave < MAXSTR) {
/* allow null */
curstr[nhave++] = 1;
c++;
}
if (nhave < MAXSTR)
curstr[nhave++] = c;
c = getschar(endc);
}
curstr[nhave] = 0;
return 1;
}
}
getoct(c)
{
char n, i;
n = c - '0';
for (i=1; i < 3; i++) {
c = mygetchar();
if (c < '0' || c > '7') {
myungetc(c);
return (int)n;
}
n = 8*n + (c - '0');
}
return (int)n;
}
getschar(del)
char del;
{
register int c;
more:
c = mygetchar();
if (c == del)
return NOCHAR;
if (c == '\n') {
error("nl in string");
myungetc(c);
return NOCHAR;
}
if (c == '\\' && (tk_flags & TK_NOESC) == 0) {
c = mygetchar();
if (c == del)
return c;
if (c >= '0' && c <= '7')
return getoct(c);
switch (c) {
/*
case '\n':
goto more;
*/
case 'b':
c = '\b';
break;
case 'n':
c = '\n';
break;
case 't':
c = '\t';
break;
case 'r':
c = '\r';
break;
case 'f':
c = '\f';
break;
}
}
return c;
}
#ifndef dLibs
isalpha(c)
register char c;
{
if ((c>='a' && c<='z') ||
(c>='A' && c<='Z'))
return 1;
return 0;
}
isalnum(c)
register char c;
{
return (isalpha(c) || (c>='0' && c<='9'));
}
tolower(c)
register char c;
{
if (c>='A' && c<='Z')
c += 'a'-'A';
return c;
}
#endif
ishexa(c)
register char c;
{
if (c>='a' && c<='f')
return (c-'a'+10);
if (c>='A' && c<='F')
return (c-'A'+10);
return 0;
}
#if CC68
hackgetc()
{
register int c;
c = bios(2,2);
switch (c) {
case 4:
return EOF;
case '\r':
case '\n':
bios(3,2,'\r');
bios(3,2,'\n');
return '\n';
}
bios(3,2,c);
return c;
}
#endif
#if dLibs
hackgetc()
{
register int c;
c = getchar();
switch (c) {
case 4:
return EOF;
case '\n':
putchar('\n');
break;
}
return c;
}
#endif
SHAR_EOF
# End of shell archive
exit 0
--
Bob Page, U of Lowell CS Dept. page@swan.ulowell.edu ulowell!page
Have five nice days.