v13i014: Functional programming language, Part01/02
Rich Salz
rsalz at bbn.com
Fri Feb 5 08:12:47 AEST 1988
Submitted-by: Andy Valencia <vandys at lindy.stanford.edu>
Posting-number: Volume 13, Issue 14
Archive-name: funcproglang/part01
Enclosed is part 1 of a two-part shar implementing FP in C.
It differs from the IFP recently posted in that it closely follows
the syntax of the FP provided by 4.2 BSD (which is also the syntax used
by Backus himself). I think you'll want to tinker with the makefile
a bit, but otherwise it shouldn't cause you any trouble--just compile
and run.
Thanks,
Andy Valencia
vandys at lindy.stanford.edu
-----cut here-----cut here-----cut here-----cut here-----
#!/bin/sh
# This is a shell archive.
# It contains fp.shar, 1/2
# Run the following text with /bin/sh to extract.
cat - << \Funky!Stuff! > Makefile
#
# Makefile for fp
#
# Copyright (c) 1986 by Andy Valencia
#
# Compile-time options
# -DMEMSTAT to get run-time memory statitistics/checking
# -DYYDEBUG to get parser tracing
DEFS=
#
# Name your math library here. On the HP-9000/320, for instance, naming
# -l881 instead of -lm will use the 68881 coprocessor.
#
MathLibs= -lfpa -lm -lfpa
#
CFLAGS= -O $(DEFS)
OBJS= y.tab.o symtab.o lex.o misc.o ast.o obj.o \
exec.o charfn.o intrin.o defun.o
fp: $(OBJS)
cc -o fp $(CFLAGS) $(OBJS) $(MathLibs)
y.tab.h y.tab.c: parse.y fp.h
yacc -d parse.y
y.tab.o: y.tab.c
cc $(CFLAGS) -c y.tab.c
lex.o: symtab.h lex.c y.tab.h
symtab.o: symtab.c symtab.h fp.h y.tab.h
ast.o: ast.c fp.h
obj.o: obj.c fp.h
exec.o: exec.c fp.h y.tab.h
charfn.o: charfn.c fp.h y.tab.h
instrinsics.o: instrinsics.c fp.h y.tab.h
defun.o: defun.c symtab.h fp.h y.tab.h
Funky!Stuff!
cat - << \Funky!Stuff! > README
This directory contains a C implementation of John Backus' "FP"
language. I wrote this over a period of time, so don't be too shocked by
many repetitions of the same sequence of code. The stuff has been written
to run on HP-UX, which is mostly system V. It handles signals using the
"old" signal handler interface, which might offend some reliable signal buffs,
but seemed to be compatible with more systems.
Aside from signals it does absolutely nothing surprising, and is quite
conscientious about declaring what it uses (even in the YACC file!). It
has ported to HP-UX on both RISC and 68K-family machines, and has also
run on our 4.2 VAX. "lint" is reasonably happy with it, but still complains
about things like "printf() returns a value which is always ignored". I
haven't done anything about these sorts of complaints. If you come
across any unportable facet (within reason), I will be happy to change it.
This code is completely original and wholly created by myself. I
release this code into the public domain without limitations or exceptions.
You may use this code in whole or part for any purpose whatsoever, including
commercial advantage. If you wish to provide some payment for its use,
give it to a charity of your choice instead.
Many thanks to John Backus for his refreshing Turing award lecture,
and to the many people who are working on non-Von Neumann languages and
machine architectures. Please get in touch with me if you are doing work
in these areas!
Regards,
Andy Valencia
vandys at lindy.stanford.edu
br.ajv at rlg.BITNET
The files and their contents are:
Makefile System-V makefile
_astprtr Debugging routine to print the syntax tree
ast.c Routines to manage syntax tree nodes
charfn.c Routines to handle "char" functions, like '+'
defun.c Routines to handle user-defined functions
exec.c Top-level run-time driving functions
fp.h Central include file
intrin.c Execution of identifier-like functions, like "hd"
lex.c The lexical analyzer
misc.c Miscellaneous functions, like main() and fatal_err()
obj.c Functions to manage "object" nodes
parse.y A YACC parser for FP
symtab.c Symbol table handler
symtab.h Local declarations for symbol table
The following files contain sample FP programs:
bubsort.fp Demo routine to do a bubble sort
dft.fp Discrete Fourier transform functions
primes.fp Prime number generator
test.fp My regression test file. Won't run on UCB FP!
Funky!Stuff!
cat - << \Funky!Stuff! > _astprtr
/*
* This file contains a routine for printing the parse tree.
* It is useful when changing the syntax around.
*
* Copyright (c) 1986 by Andy Valencia
*/
/*
* For debugging, print the parse tree
*/
void
ast_prtree(p,d)
struct ast *p;
int d;
{
int t = p->tag, x;
if( !p ) return;
for( x = 1; x <= d; x++ ) putchar(' ');
printf("Tag '%c'",t);
switch( t ){
case 'c':{
int c = (p->val).YYint;
printf(" operator '");
if( (c >= ' ') && (c < 127) )
putchar(c);
else switch( c ){
case NE: printf("NE"); break;
case LE: printf("<="); break;
case GE: printf(">="); break;
default: printf("???"); break;
}
printf("'\n");
break;
}
case 'S':
printf(" value %d\n",(p->val).YYint);
break;
case 'I':
printf(" value %d\n",(p->val).YYint);
break;
case 'F':
printf(" value %g\n",(p->val).YYfloat);
break;
case 'B':
printf(" boolean %s\n",(p->val).YYint ? "T" : "F");
break;
case 'i':
printf(" intrinsic name '%s'\n",((p->val).YYsym)->sym_pname);
break;
case 'L': {
putchar('\n');
while( p ){
ast_prtree(p->left,d+1);
p = p->right;
}
break;
}
case '[': {
struct ast *q = p->left;
putchar('\n');
while( q ){
ast_prtree(q->left,d+1);
q = q->right;
}
break;
}
default:
putchar('\n');
ast_prtree(p->left,d+1);
ast_prtree(p->middle,d+1);
ast_prtree(p->right,d+1);
break;
}
}
Funky!Stuff!
cat - << \Funky!Stuff! > ast.c
/*
* Routines for allocating & freeing AST nodes
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
#include "y.tab.h"
static struct ast *ast_list = 0;
#ifdef MEMSTAT
int ast_out = 0;
#endif
/*
* Get a node
*/
struct ast *
ast_alloc(atag,l,m,r)
int atag;
struct ast *l, *m, *r;
{
register struct ast *p;
#ifdef MEMSTAT
ast_out++;
#endif
if( p = ast_list ){
ast_list = p->left;
} else {
p = (struct ast *)malloc(sizeof(struct ast));
}
if( p == 0 ) fatal_err("Out of mem in ast_alloc()");
p->tag = atag;
p->left = l;
p->middle = m;
p->right = r;
return( p );
}
/*
* Free a node
*/
void
ast_free(p)
register struct ast *p;
{
#ifdef MEMSTAT
ast_out--;
#endif
if( !p ) fatal_err("NULL node in ast_free()");
p->left = ast_list;
ast_list = p;
}
/*
* Free a whole tree
*/
void
ast_freetree(p)
struct ast *p;
{
if( !p ) return;
ast_freetree(p->left);
ast_freetree(p->right);
ast_freetree(p->middle);
if( p->tag == '%' )
obj_unref( (p->val).YYobj );
ast_free(p);
}
Funky!Stuff!
cat - << \Funky!Stuff! > bsort.fp
#
# A divide-and-conquer sorting algorithm
#
{grpleft
concat @ &( > -> tl ; %<>) @ distl }
{grpright
concat @ &( < -> tl ; %<>) @ distl }
{arb 1}
{bsort
(>@[length %1] ->
concat@[bsort at grpleft [1] bsort at grpright]@[arb id]
; id)
}
Funky!Stuff!
cat - << \Funky!Stuff! > bubsort.fp
{swap concat@[ [2,1],tl at tl ]}
{step (>@[1,2] -> swap ; id) }
{pass
(<@[length,%2] -> id ;
apndl@[1,pass at tl]@step)
}
{bubsort
(<@[length,%2] -> id ;
apndr@[bubsort at tlr,last]@pass)
}
Funky!Stuff!
cat - << \Funky!Stuff! > charfn.c
/*
* charfn.c--functions to do the "character" functions, like +, -, ...
*
* 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) )
int numargs();
/*
* same()--looks at two objects and tells whether they are the same.
* We recurse if it is a list.
*/
static
same( o1, o2 )
register struct object *o1, *o2;
{
if( o1 == o2 ) return( 1 );
if( o1->o_type != o2->o_type ){
if( o1->o_type == T_INT )
if( o2->o_type == T_FLOAT )
return( o1->o_val.o_int == o2->o_val.o_double );
if( o2->o_type == T_INT )
if( o1->o_type == T_FLOAT )
return( o2->o_val.o_int == o1->o_val.o_double );
return( 0 );
}
switch( o1->o_type ){
case T_INT:
case T_BOOL:
return( o1->o_val.o_int == o2->o_val.o_int );
case T_FLOAT:
return( o1->o_val.o_double == o2->o_val.o_double );
case T_LIST:
return( same(CAR(o1),CAR(o2)) && same(CDR(o1),CDR(o2)) );
default:
fatal_err("Bad AST type in same()");
}
/*NOTREACHED*/
}
/*
* ispair()--tell if our argument object is a list of two elements
*/
static
ispair(obj)
register struct object *obj;
{
if( obj->o_type != T_LIST ) return( 0 );
if( CAR(obj) == 0 ) return( 0 );
if( CDR(obj) == 0 ) return( 0 );
if( CDR(CDR(obj)) ) return( 0 );
return( 1 );
}
/*
* eqobj()--tell if the two objects in the list are equal.
* undefined on ill-formed list, etc.
*/
struct object *
eqobj(obj)
struct object *obj;
{
struct object *p;
if( !ispair(obj) ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_BOOL);
if( same(CAR(obj),CAR(CDR(obj))) )
p->o_val.o_int = 1;
else
p->o_val.o_int = 0;
obj_unref(obj);
return(p);
}
/*
* noteqobj()--just like eqobj(), but not equal
*/
static struct object *
noteqobj(obj)
struct object *obj;
{
struct object *p = eqobj(obj);
if( p->o_type == T_BOOL )
p->o_val.o_int = (p->o_val.o_int ? 0 : 1);
return(p);
}
/*
* do_charfun()--execute the action of a binary function
*/
struct object *
do_charfun(act,obj)
struct ast *act;
register struct object *obj;
{
register struct object *p;
double f;
switch( (act->val).YYint ){
case '=':
return( eqobj(obj) );
case NE:
return( noteqobj(obj) );
case '>':
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:
p = obj_alloc(T_BOOL);
(p->o_val).o_int = NUMVAL(CAR(obj)) > NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case GE:
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:
p = obj_alloc(T_BOOL);
(p->o_val).o_int = NUMVAL(CAR(obj)) >= NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case LE:
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:
p = obj_alloc(T_BOOL);
(p->o_val).o_int = NUMVAL(CAR(obj)) <= NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case '<':
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:
p = obj_alloc(T_BOOL);
(p->o_val).o_int = NUMVAL(CAR(obj)) < NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case '+':
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
p = obj_alloc(T_FLOAT);
(p->o_val).o_double = NUMVAL(CAR(obj))+NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
case T_INT:
p = obj_alloc(T_INT);
(p->o_val).o_int = NUMVAL(CAR(obj))+NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case '-':
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
p = obj_alloc(T_FLOAT);
(p->o_val).o_double = NUMVAL(CAR(obj))-NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
case T_INT:
p = obj_alloc(T_INT);
(p->o_val).o_int = NUMVAL(CAR(obj))-NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case '*':
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
p = obj_alloc(T_FLOAT);
(p->o_val).o_double = NUMVAL(CAR(obj))*NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
case T_INT:
p = obj_alloc(T_INT);
(p->o_val).o_int = NUMVAL(CAR(obj))*NUMVAL(CAR(CDR(obj)));
obj_unref(obj);
return(p);
}
case '/':
switch( numargs(obj) ){
case T_UNDEF:
obj_unref(obj);
UNDEFINED;
case T_FLOAT:
case T_INT:
f = NUMVAL(CAR(CDR(obj)));
if( f == 0.0 ){
obj_unref(obj);
UNDEFINED;
}
p = obj_alloc(T_FLOAT);
(p->o_val).o_double = NUMVAL(CAR(obj))/f;
obj_unref(obj);
return(p);
}
default:
fatal_err("Undefined charop tag in execute()");
}
/*NOTREACHED*/
}
/*
* numargs()--process a list which is to be used as a pair of numeric
* arguments to a function.
*
* +, -, /, etc. all need two functions: first, they need to know
* if their arguments are OK. Is it a list, are there two
* numbers in it?, etc. We make C normalize the two numbers, but
* we tell our caller if the result will be double or int, so that he
* can allocate the right type of object.
*/
numargs(obj)
register struct object *obj;
{
register struct object *p, *q;
/*
* Don't have a well-formed list, so illegal
*/
if( !ispair(obj) ) return(T_UNDEF);
/*
* So it's a list of two. Verify type of both elements.
* 'p' gets the first object, 'q' gets second.
*/
p = CAR(obj);
q = CAR(CDR(obj));
if( !ISNUM(p) || !ISNUM(q) ) return(T_UNDEF);
if( (p->o_type == T_FLOAT) || (q->o_type == T_FLOAT) )
return(T_FLOAT);
return(T_INT);
}
Funky!Stuff!
cat - << \Funky!Stuff! > defun.c
/*
* defun.c--define a user function
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "symtab.h"
/*
* Define a function
*/
void
defun(name,def)
register struct symtab *name;
struct ast *def;
{
/*
* Check what we're defining, handle redefining
*/
switch( name->sym_type ){
case SYM_DEF:
printf("%s: redefined.\n",name->sym_pname);
ast_freetree(name->sym_val.YYast);
break;
case SYM_NEW:
printf("{%s}\n",name->sym_pname);
break;
default:
fatal_err("Bad symbol stat in defun()");
}
/*
* Mark symbol as a user-defined function, attach its
* definition.
*/
name->sym_val.YYast = def;
name->sym_type = SYM_DEF;
}
/*
* Call a previously-defined user function, or error
*/
struct object *
invoke( def, obj )
register struct symtab *def;
struct object *obj;
{
/*
* Must be a defined function
*/
if( def->sym_type != SYM_DEF ){
printf("%s: undefined\n",def->sym_pname);
obj_unref(obj);
return( obj_alloc(T_UNDEF) );
}
/*
* Call it with the object
*/
return( execute( def->sym_val.YYast, obj ) );
}
Funky!Stuff!
cat - << \Funky!Stuff! > dft.fp
# Discrete Fourier Transform
# Usage: dft : b
# Where "b" is the input vector
{pi %3.141592653589793}
{wN 1}
{p 2}
{r 2}
{B 1}
{realCDiv &/ @ distr @ reverse}
{distMult &* @ distl}
{iota0 apndl @ [%0,
iota @ - @ [id,%1]
]
}
{oddp = @ [%1 , mod @ [id,%2]]}
{cAdd &+ @ trans}
{reCxIp !cAdd @ &&* @ &distl @ trans}
{cExp [cos , sin]}
{N length @ 1}
{w cExp @ / @ [!* @ [%-2, pi, p],
wN
]
}
{ws cExp @ + @ [pi,
/ @ [!* @ [%-2, pi, p],
wN
]
]
}
{wFactors &(oddp @ 3 ->
ws @ [1,* @ tl];
w @ [1,* @ tl]) @
&apndl @
distl @
[N,
distl @ [r, iota0 @ N]
]
}
{dftPt realCDiv @ [N,
reCxIp @ [B, wFactors]
]
}
{dft &dftPt @ distl @ [id,iota0 @ length]}
{b %<1.0, 2.0, 3.0, 4.0, 3.0, 2.0, 1.0, 0.5>}
{d %<0.0, 0.5, 1.0, 1.0>}
{e %<
1.0, 2.0, 3.0, 4.0, 3.0, 2.0, 1.0, 0.5, 1.0, 2.0, 3.0, 4.0, 3.0, 2.0, 1.0, 0.5,
1.0, 2.0, 3.0, 4.0, 3.0, 2.0, 1.0, 0.5, 1.0, 2.0, 3.0, 4.0, 3.0, 2.0, 1.0, 0.5>}
Funky!Stuff!
cat - << \Funky!Stuff! > fp.h
/*
* Common definitions for FP
*
* Copyright (c) 1986 by Andy Valencia
*/
/*
* Aliases for unsigned quantities. Not really any reason, just
* couldn't resist wasting a bit...
*/
typedef unsigned char uchar;
typedef unsigned long int uint;
/*
* The symbolic names for the different types
*/
#define T_INT 1 /* Integer */
#define T_FLOAT 2 /* Floating point */
#define T_LIST 3 /* A LISP-style list */
#define T_UNDEF 4 /* The undefined object */
#define T_BOOL 5 /* A boolean value */
/*
* A list of arbitrary objects
*/
struct list {
struct object
*car, /* Head of list */
*cdr; /* and Tail */
};
/*
* An object's structure
*/
struct object {
uchar o_type; /* Type for selecting */
uint o_refs; /* Number of current refs, for GC */
union {
int o_int; /* T_INT, T_BOOL */
double o_double; /* T_FLOAT */
struct list o_list; /* T_LIST */
} o_val;
};
extern struct ast *ast_alloc();
extern struct object *obj_alloc(), *execute(), *invoke();
extern void ast_free(), ast_freetree(), fatal_err(), defun(),
symtab_init(), obj_free(), obj_unref(), obj_prtree();
extern char *malloc();
extern struct symtab *lookup();
/*
* To alleviate typing in YACC, this type embodies all the
* types which "yylval" might receive.
*/
typedef union {
int YYint;
double YYdouble;
struct ast *YYast;
struct object *YYobj;
struct list *YYlist;
struct symtab *YYsym;
} YYstype;
#define YYSTYPE YYstype
/*
* An AST
*/
struct ast {
int tag;
YYSTYPE val;
struct ast *left, *middle, *right;
};
/*
* A symbol table entry for an identifier
*/
struct symtab {
uchar sym_type;
YYstype sym_val;
struct symtab *sym_next;
char *sym_pname;
};
Funky!Stuff!
cat - << \Funky!Stuff! > misc.c
/*
* Miscellaneous functions
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
#include <setjmp.h>
#include <signal.h>
extern void exit(), longjmp();
extern char prompt;
static jmp_buf restart;
void
fatal_err(msg)
char *msg;
{
printf("Fatal error: %s\n",msg);
exit( 1 );
}
yyerror(msg)
char *msg;
{
printf("yyerror() reports '%s'\n",msg);
prompt = '\t';
}
/*
* Floating exception handler
*/
static void
badmath(){
printf("Floating exception\n");
prompt = '\t';
signal(SIGFPE, badmath);
longjmp(restart,1);
}
/*
* User interrupt handler
*/
static void
intr(){
printf("Interrupt\n");
prompt = '\t';
signal(SIGINT, intr);
longjmp(restart,1);
}
main() {
symtab_init();
prompt = '\t';
signal(SIGFPE, badmath);
signal(SIGINT, intr);
if( setjmp(restart) == 0 )
printf("FP v0.0\n");
else
printf("FP restarted\n");
yyparse();
printf("\nFP done\n");
exit( 0 );
/*NOTREACHED*/
}
Funky!Stuff!
cat - << \Funky!Stuff! > parse.y
%{
/*
* FP syntax for YACC
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
#define NULLAST ((struct ast *)0)
extern char prompt;
static char had_undef = 0;
extern void fp_cmd();
#ifdef MEMSTAT
extern int obj_out, ast_out;
#endif
%}
%start go
%token INT FLOAT T F ID UDEF AND OR XOR NE GT LT GE LE
%token SIN COS TAN ASIN ACOS ATAN LOG EXP MOD CONCAT LAST FIRST PICK
%token TL HD ATOM NOT EQ NIL REVERSE DISTL DISTR LENGTH DIV
%token TRANS APNDL APNDR TLR ROTL ROTR IOTA PAIR SPLIT OUT
%token FRONT
%token WHILE
%token '[' ']'
%right '@'
%right '%' '!' '&' '|'
%%
go : go fpInput
| go error
{ yyclearin; }
| Empty
;
fpInput
: fnDef
{
#ifdef MEMSTAT
if( obj_out || ast_out ){
printf("%d objects and %d AST nodes used in definition\n",
obj_out,ast_out);
obj_out = ast_out = 0;
}
#endif
}
| application
{
#ifdef MEMSTAT
if( obj_out || ast_out ){
printf("%d objects lost, %d AST nodes lost\n",obj_out,ast_out);
obj_out = ast_out = 0;
}
#endif
}
| ')'
{ fp_cmd(); }
;
fnDef : '{'
{ prompt = '>'; }
name funForm
'}'
{
defun($3.YYsym,$4.YYast);
prompt = '\t';
}
;
application
: { prompt = '-'; }
funForm ':' object
{
struct object *p = execute($2.YYast,$4.YYobj);
obj_prtree(p);
printf("\n");
obj_unref(p);
ast_freetree($2.YYast);
prompt = '\t';
}
;
name : UDEF
;
object : object2
{
/*
* If the luser, say, makes <1 2 <3 ?>>,
* we need to flatten it to ?.
*/
if( had_undef ){
obj_unref($1.YYobj);
$$.YYobj = obj_alloc(T_UNDEF);
had_undef = 0;
}
}
;
object2 : atom
| fpSequence
| '?'
{
$$.YYobj = obj_alloc(T_UNDEF);
had_undef = 1;
}
;
fpSequence
: '<' object2 OptComma SeqBody '>'
{
struct object *p =
$$.YYobj = obj_alloc(T_LIST);
(p->o_val).o_list.car = $2.YYobj;
(p->o_val).o_list.cdr = $4.YYobj;
}
;
SeqBody : Empty
{
$$.YYobj = 0;
}
| object2 OptComma SeqBody
{
struct object *p =
$$.YYobj = obj_alloc(T_LIST);
(p->o_val).o_list.car = $1.YYobj;
(p->o_val).o_list.cdr = $3.YYobj;
}
;
atom : T
{
struct object *p =
$$.YYobj = obj_alloc(T_BOOL);
(p->o_val).o_int = 1;
}
| F
{
struct object *p =
$$.YYobj = obj_alloc(T_BOOL);
(p->o_val).o_int = 0;
}
| '<' '>'
{
struct object *p =
$$.YYobj = obj_alloc(T_LIST);
(p->o_val).o_list.car =
(p->o_val).o_list.cdr = 0;
}
| INT
{
struct object *p =
$$.YYobj = obj_alloc(T_INT);
(p->o_val).o_int = $1.YYint;
}
| FLOAT
{
struct object *p =
$$.YYobj = obj_alloc(T_FLOAT);
(p->o_val).o_double = $1.YYdouble;
}
;
funForm : simpFn
| composition
| construction
| conditional
| constantFn
| insertion
| alpha
| While
| '(' funForm ')'
{
$$ = $2;
}
;
simpFn : IdFns
{
$$.YYast = ast_alloc('i', NULLAST, NULLAST, NULLAST);
(($$.YYast)->val).YYsym = $1.YYsym;
}
| INT
{
$$.YYast = ast_alloc('S', NULLAST, NULLAST, NULLAST);
(($$.YYast)->val).YYint = $1.YYint;
}
| binaryFn
{
$$.YYast = ast_alloc('c', NULLAST, NULLAST, NULLAST);
(($$.YYast)->val).YYint = $1.YYint;
}
| name
{
$$.YYast = ast_alloc('U', NULLAST, NULLAST, NULLAST);
(($$.YYast)->val).YYsym = $1.YYsym;
}
;
IdFns
: TL
| DIV
| HD
| EQ
| ATOM
| PICK
| NOT
| NIL
| REVERSE
| DISTL
| DISTR
| LENGTH
| TRANS
| APNDL
| APNDR
| TLR
| FRONT
| ROTL
| ROTR
| IOTA
| PAIR
| SPLIT
| CONCAT
| LAST
| FIRST
| OUT
| SIN
| COS
| TAN
| ASIN
| ACOS
| ATAN
| LOG
| EXP
| MOD
| OR
| AND
| XOR
| ID
;
binaryFn
: '<'
| '>'
| '='
| GE
| LE
| NE
| '+'
| '-'
| '*'
| '/'
;
composition
: funForm '@' funForm
{
$$.YYast = ast_alloc('@',$1.YYast,NULLAST,$3.YYast);
}
;
construction
: '[' formList ']'
{
$$.YYast = ast_alloc('[',$2.YYast,NULLAST,NULLAST);
}
;
formList
: funForm
{
$$.YYast = ast_alloc('[',$1.YYast,NULLAST,NULLAST);
}
| funForm OptComma formList
{
$$.YYast = ast_alloc('[',$1.YYast,NULLAST,$3.YYast);
}
;
conditional
: '(' funForm '-' '>' funForm ';' funForm ')'
{
$$.YYast = ast_alloc('>',$2.YYast,$5.YYast,$7.YYast);
}
;
constantFn
: '%' object
{
$$.YYast = ast_alloc('%',NULLAST,NULLAST,NULLAST);
(($$.YYast)->val).YYobj = $2.YYobj;
}
;
insertion
: '!' funForm
{
$$.YYast = ast_alloc('!',$2.YYast,NULLAST,NULLAST);
}
| '|' funForm
{
$$.YYast = ast_alloc('|',$2.YYast,NULLAST,NULLAST);
}
;
alpha : '&' funForm
{
$$.YYast = ast_alloc('&',$2.YYast,NULLAST,NULLAST);
}
;
While : '(' WHILE funForm funForm ')'
{
$$.YYast = ast_alloc('W',$3.YYast,NULLAST,$4.YYast);
}
;
Empty : /* Nothing */
;
OptComma /* Optional comma */
: Empty
| ','
;
%%
Funky!Stuff!
cat - << \Funky!Stuff! > primes.fp
#
# Print prime numbers from 3 to ?
#
{factors
&(+@[id %1]@*@[id %2])@iota at div@[id %4]
}
{isprime
|and@&(~=@[id %0])@&mod at distl@[id factors]
}
{primes
concat@&(isprime -> [id] ; %<>)@&(+@[id %1]@*@[id %2])@iota
}
Funky!Stuff!
cat - << \Funky!Stuff! > symtab.c
/*
* Yet another symbol tabler
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "symtab.h"
extern char *strcpy();
/*
* Our hash table
*/
static struct symtab
*stab[SYMTABSIZE];
/*
* Generate a hash value for a string
*/
static
hash(p)
register char *p;
{
register s = 0, c;
while( c = *p++ ) s += c;
return( s % SYMTABSIZE );
}
/*
* Allocate a new entry, fill in the salient fields
*/
static struct symtab *
new_entry(n)
char *n;
{
struct symtab *p = (struct symtab *)malloc(sizeof(struct symtab));
p->sym_type = SYM_NEW;
p->sym_next = 0;
p->sym_val.YYint = 0;
p->sym_pname = malloc((unsigned)(strlen(n)+1));
(void)strcpy(p->sym_pname,n);
return(p);
}
/*
* Given a string, go find the entry. Allocate an entry if there
* was none.
*/
struct symtab *
lookup(name)
char *name;
{
register h;
struct symtab
*p = stab[h = hash(name)],
*old;
/*
* No hash hits, must be a new entry
*/
if( p == 0 ){
return( stab[h] = new_entry(name) );
}
/*
* Had hits, work way down list
*/
while( p ){
if( strcmp(p->sym_pname,name) == 0 ) return(p);
old = p;
p = p->sym_next;
}
/*
* No hits, add to end of chain
*/
return( old->sym_next = new_entry(name) );
}
/*
* Local function to do built-in stuffing
*/
static void
stuff(sym, val)
char *sym;
int val;
{
struct symtab *p = lookup(sym);
if( p->sym_type != SYM_NEW ) fatal_err("Dup init in stuff()");
p->sym_type = SYM_BUILTIN;
p->sym_val.YYint = val;
}
/*
* Fill in symbol table with built-ins
*/
void
symtab_init(){
stuff( "and", AND );
stuff( "or", OR );
stuff( "xor", XOR );
stuff( "sin", SIN );
stuff( "cos", COS );
stuff( "tan", TAN );
stuff( "asin", ASIN );
stuff( "acos", ACOS );
stuff( "atan", ATAN );
stuff( "log", LOG );
stuff( "exp", EXP );
stuff( "mod", MOD );
stuff( "concat", CONCAT );
stuff( "last", LAST );
stuff( "first", FIRST );
stuff( "tl", TL );
stuff( "hd", HD );
stuff( "id", ID );
stuff( "atom", ATOM );
stuff( "eq", EQ );
stuff( "not", NOT );
stuff( "null", NIL );
stuff( "reverse", REVERSE );
stuff( "distl", DISTL );
stuff( "distr", DISTR );
stuff( "length", LENGTH );
stuff( "trans", TRANS );
stuff( "apndl", APNDL );
stuff( "apndr", APNDR );
stuff( "tlr", TLR );
stuff( "front", FRONT );
stuff( "rotl", ROTL );
stuff( "rotr", ROTR );
stuff( "iota", IOTA );
stuff( "pair", PAIR );
stuff( "split", SPLIT );
stuff( "out", OUT );
stuff( "while", WHILE );
stuff( "pick", PICK );
stuff( "div", DIV );
stuff( "T", T );
stuff( "F", F );
}
Funky!Stuff!
cat - << \Funky!Stuff! > symtab.h
/*
* Yet another symbol tabler
*
* Copyright (c) 1986 by Andy Valencia
*/
#include "fp.h"
#include "y.tab.h"
#define SYMTABSIZE 101
/*
* sym_type values
*/
#define SYM_BUILTIN 1 /* A built-in */
#define SYM_DEF 2 /* User-defined */
#define SYM_NEW 3 /* Never seen before! */
Funky!Stuff!
cat - << \Funky!Stuff! > test.fp
#
# Test cases for FP
#
)load blah
)blah
~
+:<1 2>
+:<1.0 2.0>
+:<1>
+:?
+:<>
+:<1 2 3>
-:<1 2>
-:<1.0 2.0>
-:<1>
-:?
*:<1 2>
*:<1.0 2.0>
*:<1>
*:?
mod:<1 2>
mod:<1.0 2.0>
mod:<1>
mod:?
mod:<1 0>
mod:< <1> <2> >
/:<1 2>
/:<1.0 2.0>
/:<1>
/:?
/:<1 0>
/:< <1> <2> >
<:<1 2>
<:<1.0 2.0>
<:<1>
<:<1 T>
<:?
>:<1 2>
>:<1.0 2.0>
>:<1>
>:?
>=:<1 2>
>=:<1.0 2.0>
>=:<1>
>=:?
<=:<1 2>
<=:<1.0 2.0>
<=:<1>
<=:?
eq:<1 2>
eq:<1 1>
eq:<1 T>
eq:<1.0 2.0>
eq:< <1 2> <1 2> >
eq:< <1 2> <1 3> >
eq:?
=:<1 2>
=:<1 1>
=:<1 T>
=:<1.0 2.0>
=:< <1 2> <1 2> >
=:< <1 2> <1 3> >
=:?
~=:<1 2>
~=:<1 1>
~=:< <1 2> <1 2> >
~=:< <1 2> <1 3> >
~=:?
hd:<1 2 3>
hd:1
hd:?
tl:<>
tl:<1>
tl:<1 2>
tl:<1 2 3>
tl:1
tl:?
iota:9
iota:<9>
&id at iota:9
&%1:?
&+:<>
|+ at iota:9
|+:<1>
|+:<>
|-:<>
|=:<>
|+:?
|and:<>
|or:<>
|xor:<>
|/:<>
|/:<1 0 0>
|*:<>
|id:<>
|%7:?
|%7:<>
!+ at iota:9
!+:<1>
!+:<>
!-:<>
!+:?
!=:<>
!and:<>
!or:<>
!xor:<>
!/:<>
!/:<1 2 0>
!*:<>
!id:<>
!%7:<>
!%7:?
&(+@[%1, id])@iota:9
[id, id, +, id]:9
(1 -> 2 ; 3):<T 1 2>
(1 -> 2 ; 3):<F 1 2>
(1 -> 2 ; 3):<? 1 2>
(1 -> 2 ; 3):<1 1 2>
%?:9
9:<1 2 3>
3:<1 2>
&+:< <1 2> <3> <4 5> >
%7:?
hd:<>
tl:<>
iota:-8
%+5:<4>
(while 1 tl ):<T F>
(while 1 tl):<1 F>
(while 1 /@tl ):<T <1 0>>
length:?
length:1
length:<>
length:<1>
length:<1 2>
reverse:?
reverse:<>
reverse:<1>
reverse:<1 2>
first:?
first:<>
first:<1>
first:<1 2>
last:?
last:<>
last:<1>
last:<1 2>
atom:?
atom:1
atom:T
atom:<>
atom:<1>
pick:?
pick:<2 <7 8 9>>
pick:<T <7 8 9>>
pick:<2 T>
pick:<99 <1 2 3>>
pick:<4 <1 2 3>>
pick:<0 <>>
pick:<>
pick:<2>
not:1
not:T
null:<>
null:<1>
null:<1 2>
null:?
reverse:?
reverse:<>
reverse:<1>
reverse:<1 2>
reverse:<1 2 3>
distl:<>
distl:?
distl:<1 <2 3 4>>
distl:<1 2>
distr:<>
distr:?
distr:<<2 3 4> 1>
distr:<1 2>
trans:<>
trans:?
trans:< <1 2 3> <4 5 6> >
trans:< <1 2> <3 4 5> >
trans:< <1 2> T >
trans:< <> <> >
apndl:< T <1 2 3>>
apndl:?
apndl:<<1 2 3> 4>
apndl:<<1 2> <3 4>>
apndl:<1 <>>
apndr:< T <1 2 3>>
apndr:?
apndr:<<1 2 3> 4>
apndr:<<1 2> <3 4>>
apndr:<1 <>>
tlr:?
tlr:<>
tlr:<1>
tlr:<1 2 3>
front:?
front:<>
front:<1>
front:<1 2>
rotl:?
rotl:<>
rotl:<1>
rotl:<1 2 3>
rotr:?
rotr:<>
rotr:<1>
rotr:<1 2 3>
pair:<>
pair:?
pair:<1>
pair:<1 2>
pair:<1 2 3>
split:<>
split:?
split:<1>
split:<1 2>
split:<1 2 3>
concat:?
concat:<>
concat:<<>>
concat:< <> <1> <2> <> >
concat:< <> <1> T <> >
id:?
id:1
out:?
out:1
sin:?
sin:1
cos:?
cos:1
tan:?
tan:1
log:?
log:1
exp:?
exp:1
asin:?
asin:1
acos:?
acos:1
atan:?
atan:1
or:?
or:<1 2>
or:<T 2>
or:<T T>
or:<1 T>
or:< 1 2 3 >
and:?
and:<1 2>
and:<T 2>
and:<T T>
and:<1 T>
and:< 1 2 3 >
xor:?
xor:<1 2>
xor:<T 2>
xor:<T T>
xor:<1 T>
xor:< 1 2 3 >
{a 1}
{a 2}
a:<4 5 6>
{b a at a}
Funky!Stuff!
--
For comp.sources.unix stuff, mail to sources at uunet.uu.net.
More information about the Comp.sources.unix
mailing list