main.c

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

   while (CatchPtr) {
      q = CatchPtr,  CatchPtr = CatchPtr->link;
      while (Env.bind != q->env.bind) {
         if (Env.bind->i == 0)
            for (i = Env.bind->cnt;  --i >= 0;)
               val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val;
         Env.bind = Env.bind->link;
      }
      while (Env.inFiles != q->env.inFiles)
         popInFiles();
      while (Env.outFiles != q->env.outFiles)
         popOutFiles();
      while (Env.ctlFiles != q->env.ctlFiles)
         popCtlFiles();
      Env = q->env;
      if (q == p)
         return;
      if (!isSym(q->tag)) {
         Push(c1, q->tag);
         EVAL(data(c1));
         drop(c1);
      }
   }
   while (Env.bind) {
      if (Env.bind->i == 0)
         for (i = Env.bind->cnt;  --i >= 0;)
            val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val;
      Env.bind = Env.bind->link;
   }
   while (Env.inFiles)
      popInFiles();
   while (Env.outFiles)
      popOutFiles();
   while (Env.ctlFiles)
      popCtlFiles();
}

/*** Evaluation ***/
any evExpr(any expr, any x) {
   any y = car(expr);
   struct {  // bindFrame
      struct bindFrame *link;
      int i, cnt;
      struct {any sym; any val;} bnd[length(y)+2];
   } f;

   f.link = Env.bind,  Env.bind = (bindFrame*)&f;
   f.i = sizeof(f.bnd) / (2*sizeof(any)) - 1;
   f.cnt = 1,  f.bnd[0].sym = At,  f.bnd[0].val = val(At);
   while (isCell(y)) {
      f.bnd[f.cnt].sym = car(y);
      f.bnd[f.cnt].val = EVAL(car(x));
      ++f.cnt, x = cdr(x), y = cdr(y);
   }
   if (isNil(y)) {
      while (--f.i > 0) {
         x = val(f.bnd[f.i].sym);
         val(f.bnd[f.i].sym) = f.bnd[f.i].val;
         f.bnd[f.i].val = x;
      }
      x = prog(cdr(expr));
   }
   else if (y != At) {
      f.bnd[f.cnt].sym = y,  f.bnd[f.cnt++].val = val(y),  val(y) = x;
      while (--f.i > 0) {
         x = val(f.bnd[f.i].sym);
         val(f.bnd[f.i].sym) = f.bnd[f.i].val;
         f.bnd[f.i].val = x;
      }
      x = prog(cdr(expr));
   }
   else {
      int n, cnt;
      cell *arg;
      cell c[n = cnt = length(x)];

      while (--n >= 0)
         Push(c[n], EVAL(car(x))),  x = cdr(x);
      while (--f.i > 0) {
         x = val(f.bnd[f.i].sym);
         val(f.bnd[f.i].sym) = f.bnd[f.i].val;
         f.bnd[f.i].val = x;
      }
      n = Env.next,  Env.next = cnt;
      arg = Env.arg,  Env.arg = c;
      x = prog(cdr(expr));
      if (cnt)
         drop(c[cnt-1]);
      Env.arg = arg,  Env.next = n;
   }
   while (--f.cnt >= 0)
      val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
   Env.bind = f.link;
   return x;
}

void undefined(any x, any ex) {
   void *h;
   char *p, nm[bufSize(x)];

   bufString(x, nm);
   if (!(p = strchr(nm,':'))  ||  p == nm  ||  p[1] == '\0')
      err(ex, x, "Undefined");
   *p++ = '\0';
   {
      int n = Home? strlen(Home) : 0;
      char buf[n + strlen(nm) + 4 + 1];

      if (strchr(nm,'/'))
         strcpy(buf, nm);
      else {
         if (n)
            memcpy(buf, Home, n);
         strcpy(buf + n, "lib/"),  strcpy(buf + n + 4, nm);
      }
      if (!(h = dlopen(buf, RTLD_LAZY | RTLD_GLOBAL))  ||  !(h = dlsym(h,p)))
         err(ex, x, "%s", (char*)dlerror());
      val(x) = box(num(h));
   }
}

