rsalz@uunet.uu.net (Rich Salz) (10/24/89)
Submitted-by: Edoardo Biagioni <biagioni@cs.unc.edu>
Posting-number: Volume 20, Issue 52
Archive-name: fpc/part03
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# shar: Shell Archiver
# Run the following text with /bin/sh to create:
# code.c
# code.h
# expr.c
echo shar: extracting code.c '(20383 characters)'
sed 's/^XX//' << \SHAR_EOF > code.c
XX/* code.c: produce code for the function encoded by the parse tree. */
XX
XX#include <stdio.h>
XX#include <strings.h>
XX#include "fpc.h"
XX#include "parse.h"
XX#include "code.h"
XX#include "fp.h"
XX
XXstatic fpexpr preoptimize ();
XXstatic void putheader ();
XXstatic void putfinish ();
XX
XXextern void codeexpr ();
XXextern char * sprintf ();
XX
XXstatic int varsneeded;
XXstatic int selneeded;
XX
XX/* assumes that oldname ends in .fp. Returns "" if for some reason
XX the file should not be opened. */
XXvoid newfname (oldname, newname)
XXchar * oldname, * newname;
XX{
XX int len;
XX
XX len = strlen (oldname);
XX if ((oldname [len - 3] != '.') ||
XX (oldname [len - 2] != 'f') ||
XX (oldname [len - 1] != 'p'))
XX {
XX *newname = '\0';
XX return;
XX }
XX (void) strcpy (newname, oldname);
XX newname [len - 2] = 'c'; /* change .fp to .c */
XX newname [len - 1] = '\0';
XX}
XX
XXvoid code (fun, tree)
XXchar * fun;
XXfpexpr tree;
XX{
XX tree = preoptimize (tree);
XX countvars (tree);
XX putheader (fun, varsneeded, selneeded, tree);
XX codeexpr (tree, "data", "res");
XX putfinish (fun);
XX}
XX
XXstatic void putdefine (name, val)
XXchar * name, *val;
XX{
XX (void) fprintf (outf, "#define %s\t%s\n", name, val);
XX}
XX
XXstatic void putdefnum (name, val)
XXchar * name;
XXint val;
XX{
XX (void) fprintf (outf, "#define %s\t%d\n", name, val);
XX}
XX
XXstatic void putmain ()
XX{
XX char inproc [MAXIDLEN], outproc [MAXIDLEN];
XX
XX/* implementation should be refined, for now we don't do -c */
XX if (check || (makeast && rstring) || traceptr)
XX (void) fprintf (outf, "#include <stdio.h>\n");
XX if (makemain && makeast && rstring)
XX (void) fprintf (outf, "#include <sgtty.h>\n\n");
XX else
XX (void) fprintf (outf, "\n");
XX if (makemain)
XX {
XX (void) strcpy (inproc, (rstring ? "getfpstring" : "getfpdata"));
XX (void) strcpy (outproc, (wstring ? "putfpstrings" : "putfpdata"));
XX if (makeast)
XX (void) strcpy (inproc, (rstring ? "getfpchar" : "getfpdata"));
XX if (redirout)
XX (void) strcpy (outproc, "putcommands");
XX (void) fprintf (outf, "main (argc, argv)\nint argc;\nchar * argv [];\n{\n");
XX (void) fprintf (outf, " extern fp_data %s (), %s ();\n", inproc, mainfn);
XX (void) fprintf (outf, " extern int fpargc;\n extern char ** fpargv;\n");
XX if (check)
XX if (printspace)
XX (void) fprintf (outf, " extern void printstorage ();\n");
XX else
XX (void) fprintf (outf, " extern void checkstorage ();\n");
XX if (makeast)
XX {
XX (void) fprintf (outf, " extern struct fp_object nilobj;\n");
XX (void) fprintf (outf, " fp_data state;\n");
XX (void) fprintf (outf, " static struct fp_constant initstate = ");
XX (void) fprintf (outf, "{(short) NILOBJ, (short) 2};\n");
XX if (rstring)
XX {
XX (void) fprintf (outf, " struct sgttyb newtty, oldtty;\n");
XX (void) fprintf (outf, " struct sgttyb * savetty;\n");
XX }
XX }
XX (void) fprintf (outf, " extern void %s ();\n fp_data input, result;\n\n",
XX outproc);
XX if (makeee || makedeb)
XX (void) fprintf (outf,
XX " (void) fprintf (stderr, \"entering main\\n\");\n");
XX (void) fprintf (outf, " fpargc = argc;\n fpargv = argv;\n");
XX if (makeast) /* produce an applicative state transition system */
XX {
XX if (rstring)
XX {
XX (void) fprintf (outf, " savetty = &oldtty;\n");
XX (void) fprintf (outf, " ioctl (0, TIOCGETP, &oldtty);\n");
XX (void) fprintf (outf, " ioctl (0, TIOCGETP, &newtty);\n");
XX (void) fprintf (outf, " newtty.sg_flags |= CBREAK;\n");
XX (void) fprintf (outf, " ioctl (0, TIOCSETP, &newtty);\n");
XX }
XX (void) fprintf (outf, " state = (fp_data) & initstate;\n");
XX (void) fprintf (outf, " input = newpair ();\n");
XX (void) fprintf (outf, " input->fp_header.fp_next->fp_entry =");
XX (void) fprintf (outf, " (fp_data) & nilobj;\n");
XX (void) fprintf (outf, " input->fp_entry = & nilobj;\n");
XX (void) fprintf (outf, " while (1)\n {\n");
XX (void) fprintf (outf, " result = %s (input);\n", mainfn);
XX if (check)
XX {
XX (void) fprintf (outf, " if ((result->fp_type != VECTOR) ||\n");
XX (void) fprintf (outf, " (result->fp_header.fp_next == 0) ||\n");
XX (void) fprintf (outf, " (result->%s != 0))\n",
XX "fp_header.fp_next->fp_header.fp_next");
XX (void) fprintf (outf,
XX " genbottom (\"non-pair returned in AST\", result);\n");
XX }
XX (void) fprintf (outf,
XX " state = result->fp_header.fp_next->fp_entry;\n");
XX (void) fprintf (outf, " %s (result->fp_entry);\n", outproc);
XX (void) fprintf (outf, " if (state->fp_type == NILOBJ)\n");
XX (void) fprintf (outf, " break;\n");
XX (void) fprintf (outf, " inc_ref (state);\n");
XX (void) fprintf (outf, " dec_ref (result);\n");
XX (void) fprintf (outf, " input = newpair ();\n");
XX (void) fprintf (outf,
XX " input->fp_header.fp_next->fp_entry = state;\n");
XX (void) fprintf (outf, " input->fp_entry = %s ();\n", inproc);
XX (void) fprintf (outf, " }\n dec_ref (result);\n");
XX if (rstring)
XX (void) fprintf (outf, " ioctl (0, TIOCSETP, &oldtty);\n");
XX }
XX else /* normal, non-ast system */
XX {
XX if (useparms)
XX {
XX (void) fprintf (outf, " if (fpargc != 1)\n");
XX (void) fprintf (outf, " input = & nilobj;\n");
XX (void) fprintf (outf, " else\n ");
XX }
XX (void) fprintf (outf, " input = %s ();\n", inproc);
XX (void) fprintf (outf, " result = %s (input);\n", mainfn);
XX (void) fprintf (outf, " %s (result);\n", outproc);
XX (void) fprintf (outf, " dec_ref (result);\n");
XX }
XX if (makeee || makedeb)
XX (void) fprintf (outf,
XX " (void) fprintf (stderr, \"exiting main\\n\");\n");
XX if (check)
XX if (printspace)
XX (void) fprintf (outf, " printstorage ();\n");
XX else
XX (void) fprintf (outf, " checkstorage ();\n");
XX (void) fprintf (outf, " return (0);\n}\n\n");
XX }
XX}
XX
XXvoid putfileheader (in, out)
XXchar * in;
XXchar * out;
XX{
XX (void) fprintf (outf, "/* %s: target file generated by fpc from source %s */\n\n",
XX out, in);
XX putdefnum ("FALSEOBJ ", FALSEOBJ);
XX putdefnum ("TRUEOBJ ", TRUEOBJ);
XX putdefnum ("INTCONST ", INTCONST);
XX putdefnum ("FLOATCONST", FLOATCONST);
XX putdefnum ("ATOMCONST ", ATOMCONST);
XX putdefnum ("CHARCONST ", CHARCONST);
XX putdefnum ("NILOBJ ", NILOBJ);
XX putdefnum ("VECTOR ", VECTOR);
XX (void) fprintf (outf, "\ntypedef struct fp_object * fp_data;\n\n");
XX (void) fprintf (outf,
XX "struct fp_object\n{\n short fp_type;\n short fp_ref;\n");
XX (void) fprintf (outf, " union\n {\n long fp_int;\n int fp_char;\n");
XX (void) fprintf (outf, " char * fp_atom;\n float fp_float;\n");
XX (void) fprintf (outf, " fp_data fp_next;\n } fp_header;\n");
XX (void) fprintf (outf, " fp_data fp_entry;\n};\n\n");
XX (void) fprintf (outf, "struct fp_constant\n{\n short fp_type;\n");
XX (void) fprintf (outf, " short fp_ref;\n %s fp_value;\n", HEADERTYPE);
XX (void) fprintf (outf, " fp_data fp_entry;\n};\n\n");
XX (void) fprintf (outf, "struct fp_floatc\n{\n short fp_type;\n");
XX (void) fprintf (outf, " short fp_ref;\n %s fp_value;\n};\n\n", HEADERFLOAT);
XX (void) fprintf (outf, "struct fp_charc\n{\n short fp_type;\n");
XX (void) fprintf (outf, " short fp_ref;\n %s fp_value;\n};\n\n", HEADERCHAR);
XX if (check)
XX {
XX (void) fprintf (outf, "struct stackframe\n{\n char * st_name;\n");
XX (void) fprintf (outf, " fp_data st_data;\n");
XX (void) fprintf (outf, " struct stackframe * st_prev;\n};\n");
XX (void) fprintf (outf, "extern struct stackframe * stack;\n\n");
XX }
XX (void) fprintf (outf, "extern fp_data newvect ();\n");
XX (void) fprintf (outf, "extern fp_data newpair ();\n");
XX (void) fprintf (outf, "extern fp_data newcell ();\n");
XX (void) fprintf (outf, "extern fp_data newconst ();\n");
XX (void) fprintf (outf, "extern void returnvect ();\n");
XX (void) fprintf (outf, "extern struct fp_object nilobj;\n");
XX (void) fprintf (outf, "extern struct fp_object tobj;\n");
XX (void) fprintf (outf, "extern struct fp_object fobj;\n\n");
XX if (makedeb || makeee || traceptr)
XX (void) fprintf (outf, "extern int depthcount;\nextern int indent ();\n\n");
XX if (makedeb || traceptr)
XX (void) fprintf (outf, "extern void printfpdata ();\n\n");
XX if (check)
XX (void) fprintf (outf, "extern void genbottom ();\n\n");
XX putdefine ("inc_ref(d)", "((d)->fp_ref++)");
XX putdefine ("dec_ref(d)",
XX"if (((d)->fp_type == VECTOR) && \\\n\t\t\t\t(--((d)->fp_ref) <= 0)) returnvect (d)");
XX putdefine ("abs(n)", "((n) < 0 ? - (n) : (n))");
XX (void) fprintf (outf, "\n");
XX putmain ();
XX}
XX
XXvoid putfiletail ()
XX{
XX (void) fprintf (outf, "\n");
XX}
XX
XXstatic void traverse (tree, fn, pre)
XX/* traverses the tree, calling fn on each and every node */
XXfpexpr tree;
XXvoid ((* fn) ());
XXint pre;
XX{
XX fpexpr save = tree;
XX
XX if (pre)
XX (* fn) (tree);
XX switch (tree->exprtype)
XX {
XX case COND:
XX traverse (tree->fpexprv.conditional [0], (* fn), pre);
XX traverse (tree->fpexprv.conditional [1], (* fn), pre);
XX traverse (tree->fpexprv.conditional [2], (* fn), pre);
XX break;
XX case BU:
XX case BUR:
XX traverse (tree->fpexprv.bulr.bufun, (* fn), pre);
XX traverse (tree->fpexprv.bulr.buobj, (* fn), pre);
XX break;
XX case WHILE:
XX traverse (tree->fpexprv.whilestat [0], (* fn), pre);
XX traverse (tree->fpexprv.whilestat [1], (* fn), pre);
XX break;
XX case COMP:
XX case CONSTR:
XX while (tree != 0)
XX {
XX traverse (tree->fpexprv.compconstr.compexpr, (* fn), pre);
XX tree = tree->fpexprv.compconstr.compnext;
XX }
XX break;
XX case AA:
XX case INSERT:
XX case RINSERT:
XX case TREE:
XX case MULTI:
XX traverse (tree->fpexprv.aains, (* fn), pre);
XX break;
XX case LIST:
XX while (tree != 0)
XX {
XX traverse (tree->fpexprv.listobj.listel, (* fn), pre);
XX tree = tree->fpexprv.listobj.listnext;
XX }
XX break;
XX case SEL:
XX case RSEL:
XX case FNCALL:
XX case NIL:
XX case TRUE:
XX case FALSE:
XX case INT:
XX case FLOAT:
XX case SYM:
XX case CHAR:
XX break;
XX default:
XX yyerror ("compiler error 11");
XX }
XX if (! pre)
XX (* fn) (save);
XX}
XX
XXstatic void opt (tree)
XXfpexpr tree;
XX{
XX if (((tree->exprtype == INSERT) ||
XX (tree->exprtype == RINSERT) ||
XX (tree->exprtype == TREE)) &&
XX (tree->fpexprv.aains->exprtype == FNCALL) &&
XX ((strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0) ||
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0) ||
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0) ||
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0)))
XX/* means we can replace the call to insert by a call to MULTI */
XX tree->exprtype = MULTI;
XX/* wasn't that easy, now? */
XX}
XX
XXstatic fpexpr preoptimize (tree)
XXfpexpr tree;
XX{ /* as long as it doesn't change the meaning of the program,
XX * everything is fair game here */
XX/* the only optimization we do here is change (insert <f>), where <f>
XX * is one of {plus, times, and, or} to (multi <f>)
XX */
XX traverse (tree, opt, 0);
XX return (tree);
XX}
XX
XXstatic int nodevars (tree)
XXfpexpr tree;
XX{
XX char errbuf [256];
XX
XX switch (tree->exprtype)
XX {
XX case COND:
XX/* a -> b ; c : res := a; if (res) then res := b; else res := c; end */
XX case FNCALL:
XX/* f: res := f (arg); */
XX case SEL:
XX/* n: i1 := n; res := arg; while (--i1 > 0) res := cdr (res);
XX res := car (res); */
XX case RSEL:
XX/* n: i1 := 0; res := arg; while (res != 0) res := cdr (res); i1++;
XX i1 := i1 - n; res := arg; while (--i1 != 0) res := cdr (res);
XX res := car (res); */
XX case NIL:
XX case TRUE:
XX case FALSE:
XX case INT:
XX case FLOAT:
XX case SYM:
XX case CHAR:
XX case LIST: /* called for each list element */
XX return (0);
XX
XX case COMP:
XX/* a o b o c o d : r1 := d (arg); r2 := c (r1); r1 := b (r2); res := a (r1); */
XX if ((tree->fpexprv.compconstr.compnext != 0) && /* should never happen */
XX(tree->fpexprv.compconstr.compnext->fpexprv.compconstr.compnext != 0))
XX return (2);
XX case CONSTR:
XX/* [a, b] : res := new (2); chase := res; chase->car := b (arg);
XX chase = cdr (chase); chase->car := a (arg); */
XX case BU:
XX/* bu op v : res := v; r1 := newvect (res, arg); res := op (r1); */
XX case BUR:
XX/* bur op v : res := v; r1 := newvect (arg, res); res := op (r1); */
XX case MULTI:
XX/* \/f: r1 := arg; res := car (r1);
XX while (r1 != 0) res := op (res, car (r1)); r1 := cdr (r1); */
XX return (1);
XX
XX case RINSERT:
XX/* \a : res := car (arg); r1 := cdr (arg);
XX while (r1 != 0) r2 := cons (res, cons (car (r1), nil));
XX res := a (r2); r1 := cdr (r1); */
XX case AA:
XX/* aa e : if (arg == <>) then res := arg;
XX else r1 := arg; res := newvect (1); r2 := res;
XX while (r1 != 0) r2->el := e (car r1); r1 := cdr (r1);
XX if (r1 != 0) r2->next = newvect (1); r2 = cdr (r2); */
XX case WHILE:
XX/* while pred f : res := arg;
XX while (1)
XX r1 := pred (res); if (! r1) then break; arg := f (res); res := arg; */
XX return (2);
XX
XX case INSERT:
XX/* /a : r1 := 0; r2 := arg;
XX while (r2 != 0) r3 := cons (car (r2), r1); r1 := r3; r2 := cdr (r2);
XX res := car (r1); r1 := cdr (r1);
XX while (r1 != 0) r2 := cons (car (r1), cons (res, nil)); res := a (r2);
XX r1 := cdr (r1); */
XX return (3);
XX
XX case TREE:
XX/* \/a: r1 := arg;
XX while (cdr (r1) != 0)
XX r2 := r1; r1 := newcell (); r3 := r1;
XX while (r2 != 0)
XX if (cdr (r2) == 0) rplaca (r3, car (r2)); r2 := 0;
XX else
XX r4 := cons (car (r2), cons (cadr (r2), nil)); r2 := cddr (r2);
XX rplaca (r3, a(r4));
XX if (r2 != 0) rplacd (r3, newcell ()); r3 := cdr (r3);
XX res := car (r1); */
XX return (5); /* one more needed for storage management */
XX
XX default:
XX (void) sprintf (errbuf, "compiler error 12, type is %d", tree->exprtype);
XX yyerror (errbuf);
XX return (-1);
XX }
XX}
XX
XXstatic void countvar (tree)
XXfpexpr tree;
XX{
XX varsneeded += nodevars (tree);
XX selneeded = selneeded ||
XX (((tree->exprtype == SEL) || (tree->exprtype == RSEL)) &&
XX (tree->fpexprv.lrsel > 1));
XX}
XX
XXstatic countvars (tree)
XXfpexpr tree;
XX{
XX varsneeded = 0;
XX selneeded = 0;
XX traverse (tree, countvar, 1);
XX}
XX
XXstatic int constcount;
XX
XXstatic void declconst (tree)
XXfpexpr tree;
XX/* traverse procedure called in post-order traversal. It generates a
XX * new "constant variable" for the constant and stores it in the tree.
XX * It also generates a declaration for the constant itself, using
XX * the "constant variables" of the elements in case of lists.
XX * A constant declaration is of the form.
XX * static fp_data cnn = {type, 1, val, entry}
XX */
XX{
XX static char def1 [] = " static struct fp_constant ";
XX static char def2 [] = " =\n {(short) ";
XX static char def3 [] = ", (short) 1";
XX fpexpr next;
XX
XX if (tree->exprtype >= NIL)
XX {
XX (void) sprintf (tree->constvar, "c%d", constcount++);
XX/* we always use a new constant "variable" for a new constant
XX * encountered. That may be updated later to allow sharing of
XX * equal constants, as in equal nil/true/false and (less often)
XX * numbers, strings or lists. Not a high priority item, on V.M.
XX * systems */
XX switch (tree->exprtype)
XX {
XX case FALSE:
XX (void) fprintf (outf, "%s%s%s%s%s};\n", def1, tree->constvar,
XX def2, "FALSEOBJ", def3);
XX break;
XX case TRUE:
XX (void) fprintf (outf, "%s%s%s%s%s};\n", def1, tree->constvar,
XX def2, "TRUEOBJ", def3);
XX break;
XX case NIL:
XX (void) fprintf (outf, "%s%s%s%s%s};\n", def1, tree->constvar,
XX def2, "NILOBJ", def3);
XX break;
XX case INT:
XX (void) fprintf (outf, "%s%s%s%s%s, (%s) %d};\n", def1, tree->constvar,
XX def2, "INTCONST", def3, HEADERTYPE,
XX tree->fpexprv.intobj);
XX break;
XX case FLOAT:
XX (void) fprintf (outf, "%s%s%s%s%s, %lf};\n",
XX " static struct fp_floatc ", tree->constvar,
XX def2, "FLOATCONST", def3, tree->fpexprv.floatobj);
XX break;
XX case SYM:
XX (void) fprintf (outf, "%s%s%s%s%s, (%s) \"%s\"};\n", def1,
XX tree->constvar, def2, "ATOMCONST", def3,
XX HEADERTYPE, tree->fpexprv.symbol);
XX break;
XX case CHAR:
XX (void) fprintf (outf, "%s%s%s%s%s, '\\%o'};\n",
XX " static struct fp_charc ", tree->constvar,
XX def2, "CHARCONST", def3, tree->fpexprv.character);
XX break;
XX case LIST:
XX next = tree->fpexprv.listobj.listnext;
XX if (next != 0)
XX declconst (next);
XX (void) fprintf (outf, "%s%s%s%s%s, (%s) %c%s, (fp_data) &%s};\n", def1,
XX tree->constvar, def2, "VECTOR", def3, HEADERTYPE,
XX ((next == 0) ? '0' : '&'),
XX ((next == 0) ? "" : next->constvar),
XX tree->fpexprv.listobj.listel->constvar);
XX break;
XX default: /* error */
XX yyerror ("compiler error 13");
XX }
XX } /* else it is not a constant, ignore it */
XX}
XX
XXstatic char externs [MAXIDS] [MAXIDLEN];
XXstatic int extptr;
XX
XXstatic void putoneextern (tree)
XXfpexpr tree;
XX{
XX int search = 0;
XX char buf [MAXIDLEN];
XX
XX if (tree->exprtype == FNCALL)
XX {
XX if (strcmp (tree->fpexprv.funcall, "times") == 0)
XX (void) strcpy (buf, "fptimes");
XX else
XX (void) strcpy (buf, tree->fpexprv.funcall);
XX while ((search < extptr) &&
XX (strcmp (buf, externs [search]) != 0))
XX search++;
XX if (search == extptr) /* must insert new name */
XX (void) strcpy (externs [extptr++], buf);
XX }
XX}
XX
XXstatic void putexterns (tree, fun)
XXfpexpr tree;
XXchar * fun;
XX{
XX (void) strcpy (externs [0], fun);
XX extptr = 1;
XX traverse (tree, putoneextern, 1);
XX if (extptr > 1)
XX {
XX (void) fprintf (outf, " extern fp_data");
XX while (--extptr > 0)
XX {
XX (void) fprintf (outf, " %s ()%s", externs [extptr],
XX (extptr == 1) ? ";\n" : ",");
XX if (((extptr - 1) & DCLEMASK) == DCLEMASK)
XX (void) fprintf (outf, "\n\t\t");
XX }
XX }
XX}
XX
XXstatic int freevar;
XX
XXstatic void declvars (vars, hassel)
XXint vars, hassel;
XX{
XX freevar = 0;
XX if (hassel)
XX (void) fprintf (outf, " register int sel;\n");
XX (void) fprintf (outf, " fp_data");
XX while (vars-- > 0)
XX {
XX (void) fprintf (outf, " d%d,", vars);
XX if ((vars & DCLMASK) == DCLMASK)
XX (void) fprintf (outf, "\n\t ");
XX }
XX (void) fprintf (outf, " res;\n");
XX if (check)
XX (void) fprintf (outf, " struct stackframe stackentry;\n");
XX (void) fprintf (outf, "\n");
XX}
XX
XXvoid newvar (buf)
XXchar * buf;
XX{
XX (void) sprintf (buf, "d%d", freevar++);
XX}
XX
XXstatic int tracingfn;
XX
XXstatic void entertrace (fname)
XXchar * fname;
XX{
XX if (makeee || makedeb || tracingfn)
XX {
XX (void) fprintf (outf,
XX " depthcount += 2;\n indent (depthcount, stderr);\n");
XX if (makedeb || tracingfn)
XX {
XX (void) fprintf (outf, " (void) fprintf (stderr, \"entering %s, data is\\n\");\n",
XX fname);
XX (void) fprintf (outf, " printfpdata (stderr, data, depthcount);\n");
XX (void) fprintf (outf, " (void) fprintf (stderr, \"\\n\");\n");
XX }
XX else
XX (void) fprintf (outf, " (void) fprintf (stderr, \"entering %s\\n\");\n", fname);
XX }
XX if (check) /* keep the stack */
XX {
XX (void) fprintf (outf, " stackentry.st_prev = stack;\n");
XX (void) fprintf (outf, " stackentry.st_data = data;\n inc_ref (data);\n");
XX (void) fprintf (outf, " stackentry.st_name = \"%s\";\n", fname);
XX (void) fprintf (outf, " stack = & stackentry;\n", fname);
XX }
XX}
XX
XXstatic void putheader (fname, vars, hassel, tree)
XXchar * fname;
XXint vars, hassel;
XXfpexpr tree;
XX{
XX int trace;
XX
XX for (trace = 0;
XX (trace < traceptr) && (strcmp (tracefns [trace], fname) != 0);
XX trace++)
XX ;
XX tracingfn = (trace < traceptr); /* are we tracing this function? */
XX (void) fprintf (outf, "fp_data %s (data)\nfp_data data;\n{\n", fname);
XX putexterns (tree, fname);
XX constcount = 0;
XX traverse (tree, declconst, 0); /* declare the static constants */
XX declvars (vars, hassel);
XX entertrace (fname);
XX}
XX
XXstatic void putfinish (fname)
XXchar * fname;
XX{
XX if (makeee || makedeb || tracingfn)
XX {
XX (void) fprintf (outf,
XX " indent (depthcount, stderr);\n depthcount -= 2;\n");
XX if (makedeb || tracingfn)
XX {
XX (void) fprintf (outf, " (void) fprintf (stderr, \"exiting %s, result is\\n\");\n",
XX fname);
XX (void) fprintf (outf, " printfpdata (stderr, res, depthcount);\n");
XX (void) fprintf (outf, " (void) fprintf (stderr, \"\\n\");\n");
XX }
XX else
XX (void) fprintf (outf, " (void) fprintf (stderr, \"exiting %s\\n\");\n", fname);
XX }
XX if (check) /* restore the stack */
XX {
XX (void) fprintf (outf, " dec_ref (data);\n");
XX (void) fprintf (outf, " stack = stackentry.st_prev;\n");
XX }
XX (void) fprintf (outf, " return (res);\n}\n\n");
XX tracingfn = 0;
XX}
SHAR_EOF
if test 20383 -ne "`wc -c code.c`"
then
echo shar: error transmitting code.c '(should have been 20383 characters)'
fi
echo shar: extracting code.h '(843 characters)'
sed 's/^XX//' << \SHAR_EOF > code.h
XX/* code.h: defines the constants used by code.c not declared in parse.h */
XX
XX#define DCLMASK 0x7 /* There will be at most DCLMASK+1 declarations */
XX /* on a single line. This value only affects */
XX /* pretty-printing and should be 2^x-1 for some x */
XX
XX#define DCLEMASK 0x3 /* Like DCLMASK, but for externs, which are longer */
XX
XX#define HEADERTYPE "long"
XX /* this must be a type of the same size as the */
XX /* largest element of the union {...} fp_header */
XX /* in the declaration of fp_object. Otherwise, */
XX /* the declaration of constants will be incorrect */
XX
XX#define HEADERFLOAT "float" /* this is the type of fp_float */
XX
XX#define HEADERCHAR "int" /* this is the type of fp_char */
XX
XX#define BRACE (void) fprintf (outf, "%s{\n", indentstr ()); indent (1)
XX
XX#define UNBRACE (void) indent (0); fprintf (outf, "%s}\n", indentstr ())
SHAR_EOF
if test 843 -ne "`wc -c code.h`"
then
echo shar: error transmitting code.h '(should have been 843 characters)'
fi
echo shar: extracting expr.c '(26310 characters)'
sed 's/^XX//' << \SHAR_EOF > expr.c
XX/* expr.c: produce code for the expression encoded by the parse tree. */
XX
XX#include <stdio.h>
XX#include <strings.h>
XX#include "fpc.h"
XX#include "parse.h"
XX#include "code.h"
XX#include "fp.h"
XX
XXextern void newvar ();
XXextern char * sprintf ();
XX
XXstatic void codecond ();
XXstatic void codebu ();
XXstatic void codewhile ();
XXstatic void codecomp ();
XXstatic void codeaa ();
XXstatic void codeconstr ();
XXstatic void codeinsert ();
XXstatic void codesel ();
XXstatic void codefncall ();
XXstatic void codeconst ();
XXstatic void codemulti ();
XX
XXvoid codeexpr (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX{
XX int type = 0;
XX/* used to distinguish between slightly different functional forms that
XX * use the same procedure to generate code.
XX */
XX
XX switch (tree->exprtype)
XX {
XX case COND:
XX codecond (tree, invar, outvar);
XX break;
XX case BUR:
XX type++;
XX case BU:
XX codebu (tree, type, invar, outvar);
XX break;
XX case WHILE:
XX codewhile (tree, invar, outvar);
XX break;
XX case COMP:
XX codecomp (tree, invar, outvar);
XX break;
XX case AA:
XX codeaa (tree, invar, outvar);
XX break;
XX case CONSTR:
XX codeconstr (tree, invar, outvar);
XX break;
XX case TREE:
XX type++;
XX case RINSERT:
XX type++;
XX case INSERT:
XX codeinsert (tree, type, invar, outvar);
XX break;
XX case MULTI:
XX codemulti (tree, invar, outvar);
XX break;
XX case RSEL:
XX type++;
XX case SEL:
XX codesel (tree, type, invar, outvar);
XX break;
XX case FNCALL:
XX codefncall (tree, invar, outvar);
XX break;
XX default:
XX if ((tree->exprtype >= NIL) && (tree->exprtype <= CHAR))
XX codeconst (tree, invar, outvar);
XX else
XX yyerror ("compiler error 10");
XX }
XX}
XX
XXstatic int indlev = 1;
XX
XXstatic void indent (plus)
XXint plus;
XX{
XX if (plus > 0)
XX indlev++;
XX else
XX indlev--;
XX}
XX
XXstatic char * indentstr ()
XX/* returns a reference to a string with 2*indlev blanks. Notice that
XX * successive calls will refer to the same string.... 'nuff said. */
XX{
XX register char * str;
XX register int count;
XX static char blanks [1024] = "";
XX
XX if (indlev > 511)
XX yyerror ("error: expression nesting too great");
XX count = indlev;
XX for (str = blanks; count > 3; *(str++) = '\t')
XX count -= 4;
XX count *= 2;
XX for ( ; count > 0; *(str++) = ' ')
XX count -= 1;
XX *str = '\0';
XX return (blanks);
XX}
XX
XXstatic void codecond (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX/* a -> b ; c : res := a; if (res) then res := b; else res := c; end */
XX{
XX (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), invar);
XX codeexpr (tree->fpexprv.conditional [0], invar, outvar); /* r := a (d); */
XX (void) fprintf (outf, "%sif (%s->fp_type%s)\n", /* if (r) */
XX indentstr (), outvar, (check)? " == TRUEOBJ" : "");
XX BRACE;
XX codeexpr (tree->fpexprv.conditional [1], invar, outvar); /* r := b (d); */
XX UNBRACE;
XX (void) fprintf (outf, "%selse", indentstr ()); /* else */
XX if (check)
XX (void) fprintf (outf, " if (%s->fp_type == FALSEOBJ)", outvar);
XX (void) fprintf (outf, "\n");
XX BRACE;
XX codeexpr (tree->fpexprv.conditional [2], invar, outvar); /* r := c (d); */
XX UNBRACE;
XX if (check)
XX (void) fprintf (outf,
XX "%selse\n%s genbottom (\"%s\", %s);\n",
XX indentstr (), indentstr (), "in conditional: non-boolean pred",
XX outvar);
XX}
XX
XXstatic void codebu (tree, right, invar, outvar)
XXfpexpr tree;
XXint right;
XXchar * invar, * outvar;
XX/* bu op v : res := v; r1 := newvect (res, arg); res := op (r1);
XX bur op v : res := v; r1 := newvect (arg, res); res := op (r1); */
XX{
XX char pair [MAXIDLEN];
XX/* later on should optimize bu/r op x for op in {=, !=, +, -, *, div, mod}
XX * and for x an atomic type */
XX
XX codeconst (tree->fpexprv.bulr.buobj, "", outvar);
XX newvar (pair);
XX (void) fprintf (outf, "%s%s = newpair ();\n", indentstr (), pair);
XX (void) fprintf (outf, "%s%s->fp_header.fp_next->fp_entry = %s;\n",
XX indentstr (), pair, (right) ? outvar : invar);
XX (void) fprintf (outf, "%s%s->fp_entry = %s;\n",
XX indentstr (), pair, (right) ? invar : outvar);
XX codeexpr (tree->fpexprv.bulr.bufun, pair, outvar);
XX}
XX
XXstatic void codewhile (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX/* while pred f : res := arg;
XX while (1)
XX r1 := pred (res); if (! r1) then break; arg := f (res); res := arg; */
XX{
XX char predicate [MAXIDLEN];
XX char result [MAXIDLEN];
XX
XX newvar (predicate);
XX newvar (result);
XX (void) fprintf (outf, "%s%s = %s;\n%swhile (1)\n",
XX indentstr (), outvar, invar, indentstr ());
XX BRACE;
XX (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), outvar);
XX codeexpr (tree->fpexprv.whilestat [0], outvar, predicate);
XX/* notice: need not dec_ref (predicate) since the result is
XX ALWAYS a boolean, so dec_ref'ing it would make no difference */
XX (void) fprintf (outf, "%sif (%s %s->fp_type)\n%s break;\n",
XX indentstr (), ((check) ? "FALSEOBJ ==" : "!"),
XX predicate, indentstr ());
XX if (check)
XX (void) fprintf (outf, "%selse if (%s->fp_type != TRUEOBJ)\n%s %s%s);\n",
XX indentstr (), predicate, indentstr (),
XX "genbottom (\"predicate for while is not boolean\", ", predicate);
XX codeexpr (tree->fpexprv.whilestat [1], outvar, result);
XX (void) fprintf (outf, "%s%s = %s;\n", indentstr (), outvar, result);
XX UNBRACE;
XX}
XX
XXstatic void codecomp (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX/* a o b o c o d : r1 := d (arg); r2 := c (r1); r1 := b (r2); res := a (r1); */
XX/* we need to alternate use of r1 and r2 since some of the functional forms
XX will generate wierd code if given the same input and output variable */
XX{
XX char pass [2] [MAXIDLEN];
XX char count = 0;
XX
XX newvar (pass [0]);
XX if ((tree->fpexprv.compconstr.compnext != 0) && /* should never happen */
XX (tree->fpexprv.compconstr.compnext->fpexprv.compconstr.compnext != 0))
XX/* the second expression will return false if we have (a o b) */
XX newvar (pass [1]);
XX while (tree != 0)
XX {
XX if (tree->fpexprv.compconstr.compnext != 0)
XX codeexpr (tree->fpexprv.compconstr.compexpr, invar, pass [count]);
XX else
XX codeexpr (tree->fpexprv.compconstr.compexpr, invar, outvar);
XX invar = pass [count];
XX count = (count + 1) % 2;
XX tree = tree->fpexprv.compconstr.compnext;
XX }
XX}
XX
XXstatic void codeaa (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX/* aa e : if (arg == <>) then res := arg;
XX else r1 := arg; res := newcell (); r2 := res;
XX while (r1 != 0) r2->el := e (car r1); r1 := cdr (r1);
XX if (r1 != 0) r2->next = newcell (); r2 = cdr (r2); */
XX{
XX char chasearg [MAXIDLEN], chaseres [MAXIDLEN], tempres [MAXIDLEN],
XX tempval [MAXIDLEN];
XX
XX (void) fprintf (outf, "%sif (%s->fp_type == NILOBJ)\n%s %s = %s;\n%selse",
XX indentstr (), invar, indentstr (), outvar, invar, indentstr ());
XX if (check)
XX (void) fprintf (outf, " if (%s->fp_type == VECTOR)", invar);
XX newvar (chasearg);
XX newvar (chaseres);
XX (void) fprintf (outf, "\n");
XX BRACE;
XX (void) fprintf (outf, "%s%s = %s;\n%s%s = %s = newcell ();\n",
XX indentstr (), chasearg, invar,
XX indentstr (), chaseres, outvar);
XX (void) fprintf (outf, "%swhile (1)\n", indentstr ());
XX BRACE;
XX (void) sprintf (tempres, "%s->fp_entry", chaseres);
XX (void) sprintf (tempval, "%s->fp_entry", chasearg);
XX (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), tempval);
XX codeexpr (tree->fpexprv.aains, tempval, tempres);
XX (void) fprintf (outf, "%sif (%s = %s->fp_header.fp_next)\n",
XX indentstr (), chasearg, chasearg, indentstr ());
XX (void) fprintf (outf, "%s %s = %s->fp_header.fp_next = newcell ();\n",
XX indentstr (), chaseres, chaseres);
XX (void) fprintf (outf, "%selse\n%s break;\n", indentstr (), indentstr ());
XX UNBRACE;
XX UNBRACE;
XX if (check)
XX (void) fprintf (outf,
XX "%selse\n%s genbottom (\"%s\", %s);\n",
XX indentstr (), indentstr (),
XX "apply-to-all called with atomic argument", invar);
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
XX}
XX
XXstatic void codeconstr (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX/* [a, b] : res := new (2); chase := res; chase->car := b (arg);
XX chase = cdr (chase); chase->car := a (arg); */
XX{
XX int length;
XX fpexpr subtree = tree;
XX char chase [MAXIDLEN];
XX char tempres [MAXIDLEN];
XX
XX for (length = 0; subtree != 0; length++)
XX subtree = subtree->fpexprv.compconstr.compnext;
XX newvar (chase);
XX (void) sprintf (tempres, "%s->fp_entry", chase);
XX if (length > 2)
XX (void) fprintf (outf, "%s%s = %s = newvect (%d);\n", indentstr (),
XX outvar, chase, length);
XX else if (length == 2)
XX (void) fprintf (outf, "%s%s = %s = newpair ();\n", indentstr (),
XX outvar, chase);
XX else
XX (void) fprintf (outf, "%s%s = %s = newcell ();\n", indentstr (),
XX outvar, chase);
XX if (length > 1)
XX (void) fprintf (outf, "%s%s->fp_ref += %d;\n", indentstr (), invar,
XX length - 1);
XX while (tree != 0)
XX {
XX codeexpr (tree->fpexprv.compconstr.compexpr, invar, tempres);
XX tree = tree->fpexprv.compconstr.compnext;
XX if (tree != 0)
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
XX indentstr (), chase, chase);
XX }
XX}
XX
XXstatic void codemulti (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX{
XX/* multi f: r1 := arg; res := newconst (); res->val := initval;
XX while (r1 != 0) res := op (res, car (r1)); r1 := cdr (r1); */
XX char var1 [MAXIDLEN];
XX int optype; /* 0 for +, 1 for *, 2 for and, 3 for or */
XX int isand;
XX int isplus;
XX char opchar; /* + for +, * for * */
XX
XX newvar (var1);
XX if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0)
XX optype = 0;
XX else if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0)
XX optype = 1;
XX else if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0)
XX optype = 2;
XX else if (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0)
XX optype = 3;
XX else
XX yyerror ("compiler error 20");
XX if (check)
XX {
XX (void) fprintf (outf, "%sif (%s->fp_type != VECTOR)\n",
XX indentstr (), invar);
XX indent (1);
XX (void) fprintf (outf,
XX"%sgenbottom (\"error in insert: argument not a vector\", %s);\n",
XX indentstr (), invar);
XX indent (0);
XX }
XX/* multi f: r1 := arg; */
XX (void) fprintf (outf, "%s%s = %s;\n", indentstr (), var1, invar);
XX if (optype > 1)
XX {
XX isand = (optype == 2);
XX/* while ((r1 != 0) && (car (r1) != true[false])) r1 := cdr (r1); */
XX (void) fprintf (outf, "%swhile (%s && ", indentstr (), var1);
XX if (isand)
XX if (check)
XX (void) fprintf (outf, "(%s->fp_entry->fp_type == TRUEOBJ))\n", var1);
XX else
XX (void) fprintf (outf, "%s->fp_entry->fp_type)\n", var1);
XX else
XX (void) fprintf (outf, "(%s->fp_entry->fp_type == FALSEOBJ))\n", var1);
XX indent (1);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n", indentstr (),
XX var1, var1);
XX indent (0);
XX/* if (r1 == 0) res := default else res := other */
XX (void) fprintf (outf, "%sif (%s)\n", indentstr (), var1);
XX indent (1);
XX if (check)
XX {
XX (void) fprintf (outf, "%sif (%s->fp_entry->fp_type != %sOBJ)\n",
XX indentstr (), var1, (isand ? "FALSE" : "TRUE"));
XX indent (1);
XX (void) fprintf (outf,
XX"%sgenbottom (\"error in insert %s: argument not a boolean vector\", %s);\n",
XX indentstr (), (isand ? "and" : "or"), invar);
XX indent (0);
XX (void) fprintf (outf, "%selse\n", indentstr ());
XX indent (1);
XX }
XX (void) fprintf (outf, "%s%s = & %cobj;\n", indentstr (), outvar,
XX (isand ? 'f' : 't'));
XX if (check)
XX indent (0);
XX indent (0);
XX (void) fprintf (outf, "%selse\n", indentstr ());
XX indent (1);
XX (void) fprintf (outf, "%s%s = & %cobj;\n", indentstr (), outvar,
XX (isand ? 't' : 'f'));
XX indent (0);
XX }
XX else /* numeric */
XX {
XX isplus = (optype == 0);
XX opchar = isplus ? '+' : '*';
XX/* multi f: r1 := arg; res := newconst (INT); res->val := 0|1; */
XX (void) fprintf (outf, "%s%s = newconst (INTCONST);\n", indentstr (),
XX outvar);
XX (void) fprintf (outf, "%sif (%s->fp_entry->fp_type == INTCONST)\n",
XX indentstr (), var1);
XX BRACE;
XX (void) fprintf (outf, "%s%s->fp_header.fp_int = ", indentstr (), outvar);
XX (void) fprintf (outf, "%s->fp_entry->fp_header.fp_int;\n", var1);
XX/* while (d0 && (d0->car->type == int)) res += d0->car->val; d0 = cdr (d0); */
XX (void) fprintf (outf, "%swhile ((%s = %s->fp_header.fp_next) && ",
XX indentstr (), var1, var1);
XX (void) fprintf (outf, "(%s->fp_entry->fp_type == INTCONST))\n", var1);
XX if (check) /* need to check for arithmetic overflow */
XX {
XX BRACE;
XX if (isplus)
XX {
XX (void) fprintf (outf, "%sif (((%s->fp_header.fp_int < 0) == ",
XX indentstr (), outvar);
XX (void) fprintf (outf, "(%s->fp_entry->fp_header.fp_int < 0)) &&\n",
XX var1);
XX }
XX else
XX (void) fprintf (outf, "%sif ((%s->fp_header.fp_int != 0) &&\n",
XX indentstr (), outvar);
XX indent (1);
XX indent (1);
XX (void) fprintf (outf, "%s((%d %c abs (%s->fp_header.fp_int))",
XX indentstr (), MAXINT, (isplus ? '-' : '/'), outvar);
XX (void) fprintf (outf, " < abs (%s->fp_entry->fp_header.fp_int)))\n",
XX var1);
XX
XX indent (0);
XX (void) fprintf (outf, "%sgenbottom (\"overflow in insert %c\", %s);\n",
XX indentstr (), opchar, invar);
XX indent (0);
XX }
XX else
XX indent (1);
XX (void) fprintf (outf, "%s%s->fp_header.fp_int ", indentstr (), outvar);
XX (void) fprintf (outf, "%c= %s->fp_entry->fp_header.fp_int;\n",
XX opchar, var1);
XX if (check)
XX {
XX UNBRACE;
XX }
XX else
XX indent (0);
XX UNBRACE;
XX (void) fprintf (outf, "%selse\n", indentstr ());
XX indent (1);
XX (void) fprintf (outf, "%s%s->fp_header.fp_int = %c;\n", indentstr (),
XX outvar, (isplus ? '0' : '1'));
XX indent (0);
XX (void) fprintf (outf, "%sif (%s)\n", indentstr (), var1);
XX BRACE;
XX (void) fprintf (outf, "%s%s->fp_header.fp_float =", indentstr (), outvar);
XX (void) fprintf (outf, " %s->fp_header.fp_int;\n", outvar);
XX (void) fprintf (outf, "%s%s->fp_type = FLOATCONST;\n", indentstr (),
XX outvar);
XX (void) fprintf (outf, "%swhile (%s)\n", indentstr (), var1);
XX BRACE;
XX (void) fprintf (outf, "%sif (%s->fp_entry->fp_type == FLOATCONST)\n",
XX indentstr (), var1);
XX indent (1);
XX (void) fprintf (outf, "%s%s->fp_header.fp_float ", indentstr (), outvar);
XX (void) fprintf (outf, "%c= %s->fp_entry->fp_header.fp_float;\n",
XX opchar, var1);
XX indent (0);
XX if (check)
XX {
XX (void) fprintf (outf, "%selse if (%s->fp_entry->fp_type != INTCONST)\n",
XX indentstr (), var1);
XX indent (1);
XX (void) fprintf (outf,
XX"%sgenbottom (\"error in insert %c: argument not a numeric vector\", %s);\n",
XX indentstr (), opchar, invar);
XX indent (0);
XX }
XX (void) fprintf (outf, "%selse\n", indentstr ());
XX indent (1);
XX (void) fprintf (outf, "%s%s->fp_header.fp_float ", indentstr (), outvar);
XX (void) fprintf (outf, "%c= %s->fp_entry->fp_header.fp_int;\n",
XX opchar, var1);
XX indent (0);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n", indentstr (),
XX var1, var1);
XX UNBRACE;
XX UNBRACE;
XX }
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
XX}
XX
XXstatic void codeinsert (tree, type, invar, outvar)
XXfpexpr tree;
XXint type; /* 0 for left, 1 for right, 2 for tree */
XXchar * invar, * outvar;
XX/* /a : r3 := 0; r2 := arg;
XX while (r2 != 0) r1 := cons (car (r2), r3); r3 := r1; r2 := cdr (r2);
XX res := car (r3); r1 := cdr (r3);
XX while (r1 != 0) r2 := cons (car (r1), cons (res, nil));
XX res := a (r2); r1 := cdr (r1);
XX \a : res := car (arg); r1 := cdr (arg);
XX while (r1 != 0) r2 := cons (res, cons (car (r1), nil));
XX res := a (r2); r1 := cdr (r1);
XX \/a: r1 = arg;
XX while (r1->cdr != 0)
XX r2 := r1; r1 := newcell (); r3 := r1;
XX while (r2 != 0)
XX if (r2->cdr == 0) r3->car = r2->car; r2 = 0;
XX else
XX r4 = newpair (); r4->car = r2->car; r2 = r2->cdr;
XX r4->cdr->car = r2->car; r2 = r2->cdr; r3->car = a (r4);
XX if (r2 != 0) r3->cdr = newcell (); r3 = r3->cdr;
XX res = r1->car; */
XX{
XX char insertname [13];
XX char var1 [MAXIDLEN],
XX var2 [MAXIDLEN],
XX var3 [MAXIDLEN],
XX var4 [MAXIDLEN],
XX var5 [MAXIDLEN], /* used for ref count in tree insert */
XX argvar [MAXIDLEN], /* this is the argument to the fn in rins */
XX varcar [MAXIDLEN];
XX
XX newvar (var1);
XX newvar (var2);
XX switch (type)
XX {
XX case 0: /* normal insert */
XX (void) strcpy (insertname, "left insert");
XX newvar (var3);
XX (void) strcpy (argvar, var3);
XX break;
XX case 1: /* right insert */
XX (void) strcpy (insertname, "right insert");
XX (void) strcpy (argvar, invar);
XX break;
XX default: /* tree insert */
XX (void) strcpy (insertname, "tree insert");
XX newvar (var3);
XX newvar (var4);
XX newvar (var5);
XX (void) sprintf (varcar, "%s->fp_entry", var3);
XX break;
XX }
XX if (check)
XX {
XX (void) fprintf (outf, "%sif (%s->fp_type != VECTOR)\n",
XX indentstr (), invar);
XX (void) fprintf (outf, "%s genbottom (\"%s%s\", %s);\n", indentstr (),
XX "non-vector passed to ", insertname, invar);
XX }
XX switch (type)
XX {
XX case 0: /* normal insert */
XX/* r3 := 0; r2 := arg; */
XX (void) fprintf (outf, "%s%s = 0;\n%s%s = %s;\n", indentstr (),
XX var3, indentstr (), var2, invar);
XX/* while (r2 != 0) r1 := cons (car (r2), r3); r3 := r1; r2 := cdr (r2); */
XX/* i.e., reverse+copy arg into ra. Increment the refs of each element
XX of arg, afterwards return arg, and the elements will stay. */
XX (void) fprintf (outf, "%swhile (%s)\n", indentstr (), var2);
XX BRACE;
XX (void) fprintf (outf, "%s%s = newcell ();\n", indentstr (), var1);
XX (void) fprintf (outf, "%s%s->fp_header.fp_next = %s;\n",
XX indentstr (), var1, var3);
XX (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n%s%s = %s;\n",
XX indentstr (), var1, var2, indentstr (), var3, var1);
XX (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var3);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
XX indentstr (), var2, var2);
XX UNBRACE;
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
XX case 1: /* right insert */
XX/* res := car (arg/r3); r1 := cdr (arg/r3); */
XX (void) fprintf (outf, "%s%s = %s->fp_entry;\n", indentstr (),
XX outvar, argvar);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n", indentstr (),
XX var1, argvar);
XX (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), outvar);
XX/* while (r1 != 0) r2 := cons (res, cons (car (r1), nil));
XX r2 := cons (car (r1), cons (res, nil));
XX res := a (r2); r1 := cdr (r1); */
XX (void) fprintf (outf, "%swhile (%s)\n",
XX indentstr (), var1);
XX BRACE;
XX (void) fprintf (outf, "%s%s = newpair ();\n", indentstr (), var2);
XX if (type == 0)
XX {
XX (void) fprintf (outf, "%s%s->fp_header.fp_next->fp_entry = %s;\n",
XX indentstr (), var2, outvar);
XX (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n",
XX indentstr (), var2, var1);
XX }
XX else
XX {
XX (void) fprintf (outf, "%s%s->fp_entry = %s;\n",
XX indentstr (), var2, outvar);
XX (void) fprintf (outf,
XX "%s%s->fp_header.fp_next->fp_entry = %s->fp_entry;\n",
XX indentstr (), var2, var1);
XX }
XX (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var1);
XX codeexpr (tree->fpexprv.aains, var2, outvar);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
XX indentstr (), var1, var1);
XX UNBRACE;
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), argvar);
XX break;
XX default: /* tree insert */
XX/* \/a: r1 = arg; */
XX (void) fprintf (outf, "%s%s = %s;\n", indentstr (), var1, invar);
XX/* while (r1->cdr != 0) */
XX (void) fprintf (outf, "%swhile (%s->fp_header.fp_next%s)\n",
XX indentstr (), var1, (check ? " != 0" : ""));
XX BRACE;
XX/* r2 = r1; r1 := r3 := newcell (); */
XX (void) fprintf (outf, "%s%s = %s = %s;\n", indentstr (), var2,
XX var5, var1);
XX (void) fprintf (outf, "%s%s = %s = newcell ();\n", indentstr (),
XX var1, var3);
XX/* while (r2 != 0) */
XX (void) fprintf (outf, "%swhile (%s%s)\n", indentstr (), var2,
XX (check ? " != 0" : ""));
XX indent (1);
XX/* if (r2->cdr == 0) r3->car := r2->car; r2 := 0; */
XX/* else */
XX (void) fprintf (outf, "%sif (%s->fp_header.fp_next == 0)\n",
XX indentstr (), var2);
XX BRACE;
XX (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n",
XX indentstr (), var3, var2);
XX (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var2);
XX (void) fprintf (outf, "%s%s = 0;\n", indentstr (), var2);
XX UNBRACE;
XX (void) fprintf (outf, "%selse\n", indentstr ());
XX BRACE;
XX/* r4 := newpair (); r4->car := r2->car; r2 := r2->cdr; */
XX (void) fprintf (outf, "%s%s = newpair ();\n", indentstr (), var4);
XX (void) fprintf (outf, "%s%s->fp_entry = %s->fp_entry;\n",
XX indentstr (), var4, var2);
XX (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var2);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
XX indentstr (), var2, var2);
XX/* r4->cdr->car := r2->car; r2 := r2->cdr; r3->car := a (r4); */
XX (void) fprintf (outf,
XX "%s%s->fp_header.fp_next->fp_entry = %s->fp_entry;\n",
XX indentstr (), var4, var2);
XX (void) fprintf (outf, "%sinc_ref (%s->fp_entry);\n", indentstr (), var2);
XX (void) fprintf (outf, "%s%s = %s->fp_header.fp_next;\n",
XX indentstr (), var2, var2);
XX codeexpr (tree->fpexprv.aains, var4, varcar);
XX/* if (r2 != 0) r3->cdr := newcell (); r3 := r3->cdr; */
XX (void) fprintf (outf, "%sif (%s%s)\n", indentstr (), var2,
XX (check ? " != 0" : ""));
XX (void) fprintf (outf,
XX "%s %s = %s->fp_header.fp_next = newcell ();\n",
XX indentstr (), var3, var3);
XX/* res := r1->car; */
XX UNBRACE;
XX indent (0);
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), var5);
XX UNBRACE;
XX (void) fprintf (outf, "%s%s = %s->fp_entry;\n",
XX indentstr (), outvar, var1);
XX (void) fprintf (outf, "%sinc_ref (%s);\n", indentstr (), outvar);
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), var1);
XX break;
XX }
XX}
XX
XXstatic void codesel (tree, right, invar, outvar)
XXfpexpr tree;
XXint right;
XXchar * invar, * outvar;
XX/* n: i1 := n; r := d; while (--i1 != 0) r := cdr (r);
XX r := car (r);
XX nr: i1 := 0; r := d; while (r != 0) r := cdr (r); i1++;
XX i1 := i1 - (n - 1); r := d; while (--i1 != 0) r := cdr (r);
XX r := car (r); */
XX/* notice that selectors of 1 are special cases, since they occurr
XX * very frequently and can be optimized a bit */
XX{
XX char * ind;
XX char * errmess = "argument too short for ";
XX char checkstr [256];
XX int selector;
XX
XX checkstr [0] = '\0';
XX selector = tree->fpexprv.lrsel;
XX ind = indentstr ();
XX if (check)
XX {
XX (void) fprintf (outf, "%sif (%s->fp_type != VECTOR)\n", ind, invar);
XX (void) fprintf (outf,
XX "%s genbottom (\"selector %d%s applied to nonvector\", %s);\n",
XX ind, selector, (right) ? "r" : "", invar);
XX }
XX if (selector == 1) /* first or last */
XX {
XX if (right) /* last: common special case */
XX {
XX (void) fprintf (outf, "%s%s = %s;\n", ind, outvar, invar); /* r := d; */
XX (void) fprintf (outf, /* while (cdr (r) != 0) */
XX "%swhile (%s->fp_header.fp_next)\n", ind, outvar);
XX (void) fprintf (outf, /* r = cdr (r); */
XX "%s %s = %s->fp_header.fp_next;\n", ind,
XX outvar, outvar);
XX (void) fprintf (outf, /* r = car (r); */
XX "%s%s = %s->fp_entry;\n", ind, outvar, outvar);
XX }
XX else /* first: *very* common special case */
XX/* r := car (d); */
XX (void) fprintf (outf, "%s%s = %s->fp_entry;\n", ind, outvar, invar);
XX }
XX else /* selector != 1, general (i.e., non-special) case */
XX {
XX /* i1 := 1 or i1 := n */
XX (void) fprintf (outf, "%ssel = %d;\n", ind, (right) ? 1 : selector);
XX if (right)
XX {
XX (void) fprintf (outf, "%s%s = %s;\n", ind, outvar, invar); /* r := d; */
XX (void) fprintf (outf, /* while ((r = cdr (r)) != 0) i1++; */
XX "%swhile (%s = %s->fp_header.fp_next)\n%s sel++;\n",
XX ind, outvar, outvar, ind);
XX if (check)
XX (void) fprintf (outf,
XX "%sif (sel < %d)\n%s genbottom (\"%s%dr\", %s);\n",
XX ind, selector, ind, errmess, selector, invar);
XX /* i1 := i1 - (n - 1); */
XX (void) fprintf (outf, "%ssel -= %d;\n", ind, selector - 1);
XX }
XX (void) fprintf (outf, "%s%s = %s;\n", ind, outvar, invar); /* r := d; */
XX if (check && (! right))
XX (void) sprintf (checkstr,
XX"if (%s == 0)\n%s genbottom (\"%ssel %d\", %s);\n%s else\n%s ",
XX outvar, ind, errmess, selector, invar, ind, ind);
XX /* while (--i1 != 0) r := cdr (r); */
XX (void) fprintf (outf,
XX "%swhile (--sel)\n%s %s%s = %s->fp_header.fp_next;\n",
XX ind, ind, checkstr, outvar, outvar);
XX /* r := car (r); */
XX if (check && (! right))
XX (void) fprintf (outf,
XX "%sif (%s == 0)\n%s genbottom (\"%ssel %d\", %s);\n",
XX ind, outvar, ind, errmess, selector, invar);
XX (void) fprintf (outf, "%s%s = %s->fp_entry;\n", ind, outvar, outvar);
XX }
XX (void) fprintf (outf, "%sinc_ref (%s);\n%sdec_ref (%s);\n",
XX ind, outvar, ind, invar);
XX}
XX
XXstatic void codefncall (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX/* f: res := f (arg); */
XX{
XX if (strcmp (tree->fpexprv.funcall, "times") == 0)
XX (void) fprintf (outf, "%s%s = %s (%s);\n",
XX indentstr (), outvar, "fptimes", invar);
XX else
XX (void) fprintf (outf, "%s%s = %s (%s);\n",
XX indentstr (), outvar, tree->fpexprv.funcall, invar);
XX}
XX
XXstatic void codeconst (tree, invar, outvar)
XXfpexpr tree;
XXchar * invar, * outvar;
XX{
XX if (*invar != '\0')
XX (void) fprintf (outf, "%sdec_ref (%s);\n", indentstr (), invar);
XX (void) fprintf (outf, "%s%s = (fp_data) & (%s);\n%sinc_ref (%s);\n",
XX indentstr (), outvar, tree->constvar, indentstr (), outvar);
XX}
SHAR_EOF
if test 26310 -ne "`wc -c expr.c`"
then
echo shar: error transmitting expr.c '(should have been 26310 characters)'
fi
# End of shell archive
exit 0
--
Please send comp.sources.unix-related mail to rsalz@uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.