koreth@panarthea.ebay.sun.com (Steven Grimm) (10/25/89)
Submitted-by: ncar.ucar.edu!dunike!onecom!wldrdg!hans (Johann Ruegg)
Posting-number: Volume 2, Issue 95
Archive-name: sozobon1.2/part04
#! /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 4 (of 9)."
# Contents: hcc/D2.C hcc/DECL.C hcc/EXPR.C hcc/TOK.C
# Wrapped by koreth@panarthea on Tue Oct 24 18:40:45 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'hcc/D2.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/D2.C'\"
else
echo shar: Extracting \"'hcc/D2.C'\" \(9938 characters\)
sed "s/^X//" >'hcc/D2.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 * d2.c
X *
X * Declaration subroutines
X *
X * Mostly routines for initializations
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 NODEP cur;
Xextern NODEP symtab[];
Xextern level;
X
Xextern int oflags[];
X#define debugi oflags['i'-'a']
X
Xsu_size(lp, cp, xp, isunion)
Xregister long *lp;
Xchar *cp;
Xregister NODE *xp;
X{
X long sz;
X char al;
X
X sz = xp->n_tptr->t_size;
X al = xp->n_tptr->t_aln;
X if (isunion) {
X *lp = *lp > sz ? *lp : sz;
X } else {
X while (al & (*lp)) { /* align new field */
X (*lp)++;
X xp->e_offs++;
X }
X *lp += sz;
X }
X *cp = *cp > al ? *cp : al;
X}
X
Xlc_size(lp, rp, xp)
Xregister long *lp;
Xint *rp;
Xregister NODE *xp;
X{
X long sz;
X char al;
X long arg_size();
X#ifdef LAT_HOST
X long tsz;
X#endif
X
X if (level > 1 && xp->e_sc == K_REGISTER) {
X if (lc_reg(rp, xp))
X return;
X else
X xp->e_sc = K_AUTO;
X }
X if (xp->e_sc == K_AUTO || level == 1) {
X sz = xp->n_tptr->t_size;
X al = xp->n_tptr->t_aln;
X while (al & (*lp)) { /* align new field */
X (*lp)++;
X xp->e_offs++;
X }
X if (level == 1) {
X#ifndef LAT_HOST
X sz = arg_size(sz,xp);
X#else
X tsz = arg_size(sz,xp);
X sz = tsz;
X#endif
X xp->e_offs += ARG_BASE + *lp;
X }
X *lp += sz;
X if (level != 1)
X xp->e_offs = LOC_BASE - *lp;
X }
X}
X
Xsu_fld(lp, alp, xp, fldw, fop)
Xregister long *lp;
Xchar *alp;
Xregister NODE *xp;
Xint *fop;
X{
X if (*alp < ALN_I)
X *alp = ALN_I;
X if (fldw == 0) {
X afterfld(lp, fop);
X return;
X }
X if (fldw + *fop > 8*SIZE_I)
X afterfld(lp, fop);
X if (xp) {
X xp->e_fldw = fldw;
X xp->e_fldo = *fop;
X }
X *fop += fldw;
X}
X
Xafterfld(szp, fop)
Xlong *szp;
Xint *fop;
X{
X if (*fop) {
X *szp += SIZE_I;
X *fop = 0;
X }
X}
X
Xok_gsh(sc, np)
XNODE *np;
X{
X if (sc == K_REGISTER || sc == K_AUTO) {
X error("reg/auto outside fun");
X return 0;
X }
X return ok_ty(np, NULL);
X}
X
Xok_gx(np, endp)
XNODEP np, endp;
X{
X if (np)
X return ok_ty(np->n_tptr, endp);
X return 0;
X}
X
Xok_lsh(sc, np)
XNODE *np;
X{
X return ok_ty(np, NULL);
X}
X
Xarytoptr(np)
XNODEP np;
X{
X NODEP tp = np->n_tptr;
X NODEP copyone();
X
X if (np->n_flags & N_COPYT) { /* cant change if a dupl. */
X tp = copyone(tp);
X np->n_tptr = tp;
X np->n_flags &= ~N_COPYT;
X }
X tp->t_token = STAR;
X strcpy(tp->n_name, "Aptr to");
X}
X
Xok_lx(np,endp)
XNODEP np, endp;
X{
X if (np) {
X if (level == 1 && np->n_tptr->t_token == '[')
X arytoptr(np);
X return ok_ty(np->n_tptr, endp);
X }
X return 0;
X}
X
Xok_suh(np)
XNODEP np;
X{
X return 1;
X}
X
Xok_sux(np, endp)
XNODEP np, endp;
X{
X if (np)
X return ok_ty(np->n_tptr, endp);
X return 0;
X}
X
Xok_enx(np, endp)
XNODEP np, endp;
X{
X if (np && np->n_tptr == endp) /* no modifiers */
X return 1;
X return 0;
X}
X
Xok_cast(np, endp)
XNODEP np, endp;
X{
X if (np)
X return ok_ty(np, endp);
X return 0;
X}
X
Xok_ty(np, endp)
Xregister NODEP np, endp;
X{
X NODEP child;
X long csize;
X long conlval();
X
X if (np == endp)
X return 1;
X child = np->n_tptr;
X if (child) {
X if (ok_ty(child, endp) == 0)
X return 0;
X csize = child->t_size;
X }
X
X switch (np->t_token) {
X case STAR:
X np->t_size = SIZE_P;
X np->t_aln = ALN_P;
X break;
X case '(':
X /* size 0 okay - fun ret void */
X if (child->t_token == '[') {
X error("bad func");
X return 0;
X }
X /* size 0 */
X break;
X case '[':
X if (csize == 0) {
X error("bad array");
X return 0;
X }
X if (np->n_right) {
X csize *= conlval(np->n_right);
X np->n_right = NULL;
X np->t_size = csize;
X }
X np->t_aln = child->t_aln;
X break;
X default:
X return 1;
X }
X return 1;
X}
X
Xok_revx(rv,forcast)
XNODEP rv;
X{
X if (rv == NULL)
X return 1;
X if (forcast == 0 && rv->e_token != ID) {
X error("need ID");
X return 0;
X }
X if (forcast && rv->e_token == ID) {
X error("ID in cast");
X return 0;
X }
X return 1;
X}
X
Xopt_ginit(xp)
XNODEP xp;
X{
X if (xp->e_token != ID)
X return;
X if (xp->n_tptr->t_token == '(')
X return;
X switch (xp->e_sc) {
X case K_STATIC:
X case HERE_SC:
X if (cur->e_token == '=') {
X out_gv(xp, 0);
X fadvnode();
X g_init(xp->n_tptr);
X } else
X out_gv(xp, 1);
X }
X}
X
Xopt_linit(xp)
XNODEP xp;
X{
X if (xp->e_token != ID)
X return;
X if (xp->n_tptr->t_token == '(')
X return;
X switch (xp->e_sc) {
X case K_STATIC:
X if (cur->e_token == '=') {
X out_gv(xp, 0);
X fadvnode();
X g_init(xp->n_tptr);
X } else
X out_gv(xp, 1);
X to_text();
X break;
X case K_AUTO:
X case K_REGISTER:
X if (cur->e_token == '=')
X a_init(xp);
X break;
X }
X}
X
Xa_init(op)
XNODEP op;
X{
X register NODEP np, xp;
X NODEP assignx(), copynode();
X
X np = cur; advnode();
X xp = assignx();
X op = copynode(op);
X np->n_left = op;
X np->n_right = xp;
X np->e_type = E_BIN;
X do_expr(np, FORSIDE);
X return;
X}
X
Xopt_enval(intp)
Xint *intp;
X{
X NODEP np;
X NODEP questx();
X
X if (cur->e_token == '=') {
X fadvnode();
X np = questx();
X *intp = conxval(np);
X return;
X }
X}
X
Xopt_field(xp,wdp,isunion)
XNODE *xp;
Xint *wdp;
X{
X NODEP np;
X NODEP questx();
X int i;
X
X *wdp = -1;
X if (isunion) return;
X if (cur->e_token == ':') {
X fadvnode();
X np = questx();
X i = conxval(np);
X if (i > 8*SIZE_I) {
X error("field too big");
X i = 8*SIZE_I;
X }
X if (xp) {
X if (i <= 0 || bad_fty(xp->n_tptr)) {
X error("bad field");
X return;
X }
X } else if (i < 0) {
X error("neg field width");
X return;
X }
X *wdp = i;
X return;
X }
X}
X
Xbad_fty(tp)
XNODEP tp;
X{
X int tok;
X
X tok = tp->t_token;
X if (tok == K_INT || tok == K_UNSIGNED)
X return 0;
X return 1;
X}
X
Xfield(xp, wd, ofp)
XNODEP xp;
Xint *ofp;
X{
X}
X
XNODEP
Xdef_type()
X{
X NODEP bas_type();
X
X return bas_type(K_INT);
X}
X
X#define NSC LAST_SC-FIRST_SC+1
X#define NBAS LAST_BAS-FIRST_BAS+1
X
XNODE basics[NBAS];
XNODE str_ptr, fun_int;
X
Xstruct bt {
X char *name;
X int size;
X char align;
X} btbl[] = {
X {"Uchar", SIZE_C, ALN_C},
X {"Ulong", SIZE_L, ALN_L},
X {"Long", SIZE_L, ALN_L},
X {"Short", SIZE_S, ALN_S},
X {"Uns", SIZE_U, ALN_U},
X {"Int", SIZE_I, ALN_I},
X {"Char", SIZE_C, ALN_C},
X {"Float", SIZE_F, ALN_F},
X {"Dbl", SIZE_D, ALN_D},
X {"Void", 0},
X};
X
XNODEP
Xbas_type(btype)
X{
X NODEP rv;
X static once = 0;
X
X if (once == 0) {
X once++;
X
X sprintf(str_ptr.n_name, "Ptr to");
X str_ptr.t_token = STAR;
X str_ptr.n_tptr = bas_type(K_CHAR);
X str_ptr.n_flags = N_COPYT;
X str_ptr.t_size = SIZE_P;
X str_ptr.t_aln = ALN_P;
X
X sprintf(fun_int.n_name, "Fun ret");
X fun_int.t_token = '(';
X fun_int.n_tptr = bas_type(K_INT);
X fun_int.n_flags = N_COPYT;
X }
X if (btype == SCON)
X return &str_ptr;
X else if (btype == '(')
X return &fun_int;
X rv = &basics[btype-FIRST_BAS];
X if (rv->t_token == 0) {
X rv->t_token = btype;
X rv->t_size = btbl[btype-FIRST_BAS].size;
X rv->t_aln = btbl[btype-FIRST_BAS].align;
X sprintf(rv->n_name, btbl[btype-FIRST_BAS].name);
X }
X return rv;
X}
X
X/* new function name seen in expr */
XNODEP
Xnew_fun(op)
XNODE *op;
X{
X NODEP np;
X NODEP copyone();
X
X /* we know left, right and tptr are NULL */
X np = copyone(op); /* ID node */
X np->n_tptr = bas_type('(');
X np->n_flags = N_COPYT;
X np->e_sc = K_EXTERN;
X new_sym(symtab, np);
X return np;
X}
X
X/* declare arg name as int */
Xdef_arg(listpp, op)
XNODE **listpp, *op;
X{
X register NODEP np;
X NODEP copyone();
X
X np = copyone(op);
X np->n_tptr = bas_type(K_INT);
X np->n_flags = N_COPYT;
X np->e_sc = K_AUTO;
X new_sym(listpp, np);
X}
X
X/* initialize 0 or 1 thing of any type (tp) */
Xg_init(tp)
Xregister NODEP tp;
X{
X int nsee;
X long sz;
X int oldsize;
X int seebr = 0;
X
X if (cur->e_token == SCON &&
X tp->t_token == '[' &&
X tp->n_tptr->t_token == K_CHAR) { /* hack for SCON ary */
X nsee = out_scon(cur);
X fadvnode();
X a_fix(tp, nsee);
X return 1;
X }
X
X if (cur->e_token == '{') {
X fadvnode();
X seebr = 1;
X }
X
X switch (tp->t_token) {
X case '[':
X if (tp->t_size)
X oldsize = tp->t_size / tp->n_tptr->t_size;
X else
X oldsize = 0;
X nsee = inita(tp->n_tptr, oldsize);
X if (nsee)
X a_fix(tp, nsee);
X break;
X case K_STRUCT:
X o_aln(tp->t_aln);
X nsee = inits(tp->n_right);
X break;
X case K_UNION:
X o_aln(tp->t_aln);
X nsee = g_init(tp->n_right->n_tptr);
X if (nsee) {
X sz = tp->t_size - tp->n_right->n_tptr->t_size;
X if (sz)
X o_nz(sz, 0);
X }
X break;
X default:
X nsee = init1(tp);
X break;
X }
X
X if (seebr) {
X if (cur->e_token == ',')
X fadvnode();
X eat('}');
X }
X return nsee ? 1 : 0;
X}
X
X/* initialize one (or 0) scalar to an expr */
Xinit1(tp)
Xregister NODEP tp;
X{
X NODEP xp;
X NODEP assignx();
X
X if (debugi) {
X printf("init1");
X printnode(tp);
X }
X xp = assignx();
X if (xp) {
X if (debugi)
X printnode(xp);
X o_vinit(tp, xp);
X return 1;
X } else
X return 0;
X}
X
X/* set array size or fill array with zeros */
Xa_fix(tp, nsee)
Xregister NODEP tp;
X{
X int oldsize;
X
X if (tp->t_size) {
X oldsize = tp->t_size / tp->n_tptr->t_size;
X if (oldsize > nsee) {
X o_nz(tp->n_tptr->t_size * (oldsize-nsee),
X tp->n_tptr->t_aln);
X } else if (oldsize < nsee) {
X error("too many init exprs");
X }
X } else
X tp->t_size = nsee * tp->n_tptr->t_size;
X}
X
X/* initialize up to max items of type tp */
X/* if max is 0, any number is okay */
X
Xinita(tp, maxi)
XNODEP tp;
X{
X int nsee;
X
X nsee = g_init(tp);
X if (nsee == 0)
X return 0;
X
X while (cur->e_token == ',') {
X if (nsee == maxi)
X break;
X fadvnode();
X nsee += g_init(tp);
X }
X return nsee;
X}
X
X/* initialize (possible) structure */
Xinits(np)
Xregister NODEP np;
X{
X int see1;
X
X see1 = g_init(np->n_tptr);
X if (see1 == 0)
X return 0;
X
X while (np->n_next) {
X np = np->n_next;
X if (cur->e_token == ',') {
X fadvnode();
X see1 = g_init(np->n_tptr);
X } else
X see1 = 0;
X if (see1 == 0)
X z_init(np->n_tptr);
X }
X
X return 1;
X}
X
Xz_init(tp)
Xregister NODEP tp;
X{
X switch (tp->t_token) {
X case '[':
X case K_STRUCT:
X case K_UNION:
X o_nz(tp->t_size, tp->t_aln);
X break;
X default:
X out_zi(tp);
X }
X}
END_OF_FILE
if test 9938 -ne `wc -c <'hcc/D2.C'`; then
echo shar: \"'hcc/D2.C'\" unpacked with wrong size!
fi
# end of 'hcc/D2.C'
fi
if test -f 'hcc/DECL.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/DECL.C'\"
else
echo shar: Extracting \"'hcc/DECL.C'\" \(10944 characters\)
sed "s/^X//" >'hcc/DECL.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 * decl.c
X *
X * Do all declarations
X *
X * Currently,
X * struct tags are local
X * struct members are tied to the struct
X * enum tags are ignored
X * enum members are local
X */
X
X#include <stdio.h>
X#include "param.h"
X#include "tok.h"
X#include "nodes.h"
X
Xextern NODE *cur;
Xextern level;
X
XNODEP symtab[NHASH], tagtab;
Xextern NODE *blktab;
X
XNODEP alltags(), allsyms(), llook(), hlook();
X
Xextern int oflags[];
X#define debug oflags['v'-'a']
X
X/* look for global data decls
X return when see something weird
X return last ID declared */
XNODEP
Xglb_decls()
X{
X register NODEP head, xp;
X NODEP d_type(), def_type(), d_declr();
X int sclass;
X
X for(;;) {
X sclass = d_scl(HERE_SC);
X head = d_type();
X if (head == NULL)
X head = def_type();
X if (ok_gsh(sclass, head) == 0)
X continue;
X more:
X xp = d_declr(head,0);
X if (ok_gx(xp,head)) {
X xp->e_sc = sclass;
X opt_ginit(xp);
X new_sym(symtab,xp);
X if (xp->n_tptr->t_token == '(') { /* func */
X if (cur->e_token == ',' ||
X cur->e_token == ';')
X fix_fun(xp);
X else
X return xp;
X }
X }
X
X if (cur->e_token == ',') {
X fadvnode();
X goto more;
X }
X
X if (cur->e_token == ';') {
X fadvnode();
X } else
X return NULL;
X }
X}
X
X/* do local or arg decls
X return 1 if see something */
Xloc_decls()
X{
X register NODEP head, xp;
X NODEP d_type(), def_type(), d_declr();
X int sclass;
X int regs;
X long size;
X int rv = 0;
X
X size = level > 2 ? blktab->n_next->b_size : 0;
X regs = level > 1 ? blktab->n_next->b_regs : 0;
X while (is_ty_start()) {
X rv++;
X sclass = d_scl(K_AUTO);
X head = d_type();
X if (head == NULL)
X head = def_type();
X if (ok_lsh(sclass, head) == 0)
X continue;
X more:
X xp = d_declr(head,0);
X if (ok_lx(xp,head)) {
X xp->e_sc = sclass;
X if (level > 1) { /* not args */
X lc_size(&size, ®s, xp);
X out_advice(xp);
X }
X new_sym(&blktab->b_syms,xp);
X fix_fun(xp);
X opt_linit(xp,sclass);
X }
X
X if (cur->e_token == ',') {
X fadvnode();
X goto more;
X }
X
X if (cur->e_token == ';') {
X fadvnode();
X } else {
X error("expect ;");
X return 1;
X }
X }
X while (STACKALN & size)
X size++;
X blktab->b_size = size;
X blktab->b_regs = regs;
X return rv;
X}
X
X/* Decls inside Struct/Union */
Xsu_decls(listpp, isunion, sizep, alnp)
XNODEP *listpp;
Xlong *sizep;
Xchar *alnp;
X{
X register NODEP head, xp;
X NODEP d_type(), d_declr();
X long size;
X char aln;
X int fldw, fldoff;
X
X aln = 0;
X size = 0;
X fldoff = 0;
X for(;;) {
X head = d_type();
X if (head == NULL)
X goto out;
X if (ok_suh(head) == 0)
X continue;
X more:
X xp = d_declr(head,0);
X opt_field(xp,&fldw,isunion);
X if (ok_sux(xp,head)) {
X if (fldw > 0) { /* handle field */
X su_fld(&size,&aln,xp,fldw,&fldoff);
X xp->e_offs = size;
X } else { /* handle non-field */
X afterfld(&size,&fldoff);
X xp->e_offs = isunion ? 0 : size;
X su_size(&size,&aln,xp,isunion);
X }
X new_sym(listpp,xp);
X listpp = &xp->n_next;
X } else if (fldw == 0) {
X afterfld(&size, &fldoff);
X }
X
X if (cur->e_token == ',') {
X fadvnode();
X goto more;
X }
X
X if (cur->e_token == ';') {
X fadvnode();
X } else
X goto out;
X }
Xout:
X afterfld(&size,&fldoff);
X while (aln & size)
X size++;
X *sizep = size;
X *alnp = aln;
X return;
X}
X
X/* Decls inside Enum */
Xen_decls()
X{
X register NODEP head, xp;
X NODEP bas_type(), d_declr();
X int curval = 0;
X
X for(;;) {
X head = bas_type(K_INT);
X more:
X xp = d_declr(head,0);
X if (ok_enx(xp,head)) {
X opt_enval(&curval);
X xp->e_ival = curval++;
X xp->e_sc = ENUM_SC;
X new_sym(level ? blktab->b_syms : (NODE *)symtab,
X xp);
X }
X
X if (cur->e_token == ',') {
X fadvnode();
X goto more;
X }
X
X return;
X }
X}
X
X/*
X * called from expr.c, make a cast
X * only called if is_ty_start();
X */
XNODE *
Xmakecast()
X{
X NODEP head, xp;
X register NODEP np;
X NODEP d_type(), d_declr(), def_type();
X
X head = d_type(); /* we know this is not NULL */
X xp = d_declr(head, 1);
X if (ok_cast(xp,head) == 0) {
X xp = def_type(); /* return cast to INT */
X }
X np = allocnode();
X np->e_token = TCONV;
X np->n_tptr = xp;
X if (xp == head)
X np->n_flags |= N_COPYT;
X if (debug) {
X printf("Make cast");
X printnode(np);
X }
X return np;
X}
X
Xis_ty_start()
X{
X NODEP rv;
X
X if (is_tykw(cur->e_token))
X return 1;
X if (cur->e_token == ID) {
X rv = allsyms(cur);
X if (rv && rv->e_sc == K_TYPEDEF)
X return 1;
X }
X return 0;
X}
X
X/* assemble decl and put in listpp */
Xnew_sym(listpp, xp)
XNODEP *listpp;
XNODEP xp;
X{
X NODEP old;
X
X if (xp == NULL)
X return 0;
X/* put in table */
X if (debug) {
X printf("New sym sc %c", "EARTSCH"[xp->e_sc-K_EXTERN]);
X printnode(xp);
X }
X /* later look for previous definition */
X if (listpp == (NODE **)symtab) {
X old = hlook(listpp, xp);
X if (old == NULL || def2nd(old, xp))
X puthlist(listpp, xp);
X } else {
X old = llook(*listpp, xp);
X if (old == NULL || def2nd(old, xp))
X putlist(listpp, xp);
X }
X return 1;
X}
X
X/* look for storage class */
Xd_scl(defau)
X{
X int rv;
X
X if (is_sclass(cur->e_token)) {
X rv = cur->e_token;
X fadvnode();
X return rv;
X }
X /* no storage class specified */
X return defau;
X}
X
XNODEP
Xd_declr(head, forcast)
XNODEP head;
X{
X NODEP e1;
X NODEP declarator(), rev_decl();
X NODEP xp, tailp;
X
X e1 = declarator();
X xp = rev_decl(e1, &tailp, forcast);
X if (xp) {
X tailp->n_tptr = head;
X tailp->n_flags |= N_COPYT;
X return xp;
X } else if (forcast)
X return head;
X else
X return NULL;
X}
X
XNODEP
Xrev_decl(np,tailpp,forcast)
XNODEP np, *tailpp;
X{
X NODEP rv, scan, nxt;
X
X rv = NULL;
X for (scan = np; scan != NULL; scan = nxt) {
X nxt = scan->n_next;
X scan->n_next = NULL;
X if (rv == NULL) {
X *tailpp = scan;
X scan->n_tptr = NULL;
X rv = scan;
X } else {
X scan->n_tptr = rv;
X rv = scan;
X }
X e_to_t(rv);
X switch (rv->t_token) {
X case UNARY '*':
X sprintf(rv->n_name, "Ptr to");
X break;
X case '(':
X sprintf(rv->n_name, "Fun ret");
X break;
X case '[':
X sprintf(rv->n_name, "Ary of");
X break;
X case ID:
X break;
X default:
X error("bad type xpr");
X return NULL;
X }
X }
X /* if normal decl and see something, must see id first */
X if (!ok_revx(rv,forcast))
X rv = NULL;
X return rv;
X}
X
X/*
X * Looking for type part of a decl
X */
XNODEP
Xd_type()
X{
X int btype, adj;
X NODEP rv;
X NODEP bas_type(), decl_su(), decl_enum();
X
X /* look for 'struct', 'union', 'enum' or typedef ID */
X switch (cur->e_token) {
X case ID:
X rv = allsyms(cur);
X if (rv && rv->e_sc == K_TYPEDEF) {
X fadvnode();
X rv = rv->n_tptr;
X return rv;
X }
X return NULL;
X case K_STRUCT:
X return decl_su(0);
X case K_UNION:
X return decl_su(1);
X case K_ENUM:
X return decl_enum();
X }
X
X /* look for modifiers 'long', 'short', 'unsigned' */
X adj = 0;
X while (is_tadj(cur->e_token)) {
X switch (cur->e_token) {
X case K_SHORT:
X adj |= SAW_SHORT;
X break;
X case K_LONG:
X adj |= SAW_LONG;
X break;
X case K_UNSIGNED:
X adj |= SAW_UNS;
X break;
X }
X fadvnode();
X }
X
X /* look for base type 'char', 'int', 'float', 'double', 'void'*/
X if (is_btype(cur->e_token)) {
X btype = cur->e_token;
X fadvnode();
X } else if (adj == 0) /* saw nothing */
X return NULL;
X else
X btype = K_INT;
X
X if (adj)
X btype = adj_type(btype, adj);
X rv = bas_type(btype);
X return rv;
X}
X
XNODEP
Xdecl_enum()
X{
X NODEP bas_type();
X
X fadvnode(); /* skip 'enum' */
X
X if (cur->e_token == ID) { /* ignore tag */
X fadvnode();
X }
X if (cur->e_token == '{') { /* new declaration */
X fadvnode(); /* skip '{' */
X en_decls(); /* global scope */
X if (cur->e_token != '}')
X error("expect }");
X else
X fadvnode(); /* skip '}' */
X }
X return bas_type(K_INT);
X}
X
XNODEP
Xdecl_su(isunion)
X{
X register NODEP rv, tagp;
X NODEP *attab;
X extern lineno;
X
X fadvnode(); /* skip 'struct' or 'union' */
X
X attab = level ? &blktab->b_tags : &tagtab;
X tagp = NULL;
X if (cur->e_token == ID) { /* hold on to ID node */
X tagp = cur;
X e_to_t(tagp);
X advnode();
X nnmadd(tagp, isunion ? ".U" : ".S");
X }
X if (cur->e_token == '{') { /* new declaration */
X if (tagp == NULL) { /* make fake name */
X tagp = allocnode();
X sprintf(tagp->n_name, isunion ? "%dU" :
X "%dS", lineno);
X }
X fadvnode(); /* skip '{' */
X if (rv = llook(*attab, tagp)) {
X freenode(tagp);
X if (rv->n_right) {
X errors("struct redefined", rv->n_name);
X freenode(rv->n_right);
X rv->n_right = NULL;
X }
X } else { /* new defn */
X rv = tagp;
X rv->t_token = isunion ? K_UNION : K_STRUCT;
X rv->n_flags |= N_BRKPR; /* break print loops */
X putlist(attab, rv);
X }
X su_decls(&rv->n_right, isunion,
X &rv->t_size, &rv->t_aln);
X if (cur->e_token != '}')
X error("expect }");
X else
X fadvnode(); /* skip '}' */
X } else { /* reference to old */
X if (tagp == NULL) {
X error("nonsense struct");
X goto out;
X }
X /* ANSI special decl
X struct <tag> ;
X for hiding old tag within block */
X if (cur->e_token == ';' && level)
X rv = llook(*attab, tagp);
X else
X rv = alltags(tagp);
X if (rv == NULL) { /* delayed tag */
X rv = tagp;
X rv->t_token = isunion ? K_UNION : K_STRUCT;
X rv->n_flags |= N_BRKPR; /* break print loops */
X putlist(attab, rv);
X goto out;
X } else
X freenode(tagp);
X }
Xout:
X return rv;
X}
X
XNODE *
Xalltags(np)
XNODE *np;
X{
X register NODE *bp;
X NODE *rv;
X
X for (bp=blktab; bp != NULL; bp = bp->n_next)
X if ((rv = llook(bp->b_tags, np)) != NULL)
X return rv;
X return llook(tagtab, np);
X}
X
XNODE *
Xallsyms(np)
XNODE *np;
X{
X register NODE *bp;
X NODE *rv;
X
X for (bp=blktab; bp != NULL; bp = bp->n_next)
X if ((rv = llook(bp->b_syms, np)) != NULL)
X return rv;
X return hlook(symtab, np);
X}
X
Xsim_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_size != b->t_size && a->t_size && b->t_size)
X return 0;
X a = a->n_tptr;
X b = b->n_tptr;
X goto more;
X}
X
X/* 2nd def of same name at same level */
X/* OK if one extern and types the same */
Xdef2nd(old,new)
XNODEP old, new;
X{
X int osc, nsc;
X
X if (sim_type(old->n_tptr, new->n_tptr) == 0)
X goto bad;
X osc = old->e_sc;
X nsc = new->e_sc;
X if (nsc == K_EXTERN) { /* works only if no further use allowed */
X freenode(new);
X return 0;
X }
X if (osc == K_EXTERN) {
X /* replace old def with new one */
X /* for now, just put new one on list too */
X return 1;
X }
Xbad:
X errorn("bad 2nd decl of ", new);
X /* use 2nd def so other stuff works */
X return 1;
X}
X
X/* saw fun but no body */
Xfix_fun(np)
XNODE *np;
X{
X if (np == NULL) return;
X if (np->n_tptr->t_token == '(') { /* fix to extern */
X if (np->e_sc != K_TYPEDEF)
X np->e_sc = K_EXTERN;
X }
X}
X
Xe_to_t(np)
XNODE *np;
X{
X int token;
X
X token = np->e_token;
X np->t_token = token;
X np->t_size = 0;
X np->t_aln = 0;
X}
END_OF_FILE
if test 10944 -ne `wc -c <'hcc/DECL.C'`; then
echo shar: \"'hcc/DECL.C'\" unpacked with wrong size!
fi
# end of 'hcc/DECL.C'
fi
if test -f 'hcc/EXPR.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/EXPR.C'\"
else
echo shar: Extracting \"'hcc/EXPR.C'\" \(9558 characters\)
sed "s/^X//" >'hcc/EXPR.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 * expr.c
X *
X * Expression parse routines
X *
X * All routines return either NULL or a valid tree
X * binop nodes have non-null left and right
X * unop nodes have non-null left
X *
X * Special nodes:
X * '(' : function call. left:name-expr right:args
X * ',': if part of function arg list, ival:num. descendants
X * '?' : ?switch. left:test-expr right:':' part
X * ':' : left:true-expr right:false-expr
X * TCONV: left:convertee tptr:type-list
X * TSIZEOF: tptr:type-list
X *
X */
X
X#include <stdio.h>
X#include "param.h"
X#include "nodes.h"
X#include "tok.h"
X
Xextern NODEP cur;
XNODEP getnode();
XNODEP opt_follow();
X
Xextern int oflags[];
X#define debug oflags['x'-'a']
X
Xadvnode()
X{
X cur = getnode();
X}
X
Xfadvnode()
X{
X freenode(cur);
X cur = getnode();
X}
X
XNODEP
Xgete_or_ty()
X{
X NODEP getexpr(), makecast();
X NODEP rv;
X
X if (is_ty_start()) {
X rv = makecast();
X if (debug) {
X printf("TY_X");
X printnode(rv);
X }
X return rv;
X } else
X return getexpr();
X}
X
X/* call this for any expr including comma's */
XNODEP
Xgetexpr()
X{
X NODEP np, get_f_expr();
X
X np = get_f_expr(0);
X return np;
X}
X
XNODEP
Xget_f_expr(flg)
Xint flg;
X{
X NODEP assignx();
X register NODEP op, lpart, rpart;
X int i = 0;
X
X lpart = assignx();
X if (lpart == NULL) {
X return NULL;
X }
X i++;
Xmore:
X if (cur->e_token != ',')
X return lpart;
X
X op = cur; advnode();
X rpart = assignx();
X if (rpart == NULL) {
X error("',' expr syntax");
X return lpart;
X }
X i++;
X op->n_left = lpart;
X op->n_right = rpart;
X op->e_type = E_BIN;
X op->e_ival = flg ? i : 0;
X lpart = op;
X if (debug) {
X printf("COMMA");
X printnode(op);
X }
X goto more;
X}
X
X/* call this if you want expr w/o comma's */
XNODEP
Xassignx()
X{
X NODEP questx();
X register NODEP op, lpart, rpart;
X
X lpart = questx();
X if (lpart == NULL)
X return NULL;
X if (!isassign(cur->e_token) && cur->e_token != '=')
X return lpart;
X op = cur; advnode();
X rpart = assignx();
X if (rpart == NULL) {
X error("'=op' expr syntax");
X return lpart;
X }
X op->n_left = lpart;
X op->n_right = rpart;
X op->e_type = E_BIN;
X if (debug) {
X printf("ASSIGN");
X printnode(op);
X }
X return op;
X}
X
X/* call this if you want expr w/o assign's or comma's */
X/* i.e. constant-expression */
XNODEP
Xquestx()
X{
X NODEP binary();
X register NODEP holdq, holdc;
X NODEP qpart, tpart, fpart;
X
X qpart = binary();
X if (qpart == NULL)
X return NULL;
X if (cur->e_token != '?')
X return qpart;
X holdq = cur; advnode();
X tpart = questx();
X if (tpart == NULL || cur->e_token != ':') {
Xbad:
X error("'?:' expr syntax");
X return qpart;
X }
X holdc = cur; advnode();
X fpart = questx();
X if (fpart == NULL) goto bad;
X holdc->n_left = tpart;
X holdc->n_right = fpart;
X holdc->e_type = E_BIN;
X holdq->n_left = qpart;
X holdq->n_right = holdc;
X holdq->e_type = E_BIN;
X if (debug) {
X printf("QUEST");
X printnode(holdq);
X }
X return holdq;
X}
X
XNODEP
Xbinary()
X{
X NODEP unary(), buildbin();
X register NODEP rv, op, e2;
X
X rv = unary();
X if (rv == NULL)
X return NULL;
X rv->e_prec = 0;
Xmore:
X if (cur->e_prec == 0) /* not binary op */
X return rv;
X op = cur; advnode();
X e2 = unary();
X if (e2 == NULL) {
X error("bin-op expr syntax");
X return rv;
X }
X e2->e_prec = 0;
X rv = buildbin(rv, op, e2);
X if (debug) {
X printf("BINARY");
X printnode(rv);
X }
X goto more;
X}
X
XNODEP
Xbuildbin(lpart, op, upart)
XNODEP lpart, op, upart;
X{
X register NODEP look, tail;
X NODEP rv;
X
X tail = NULL;
X look = lpart;
X for (look=lpart; op->e_prec < look->e_prec; look=look->n_right)
X tail = look;
X if (tail == NULL) {
X op->n_left = lpart;
X op->n_right = upart;
X rv = op;
X } else {
X tail->n_right = op;
X op->n_left = look;
X op->n_right = upart;
X rv = lpart;
X }
X op->e_type = E_BIN;
X return rv;
X}
X
XNODEP
Xunary()
X{
X register NODEP tp,e1;
X NODEP primary();
X
X if (cur->e_flags & CAN_U) {
X tp = cur; advnode();
X if (tp->e_prec) { /* also have BINARY op */
X tp->e_token = UNARY tp->e_token;
X strcat(tp->n_name, "U");
X }
X tp->n_left = unary();
X tp->e_type = E_UNARY;
X goto check;
X } else
X switch (cur->e_token) {
X case '(':
X fadvnode();
X tp = gete_or_ty();
X if (cur->e_token != ')') {
X error("missing )");
X } else
X fadvnode();
X if (tp == NULL)
X return NULL;
X if (tp->e_token == TCONV && tp->n_left == NULL) {
X sprintf(tp->n_name, "cast to");
X tp->n_left = unary();
X tp->e_type = E_UNARY;
X } else {
X tp = opt_follow(tp);
X goto out;
X }
X goto check;
X case K_SIZEOF:
X tp = cur;
X advnode();
X if (cur->e_token == '(') { /* may be type expr */
X fadvnode();
X e1 = gete_or_ty();
X if (cur->e_token != ')') {
X error("missing )");
X } else
X fadvnode();
X } else
X e1 = unary();
X if (e1 == NULL) {
X error("sizeof expr syntax");
X return NULL;
X }
X if (e1->e_token == TCONV) {
X freeunit(tp);
X e1->e_token = TSIZEOF;
X sprintf(e1->n_name, "T-sizeof");
X tp = e1;
X tp->e_type = E_LEAF;
X goto out;
X } else {
X tp->e_type = E_UNARY;
X tp->n_left = e1;
X }
X goto check;
X default:
X tp = primary();
X goto out;
X }
Xcheck:
X if (tp == NULL) return NULL;
X if (tp->n_left == NULL) {
X error("u-op expr syntax");
X return NULL;
X }
Xout:
X if (debug) {
X printf("UNARY");
X printnode(tp);
X }
X return tp;
X}
X
XNODEP
Xprimary()
X{
X register NODEP e1;
X
X switch (cur->e_token) {
X case ID:
X case ICON:
X case FCON:
X case SCON:
X e1 = cur;
X e1->e_type = E_LEAF;
X advnode();
X break;
X case '(':
X fadvnode();
X e1 = getexpr();
X if (cur->e_token != ')')
X error("missing )");
X else
X fadvnode();
X break;
X default:
X e1 = NULL;
X }
X if (e1 == NULL)
X return NULL;
X return opt_follow(e1);
X}
X
XNODEP
Xopt_follow(np)
XNODEP np;
X{
X register NODEP tp, e1, t2;
X
X switch (cur->e_token) {
X case '[':
X tp = cur; advnode();
X e1 = getexpr();
X if (cur->e_token != ']') {
X error("missing ]");
X return np;
X } else {
X t2 = cur; advnode();
X }
X if (e1 == NULL) {
X error("empty []");
X return np;
X }
X t2->n_left = np;
X t2->n_right = e1;
X t2->e_type = E_BIN;
X t2->e_token = '+';
X strcpy(t2->n_name, "+ [");
X
X tp->n_left = t2;
X tp->e_type = E_UNARY;
X tp->e_token = STAR;
X strcpy(tp->n_name, "U*");
X
X goto out;
X case '(':
X tp = cur;
X advnode();
X e1 = get_f_expr(1);
X if (cur->e_token != ')')
X error("expect )");
X else
X fadvnode();
X tp->n_left = np;
X tp->n_right = e1;
X tp->e_type = E_SPEC;
X goto out;
X case '.':
X case ARROW:
X tp = cur; advnode();
X if (cur->e_token != ID) {
X error("expect ID");
X return np;
X }
X tp->n_left = np;
X tp->n_right = cur;
X tp->e_type = E_SPEC;
X if (tp->e_token == ARROW) { /* make into (*X).Y */
X tp->e_token = '.';
X strcpy(tp->n_name, ".");
X
X t2 = allocnode();
X t2->e_token = STAR;
X t2->n_left = np;
X t2->e_type = E_UNARY;
X strcpy(t2->n_name, "U*");
X
X tp->n_left = t2;
X }
X advnode();
X goto out;
X case DOUBLE '+':
X case DOUBLE '-':
X tp = cur; advnode();
X tp->e_token = (tp->e_token == DOUBLE '+') ? POSTINC : POSTDEC;
X strcat(tp->n_name, "post");
X tp->n_left = np;
X tp->e_type = E_UNARY;
X goto out;
X default:
X return np;
X }
Xout:
X return opt_follow(tp);
X}
X
X/* restricted version of unary for declarations or coertions */
X/* allows NULL primary part */
XNODEP
Xdeclarator()
X{
X register NODEP tp,e1;
X NODEP ty_primary(), ty_follow();
X
X if (cur->e_token == '*') {
X tp = cur;
X tp->e_token = UNARY tp->e_token;
X strcat(tp->n_name, "U");
X advnode();
X tp->n_left = declarator();
X return tp;
X } else
X switch (cur->e_token) {
X case '(':
X tp = cur;
X advnode();
X e1 = declarator();
X if (cur->e_token != ')') {
X error("expect )");
X } else
X fadvnode();
X if (e1 == NULL) { /* special "fun of" */
X /* left and right already NULL */
X return ty_follow(tp);
X } else {
X freeunit(tp);
X return ty_follow(e1);
X }
X default:
X return ty_primary();
X }
X}
X
X/* restricted version of primary for "declarator" */
XNODEP
Xty_primary()
X{
X register NODEP e1;
X NODEP ty_follow();
X
X switch (cur->e_token) {
X case ID:
X e1 = cur;
X advnode();
X break;
X case '(':
X fadvnode();
X e1 = declarator();
X if (cur->e_token != ')')
X error("expect )");
X else
X fadvnode();
X break;
X default:
X e1 = NULL;
X }
X return ty_follow(e1);
X}
X
X/* restricted version of opt_follow for 'declarator' */
X/* allow null [] */
XNODEP
Xty_follow(np)
XNODEP np;
X{
X register NODEP tp, e1;
X NODEP ty_args();
X
X switch (cur->e_token) {
X case '[':
X tp = cur;
X advnode();
X e1 = questx();
X if (cur->e_token != ']')
X error("expect ]");
X else
X fadvnode();
X tp->n_left = np;
X tp->n_right = e1;
X goto out;
X case '(':
X tp = cur;
X advnode();
X e1 = ty_args(); /* allow args of fun to follow */
X if (cur->e_token != ')')
X error("expect )");
X else
X fadvnode();
X tp->n_left = np;
X tp->n_right = e1;
X goto out;
X default:
X return np;
X }
Xout:
X return ty_follow(tp);
X}
X
X/* called for args of function declaration or NULL */
XNODEP
Xty_args()
X{
X NODEP opt_id();
X register NODEP rv, tail, new;
X
X rv = opt_id();
X if (rv == NULL)
X return NULL;
X tail = rv;
Xmore:
X if (cur->e_token != ',')
X return rv;
X fadvnode();
X new = opt_id();
X if (new == NULL) {
X error("expect as-op value");
X return rv;
X }
X tail->n_left = new;
X tail = new;
X goto more;
X}
X
XNODEP
Xopt_id()
X{
X NODEP rv;
X
X if (cur->e_token == ID) {
X rv = cur;
X advnode();
X return rv;
X } else
X return NULL;
X}
END_OF_FILE
if test 9558 -ne `wc -c <'hcc/EXPR.C'`; then
echo shar: \"'hcc/EXPR.C'\" unpacked with wrong size!
fi
# end of 'hcc/EXPR.C'
fi
if test -f 'hcc/TOK.C' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'hcc/TOK.C'\"
else
echo shar: Extracting \"'hcc/TOK.C'\" \(10934 characters\)
sed "s/^X//" >'hcc/TOK.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 * tok.c
X *
X * Basic level token routines
X *
X * At this level, we return the following things:
X * id's - strings of alpha-alnum
X * integer constants
X * float constants
X * string constants
X * multi-char tokens
X *
X * We DONT know about:
X * keywords
X * #defined id's
X * any other meaning of a name
X *
X * Interface:
X * call nxttok() to get next token
X * look at 'curtok' for current token
X * note that curtok.name points to a static area
X * for ID or SCON
X *
X * if EOF is seen, we call endfile() before
X * giving up
X *
X * Special flags: (tk_flags)
X * These special flags are needed for the pre-processor.
X * All but TK_SEENL are 1-shot.
X *
X * TK_SEENL - want to see \n
X * TK_WS - want to see white space (for #define)
X * TK_NOESC - dont do '\' escapes in strings
X * TK_LTSTR - '<' is a string starter
X * TK_ONLY1 - skip to token after \n (for #if--)
X */
X
X#include <stdio.h>
X#include "param.h"
X#include "tok.h"
X
X#if dLibs
X#include <ctype.h>
X#endif
X
Xstruct tok curtok;
Xchar curstr[MAXSTR+1];
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
Xint tk_flags, sawnl;
X
Xextern FILE *input;
Xextern int lineno;
X
X#define NOCHAR 0x100
X
X#ifdef DEBUG
Xextern int oflags[];
X#define debug oflags['b'-'a']
X#endif
X
Xnxttok()
X{
X register struct tok *t;
X char *getname();
X long getnum();
X register int c;
X double getfrac();
X
X t = &curtok;
X t->name = curstr;
X t->name[0] = 0;
X t->prec = 0;
X t->flags = 0;
Xmore:
X c = mygetchar();
X if (c == EOF) {
X tk_flags = 0;
X return 0;
X }
X if (c == '\n') {
X tk_flags &= ~TK_ONLY1;
X if ((tk_flags & TK_SEENL) == 0)
X goto more;
X t->tnum = NL;
X t->name = "\n";
X goto out;
X }
X if (tk_flags & TK_ONLY1)
X goto more;
X if (c <= ' ') {
X if ((tk_flags & TK_SEEWS) == 0)
X goto more;
X t->tnum = WS;
X t->name = " ";
X goto out;
X }
X if (c >= '0' && c <= '9') {
X t->tnum = ICON;
X t->ival = getnum(c);
X if (lookfrac(t->ival) || lookexp(t->ival,0.0))
X goto out;
X moresuf:
X c = mygetchar();
X if (tolower(c) == 'l') {
X t->flags |= SEE_L;
X goto moresuf;
X } else if (tolower(c) == 'u') {
X t->flags |= SEE_U;
X goto moresuf;
X } else {
X myungetc(c);
X }
X sprintf(curstr, "%ld",
X t->ival);
X goto out;
X }
X if (isalpha(c) || c == '_') {
X t->tnum = ID;
X t->name = getname(c);
X goto out;
X }
X if (c == '.') {
X c = mygetchar();
X if (c >= '0' && c <= '9') {
X gotfrac(0L, getfrac(c));
X goto out;
X } else {
X myungetc(c);
X matchop('.');
X goto out;
X }
X }
X if(matchop(c) == 0)
X goto more;
Xout:
X if (debug) printf("<%s>", t->name);
X tk_flags &= TK_SEENL; /* all but SEENL are 1-shot */
X return 1;
X}
X
Xlong
Xgetnum(c)
Xregister int c;
X{
X register long val = 0;
X int base, i;
X
X if (c == '0') {
X base = 8;
X } else {
X base = 10;
X val = c - '0';
X }
Xmore:
X c = mygetchar();
X if (c == EOF)
X return val;
X if (tolower(c) == 'x' && val == 0) {
X base = 16;
X goto more;
X }
X if (c >= '0' && c <= '9') {
X val = base*val + (c - '0');
X goto more;
X }
X if (base == 16 && (i = ishexa(c))) {
X val = 16*val + i;
X goto more;
X }
X myungetc(c);
X return val;
X}
X
Xdouble
Xgetfrac(c)
Xregister c;
X{
X register double val;
X register double dig = 0.1;
X
X val = dig * (c - '0');
Xmore:
X c = mygetchar();
X if (c >= '0' && c <= '9') {
X dig = .1 * dig;
X val += dig * (c - '0');
X goto more;
X }
X myungetc(c);
X return val;
X}
X
Xlookfrac(intpart)
Xlong intpart;
X{
X int c;
X double frac;
X
X c = mygetchar();
X if (c != '.') {
X myungetc(c);
X return 0;
X }
X c = mygetchar();
X if (c >= '0' && c <= '9') {
X frac = getfrac(c);
X } else {
X myungetc(c);
X frac = 0.0;
X }
X gotfrac(intpart, frac);
X return 1;
X}
X
Xgotfrac(intpart, frac)
Xlong intpart;
Xdouble frac;
X{
X if (lookexp(intpart, frac) == 0)
X makeflt(intpart, frac, 0);
X}
X
Xlookexp(intpart, frac)
Xlong intpart;
Xdouble frac;
X{
X int c;
X int minus;
X int exp;
X
X minus = 0;
X c = mygetchar();
X if (tolower(c) != 'e') {
X myungetc(c);
X return 0;
X }
X c = mygetchar();
X if (c == '-') {
X minus = 1;
X c = mygetchar();
X } else if (c == '+')
X c = mygetchar();
X if (c >= '0' && c <= '9') {
X exp = getnum(c);
X } else {
X exp = 0;
X myungetc(c);
X }
X if (minus)
X exp = -exp;
X makeflt(intpart, frac, exp);
X return 1;
X}
X
Xmakeflt(intpart, frac, exp)
Xlong intpart;
Xdouble frac;
X{
X register double val;
X double mod, mod10;
X register struct tok *t;
X
X val = intpart + frac;
X if (exp > 0) {
X mod = 1e1;
X mod10 = 1e10;
X } else if (exp < 0) {
X mod = 1e-1;
X mod10 = 1e-10;
X exp = -exp;
X }
X while (exp >= 10) {
X val *= mod10;
X exp -= 10;
X }
X while (exp--)
X val *= mod; /* slow and dirty */
X t = &curtok;
X t->tnum = FCON;
X t->fval = val;
X sprintf(t->name, FLTFORM, val);
X}
X
Xchar *
Xgetname(c)
Xregister int c;
X{
X register int nhave;
X
X nhave = 0;
X do {
X if (nhave < MAXSTR)
X curstr[nhave++] = c;
X c = mygetchar();
X } while (isalnum(c) || c == '_');
X myungetc(c);
X curstr[nhave] = 0;
X return curstr;
X}
X
Xstatic char *holdstr;
X
Xchr_push(s)
Xchar *s;
X{
X holdstr = s;
X}
X
Xstatic int holdchar, xholdchar;
X
Xmygetchar()
X{
X register int c;
X int c2;
X
X if (holdchar) {
X c = holdchar;
X holdchar = 0;
X goto out;
X }
X if (holdstr) { /* used for -D args */
X c = *holdstr++;
X if (c == 0) {
X holdstr = NULL;
X return '\n';
X }
X return c;
X }
X
Xretry:
X c = xgetc();
X if (c == EOF) {
X if (endfile())
X goto retry;
X } else if (c == '\\') { /* ansi handling of backslash nl */
X c2 = xgetc();
X if (c2 == '\n') {
X lineno++;
X goto retry;
X } else
X xholdchar = c2;
X }
Xout:
X if (c == '\n') {
X sawnl++; /* for pre.c */
X lineno++;
X }
X return c;
X}
X
Xxgetc()
X{
X register int c;
X
X if (xholdchar) {
X c = xholdchar;
X xholdchar = 0;
X return c;
X }
X#if CC68|dLibs
X if (input == stdin) /* bypass stupid input */
X c = hackgetc();
X else
X#endif
X c = getc(input);
X if (c != EOF)
X c &= 0x7f;
X return c;
X}
X
Xmyungetc(c)
Xchar c;
X{
X if (c != EOF)
X holdchar = c;
X if (c == '\n')
X lineno--;
X}
X
Xstruct op {
X char *name;
X char *asname;
X int flags;
X char prec;
X char value;
X} ops[] = {
X {"{"},
X {"}"},
X {"["},
X {"]"},
X {"("},
X {")"},
X {"#"},
X {"\\"},
X {";"},
X {","},
X {":"},
X {"."},
X
X {"\"", 0, SPECIAL},
X {"'", 0, SPECIAL},
X
X {"==", 0, C_NOT_A, 5},
X {"=", 0, 0},
X
X {"++", 0, CAN_U},
X {"+", "+=", CAN_AS|C_AND_A, 2},
X
X {"--", 0, CAN_U},
X {"->", 0, 0, 0, ARROW},
X {"-", "-=", CAN_U|CAN_AS, 2},
X
X {"*", "*=", CAN_U|CAN_AS|C_AND_A, 1},
X {"%", "%=", CAN_AS, 1},
X
X {"/*", 0, SPECIAL},
X {"/", "/=", CAN_AS, 1},
X
X {"&&", 0, 0, 9},
X {"&", "&=", CAN_U|CAN_AS|C_AND_A, 6},
X
X {"||", 0, 0, 10},
X {"|", "|=", CAN_AS|C_AND_A, 8},
X
X {"!=", 0, C_NOT_A, 5, NOTEQ},
X {"!", 0, CAN_U},
X
X {"~", 0, CAN_U},
X
X {"^", "^=", CAN_AS|C_AND_A, 7},
X
X {"<<", "<<=", CAN_AS, 3},
X {"<=", 0, C_NOT_A, 4, LTEQ},
X {"<", 0, SPECIAL|C_NOT_A, 4},
X
X {">>", ">>=", CAN_AS, 3},
X {">=", 0, C_NOT_A, 4, GTEQ},
X {">", 0, C_NOT_A, 4},
X
X {"?", 0, 0},
X
X {0, 0, 0}
X};
X
X#define FIRST_C '!'
X#define LAST_C 0177
Xstruct op *opstart[LAST_C-FIRST_C+1];
X
Xmo_init()
X{
X register struct op *p;
X register c;
X
X for (p=ops; p->name; p++) {
X c = p->name[0];
X if (opstart[c-FIRST_C] == 0)
X opstart[c-FIRST_C] = p;
X }
X}
X
Xmatchop(c)
X{
X register struct tok *t;
X register struct op *p;
X int nxt;
X int value;
X static first = 0;
X
X t = &curtok;
X nxt = mygetchar();
X value = c;
X if (first == 0) {
X mo_init();
X first = 1;
X }
X p = opstart[c-FIRST_C];
X if (p)
X for (; p->name; p++)
X if (p->name[0] == c)
X if (p->name[1] == 0 || p->name[1] == nxt) {
X if (p->name[1] == 0)
X myungetc(nxt);
X else {
X value = p->value ? p->value :
X DOUBLE value;
X }
X if (p->flags & SPECIAL)
X if (c != '<' ||
X tk_flags & TK_LTSTR)
X return dospec(p);
X t->flags = p->flags;
X if (p->flags & CAN_AS) {
X nxt = mygetchar();
X if (nxt != '=') {
X myungetc(nxt);
X } else {
X value = ASSIGN value;
X t->flags = 0;
X }
X }
X t->name = isassign(value)?p->asname:p->name;
X t->tnum = value;
X t->prec = isassign(value)? 0 : p->prec;
X return 1;
X }
X myungetc(nxt);
X t->name = "???";
X t->tnum = BADTOK;
X return 0;
X}
X
Xdospec(p)
Xstruct op *p;
X{
X register struct tok *t;
X register int c;
X int nhave;
X int endc;
X
X t = &curtok;
X switch (p->name[0]) {
X case '/': /* slash-star */
Xlook:
X do {
X c = mygetchar();
X } while (c != '*');
X c = mygetchar();
X if (c == '/')
X return 0;
X myungetc(c);
X goto look;
X case '\'':
X t->tnum = ICON;
X t->ival = getschar('\''); /* allow only 1 for now*/
X while (getschar('\'') != NOCHAR)
X ;
X sprintf(curstr, "%d", (int)t->ival);
X return 1;
X case '<':
X endc = '>';
X t->tnum = SCON2;
X goto strs;
X case '"':
X endc = '"';
X t->tnum = SCON;
X strs:
X t->name = curstr;
X nhave = 0;
X c = getschar(endc);
X while (c != NOCHAR) {
X if (c >= 0 && c <= 1 && nhave < MAXSTR) {
X /* allow null */
X curstr[nhave++] = 1;
X c++;
X }
X if (nhave < MAXSTR)
X curstr[nhave++] = c;
X c = getschar(endc);
X }
X curstr[nhave] = 0;
X return 1;
X }
X}
X
Xgetoct(c)
X{
X char n, i;
X
X n = c - '0';
X for (i=1; i < 3; i++) {
X c = mygetchar();
X if (c < '0' || c > '7') {
X myungetc(c);
X return (int)n;
X }
X n = 8*n + (c - '0');
X }
X return (int)n;
X}
X
Xgetschar(del)
Xchar del;
X{
X register int c;
X
Xmore:
X c = mygetchar();
X if (c == del)
X return NOCHAR;
X if (c == '\n') {
X error("nl in string");
X myungetc(c);
X return NOCHAR;
X }
X if (c == '\\' && (tk_flags & TK_NOESC) == 0) {
X c = mygetchar();
X if (c == del)
X return c;
X if (c >= '0' && c <= '7')
X return getoct(c);
X switch (c) {
X/*
X case '\n':
X goto more;
X*/
X case 'b':
X c = '\b';
X break;
X case 'n':
X c = '\n';
X break;
X case 't':
X c = '\t';
X break;
X case 'r':
X c = '\r';
X break;
X case 'f':
X c = '\f';
X break;
X }
X }
X return c;
X}
X
X#if !dLibs
X
Xisalpha(c)
Xregister char c;
X{
X if ((c>='a' && c<='z') ||
X (c>='A' && c<='Z'))
X return 1;
X return 0;
X}
X
Xisalnum(c)
Xregister char c;
X{
X return (isalpha(c) || (c>='0' && c<='9'));
X}
X
Xtolower(c)
Xregister char c;
X{
X if (c>='A' && c<='Z')
X c += 'a'-'A';
X return c;
X}
X
X#endif
X
Xishexa(c)
Xregister char c;
X{
X if (c>='a' && c<='f')
X return (c-'a'+10);
X if (c>='A' && c<='F')
X return (c-'A'+10);
X return 0;
X}
X
X#if CC68
Xhackgetc()
X{
X register int c;
X
X c = bios(2,2);
X switch (c) {
X case 4:
X return EOF;
X case '\r':
X case '\n':
X bios(3,2,'\r');
X bios(3,2,'\n');
X return '\n';
X }
X bios(3,2,c);
X return c;
X}
X#endif
X
X#if dLibs
Xhackgetc()
X{
X register int c;
X
X c = getchar();
X switch (c) {
X case 4:
X return EOF;
X case '\n':
X putchar('\n');
X break;
X }
X return c;
X}
X#endif
END_OF_FILE
if test 10934 -ne `wc -c <'hcc/TOK.C'`; then
echo shar: \"'hcc/TOK.C'\" unpacked with wrong size!
fi
# end of 'hcc/TOK.C'
fi
echo shar: End of archive 4 \(of 9\).
cp /dev/null ark4isdone
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