/* Evaluate a list */
any evList(any ex) {
   any foo;

   if (!isSym(foo = car(ex))) {
      if (isNum(foo))
         return ex;
      if (Signal)
         sighandler(ex);
      if (isNum(foo = evList(foo)))
         return evSubr(foo,ex);
      if (isCell(foo))
         return evExpr(foo, cdr(ex));
   }
   for (;;) {
      if (isNil(val(foo)))
         undefined(foo,ex);
      if (Signal)
         sighandler(ex);
      if (isNum(foo = val(foo)))
         return evSubr(foo,ex);
      if (isCell(foo))
         return evExpr(foo, cdr(ex));
   }
}

/* Evaluate any to sym */
any evSym(any x) {return xSym(EVAL(car(x)));}

any xSym(any x) {
   int i;
   any nm;
   cell c1, c2;

   if (isSym(x))
      return x;
   Push(c1,x);
   nm = NULL,  pack(x, &i, &nm, &c2);
   drop(c1);
   return nm? consStr(data(c2)) : Nil;
}

/* Evaluate count */
long evCnt(any ex, any x) {return xCnt(ex, EVAL(car(x)));}

long xCnt(any ex, any x) {
   NeedCnt(ex,x);
   return unBox(x);
}

/* Evaluate double */
double evDouble(any ex, any x) {
   x = EVAL(car(x));
   NeedNum(ex,x);
   return numToDouble(x);
}

// (args) -> flg
any doArgs(any ex __attribute__((unused))) {
   return Env.next > 0? T : Nil;
}

// (next) -> any
any doNext(any ex __attribute__((unused))) {
   if (Env.next > 0)
      return data(Env.arg[--Env.next]);
   if (Env.next == 0)
      Env.next = -1;
   return Nil;
}

// (arg ['cnt]) -> any
any doArg(any ex) {
   long n;

   if (Env.next < 0)
      return Nil;
   if (!isCell(cdr(ex)))
      return data(Env.arg[Env.next]);
   if ((n = evCnt(ex,cdr(ex))) > 0  &&  n <= Env.next)
      return data(Env.arg[Env.next - n]);
   return Nil;
}

// (rest) -> lst
any doRest(any x) {
   int i;
   cell c1;

   if ((i = Env.next) <= 0)
      return Nil;
   Push(c1, x = cons(data(Env.arg[--i]), Nil));
   while (i)
      x = cdr(x) = cons(data(Env.arg[--i]), Nil);
   return Pop(c1);
}

