koreth@panarthea.ebay.sun.com (Steven Grimm) (10/26/89)
Submitted-by: ncar.ucar.edu!dunike!onecom!wldrdg!hans (Johann Ruegg)
Posting-number: Volume 2, Issue 98
Archive-name: sozobon1.2/part07
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 7 (of 9)."
# Contents: hcc/GUNK.C hcc/P2.C hcc/PRE.C
# Wrapped by koreth@panarthea on Tue Oct 24 18:40:46 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'hcc/GUNK.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/GUNK.C'\"
else
echo shar: Extracting \"'hcc/GUNK.C'\" \(15002 characters\)
sed "s/^X//" >'hcc/GUNK.C' <<'END_OF_FILE'
X/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
X *
X * Permission is granted to anyone to use this software for any purpose
X * on any computer system, and to redistribute it freely, with the
X * following restrictions:
X * 1) No charge may be made other than reasonable charges for reproduction.
X * 2) Modified versions must be clearly marked as such.
X * 3) The authors are not responsible for any harmful consequences
X * of using this software, even if they result from defects in it.
X *
X * gunk.c
X *
X * Transformations on expression trees
X * Most of this stuff is because we cant handle
X * floats, long mul/div, or fields directly.
X */
X
X#include <stdio.h>
X#include "param.h"
X#include "bstok.h"
X#include "tytok.h"
X#include "flags.h"
X#include "nodes.h"
X#include "gen.h"
X
XNODEP copyone();
X
X#define gwiden(x) ((x)==1 ? 2 : (x))
X#define isfield(np) ((np)->g_token == '.' && (np)->g_fldw)
X
XNODEP npar1, npar2, npar3;
Xchar *spar1, *spar2, *spar3;
Xint ipar1, ipar2, ipar3;
X
Xstruct rule {
X int (*match)(); /* test for transformation needed */
X int (*rewri)(); /* rewrite function */
X};
X
Xint m_unfold(), unfold(), m_cast(), cast(), m_inline(), inline();
Xint m_hardas(), hardas(), m_fcmp(), fcmp(), m_md_shf(), md_shf();
Xint m_eident(), eident(), m_incdec(), incdec(), m_fldas(), fldas();
X
Xstruct rule gunktbl[] = {
X {m_unfold, unfold},
X {m_cast, cast},
X {m_md_shf, md_shf},
X {m_eident, eident},
X {m_incdec, incdec},
X {m_hardas, hardas},
X {m_inline, inline}, /* must cast before inline */
X {m_fcmp, fcmp},
X {m_fldas, fldas},
X {0}
X};
X
Xint anygunk;
X
Xgunk(np)
XNODEP np;
X{
X do {
X anygunk = 0;
X gunks(np);
X } while (anygunk);
X}
X
Xgunks(np)
Xregister NODEP np;
X{
X switch (np->g_type) {
X case E_BIN:
X gunks(np->n_right);
X case E_UNARY:
X gunks(np->n_left);
X }
X gunk1(np);
X}
X
Xgunk1(np)
XNODEP np;
X{
X register struct rule *p;
X
X for (p=gunktbl; p->match; p++)
X if ((*p->match)(np)) {
X anygunk++;
X (*p->rewri)(np);
X return;
X }
X}
X
X/*
X * Change pointer arithmetic to equivalent trees
X * (main thing is to mult or div by object size)
X */
Xm_unfold(np)
XNODEP np;
X{
X switch (np->g_token) {
X case PTRADD:
X ipar1 = '+';
X return 1;
X case PTRSUB:
X ipar1 = '-';
X return 1;
X case PTRDIFF:
X ipar1 = 0;
X return 1;
X case ASSIGN PTRADD:
X ipar1 = ASSIGN '+';
X return 1;
X case ASSIGN PTRSUB:
X ipar1 = ASSIGN '-';
X return 1;
X }
X return 0;
X}
X
Xunfold(np)
XNODEP np;
X{
X if (ipar1) {
X ins_mul(np, np->g_offs);
X np->g_token = ipar1;
X } else {
X ins_div(np, np->g_offs);
X }
X}
X
XNODEP
Xnewgcon(kon, ty, sz)
Xlong kon;
X{
X register NODEP kp;
X
X kp = allocnode();
X kp->g_token = ICON;
X sprintf(kp->n_name, "%ld", kon);
X kp->g_offs = kon;
X kp->g_type = E_LEAF;
X kp->g_ty = ty;
X kp->g_sz = sz;
X return kp;
X}
X
Xins_mul(np, kon)
XNODEP np;
Xlong kon;
X{
X NODEP rp = np->n_right;
X register NODEP mp, kp;
X
X if (kon == 1)
X return;
X if (rp->g_token == ICON) {
X rp->g_offs *= kon;
X rp->g_sz = gwiden(rp->g_sz);
X return;
X }
X
X mp = allocnode();
X mp->g_token = '*';
X sprintf(mp->n_name, "p*");
X mp->g_type = E_BIN;
X mp->g_ty = rp->g_ty;
X mp->g_sz = gwiden(rp->g_sz);
X
X kp = newgcon(kon, mp->g_ty, mp->g_sz);
X
X mp->n_right = kp;
X mp->n_left = np->n_right;
X np->n_right = mp;
X}
X
Xins_div(np, kon)
Xregister NODEP np;
Xlong kon;
X{
X register NODEP tp, kp;
X
X kp = newgcon(kon, np->g_ty, np->g_sz);
X
X tp = copyone(np);
X tp->g_token = '-';
X tp->n_left = np->n_left;
X tp->n_right = np->n_right;
X tp->g_sz = SIZE_P;
X tp->g_ty = ET_U;
X
X np->n_left = tp;
X np->n_right = kp;
X np->g_type = E_BIN;
X np->g_token = '/';
X sprintf(np->n_name, "p/");
X}
X
X#define CAST_LN 1
X#define CAST_RN 2
X#define CAST_LLONG 3
X
X/*
X * Insert needed (implied) casts
X */
Xm_cast(np)
XNODEP np;
X{
X NODEP lp = np->n_left;
X
X switch (np->g_type) {
X case E_LEAF:
X return 0;
X case E_BIN:
X return bm_cast(np);
X }
X /* must be unary */
X switch (np->g_token) {
X case UNARY '-':
X case '~':
X return castup(lp, np, CAST_LN);
X case TCONV:
X return fcastlong(np);
X }
X return 0;
X}
X
Xbm_cast(np)
Xregister NODEP np;
X{
X NODEP lp = np->n_left, rp = np->n_right;
X
X if (isassign(np->g_token)) {
X if (castup(rp, lp, CAST_RN))
X return 1;
X if (castmagic(rp, lp, CAST_RN, np->g_token - (ASSIGN 0)))
X return 1;
X return 0;
X }
X
X switch (np->g_token) {
X case '=':
X if (np->g_ty == ET_A)
X return 0;
X return castany(rp, lp, CAST_RN);
X
X case '<':
X case '>':
X case DOUBLE '=':
X case NOTEQ:
X case LTEQ:
X case GTEQ:
X if (castup(lp, rp, CAST_LN))
X return 1;
X return castup(rp, lp, CAST_RN);
X
X case '(':
X case ',':
X case '?':
X case DOUBLE '&':
X case DOUBLE '|':
X return 0;
X
X case DOUBLE '<':
X case DOUBLE '>':
X if (castup(lp, np, CAST_LN))
X return 1;
X return castany(rp, np, CAST_RN);
X
X default:
X if (castup(lp, np, CAST_LN))
X return 1;
X return castup(rp, np, CAST_RN);
X }
X return 0;
X}
X
Xfcastlong(np)
XNODEP np;
X{
X NODEP lp = np->n_left;
X
X if (red_con(lp))
X return 0;
X if (np->g_ty == ET_F && lp->g_ty != ET_F && lp->g_sz != SIZE_L) {
X ipar1 = CAST_LLONG;
X return 1;
X }
X if (lp->g_ty == ET_F && np->g_ty != ET_F && np->g_sz != SIZE_L) {
X ipar1 = CAST_LLONG;
X return 1;
X }
X return 0;
X}
X
Xcastup(lowp, hip, par)
XNODEP lowp, hip;
X{
X if (stronger(hip, lowp)) {
X ipar1 = par;
X npar1 = hip;
X return 1;
X }
X return 0;
X}
X
Xcastmagic(p1, p2, par, tok)
XNODEP p1, p2;
X{
X if (xstronger(p1,p2) && magicop(tok)) {
X ipar1 = par;
X npar1 = p2;
X return 1;
X }
X return 0;
X}
X
Xcastany(p1, p2, par)
XNODEP p1, p2;
X{
X if (p1->g_sz != p2->g_sz ||
X ((p1->g_ty == ET_F) != (p2->g_ty == ET_F))) {
X ipar1 = par;
X npar1 = p2;
X return 1;
X }
X return 0;
X}
X
Xcast(np)
XNODEP np;
X{
X switch (ipar1) {
X case CAST_LN:
X castsub(npar1->g_ty, npar1->g_sz, &np->n_left, np->n_left);
X break;
X case CAST_RN:
X castsub(npar1->g_ty, npar1->g_sz, &np->n_right, np->n_right);
X break;
X case CAST_LLONG:
X castsub(ET_S, SIZE_L, &np->n_left, np->n_left);
X break;
X }
X}
X
Xcastsub(ty, sz, npp, np)
XNODEP *npp, np;
X{
X register NODEP tp;
X
X /* ICON cast optimization */
X if (np->g_token == ICON &&
X np->g_ty == ty &&
X np->g_sz < sz) {
X np->g_sz = sz;
X return;
X }
X
X tp = allocnode();
X tp->g_token = TCONV;
X strcpy(tp->n_name, "cast up");
X tp->n_left = np;
X *npp = tp;
X tp->g_sz = sz;
X tp->g_ty = ty;
X tp->g_type = E_UNARY;
X}
X
X/*
X * Change stuff computer cant do to calls to inline functions
X * (in this case, all floats and long *%/)
X */
Xm_inline(np)
XNODEP np;
X{
X int isfloat, isuns;
X
X if (np->g_type == E_LEAF)
X return 0;
X
X if (np->g_ty == ET_A)
X return 0;
X isfloat = (np->g_ty == ET_F);
X isuns = (np->g_ty == ET_U);
X
X if (np->g_type == E_UNARY) {
X switch (np->g_token) {
X case UNARY '-':
X if (!isfloat) return 0;
X spar1 = "%fpneg";
X return 1;
X case TCONV:
X if ((np->n_left->g_ty == ET_F) == isfloat)
X return 0;
X if (red_con(np->n_left))
X return 0;
X spar1 = isfloat ? "fpltof" : "fpftol";
X return 1;
X }
X return 0;
X }
X
X if (np->g_sz != 4) /* longs or floats only */
X return 0;
X
X switch (np->g_token) {
X case '*':
X spar1 = isfloat ? "%fpmul" : (isuns ? "%lmulu" : "%lmul");
X return 1;
X case '/':
X spar1 = isfloat ? "%fpdiv" : (isuns ? "%ldivu" : "%ldiv");
X return 1;
X case '+':
X if (!isfloat) return 0;
X spar1 = "%fpadd";
X return 1;
X case '-':
X if (!isfloat) return 0;
X spar1 = "%fpsub";
X return 1;
X case '%':
X spar1 = isuns ? "%lremu" : "%lrem";
X return 1;
X }
X return 0;
X}
X
Xinline(np)
XNODEP np;
X{
X register NODEP nmp, cmap;
X int isunary;
X
X isunary = (np->g_type == E_UNARY);
X
X if (isunary) {
X np->n_right = np->n_left;
X np->g_type = E_BIN;
X } else {
X cmap = copyone(np);
X cmap->n_left = np->n_left;
X cmap->n_right = np->n_right;
X np->n_right = cmap;
X
X cmap->g_token = ',';
X cmap->g_offs = 2;
X strcpy(cmap->n_name, ",inl");
X }
X
X nmp = allocnode();
X np->n_left = nmp;
X
X np->g_token = '(';
X strcpy(np->n_name, "inline");
X
X nmp->g_token = ID;
X strcpy(nmp->n_name, spar1);
X#ifdef OUT_AZ
X strcat(nmp->n_name, "#");
X#endif
X}
X
X/*
X * Transform hard ++,-- to equivalent trees
X * (for us, floats or fields)
X */
Xm_incdec(np)
XNODEP np;
X{
X if (np->g_type != E_UNARY)
X return 0;
X if (np->g_ty != ET_F && !isfield(np->n_left))
X return 0;
X
X ipar2 = 0;
X switch (np->g_token) {
X case DOUBLE '+':
X ipar1 = ASSIGN '+';
X spar1 = "+=";
X break;
X case DOUBLE '-':
X ipar1 = ASSIGN '-';
X spar1 = "-=";
X break;
X case POSTINC:
X ipar1 = DOUBLE '+';
X spar1 = "++";
X ipar2 = '-';
X spar2 = "-";
X break;
X case POSTDEC:
X ipar1 = DOUBLE '-';
X spar1 = "--";
X ipar2 = '+';
X spar2 = "+";
X break;
X default:
X return 0;
X }
X return 1;
X}
X
Xincdec(np)
Xregister NODEP np;
X{
X NODEP t1;
X NODEP onep;
X
X onep = newgcon(1L, ET_S, SIZE_I);
X
X if (ipar2 == 0) { /* easy case, ++X becomes X+=1 */
X np->g_token = ipar1;
X np->g_type = E_BIN;
X np->n_right = onep;
X strcpy(np->n_name, spar1);
X return;
X }
X
X /* hard case, X++ becomes (++X - 1) */
X t1 = copyone(np);
X t1->n_left = np->n_left;
X np->n_left = t1;
X np->n_right = onep;
X np->g_type = E_BIN;
X np->g_token = ipar2;
X strcpy(np->n_name, spar2);
X
X t1->g_token = ipar1;
X strcpy(t1->n_name, spar1);
X}
X
X/*
X * Transform hard op= trees to equivalent '=' trees
X * (in this case, all floats, long or char *%/, fields)
X */
Xm_hardas(np)
XNODEP np;
X{
X int op;
X
X if (np->g_type != E_BIN)
X return 0;
X op = np->g_token;
X if (isassign(op))
X op -= ASSIGN 0;
X else
X return 0;
X if (xstronger(np->n_right, np->n_left) &&
X magicop(op) == 0)
X return 1;
X if (np->g_ty == ET_F || isfield(np->n_left))
X return 1;
X if (np->g_sz == 4 || np->g_sz == 1)
X switch (op) {
X case '*':
X case '/':
X case '%':
X return 1;
X }
X return 0;
X}
X
Xhardas(np)
XNODEP np;
X{
X NODEP opp, newl;
X NODEP copynode();
X
X if (m_vhard(np)) {
X vhard(np);
X return;
X }
X
X opp = copyone(np);
X newl = copynode(np->n_left);
X opp->n_right = np->n_right;
X np->n_right = opp;
X opp->n_left = newl;
X
X np->g_token = '=';
X strcpy(np->n_name, "unfold");
X
X opp->g_token -= (ASSIGN 0);
X bmaxty(opp);
X}
X
X/*
X * Check for lhs of op= that have side effects or are complex
X */
Xm_vhard(np)
XNODEP np;
X{
X NODEP lp = np->n_left;
X
X while (lp->g_token == '.')
X lp = lp->n_left;
X if (lp->g_token != STAR)
X return 0;
X return isvhard(lp->n_left);
X}
X
Xisvhard(np)
XNODEP np;
X{
X NODEP rp;
X
Xdescend:
X switch (np->g_type) {
X case E_LEAF:
X return 0;
X case E_UNARY:
X switch (np->g_token) {
X case '(':
X case DOUBLE '+':
X case DOUBLE '-':
X case POSTINC:
X case POSTDEC:
X return 1;
X default:
X np = np->n_left;
X goto descend;
X }
X case E_BIN:
X switch (np->g_token) {
X case '+':
X case '-':
X rp = np->n_right;
X if (rp->g_token == ICON && np->g_ty != ET_F) {
X np = np->n_left;
X goto descend;
X }
X /* fall through */
X default:
X return 1;
X }
X }
X}
X
Xvhard(np)
XNODEP np;
X{
X NODEP starp;
X NODEP atree, btree;
X NODEP t1, t2;
X register NODEP opp;
X NODEP tmp_var();
X
X starp = np->n_left;
X while (starp->g_token == '.')
X starp = starp->n_left;
X atree = starp->n_left;
X btree = np->n_right;
X t1 = tmp_var(ET_U, SIZE_P);
X t2 = copyone(t1);
X starp->n_left = t2;
X
X opp = copyone(t1);
X opp->g_type = E_BIN;
X opp->g_token = '=';
X strcpy(opp->n_name, "=");
X opp->n_right = atree;
X opp->n_left = t1;
X
X comma_r(np, opp);
X}
X
Xcomma_r(topp, lp)
XNODEP topp, lp;
X{
X register NODEP newp;
X
X newp = copyone(topp);
X topp->g_token = ',';
X strcpy(topp->n_name, ",");
X newp->n_left = topp->n_left;
X newp->n_right = topp->n_right;
X topp->n_left = lp;
X topp->n_right = newp;
X}
X
XNODEP
Xtmp_var(ty, sz)
X{
X register NODEP t1;
X
X t1 = allocnode();
X t1->g_token = OREG;
X t1->g_type = E_LEAF;
X t1->g_rno = AREG+6;
X t1->g_ty = ty;
X t1->g_sz = sz;
X t1->g_offs = - tmp_alloc(sz);
X strcpy(t1->n_name, "tmp_v");
X return t1;
X}
X
X/* X op= Y where Y's type is stronger than X's
X either unfold it or (default)
X cast Y to weaker type (+ or -)
X*/
X
Xmagicop(op)
X{
X switch (op) {
X case '+':
X case '-':
X case DOUBLE '<':
X case DOUBLE '>':
X case '&':
X case '|':
X case '^':
X return 1;
X }
X return 0;
X}
X
Xstronger(xp, yp)
XNODEP xp, yp;
X{
X if (xp->g_sz > yp->g_sz ||
X (xp->g_sz == yp->g_sz && xp->g_ty > yp->g_ty))
X return 1;
X return 0;
X}
X
X/* stronger with ET_S and ET_U considered equal */
Xxstronger(xp, yp)
XNODEP xp, yp;
X{
X if (xp->g_sz > yp->g_sz ||
X (xp->g_ty == ET_F && yp->g_ty != ET_F))
X return 1;
X return 0;
X}
X
X/* give np the type of the stronger child */
Xbmaxty(np)
XNODEP np;
X{
X NODEP lp = np->n_left, rp = np->n_right;
X
X if (stronger(lp, rp))
X rp = lp;
X np->g_ty = rp->g_ty;
X np->g_sz = gwiden(rp->g_sz);
X}
X
X/*
X * Change floating compares to inline call
X */
Xm_fcmp(np)
XNODEP np;
X{
X /* already made L and R same with casts */
X if (np->g_type != E_BIN || np->n_left->g_ty != ET_F)
X return 0;
X switch (np->g_token) {
X case '<':
X spar2 = "lt";
X return 1;
X case '>':
X spar2 = "gt";
X return 1;
X case DOUBLE '=':
X spar2 = "eq";
X return 1;
X case NOTEQ:
X spar2 = "ne";
X return 1;
X case GTEQ:
X spar2 = "ge";
X return 1;
X case LTEQ:
X spar2 = "le";
X return 1;
X }
X return 0;
X}
X
Xfcmp(np)
Xregister NODEP np;
X{
X register NODEP tp;
X
X spar1 = "%fpcmp";
X inline(np);
X
X tp = copyone(np);
X tp->n_left = np->n_left;
X tp->n_right = np->n_right;
X np->n_left = tp;
X
X np->n_right = NULL;
X np->g_type = E_UNARY;
X np->g_token = CMPBR;
X sprintf(np->n_name, spar2);
X}
X
X/*
X * Remove useless binary operations with identity constant
X */
Xm_eident(np)
XNODEP np;
X{
X NODEP rp = np->n_right;
X long l;
X int i, op;
X
X if (np->g_type != E_BIN)
X return 0;
X if (np->g_ty == ET_F)
X return 0;
X while (rp->g_token == TCONV && rp->g_ty != ET_F)
X rp = rp->n_left;
X if (rp->g_token != ICON)
X return 0;
X l = rp->g_offs;
X if (l < 0 || l > 1)
X return 0;
X
X op = np->g_token;
X if (isassign(op))
X op -= ASSIGN 0;
X switch (op) {
X case '+':
X case '-':
X case DOUBLE '<':
X case DOUBLE '>':
X case '|':
X case '^':
X i = 0; break;
X case '*':
X case '/':
X i = 1; break;
X default:
X return 0;
X }
X if (l != i)
X return 0;
X return 1;
X}
X
Xeident(np)
XNODEP np;
X{
X NODEP lp = np->n_left, rp = np->n_right;
X
X freenode(rp);
X
X lcpy(np, lp, sizeof(NODE)/4);
X
X freeunit(lp);
X}
X
X#define MAXLOOK 8
X
X/*
X * Change certain mult or div to equivalent shift
X */
Xm_md_shf(np)
XNODEP np;
X{
X NODEP rp = np->n_right;
X long l;
X register i, j;
X
X if (np->g_type != E_BIN)
X return 0;
X if (np->g_ty == ET_F)
X return 0;
X while (rp->g_token == TCONV && rp->g_ty != ET_F)
X rp = rp->n_left;
X if (rp->g_token != ICON)
X return 0;
X
X switch (np->g_token) {
X case '*':
X ipar1 = DOUBLE '<'; break;
X case '/':
X ipar1 = DOUBLE '>'; break;
X case ASSIGN '*':
X ipar1 = ASSIGN DOUBLE '<'; break;
X case ASSIGN '/':
X ipar1 = ASSIGN DOUBLE '>'; break;
X default:
X return 0;
X }
X
X l = rp->g_offs;
X if (l < 2 || l > (1<<MAXLOOK))
X return 0;
X i = l;
X for (j=1; j<=MAXLOOK; j++)
X if (i == 1<<j) {
X ipar2 = j;
X return 1;
X }
X return 0;
X}
X
Xmd_shf(np)
XNODEP np;
X{
X NODEP rp = np->n_right;
X
X np->g_token = ipar1;
X while (rp->g_token == TCONV)
X rp = rp->n_left;
X rp->g_offs = ipar2;
X}
X
Xm_fldas(np)
XNODEP np;
X{
X if (np->g_type != E_BIN)
X return 0;
X if (np->g_token == '=' && isfield(np->n_left))
X return 1;
X return 0;
X}
X
Xfldas(np)
Xregister NODEP np;
X{
X NODEP lp = np->n_left;
X
X np->g_fldw = lp->g_fldw;
X np->g_fldo = lp->g_fldo;
X np->g_token = FIELDAS;
X
X lp->g_fldw = 0;
X}
X
Xred_con(np)
Xregister NODEP np;
X{
X while (np->g_token == TCONV)
X np = np->n_left;
X if (np->g_token == ICON || np->g_token == FCON)
X return 1;
X return 0;
X}
END_OF_FILE
if test 15002 -ne `wc -c <'hcc/GUNK.C'`; then
echo shar: \"'hcc/GUNK.C'\" unpacked with wrong size!
fi
# end of 'hcc/GUNK.C'
fi
if test -f 'hcc/P2.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/P2.C'\"
else
echo shar: Extracting \"'hcc/P2.C'\" \(14397 characters\)
sed "s/^X//" >'hcc/P2.C' <<'END_OF_FILE'
X/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
X *
X * Permission is granted to anyone to use this software for any purpose
X * on any computer system, and to redistribute it freely, with the
X * following restrictions:
X * 1) No charge may be made other than reasonable charges for reproduction.
X * 2) Modified versions must be clearly marked as such.
X * 3) The authors are not responsible for any harmful consequences
X * of using this software, even if they result from defects in it.
X *
X * p2.c
X *
X * Expression tree routines.
X *
X * Constant folding, typing of nodes, simple transformations.
X */
X
X#include <stdio.h>
X#include "param.h"
X#include "tok.h"
X#include "nodes.h"
X#include "cookie.h"
X
X#if MMCC
Xoverlay "pass2"
X#endif
X
Xextern int xflags[];
X#define debug xflags['t'-'a']
X
Xextern nmerrors;
XNODEP bas_type();
X
Xdo_expr(np, cookie)
XNODE *np;
X{
X if (np == NULL)
X return;
X/* include if want only one error at a time
X if (nmerrors) {
X freenode(np);
X return;
X }
X*/
X p2_expr(&np);
X genx(np, cookie);
X}
X
Xp2_expr(npp)
XNODEP *npp;
X{
X NODEP np = *npp;
X
X if (np == NULL) return;
X if (debug > 1) {
X printf("P2 enter");
X printnode(np);
X }
X confold(npp,0);
X np = *npp;
X form_types(np);
X if (debug) {
X printf("p2_expr");
X printnode(np);
X }
X return;
X}
X
Xform_types(np)
XNODEP np;
X{
X
X if (np == NULL) return;
X switch (np->e_type) {
X case E_SPEC:
X switch (np->e_token) { /* special cases */
X case '.':
X case ARROW:
X form_types(np->n_left);
X sel_type(np);
X return;
X case '(':
X if (np->n_right) {
X form_types(np->n_right); /* args */
X np->e_type = E_BIN;
X } else
X np->e_type = E_UNARY;
X fun_type(np);
X return;
X }
X /* fall through */
X case E_BIN:
X form_types(np->n_left);
X form_types(np->n_right);
X b_types(np);
X break;
X
X case E_UNARY:
X form_types(np->n_left);
X u_types(np);
X break;
X
X case E_LEAF:
X l_types(np);
X break;
X }
X}
X
X/* (fun) (args) */
Xfun_type(np)
XNODEP np;
X{
X NODEP lp, typ;
X NODEP allsyms(), new_fun();
X
X lp = np->n_left;
X if (lp->e_token == ID) { /* may be new ID */
X typ = allsyms(lp);
X if (typ == NULL)
X typ = new_fun(lp);
X typ = typ->n_tptr;
X lp->n_tptr = typ;
X lp->n_flags |= N_COPYT;
X } else {
X form_types(lp);
X typ = lp->n_tptr;
X }
X if (typ->t_token != '(') { /* fun ret ? */
X error("call non-fun");
X goto bad;
X }
X typ = typ->n_tptr;
X goto good;
Xbad:
X typ = bas_type(K_INT);
Xgood:
X np->n_tptr = typ;
X np->n_flags |= N_COPYT;
X}
X
X/* (struct|union) (. or ->) ID */
Xsel_type(xp)
XNODEP xp;
X{
X NODEP np, sup;
X int tok;
X NODEP rv;
X NODEP llook();
X
X np = xp->n_right;
X sup = xp->n_left->n_tptr;
X tok = xp->e_token;
X
X/* already checked that np->e_token == ID */
X if (tok == ARROW) {
X if (sup->t_token != STAR) {
X error("(non pointer)->");
X goto bad;
X }
X sup = sup->n_tptr;
X }
X if (sup->t_token != K_STRUCT && sup->t_token != K_UNION) {
X error("select non-struct");
X goto bad;
X }
X rv = llook(sup->n_right, np);
X if (rv == NULL) {
X error("? member ID");
X goto bad;
X }
X xp->e_offs = rv->e_offs;
X if (rv->e_fldw) {
X xp->e_fldw = rv->e_fldw;
X xp->e_fldo = rv->e_fldo;
X }
X rv = rv->n_tptr;
X goto good;
Xbad:
X rv = bas_type(K_INT);
Xgood:
X xp->n_tptr = rv;
X xp->n_flags |= N_COPYT;
X
X /* change to UNARY op */
X xp->e_type = E_UNARY;
X freenode(np);
X xp->n_right = NULL;
X
X /* change ARY OF to PTR TO */
X if (rv->t_token == '[')
X see_array(xp);
X}
X
Xl_types(np)
Xregister NODE *np;
X{
X NODEP allsyms();
X register NODE *tp;
X
X switch (np->e_token) {
X case ID: /* already did see_id */
X if (np->n_tptr->t_token == '[') /* change to &ID */
X see_array(np);
X return;
X case ICON:
X tp = bas_type(icon_ty(np));
X break;
X case FCON:
X tp = bas_type(K_DOUBLE);
X break;
X case SCON:
X tp = bas_type(SCON);
X break;
X default:
X errors("Weird leaf",np->n_name);
X bad:
X tp = bas_type(K_INT);
X }
X np->n_tptr = tp;
X np->n_flags |= N_COPYT;
X}
X
Xu_types(np)
XNODEP np;
X{
X NODEP tp;
X NODEP lp = np->n_left;
X NODEP normalty();
X
X tp = lp->n_tptr; /* default */
X
X switch (np->e_token) {
X case DOUBLE '+':
X case DOUBLE '-':
X case POSTINC:
X case POSTDEC:
X mustlval(lp);
X mustty(lp, R_SCALAR);
X if (tp->t_token == STAR)
X np->e_offs = tp->n_tptr->t_size;
X else
X np->e_offs = 1;
X break;
X case STAR:
X if (mustty(lp, R_POINTER)) goto bad;
X tp = tp->n_tptr;
X np->n_tptr = tp;
X np->n_flags |= N_COPYT;
X
X /* Ary of to Ptr to */
X if (tp->t_token == '[')
X see_array(np);
X return;
X case UNARY '&':
X mustlval(lp);
X tp = allocnode();
X tp->n_tptr = lp->n_tptr;
X tp->n_flags |= N_COPYT;
X tp->t_token = STAR;
X sprintf(tp->n_name, "Ptr to");
X tp->t_size = SIZE_P;
X np->n_tptr = tp;
X return; /* no COPYT */
X case UNARY '-':
X mustty(lp, R_ARITH);
X tp = normalty(lp, NULL);
X break;
X case TCONV:
X mustty(lp, R_SCALAR);
X if (np->n_tptr->t_token != K_VOID)
X mustty(np, R_SCALAR);
X return; /* type already specified */
X case '!':
X mustty(lp, R_SCALAR);
X tp = bas_type(K_INT);
X break;
X case '~':
X mustty(lp, R_INTEGRAL);
X tp = normalty(lp, NULL);
X break;
X default:
X error("bad unary type");
X bad:
X tp = bas_type(K_INT);
X }
X np->n_tptr = tp;
X np->n_flags |= N_COPYT;
X}
X
Xb_types(np)
XNODEP np;
X{
X NODEP tp;
X NODEP lp, rp;
X NODEP normalty(), addty(), colonty();
X int op;
X
X op = np->e_token;
X if (isassign(op)) {
X mustlval(np->n_left);
X op -= (ASSIGN 0);
X }
X
X lp = np->n_left;
X rp = np->n_right;
X tp = bas_type(K_INT);
X switch (op) {
X case '*':
X case '/':
X mustty(lp, R_ARITH);
X mustty(rp, R_ARITH);
X tp = normalty(lp,rp);
X break;
X case '%':
X case '&':
X case '|':
X case '^':
X mustty(lp, R_INTEGRAL);
X mustty(rp, R_INTEGRAL);
X tp = normalty(lp,rp);
X break;
X case '+':
X case '-':
X mustty(lp, R_SCALAR);
X mustty(rp, R_SCALAR);
X tp = addty(np);
X break;
X case DOUBLE '<':
X case DOUBLE '>':
X mustty(lp, R_INTEGRAL);
X mustty(rp, R_INTEGRAL);
X tp = normalty(lp, NULL);
X break;
X case '<':
X case '>':
X case LTEQ:
X case GTEQ:
X case DOUBLE '=':
X case NOTEQ:
X mustty(lp, R_SCALAR);
X mustty(rp, R_SCALAR);
X chkcmp(np);
X break; /* INT */
X case DOUBLE '&':
X case DOUBLE '|':
X mustty(lp, R_SCALAR);
X mustty(rp, R_SCALAR);
X break; /* INT */
X case '?':
X mustty(lp, R_SCALAR);
X tp = rp->n_tptr;
X break;
X case ':':
X if (same_type(lp->n_tptr, rp->n_tptr)) {
X tp = lp->n_tptr;
X break;
X }
X mustty(lp, R_SCALAR);
X mustty(rp, R_SCALAR);
X tp = colonty(np);
X break;
X case '=':
X mustlval(lp);
X mustty(lp, R_ASSN);
X asn_chk(lp->n_tptr, rp);
X tp = lp->n_tptr;
X break;
X case ',':
X tp = rp->n_tptr;
X break;
X default:
X error("bad binary type");
X bad:
X tp = bas_type(K_INT);
X }
X if (isassign(np->e_token)) {
X /* ignore normal result -- result is left type */
X tp = lp->n_tptr;
X }
X np->n_tptr = tp;
X np->n_flags |= N_COPYT;
X}
X
Xlong
Xconlval(np)
XNODEP np;
X{
X long i;
X
X confold(&np,0);
X if (np->e_token == ICON) {
X i = np->e_ival;
X freenode(np);
X return i;
X }
X error("need const expr");
X return 0;
X}
X
Xconxval(np)
XNODEP np;
X{
X return (int)conlval(np);
X}
X
Xconfold(npp,spec)
XNODEP *npp;
X{
X NODEP np;
X NODEP tp, onp;
X int tok,spl,spr;
X long l;
X
X np = *npp;
X if (np == NULL) return;
X switch (np->e_type) {
X case E_LEAF:
X lcanon(np,spec);
X return;
X case E_UNARY:
X confold(&np->n_left,0);
X ucanon(np);
X return;
X case E_BIN:
X confold(&np->n_left,0);
X /* delay confold on the right tree */
X switch (np->e_token) {
X case DOUBLE '|':
X l = np->n_left->e_ival;
X tp = np;
X goto l_or_r;
X case DOUBLE '&':
X l = ! np->n_left->e_ival;
X tp = np;
X goto l_or_r;
X case '?':
X l = np->n_left->e_ival;
X tp = np->n_right; /* ':' node */
X l_or_r:
X tok = np->n_left->e_token;
X if (tok != ICON) {
X confold(&np->n_right,0);
X return;
X }
X onp = np;
X if (l) { /* take true side */
X np = tp->n_left;
X tp->n_left = NULL;
X } else { /* take false side */
X np = tp->n_right;
X tp->n_right = NULL;
X }
X freenode(onp);
X confold(&np,0);
X *npp = np;
X return;
X }
X confold(&np->n_right,0);
X bcanon(np);
X if (np->e_flags & C_AND_A)
X b_assoc(np);
X return;
X case E_SPEC:
X tok = np->e_token;
X spl = spr = 0;
X switch (tok) {
X case '(':
X spl = tok; /* new name allowed */
X break;
X case '.':
X case ARROW:
X spr = tok; /* look in struct sym.tab. */
X break;
X }
X confold(&np->n_left,spl);
X confold(&np->n_right,spr);
X return;
X }
X}
X
Xnewicon(np,x,nf)
XNODE *np;
Xlong x;
X{
X np->e_token = ICON;
X np->e_ival = x;
X np->e_flags = nf;
X sprintf(np->n_name, "%ld", x);
X np->e_type = E_LEAF;
X if (np->n_left) {
X freenode(np->n_left);
X np->n_left = NULL;
X }
X if (np->n_right) {
X freenode(np->n_right);
X np->n_right = NULL;
X }
X}
X
Xnewfcon(np,x,nf)
XNODE *np;
Xdouble x;
X{
X np->e_token = FCON;
X np->e_fval = x;
X np->e_flags = nf;
X sprintf(np->n_name, FLTFORM, x);
X np->e_type = E_LEAF;
X if (np->n_left) {
X freenode(np->n_left);
X np->n_left = NULL;
X }
X if (np->n_right) {
X freenode(np->n_right);
X np->n_right = NULL;
X }
X}
X
X/* LEAF */
X/* sptok is token if E_SPEC node is parent
X and dont want to look at ID yet */
Xlcanon(np,sptok)
XNODE *np;
X{
X NODE *tp;
X NODEP allsyms();
X long x;
X
X if (np->e_token == ID) {
X if (sptok)
X return;
X see_id(np);
X return;
X }
X if (np->e_token == TSIZEOF) {
X tp = np->n_tptr;
X x = tp->t_size;
X np->n_tptr = NULL;
X if ((np->n_flags & N_COPYT) == 0)
X freenode(tp);
X newicon(np, x, 0);
X }
X}
X
X/* UNARY */
Xucanon(np)
XNODE *np;
X{
X NODE *tp;
X long x,l;
X int lflags = 0;
X
X if (np->e_token == K_SIZEOF) {
X tp = np->n_left;
X confold(&tp,0);
X form_types(tp);
X tp = tp->n_tptr;
X x = tp->t_size;
X goto out;
X }
X
X if (np->n_left->e_token == FCON) {
X if (np->e_token == UNARY '-')
X newfcon(np, -(np->n_left->e_fval));
X return;
X }
X if (np->n_left->e_token != ICON)
X return;
X l = np->n_left->e_ival;
X lflags = np->n_left->e_flags;
X switch (np->e_token) {
X case UNARY '-':
X x = -l; break;
X case '~':
X x = ~l; break;
X case '!':
X x = !l; break;
X default:
X return;
X }
Xout:
X newicon(np, x, lflags);
X}
X
Xbcanon(np)
Xregister NODE *np;
X{
X int ltok, rtok;
X double l,r;
X NODEP tp;
X
X ltok = np->n_left->e_token;
X rtok = np->n_right->e_token;
X if (ltok != ICON && ltok != FCON)
X return;
X if (rtok != ICON && rtok != FCON) {
X /* left is ?CON, right is not */
X if (np->e_flags & (C_AND_A|C_NOT_A)) {
X /* reverse sides - put CON on right */
X tp = np->n_left;
X np->n_left = np->n_right;
X np->n_right = tp;
X if (np->e_flags & C_NOT_A)
X swt_op(np);
X }
X return;
X }
X if (ltok == ICON && rtok == ICON) {
X b2i(np);
X return;
X }
X if (ltok == FCON)
X l = np->n_left->e_fval;
X else
X l = (double)np->n_left->e_ival;
X if (rtok == FCON)
X r = np->n_right->e_fval;
X else
X r = (double)np->n_right->e_ival;
X b2f(np,l,r);
X}
X
X/* canon for assoc. & comm. op */
X/* this code will almost never be executed, but it was fun. */
Xb_assoc(np)
XNODEP np;
X{
X NODEP lp, rp;
X int tok;
X
X lp = np->n_left;
X if (lp->e_token != np->e_token)
X return;
X /* left is same op as np */
X rp = np->n_right;
X tok = lp->n_right->e_token;
X if (tok != ICON && tok != FCON)
X return;
X /* left.right is ?CON */
X tok = rp->e_token;
X if (tok == ICON || tok == FCON) {
X /* have 2 CONS l.r and r -- put together on r */
X NODEP ep;
X ep = lp->n_left;
X np->n_left = ep;
X np->n_right = lp;
X lp->n_left = rp;
X /* can now fold 2 CONS */
X bcanon(lp);
X } else {
X /* have 1 CON at l.r -- move to top right */
X NODEP kp;
X kp = lp->n_right;
X lp->n_right = rp;
X np->n_right = kp;
X }
X}
X
X/* switch pseudo-commutative op */
Xswt_op(np)
XNODEP np;
X{
X int newtok;
X char *newnm;
X
X switch (np->e_token) {
X case '<': newtok = '>'; newnm = ">"; break;
X case '>': newtok = '<'; newnm = "<"; break;
X case LTEQ: newtok = GTEQ; newnm = ">="; break;
X case GTEQ: newtok = LTEQ; newnm = "<="; break;
X default:
X return;
X }
X np->e_token = newtok;
X strcpy(np->n_name, newnm);
X}
X
X/* BINARY 2 ICON's */
Xb2i(np)
Xregister NODE *np;
X{
X register long l,r,x;
X int newflags,lflags;
X
X newflags = 0;
X
X r = np->n_right->e_ival;
X newflags = np->n_right->e_flags;
X
X l = np->n_left->e_ival;
X lflags = np->n_left->e_flags;
X newflags = newflags>lflags ? newflags : lflags;
X
X switch (np->e_token) {
X case '+':
X x = l+r; break;
X case '-':
X x = l-r; break;
X case '*':
X x = l*r; break;
X case '/':
X x = l/r; break;
X case '%':
X x = l%r; break;
X case '>':
X x = l>r; break;
X case '<':
X x = l<r; break;
X case LTEQ:
X x = l<=r; break;
X case GTEQ:
X x = l>=r; break;
X case DOUBLE '=':
X x = l==r; break;
X case NOTEQ:
X x = l!=r; break;
X case '&':
X x = l&r; break;
X case '|':
X x = l|r; break;
X case '^':
X x = l^r; break;
X case DOUBLE '<':
X x = l<<r; break;
X case DOUBLE '>':
X x = l>>r; break;
X default:
X return;
X }
X newicon(np, x, newflags);
X}
X
X/* BINARY 2 FCON's */
Xb2f(np,l,r)
Xregister NODE *np;
Xdouble l,r;
X{
X register double x;
X int ix, isint;
X
X isint = 0;
X
X switch (np->e_token) {
X case '+':
X x = l+r; break;
X case '-':
X x = l-r; break;
X case '*':
X x = l*r; break;
X case '/':
X x = l/r; break;
X case '>':
X ix = l>r; isint++; break;
X case '<':
X ix = l<r; isint++; break;
X case LTEQ:
X ix = l>=r; isint++; break;
X case GTEQ:
X ix = l<=r; isint++; break;
X case DOUBLE '=':
X ix = l==r; isint++; break;
X case NOTEQ:
X ix = l!=r; isint++; break;
X default:
X return;
X }
X if (isint)
X newicon(np, (long)ix, 0);
X else
X newfcon(np, x);
X}
X
Xsame_type(a,b)
Xregister NODE *a, *b;
X{
Xmore:
X if (a == b)
X return 1;
X if (a == NULL || b == NULL)
X return 0;
X if (a->t_token != b->t_token)
X return 0;
X if (a->t_token != STAR && a->t_size != b->t_size)
X return 0;
X a = a->n_tptr;
X b = b->n_tptr;
X goto more;
X}
X
Xsee_id(np)
XNODEP np;
X{
X NODEP tp;
X NODEP allsyms(), def_type();
X
X tp = allsyms(np);
X if (tp == NULL) {
X errorn("undefined:", np);
X tp = def_type();
X goto out;
X }
X switch (tp->e_sc) {
X case ENUM_SC:
X newicon(np, tp->e_ival, 0);
X return;
X case K_REGISTER:
X np->e_rno = tp->e_rno;
X /* fall through */
X default:
X np->e_sc = tp->e_sc;
X np->e_offs = tp->e_offs;
X tp = tp->n_tptr;
X }
Xout:
X np->n_tptr = tp;
X np->n_flags |= N_COPYT;
X
X /* special conversions */
X if (tp->t_token == '(')
X insptrto(np);
X}
X
Xinsptrto(np)
XNODEP np;
X{
X NODEP op, copyone();
X
X op = copyone(np);
X
X np->n_left = op;
X np->e_token = UNARY '&';
X np->e_type = E_UNARY;
X strcpy(np->n_name, "&fun");
X np->n_flags &= ~N_COPYT;
X}
X
X/* np points to ID or STAR or '.' node
X tptr is a COPY
X tptr token is '[' */
X
Xsee_array(np)
XNODEP np;
X{
X NODEP tp, copyone();
X
X tp = copyone(np);
X tp->n_left = np->n_left;
X tp->n_tptr = tp->n_tptr->n_tptr;
X
X np->n_left = tp;
X np->e_token = UNARY '&';
X np->e_type = E_UNARY;
X strcpy(np->n_name, "&ary");
X arytoptr(np);
X/* leave old size
X np->n_tptr->t_size = SIZE_P;
X*/
X}
END_OF_FILE
if test 14397 -ne `wc -c <'hcc/P2.C'`; then
echo shar: \"'hcc/P2.C'\" unpacked with wrong size!
fi
# end of 'hcc/P2.C'
fi
if test -f 'hcc/PRE.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/PRE.C'\"
else
echo shar: Extracting \"'hcc/PRE.C'\" \(14315 characters\)
sed "s/^X//" >'hcc/PRE.C' <<'END_OF_FILE'
X/* Copyright (c) 1988 by Sozobon, Limited. Author: Johann Ruegg
X *
X * Permission is granted to anyone to use this software for any purpose
X * on any computer system, and to redistribute it freely, with the
X * following restrictions:
X * 1) No charge may be made other than reasonable charges for reproduction.
X * 2) Modified versions must be clearly marked as such.
X * 3) The authors are not responsible for any harmful consequences
X * of using this software, even if they result from defects in it.
X *
X * pre.c
X *
X * preprocessor for the compiler
X *
X * Handles all preprocessor (#) commands and
X * looks up keywords
X *
X * Interface:
X * getnode() returns next "token node"
X */
X
X#include <stdio.h>
X#include "param.h"
X#include "tok.h"
X#include "nodes.h"
X
X#if CC68
XFILE *fopenb();
X#define fopen fopenb
X#endif
X
Xextern struct tok curtok;
Xextern char curstr[];
X
X#define TK_SEENL 1 /* want to see NL token */
X#define TK_SEEWS 2 /* want to see WS token */
X#define TK_ONLY1 4 /* only want 1st token on line */
X#define TK_LTSTR 8 /* '<' starts a string */
X#define TK_NOESC 16 /* dont do '\' escapes in string */
X
Xextern int tk_flags, sawnl;
X
X#ifndef ACK_HOST
XNODE *deflist[NHASH];
XNODE *holdtok;
Xint iflevel, iftruth, ifnest, in_if_x, skip_id;
X#else
X#if PART_1
XNODE *deflist[NHASH];
XNODE *holdtok;
Xextern int iflevel, iftruth, ifnest, in_if_x, skip_id;
X#else
Xextern NODE *deflist[NHASH];
Xextern NODE *holdtok;
Xint iflevel, iftruth, ifnest, in_if_x, skip_id;
X#endif
X#endif
X
Xextern lineno;
Xextern char *inname;
Xextern FILE *input;
X
XNODE *hlook(), *llook();
XNODEP tok_to_node();
XNODE *copylist();
X
X#ifdef DEBUG
Xextern int oflags[];
X#define debugd oflags['d'-'a']
X#define debugt oflags['t'-'a']
X#endif
X
X#ifndef ACK_HOST
X#define PART_1 1
X#define PART_2 1
X#endif
X
X#if PART_1
X
XNODEP
Xhi_node()
X{
X register NODEP rv;
X
X /* node from hold queue ? */
X if (holdtok) {
X#ifdef DEBUG
X if (debugd > 2) {
X printf("Holdqueue");
X printnode(holdtok);
X }
X#endif
X rv = holdtok;
X holdtok = rv->n_next;
X rv->n_next = NULL;
X return rv;
X }
X /* node from input */
Xagain:
X while (iflevel && !iftruth)
X skiplines();
X if (nxttok()==0)
X return NULL;
X if (curtok.tnum == '#') {
X dopound(0);
X goto again;
X }
X rv = tok_to_node();
X return rv;
X}
X
XNODEP
Xgetnode()
X{
X register NODEP rv;
X NODEP dp;
X
Xagain:
X rv = hi_node();
X if (rv == NULL) {
X rv = allocnode();
X rv->e_token = EOFTOK;
X strcpy(rv->n_name, "*EOF*");
X } else
X if (rv->e_token == ID) {
X if (in_if_x && strcmp(rv->n_name, "defined") == 0) {
X skip_id = 1;
X goto out;
X }
X if (skip_id) {
X skip_id = 0;
X goto out;
X }
X if ((dp = hlook(deflist, rv)) != NULL) {
X expand(dp);
X freenode(rv);
X goto again;
X } else if (rv->n_name[0] == '_' && builtin(rv))
X return rv;
X else
X kw_tok(rv);
X }
Xout:
X#ifdef DEBUG
X if (debugt) {
X putchar('[');
X put_nnm(rv);
X printf("] ");
X }
X#endif
X return rv;
X}
X
Xbuiltin(np)
Xregister NODEP np;
X{
X int rv;
X
X if (strcmp(np->n_name, "__LINE__") == 0) {
X np->e_token = ICON;
X np->e_ival = lineno;
X return 1;
X }
X else if (strcmp(np->n_name, "__FILE__") == 0) {
X np->e_token = SCON;
X nscpy(np, inname);
X return 1;
X }
X return 0;
X}
X
Xskiplines()
X{
X for (;;) {
X if (nxttok()== 0)
X return;
X if (curtok.tnum == '#') {
X dopound(1);
X return;
X }
X tk_flags |= TK_ONLY1;
X }
X}
X
Xstatic defnargs;
X
Xp_def()
X{
X NODE *args;
X NODE *val;
X NODE *def;
X NODE *def_rgs(), *def_val();
X
X defnargs = -1;
X args = NULL;
X val = NULL;
X nxttok();
X if (curtok.tnum != ID) {
X error("bad #define");
X goto flush;
X }
X def = tok_to_node();
X
X tk_flags |= TK_SEEWS;
X nxttok();
X switch (curtok.tnum) {
X case '(':
X defnargs = 0;
X args = def_rgs();
X case WS:
X goto getval;
X case NL:
X goto dodef;
X default:
X error("bad #define");
X goto flush;
X }
Xgetval:
X val = def_val();
Xdodef:
X def->e_ival = defnargs;
X define(def, val, args);
Xflush:
X ;
X}
X
Xoptdef(s,as)
Xchar *s, *as;
X{
X NODEP val;
X NODEP def;
X NODEP id_tok(), def_val();
X
X defnargs = -1;
X val = NULL;
X
X def = id_tok(s);
X chr_push(as);
X
X tk_flags |= TK_SEENL;
X
X val = def_val();
X
X tk_flags = 0;
X
X def->e_ival = defnargs;
X define(def, val, NULL);
X}
X
X/*
Xoptundef(s)
Xchar *s;
X{
X NODEP np, tp, id_tok();
X
X np = id_tok(s);
X tp = hlook(deflist, np);
X if (tp != NULL)
X tp->n_name[0] = '#';
X freenode(np);
X}
X*/
X
Xsamedef(p1, p2)
XNODEP p1, p2;
X{
X if (p1->e_ival != p2->e_ival)
X return 0;
X return same_list(p1->n_right, p2->n_right);
X}
X
Xsame_list(p1, p2)
XNODEP p1, p2;
X{
X if (p1 == NULL)
X return p2 == NULL;
X if (p2 == NULL)
X return 0;
X if (l_cmp(p1, p2, sizeof(*p1)/sizeof(long)) != 0)
X return 0;
X return same_list(p1->n_left, p2->n_left);
X}
X
Xl_cmp(p1, p2, n)
XNODE *p1, *p2;
X{
X if (xstrcmp(p1,p2) != 0)
X return 1;
X if (p1->e_token != p2->e_token ||
X p1->e_ival != p2->e_ival)
X return 1;
X return 0;
X}
X
Xdefine(def, val, args)
XNODEP def, val, args;
X{
X NODEP oldp;
X
X if (args != NULL) {
X argsmod(val, args);
X freenode(args);
X }
X def->n_right = val;
X if ((oldp = hlook(deflist, def)) != NULL) {
X if (!samedef(oldp, def))
X warnn("redefined", def);
X }
X#ifdef DEBUG
X if (debugd) {
X printf("define (%d args)", (int)def->e_ival);
X printnode(def);
X }
X#endif
X puthlist(deflist, def);
X}
X
Xargsmod(toks, args)
XNODEP toks, args;
X{
X register NODE *np, *vp;
X
X for (np=toks; np != NULL; np = np->n_next)
X if (np->e_token == ID) {
X vp = llook(args,np);
X if (vp != NULL) {
X np->e_token = DPARAM;
X np->e_ival = vp->e_ival;
X sprintf(np->n_name, "\\%d", (int)np->e_ival);
X }
X }
X}
X
XNODE *
Xdef_rgs()
X{
X NODE *rv;
X NODE *tail;
X NODE *np;
X
X rv = NULL;
X tail = NULL;
X nxttok();
X if (curtok.tnum == ')') {
X goto out;
X }
Xmore:
X if (curtok.tnum != ID) {
X error("expect ID");
X goto bad;
X }
X np = tok_to_node();
X np->e_ival = defnargs; /* hold sequence number */
X defnargs++;
X if (tail == NULL) { /* first one */
X rv = np;
X tail = np;
X } else { /* more */
X tail->n_next = np;
X tail = np;
X }
X nxttok();
X if (curtok.tnum == ',') {
X nxttok();
X goto more;
X }
X if (curtok.tnum == ')')
X goto out;
X error("define arg syntax");
Xbad:
X freenode(rv);
X rv = NULL;
X defnargs = 0;
Xout:
X return rv;
X}
X
XNODE *
Xdef_val()
X{
X NODE *rv;
X NODE *tail;
X NODE *np;
X
X rv = NULL;
X tail = NULL;
Xmore:
X nxttok();
X if (curtok.tnum == NL) {
X goto out;
X/*
X } else if (curtok.tnum == '\\') {
X nxttok();
X if (curtok.tnum != NL)
X goto bad;
X goto more;
X*/
X }
X np = tok_to_node();
X if (tail == NULL) { /* first one */
X rv = np;
X tail = np;
X } else { /* more */
X tail->n_next = np;
X tail = np;
X }
X goto more;
X
Xbad:
X freenode(rv);
X rv = NULL;
Xout:
X return rv;
X}
X
XNODE *
Xgath1(sep)
Xint *sep;
X{
X NODE *np, *rv, *tail;
X int inparen;
X
X inparen = 0;
X rv = NULL;
X tail = NULL;
Xmore:
X np = hi_node();
X if (np == NULL) {
X goto bad;
X }
X switch (np->e_token) {
X case ')':
X case ',':
X if (inparen) { /* dont end, part of subexpr */
X if (np->e_token == ')')
X inparen--;
X break;
X }
X *sep = np->e_token;
X freenode(np);
X goto out;
X case '(':
X inparen++;
X break;
X }
X if (tail == NULL) { /* first one */
X rv = np;
X tail = np;
X } else { /* more */
X tail->n_next = np;
X tail = np;
X }
X goto more;
Xbad:
X freenode(rv);
X rv = NULL;
X *sep = 0;
Xout:
X return rv;
X}
X
XNODE *
Xgath_args(n)
X{
X NODE *rv;
X NODE *tail;
X NODE *np;
X int sep;
X int getn;
X
X getn = 0;
X rv = NULL;
X tail = NULL;
X np = hi_node();
X if (np->e_token != '(') {
X error("expect (");
X goto bad;
X }
X freenode(np);
X if (n == 0) {
X np = hi_node();
X if (np->e_token != ')') {
X error("expect )");
X goto bad;
X }
X freenode(np);
X return NULL;
X }
Xmore:
X np = gath1(&sep);
X if (np == NULL) {
X error("expect arg");
X goto bad;
X }
X getn++;
X if (tail == NULL) { /* first one */
X rv = np;
X tail = np;
X } else { /* more */
X tail->n_right = np;
X tail = np;
X }
X if (sep) switch (sep) {
X case ',':
X goto more;
X case ')':
X if (getn != n) {
X error("arg num mismatch");
X goto bad;
X }
X goto out;
X }
X error("expand arg syntax");
Xbad:
X freenode(rv);
X rv = NULL;
Xout:
X return rv;
X}
X
XNODE *
Xargfix(val, args, rt)
XNODE *val, *args;
XNODE **rt;
X{
X register NODE *scan, *sub;
X NODE *head;
X NODE *tail, *back;
X NODE *rthnode();
X NODE *copylist();
X
X head = val;
X back = NULL;
X for (scan = val; scan != NULL; back=scan, scan=scan->n_next)
X if (scan->e_token == DPARAM) {
X sub = rthnode(args, (int)scan->e_ival);
X sub = copylist(sub,&tail);
X if (back) {
X back->n_next = sub;
X tail->n_next = scan->n_next;
X } else {
X head = sub;
X tail->n_next = scan->n_next;
X }
X scan->n_next = NULL;
X freenode(scan);
X scan = tail;
X }
X *rt = back;
X return head;
X}
X
Xexpand(dp)
XNODEP dp;
X{
X int nargs;
X NODEP args;
X register NODEP val;
X NODEP tail;
X
X val = dp->n_right;
X if (val)
X val = copylist(val, &tail);
X nargs = dp->e_ival;
X if (nargs >= 0) {
X args = gath_args(nargs);
X if (args) {
X if (val)
X val = argfix(val,args,&tail);
X freenode(args);
X }
X }
X if (val == NULL)
X return;
X#ifdef DEBUG
X if (debugd > 1) {
X printf("Expand");
X printnode(val);
X }
X#endif
X tail->n_next = holdtok;
X holdtok = val;
X}
X
Xp_undef()
X{
X NODEP np, tp;
X
X nxttok();
X if (curtok.tnum != ID) {
X error("bad #undef");
X goto out;
X }
X tp = tok_to_node();
X if ((np = hlook(deflist, tp)) != NULL)
X /* quick and dirty */
X np->n_name[0] = '#';
X freenode(tp);
Xout:
X ;
X}
X
X#endif
X#if PART_2
X
Xp_inc()
X{
X int chkhere;
X FILE *newf, *srch_open();
X char *scopy(), *newnm;
X
X tk_flags |= TK_NOESC|TK_LTSTR;
X nxttok();
X switch (curtok.tnum) {
X case SCON:
X chkhere = 1;
X break;
X case SCON2:
X chkhere = 0;
X break;
X case NL:
X case EOF:
X error("bad #include");
X return;
X }
X newf = srch_open(curstr, chkhere);
X if (newf == NULL) {
X fatals("Cant open ", curstr);
X return;
X }
X newnm = scopy(curstr);
X do
X nxttok();
X while (curtok.tnum != NL);
X newfile(newf,newnm);
X}
X
Xint inclvl;
Xstruct svinc {
X int lineno;
X FILE *fd;
X char *filenm;
X} svincs[MAXINCL];
X
X#if NEEDBUF
Xchar p_buf[MAXINCL][BUFSIZ];
X#endif
X
Xstatic char obuf[MAXSTR];
X
Xnewfile(fd,s)
XFILE *fd;
Xchar *s;
X{
X register struct svinc *p;
X
X inclvl++;
X if (inclvl > MAXINCL) {
X inclvl--;
X fclose(fd);
X error("too many includes");
X return;
X }
X p = &svincs[inclvl-1];
X p->lineno = lineno;
X p->fd = input;
X p->filenm = inname;
X input = fd;
X lineno = 1;
X inname = s;
X#if NEEDBUF
X setbuf(input, p_buf[inclvl-1]);
X#endif
X}
X
Xendfile()
X{
X register struct svinc *p;
X
X if (inclvl == 0)
X return 0;
X fclose(input);
X inclvl--;
X p = &svincs[inclvl];
X sfree(inname);
X input = p->fd;
X lineno = p->lineno;
X inname = p->filenm;
X return 1;
X}
X
X#define MAXIDIR 10
X
X#ifndef FOR_AMIGA
X#ifndef MINIX
Xchar *srchlist[MAXIDIR] = {
X "",
X "\\include\\",
X "\\sozobon\\include\\",
X "",
X 0
X};
Xstatic int idir_n = 4; /* number of entries in above table */
X#else
Xchar *srchlist[MAXIDIR] = {
X "",
X "/usr/include/",
X 0
X};
Xstatic int idir_n = 2;
X#endif
X#else
Xchar *srchlist[MAXIDIR] = {
X "",
X "include:",
X 0
X};
Xstatic int idir_n = 2; /* number of entries in above table */
X#endif
X
Xstatic int idir_put = 1; /* where to put -I dirs */
X
Xoptincl(s)
Xchar *s;
X{
X register char **pp;
X
X if (idir_n >= MAXIDIR-1) {
X warn("too many -I dirs");
X return;
X }
X for (pp = &srchlist[idir_n]; pp > &srchlist[idir_put]; ) {
X pp--;
X pp[1] = pp[0];
X }
X *pp = s;
X idir_put++;
X idir_n++;
X}
X
XFILE *
Xsrch_open(s, chkhere)
Xchar *s;
X{
X char **dir;
X FILE *fd;
X
X dir = srchlist;
X if (chkhere == 0) dir++;
X while (*dir) {
X strcpy(obuf, *dir);
X strcat(obuf, s);
X fd = fopen(obuf, ROPEN);
X if (fd != NULL) {
X return fd;
X }
X dir++;
X }
X return NULL;
X}
X
Xp_if(kind,skipping)
X{
X int truth;
X NODEP tp;
X
X if (skipping) {
X ifnest++;
X return;
X }
X switch (kind) {
X case 0:
X truth = if_expr();
X break;
X case 1:
X case 2:
X nxttok();
X if (curtok.tnum != ID) {
X error("bad #if(n)def");
X goto flush;
X }
X tp = tok_to_node();
X truth = (hlook(deflist, tp) != NULL);
X freenode(tp);
X if (kind == 2)
X truth = !truth;
X }
X iflevel++;
X iftruth = truth;
Xflush:
X ;
X}
X
Xif_expr()
X{
X NODE *tp, *questx();
X extern NODE *cur;
X int rv;
X
X in_if_x = 1;
X skip_id = 0;
X advnode();
X tp = questx();
X in_if_x = 0;
X skip_id = 0;
X if (tp) {
X pnames(tp);
X rv = conxval(tp);
X } else
X rv = 0;
X if (cur->e_token != NL) {
X error("bad #if");
X } else
X freenode(cur);
X return rv;
X}
X
Xpnames(np)
Xregister NODEP np;
X{
Xagain:
X if (np->e_token == ID) {
X np->e_token = ICON;
X np->e_ival = 0;
X } else if (np->e_token == '(') {
X NODEP rp, lp;
X int truth;
X
X rp = np->n_right;
X lp = np->n_left;
X if (lp->e_token == ID && strcmp(lp->n_name, "defined") == 0
X && rp && rp->e_token == ID) {
X truth = (hlook(deflist, rp) != NULL);
X freenode(rp);
X freenode(lp);
X np->n_left = NULL;
X np->n_right = NULL;
X np->e_token = ICON;
X np->e_ival = truth;
X }
X }
X if (np->n_right)
X pnames(np->n_right);
X np = np->n_left;
X if (np)
X goto again;
X}
X
Xp_swit(kind,skipping)
X{
X if (skipping && ifnest) {
X if (kind == 1)
X ifnest--;
X return;
X }
X if (iflevel == 0) {
X error("not in #if");
X goto out;
X }
X switch (kind) {
X case 0: /* else */
X iftruth = !iftruth;
X break;
X case 1: /* endif */
X iflevel--;
X iftruth = 1;
X break;
X }
Xout:
X ;
X}
X
Xp_line()
X{
X char *scopy();
X
X nxttok();
X if (curtok.tnum != ICON) {
X error("bad #line");
X goto flush;
X }
X tk_flags |= TK_NOESC;
X nxttok();
X if (curtok.tnum == SCON) {
X sfree(inname);
X inname = scopy(curtok.name);
X }
X lineno = curtok.ival;
Xflush:
X ;
X}
X
Xstruct cmds {
X char *name;
X int (*fun)();
X int arg;
X int skip;
X} pcmds[] = {
X {"define", p_def, 0, 1},
X {"undef", p_undef, 0, 1},
X {"include", p_inc, 0, 1},
X {"if", p_if, 0, 0},
X {"ifdef", p_if, 1, 0},
X {"ifndef", p_if, 2, 0},
X {"else", p_swit, 0, 0},
X {"endif", p_swit, 1, 0},
X {"line", p_line, 0, 1},
X {0}
X};
X
Xdopound(skipping)
X{
X register struct cmds *p;
X register char *cname;
X
X tk_flags |= TK_SEENL;
X sawnl = 0;
X nxttok();
X if (curtok.tnum != ID) {
X error("expect name");
X return;
X }
X cname = curtok.name;
X for (p=pcmds; p->name; p++)
X if (strcmp(p->name, cname) == 0) {
X if (!skipping || !p->skip)
X (*p->fun)(p->arg, skipping);
X tk_flags = 0;
X if (sawnl == 0)
X tk_flags |= TK_ONLY1;
X return;
X }
X error("bad # command");
X}
X
XNODEP
Xtok_to_node()
X{
X register struct tok *tp;
X register NODEP np;
X
X tp = &curtok;
X np = allocnode();
X np->e_token = tp->tnum;
X np->e_flags = tp->flags;
X if (tp->prec) /* binary op */
X np->e_prec = tp->prec;
X else
X switch (np->e_token) {
X case ICON:
X np->e_ival = tp->ival;
X break;
X case FCON:
X np->e_fval = tp->fval;
X break;
X }
X nscpy(np, tp->name);
X return np;
X}
X
XNODEP
Xid_tok(s)
Xchar *s;
X{
X NODEP np;
X
X np = allocnode();
X np->e_token = ID;
X nscpy(np, s);
X return np;
X}
X
X#endif
END_OF_FILE
if test 14315 -ne `wc -c <'hcc/PRE.C'`; then
echo shar: \"'hcc/PRE.C'\" unpacked with wrong size!
fi
# end of 'hcc/PRE.C'
fi
echo shar: End of archive 7 \(of 9\).
cp /dev/null ark7isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 9 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0