pico.h

A very small LISP implementation with several packages and demo programs.

/* 20dec07abu
 * (c) Software Lab. Alexander Burger
 */

#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <unistd.h>
#include <limits.h>
#include <ctype.h>
#include <string.h>
#include <math.h>
#include <errno.h>
#include <fcntl.h>
#include <dirent.h>
#include <termios.h>
#include <setjmp.h>
#include <signal.h>
#include <dlfcn.h>
#include <time.h>
#include <sys/time.h>
#include <sys/times.h>
#include <sys/stat.h>
#ifndef NOWAIT
#include <sys/wait.h> // tcc doen't like it
#endif

#ifndef __CYGWIN__
#define MAIN main
#else
#define MAIN main2
#endif

#define WORD ((int)sizeof(long))
#define BITS (8*WORD)
#define MASK ((word)-1)
#define CELLS (1024*1024/sizeof(cell)) // Heap allocation unit 1MB
#define HASH  4999                     // Hash table size (should be prime)
#define TOP   0x10000                  // Character Top

typedef unsigned long word;
typedef unsigned char byte;
typedef unsigned char *ptr;
typedef unsigned long long word2;

#undef bool
typedef enum {NO,YES} bool;

typedef struct cell {            // Pico primary data type
   struct cell *car;
   struct cell *cdr;
} cell, *any;

typedef any (*fun)(any);

typedef struct heap {
   cell cells[CELLS];
   struct heap *next;
} heap;

typedef struct child {
   int pid;
   int hear, tell;
   int ofs, cnt;
   byte *buf;
} child;

typedef struct bindFrame {
   struct bindFrame *link;
   int i, cnt;
   struct {any sym; any val;} bnd[1];
} bindFrame;

typedef struct methFrame {
   struct methFrame *link;
   any key, cls;
} methFrame;

typedef struct inFile {
   int fd, ix, cnt, next;
   int line, src;
   char *name;
   byte buf[BUFSIZ];
} inFile;

typedef struct outFile {
   int fd, ix;
   byte buf[BUFSIZ];
} outFile;

typedef struct inFrame {
   struct inFrame *link;
   void (*get)(void);
   pid_t pid;
   int fd;
} inFrame;

typedef struct outFrame {
   struct outFrame *link;
   void (*put)(int);
   pid_t pid;
   int fd;
} outFrame;

typedef struct ctlFrame {
   struct ctlFrame *link;
   int fd;
} ctlFrame;

typedef struct parseFrame {
   any name;
   word dig, eof;
} parseFrame;

typedef struct stkEnv {
   cell *stack, *arg;
   bindFrame *bind;
   methFrame *meth;
   int next, protect, trace;
   any make;
   inFrame *inFiles;
   outFrame *outFiles;
   ctlFrame *ctlFiles;
   parseFrame *parser;
   void (*get)(void);
   void (*put)(int);
   bool brk;
} stkEnv;

typedef struct catchFrame {
   struct catchFrame *link;
   any tag;
   stkEnv env;
   jmp_buf rst;
} catchFrame;

/*** Macros ***/
#define Free(p)         ((p)->car=Avail, Avail=(p))
#define cellPtr(x)      ((any)((word)(x) & ~(2*WORD-1)))

/* Number access */
#define num(x)          ((word)(x))
#define numPtr(x)       ((any)(num(x)+(WORD/2)))
#define numCell(n)      ((any)(num(n)-(WORD/2)))
#define box(n)          (consNum(n,Nil))
#define unDig(x)        num(car(numCell(x)))
#define setDig(x,v)     (car(numCell(x))=(any)(v))
#define isNeg(x)        (unDig(x) & 1)
#define pos(x)          (car(numCell(x)) = (any)(unDig(x) & ~1))
#define neg(x)          (car(numCell(x)) = (any)(unDig(x) ^ 1))
#define lo(w)           num((w)&MASK)
#define hi(w)           num((w)>>BITS)

/* Symbol access */
#define symPtr(x)       ((any)&(x)->cdr)
#define val(x)          ((x)->car)
#define tail(s)         (((s)-1)->cdr)
#define tail1(s)        ((any)(num(tail(s)) & ~1))
#define Tail(s,v)       (tail(s) = (any)(num(v) | num(tail(s)) & 1))
#define ext(x)          ((any)(num(x) | 1))
#define mkExt(s)        (*(word*)&tail(s) |= 1)

