/* lysp.c -- LYSP: commemorating 50 Years of Symbolic Processing
** (no relation to the long-deceased dialect from IBM)
**
** Copyright (c) 2008 Ian Piumarta
** All Rights Reserved
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the 'Software'),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, and/or sell
** copies of the Software, and to permit persons to whom the Software is
** furnished to do so, provided that the above copyright notice(s) and this
** permission notice appear in all copies of the Software. Inclusion of the
** the above copyright notice(s) and this permission notice in supporting
** documentation would be appreciated but is not required.
**
** THE SOFTWARE IS PROVIDED 'AS IS'. USE ENTIRELY AT YOUR OWN RISK.
**
** Last edited: 2012-01-12 15:44:18 by piumarta on vps2.piumarta.com
*/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stdarg.h>
#include <ctype.h>
#include <unistd.h>
#include <errno.h>
#include <sys/errno.h>
#include <assert.h>
#ifndef BDWGC
# error you did neither -DBDWGC=0 nor -DBDWGC=1 in the compilation command
#endif
#if BDWGC
# include <gc/gc.h>
# define GC_PROTECT(X)
# define GC_UNPROTECT(X)
#else
# include "gc.h"
#endif
#define balloc GC_malloc_atomic
#define malloc GC_malloc
static void fatal(const char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
fprintf(stderr, "\nError: ");
vfprintf(stderr, fmt, ap);
fprintf(stderr, "\n");
va_end(ap);
exit(1);
}
typedef enum { None, Number, String, Symbol, Cons, Subr, Fsubr, Expr, Fexpr, Psubr } Tag;
struct _Cell;
typedef struct _Cell Cell;
typedef Cell *(*Subr_t)(Cell *args, Cell *env);
Cell *apply(Cell *fn, Cell *args, Cell *env);
struct _Cell
{
Tag mTag;
union {
long mNumber;
const char *mString;
const char *mSymbol;
struct {
Cell *a;
Cell *d;
} mCons;
Subr_t mSubr;
struct {
Cell *expr;
Cell *env;
} mExpr;
};
};
Cell *mkNumber(long n) { Cell *self= balloc(sizeof(Cell)); self->mTag= Number; self->mNumber= n; return self; }
Cell *mkString(const char *s) { Cell *self= balloc(sizeof(Cell)); self->mTag= String; self->mString= s; return self; }
Cell *mkSymbol(const char *s) { Cell *self= balloc(sizeof(Cell)); self->mTag= Symbol; self->mString= s; return self; }
Cell *cons(Cell *a, Cell *d) { Cell *self= malloc(sizeof(Cell)); self->mTag= Cons; self->mCons.a= a; self->mCons.d= d; return self; }
Cell *mkSubr(Subr_t fn) { Cell *self= balloc(sizeof(Cell)); self->mTag= Subr; self->mSubr= fn; return self; }
Cell *mkFsubr(Subr_t fn) { Cell *self= balloc(sizeof(Cell)); self->mTag= Fsubr; self->mSubr= fn; return self; }
Cell *mkExpr(Cell *x, Cell *e) { Cell *self= malloc(sizeof(Cell)); self->mTag= Expr; self->mExpr.expr= x; self->mExpr.env= e; return self; }
Cell *mkFexpr(Cell *x, Cell *e) { Cell *self= malloc(sizeof(Cell)); self->mTag= Fexpr; self->mExpr.expr= x; self->mExpr.env= e; return self; }
Cell *mkPsubr(Subr_t fn) { Cell *self= balloc(sizeof(Cell)); self->mTag= Psubr; self->mSubr= fn; return self; }
int nilP(Cell *self) { return !self; }
int numberP(Cell *self) { return self && self->mTag == Number; }
int stringP(Cell *self) { return self && self->mTag == String; }
int symbolP(Cell *self) { return self && self->mTag == Symbol; }
int consP(Cell *self) { return self && self->mTag == Cons; }
int subrP(Cell *self) { return self && self->mTag == Subr; }
int fsubrP(Cell *self) { return self && self->mTag == Fsubr; }
int exprP(Cell *self) { return self && self->mTag == Expr; }
int fexprP(Cell *self) { return self && self->mTag == Fexpr; }
int psubrP(Cell *self) { return self && self->mTag == Psubr; }
#ifndef NDEBUG
# define require(X) assert(X)
#else
# define require(X) if (!(X)) return 0
#endif
long number(Cell *self) { require(numberP(self)); return self->mNumber; }
const char *string(Cell *self) { require(stringP(self)); return self->mString; }
const char *symbol(Cell *self) { require(symbolP(self)); return self->mSymbol; }
Subr_t subr(Cell *self) { require(subrP(self)); return self->mSubr; }
Subr_t fsubr(Cell *self) { require(fsubrP(self)); return self->mSubr; }
Cell *expr(Cell *self) { require(exprP(self)); return self->mExpr.expr; }
Cell *exprenv(Cell *self) { require(exprP(self)); return self->mExpr.env; }
Cell *fexpr(Cell *self) { require(fexprP(self)); return self->mExpr.expr; }
Cell *fexprenv(Cell *self) { require(fexprP(self)); return self->mExpr.env; }
Subr_t psubr(Cell *self) { require(psubrP(self)); return self->mSubr; }
Cell *car(Cell *self) { require(!self || consP(self)); return self ? self->mCons.a : 0; }
Cell *cdr(Cell *self) { require(!self || consP(self)); return self ? self->mCons.d : 0; }
Cell *rplaca(Cell *self, Cell *c) { require(!self || consP(self)); return self ? self->mCons.a= c : c; }
Cell *rplacd(Cell *self, Cell *c) { require(!self || consP(self)); return self ? self->mCons.d= c : c; }
#undef require
Cell *caar (Cell *self) { return car(car(self)); }
Cell *cadr (Cell *self) { return car(cdr(self)); }
Cell *cdar (Cell *self) { return cdr(car(self)); }
Cell *caddr (Cell *self) { return car(cdr(cdr(self))); }
Cell *cadar (Cell *self) { return car(cdr(car(self))); }
Cell *interns= 0;
Cell *intern(const char *s)
{
Cell *cell= 0;
for (cell= interns; cell; cell= cdr(cell))
if (!strcmp(symbol(car(cell)), s))
return car(cell);
cell= mkSymbol(strdup(s));
GC_PROTECT(cell);
interns= cons(cell, interns);
GC_UNPROTECT(cell);
return car(interns);
}
Cell *assq(Cell *key, Cell *list)
{
for (; list; list= cdr(list))
if (key == caar(list)) return car(list);
return 0;
}
Cell *print(Cell *self, FILE *stream)
{
if (!self) fprintf(stream, "nil");
else
switch (self->mTag) {
case Number: fprintf(stream, "%ld", number(self)); break;
case String: fprintf(stream, "\"%s\"", string(self)); break;
case Symbol: fprintf(stream, "%s", symbol(self)); break;
case Subr: fprintf(stream, "subr<%p>", subr(self)); break;
case Fsubr: fprintf(stream, "fsubr<%p>", fsubr(self)); break;
case Expr: fprintf(stream, "(lambda "); print(expr(self), stream); fprintf(stream, ")"); break;
case Fexpr: fprintf(stream, "(flambda "); print(fexpr(self), stream); fprintf(stream, ")"); break;
case Psubr: fprintf(stream, "psubr<%p>", psubr(self)); break;
case Cons: {
fprintf(stream, "(");
while (self && consP(self)) {
print(car(self), stream);
if ((self= cdr(self))) fputc(' ', stream);
}
if (self) {
fprintf(stream, ". ");
print(self, stream);
}
fprintf(stream, ")");
break;
}
default:
fprintf(stream, "?%p", self);
break;
}
return self;
}
Cell *println(Cell *self, FILE *stream)
{
print(self, stream);
fprintf(stream, "\n");
return self;
}
Cell *_S_t = 0;
Cell *_S_quote = 0;
Cell *_S_qquote = 0;
Cell *_S_uquote = 0;
Cell *_S_uquotes = 0;
Cell *syntaxTable= 0;
Cell *globals= 0;
typedef Cell *(*Reader)(int, FILE *);
Cell *readFile(FILE *in);
Cell *readAlpha(int c, FILE *in);
Cell *readSign(int c, FILE *in);
Reader readers[256];
#define CEOF ((Cell *)-1)
Cell *readIllegal(int c, FILE *in)
{
fprintf(stderr, "ignoring illegal character ");
fprintf(stderr, (isprint(c) ? "%c" : "0x%02x"), c);
fprintf(stderr, "\n");
return 0;
}
Cell *readBlank(int c, FILE *in)
{
return 0;
}
Cell *readDigit(int c, FILE *in)
{
char buf[1024];
int index= 0;
char *endptr;
long number= 0;
buf[index++]= c;
if ('0' == c) {
if (strchr("xX", (c= getc(in)))) buf[index++]= c;
else ungetc(c, in);
}
while ((c= getc(in)) > 0 && (readDigit == readers[c] || readAlpha == readers[c])) buf[index++]= c;
ungetc(c, in);
buf[index]= '\0';
errno= 0;
number= strtol(buf, &endptr, 0);
if ((ERANGE == errno) || (errno && !number)) perror(buf);
if (*endptr != '\0') fprintf(stderr, "%s: invalid digits in number\n", buf);
return mkNumber(number);
}
Cell *readAlpha(int c, FILE *in)
{
char buf[1024];
int index= 0;
buf[index++]= c;
while ((c= getc(in)) > 0 && (readAlpha == readers[c] || readDigit == readers[c] || readSign == readers[c])) buf[index++]= c;
ungetc(c, in);
buf[index]= '\0';
return intern(buf);
}
Cell *readSign(int c, FILE *in)
{
int d= getc(in);
ungetc(d, in);
return (d > 0 && readers[d] == readDigit) ? readDigit(c, in) : readAlpha(c, in);
}
Cell *readString(int d, FILE *in)
{
char buf[1024];
int index= 0;
int c;
while ((c= getc(in)) > 0 && c != d) if ('\\' == (buf[index++]= c)) buf[index++]= getc(in);
if (c != d) fatal("EOF in string");
buf[index]= '\0';
return mkString(strdup(buf));
}
Cell *readQuote(int c, FILE *in)
{
Cell *cell= readFile(in);
if (CEOF == cell) fatal("EOF in quoted literal");
GC_PROTECT(cell);
cell= cons(cell, 0);
cell= cons(_S_quote, cell);
GC_UNPROTECT(cell);
return cell;
}
Cell *readQquote(int c, FILE *in)
{
Cell *cell= readFile(in);
if (CEOF == cell) fatal("EOF in quasiquoted literal");
GC_PROTECT(cell);
cell= cons(cell, 0);
cell= cons(_S_qquote, cell);
GC_UNPROTECT(cell);
return cell;
}
Cell *readUquote(int c, FILE *in)
{
int splice= 0;
if ('@' == (c= getc(in))) splice= 1;
else ungetc(c, in);
Cell *cell= readFile(in);
if (CEOF == cell) fatal("EOF in quasiquoted literal");
GC_PROTECT(cell);
cell= cons(cell, 0);
cell= cons((splice ? _S_uquotes : _S_uquote), cell);
GC_UNPROTECT(cell);
return cell;
}
Cell *readList(int d, FILE *in)
{
Cell *head, *tail, *cell= 0;
tail= head= cons(0, 0);
GC_PROTECT(head);
GC_PROTECT(cell);
switch (d) {
case '(': d= ')'; break;
case '[': d= ']'; break;
case '{': d= '}'; break;
}
int c;
for (;;) {
while (isspace((c= getc(in))));
if (c == d) break;
if (c == ')' || c == ']' || c == '}') fatal("mismatched parentheses");
if (c == '.')
rplacd(tail, readFile(in));
else {
ungetc(c, in);
cell= readFile(in);
if (feof(in)) fatal("EOF in list");
tail= rplacd(tail, cons(cell, 0));
}
}
head= cdr(head);
if (head && symbolP(car(head))) {
Cell *syntax= assq(car(head), cdr(syntaxTable));
if (syntax) head= apply(cdr(syntax), cdr(head), globals);
if (!head) {
GC_UNPROTECT(head);
return 0;
}
}
GC_UNPROTECT(head);
return head ? head : (Cell *)-1;
}
Cell *readSemi(int c, FILE *in)
{
while ((c= getc(in)) && (c != '\n') && (c != '\r'));
return 0;
}
Cell *readFile(FILE *in)
{
int c;
Cell *cell;
do {
while (isspace(c= getc(in)));
if (c < 0) return (Cell *)-1;
cell= readers[c](c, in);
} while (!cell);
if (cell == (Cell *)-1) cell= 0;
return cell;
}
static void initReaders(Reader r, const char *chars)
{
while (*chars) readers[(int)*chars++]= r;
}
Cell *undefined(Cell *sym)
{
fprintf(stderr, "undefined: %s\n", symbol(sym));
return 0;
}
Cell *eval(Cell *expr, Cell *env);
Cell *evargs(Cell *self, Cell *env)
{
if (self) {
Cell *head, *tail;
head= eval(car(self), env);
GC_PROTECT(head);
tail= evargs(cdr(self), env);
GC_PROTECT(tail);
head= cons(head, tail);
GC_UNPROTECT(head);
return head;
}
return 0;
}
Cell *evbind(Cell *expr, Cell *args, Cell *env)
{
Cell *cell= 0;
GC_PROTECT(env);
GC_PROTECT(cell);
if (consP(expr))
for (; expr; expr= cdr(expr), args= cdr(args)) {
cell= cons(car(expr), car(args));
env= cons(cell, env);
}
else {
cell= cons(expr, args);
env= cons(cell, env);
}
GC_UNPROTECT(env);
return env;
}
Cell *evlist(Cell *expr, Cell *env)
{
Cell *result= 0;
GC_PROTECT(expr);
GC_PROTECT(env);
GC_PROTECT(result);
for (; expr; expr= cdr(expr)) result= eval(car(expr), env);
GC_UNPROTECT(expr);
return result;
}
typedef void (*apply_t)(void);
typedef union { char *argp; } *arglist_t;
long primcall(apply_t fn, arglist_t args, int size)
{
void *ret= __builtin_apply(fn, args, size);
__builtin_return(ret);
}
void *cellToPrim(Cell *cell)
{
switch (cell->mTag) {
case Cons: case Expr: case Fexpr: return (void *)cell;
default: return (void *)cell->mCons.a;
}
}
Cell *apply(Cell *fn, Cell *args, Cell *env)
{
GC_PROTECT(fn);
GC_PROTECT(args);
GC_PROTECT(env);
if (fn)
switch (fn->mTag) {
case Subr: return subr(fn)(evargs(args, env), env);
case Fsubr: return fsubr(fn)(args, env);
case Expr: {
Cell *eva= evargs(args, env);
GC_PROTECT(eva);
eva= evlist(cdr(expr(fn)), evbind(car(expr(fn)), eva, exprenv(fn)));
GC_UNPROTECT(fn);
return eva;
}
case Fexpr: {
Cell *eva= cons(env, 0);
GC_PROTECT(eva);
eva= cons(args, eva);
eva= evlist(cdr(fexpr(fn)), evbind(car(fexpr(fn)), eva, fexprenv(fn)));
GC_UNPROTECT(fn);
return eva;
}
case Psubr: {
void *argv[32]; /* fixme: count the args, then alloca() */
int i;
for (i= 1; args; args= cdr(args), ++i) argv[i]= cellToPrim(eval(car(args), env));
argv[0]= &argv[1];
return mkNumber(primcall((apply_t)psubr(fn), (void*)argv, sizeof(void *) * i));
}
default: break;
}
fprintf(stderr, "cannot apply: ");
println(fn, stderr);
return 0;
}
Cell *eval(Cell *expr, Cell *env)
{
if (!expr) return 0;
switch (expr->mTag) {
case Number: case String: case Subr: case Fsubr: case Expr: {
return expr;
}
case Symbol: {
Cell *cell= assq(expr, env);
if (!cell) return undefined(expr);
return cdr(cell);
}
case Cons: {
Cell *cell;
GC_PROTECT(expr);
GC_PROTECT(env);
cell= eval(car(expr), env);
GC_PROTECT(cell);
cell= apply(cell, cdr(expr), env);
GC_UNPROTECT(expr);
return cell;
}
default:
fatal("unknown tag");
}
return 0;
}
Cell *defineFsubr(Cell *args, Cell *env)
{
Cell *cell= 0;
GC_PROTECT(args);
GC_PROTECT(env);
if (args) {
cell= cons(car(args), 0);
GC_PROTECT(cell);
rplacd(globals, cons(cell, cdr(globals)));
cell= rplacd(cell, eval(cadr(args), env));
}
GC_UNPROTECT(args);
return cell;
}
Cell *setqFsubr(Cell *args, Cell *env)
{
Cell *key, *value= 0;
GC_PROTECT(args);
GC_PROTECT(env);
key= car(args);
if (symbolP(key)) {
Cell *cell;
value= eval(cadr(args), env);
GC_PROTECT(value);
cell= assq(key, env);
if (!cell) {
GC_UNPROTECT(args);
return undefined(key);
}
rplacd(cell, value);
}
GC_UNPROTECT(args);
return value;
}
Cell *lambdaFsubr(Cell *args, Cell *env)
{
return mkExpr(args, env);
}
Cell *flambdaFsubr(Cell *args, Cell *env)
{
return mkFexpr(args, env);
}
Cell *letFsubr(Cell *args, Cell *env)
{
Cell *cell, *tmp= 0;
GC_PROTECT(args);
GC_PROTECT(env);
GC_PROTECT(tmp);
for (cell= car(args); cell; cell= cdr(cell)) {
tmp= eval(cadar(cell), env);
tmp= cons(caar(cell), tmp);
env= cons(tmp, env);
}
GC_UNPROTECT(args);
return evlist(cdr(args), env);
}
Cell *orFsubr(Cell *args, Cell *env)
{
Cell *value;
GC_PROTECT(args);
GC_PROTECT(env);
for (value= 0; args && !value; args= cdr(args))
value= eval(car(args), env);
GC_UNPROTECT(args);
return value;
}
Cell *andFsubr(Cell *args, Cell *env)
{
Cell *value;
GC_PROTECT(args);
GC_PROTECT(env);
for (value= _S_t; args && value; args= cdr(args))
value= eval(car(args), env);
GC_UNPROTECT(args);
return value;
}
Cell *ifFsubr(Cell *args, Cell *env)
{
Cell *cell;
GC_PROTECT(args);
GC_PROTECT(env);
cell= (eval(car(args), env) ? eval(cadr (args), env) : eval(caddr(args), env));
GC_UNPROTECT(args);
return cell;
}
Cell *whileFsubr(Cell *args, Cell *env)
{
Cell *result= 0;
GC_PROTECT(args);
GC_PROTECT(env);
GC_PROTECT(result);
while (eval(car(args), env)) result= evlist(cdr(args), env);
GC_UNPROTECT(args);
return result;
}
Cell *mapArgs(Cell *args)
{
Cell *arg, *tail;
if (!args) return 0;
arg= caar(args);
GC_PROTECT(args);
GC_PROTECT(arg);
rplaca(args, cdar(args));
tail= mapArgs(cdr(args));
arg= cons(arg, tail);
GC_UNPROTECT(args);
return arg;
}
Cell *mapSubr(Cell *args, Cell *env)
{
Cell *fn= car(args), *head, *tail, *cell= 0;
GC_PROTECT(args);
GC_PROTECT(env);
GC_PROTECT(cell);
tail= head= cons(0, 0);
args= cdr(args);
while (car(args)) {
cell= mapArgs(args);
cell= apply(fn, cell, env);
tail= rplacd(tail, cons(cell, 0));
}
GC_UNPROTECT(args);
return cdr(head);
}
Cell *evalSubr(Cell *args, Cell *env)
{
Cell *evalArg= car(args);
Cell *evalEnv= cadr(args);
GC_PROTECT(args);
GC_PROTECT(env);
evalArg= eval(evalArg, evalEnv ? evalEnv : env);
GC_UNPROTECT(args);
return evalArg;
}
Cell *applySubr(Cell *args, Cell *env) { return apply(car(args), cdr(args), env); }
Cell *consSubr(Cell *args, Cell *env) { return cons(car(args), cadr(args)); }
Cell *rplacaSubr(Cell *args, Cell *env) { return rplaca(car(args), cadr(args)); }
Cell *rplacdSubr(Cell *args, Cell *env) { return rplacd(car(args), cadr(args)); }
Cell *carSubr(Cell *args, Cell *env) { return caar(args); }
Cell *cdrSubr(Cell *args, Cell *env) { return cdar(args); }
Cell *assqSubr(Cell *args, Cell *env) { return assq(car(args), cadr(args)); }
Cell *printlnSubr(Cell *args, Cell *env)
{
for (; args; args= cdr(args)) {
print(car(args), stdout);
if (cdr(args)) putchar(' ');
}
putchar('\n');
return 0;
}
#define arithmetic(name, id, op) \
Cell *name##Subr(Cell *args, Cell *env) \
{ \
if (cdr(args)) { \
long n= number(car(args)); \
for (args= cdr(args); args; args= cdr(args)) \
n op##= number(car(args)); \
return mkNumber(n); \
} \
return mkNumber(id op number(car(args))); \
}
arithmetic(add, 0, +)
arithmetic(subtract, 0, -)
arithmetic(multiply, 1, *)
arithmetic(divide, 1, /)
arithmetic(modulus, 1, %)
#undef arithmetic
#define relation(name, op) \
Cell *name##Subr(Cell *args, Cell *env) \
{ \
Cell *numbers; \
for (numbers= args; cdr(numbers); numbers= cdr(numbers)) \
if (!(number(car(numbers)) op number(cadr(numbers)))) \
return 0; \
return args; \
}
relation(less, < )
relation(lessEqual, <=)
relation(equal, ==)
relation(notEqual, !=)
relation(greaterEqual, >=)
relation(greater, > )
#undef relation
int numbersP2(Cell *args) { return numberP(car(args)) && numberP(cadr(args)); }
int numbersP3(Cell *args) { return numberP(car(args)) && numberP(cadr(args)) && numberP(caddr(args)); }
Cell *primToStringSubr(Cell *args) { return numberP(car(args)) ? mkString(strdup((char *)number(car(args)))) : 0; }
typedef void *ptr;
#define access(type) \
Cell *type##PeekSubr(Cell *args, Cell *env) { return numbersP2(args) ? mkNumber((long)((type *)number(car(args)))[number(cadr(args))]) : 0; } \
Cell *type##PokeSubr(Cell *args, Cell *env) { if (numbersP3(args)) ((type *)number(car(args)))[number(cadr(args))]= (type)number(caddr(args)); return caddr(args); }
access(char)
access(short)
access(int)
access(long)
access(ptr)
#undef access
#include <dlfcn.h>
void *rtldDefault= 0;
Cell *dlsymSubr(Cell *args, Cell *env) { return stringP(car(args)) ? mkPsubr(dlsym(rtldDefault, string(car(args)))) : 0; }
Cell *fsubrSubr(Cell *args, Cell *env) { return psubrP (car(args)) ? mkFsubr(psubr(car(args))) : 0; }
Cell *subrSubr (Cell *args, Cell *env) { return psubrP (car(args)) ? mkSubr (psubr(car(args))) : 0; }
int xFlag= 0;
int vFlag= 0;
Cell *repl(FILE *in)
{
Cell *expr= 0, *value= 0;
GC_PROTECT(expr);
GC_PROTECT(value);
while (!feof(in)) {
if (isatty(fileno(in))) {
printf("> ");
fflush(stdout);
}
expr= readFile(in);
if (CEOF == expr) break;
if (xFlag) println(expr, stderr);
if (expr) {
value= eval(expr, globals);
if (isatty(fileno(in))) println(value, stderr);
if (vFlag) { fprintf(stderr, "==> "); println(value, stderr); }
}
}
GC_UNPROTECT(expr);
return value;
}
#if !BDWGC
void markFunction(void *ptr)
{
Cell *cell= (Cell *)ptr;
assert(ptr);
switch (cell->mTag) {
case Number: case String: case Symbol: case Subr: case Fsubr:
return;
case Cons:
case Expr:
case Fexpr:
if (cell->mCons.a) GC_mark(cell->mCons.a);
if (cell->mCons.d) GC_mark(cell->mCons.d);
return;
default:
fatal("unknown tag");
}
}
void freeFunction(void *ptr)
{
Cell *cell= (Cell *)ptr;
switch (cell->mTag) {
case String: free((void *)string(cell)); return;
case Symbol: free((void *)symbol(cell)); return;
default: return;
}
}
#endif
int main(int argc, char **argv)
{
int i;
#if BDWGC
GC_INIT();
#else
GC_mark_function= markFunction;
GC_free_function= freeFunction;
#endif
for (i= 0; i < 256; ++i) readers[i]= readIllegal;
initReaders(readBlank, " \t\n\v\f\r");
initReaders(readDigit, "0123456789");
initReaders(readAlpha, "abcdefghijklmnopqrstuvwxyz");
initReaders(readAlpha, "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
initReaders(readAlpha, "!#$%&*/:<=>?@\\^_|~");
initReaders(readSign, "+-");
initReaders(readString, "\"");
initReaders(readQuote, "'");
initReaders(readQquote, "`");
initReaders(readUquote, ",");
initReaders(readList, "([{");
initReaders(readAlpha, ".");
initReaders(readSemi, ";");
rtldDefault= dlopen(0, RTLD_NOW | RTLD_GLOBAL);
_S_t = intern("t");
_S_quote = intern("quote");
_S_qquote = intern("quasiquote");
_S_uquote = intern("unquote");
_S_uquotes = intern("unquote-splicing");
globals= cons(cons(intern("t" ), _S_t ), globals);
globals= cons(cons(intern("dlsym" ), mkSubr (dlsymSubr )), globals);
globals= cons(cons(intern("fsubr" ), mkSubr (fsubrSubr )), globals);
globals= cons(cons(intern("subr" ), mkSubr (subrSubr )), globals);
globals= cons(cons(intern("define" ), mkFsubr(defineFsubr )), globals);
globals= cons((syntaxTable= cons(intern("*syntax-table*"), 0)), globals);
GC_PROTECT(globals);
GC_PROTECT(interns);
if (argc == 1) repl(stdin);
else {
for (++argv; argc > 1; --argc, ++argv) {
if (!strcmp(*argv, "-v")) vFlag= 1;
else if (!strcmp(*argv, "-x")) xFlag= 1;
else if (!strcmp(*argv, "-" )) repl(stdin);
else {
FILE *in= fopen(*argv, "r");
if (!in) perror(*argv);
else {
repl(in);
fclose(in);
}
}
}
}
return 0;
}
网友评论