main.c

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

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

#include "pico.h"

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

static int TtyPid;
static word2 USec;
static struct timeval Tv;
static bool Jam;
static struct termios RawTermio;
static jmp_buf ErrRst;
static void finish(int) __attribute__ ((noreturn));


/*** System ***/
static void finish(int n) {
   setCooked();
   exit(n);
}

void giveup(char *msg) {
   fprintf(stderr, "%d %s\n", (int)getpid(), msg);
   finish(1);
}

void bye(int n) {
   static bool b;

   if (!b) {
      b = YES;
      unwind(NULL);
      prog(val(Bye));
   }
   finish(n);
}

void execError(char *s) {
   fprintf(stderr, "%s: can't exec\n", s);
   exit(127);
}

/* Install interrupting signal */
static void iSignal(int n, void (*foo)(int)) {
   struct sigaction act, old;

   act.sa_handler = foo;
   sigemptyset (&act.sa_mask);
   act.sa_flags = 0;
   if (sigaction(n, &act, &old) < 0)
      giveup("Bad signal handler");
}

/* Signal handler */
void sighandler(any ex) {
   int i;

   if (!Env.protect) {
      switch (Signal) {
      case SIGINT:
         Signal = 0,  brkLoad(ex);
         break;
      case SIGUSR1:
         Signal = 0,  run(val(Sig1));
         break;
      case SIGUSR2:
         Signal = 0,  run(val(Sig2));
         break;
      case SIGALRM:
         Signal = 0,  run(Alarm);
         break;
      case SIGHUP:
         if (!isNil(val(Hup))) {
            Signal = 0,  run(val(Hup));
            break;
         }
      case SIGTERM:
         for (i = 0; i < Children; ++i)
            if (Child[i].pid)
               return;
         Signal = 0,  bye(0);
      }
   }
}

static void doSigTerm(int n) {
   if (TtyPid)
      kill(TtyPid, n);
   else
      Signal = SIGTERM;
}

static void doSignal(int n) {
   if (TtyPid)
      kill(TtyPid, n);
   else
      Signal = n;
}

static void doSigChld(int n __attribute__((unused))) {
   pid_t pid;
   int stat;

   while ((pid = waitpid(0, &stat, WNOHANG)) > 0)
      if (WIFSIGNALED(stat))
         fprintf(stderr, "%d SIG-%d\n", (int)pid, WTERMSIG(stat));
}

static void doTermStop(int n __attribute__((unused))) {
   sigset_t mask;

   tcsetattr(STDIN_FILENO, TCSADRAIN, Termio);
   sigemptyset(&mask);
   sigaddset(&mask, SIGTSTP);
   sigprocmask(SIG_UNBLOCK, &mask, NULL);
   signal(SIGTSTP, SIG_DFL),  raise(SIGTSTP),  signal(SIGTSTP, doTermStop);
   tcsetattr(STDIN_FILENO, TCSADRAIN, &RawTermio);
}

void setRaw(void) {
   if (!Termio  &&  tcgetattr(STDIN_FILENO, &RawTermio) == 0) {
      *(Termio = malloc(sizeof(struct termios))) = RawTermio;
      RawTermio.c_iflag = 0;
      RawTermio.c_lflag = ISIG;
      RawTermio.c_cc[VMIN] = 1;
      RawTermio.c_cc[VTIME] = 0;
      tcsetattr(STDIN_FILENO, TCSADRAIN, &RawTermio);
      if (signal(SIGTSTP,SIG_IGN) == SIG_DFL)
         signal(SIGTSTP, doTermStop);
   }
}

void setCooked(void) {
   if (Termio)
      tcsetattr(STDIN_FILENO, TCSADRAIN, Termio);
   Termio = NULL;
}

// (raw ['flg]) -> flg
any doRaw(any x) {
   if (!isCell(x = cdr(x)))
      return Termio? T : Nil;
   if (isNil(EVAL(car(x)))) {
      setCooked();
      return Nil;
   }
   setRaw();
   return T;
}

// (alarm 'cnt . prg) -> cnt
any doAlarm(any x) {
   int n = alarm((int)evCnt(x,cdr(x)));
   Alarm = cddr(x);
   return boxCnt(n);
}

// (protect . prg) -> any
any doProtect(any x) {
   ++Env.protect;
   x = prog(cdr(x));
   --Env.protect;
   return x;
}

/* Allocate memory */
void *alloc(void *p, size_t siz) {
   if (!(p = realloc(p,siz)))
      giveup("No memory");
   return p;
}