/* Cell access */
#define car(x)          ((x)->car)
#define cdr(x)          ((x)->cdr)
#define caar(x)         (car(car(x)))
#define cadr(x)         (car(cdr(x)))
#define cdar(x)         (cdr(car(x)))
#define cddr(x)         (cdr(cdr(x)))
#define caaar(x)        (car(car(car(x))))
#define caadr(x)        (car(car(cdr(x))))
#define cadar(x)        (car(cdr(car(x))))
#define caddr(x)        (car(cdr(cdr(x))))
#define cdaar(x)        (cdr(car(car(x))))
#define cdadr(x)        (cdr(car(cdr(x))))
#define cddar(x)        (cdr(cdr(car(x))))
#define cdddr(x)        (cdr(cdr(cdr(x))))
#define cadddr(x)       (car(cdr(cdr(cdr(x)))))
#define cddddr(x)       (cdr(cdr(cdr(cdr(x)))))

#define data(c)         ((c).car)
#define Save(c)         ((c).cdr=Env.stack, Env.stack=&(c))
#define drop(c)         (Env.stack=(c).cdr)
#define Push(c,x)       (data(c)=(x), Save(c))
#define Tuck(c1,c2,x)   (data(c1)=(x), (c1).cdr=(c2).cdr, (c2).cdr=&(c1))
#define Pop(c)          (drop(c), data(c))

#define Bind(s,f)       ((f).i=0, (f).cnt=1, (f).bnd[0].sym=(s), (f).bnd[0].val=val(s), (f).link=Env.bind, Env.bind=&(f))
#define Unbind(f)       (val((f).bnd[0].sym)=(f).bnd[0].val, Env.bind=(f).link)

/* Predicates */
#define isNil(x)        ((x)==Nil)
#define isNum(x)        (num(x)&(WORD/2))
#define isSym(x)        (num(x)&WORD)
#define isCell(x)       (!(num(x)&(2*WORD-2)))
#define isExt(s)        (num(tail(s))&1)
#define IsZero(n)       (!unDig(n) && !isNum(cdr(numCell(n))))

/* Evaluation */
#define EVAL(x)         (isNum(x)? x : isSym(x)? val(x) : evList(x))
#define evSubr(f,x)     (*(fun)unDig(f))(x)

/* Error checking */
#define NeedNum(ex,x)   if (!isNum(x)) numError(ex,x)
#define NeedCnt(ex,x)   if (!isNum(x) || isNum(cdr(numCell(x)))) cntError(ex,x)
#define NeedSym(ex,x)   if (!isSym(x)) symError(ex,x)
#define NeedExt(ex,x)   if (!isSym(x) || !isExt(x)) extError(ex,x)
#define NeedCell(ex,x)  if (!isCell(x)) cellError(ex,x)
#define NeedAtom(ex,x)  if (isCell(x)) atomError(ex,x)
#define NeedLst(ex,x)   if (!isCell(x) && !isNil(x)) lstError(ex,x)
#define NeedVar(ex,x)   if (isNum(x)) varError(ex,x)
#define CheckNil(ex,x)  if (isNil(x)) protError(ex,x)
#define CheckVar(ex,x)  if ((x)>=Nil && (x)<=T) protError(ex,x)

/* External symbol access */
#define Fetch(ex,x)     if (isExt(x)) db(ex,x,1)
#define Touch(ex,x)     if (isExt(x)) db(ex,x,2)

/* Globals */
extern int Signal, Chr, Next0, Spkr, Mic, Slot, Hear, Tell, Children;
extern char **AV, *Home;
extern child *Child;
extern heap *Heaps;
extern cell *Avail;
extern stkEnv Env;
extern catchFrame *CatchPtr;
extern struct termios *Termio;
extern FILE *StdOut;
extern int InFDs, OutFDs;
extern inFile *InFile, **InFiles;
extern outFile *OutFile, **OutFiles;
extern int (*getBin)(void);
extern void (*putBin)(int);
extern any TheKey, TheCls;
extern any Alarm, Line, Zero, One, Intern[HASH], Transient[HASH], Extern[HASH];
extern any ApplyArgs, ApplyBody, DbVal, DbTail;
extern any Nil, DB, Meth, Quote, T;
extern any Solo, PPid, Pid, At, At2, At3, This, Dbg, Zap, Scl, Class;
extern any Run, Hup, Sig1, Sig2, Up, Err, Rst, Msg, Uni, Led, Adr, Fork, Bye;

