Subject: v20i053: Portable compiler of the FP language, Part04/06 Newsgroups: comp.sources.unix Sender: sources Approved: rsalz@uunet.UU.NET Submitted-by: Edoardo Biagioni 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 * , 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 XX#include 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, "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, "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, "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, "= 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, "fpexprv.aains); XX (void) fprintf (outfile, ">\n"); XX break; XX case CONSTR: XX (void) fprintf (outfile, "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, "exprtype == RINSERT) XX (void) fprintf (outfile, "exprtype == INSERT) */ XX (void) fprintf (outfile, "fpexprv.aains); XX (void) fprintf (outfile, ">\n"); XX } XX break; XX case RSEL: XX (void) fprintf (outfile, "\n", tree->fpexprv.lrsel); XX break; XX case SEL: XX (void) fprintf (outfile, "