/* Allocate cell heap */
void heapAlloc(void) {
   heap *h;
   cell *p;

   h = (heap*)((long)alloc(NULL,
      sizeof(heap) + sizeof(cell)) + (sizeof(cell)-1) & ~(sizeof(cell)-1) );
   h->next = Heaps,  Heaps = h;
   p = h->cells + CELLS-1;
   do
      Free(p);
   while (--p >= h->cells);
}

// (heap 'flg) -> cnt
any doHeap(any x) {
   long n = 0;

   x = cdr(x);
   if (isNil(EVAL(car(x)))) {
      heap *h = Heaps;
      do
         ++n;
      while (h = h->next);
      return boxCnt(n);
   }
   for (x = Avail;  x;  x = car(x))
      ++n;
   return boxCnt(n / CELLS);
}

// (env ['lst] | ['sym 'val] ..) -> lst
any doEnv(any x) {
   int i;
   bindFrame *p;
   cell c1, c2;

   Push(c1, Nil);
   if (!isCell(x = cdr(x))) {
      for (p = Env.bind;  p;  p = p->link) {
         if (p->i == 0) {
            for (i = p->cnt;  --i >= 0;) {
               for (x = data(c1); ; x = cdr(x)) {
                  if (!isCell(x)) {
                     data(c1) = cons(cons(p->bnd[i].sym, val(p->bnd[i].sym)), data(c1));
                     break;
                  }
                  if (caar(x) == p->bnd[i].sym)
                     break;
               }
            }
         }
      }
   }
   else {
      do {
         Push(c2, EVAL(car(x)));
         if (isCell(data(c2))) {
            do
               data(c1) = cons(cons(car(data(c2)), val(car(data(c2)))), data(c1));
            while (isCell(data(c2) = cdr(data(c2))));
         }
         else if (!isNil(data(c2))) {
            x = cdr(x);
            data(c1) = cons(cons(data(c2), EVAL(car(x))), data(c1));
         }
         drop(c2);
      }
      while (isCell(x = cdr(x)));
   }
   return Pop(c1);
}

// (up [cnt] sym ['val]) -> any
any doUp(any x) {
   any y, *val;
   int cnt, i;
   bindFrame *p;

   x = cdr(x);
   if (!isNum(y = car(x)))
      cnt = 1;
   else
      cnt = (int)unBox(y),  x = cdr(x),  y = car(x);
   for (p = Env.bind, val = &val(y);  p;  p = p->link) {
      if (p->i <= 0) {
         for (i = 0;  i < p->cnt;  ++i)
            if (p->bnd[i].sym == y) {
               if (!--cnt) {
                  if (isCell(x = cdr(x)))
                     return p->bnd[i].val = EVAL(car(x));
                  return p->bnd[i].val;
               }
               val = &p->bnd[i].val;
               break;
            }
      }
   }
   if (isCell(x = cdr(x)))
      return *val = EVAL(car(x));
   return *val;
}

// (stk any ..) -> T
any doStk(any x) {
   any p;
   outFile *oSave = OutFile;
   FILE *stdSave = StdOut;

   OutFile = NULL,  StdOut = stderr;
   print(cdr(x)), crlf();
   for (p = Env.stack; p; p = cdr(p)) {
      fprintf(stderr, "%lX ", num(p)),  fflush(stderr);
      print(car(p)), crlf();
   }
   crlf();
   OutFile = oSave,  StdOut = stdSave;
   return T;
}

/*** Primitives ***/
/* Comparisons */
bool equal(any x, any y) {
   for (;;) {
      if (x == y)
         return YES;
      if (isNum(x)) {
         if (!isNum(y)  ||  unDig(x) != unDig(y))
            return NO;
         x = cdr(numCell(x)),  y = cdr(numCell(y));
      }
      else if (isSym(x)) {
         if (!isSym(y)  || !isNum(x = name(x))  ||  !isNum(y = name(y)))
            return NO;
      }
      else {
         any a, b;

         if (!isCell(y))
            return NO;
         while (car(x) == Quote) {
            if (car(y) != Quote)
               return NO;
            if (x == cdr(x))
               return y == cdr(y);
            if (y == cdr(y))
               return NO;
            if (!isCell(x = cdr(x)))
               return equal(x, cdr(y));
            if (!isCell(y = cdr(y)))
               return NO;
         }
         a = x, b = y;
         for (;;) {
            if (!equal(car(x), car(y)))
               return NO;
            if (!isCell(x = cdr(x)))
               return equal(x, cdr(y));
            if (!isCell(y = cdr(y)))
               return NO;
            if (x == a && y == b)
               return YES;
         }
      }
   }
}