/* Prototypes */
void *alloc(void*,size_t);
any apply(any,any,bool,int,cell*);
void argError(any,any) __attribute__ ((noreturn));
void atomError(any,any) __attribute__ ((noreturn));
void begString(void);
void bigAdd(any,any);
int bigCompare(any,any);
any bigCopy(any);
void bigSub(any,any);
void binPrint(any);
any binRead(void);
word2 blk64(any);
void blocking(bool,any,int);
any boxChar(int,int*,any*);
any boxWord2(word2);
void brkLoad(any);
int bufSize(any);
void bufString(any,char*);
void bye(int) __attribute__ ((noreturn));
void byteSym(int,int*,any*);
void cellError(any,any) __attribute__ ((noreturn));
void charSym(int,int*,any*);
void closeInFile(int);
void closeOutFile(int);
void cntError(any,any) __attribute__ ((noreturn));
int compare(any,any);
any cons(any,any);
any consNum(word,any);
any consStr(any);
any consSym(any,any);
void crlf(void);
void ctOpen(any,any,ctlFrame*);
void db(any,any,int);
int dbSize(any,any);
void digAdd(any,word);
void digDiv2(any);
void digMul2(any);
void digSub1(any);
any doubleToNum(double);
any endString(void);
bool equal(any,any);
void err(any,any,char*,...) __attribute__ ((noreturn));
any evExpr(any,any);
long evCnt(any,any);
double evDouble(any,any);
any evList(any);
any evSym(any);
void execError(char*) __attribute__ ((noreturn));
void extError(any,any) __attribute__ ((noreturn));
any findHash(any,any*);
int firstByte(any);
bool flush(outFile*);
pid_t forkLisp(any);
any get(any,any);
int getChar(void);
void getStdin(void);
void giveup(char*) __attribute__ ((noreturn));
unsigned long hash(any);
bool hashed(any,long,any*);
void heapAlloc(void);
void initInFile(int,char*);
void initOutFile(int);
void initSymbols(void);
any intern(char*);
bool isBlank(any);
bool isLife(any);
void lstError(any,any) __attribute__ ((noreturn));
any load(any,int,any);
any method(any);
any mkChar(int);
any mkDat(int,int,int);
any mkName(char*);
any mkStr(char*);
any name(any);
any new64(word2,any);
any newId(int);
int numBytes(any);
void numError(any,any) __attribute__ ((noreturn));
double numToDouble(any);
any numToSym(any,int,int,int);
void outName(any);
void outString(char*);
void outWord(word);
void pack(any,int*,any*,cell*);
int pathSize(any);
void pathString(any,char*);
void pipeError(any,char*);
void popCtlFiles(void);
void popInFiles(void);
void popOutFiles(void);
void pr(any);
void prin(any);
void print(any);
void prn(long);
void protError(any,any) __attribute__ ((noreturn));
void pushInFiles(inFrame*);
void pushOutFiles(outFrame*);
void pushCtlFiles(ctlFrame*);
any put(any,any,any);
void putStdout(int);
void rdOpen(any,any,inFrame*);
any read1(int);
bool rdBytes(int,byte*,int);
int secondByte(any);
void setCooked(void);
void setRaw(void);
void sighandler(any);
int slow(int,byte*,int);
void space(void);
int symByte(any);
int symChar(any);
void symError(any,any) __attribute__ ((noreturn));
any symToNum(any,int,int,int);
word2 unBoxWord2(any);
void undefined(any,any);
void unwind (catchFrame*);
void varError(any,any) __attribute__ ((noreturn));
long waitFd(any,int,long);
bool wrBytes(int,byte*,int);
void wrOpen(any,any,outFrame*);
long xCnt(any,any);
any xSym(any);
void zapZero(any);

any doAbs(any);
any doAccept(any);
any doAdd(any);
any doAlarm(any);
any doAll(any);
any doAnd(any);
any doAny(any);
any doAppend(any);
any doApply(any);
any doArg(any);
any doArgs(any);
any doArgv(any);
any doAsoq(any);
any doAs(any);
any doAssoc(any);
any doAt(any);
any doAtom(any);
any doBegin(any);
any doBind(any);
any doBitAnd(any);
any doBitOr(any);
any doBitQ(any);
any doBitXor(any);
any doBool(any);
any doBox(any);
any doBoxQ(any);
any doBreak(any);
any doBy(any);
any doBye(any) __attribute__ ((noreturn));
any doCaaar(any);
any doCaadr(any);
any doCaar(any);
any doCadar(any);
any doCadddr(any);
any doCaddr(any);
any doCadr(any);
any doCall(any);