rsalz@bbn.com (Rich Salz) (02/05/88)
Submitted-by: Andy Valencia <vandys@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@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@lindy.stanford.edu br.ajv@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@grpleft [1] bsort@grpright]@[arb id] ; id) } Funky!Stuff! cat - << \Funky!Stuff! > bubsort.fp {swap concat@[ [2,1],tl@tl ]} {step (>@[1,2] -> swap ; id) } {pass (<@[length,%2] -> id ; apndl@[1,pass@tl]@step) } {bubsort (<@[length,%2] -> id ; apndr@[bubsort@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@div@[id %4] } {isprime |and@&(~=@[id %0])@&mod@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@iota:9 &%1:? &+:<> |+@iota:9 |+:<1> |+:<> |-:<> |=:<> |+:? |and:<> |or:<> |xor:<> |/:<> |/:<1 0 0> |*:<> |id:<> |%7:? |%7:<> !+@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@a} Funky!Stuff! -- For comp.sources.unix stuff, mail to sources@uunet.uu.net.