v13i015: Functional programming language, Part02/02

Rich Salz rsalz at bbn.com
Fri Feb 5 08:13:05 AEST 1988


Submitted-by: Andy Valencia <vandys at 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 at uunet.uu.net.



More information about the Comp.sources.unix mailing list