sym.c

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

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

#include "pico.h"

/* ELF hash algorithm */
unsigned long hash(any x) {
   unsigned long g, h;
   word n;

   for (h = 0; isNum(x); x = cdr(numCell(x)))
      for (n = unDig(x); n; n >>= 8)
         g = (h = (h<<4) + (n&0xFF)) & 0xF0000000,  h = (h ^ g>>24) & ~g;
   return h % HASH;
}

bool hashed(any s, long h, any *tab) {
   any x;

   for (x = tab[h];  isCell(x);  x = cdr(x))
      if (s == car(x))
         return YES;
   return NO;
}

any findHash(any s, any *p) {
   any x, y, *q, h;

   if (isCell(h = *p)) {
      x = s,  y = name(car(h));
      while (unDig(x) == unDig(y)) {
         x = cdr(numCell(x));
         y = cdr(numCell(y));
         if (!isNum(x) && !isNum(y))
            return car(h);
      }
      while (isCell(h = *(q = &cdr(h)))) {
         x = s,  y = name(car(h));
         while (unDig(x) == unDig(y)) {
            x = cdr(numCell(x));
            y = cdr(numCell(y));
            if (!isNum(x) && !isNum(y)) {
               *q = cdr(h),  cdr(h) = *p,  *p = h;
               return car(h);
            }
         }
      }
   }
   return NULL;
}

/* Get symbol name */
any name(any s) {
   for (s = tail1(s); isCell(s); s = cdr(s));
   return s;
}

// (name 'sym ['sym2]) -> sym
any doName(any ex) {
   any x, y, *p;
   cell c1;

   x = cdr(ex),  data(c1) = EVAL(car(x));
   NeedSym(ex,data(c1));
   y = name(data(c1));
   if (!isCell(x = cdr(x)))
      return isNum(y)? consStr(y) : Nil;
   if (isNil(data(c1)) || isExt(data(c1)) || hashed(data(c1), hash(y), Intern))
      err(ex, data(c1), "Can't rename");
   Save(c1);
   x = EVAL(car(x));
   NeedSym(ex,x);
   for (p = &tail(data(c1)); isCell(*p); p = &cdr(*p));
   *p = name(x);
   return Pop(c1);
}

/* Find or create single-char symbol */
any mkChar(int c) {
   any x;

   if (c == TOP)
      c = 0xFF;
   else if (c >= 0x80) {
      if (c < 0x800)
         c = 0xC0 | c>>6 & 0x1F  |  (0x80 | c & 0x3F) << 8;
      else
         c = 0xE0 | c>>12 & 0x0F  |  (0x80 | c>>6 & 0x3F) << 8  |  (0x80 | c & 0x3F) << 16;
      return consStr(box(c));
   }
   for (x = Transient[c];  isCell(x);  x = cdr(x))
      if (num(c) == unDig(name(car(x))))
         return car(x);
   x = consStr(box(c));
   Transient[c] = cons(x, Transient[c]);
   return x;
}

/* Make name */
any mkName(char *s) {
   int i;
   any nm;
   cell c1;

   i = 0,  Push(c1, nm = box(*(byte*)s++));
   while (*s)
      byteSym(*(byte*)s++, &i, &nm);
   return Pop(c1);
}

any intern(char *s) {
   any nm, x, *h;

   if (!*s)
      return Nil;
   nm = mkName(s);
   if (x = findHash(nm, h = Intern + hash(nm)))
      return x;
   *h = cons(x = consStr(nm), *h);
   return x;
}

/* Make string */
any mkStr(char *s) {return s && *s? consStr(mkName(s)) : Nil;}

/* Get first byte of symbol name */
int firstByte(any s) {
   return !isNum(s = name(s))? 0 : unDig(s) & 0xFF;
}

int secondByte(any s) {
   return !isNum(s = name(s))? 0 : unDig(s) >> 8 & 0xFF;
}

bool isBlank(any x) {
   int c;

   if (!isSym(x))
      return NO;
   for (c = symChar(name(x)); c; c = symChar(NULL))
      if (c > ' ')
         return NO;
   return YES;
}

// (sp? 'any) -> flg
any doSpQ(any x) {
   x = cdr(x);
   return isBlank(EVAL(car(x)))? T : Nil;
}

// (pat? 'any) -> sym | NIL
any doPatQ(any x) {
   x = cdr(x);
   return isSym(x = EVAL(car(x))) && firstByte(x) == '@'? x : Nil;
}

