rsalz@uunet.uu.net (Rich Salz) (10/24/89)
Submitted-by: Edoardo Biagioni <biagioni@cs.unc.edu>
Posting-number: Volume 20, Issue 53
Archive-name: fpc/part04
# 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:
# fp.c.part2
# mkffp.c
echo shar: extracting fp.c.part2 '(34144 characters)'
sed 's/^XX//' << \SHAR_EOF > fp.c.part2
XX
XXfp_data apndr (data)
XXfp_data data;
XX{
XX register fp_data vector, el, res, prev, next;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering apndr, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (data->fp_type != VECTOR)
XX genbottom ("apndr: input is not a vector", data);
XX if ((data->fp_header.fp_next == 0) ||
XX (data->fp_header.fp_next->fp_header.fp_next != 0))
XX genbottom ("apndr: input is not a 2-element vector", data);
XX#endif
XX vector = data->fp_entry;
XX el = data->fp_header.fp_next->fp_entry;
XX#ifndef NOCHECK
XX if (nonvector (vector))
XX genbottom ("apndr: 1st element is not a vector or nil", data);
XX#endif
XX if (vector->fp_type != VECTOR) /* nil? */
XX vector = 0;
XX prev = 0; /* copy the first argument */
XX while (vector != 0)
XX {
XX next = newcell ();
XX if (vector != data->fp_entry)
XX prev->fp_header.fp_next = next;
XX else
XX res = next;
XX next->fp_entry = vector->fp_entry;
XX inc_ref (next->fp_entry);
XX prev = next;
XX vector = vector->fp_header.fp_next;
XX }
XX next = newcell (); /* cons the second argument to the right */
XX next->fp_entry = el;
XX inc_ref (el);
XX if (prev == 0)
XX res = next;
XX else
XX prev->fp_header.fp_next = next;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting apndr, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXvoid parmbot (fname, errdesc, data)
XXchar * fname;
XXchar * errdesc;
XXfp_data data;
XX{
XX char buffer [100];
XX
XX (void) strcpy (buffer, fname);
XX (void) strcat (buffer, ": ");
XX (void) strcat (buffer, errdesc);
XX genbottom (buffer, data);
XX}
XX
XXint compare ();
XX
XXint compvectors (v1, v2)
XXfp_data v1, v2;
XX/* like compare, but for v1, v2 assumed vectors or 0 (not checked) */
XX{
XX register int tempres;
XX
XX if (v1 == v2)
XX return (0);
XX if (v1 == 0)
XX return (- 1);
XX if (v2 == 0)
XX return (1);
XX/* compare the heads */
XX if ((tempres = compare (v1->fp_entry, v2->fp_entry)) != 0)
XX return (tempres);
XX/* heads are same, compare tails */
XX return (compvectors (v1->fp_header.fp_next, v2->fp_header.fp_next));
XX}
XX
XXint compare (op1, op2)
XXfp_data op1, op2;
XX/* compares the two objects (numbers, symbols, nil, true, false, vectors)
XX * in data and returns an int > 0, = 0 or < 0 depending on the first being
XX * greater, equal to or less than the second. Also takes care
XX * of error messages. Returns the input data.
XX * notice: F < T < num < atom < char < nil < vector
XX */
XX{
XX register int result = 0;
XX register int type1, type2;
XX register float num1, num2;
XX register float eps;
XX#define ONEPLUSEPSILON 1.0001
XX#define ONEMINUSEPSILON (2.0 - ONEPLUSEPSILON)
XX
XX type1 = op1->fp_type;
XX type2 = op2->fp_type;
XX if ((type1 == type2) && (type1 != FLOATCONST))
XX /* floats are handled in the else if */
XX switch (type1)
XX {
XX case INTCONST:
XX return (op1->fp_header.fp_int - op2->fp_header.fp_int);
XX case CHARCONST:
XX return (op1->fp_header.fp_char - op2->fp_header.fp_char);
XX case ATOMCONST:
XX result = strcmp (op1->fp_header.fp_atom, op2->fp_header.fp_atom);
XX break;
XX case VECTOR: /* use an arbitrary ordering! */
XX result = compvectors (op1, op2);
XX break;
XX default: /* nil, true, false */
XX /* do nothing, equality of types implies equality of data */
XX ;
XX }
XX else if (((type1 == INTCONST) || (type1 == FLOATCONST)) &&
XX ((type2 == INTCONST) || (type2 == FLOATCONST)))
XX {
XX num1 = ((type1 == INTCONST) ? op1->fp_header.fp_int :
XX op1->fp_header.fp_float);
XX num2 = ((type2 == INTCONST) ? op2->fp_header.fp_int :
XX op2->fp_header.fp_float);
XX eps = (num1 >= 0.0) ? ONEPLUSEPSILON : ONEMINUSEPSILON;
XX if ((num1 * eps) < num2)
XX result = -1;
XX else if ((num1 / eps) > num2)
XX result = 1;
XX else
XX result = 0;
XX }
XX else if (type1 < type2)
XX result = -1;
XX else if (type1 > type2)
XX result = 1;
XX else
XX result = 0;
XX return (result);
XX}
XX
XXfp_data eq (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering eq, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX checkpair (data, "eq");
XX if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) == 0)
XX res = fp_true;
XX else
XX res = fp_false;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting eq, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data notequal (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering notequal, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX checkpair (data, "eq");
XX if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) != 0)
XX res = fp_true;
XX else
XX res = fp_false;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting notequal, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data lequal (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering lequal, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX checkpair (data, "lequal");
XX if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) <= 0)
XX res = fp_true;
XX else
XX res = fp_false;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting lequal, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data less (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering less, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX checkpair (data, "less");
XX if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) < 0)
XX res = fp_true;
XX else
XX res = fp_false;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting less, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data gequal (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering gequal, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX checkpair (data, "gequal");
XX if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) >= 0)
XX res = fp_true;
XX else
XX res = fp_false;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting gequal, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data greater (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering greater, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX checkpair (data, "greater");
XX if (compare (data->fp_entry, data->fp_header.fp_next->fp_entry) > 0)
XX res = fp_true;
XX else
XX res = fp_false;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting greater, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XX#ifndef NOCHECK
XXvoid checkarith (data, fname)
XXfp_data data;
XXchar * fname;
XX{
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering %s, object is ", fname);
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX if (data->fp_type != VECTOR)
XX parmbot (fname, "input is not a vector", data);
XX if ((data->fp_header.fp_next == 0) ||
XX (data->fp_header.fp_next->fp_header.fp_next != 0))
XX parmbot (fname, "input is not a 2-element vector", data);
XX if ((data->fp_entry->fp_type != INTCONST) &&
XX (data->fp_entry->fp_type != FLOATCONST))
XX parmbot (fname, "1st argument is not a number", data);
XX if ((data->fp_header.fp_next->fp_entry->fp_type != INTCONST) &&
XX (data->fp_header.fp_next->fp_entry->fp_type != FLOATCONST))
XX parmbot (fname, "second argument is not a number", data);
XX}
XX
XX#endif
XX
XXfp_data plus (data)
XXfp_data data;
XX{
XX register fp_data res;
XX register float op1, op2;
XX register int isint = 1;
XX
XX#ifndef NOCHECK
XX checkarith (data, "plus");
XX#endif
XX if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
XX }
XX if (data->fp_entry->fp_type == INTCONST)
XX op1 = data->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op1 = data->fp_entry->fp_header.fp_float;
XX }
XX#ifndef NOCHECK
XX if (isint && ((op1 < 0) == (op2 < 0)) &&
XX ((MAXINT - abs (op1)) < abs (op2)))
XX genbottom ("plus: overflow or underflow", data);
XX#endif
XX if (isint)
XX {
XX res = newconst (INTCONST);
XX res->fp_header.fp_int = op1 + op2;
XX }
XX else
XX {
XX res = newconst (FLOATCONST);
XX res->fp_header.fp_float = op1 + op2;
XX }
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting plus, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data minus (data)
XXfp_data data;
XX{
XX register fp_data res;
XX register float op1, op2;
XX register int isint = 1;
XX
XX#ifndef NOCHECK
XX checkarith (data, "minus");
XX#endif
XX if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
XX }
XX if (data->fp_entry->fp_type == INTCONST)
XX op1 = data->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op1 = data->fp_entry->fp_header.fp_float;
XX }
XX#ifndef NOCHECK
XX if (isint && ((op1 < 0) != (op2 < 0)) &&
XX ((MAXINT - abs (op1)) < abs (op2)))
XX genbottom ("minus: overflow or underflow", data);
XX#endif
XX if (isint)
XX {
XX res = newconst (INTCONST);
XX res->fp_header.fp_int = op1 - op2;
XX }
XX else
XX {
XX res = newconst (FLOATCONST);
XX res->fp_header.fp_float = op1 - op2;
XX }
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting minus, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data fptimes (data)
XXfp_data data;
XX{
XX register fp_data res;
XX register float op1, op2;
XX register int isint = 1;
XX
XX#ifndef NOCHECK
XX checkarith (data, "times");
XX#endif
XX if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
XX }
XX if (data->fp_entry->fp_type == INTCONST)
XX op1 = data->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op1 = data->fp_entry->fp_header.fp_float;
XX }
XX#ifndef NOCHECK
XX if (isint && (op1 != 0) && ((MAXINT / abs (op1)) < abs (op2)))
XX/* the second condition is to insure that the test does not overflow */
XX genbottom ("times: arithmetic overflow", data);
XX#endif
XX if (isint)
XX {
XX res = newconst (INTCONST);
XX res->fp_header.fp_int = op1 * op2;
XX }
XX else
XX {
XX res = newconst (FLOATCONST);
XX res->fp_header.fp_float = op1 * op2;
XX }
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting times, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data div (data)
XXfp_data data;
XX{
XX register fp_data res;
XX register float op1, op2, intermediate;
XX register int isint = 1;
XX
XX#ifndef NOCHECK
XX checkarith (data, "div");
XX#endif
XX if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
XX }
XX if (data->fp_entry->fp_type == INTCONST)
XX op1 = data->fp_entry->fp_header.fp_int;
XX else
XX {
XX isint = 0;
XX op1 = data->fp_entry->fp_header.fp_float;
XX }
XX#ifndef NOCHECK
XX if (op2 == 0.0)
XX genbottom ("div: division by 0", data);
XX#endif
XX if (isint)
XX {
XX res = newconst (INTCONST);
XX intermediate = op1 / op2;
XX res->fp_header.fp_int = intermediate;
XX if ((res->fp_header.fp_int < 0) &&
XX (res->fp_header.fp_int != intermediate))
XX res->fp_header.fp_int--;
XX }
XX else
XX {
XX res = newconst (FLOATCONST);
XX res->fp_header.fp_float = op1 / op2;
XX }
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting div, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data mod (data)
XXfp_data data;
XX{
XX register fp_data res;
XX register long op1, op2;
XX
XX#ifndef NOCHECK
XX checkarith (data, "mod");
XX#endif
XX if (data->fp_header.fp_next->fp_entry->fp_type == INTCONST)
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_int;
XX else
XX op2 = data->fp_header.fp_next->fp_entry->fp_header.fp_float;
XX if (data->fp_entry->fp_type == INTCONST)
XX op1 = data->fp_entry->fp_header.fp_int;
XX else
XX op1 = data->fp_entry->fp_header.fp_float;
XX#ifndef NOCHECK
XX if (op2 == 0.0)
XX genbottom ("mod: division by 0", data);
XX#endif
XX res = newconst (INTCONST);
XX res->fp_header.fp_int = op1 % op2;
XX if (res->fp_header.fp_int < 0)
XX res->fp_header.fp_int += abs (op2);
XX if ((op2 < 0) && (res->fp_header.fp_int != 0))
XX res->fp_header.fp_int = (- op2) - res->fp_header.fp_int;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting mod, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data neg (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering neg, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if ((data->fp_type != INTCONST) && (data->fp_type != FLOATCONST))
XX genbottom ("neg: input is not a number", data);
XX#endif
XX res = newconst (data->fp_type);
XX if (data->fp_type == INTCONST)
XX res->fp_header.fp_int = - data->fp_header.fp_int;
XX else
XX res->fp_header.fp_float = - data->fp_header.fp_float;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting neg, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data null (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering null, argument is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX if (data->fp_type == NILOBJ)
XX res = (fp_true);
XX else
XX res = (fp_false);
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting null, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data length (data)
XXfp_data data;
XX{
XX register fp_data res, vector;
XX register long size;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering length, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (nonvector (data))
XX genbottom ("length: input is not a vector or nil", data);
XX#endif
XX size = 0;
XX if (data->fp_type == NILOBJ)
XX vector = 0;
XX else
XX vector = data;
XX while (vector != 0)
XX {
XX size++;
XX vector = vector->fp_header.fp_next;
XX }
XX res = newconst (INTCONST);
XX res->fp_header.fp_int = size;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting length, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data trans (data)
XXfp_data data;
XX{
XX/* implementation: a matrix backbone is the set of storage cells that
XX point to rows of the matrix. What we do is we copy the argument's
XX backbone, then use it to step through all elements of the first
XX column while updating the backbone to point to the second column
XX and building a result row, and repeat. */
XX register fp_data fromptr, /* holds the "from" part when pointer chasing */
XX toptr, /* holds the "to" part when pointer chasing */
XX resptr, /* holds a copy of the result backbone */
XX bbcopy, /* holds a copy of the matrix backbone */
XX res; /* holds the final result */
XX register long rows = 1, cols = 1;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering trans, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (data->fp_type != VECTOR)
XX genbottom ("trans: input is not a vector", data);
XX#endif
XX if (data->fp_entry->fp_type != VECTOR)
XX { /* The loop is for legality check only. */
XX /* it is legal to tranpose a vector of nils into nil. */
XX /* the converse (nil to a vector of nils) is not legal. */
XX /* that is the only case in which trans o trans != id. */
XX#ifndef NOCHECK
XX for (fromptr = data; fromptr != 0; fromptr = fromptr->fp_header.fp_next)
XX if (fromptr->fp_entry->fp_type != NILOBJ)
XX genbottom ("trans: input is not a matrix", data);
XX#endif
XX res = fp_nil;
XX }
XX else
XX { /* find out number of source cols = dest rows */
XX fromptr = data->fp_entry;
XX while ((fromptr = fromptr->fp_header.fp_next) != 0)
XX cols++;
XX /* now find out number of source rows = dest cols */
XX fromptr = data;
XX while ((fromptr = fromptr->fp_header.fp_next) != 0)
XX rows++;
XX bbcopy = newvect (rows); /* copy the old backbone to bbcopy */
XX fromptr = data;
XX toptr = bbcopy;
XX while (fromptr != 0)
XX {
XX toptr->fp_entry = fromptr->fp_entry;
XX/* no need to inc_ref since we will reset the backbone to be
XX all NILs before returning it. */
XX toptr = toptr->fp_header.fp_next;
XX fromptr = fromptr->fp_header.fp_next;
XX } /* backbone copied, now start building output rows */
XX res = newvect (cols); /* the result has "cols" rows */
XX resptr = res;
XX while (resptr != 0) /* build one row at a time, and assign it to */
XX { /* resptr->fp_entry, so we are done when resptr is 0 */
XX/* loop invariant: every time we enter the loop, we are (inductively)
XX building the transpose of bbcopy into resptr. When we finish
XX each loop, we will have removed the first column of bbcopy and built
XX the top row of resptr, and changed bbcopy to remove its first column. */
XX resptr->fp_entry = toptr = newvect (rows);
XX fromptr = bbcopy;
XX/* resptr is the backbone of res. fromptr runs along bbcopy
XX and updates it to point to the next element of each row. toptr
XX runs along the current result row to initialize it. */
XX while (toptr != 0) /* here we build one row of res */
XX {
XX#ifndef NOCHECK
XX if (fromptr->fp_entry == 0)
XX genbottom ("trans: rows are not all equally long", data);
XX#endif
XX toptr->fp_entry = fromptr->fp_entry->fp_entry;
XX inc_ref (toptr->fp_entry);
XX fromptr->fp_entry = fromptr->fp_entry->fp_header.fp_next;
XX/* make the backbone so it points to the next element of the row,
XX in effect deleting this element of the first column from bbcopy. */
XX fromptr = fromptr->fp_header.fp_next;
XX toptr = toptr->fp_header.fp_next;
XX } /* the row of result is built, go on to the next. */
XX resptr = resptr->fp_header.fp_next;
XX }
XX for (fromptr = bbcopy; fromptr != 0; fromptr = fromptr->fp_header.fp_next)
XX#ifndef NOCHECK
XX if (fromptr->fp_entry != 0)
XX genbottom ("trans: rows are not all equally long", data);
XX else
XX#endif
XX fromptr->fp_entry = fp_nil;
XX dec_ref (bbcopy);
XX }
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting trans, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XX#ifndef NOCHECK
XXvoid checklog (data, fname)
XXfp_data data;
XXchar * fname;
XX{
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering %s, object is ", fname);
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX if (data->fp_type != VECTOR)
XX parmbot (fname, "input is not a vector", data);
XX if ((data->fp_header.fp_next == 0) ||
XX (data->fp_header.fp_next->fp_header.fp_next != 0))
XX parmbot (fname, "input is not a 2-element vector", data);
XX if (nonboolean (data->fp_entry))
XX parmbot (fname, "1st argument is not a boolean", data);
XX if (nonboolean (data->fp_header.fp_next->fp_entry))
XX parmbot (fname, "second argument is not a boolean", data);
XX}
XX#endif
XX
XXfp_data and (data)
XXfp_data data;
XX{
XX register fp_data res;
XX register fp_data op1, op2;
XX
XX#ifndef NOCHECK
XX checklog (data, "and");
XX#endif
XX op1 = data->fp_entry;
XX op2 = data->fp_header.fp_next->fp_entry;
XX if ((op1->fp_type == TRUEOBJ) &&
XX (op2->fp_type == TRUEOBJ))
XX res = (fp_true);
XX else
XX res = (fp_false);
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting and, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data or (data)
XXfp_data data;
XX{
XX register fp_data res, op1, op2;
XX
XX#ifndef NOCHECK
XX checklog (data, "or");
XX#endif
XX op1 = data->fp_entry;
XX op2 = data->fp_header.fp_next->fp_entry;
XX if ((op1->fp_type == TRUEOBJ) ||
XX (op2->fp_type == TRUEOBJ))
XX res = (fp_true);
XX else
XX res = (fp_false);
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting or, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data not (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering not, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (nonboolean (data))
XX genbottom ("not: argument is not a boolean", data);
XX#endif
XX if (data->fp_type == TRUEOBJ)
XX res = (fp_false);
XX else
XX res = (fp_true);
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting not, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data iota (data)
XXfp_data data;
XX{
XX register fp_data res, num, vect;
XX register long pos, size;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering iota, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if ((data->fp_type != INTCONST) && (data->fp_type != FLOATCONST))
XX genbottom ("iota: input is not a number", data);
XX#endif
XX if (data->fp_type == INTCONST)
XX size = data->fp_header.fp_int;
XX else
XX size = data->fp_header.fp_float;
XX#ifndef NOCHECK
XX if (size < 0)
XX genbottom ("iota: input is negative", data);
XX#endif
XX if (size == 0)
XX return (fp_nil);
XX res = newvect (size);
XX vect = res;
XX pos = 0;
XX while (size > pos++)
XX {
XX num = newconst (INTCONST);
XX num->fp_header.fp_int = pos;
XX vect->fp_entry = num;
XX vect = vect->fp_header.fp_next;
XX }
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting iota, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XX/* the following function is used very often, so it is included
XX * here for speed, though it could be defined as \/(/apndl o apndr).
XX * It is not mentioned in the Backus Turing award lecture. */
XXfp_data append (data)
XXfp_data data;
XX{
XX register fp_data entry; /* holds the vector being copied */
XX register fp_data new; /* holds the next cell filled in for new */
XX register fp_data res; /* holds final result, but tested often */
XX register fp_data old; /* chases 'data' */
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering append, argument is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK /* arg must be a vector of vectors or nils */
XX if (data->fp_type != VECTOR)
XX genbottom ("append: input is not a vector", data);
XX#endif
XX res = 0;
XX for (entry = data->fp_entry, old = data->fp_header.fp_next;
XX old != 0;
XX entry = old->fp_entry, old = old->fp_header.fp_next)
XX {
XX if (entry->fp_type == VECTOR)
XX { /* partial loop unrolling to avoid testing for res == 0 in the
XX inner (for) loop: */
XX if (res == 0)
XX new = res = newcell ();
XX else
XX new = new->fp_header.fp_next = newcell ();
XX new->fp_entry = entry->fp_entry;
XX inc_ref (new->fp_entry);
XX for (entry = entry->fp_header.fp_next;
XX entry != 0; /* this condition tested at start! */
XX entry = entry->fp_header.fp_next)
XX {
XX new = new->fp_header.fp_next = newcell ();
XX new->fp_entry = entry->fp_entry;
XX inc_ref (new->fp_entry);
XX }
XX }
XX#ifndef NOCHECK
XX else if (entry->fp_type != NILOBJ)
XX genbottom ("append: input is not a vector of nils or vectors", data);
XX#endif
XX }
XX if (res == 0)
XX#ifndef NOCHECK
XX if ((entry->fp_type != NILOBJ) && (entry->fp_type != VECTOR))
XX genbottom ("append: input is not a vector of nils or vectors", data);
XX else
XX#endif
XX res = entry;
XX else
XX if (entry->fp_type == VECTOR)
XX new->fp_header.fp_next = entry;
XX#ifndef NOCHECK
XX else if (entry->fp_type != NILOBJ)
XX genbottom ("append: input is not a vector of nils or vectors", data);
XX#endif
XX inc_ref (entry); /* doesn't hurt, even if entry is nil */
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting append, result is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XX/* following are the character functions which I have come up with,
XX * namely newline, implode, explode */
XX
XX/* constant function returning the new-line character */
XXfp_data newline (data)
XXfp_data data;
XX{
XX static struct fp_charc nlc =
XX {(short) CHARCONST, (short) 1, '\n'};
XX static struct fp_constant nl =
XX {(short) VECTOR, (short) 1, (long) 0, (fp_data) &nlc};
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering newline, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX dec_ref (data);
XX res = (fp_data) & (nl);
XX inc_ref (res);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting newline\n");
XX#endif
XX return (res);
XX}
XX
XXstatic fp_data toFPstring (str)
XXregister char * str;
XX{
XX register fp_data chase, ch;
XX register fp_data res;
XX
XX if (*str == '\0')
XX res = fp_nil;
XX else
XX {
XX res = chase = newcell ();
XX while (1)
XX {
XX ch = newconst (CHARCONST);
XX ch->fp_header.fp_char = *(str++);
XX chase->fp_entry = ch;
XX if (*str == '\0')
XX break;
XX chase = chase->fp_header.fp_next = newcell ();
XX }
XX }
XX return (res);
XX}
XX
XXstatic void toCstring (fp, c)
XXfp_data fp;
XXchar * c;
XX{
XX for ( ; fp != 0; fp = fp->fp_header.fp_next)
XX *(c++) = fp->fp_entry->fp_header.fp_char;
XX *c = '\0';
XX}
XX
XXfp_data explode (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering explode, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (data->fp_type != ATOMCONST)
XX genbottom ("explode: argument is not an atom", data);
XX#endif
XX res = toFPstring (data->fp_header.fp_atom);
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting explode, object is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XXfp_data implode (data)
XXfp_data data;
XX{
XX register unsigned len = 1;
XX register fp_data res, chase;
XX register char * str;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering implode, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (! isstring (data))
XX genbottom ("implode: argument is not a string", data);
XX#endif
XX for (chase = data; chase != 0; chase = chase->fp_header.fp_next)
XX len++;
XX res = newconst (ATOMCONST);
XX res->fp_header.fp_atom = str = malloc (len);
XX toCstring (data, str);
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting implode, object is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XX/* following is the real to integer conversion function. Note: to
XX * convert from integer to real, use (bu * 1.0) */
XX
XX/* function returning the floor of the value of any numeric parameter */
XXfp_data trunc (data)
XXfp_data data;
XX{
XX register fp_data res;
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering trunc, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX if (data->fp_type == INTCONST) /* no-op */
XX return (data);
XX#ifndef NOCHECK
XX if (data->fp_type != FLOATCONST)
XX genbottom ("trunc: argument is not a number", data);
XX#endif
XX res = newconst (INTCONST);
XX res->fp_header.fp_int = data->fp_header.fp_float;
XX if (res->fp_header.fp_int > data->fp_header.fp_float) /* adjust */
XX res->fp_header.fp_int--;
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting trunc, object is ");
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (res);
XX}
XX
XX/* following are the I/O functions not described or hinted at in the
XX * Backus paper. They are documented one by one. */
XX
XX/* trace outputs its data, which must be a string, in raw output mode,
XX * and returns it */
XXfp_data trace (data)
XXfp_data data;
XX{
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering trace, object is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if ((data->fp_type != NILOBJ) && ! isstring (data))
XX genbottom ("trace: input is not a string", data);
XX#endif
XX putfpstring (data, stderr);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting trace, result is ");
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX return (data);
XX}
XX
XX/* takes as argument a string and the name of a function, and
XX * returns the file with the given name (opened for reading),
XX * which may be 0. It does not dec_ref data.
XX */
XXstatic FILE * openfile (data, funname)
XXfp_data data;
XXchar * funname;
XX{
XX char name [FNAMELEN];
XX
XX#ifdef DEBUG
XX (void) fprintf (stderr, "entering %s, object is ", funname);
XX printfpdata (stderr, data, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX#ifndef NOCHECK
XX if (! isstring (data))
XX {
XX sprintf (name, "%s: input is not a string", funname);
XX genbottom (name, data);
XX }
XX#endif
XX toCstring (data, name);
XX return (fopen (name, "r"));
XX}
XX
XXstatic void closefile (f, funname, data, res)
XXFILE * f;
XXchar * funname;
XXfp_data data, res;
XX{
XX char errstr [100];
XX
XX if (f != 0)
XX if (fclose (f) == EOF)
XX#ifndef NOCHECK
XX {
XX sprintf (errstr, "%s: unable to close the file", funname);
XX genbottom (errstr, data);
XX }
XX#else
XX ;
XX#endif
XX dec_ref (data);
XX#ifdef DEBUG
XX (void) fprintf (stderr, "exiting %s, result is ", res);
XX printfpdata (stderr, res, 0);
XX (void) putc ('\n', stderr);
XX#endif
XX}
XX
XX/* filetype takes as input a string and returns:
XX * none if the file does not exist
XX * empty if the file exists but has no data
XX * binary if the file contains non-textual characters
XX * data if the file can be read by the parser
XX * text otherwise.
XX * A text file can usually be read as data (just returns
XX * the first word as an atom; that is however still
XX * marked as text. It is data if it has a single symbol
XX * alone on the first nonblank line. A data file may
XX * usually be read as text.
XX */
XXfp_data filetype (data)
XXfp_data data;
XX{
XX static struct fp_atom none =
XX {(short) ATOMCONST, (short) 1, (char *) "none"};
XX static struct fp_atom empty =
XX {(short) ATOMCONST, (short) 1, (char *) "empty"};
XX static struct fp_atom datafile =
XX {(short) ATOMCONST, (short) 1, (char *) "data"};
XX static struct fp_atom text =
XX {(short) ATOMCONST, (short) 1, (char *) "text"};
XX static struct fp_atom binary =
XX {(short) ATOMCONST, (short) 1, (char *) "binary"};
XX fp_data res;
XX FILE * f;
XX int intch;
XX char c;
XX int isbinfile ();
XX
XX f = openfile (data, "filetype");
XX if (f == 0)
XX res = (fp_data) & none;
XX else if ((intch = getc (f)) == EOF)
XX res = (fp_data) & empty;
XX else
XX {
XX/* criteria for datafile:
XX * the first nonempty line contains a symbol by itsef --> datafile
XX * the datafile begins with a parseable vector or string --> datafile
XX * else --> text file or binary file
XX */
XX while (isspace (intch)) /* find the first nonempty line */
XX intch = getc (f);
XX if (isalpha (intch)) /* is it a symbol on an empty line? */
XX {
XX while (isalnum (intch))
XX intch = getc (f);
XX while ((intch == ' ') || (intch == '\t'))
XX intch = getc (f);
XX if ((intch == '\n') || (intch == EOF))
XX res = (fp_data) & datafile;
XX else if (isbinfile (f, intch))
XX res = (fp_data) & binary;
XX else
XX res = (fp_data) & text;
XX }
XX else
XX {
XX c = intch;
XX if (readfpdata (f, &c, 1) ->fp_type == TRUEOBJ)
XX res = (fp_data) & datafile;
XX/* notice readfpdata returned the last character it read */
XX else if (isbinfile (f, c))
XX res = (fp_data) & binary;
XX else
XX res = (fp_data) & text;
XX }
XX }
XX inc_ref (res);
XX closefile (f, "filetype", data, res);
XX return (res);
XX}
XX
XXstatic int isbinfile (f, ch)
XXFILE * f;
XXint ch;
XX{
XX for (; ch != EOF; ch = getc (f))
XX if (! (isprint (ch) || isspace (ch)))
XX return (1);
XX return (0);
XX}
XX
XXfp_data readfile (data)
XXfp_data data;
XX{
XX FILE * f;
XX int c;
XX char input;
XX fp_data res;
XX
XX f = openfile (data, "readfile");
XX if ((f == 0) || ((c = getc (f)) == EOF))
XX res = fp_nil;
XX else
XX {
XX input = c;
XX res = readfpdata (f, &input, 0);
XX }
XX closefile (f, "readfile", data, res);
XX return (res);
XX}
XX
XXfp_data inputfile (data)
XXfp_data data;
XX{
XX fp_data res;
XX FILE * f;
XX
XX f = openfile (data, "inputfile");
XX res = readfpstring (f);
XX closefile (f, "inputfile", data, res);
XX return (res);
XX}
XX
XX/* the next function ignores its input and returns the arguments
XX * given in the call to the program. The arguments are returned
XX * in the following form:
XX * <argopt*>, where
XX * argopt ::= "argument" | option
XX * option ::= <'option, "value"> | <'option, <>>
XX */
XXfp_data arguments (data)
XXfp_data data;
XX{
XX static fp_data res = 0; /* re-use it after it has been initialized */
XX fp_data old, option;
XX
XX dec_ref (data);
XX if (res == 0) /* do the work, once and for all */
XX {
XX if (fpargc == 1) /* no arguments, options */
XX res = fp_nil;
XX while ((fpargc--) > 1) /* else: read arguments in reverse order */
XX {
XX old = res;
XX res = newcell ();
XX res->fp_header.fp_next = old;
XX if (fpargv [fpargc] [0] == '-') /* it's an option */
XX {
XX option = newpair ();
XX option->fp_entry = newconst (CHARCONST);
XX option->fp_entry->fp_header.fp_char = fpargv [fpargc] [1];
XX option->fp_header.fp_next->fp_entry =
XX toFPstring (& (fpargv [fpargc] [2]));
XX }
XX else /* it's an argument */
XX res->fp_entry = toFPstring (fpargv [fpargc]);
XX }
XX#ifndef NOCHECK
XX old = staticstore;
XX staticstore = newcell ();
XX staticstore->fp_header.fp_next = old;
XX staticstore->fp_entry = res;
XX#endif
XX }
XX inc_ref (res);
XX return (res);
XX}
SHAR_EOF
if test 34144 -ne "`wc -c fp.c.part2`"
then
echo shar: error transmitting fp.c.part2 '(should have been 34144 characters)'
fi
echo shar: extracting mkffp.c '(5533 characters)'
sed 's/^XX//' << \SHAR_EOF > mkffp.c
XX/* mkffp.c: this file, when linked with the FP preprocessor, will
XX * produce an FP to FFP compiler. The compiler will read in
XX * one or more FP files and for each FP function defined
XX * will produce a corresponding FFP file function.ffp.
XX */
XX
XX#include <stdio.h>
XX#include <strings.h>
XX#include "fpc.h"
XX#include "parse.h"
XX#include "code.h"
XX
XXFILE * outfile;
XX
XX/* set newname to "" to indicate that no file should be opened */
XXvoid newfname (oldname, newname)
XXchar * oldname, * newname;
XX{
XX *newname = '\0';
XX}
XX
XXstatic void codeobj (tree)
XXfpexpr tree;
XX{
XX switch (tree->exprtype)
XX {
XX case NIL:
XX (void) fprintf (outfile, "<>");
XX break;
XX case TRUE:
XX (void) fprintf (outfile, "T");
XX break;
XX case FALSE:
XX (void) fprintf (outfile, "F");
XX break;
XX case INT:
XX (void) fprintf (outfile, "%d", tree->fpexprv.intobj);
XX break;
XX case FLOAT:
XX (void) fprintf (outfile, "%f", tree->fpexprv.floatobj);
XX break;
XX case SYM:
XX (void) fprintf (outfile, "%s", tree->fpexprv.symbol);
XX break;
XX case CHAR:
XX (void) fprintf (outfile, "'%c", tree->fpexprv.character);
XX break;
XX case LIST:
XX (void) putc ('<', outfile);
XX while (tree != 0)
XX {
XX codeobj (tree->fpexprv.listobj.listel);
XX (void) putc (' ', outfile);
XX tree = tree->fpexprv.listobj.listnext;
XX }
XX (void) fprintf (outfile, ">\n");
XX break;
XX default:
XX yyerror ("compiler error 11");
XX }
XX}
XX
XXstatic void codeexpr (tree)
XXfpexpr tree;
XX{
XX#define STKSIZE 128
XX fpexpr stack [STKSIZE];
XX int stkptr;
XX
XX switch (tree->exprtype)
XX {
XX case COND:
XX (void) fprintf (outfile, "<cond ");
XX codeexpr (tree->fpexprv.conditional [0]);
XX (void) putc (' ', outfile);
XX codeexpr (tree->fpexprv.conditional [1]);
XX (void) putc (' ', outfile);
XX codeexpr (tree->fpexprv.conditional [2]);
XX (void) fprintf (outfile, ">\n");
XX break;
XX case BUR:
XX case BU:
XX if (tree->exprtype != BU)
XX (void) fprintf (outfile, "<bur ");
XX else
XX (void) fprintf (outfile, "<bu ");
XX codeexpr (tree->fpexprv.bulr.bufun);
XX (void) putc (' ', outfile);
XX codeobj (tree->fpexprv.bulr.buobj);
XX (void) fprintf (outfile, ">\n");
XX break;
XX case WHILE:
XX (void) fprintf (outfile, "<while ");
XX codeexpr (tree->fpexprv.whilestat [0]);
XX (void) putc (' ', outfile);
XX codeexpr (tree->fpexprv.whilestat [1]);
XX (void) fprintf (outfile, ">\n");
XX break;
XX case COMP:
XX (void) fprintf (outfile, "<compose ");
XX stkptr = 0;
XX while (tree != 0)
XX {
XX if (stkptr >= STKSIZE)
XX yyerror ("compiler stack overflow, compose too long");
XX stack [stkptr++] = tree->fpexprv.compconstr.compexpr;
XX tree = tree->fpexprv.compconstr.compnext;
XX }
XX while (stkptr != 0)
XX {
XX codeexpr (stack [--stkptr]);
XX (void) putc (' ', outfile);
XX }
XX (void) fprintf (outfile, ">\n");
XX break;
XX case AA:
XX (void) fprintf (outfile, "<aa ");
XX codeexpr (tree->fpexprv.aains);
XX (void) fprintf (outfile, ">\n");
XX break;
XX case CONSTR:
XX (void) fprintf (outfile, "<constr ");
XX while (tree != 0)
XX {
XX codeexpr (tree->fpexprv.compconstr.compexpr);
XX (void) putc (' ', outfile);
XX tree = tree->fpexprv.compconstr.compnext;
XX }
XX (void) fprintf (outfile, ">\n");
XX break;
XX case TREE:
XX case RINSERT:
XX case INSERT:
XX if ((tree->fpexprv.aains->exprtype == FNCALL) &&
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "plus") == 0))
XX (void) fprintf (outfile, "plus");
XX else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "times") == 0))
XX (void) fprintf (outfile, "times");
XX else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "and") == 0))
XX (void) fprintf (outfile, "and");
XX else if ((tree->fpexprv.aains->exprtype == FNCALL) &&
XX (strcmp (tree->fpexprv.aains->fpexprv.funcall, "or") == 0))
XX (void) fprintf (outfile, "or");
XX else
XX {
XX if (tree->exprtype == TREE)
XX (void) fprintf (outfile, "<tree ");
XX else if (tree->exprtype == RINSERT)
XX (void) fprintf (outfile, "<rinsert ");
XX else /* (tree->exprtype == INSERT) */
XX (void) fprintf (outfile, "<insert ");
XX codeexpr (tree->fpexprv.aains);
XX (void) fprintf (outfile, ">\n");
XX }
XX break;
XX case RSEL:
XX (void) fprintf (outfile, "<rselect %d>\n", tree->fpexprv.lrsel);
XX break;
XX case SEL:
XX (void) fprintf (outfile, "<select %d>\n", tree->fpexprv.lrsel);
XX break;
XX case FNCALL:
XX (void) fprintf (outfile, "%s", tree->fpexprv.funcall);
XX break;
XX default:
XX if ((tree->exprtype >= NIL) && (tree->exprtype <= CHAR))
XX {
XX (void) fprintf (outfile, "<const ");
XX codeobj (tree);
XX (void) fprintf (outfile, ">\n");
XX }
XX else
XX yyerror ("compiler error 10");
XX }
XX}
XX
XX/* called for each source FP function */
XXvoid code (fun, tree)
XXchar * fun;
XXfpexpr tree;
XX{
XX char name [256];
XX
XX (void) strcpy (name, fun);
XX (void) strcpy (name + strlen (fun), ".ffp");
XX outfile = fopen (name, "w");
XX if (outfile == 0)
XX {
XX (void) sprintf (name, "unable to open file %s, aborting\n", name);
XX yyerror (name);
XX }
XX codeexpr (tree);
XX (void) fclose (outfile);
XX}
XX
XX/* the following two functions are provided for compatibility */
XXvoid putfileheader (inname, outname)
XXchar * inname;
XXchar * outname;
XX{
XX}
XX
XXvoid putfiletail ()
XX{
XX}
SHAR_EOF
if test 5533 -ne "`wc -c mkffp.c`"
then
echo shar: error transmitting mkffp.c '(should have been 5533 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.