int compare(any x, any y) {
   any a, b;

   if (x == y)
      return 0;
   if (isNil(x))
      return -1;
   if (x == T)
      return +1;
   if (isNum(x)) {
      if (!isNum(y))
         return isNil(y)? +1 : -1;
      return bigCompare(x,y);
   }
   if (isSym(x)) {
      int b1, b2;
      word n1, n2;

      if (isNum(y) || isNil(y))
         return +1;
      if (isCell(y) || y == T)
         return -1;
      if (!isNum(a = name(x)))
         return !isNum(name(y))? 1664525*(int32_t)(long)x - 1664525*(int32_t)(long)y : -1;
      if (!isNum(b = name(y)))
         return +1;
      n1 = unDig(a), n2 = unDig(b);
      for (;;) {
         if ((b1 = n1 & 0xFF) != (b2 = n2 & 0xFF))
            return b1 - b2;
         if ((n1 >>= 8) == 0) {
            if ((n2 >>= 8) != 0)
               return -1;
            if (!isNum(a = cdr(numCell(a))))
               return !isNum(b = cdr(numCell(b)))? 0 : -1;
            if (!isNum(b = cdr(numCell(b))))
               return +1;
            n1 = unDig(a), n2 = unDig(b);
         }
         else if ((n2 >>= 8) == 0)
            return +1;
      }
   }
   if (!isCell(y))
      return y == T? -1 : +1;
   a = x, b = y;
   for (;;) {
      int n;

      if (n = compare(car(x),car(y)))
         return n;
      if (!isCell(x = cdr(x)))
         return compare(x, cdr(y));
      if (!isCell(y = cdr(y)))
         return y == T? -1 : +1;
      if (x == a && y == b)
         return 0;
   }
}

/*** Error handling ***/
static void reset(void) {
   Env.protect = 0;
   unwind(NULL);
   Env.stack = NULL;
   Env.meth = NULL;
   Env.next = -1;
   Env.make = NULL;
   Env.parser = NULL;
   Env.trace = 0;
}

void err(any ex, any x, char *fmt, ...) {
   va_list ap;
   char msg[240];
   outFrame f;

   Chr = 0;
   Env.brk = NO;
   Alarm = Line = Nil;
   f.pid = -1,  f.fd = 2,  pushOutFiles(&f);
   while (*AV  &&  strcmp(*AV,"-") != 0)
      ++AV;
   if (InFile && InFile->name)
      fprintf(stderr, "[%s:%d] ", InFile->name, InFile->src);
   if (ex)
      outString("!? "), print(val(Up) = ex), crlf();
   if (x)
      print(x), outString(" -- ");
   va_start(ap,fmt);
   vsnprintf(msg, sizeof(msg), fmt, ap);
   va_end(ap);
   if (msg[0]) {
      outString(msg), crlf();
      val(Msg) = mkStr(msg);
      if (!isNil(val(Err)) && !Jam)
         Jam = YES,  prog(val(Err)),  Jam = NO;
      if (!isNil(val(Rst)))
         reset(),  longjmp(ErrRst, -1);
      if (!isatty(STDIN_FILENO) || !isatty(STDOUT_FILENO))
         bye(1);
      load(NULL, '?', Nil);
   }
   reset();
   StdOut = stdout;
   longjmp(ErrRst, +1);
}

// (quit ['any ['any]])
any doQuit(any x) {
   cell c1;

   x = cdr(x),  Push(c1, evSym(x));
   x = isCell(x = cdr(x))?  EVAL(car(x)) : NULL;
   {
      char msg[bufSize(data(c1))];

      bufString(data(c1), msg);
      drop(c1);
      err(NULL, x, "%s", msg);
   }
}

void argError(any ex, any x) {err(ex, x, "Bad argument");}
void numError(any ex, any x) {err(ex, x, "Number expected");}
void cntError(any ex, any x) {err(ex, x, "Small number expected");}
void symError(any ex, any x) {err(ex, x, "Symbol expected");}
void extError(any ex, any x) {err(ex, x, "External symbol expected");}
void cellError(any ex, any x) {err(ex, x, "Cell expected");}
void atomError(any ex, any x) {err(ex, x, "Atom expected");}
void lstError(any ex, any x) {err(ex, x, "List expected");}
void varError(any ex, any x) {err(ex, x, "Variable expected");}
void protError(any ex, any x) {err(ex, x, "Protected symbol");}

void pipeError(any ex, char *s) {err(ex, NULL, "Pipe %s error", s);}

void unwind(catchFrame *p) {
   int i;
   catchFrame *q;
   cell c1;