// (fun? 'any) -> any
any doFunQ(any x) {
   any y;

   x = cdr(x);
   if (isSym(x = EVAL(car(x))))
      return Nil;
   if (isNum(x))
      return (unDig(x)&3) || isNum(cdr(numCell(x)))? Nil : x;
   for (y = cdr(x); isCell(y) && y != x; y = cdr(y)) {
      if (isCell(car(y))) {
         if (isCell(cdr(y)) && isNum(caar(y)))
            return Nil;
         if (isNil(caar(y)) || caar(y) == T)
            return Nil;
      }
      else if (!isNil(cdr(y)))
         return Nil;
   }
   if (!isNil(y))
      return Nil;
   if (isNil(x = car(x)))
      return T;
   for (y = x; isCell(y);)
      if (isNum(car(y)) || isCell(car(y)) || isNil(car(y)) || car(y)==T || x==(y=cdr(y)))
         return Nil;
   return isNum(y) || y==T? Nil : x;
}

// (all ['T | 0]) -> lst
any doAll(any x) {
   any *p;
   int i;
   cell c1;

   x = cdr(x),  x = EVAL(car(x));
   p = isNil(x)? Intern : x==T? Transient : Extern;
   Push(c1, Nil);
   for (i = 0; i < HASH; ++i)
      for (x = p[i]; isCell(x); x = cdr(x))
         data(c1) = cons(car(x), data(c1));
   return Pop(c1);
}

// (intern 'sym) -> sym
any doIntern(any ex) {
   any x, y, z, *h;

   x = cdr(ex),  x = EVAL(car(x));
   NeedSym(ex,x);
   if (!isNum(y = name(x)))
      return Nil;
   if (z = findHash(y, h = Intern + hash(y)))
      return z;
   *h = cons(x,*h);
   return x;
}

// (extern 'sym) -> sym | NIL
any doExtern(any ex) {
   int c, i;
   any x, y, *h, nm;
   cell c1, c2;

   x = cdr(ex),  x = EVAL(car(x));
   NeedSym(ex,x);
   if (!isNum(x = name(x)))
      return Nil;
   if (!(y = findHash(x, Extern + hash(x)))) {
      Push(c1, x);
      if ((c = symChar(x)) == '{')
         c = symChar(NULL);
      Push(c2, boxChar(c, &i, &nm));
      while ((c = symChar(NULL)) && c != '}')
         charSym(c, &i, &nm);
      if (!(y = findHash(data(c2), h = Extern + hash(data(c2))))) {
         mkExt(y = consSym(Nil,data(c2)));
         *h = cons(y,*h);
      }
      drop(c1);
   }
   return isLife(y)? y : Nil;
}

// (==== ['sym ..]) -> NIL
any doHide(any ex) {
   any x, y, z, *h;
   int i;

   for (i = 0; i < HASH; ++i)
      Transient[i] = Nil;
   for (x = cdr(ex); isCell(x); x = cdr(x)) {
      y = EVAL(car(x));
      NeedSym(ex,y);
      if (isNum(z = name(y)) && !findHash(z, h = Transient + hash(z)))
         *h = cons(y,*h);
   }
   return Nil;
}

// (box? 'any) -> sym | NIL
any doBoxQ(any x) {
   x = cdr(x);
   return isSym(x = EVAL(car(x))) && !isNum(name(x))? x : Nil;
}

// (str? 'any) -> sym | NIL
any doStrQ(any x) {
   x = cdr(x);
   return isSym(x = EVAL(car(x))) &&
         !isExt(x) && !hashed(x,hash(name(x)),Intern)? x : Nil;
}

// (ext? 'any) -> sym | NIL
any doExtQ(any x) {
   x = cdr(x);
   return isSym(x = EVAL(car(x))) && isExt(x) && isLife(x) ? x : Nil;
}

// (touch 'sym) -> sym
any doTouch(any ex) {
   any x = cdr(ex);
   x = EVAL(car(x));
   NeedSym(ex,x);
   Touch(ex,x);
   return x;
}

// (zap 'sym) -> sym
any doZap(any ex) {
   any x, y, *h;

   x = cdr(ex),  x = EVAL(car(x));
   NeedSym(ex,x);
   if (isExt(x))
      db(ex,x,3);
   else {
      if (x >= Nil  &&  x <= Bye)
         protError(ex,x);
      for (h = Intern + hash(name(x)); isCell(y = *h); h = &y->cdr)
         if (x == car(y)) {
            *h = cdr(y);
            break;
         }
   }
   return x;
}

// (chop 'any) -> lst
any doChop(any x) {
   int c;
   cell c1, c2;

   if (isCell(x = EVAL(cadr(x))))
      return x;
   if (!(c = symChar(name(x = xSym(x)))))
      return Nil;
   Push(c1, x);
   Push(c2, x = cons(mkChar(c), Nil));
   while (c = symChar(NULL))
      x = cdr(x) = cons(mkChar(c), Nil);
   drop(c1);
   return data(c2);
}

void pack(any x, int *i, any *nm, cell *p) {
   int c;
   cell c1;

   if (isCell(x))
      do