rsalz@bbn.com (Rich Salz) (02/05/88)
Submitted-by: Andy Valencia <vandys@lindy.stanford.edu>
Posting-number: Volume 13, Issue 15
Archive-name: funcproglang/part02
[ This doesn't have a manual page; for details see Backus's writing
on FP, and the FP paper in the UCB manuals. --r$ ]
#!/bin/sh
# This is a shell archive.
# It contains fp.shar, 2/2
# Run the following text with /bin/sh to extract.
cat - << \Funky!Stuff! > exec.c
/*
* Execution module for FP. Runs along the AST and executes actions.
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
#include "y.tab.h"
/*
* This ugly set of macros makes access to objects easier.
*
* UNDEFINED generates the undefined object & returns it
* NUMVAL generates a value for C of the correct type
* CAR manipulates the object as a list & gives its first part
* CDR is like CAR but gives all but the first
* ISNUM provides a boolean saying if the named object is a number
*/
#define UNDEFINED return(obj_alloc(T_UNDEF));
#define NUMVAL(x) ( ((x)->o_type == T_INT) ? \
(((x)->o_val).o_int) : (((x)->o_val).o_double) )
#define CAR(x) ( ((x)->o_val).o_list.car )
#define CDR(x) ( ((x)->o_val).o_list.cdr )
#define ISNUM(x) ( ((x)->o_type == T_INT) || (x->o_type == T_FLOAT) )
extern struct object *do_charfun(), *do_intrinsics();
static struct object *do_rinsert(), *do_binsert();
/*
* Given an AST for an action, and an object to do the action upon,
* execute the action and return the result.
*/
struct object *
execute( act, obj )
register struct ast *act;
register struct object *obj;
{
register struct object *p, *q;
int x;
/*
* Broad categories of executable entities
*/
switch( act->tag ){
/*
* Invoke a user-defined function
*/
case 'U':
return( invoke( act->val.YYsym, obj) );
/*
* Right-insert operator
*/
case '!':
return( do_rinsert(act->left,obj) );
/*
* Binary-insert operator
*/
case '|':
return( do_binsert(act->left,obj) );
/*
* Intrinsics
*/
case 'i':
return( do_intrinsics(act->val.YYsym, obj) );
/*
* Select one element from a list
*/
case 'S':
if(
(obj->o_type != T_LIST) ||
!CAR(obj)
){
obj_unref(obj);
UNDEFINED;
}
p = obj;
if( (x = act->val.YYint) == 0 ){
obj_unref(obj);
UNDEFINED;
}
/*
* Negative selectors count from end of list
*/
if( x < 0 ){
int tmp = listlen(p);
x += (tmp+1);
if( x < 0 ){
obj_unref(obj);
UNDEFINED;
}
}
while( --x ){ /* Scan down list X times */
if( !p ) break;
p = CDR(p);
}
if( !p ){ /* Fell off bottom of list */
obj_unref(obj);
UNDEFINED;
}
p = CAR(p);
p->o_refs += 1; /* Add reference to this elem */
obj_unref(obj); /* Unreference list as a whole */
return(p);
/*
* Apply the action on the left to the result of executing
* the action on the right against the object.
*/
case '@':
p = execute( act->right, obj );
return( execute( act->left, p ) );
/*
* Build a new list by applying the listed actions to the object
* All is complicated by the fact that we must be clean in
* the presence of T_UNDEF popping up along the way.
*/
case '[':{
struct object *hd, **hdp = &hd;
act = act->left;
hd = (struct object *)0;
while( act ){
obj->o_refs += 1;
if( (p = execute(act->left,obj))->o_type == T_UNDEF ){
obj_unref(hd);
obj_unref(obj);
return(p);
}
*hdp = q = obj_alloc(T_LIST);
hdp = &(CDR(q));
CAR(q) = p;
act = act->right;
}
obj_unref(obj);
return(hd);
}
/*
* These are the single-character operations (+, -, etc.)
*/
case 'c':
return(do_charfun(act,obj));
/*
* Conditional. Evaluate & return one of the two paths
*/
case '>':
obj->o_refs += 1;
p = execute(act->left,obj);
if( p->o_type == T_UNDEF ){
obj_unref(obj);
return(p);
}
if( p->o_type != T_BOOL ){
obj_unref(obj);
obj_unref(p);
UNDEFINED;
}
if( p->o_val.o_int ) q = execute(act->middle,obj);
else q = execute(act->right,obj);
obj_unref(p);
return(q);
/*
* Apply the action to each member of a list
*/
case '&': {
struct object *hd, **hdp = &hd, *r;
hd = 0;
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
if( !CAR(obj) ) return(obj);
for( p = obj; p; p = CDR(p) ){
(p->o_val.o_list.car)->o_refs += 1;
if( (q = execute(act->left,CAR(p)))->o_type == T_UNDEF ){
obj_unref(hd); obj_unref(obj);
return(q);
}
*hdp = r = obj_alloc(T_LIST);
CAR(r) = q;
hdp = &CDR(r);
}
obj_unref(obj);
return(hd);
}
/*
* Introduce an object
*/
case '%':
if( obj->o_type == T_UNDEF ) return(obj);
obj_unref(obj);
p = act->val.YYobj;
p->o_refs += 1;
return(p);
/*
* Do a while loop
*/
case 'W':
while( 1 ){
if( obj->o_type == T_UNDEF ){
obj_unref(obj);
UNDEFINED;
}
obj->o_refs += 1;
p = execute(act->left,obj);
if( p->o_type != T_BOOL ){
obj_unref(obj);
obj_unref(p);
UNDEFINED;
}
if( p->o_val.o_int ){
obj_unref(p);
obj = execute(act->right,obj);
} else {
obj_unref(p);
return(obj);
}
}
default:
fatal_err("Undefined AST tag in execute()");
}
/*NOTREACHED*/
}
/*
* Local function to handle the tedious right-inserting
*/
static struct object *
do_rinsert(act,obj)
struct ast *act;
struct object *obj;
{
register struct object *p, *q;
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
/*
* If the list is empty, then we need to look at the applied
* operator. If it's one for which we have an identity,
* return the identity. Otherwise, undefined. Bletch.
*/
if( !CAR(obj) ){
obj_unref(obj);
if( act->tag == 'c' ){
switch( act->val.YYint ){
case '+':
case '-':
p = obj_alloc(T_INT);
p->o_val.o_int = 0;
break;
case '/':
case '*':
p = obj_alloc(T_INT);
p->o_val.o_int = 1;
break;
default:
UNDEFINED;
}
} else if ( act->tag == 'i' ){
switch( (act->val.YYsym)->sym_val.YYint ){
case AND:
p = obj_alloc(T_BOOL);
p->o_val.o_int = 1;
break;
case OR:
case XOR:
p = obj_alloc(T_BOOL);
p->o_val.o_int = 0;
break;
default:
UNDEFINED;
}
} else UNDEFINED;
return(p);
}
/*
* If the list has only one element, we return that element.
*/
if( !(p = CDR(obj)) ){
p = CAR(obj);
p->o_refs += 1;
obj_unref(obj);
return(p);
}
/*
* If the list has two elements, we apply our operator and reduce
*/
if( !CDR(p) ){
return( execute(act,obj) );
}
/*
* Here's the nasty one. We have three or more, so recurse on our-
* selves to handle all but the first, then apply operation to
* first linked onto the result. Normal business over undefined
* objects popping up.
*/
CDR(obj)->o_refs += 1;
p = do_rinsert(act,CDR(obj));
if( p->o_type == T_UNDEF ){
obj_unref(obj);
return(p);
}
q = obj_alloc(T_LIST);
CAR(q) = CAR(obj);
CAR(obj)->o_refs += 1;
CAR(CDR(q) = obj_alloc(T_LIST)) = p;
obj_unref(obj);
return( execute(act,q) );
}
/*
* Local function to handle the tedious binary inserting
*/
static struct object *
do_binsert(act,obj)
struct ast *act;
struct object *obj;
{
register struct object *p, *q;
struct object *hd, **hdp, *r;
int x;
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
/*
* If the list is empty, then we need to look at the applied
* operator. If it's one for which we have an identity,
* return the identity. Otherwise, undefined. Bletch.
*/
if( !CAR(obj) ){
obj_unref(obj);
if( act->tag == 'c' ){
switch( act->val.YYint ){
case '+':
case '-':
p = obj_alloc(T_INT);
p->o_val.o_int = 0;
break;
case '/':
case '*':
p = obj_alloc(T_INT);
p->o_val.o_int = 1;
break;
default:
UNDEFINED;
}
} else if ( act->tag == 'i' ){
switch( (act->val.YYsym)->sym_val.YYint ){
case AND:
p = obj_alloc(T_BOOL);
p->o_val.o_int = 1;
break;
case OR:
case XOR:
p = obj_alloc(T_BOOL);
p->o_val.o_int = 0;
break;
default:
UNDEFINED;
}
} else UNDEFINED;
return(p);
}
/*
* If the list has only one element, we return that element.
*/
if( !(p = CDR(obj)) ){
p = CAR(obj);
p->o_refs += 1;
obj_unref(obj);
return(p);
}
/*
* If the list has two elements, we apply our operator and reduce
*/
if( !CDR(p) ){
return( execute(act,obj) );
}
/*
* For three or more elements, we must set up to split the list
* into halves. For every two steps which 'p' makes forward,
* 'q' advances one. When 'p' hits the end, 'q' names the 2nd
* half, and 'hd' names a copy of the first.
*/
x = 0;
hd = 0;
hdp = &hd;
for( q = obj; p; p = CDR(p) ){
if( x ){
*hdp = r = obj_alloc(T_LIST);
hdp = &CDR(r);
CAR(r) = CAR(q);
CAR(q)->o_refs += 1;
q = CDR(q);
x = 0;
} else
x = 1;
}
*hdp = p = obj_alloc(T_LIST);
CAR(p) = CAR(q);
CAR(q)->o_refs += 1;
/*
* 'q' names the second half, but we must add a reference, otherwise
* our use of it via execute() will consume it (and obj still
* references it...).
*/
q = CDR(q);
q->o_refs += 1;
/*
* Almost there... "hd" is the first, "q" is the second, we encase
* them in an outer list, and call execute on them.
*/
p = obj_alloc(T_LIST);
CAR(p) = do_binsert(act,hd);
CAR(CDR(p) = obj_alloc(T_LIST)) = do_binsert(act,q);
obj_unref(obj);
return(execute(act,p));
}
Funky!Stuff!
cat - << \Funky!Stuff! > intrin.c
/*
* intrin.c--intrinsic functions for FP. These are the ones which
* parse as an identifier, and are symbol-tabled.
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
#include "y.tab.h"
#include "math.h"
/*
* This ugly set of macros makes access to objects easier.
*
* UNDEFINED generates the undefined object & returns it
* NUMVAL generates a value for C of the correct type
* CAR manipulates the object as a list & gives its first part
* CDR is like CAR but gives all but the first
* ISNUM provides a boolean saying if the named object is a number
*/
#define UNDEFINED return(obj_alloc(T_UNDEF));
#define NUMVAL(x) ( (x->o_type == T_INT) ? \
((x->o_val).o_int) : ((x->o_val).o_double) )
#define CAR(x) ( ((x)->o_val).o_list.car )
#define CDR(x) ( ((x)->o_val).o_list.cdr )
#define ISNUM(x) ( (x->o_type == T_INT) || (x->o_type == T_FLOAT) )
static struct object *do_dist(), *do_trans(), *do_bool();
extern int numargs();
extern struct object *eqobj();
/*
* Main intrinsic processing routine
*/
struct object *
do_intrinsics(act,obj)
struct symtab *act;
register struct object *obj;
{
register struct object *p, *q;
double f;
/*
* Switch off the tokenal value assigned by YACC. Depending on the
* sophistication of your C compiler, this can generate some
* truly horrendous code. Be prepared! Perhaps it would be
* better to store a pointer to a function in with the symbol
* table...
*/
switch( act->sym_val.YYint ){
case LENGTH:{ /* Length of a list */
int l;
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
for( p = obj, l = 0; p && CAR(p); p = CDR(p) ) l++;
obj_unref(obj);
p = obj_alloc(T_INT);
p->o_val.o_int = l;
return(p);
}
case ID: /* Identity */
return(obj);
case OUT: /* Identity, but print debug line too */
printf("out: ");
obj_prtree(obj);
putchar('\n');
return(obj);
case FIRST:
case HD: /* First elem of a list */
if( obj->o_type != T_LIST ){
obj_unref(obj); UNDEFINED;
}
if( !(p = CAR(obj)) ) return(obj);
p->o_refs += 1;
obj_unref(obj);
return(p);
case TL: /* Remainder of list */
if( (obj->o_type != T_LIST) || !CAR(obj) ){
obj_unref(obj); UNDEFINED;
}
if( !(p = CDR(obj)) ){
p = obj_alloc(T_LIST);
} else {
p->o_refs += 1;
}
obj_unref(obj);
return(p);
case IOTA:{ /* Given arg N, generate <1..N> */
int x, l;
struct object *hd, **hdp = &hd;
if( (obj->o_type != T_INT) && (obj->o_type != T_FLOAT) ){
obj_unref(obj);
UNDEFINED;
}
l = (obj->o_type == T_INT) ? obj->o_val.o_int : obj->o_val.o_double;
obj_unref(obj);
if( l < 0 ) UNDEFINED;
if( l == 0 ) return( obj_alloc(T_LIST) );
for( x = 1; x <= l; x++ ){
*hdp = p = obj_alloc(T_LIST);
q = obj_alloc(T_INT);
q->o_val.o_int = x;
CAR(p) = q;
hdp = &CDR(p);
}
return(hd);
} /* Local block for IOTA */
case PICK:{ /* Parameterized selection */
int x;
/*
* Verify all elements which we will use
*/
if(
(obj->o_type != T_LIST) ||
( (p = CAR(obj))->o_type != T_INT ) ||
!(q = CDR(obj)) ||
( (q = CAR(q))->o_type != T_LIST) ||
( (x = p->o_val.o_int) == 0 )
){
obj_unref(obj);
UNDEFINED;
}
/*
* If x is negative, we are counting from the end
*/
if( x < 0 ){
int tmp = listlen(q);
x += (tmp + 1);
if( x < 1 ){
obj_unref(obj);
UNDEFINED;
}
}
/*
* Loop along the list until our count is expired
*/
for( ; x > 1; --x ){
if( !q ) break;
q = CDR(q);
}
/*
* If fell off the list, error
*/
if( !q || !(q = CAR(q)) ){
obj_unref(obj);
UNDEFINED;
}
/*
* Add a reference to the named object, release the old object
*/
q->o_refs += 1;
obj_unref(obj);
return(q);
}
case LAST: /* Return last element of list */
if( (q = obj)->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
if( !CAR(obj) ) return(obj);
while( p = CDR(q) ) q = p;
q = CAR(q);
q->o_refs += 1;
obj_unref(obj);
return(q);
case FRONT:
case TLR:{ /* Return a list of all but list */
struct object *hd = 0, **hdp = &hd;
if(
((q = obj)->o_type != T_LIST) ||
!CAR(obj)
){
obj_unref(obj);
UNDEFINED;
}
while( CDR(q) ){
*hdp = p = obj_alloc(T_LIST);
if( CAR(p) = CAR(q) ){
CAR(p)->o_refs += 1;
}
hdp = &CDR(p);
q = CDR(q);
}
obj_unref(obj);
if( !hd ) return( obj_alloc(T_LIST) );
else return(hd);
}
case DISTL: /* Distribute from left-most element */
if(
(obj->o_type != T_LIST) ||
( !(q = CAR(obj)) ) ||
(!CDR(obj)) ||
(!(p = CAR(CDR(obj))) ) ||
(p->o_type != T_LIST)
){
obj_unref(obj);
UNDEFINED;
}
return( do_dist(q,p,obj,0) );
case DISTR: /* Distribute from left-most element */
if(
(obj->o_type != T_LIST) ||
( !(q = CAR(obj)) ) ||
(!CDR(obj)) ||
(!(p = CAR(CDR(obj))) ) ||
(q->o_type != T_LIST)
){
obj_unref(obj);
UNDEFINED;
}
return( do_dist(p,q,obj,1) );
case APNDL:{ /* Append element from left */
struct object *r;
if(
(obj->o_type != T_LIST) ||
( !(q = CAR(obj)) ) ||
(!CDR(obj)) ||
(!(p = CAR(CDR(obj))) ) ||
(p->o_type != T_LIST)
){
obj_unref(obj);
UNDEFINED;
}
q->o_refs += 1;
if( !CAR(p) ){ /* Null list? */
obj_unref(obj);
p = obj_alloc(T_LIST);
CAR(p) = q;
return(p); /* Just return element */
}
p->o_refs += 1;
r = obj_alloc(T_LIST);
CDR(r) = p;
CAR(r) = q;
obj_unref(obj);
return(r);
}
case APNDR:{ /* Append element from right */
struct object *hd = 0, **hdp = &hd, *r;
if(
(obj->o_type != T_LIST) ||
( !(q = CAR(obj)) ) ||
(!CDR(obj)) ||
(!(r = CAR(CDR(obj))) ) ||
(q->o_type != T_LIST)
){
obj_unref(obj);
UNDEFINED;
}
r->o_refs += 1;
if( !CAR(q) ){ /* Empty list */
obj_unref(obj);
p = obj_alloc(T_LIST);
CAR(p) = r;
return(p); /* Just return elem */
}
/*
* Loop through list, building a new one. We can't just reuse
* the old one because we're modifying its end.
*/
while( q ){
*hdp = p = obj_alloc(T_LIST);
CAR(q)->o_refs += 1;
CAR(p) = CAR(q);
hdp = &CDR(p);
q = CDR(q);
}
/*
* Tack the element onto the end of the built list
*/
*hdp = p = obj_alloc(T_LIST);
CAR(p) = r;
obj_unref(obj);
return(hd);
}
case TRANS: /* Transposition */
return( do_trans(obj) );
case REVERSE:{ /* Reverse all elements of a list */
struct object *r;
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
if( !CAR(obj) ) return(obj);
for( p = 0, q = obj; q; q = CDR(q) ){
r = obj_alloc(T_LIST);
CDR(r) = p;
p = r;
CAR(p) = CAR(q);
CAR(q)->o_refs += 1;
}
obj_unref(obj);
return(p);
}
case ROTL:{ /* Rotate left */
struct object *hd = 0, **hdp = &hd;
/*
* Wanna list
*/
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
/*
* Need two elems, otherwise be ID function
*/
if(
!(CAR(obj)) ||
!(q = CDR(obj)) ||
!(CAR(q))
){
return(obj);
}
/*
* Loop, starting from second. Build parallel list.
*/
for( /* q has CDR(obj) */ ; q; q = CDR(q) ){
*hdp = p = obj_alloc(T_LIST);
hdp = &CDR(p);
CAR(p) = CAR(q);
CAR(q)->o_refs += 1;
}
*hdp = p = obj_alloc(T_LIST);
CAR(p) = CAR(obj);
CAR(obj)->o_refs += 1;
obj_unref(obj);
return(hd);
}
case ROTR:{ /* Rotate right */
struct object *hd = 0, **hdp = &hd;
/*
* Wanna list
*/
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
/*
* Need two elems, otherwise be ID function
*/
if(
!(CAR(obj)) ||
!(q = CDR(obj)) ||
!(CAR(q))
){
return(obj);
}
/*
* Loop over list. Stop one short of end.
*/
for( q = obj; CDR(q); q = CDR(q) ){
*hdp = p = obj_alloc(T_LIST);
hdp = &CDR(p);
CAR(p) = CAR(q);
CAR(q)->o_refs += 1;
}
p = obj_alloc(T_LIST);
CAR(p) = CAR(q);
CAR(q)->o_refs += 1;
CDR(p) = hd;
obj_unref(obj);
return(p);
}
case CONCAT:{ /* Concatenate several lists */
struct object *hd = 0, **hdp = &hd, *r;
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
if( !CAR(obj) ) return(obj);
for( p = obj; p; p = CDR(p) ){
q = CAR(p);
if( q->o_type != T_LIST ){
obj_unref(obj);
obj_unref(hd);
UNDEFINED;
}
if( !CAR(q) ) continue;
for( ; q; q = CDR(q) ){
*hdp = r = obj_alloc(T_LIST);
hdp = &CDR(r);
CAR(r) = CAR(q);
CAR(q)->o_refs += 1;
}
}
obj_unref(obj);
if( !hd )
return(obj_alloc(T_LIST));
return(hd);
}
case SIN: /* sin() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = sin(f);
obj_unref(obj);
return(p);
case COS: /* cos() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = cos(f);
obj_unref(obj);
return(p);
case TAN: /* tan() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = tan(f);
obj_unref(obj);
return(p);
case ASIN: /* asin() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = asin(f);
obj_unref(obj);
return(p);
case ACOS: /* acos() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = acos(f);
obj_unref(obj);
return(p);
case ATAN: /* atan() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = atan(f);
obj_unref(obj);
return(p);
case EXP: /* exp() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = exp(f);
obj_unref(obj);
return(p);
case LOG: /* log() function */
if( !ISNUM(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
f = NUMVAL(obj);
p->o_val.o_double = log(f);
obj_unref(obj);
return(p);
case MOD: /* Modulo */
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:{
int x1, x2;
x1 = NUMVAL(CAR(obj));
if( (x2 = NUMVAL(CAR(CDR(obj)))) == 0 ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_INT);
(p->o_val).o_int = x1 % x2;
obj_unref(obj);
return(p);
}
}
case PAIR:{ /* Pair up successive elements of a list */
struct object *hd = 0, **hdp = &hd, *r;
int x;
if(
(obj->o_type != T_LIST) ||
!CAR(obj)
){
obj_unref(obj);
UNDEFINED;
}
for( p = obj, x = 0; p; p = CDR(p) ){
if( x == 0 ){
*hdp = q = obj_alloc(T_LIST);
hdp = &CDR(q);
CAR(q) = r = obj_alloc(T_LIST);
CAR(r) = CAR(p);
CAR(p)->o_refs += 1;
x++;
} else {
CDR(r) = q = obj_alloc(T_LIST);
CAR(q) = CAR(p);
CAR(p)->o_refs += 1;
x = 0;
}
}
obj_unref(obj);
return(hd);
}
case SPLIT:{ /* Split list into two (roughly) equal halves */
int l,x;
struct object *hd = 0, **hdp = &hd, *top;
if(
(obj->o_type != T_LIST) ||
( (l = listlen(obj)) == 0 )
){
obj_unref(obj);
UNDEFINED;
}
l = ((l-1) >> 1)+1;
for( x = 0, p = obj; x < l; ++x, p = CDR(p) ){
*hdp = q = obj_alloc(T_LIST);
hdp = &CDR(q);
CAR(q) = CAR(p);
CAR(p)->o_refs += 1;
}
CAR(top = obj_alloc(T_LIST)) = hd;
hd = 0; hdp = &hd;
while(p){
*hdp = q = obj_alloc(T_LIST);
hdp = &CDR(q);
CAR(q) = CAR(p);
CAR(p)->o_refs += 1;
p = CDR(p);
}
if( !hd ) hd = obj_alloc(T_LIST);
CAR(CDR(top) = obj_alloc(T_LIST)) = hd;
obj_unref(obj);
return(top);
}
case ATOM:{
int result;
switch( obj->o_type ){
case T_UNDEF:
return(obj);
case T_INT:
case T_BOOL:
case T_FLOAT:
result = 1;
break;
default:
result = 0;
}
p = obj_alloc(T_BOOL);
p->o_val.o_int = result;
obj_unref(obj);
return(p);
}
case DIV: /* Like '/', but forces integer operation */
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:{
int x1, x2;
x1 = NUMVAL(CAR(obj));
if( (x2 = NUMVAL(CAR(CDR(obj)))) == 0 ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_INT);
(p->o_val).o_int = x1 / x2;
obj_unref(obj);
return(p);
}
}
case NIL:
if( obj->o_type != T_LIST ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_BOOL);
if( CAR(obj) ) p->o_val.o_int = 0;
else p->o_val.o_int = 1;
obj_unref(obj);
return(p);
case EQ:
return( eqobj(obj) );
case AND:
return( do_bool(obj,AND) );
case OR:
return( do_bool(obj,OR) );
case XOR:
return( do_bool(obj,XOR) );
case NOT:
if( obj->o_type != T_BOOL ){
obj_unref(obj);
UNDEFINED;
}
(p = obj_alloc(T_BOOL))->o_val.o_int = !obj->o_val.o_int;
obj_unref(obj);
return(p);
default:
fatal_err("Unrecognized symbol in do_intrinsics()");
} /* Switch() */
/*NOTREACHED*/
}
/*
* listlen()--return length of a list
*/
listlen(p)
register struct object *p;
{
register l = 0;
while( p && CAR(p) ){
++l;
p = CDR(p);
}
return(l);
}
/*
* Common code between distribute-left and -right
*/
static struct object *
do_dist(elem,lst,obj,side)
register struct object *elem, *lst;
struct object *obj; /* Source object */
int side; /* Which side to stick on */
{
register struct object *r, *r2;
struct object *hd, **hdp = &hd;
if( !CAR(lst) ){ /* Distributing over NULL list */
lst->o_refs += 1;
obj_unref(obj);
return(lst);
}
/*
* Evil C! Line-by-line, here's what's happening
* 1. Get the first list element for the "lower" list
* 2. Bind the CAR of it to the distributing object,
* incrementing that object's reference counter.
* 3. Get the second element for the "lower" list, bind
* the CDR of the first element to it.
* 4. Bind the CAR of the second element to the current
* element in the list being distributed over, increment
* that object's reference count.
* 5. Allocate the "upper" list element, build it into the
* chain.
* 6. Advance the chain building pointer to be ready to add
* the next element.
* 7. Advance to next element of list being distributed over.
*
* Gee, wasn't that easy?
*/
while( lst ){
r = obj_alloc(T_LIST);
if( !side ){
CAR(r) = elem;
elem->o_refs += 1;
} else {
CAR(r) = CAR(lst);
CAR(lst)->o_refs += 1;
}
r2 = CDR(r) = obj_alloc(T_LIST);
if( !side ){
CAR(r2) = CAR(lst);
CAR(lst)->o_refs += 1;
} else {
CAR(r2) = elem;
elem->o_refs += 1;
}
*hdp = obj_alloc(T_LIST);
CAR(*hdp) = r;
hdp = &CDR(*hdp);
lst = CDR(lst);
}
obj_unref(obj);
return(hd);
}
/*
* do_trans()--transpose the elements of the "matrix"
*/
static struct object *
do_trans(obj)
register struct object *obj;
{
int len = 0, x, y;
register struct object *p, *q, *r;
struct object *hd = 0, **hdp = &hd;
/*
* Check argument, make sure first element is a list.
*/
if(
( (p = obj)->o_type != T_LIST) ||
!( p = CAR(obj) ) ||
( p->o_type != T_LIST )
){
obj_unref(obj);
UNDEFINED;
}
/*
* Get how many down (len)
*/
len = listlen(p);
/*
* Verify the structure. Make sure each across is a list,
* and of the same length.
*/
for( q = obj; q ; q = CDR(q) ){
r = CAR(q);
if(
(r->o_type != T_LIST) ||
(listlen(r) != len)
){
obj_unref(obj);
UNDEFINED;
}
}
/*
* By definition, list of NULL lists returns <>
*/
if( len == 0 ){
obj_unref(obj);
return( obj_alloc(T_LIST) );
}
/*
* Here is an O(n^3) way of building a transposed matrix.
* Loop over each depth, building across. I'm so debonnair
* about it because I never use this blinking function.
*/
for( x = 0; x < len; ++x ){
struct object *s = obj_alloc(T_LIST), *hd2 = 0, **hdp2 = &hd2;
*hdp = s;
hdp = &CDR(s);
for( p = obj; p; p = CDR(p) ){
q = CAR(p);
for( y = 0; y < x; ++y )
q = CDR(q);
q = CAR(q);
r = obj_alloc(T_LIST);
*hdp2 = r;
hdp2 = &CDR(r);
CAR(r) = q;
q->o_refs += 1;
}
CAR(s) = hd2;
}
obj_unref(obj);
return(hd);
}
/*
* do_bool()--do the three boolean binary operators
*/
static struct object *
do_bool(obj,op)
struct object *obj;
int op;
{
register struct object *p, *q;
struct object *r;
int i;
if(
(obj->o_type != T_LIST) ||
( (p = CAR(obj))->o_type != T_BOOL) ||
( (q = CAR(CDR(obj)))->o_type != T_BOOL)
){
obj_unref(obj);
UNDEFINED;
}
r = obj_alloc(T_BOOL);
switch( op ){
case AND:
i = p->o_val.o_int && q->o_val.o_int;
break;
case OR:
i = p->o_val.o_int || q->o_val.o_int;
break;
case XOR:
i = (p->o_val.o_int || q->o_val.o_int) &&
!(p->o_val.o_int && q->o_val.o_int);
break;
default:
fatal_err("Illegal binary logical op in do_bool()");
}
r->o_val.o_int = i;
obj_unref(obj);
return(r);
}
Funky!Stuff!
cat - << \Funky!Stuff! > lex.c
/*
* A standard lexical analyzer
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "symtab.h"
#include <stdio.h>
#include <ctype.h>
static char buf[80];
static int donum();
extern YYSTYPE yylval;
extern void exit(), perror();
static FILE *cur_in = stdin;
static nextc();
char prompt;
#define MAXNEST 5 /* How deep can we get? */
static FILE *fstack[MAXNEST]; /* For nested loads */
static int fpos = 0;
/*
* Skip leading white space in current input stream
*/
static void
skipwhite(){
register c;
/*
* Skip leading blank space
*/
while( (c = nextc()) != EOF )
if( !isspace(c) ) break;
ungetc(c,cur_in);
}
/*
* Lexical analyzer for YACC
*/
yylex(){
register char *p = buf;
register c, c1;
/*
* Skip over white space
*/
again:
skipwhite();
c = nextc();
/*
* Return EOF
*/
if( c == EOF ) return(c);
/*
* An "identifier"?
*/
if( isalpha(c) ){
struct symtab *q;
/*
* Assemble a "word" out of the input stream, symbol table it
*/
*p++ = c;
while( isalnum(c = nextc()) ) *p++ = c;
ungetc(c,cur_in);
*p = '\0';
q = lookup(buf);
/*
* yylval is always set to the symbol table entry
*/
yylval.YYsym = q;
/*
* For built-ins, return the token value
*/
if( q->sym_type == SYM_BUILTIN ) return( q->sym_val.YYint );
/*
* For user-defined (or new),
* return "User Defined"--UDEF
*/
return( UDEF );
}
/*
* For numbers, call our number routine.
*/
if( isdigit(c) ) return( donum(c) );
/*
* For possible unary operators, see if a digit
* immediately follows.
*/
if( (c == '+') || (c == '-') ){
char c2 = nextc();
ungetc(c2,cur_in);
if( isdigit(c2) )
return( donum(c) );
}
/*
* For certain C operators, need to look at following char to
* assemble relationals. Otherwise, just return the char.
*/
yylval.YYint = c;
switch( c ){
case '<':
if( (c1 = nextc()) == '=' ) return( yylval.YYint = LE );
ungetc( c1, cur_in );
return(c);
case '>':
if( (c1 = nextc()) == '=' ) return( yylval.YYint = GE );
ungetc( c1, cur_in );
return(c);
case '~':
if( (c1 = nextc()) == '=' ) return( yylval.YYint = NE );
ungetc( c1, cur_in );
return(c);
default:
return(c);
}
}
static int
donum(startc)
char startc;
{
char isdouble = 0;
register char c, *p = buf;
*p++ = startc;
for(;;){
c = nextc();
if( isdigit(c) ){
*p++ = c;
continue;
}
if( c == '.' ){
*p++ = c;
isdouble = 1;
continue;
}
ungetc( c, cur_in );
break;
}
*p = '\0';
if( isdouble ){
sscanf(buf,"%lf",&(yylval.YYdouble));
return( FLOAT );
} else {
sscanf(buf,"%d",&(yylval.YYint));
return( INT );
}
}
/*
* getchar() function for lexical analyzer. Adds a prompt if
* input is from keyboard, also localizes I/O redirection.
*/
static
nextc(){
register int c;
static saw_eof = 0;
again:
if( cur_in == stdin ){
if( saw_eof ) return(EOF);
if( !stdin->_cnt )
putchar(prompt);
}
c = fgetc(cur_in);
if( c == '#' ){
while( (c = fgetc(cur_in)) != EOF )
if( c == '\n' ) goto again;
}
/*
* Pop up a level of indirection on EOF
*/
if( c == EOF ){
if( cur_in != stdin ){
fclose(cur_in);
cur_in = fstack[--fpos];
goto again;
} else {
saw_eof++;
}
}
return(c);
}
/*
* Command processor. The reason it's here is that we play with
* I/O redirection. Shrug.
*/
void
fp_cmd(){
char cmd[80], *p = cmd, arg[80];
register c;
FILE *newf;
/*
* Assemble a word, the command
*/
skipwhite();
if( (c = nextc()) == EOF ) return;
*p++ = c;
while( (c = nextc()) != EOF )
if( isalpha(c) ) *p++ = c;
else break;
*p = '\0';
/*
* Process the command
*/
if( strcmp(cmd,"load") == 0 ){ /* Load command */
/*
* Get next word, the file to load
*/
skipwhite();
p = arg;
while( (c = nextc()) != EOF )
if( isspace(c) ) break;
else *p++ = c;
*p = '\0';
/*
* Can we push down any more?
*/
if( fpos == MAXNEST-1 ){
printf(")load'ed files nested too deep\n");
return;
}
/*
* Try and open the file
*/
if( (newf = fopen(arg,"r")) == 0 ){
perror(arg);
return;
}
/*
* Pushdown the current file, make this one it.
*/
fstack[fpos++] = cur_in;
cur_in = newf;
return;
}
if( strcmp(cmd,"quit") == 0 ){ /* Leave */
printf("\nDone\n");
exit( 0 );
}
if( strcmp(cmd,"help") == 0 ){ /* Give help */
printf("Commands are:\n");
printf(" quit - leave FP\n");
printf(" help - this message\n");
printf(" load - redirect input from a file\n");
#ifdef YYDEBUG
printf(" yydebug - toggle parser tracing\n");
#endif
return;
}
#ifdef YYDEBUG
if( strcmp(cmd,"yydebug") == 0 ){ /* Toggle parser trace */
extern int yydebug;
yydebug = !yydebug;
return;
}
#endif
printf("Unknown command '%s'\n",cmd);
}
Funky!Stuff!
cat - << \Funky!Stuff! > obj.c
/*
* obj.c--implement the type "object" and its operators
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
static struct object *free_objs = 0;
#ifdef MEMSTAT
int obj_out = 0;
#endif
/*
* Allocate an object
*/
struct object *
obj_alloc(ty)
uchar ty;
{
register struct object *p;
#ifdef MEMSTAT
obj_out++;
#endif
/*
* Have a free one on the list
*/
if( p = free_objs ){
free_objs = (p->o_val).o_list.car;
} else if( (p = (struct object *)malloc(sizeof(struct object))) == 0 )
fatal_err("out of memory in obj_alloc()");
p->o_refs = 1;
if( (p->o_type = ty) == T_LIST )
p->o_val.o_list.car = p->o_val.o_list.cdr = 0;
return(p);
}
/*
* Free an object
*/
void
obj_free(p)
struct object *p;
{
#ifdef MEMSTAT
obj_out--;
#endif
if( !p ) fatal_err("Null object to obj_free()");
(p->o_val).o_list.car = free_objs;
free_objs = p;
}
/*
* Unreference this pointer, updating objects which it might
* reference.
*/
void
obj_unref(p)
register struct object *p;
{
if( !p ) return;
if( --(p->o_refs) ) return;
switch( p->o_type ){
case T_INT:
case T_FLOAT:
case T_UNDEF:
case T_BOOL:
obj_free(p);
return;
case T_LIST:
obj_unref( (p->o_val).o_list.car );
obj_unref( (p->o_val).o_list.cdr );
obj_free(p);
return;
default:
fatal_err("Unknown type in obj_unref()");
}
/*NOTREACHED*/
}
static char last_close = 0;
void
obj_prtree(p)
struct object *p;
{
if( !p ) return;
switch( p->o_type ){
case T_INT:
last_close = 0;
printf("%d ",(p->o_val).o_int); return;
case T_FLOAT:
last_close = 0;
printf("%.9g ",(p->o_val).o_double); return;
case T_BOOL:
last_close = 0;
printf("%s ",
(p->o_val).o_int ? "T" : "F"); return;
case T_UNDEF:
last_close = 0;
printf("? "); return;
case T_LIST:
printf("<");
last_close = 0;
if( !p->o_val.o_list.car ){
printf(">");
last_close = 1;
return;
}
while( p ){
obj_prtree( (p->o_val).o_list.car );
p = (p->o_val).o_list.cdr;
}
if( !last_close ) putchar('\b');
printf("> ");
last_close = 1;
return;
}
/*NOTREACHED*/
}
Funky!Stuff!
--
For comp.sources.unix stuff, mail to sources@uunet.uu.net.