any mkDat(int y, int m, int d) {
   int n;
   static char mon[13] = {31,31,28,31,30,31,30,31,31,30,31,30,31};

   if (m<1 || m>12 || d<1 || d>mon[m] && (m!=2 || d!=29 || y%4 || !(y%100) && y%400))
      return Nil;
   n = (12*y + m - 3) / 12;
   return boxCnt((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d);
}

// (date ['T]) -> dat
// (date 'dat) -> (y m d)
// (date 'y 'm 'd) -> dat | NIL
// (date '(y m d)) -> dat | NIL
any doDate(any ex) {
   any x, z;
   int y, m, d, n;
   cell c1;
   time_t tim;
   struct tm *p;

   if (!isCell(x = cdr(ex))) {
      time(&tim);
      p = localtime(&tim);
      return mkDat(p->tm_year+1900,  p->tm_mon+1,  p->tm_mday);
   }
   if ((z = EVAL(car(x))) == T) {
      time(&tim);
      p = gmtime(&tim);
      return mkDat(p->tm_year+1900,  p->tm_mon+1,  p->tm_mday);
   }
   if (isNil(z))
      return Nil;
   if (isNum(z) && !isCell(x = cdr(x))) {
      n = xCnt(ex,z);
      y = (100*n - 20) / 3652425;
      n += (y - y/4);
      y = (100*n - 20) / 36525;
      n -= 36525*y / 100;
      m = (10*n - 5) / 306;
      d = (10*n - 306*m + 5) / 10;
      if (m < 10)
         m += 3;
      else
         ++y,  m -= 9;
      Push(c1, cons(boxCnt(d), Nil));
      data(c1) = cons(boxCnt(m), data(c1));
      data(c1) = cons(boxCnt(y), data(c1));
      return Pop(c1);
   }
   if (!isCell(z))
      return mkDat(xCnt(ex,z), evCnt(ex,x), evCnt(ex,cdr(x)));
   return mkDat(xCnt(ex, car(z)),  xCnt(ex, cadr(z)),  xCnt(ex, caddr(z)));
}

// (time ['T]) -> tim
// (time 'tim) -> (h m s)
// (time 'h 'm ['s]) -> tim | NIL
// (time '(h m [s])) -> tim | NIL
any doTime(any ex) {
   any x, z;
   int h, m, s;
   cell c1;
   time_t tim;
   struct tm *p;

   if (!isCell(x = cdr(ex))) {
      time(&tim);
      p = localtime(&tim);
      return boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec);
   }
   if ((z = EVAL(car(x))) == T) {
      time(&tim);
      p = gmtime(&tim);
      return boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec);
   }
   if (isNil(z))
      return Nil;
   if (isNum(z) && !isCell(x = cdr(x))) {
      s = xCnt(ex,z);
      Push(c1, cons(boxCnt(s % 60), Nil));
      data(c1) = cons(boxCnt(s / 60 % 60), data(c1));
      data(c1) = cons(boxCnt(s / 3600), data(c1));
      return Pop(c1);
   }
   if (!isCell(z)) {
      h = xCnt(ex, z);
      m = evCnt(ex, x);
      s = isCell(cdr(x))? evCnt(ex, cdr(x)) : 0;
   }
   else {
      h = xCnt(ex, car(z));
      m = xCnt(ex, cadr(z));
      s = isCell(cddr(z))? xCnt(ex, caddr(z)) : 0;
   }
   if (h < 0 || h > 23  ||  m < 0 || m > 59  ||  s < 0 || s > 60)
      return Nil;
   return boxCnt(h * 3600 + m * 60 + s);
}

// (usec) -> num
any doUsec(any ex __attribute__((unused))) {
   gettimeofday(&Tv,NULL);
   return boxWord2((word2)Tv.tv_sec*1000000 + Tv.tv_usec - USec);
}

// (pwd) -> sym
any doPwd(any x) {
   char *p;

   if ((p = getcwd(NULL,0)) == NULL)
      return Nil;
   x = mkStr(p);
   free(p);
   return x;
}

// (cd 'any) -> sym
any doCd(any x) {
   x = evSym(cdr(x));
   {
      char *p, path[pathSize(x)];

      pathString(x, path);
      if ((p = getcwd(NULL,0)) == NULL  ||  path[0] && chdir(path) < 0)
         return Nil;
      x = mkStr(p);
      free(p);
      return x;
   }
}

// (ctty 'sym|pid) -> flg
any doCtty(any ex) {
   any x;

   if (!isSym(x = EVAL(cadr(ex))))
      TtyPid = xCnt(ex,x);
   else {
      char tty[bufSize(x)];

      bufString(x, tty);
      if (!freopen(tty,"r",stdin) || !freopen(tty,"w",stdout) || !freopen(tty,"w",stderr))
         return Nil;
   }
   return T;
}

// (info 'any) -> (cnt|T dat . tim)
any doInfo(any x) {
   cell c1;
   struct tm *p;
   struct stat st;

   x = evSym(cdr(x));
   {
      char nm[pathSize(x)];

      pathString(x, nm);
      if (stat(nm, &st) < 0)
         return Nil;
      p = gmtime(&st.st_mtime);
      Push(c1, boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec));
      data(c1) = cons(mkDat(p->tm_year+1900,  p->tm_mon+1,  p->tm_mday), data(c1));
      data(c1) = cons(S_ISDIR(st.st_mode)? T : boxWord2((word2)st.st_size), data(c1));
      return Pop(c1);
   }
}

