Read This! |
Picolisp |
Picolisp Machine |
Pil Sources |
Linux |
BASH |
C-Programmming |
Javascipt |
Python |
Scheme |
Operating Systems |
AssemblyLanguage |
Computer Security |
Firewalls |
Exploitation |
Social Engineering |
Metasploit |
Emacs |
vim |
Pharo Smalltalk |
Databases |
Networking |
Machine Learning |
Git |
Machine Learning |
Algorithms |
Open Data Science
/* 09jan17abu
* (c) Software Lab. Alexander Burger
*/
#include "pico.h"
#include "vers.h"
#ifdef __CYGWIN__
#define O_ASYNC FASYNC
#endif
Compiler predefined macros to detect Operating systems
- Use the SVR4 macros to distinguish between Solaris and SunOS.
- AIX (Advanced Interactive eXecutive) is a series of proprietary
Unix operating systems developed and sold by IBM
- O_ASYNC - used for asynchronous IO, signal pgrp when data ready (found in fcntl.h), we turn it off.
#if defined (__SVR4) || defined (_AIX) || defined (__hpux) || defined (__sgi)
#define O_ASYNC 0
#define GETCWDLEN 1024
#else
#define GETCWDLEN 0
#endif
- termios
The termios functions describe a general terminal interface that is
provided to control asynchronous communications ports.
/* Globals */
int Repl, Chr, Slot, Spkr, Mic, Hear, Tell, Children, ExtN;
char **AV, *AV0, *Home;
child *Child;
heap *Heaps;
cell *Avail;
stkEnv Env;
catchFrame *CatchPtr;
struct termios OrgTermio, *Termio;
int InFDs, OutFDs;
inFile *InFile, **InFiles;
outFile *OutFile, **OutFiles;
int (*getBin)(void);
void (*putBin)(int);
any TheKey, TheCls, Thrown;
any Alarm, Sigio, Line, Zero, One;
any Intern[IHASH], Transient[IHASH], Extern[EHASH];
any ApplyArgs, ApplyBody, DbVal, DbTail;
any Nil, DB, Meth, Quote, T;
any Solo, PPid, Pid, At, At2, At3, This, Prompt, Dbg, Zap, Ext, Scl, Class;
any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye;
bool Break;
sig_atomic_t Signal[NSIG];
static int TtyPid;
static word2 USec;
static struct timeval Tv;
static bool Tio, Jam;
static jmp_buf ErrRst;
static void finish(int) __attribute__ ((noreturn));
static struct rlimit ULim = {RLIM_INFINITY, RLIM_INFINITY};
/*** System ***/
static void finish(int n) {
setCooked();
exit(n);
}
void giveup(char *msg) {
fprintf(stderr, "%d %sn", (int)getpid(), msg);
finish(1);
}
void bye(int n) {
static bool flg;
if (!flg) {
flg = YES;
unwind(NULL);
prog(val(Bye));
}
flushAll();
finish(n);
}
void execError(char *s) {
fprintf(stderr, "%s: Can't execn", s);
exit(127);
}
/* Install interrupting signal */
static void iSignal(int n, void (*foo)(int)) {
struct sigaction act;
act.sa_handler = foo;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
sigaction(n, &act, NULL);
}
/* Signal handler */
void sighandler(any ex) {
int i;
bool flg;
if (!Env.protect) {
Env.protect = 1;
do {
if (Signal[SIGIO]) {
--Signal[0], --Signal[SIGIO];
run(Sigio);
}
else if (Signal[SIGUSR1]) {
--Signal[0], --Signal[SIGUSR1];
run(val(Sig1));
}
else if (Signal[SIGUSR2]) {
--Signal[0], --Signal[SIGUSR2];
run(val(Sig2));
}
else if (Signal[SIGALRM]) {
--Signal[0], --Signal[SIGALRM];
run(Alarm);
}
else if (Signal[SIGINT]) {
--Signal[0], --Signal[SIGINT];
if (Repl < 2)
brkLoad(ex ?: Nil);
}
else if (Signal[SIGHUP]) {
--Signal[0], --Signal[SIGHUP];
run(val(Hup));
}
else if (Signal[SIGTERM]) {
for (flg = NO, i = 0; i < Children; ++i)
if (Child[i].pid && kill(Child[i].pid, SIGTERM) == 0)
flg = YES;
if (flg)
break;
Signal[0] = 0, bye(0);
}
} while (*Signal);
Env.protect = 0;
}
}
static void sig(int n) {
if (TtyPid)
kill(TtyPid, n);
else
++Signal[n], ++Signal[0];
}
static void sigTerm(int n) {
if (TtyPid)
kill(TtyPid, n);
else
++Signal[SIGTERM], ++Signal[0];
}
static void sigChld(int n __attribute__((unused))) {
int e, stat;
pid_t pid;
e = errno;
while ((pid = waitpid(0, &stat, WNOHANG)) > 0)
if (WIFSIGNALED(stat))
fprintf(stderr, "%d SIG-%dn", (int)pid, WTERMSIG(stat));
errno = e;
}
static void tcSet(struct termios *p) {
if (Termio)
while (tcsetattr(STDIN_FILENO, TCSADRAIN, p) && errno == EINTR);
}
static void sigTermStop(int n __attribute__((unused))) {
sigset_t mask;
tcSet(&OrgTermio);
sigemptyset(&mask);
sigaddset(&mask, SIGTSTP);
sigprocmask(SIG_UNBLOCK, &mask, NULL);
signal(SIGTSTP, SIG_DFL), raise(SIGTSTP), signal(SIGTSTP, sigTermStop);
tcSet(Termio);
}
void setRaw(void) {
if (Tio && !Termio) {
*(Termio = malloc(sizeof(struct termios))) = OrgTermio;
Termio->c_iflag = 0;
Termio->c_oflag = OPOST+ONLCR;
Termio->c_lflag = ISIG;
Termio->c_cc[VMIN] = 1;
Termio->c_cc[VTIME] = 0;
tcSet(Termio);
if (signal(SIGTSTP,SIG_IGN) == SIG_DFL)
signal(SIGTSTP, sigTermStop);
}
}
void setCooked(void) {
tcSet(&OrgTermio);
free(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);
}
// (sigio 'cnt . prg) -> cnt
any doSigio(any ex) {
any x = EVAL(cadr(ex));
int fd = (int)xCnt(ex,x);
Sigio = cddr(ex);
fcntl(fd, F_SETOWN, unBox(val(Pid)));
fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | O_NONBLOCK|O_ASYNC);
return x;
}
// (kids) -> lst
any doKids(any ex __attribute__((unused))) {
int i;
any x;
for (i = 0, x = Nil; i < Children; ++i)
if (Child[i].pid)
x = cons(box(Child[i].pid * 2), x);
return x;
}
// (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*)alloc(NULL, sizeof(heap));
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);
}
// (adr 'var) -> num
// (adr 'num) -> var
any doAdr(any x) {
x = cdr(x);
if (isNum(x = EVAL(car(x))))
return (any)(unDig(x) * WORD);
return box(num(x) / WORD);
}
// (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(
isCell(car(data(c2)))?
cons(caar(data(c2)), cdar(data(c2))) :
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;
}
}
}
if (isCell(x = cdr(x)))
return *val = EVAL(car(x));
return *val;
}
// (sys 'any ['any]) -> sym
any doSys(any x) {
any y;
y = evSym(x = cdr(x));
{
char nm[bufSize(y)];
bufString(y,nm);
if (!isCell(x = cdr(x)))
return mkStr(getenv(nm));
y = evSym(x);
{
#if defined (__sgi)
char *val = malloc(sizeof(nm) + bufSize(y));
sprintf(val, "%s=", nm);
bufString(y, val + sizeof(nm));
return putenv(val)? Nil : y;
#else
char val[bufSize(y)];
bufString(y,val);
return setenv(nm,val,1)? Nil : y;
#endif
}
}
}
/*** Primitives ***/
any circ(any x) {
any y = x;
if (!isCell(x))
return NULL;
for (;;) {
*(word*)&car(y) |= 1;
if (!isCell(y = cdr(y))) {
do
*(word*)&car(x) &= ~1;
while (isCell(x = cdr(x)));
return NULL;
}
if (num(car(y)) & 1) {
while (x != y)
*(word*)&car(x) &= ~1, x = cdr(x);
do
*(word*)&car(x) &= ~1;
while (y != (x = cdr(x)));
return y;
}
}
}
/* Comparisons */
bool equal(any x, any y) {
any a, b;
bool res;
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));
continue;
}
if (isSym(x)) {
if (!isSym(y) || !isNum(x = name(x)) || !isNum(y = name(y)))
return NO;
continue;
}
if (!isCell(y))
return NO;
a = x, b = y;
res = NO;
for (;;) {
if (!equal(car(x), (any)(num(car(y)) & ~1)))
break;
if (!isCell(cdr(x))) {
res = equal(cdr(x), cdr(y));
break;
}
if (!isCell(cdr(y)))
break;
*(word*)&car(x) |= 1, x = cdr(x), y = cdr(y);
if (num(car(x)) & 1) {
for (;;) {
if (a == x) {
if (b == y) {
for (;;) {
a = cdr(a);
if ((b = cdr(b)) == y) {
res = a == x;
break;
}
if (a == x) {
res = YES;
break;
}
}
}
break;
}
if (b == y) {
res = NO;
break;
}
*(word*)&car(a) &= ~1, a = cdr(a), b = cdr(b);
}
do
*(word*)&car(a) &= ~1, a = cdr(a);
while (a != x);
return res;
}
}
while (a != x)
*(word*)&car(a) &= ~1, a = cdr(a);
return res;
}
}
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))? (long)x - (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;
}
}
int binSize(any x) {
if (isNum(x)) {
int n = numBytes(x);
if (n < 63)
return n + 1;
return n + 2 + (n - 63) / 255;
}
else if (isNil(x))
return 1;
else if (isSym(x))
return binSize(name(x));
else {
any y = x;
int n = 2;
while (n += binSize(car(x)), !isNil(x = cdr(x))) {
if (x == y)
return n + 1;
if (!isCell(x))
return n + binSize(x);
}
return n;
}
}
/*** Error handling ***/
void err(any ex, any x, char *fmt, ...) {
va_list ap;
char msg[240];
outFrame f;
cell c1;
va_start(ap,fmt);
vsnprintf(msg, sizeof(msg), fmt, ap);
va_end(ap);
val(Up) = ex ?: Nil;
if (x)
Push(c1, x);
if (msg[0]) {
any y;
catchFrame *p;
val(Msg) = mkStr(msg);
for (p = CatchPtr; p; p = p->link)
if (y = p->tag)
while (isCell(y)) {
if (subStr(car(y), val(Msg))) {
Thrown = isNil(car(y))? val(Msg) : car(y);
unwind(p);
longjmp(p->rst, 1);
}
y = cdr(y);
}
}
Chr = ExtN = 0;
Break = NO;
Alarm = Line = Nil;
f.pid = 0, f.fd = STDERR_FILENO, pushOutFiles(&f);
if (InFile && InFile->name) {
Env.put('[');
outString(InFile->name), Env.put(':'), outWord(InFile->src);
Env.put(']'), space();
}
if (ex)
outString("!? "), print(ex), newline();
if (x)
print(x), outString(" -- ");
if (msg[0]) {
outString(msg), newline();
if (!isNil(val(Err)) && !Jam)
Jam = YES, prog(val(Err)), Jam = NO;
if (!isatty(STDIN_FILENO) || !isatty(STDOUT_FILENO))
bye(1);
load(NULL, '?', Nil);
}
unwind(NULL);
Env.stack = NULL;
Env.protect = Env.trace = 0;
Env.next = -1;
Env.task = Nil;
Env.make = Env.yoke = NULL;
Env.parser = NULL;
Env.put = putStdout;
Env.get = getStdin;
longjmp(ErrRst, +1);
}
// (quit ['any ['any]])
any doQuit(any x) {
any y;
x = cdr(x), y = evSym(x);
{
char msg[bufSize(y)];
bufString(y, msg);
x = isCell(x = cdr(x))? EVAL(car(x)) : NULL;
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 pairError(any ex, any x) {err(ex, x, "Cons pair 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 *catch) {
any x;
int i, j, n;
bindFrame *p;
catchFrame *q;
while (q = CatchPtr) {
while (p = Env.bind) {
if ((i = p->i) < 0) {
j = i, n = 0;
while (++n, ++j && (p = p->link))
if (p->i >= 0 || p->i < i)
--j;
do {
for (p = Env.bind, j = n; --j; p = p->link);
if (p->i < 0 && ((p->i -= i) > 0? (p->i = 0) : p->i) == 0)
for (j = p->cnt; --j >= 0;) {
x = val(p->bnd[j].sym);
val(p->bnd[j].sym) = p->bnd[j].val;
p->bnd[j].val = x;
}
} while (--n);
}
if (Env.bind == q->env.bind)
break;
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.inFrames != q->env.inFrames)
popInFiles();
while (Env.outFrames != q->env.outFrames)
popOutFiles();
while (Env.errFrames != q->env.errFrames)
popErrFiles();
while (Env.ctlFrames != q->env.ctlFrames)
popCtlFiles();
Env = q->env;
EVAL(q->fin);
CatchPtr = q->link;
if (q == catch)
return;
}
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.inFrames)
popInFiles();
while (Env.outFrames)
popOutFiles();
while (Env.errFrames)
popErrFiles();
while (Env.ctlFrames)
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)) {
do {
x = val(f.bnd[--f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
} while (f.i);
x = prog(cdr(expr));
}
else if (y != At) {
f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x;
do {
x = val(f.bnd[--f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
} while (f.i);
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);
do {
x = val(f.bnd[--f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
} while (f.i);
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;
}
any funq(any x) {
any y;
if (isSym(x))
return Nil;
if (isNum(x))
return (unDig(x)&3) || isNum(cdr(numCell(x)))? Nil : x;
if (circ(y = cdr(x)))
return Nil;
while (isCell(y)) {
if (isCell(car(y))) {
if (isNum(caar(y))) {
if (isCell(cdr(y)))
return Nil;
}
else if (isNil(caar(y)) || caar(y) == T)
return Nil;
}
else if (!isNil(cdr(y)))
return Nil;
y = cdr(y);
}
if (!isNil(y))
return Nil;
if (isNil(x = car(x)))
return T;
if (circ(y = x))
return Nil;
while (isCell(y)) {
if (isNum(car(y)) || isCell(car(y)) || isNil(car(y)) || car(y) == T)
return Nil;
y = cdr(y);
}
return isNum(y) || y==T? Nil : x;
}
bool sharedLib(any x) {
void *h;
char *p, nm[bufSize(x)];
bufString(x, nm);
if (!(p = strchr(nm,':')) || p == nm || p[1] == '0')
return NO;
*p++ = '0';
{
int n = Home? strlen(Home) : 0;
#ifndef __CYGWIN__
char buf[n + strlen(nm) + 4 + 1];
#else
char buf[n + strlen(nm) + 4 + 4 + 1];
#endif
if (strchr(nm,'/'))
strcpy(buf, nm);
else {
if (n)
memcpy(buf, Home, n);
strcpy(buf + n, "lib/"), strcpy(buf + n + 4, nm);
#ifdef __CYGWIN__
strcpy(buf + n + 4 + strlen(nm), ".dll");
#endif
}
if (!(h = dlopen(buf, RTLD_LAZY | RTLD_GLOBAL)) || !(h = dlsym(h,p)))
return NO;
val(x) = box(num(h));
}
return YES;
}
void undefined(any x, any ex) {
if (!sharedLib(x))
err(ex, x, "Undefined");
}
static any evList2(any foo, any ex) {
cell c1;
Push(c1, foo);
if (isCell(foo)) {
foo = evExpr(foo, cdr(ex));
drop(c1);
return foo;
}
for (;;) {
if (isNil(val(foo)))
undefined(foo,ex);
if (*Signal)
sighandler(ex);
if (isNum(foo = val(foo))) {
foo = evSubr(foo,ex);
drop(c1);
return foo;
}
if (isCell(foo)) {
foo = evExpr(foo, cdr(ex));
drop(c1);
return foo;
}
}
}
/* 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);
return evList2(foo,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);
}
static struct tm *TM;
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 (y<0 || 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;
if (!isCell(x = cdr(ex))) {
gettimeofday(&Tv,NULL);
TM = localtime(&Tv.tv_sec);
return mkDat(TM->tm_year+1900, TM->tm_mon+1, TM->tm_mday);
}
if ((z = EVAL(car(x))) == T) {
gettimeofday(&Tv,NULL);
TM = gmtime(&Tv.tv_sec);
return mkDat(TM->tm_year+1900, TM->tm_mon+1, TM->tm_mday);
}
if (isNil(z))
return Nil;
if (isCell(z))
return mkDat(xCnt(ex, car(z)), xCnt(ex, cadr(z)), xCnt(ex, caddr(z)));
if (!isCell(x = cdr(x))) {
if ((n = xCnt(ex,z)) < 0)
return Nil;
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);
}
y = xCnt(ex,z);
m = evCnt(ex,x);
return mkDat(y, m, evCnt(ex,cdr(x)));
}
any mkTime(int h, int m, int s) {
if (h < 0 || m < 0 || m > 59 || s < 0 || s > 60)
return Nil;
return boxCnt(h * 3600 + m * 60 + s);
}
// (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;
struct tm *p;
if (!isCell(x = cdr(ex))) {
gettimeofday(&Tv,NULL);
p = localtime(&Tv.tv_sec);
return boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec);
}
if ((z = EVAL(car(x))) == T)
return TM? boxCnt(TM->tm_hour * 3600 + TM->tm_min * 60 + TM->tm_sec) : Nil;
if (isNil(z))
return Nil;
if (isCell(z))
return mkTime(xCnt(ex, car(z)), xCnt(ex, cadr(z)), isCell(cddr(z))? xCnt(ex, caddr(z)) : 0);
if (!isCell(x = cdr(x))) {
if ((s = xCnt(ex,z)) < 0)
return Nil;
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);
}
h = xCnt(ex, z);
m = evCnt(ex, x);
return mkTime(h, m, isCell(cdr(x))? evCnt(ex, cdr(x)) : 0);
}
// (tzo) -> cnt
any doTzo(any ex __attribute__((unused))) {
#ifdef __linux__
return boxCnt(localtime(&Tv.tv_sec)->tm_gmtoff);
#else
return Zero;
#endif
}
// (usec ['flg]) -> num
any doUsec(any ex) {
if (!isNil(EVAL(cadr(ex))))
return boxCnt(Tv.tv_usec);
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, GETCWDLEN)) == 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, GETCWDLEN)) == NULL)
return Nil;
x = path[0] && chdir(path) < 0? Nil : mkStr(p);
free(p);
return x;
}
}
// (ctty 'sym|pid) -> flg
any doCtty(any ex) {
any x;
if (isNum(x = EVAL(cadr(ex))))
TtyPid = unDig(x) / 2;
else {
if (!isSym(x))
argError(ex,x);
{
char tty[bufSize(x)];
bufString(x, tty);
if (!freopen(tty,"r",stdin) || !freopen(tty,"w",stdout) || !freopen(tty,"w",stderr))
return Nil;
InFiles[STDIN_FILENO]->ix = InFiles[STDIN_FILENO]->cnt = InFiles[STDIN_FILENO]->next = 0;
Tio = tcgetattr(STDIN_FILENO, &OrgTermio) == 0;
OutFiles[STDOUT_FILENO]->tty = YES;
OutFiles[STDOUT_FILENO]->ix = 0;
}
}
return T;
}
// (info 'any ['flg]) -> (cnt|flg dat . tim)
any doInfo(any x) {
any y;
cell c1;
struct tm *p;
struct stat st;
y = evSym(x = cdr(x));
{
char nm[pathSize(y)];
pathString(y, nm);
x = cdr(x);
if ((isNil(EVAL(car(x)))? stat(nm, &st) : lstat(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(
(st.st_mode & S_IFMT) == S_IFDIR? T :
(st.st_mode & S_IFMT) != S_IFREG? Nil :
boxWord2((word2)st.st_size), data(c1) );
return Pop(c1);
}
}
// (file) -> (sym1 sym2 . num) | NIL
any doFile(any ex __attribute__((unused))) {
char *s, *p;
cell c1;
if (!InFile || !InFile->name)
return Nil;
Push(c1, boxCnt(InFile->src));
s = strdup(InFile->name);
if (p = strrchr(s, '/')) {
data(c1) = cons(mkStr(p+1), data(c1));
*(p+1) = '0';
data(c1) = cons(mkStr(s), data(c1));
}
else {
data(c1) = cons(mkStr(s), data(c1));
data(c1) = cons(mkStr("./"), data(c1));
}
free(s);
return Pop(c1);
}
// (dir ['any] ['flg]) -> lst
any doDir(any x) {
any y;
DIR *dp;
struct dirent *p;
cell c1;
if (isNil(y = evSym(x = cdr(x))))
dp = opendir(".");
else {
char nm[pathSize(y)];
pathString(y, nm);
dp = opendir(nm);
}
if (!dp)
return Nil;
x = cdr(x), x = EVAL(car(x));
do {
if (!(p = readdir(dp))) {
closedir(dp);
return Nil;
}
} while (isNil(x) && p->d_name[0] == '.');
Push(c1, y = cons(mkStr(p->d_name), Nil));
while (p = readdir(dp))
if (!isNil(x) || p->d_name[0] != '.')
y = cdr(y) = cons(mkStr(p->d_name), Nil);
closedir(dp);
return Pop(c1);
}
// (cmd ['any]) -> sym
any doCmd(any x) {
if (isNil(x = evSym(cdr(x))))
return mkStr(AV0);
bufString(x, AV0);
return x;
}
// (argv [var ..] [. 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);
CheckVar(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);
NeedVar(ex,y);
CheckVar(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;
}
// (version ['flg]) -> lst
any doVersion(any x) {
int i;
cell c1;
x = cdr(x);
if (isNil(EVAL(car(x)))) {
for (i = 0; i < 3; ++i) {
outWord((word)Version[i]);
Env.put(i == 2? ' ' : '.');
}
Env.put('C');
newline();
}
Push(c1, Nil);
i = 3;
do
data(c1) = cons(box(Version[--i] * 2), data(c1));
while (i);
return Pop(c1);
}
any loadAll(any ex) {
any x = Nil;
while (*AV && strcmp(*AV,"-") != 0)
x = load(ex, 0, mkStr(*AV++));
return x;
}
/*** Main ***/
static void init(int ac, char *av[]) {
char *p;
sigset_t sigs;
AV0 = *av++;
AV = av;
heapAlloc();
initSymbols();
if (ac >= 2 && strcmp(av[ac-2], "+") == 0)
val(Dbg) = T, av[ac-2] = NULL;
if (av[0] && *av[0] != '-' && (p = strrchr(av[0], '/')) && !(p == av[0]+1 && *av[0] == '.')) {
Home = malloc(p - av[0] + 2);
memcpy(Home, av[0], p - av[0] + 1);
Home[p - av[0] + 1] = '0';
}
Env.get = getStdin;
InFile = initInFile(STDIN_FILENO, NULL);
Env.put = putStdout;
initOutFile(STDERR_FILENO);
OutFile = initOutFile(STDOUT_FILENO);
Env.task = Alarm = Sigio = Line = Nil;
setrlimit(RLIMIT_STACK, &ULim);
Tio = tcgetattr(STDIN_FILENO, &OrgTermio) == 0;
ApplyArgs = cons(cons(consSym(Nil,Nil), Nil), Nil);
ApplyBody = cons(Nil,Nil);
sigfillset(&sigs);
sigprocmask(SIG_UNBLOCK, &sigs, NULL);
iSignal(SIGHUP, sig);
iSignal(SIGINT, sigTerm);
iSignal(SIGUSR1, sig);
iSignal(SIGUSR2, sig);
iSignal(SIGALRM, sig);
iSignal(SIGTERM, sig);
iSignal(SIGIO, sig);
signal(SIGCHLD, sigChld);
signal(SIGPIPE, SIG_IGN);
signal(SIGTTIN, SIG_IGN);
signal(SIGTTOU, SIG_IGN);
gettimeofday(&Tv,NULL);
USec = (word2)Tv.tv_sec*1000000 + Tv.tv_usec;
}
int MAIN(int ac, char *av[]) {
init(ac,av);
if (!setjmp(ErrRst)) {
loadAll(NULL);
++Repl;
iSignal(SIGINT, sig);
}
for (;;)
load(NULL, ':', Nil);
}
http:///wiki/?mainc