// (dir ['any]) -> lst
any doDir(any x) {
   any y;
   DIR *dp;
   struct dirent *p;
   cell c1;

   if (isNil(x = evSym(cdr(x))))
      dp = opendir(".");
   else {
      char nm[pathSize(x)];

      pathString(x, nm);
      dp = opendir(nm);
   }
   if (!dp)
      return Nil;
   do {
      if (!(p = readdir(dp))) {
         closedir(dp);
         return Nil;
      }
   } while (p->d_name[0] == '.');
   Push(c1, y = cons(mkStr(p->d_name), Nil));
   while (p = readdir(dp))
      if (p->d_name[0] != '.')
         y = cdr(y) = cons(mkStr(p->d_name), Nil);
   closedir(dp);
   return Pop(c1);
}

// (argv [sym ..] [. sym]) -> lst|sym
any doArgv(any ex) {
   any x, y;
   char **p;
   cell c1;

   if (*(p = AV) && strcmp(*p,"-") == 0)
      ++p;
   if (isNil(x = cdr(ex))) {
      if (!*p)
         return Nil;
      Push(c1, x = cons(mkStr(*p++), Nil));
      while (*p)
         x = cdr(x) = cons(mkStr(*p++), Nil);
      return Pop(c1);
   }
   do {
      if (!isCell(x)) {
         NeedSym(ex,x);
         if (!*p)
            return val(x) = Nil;
         Push(c1, y = cons(mkStr(*p++), Nil));
         while (*p)
            y = cdr(y) = cons(mkStr(*p++), Nil);
         return val(x) = Pop(c1);
      }
      y = car(x);
      NeedSym(ex,y);
      val(y) = *p? mkStr(*p++) : Nil;
   } while (!isNil(x = cdr(x)));
   return val(y);
}

// (opt) -> sym
any doOpt(any ex __attribute__((unused))) {
   return *AV && strcmp(*AV,"-")? mkStr(*AV++) : Nil;
}

/*** Main ***/
int MAIN(int ac, char *av[]) {
   int i;
   char *p;

   for (i = 1; i < ac; ++i)
      if (*av[i] != '-') {
         if ((p = strrchr(av[i], '/')) && !(p == av[i]+1 && *av[i] == '.')) {
            Home = malloc(p - av[i] + 2);
            memcpy(Home, av[i], p - av[i] + 1);
            Home[p - av[i] + 1] = '\0';
         }
         break;
      }
   AV = av+1;
   heapAlloc();
   initSymbols();
   StdOut = stdout;
   Env.get = getStdin;
   Env.put = putStdout;
   Alarm = Line = Nil;
   ApplyArgs = cons(cons(consSym(Nil,Nil), Nil), Nil);
   ApplyBody = cons(Nil,Nil);
   iSignal(SIGHUP, doSignal);
   iSignal(SIGINT, doSigTerm);
   iSignal(SIGUSR1, doSignal);
   iSignal(SIGUSR2, doSignal);
   iSignal(SIGALRM, doSignal);
   iSignal(SIGTERM, doSignal);
   signal(SIGCHLD, doSigChld);
   signal(SIGPIPE, SIG_IGN);
   signal(SIGTTIN, SIG_IGN);
   signal(SIGTTOU, SIG_IGN);
   gettimeofday(&Tv,NULL);
   USec = (word2)Tv.tv_sec*1000000 + Tv.tv_usec;
   if (setjmp(ErrRst) < 0)
      prog(val(Rst));
   else {
      while (*AV  &&  strcmp(*AV,"-") != 0)
         load(NULL, 0, mkStr(*AV++));
      iSignal(SIGINT, doSignal);
      load(NULL, ':', Nil);
   }
   bye(0);
}