greg/lysp
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Initial commit of Lysp v1.1 (http://piumarta.com/software/lysp/) code.

Browse source
This commit is contained in:
Gregory Burd 2013-07-25 21:43:50 -04:00
commit 29552c0757
7 changed files with 1543 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
.gitignore vendored Normal file
View file

@ -0,0 +1,23 @@
*~
*.lo
*.o
Makefile
Makefile.in
aclocal.m4
autom4te.cache/
config.log
config.status
configure
install-sh
missing
src/config.h
src/stamp-h1
config.guess
config.sub
depcomp
libtool
ltmain.sh
src/.deps/
src/.libs/
src/libbtds.la

30
00_README Normal file
View file

@ -0,0 +1,30 @@
LYSP: 50 Years of Symbolic Processing
Last weekend I was thinking about Ashwin Ram's "Short Ballad Dedicated to
the Growth of Programs" [1] and the result is LYSP: a tiny, lightweight Lisp
interpreter closely following the tradition of the earliest implementations.
It is dedicated to the inventor and first implementers of that language,
which is 50 years old this year. If you partially evaluate LYSP in Latin it
means "50 Years of Symbolic Processing".
IBM once made a dialect of Lisp called Lysp and published a paper about it.
As far as I know, it died shortly thereafter and so I have unilaterally
swept and reallocated the name. (If you know differently, please tell me.)
Being a weekend hack there are probably numerous bugs. If you find one,
send a description (or perferably a prescription) to the author (Ian
Piumarta) at firstName (at) lastName (dot) com. If you use it for something
interesting, I'd love to hear about that too.
It started off really small (about 150 LOC) but I got carried away. I hope
you will forgive the bloat. Compiled on x86 with gcc -Os it's about 17 KB
for the interpreter and 4 KB for the garbage collector (if you configure it
to use the cheesy, built-in, home-made, precise one -- rather than the
classy, incremental, conservative Boehm-Demers-Weiser one in /usr/lib).
That makes for about 21 KB of self-contained Lisp interpreter, including a
rudimentary (but useful) FFI and macros. If you do something interesting
with it in the embedded space, I'd love to hear about that too.
And yes: '(cdr (assq key a-list))' does exactly what you want it to in LYSP.
[1] http://www.apl.jhu.edu/~hall/lisp/Scheme-Ballad.text

17
bench.l Normal file
View file

@ -0,0 +1,17 @@
;;; -*- scheme -*-
(define lambda (fsubr (dlsym "lambdaFsubr")))
(define if (fsubr (dlsym "ifFsubr")))
(define println (subr (dlsym "printlnSubr")))
(define + (subr (dlsym "addSubr")))
(define - (subr (dlsym "subtractSubr")))
(define < (subr (dlsym "lessSubr")))
(define nfibs
(lambda (n)
(if (< n 2)
1
(+ 1 (nfibs (- n 1)) (nfibs (- n 2))))))
(println "running...")
(println (nfibs 28))

413
gc.c Normal file
View file

@ -0,0 +1,413 @@
/* gc.c -- trivial single-threaded stop-world non-moving mark-sweep collector
**
** 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: 2008-10-20 19:45:22 by piumarta on ubuntu.piumarta.com
*/
#include "gc.h"
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <string.h>
#define ALIGN sizeof(long)
#define QUANTUM 32768
#define ALLOCS_PER_GC 10000
#define VERBOSE 0
typedef struct _gcheader
{
union {
int flags;
struct {
unsigned int used : 1;
unsigned int atom : 1;
unsigned int mark : 1;
};
};
struct _gcheader *prev;
struct _gcheader *next;
size_t size;
} gcheader;
static inline void *hdr2ptr(gcheader *hdr) { return (void *)(hdr + 1); }
static inline gcheader *ptr2hdr(void *ptr) { return (gcheader *)ptr - 1; }
static gcheader gcbase= { { -1 }, &gcbase, &gcbase, 0 };
static gcheader *gcnext= &gcbase;
static int gcCount= ALLOCS_PER_GC;
void *GC_malloc(size_t lbs)
{
gcheader *hdr, *org;
if (!gcCount--) {
gcCount= ALLOCS_PER_GC;
GC_gcollect();
}
org= hdr= gcnext;
lbs= (lbs + ALIGN-1) & ~(ALIGN-1);
#if VERBOSE > 1
printf("malloc %d\n", lbs);
#endif
again:
#if VERBOSE > 3
{
gcheader *h= gcnext;
do {
printf(" %2d %p <- %p -> %p = %x\n", h->flags, h->prev, h, h->next, h->size);
h= h->next;
} while (h != gcnext);
}
#endif
do {
#if VERBOSE > 2
printf("? %2d %p <- %p -> %p = %x\n", hdr->flags, hdr->prev, hdr, hdr->next, hdr->size);
#endif
if ((!hdr->used) && (hdr->size >= lbs))
{
void *mem;
if (hdr->size >= lbs + sizeof(gcheader) + ALIGN)
{
gcheader *ins= (gcheader *)(hdr2ptr(hdr) + lbs);
ins->flags= 0;
ins->prev= hdr;
ins->next= hdr->next;
ins->size= hdr->size - lbs - sizeof(gcheader);
hdr->next->prev= ins;
hdr->next= ins;
hdr->size= lbs;
}
hdr->used= 1;
gcnext= hdr->next;
#if VERBOSE > 2
printf("MALLOC %p\n", hdr);
#endif
mem= hdr2ptr(hdr);
memset(mem, 0, hdr->size);
return mem;
}
hdr= hdr->next;
} while (hdr != org);
{
size_t incr= QUANTUM;
size_t req= sizeof(gcheader) + lbs;
while (incr <= req) incr *= 2;
hdr= (gcheader *)sbrk(incr);
if (hdr != (gcheader *)-1)
{
hdr->flags= 0;
hdr->next= &gcbase;
hdr->prev= gcbase.prev;
hdr->prev->next= hdr;
gcbase.prev= hdr;
hdr->size= incr - sizeof(gcheader);
#if VERBOSE
printf("extend by %d at %p\n", hdr->size, hdr);
#endif
goto again;
}
}
printf("out of memory\n");
return 0;
}
void *GC_malloc_atomic(size_t lbs)
{
void *mem= GC_malloc(lbs);
ptr2hdr(mem)->atom= 1;
return mem;
}
void *GC_realloc(void *ptr, size_t lbs)
{
gcheader *hdr= ptr2hdr(ptr);
void *mem;
if (lbs <= hdr->size) return ptr;
mem= GC_malloc(lbs);
memcpy(mem, ptr, hdr->size);
ptr2hdr(mem)->atom= hdr->atom;
GC_free(ptr);
return mem;
}
gcheader *GC_freeHeader(gcheader *hdr)
{
#if VERBOSE > 1
printf("FREE %p\n", hdr);
#endif
hdr->flags= 0;
if ((!hdr->prev->flags) && (hdr2ptr(hdr->prev) + hdr->prev->size == hdr))
{
#if VERBOSE > 2
printf("COALESCE PREV %p\n", hdr->prev);
#endif
hdr->prev->next= hdr->next;
hdr->next->prev= hdr->prev;
hdr->prev->size += sizeof(gcheader) + hdr->size;
hdr= hdr->prev;
}
if ((!hdr->next->used) && (hdr2ptr(hdr) + hdr->size == hdr->next))
{
#if VERBOSE > 2
printf("COALESCE NEXT %p\n", hdr->next);
#endif
hdr->size += sizeof(gcheader) + hdr->next->size;
hdr->next= hdr->next->next;
hdr->next->prev= hdr;
}
#if VERBOSE > 3
{
gcheader *h= &gcbase;
do {
printf(" %2d %p <- %p -> %p = %x\n", h->flags, h->prev, h, h->next, h->size);
h= h->next;
} while (h != &gcbase);
}
#endif
return hdr;
}
void GC_free(void *ptr)
{
gcnext= GC_freeHeader(ptr2hdr(ptr));
}
void GC_default_mark_function(void *ptr)
{
gcheader *hdr= ptr2hdr(ptr);
void **pos= ptr;
void **lim= hdr2ptr(hdr) + hdr->size - sizeof(void *);
while (pos <= lim)
{
void *field= *pos;
if (field && !((long)field & 1))
GC_mark(field);
++pos;
}
}
GC_mark_function_t GC_mark_function= GC_default_mark_function;
void GC_mark(void *ptr)
{
gcheader *hdr= ptr2hdr(ptr);
#if VERBOSE > 2
printf("mark? %p %d\n", hdr, hdr->flags);
#endif
if (!hdr->mark) {
hdr->mark= 1;
if (!hdr->atom)
GC_mark_function(ptr);
}
}
GC_free_function_t GC_free_function= 0;
void GC_sweep(void)
{
gcheader *hdr= gcbase.next;
do {
#if VERBOSE > 2
printf("sweep? %p %d\n", hdr, hdr->flags);
#endif
if (hdr->flags)
{
if (hdr->mark)
hdr->mark= 0;
else {
if (GC_free_function) GC_free_function(hdr2ptr(hdr));
hdr= GC_freeHeader(hdr);
}
}
hdr= hdr->next;
} while (hdr != &gcbase);
gcnext= gcbase.next;
}
static void ***roots= 0;
static size_t numRoots= 0;
static size_t maxRoots= 0;
struct GC_StackRoot *GC_stack_roots= 0;
void GC_add_root(void *root)
{
if (numRoots == maxRoots)
roots= maxRoots
? realloc(roots, sizeof(roots[0]) * (maxRoots *= 2))
: malloc ( sizeof(roots[0]) * (maxRoots= 128));
roots[numRoots++]= (void **)root;
}
void GC_delete_root(void *root)
{
int i;
for (i= 0; i < numRoots; ++i)
if (roots[i] == (void **)root)
break;
if (i < numRoots)
{
memmove(roots + i, roots + i + 1, sizeof(roots[0]) * (numRoots - i));
--numRoots;
}
}
void GC_gcollect(void)
{
int i;
struct GC_StackRoot *sr;
for (i= 0; i < numRoots; ++i) if (*roots[i]) GC_mark(*roots[i]);
for (sr= GC_stack_roots; sr; sr= sr->next) if (*(sr->root)) GC_mark(*(sr->root));
GC_sweep();
}
size_t GC_count_objects(void)
{
gcheader *hdr= gcbase.next;
size_t count= 0;
do {
if (hdr->flags)
++count;
hdr= hdr->next;
} while (hdr != &gcbase);
return count;
}
size_t GC_count_bytes(void)
{
gcheader *hdr= gcbase.next;
size_t count= 0;
do {
if (hdr->flags)
count += hdr->size;
hdr= hdr->next;
} while (hdr != &gcbase);
return count;
}
#if 0
#include <stdlib.h>
#define RAND(N) (1 + (int)((float)N * (rand() / (RAND_MAX + 1.0))))
struct cell { int tag; struct cell *next; };
void *mklist(int n)
{
struct cell *cell;
if (!n) return 0;
cell= GC_malloc(8);
cell->tag= n << 1 | 1;
cell->next= mklist(n - 1);
return cell;
}
void delist(struct cell *cell)
{
if (cell && cell->next && cell->next->next) {
cell->next= cell->next->next;
delist(cell->next->next);
}
}
int main()
{
int i, j;
void *a, *b, *c, *d, *e;
for (i= 0; i < 1000000; ++i) {
#if !VERBOSE
# define printf(...)
#endif
//#define GC_malloc malloc
//#define GC_free free
a= GC_malloc(RAND(1)); printf("%p\n", a);
b= GC_malloc(RAND(10)); printf("%p\n", b);
c= GC_malloc(RAND(100)); printf("%p\n", c);
d= GC_malloc(RAND(1000)); printf("%p\n", d);
e= GC_malloc(RAND(10000)); printf("%p\n", e);
GC_free(a);
GC_free(b);
// GC_free(c);
GC_free(d);
GC_free(e);
a= GC_malloc(RAND(100)); printf("%p\n", a);
b= GC_malloc(RAND(200)); printf("%p\n", b);
c= GC_malloc(RAND(300)); printf("%p\n", c);
d= GC_malloc(RAND(400)); printf("%p\n", d);
e= GC_malloc(RAND(500)); printf("%p\n", e);
GC_free(e);
GC_free(d);
// GC_free(c);
GC_free(b);
GC_free(a);
a= GC_malloc(RAND(4)); printf("%p\n", a);
b= GC_malloc(RAND(16)); printf("%p\n", b);
c= GC_malloc(RAND(64)); printf("%p\n", c);
d= GC_malloc(RAND(256)); printf("%p\n", d);
e= GC_malloc(RAND(1024)); printf("%p\n", e);
GC_free(e);
GC_free(b);
// GC_free(c);
GC_free(d);
GC_free(a);
a= GC_malloc(RAND(713)); printf("%p\n", a);
b= GC_malloc(RAND(713)); printf("%p\n", b);
c= GC_malloc(RAND(713)); printf("%p\n", c);
d= GC_malloc(RAND(713)); printf("%p\n", d);
e= GC_malloc(RAND(713)); printf("%p\n", e);
GC_free(a);
GC_free(c);
// GC_free(e);
GC_free(d);
GC_free(b);
#undef printf
if (i % 100000 == 0) printf("alive: %d bytes in %d objects\n", GC_count_bytes(), GC_count_objects());
GC_sweep();
if (i % 100000 == 0) printf("alive: %d bytes in %d objects\n", GC_count_bytes(), GC_count_objects());
}
{
GC_PROTECT(a);
for (i= 0; i < 100; ++i) {
for (j= 0; j < 100; ++j) {
a= mklist(2000);
delist(a);
#if VERBOSE
{
struct cell *c= a;
printf("----\n");
while (c) {
printf("%p %d %p\n", c, c->tag >> 1, c->next);
c= c->next;
}
}
#endif
}
GC_gcollect();
}
GC_UNPROTECT(a);
}
printf("alive: %d bytes in %d objects\n", GC_count_bytes(), GC_count_objects());
GC_sweep();
printf("alive: %d bytes in %d objects\n", GC_count_bytes(), GC_count_objects());
return 0;
}
#endif

54
gc.h Normal file
View file

@ -0,0 +1,54 @@
#ifndef _GC_H_
#define _GC_H_
#include <sys/types.h>
struct GC_StackRoot
{
void **root;
struct GC_StackRoot *next;
};
#define GC_PROTECT(V) struct GC_StackRoot _sr_##V; _sr_##V.root= (void *)&V; GC_push_root(&_sr_##V)
#define GC_UNPROTECT(V) GC_pop_root(&_sr_##V)
#define GC_INIT()
#define GC_init()
void *GC_malloc(size_t nbytes);
void *GC_malloc_atomic(size_t nbytes);
void GC_free(void *ptr);
void GC_add_root(void *root);
void GC_delete_root(void *root);
void GC_mark(void *ptr);
void GC_sweep(void);
void GC_gcollect(void);
size_t GC_count_objects(void);
size_t GC_count_bytes(void);
extern struct GC_StackRoot *GC_stack_roots;
static inline void GC_push_root(struct GC_StackRoot *sr)
{
sr->next= GC_stack_roots;
GC_stack_roots= sr;
}
static inline void GC_pop_root(struct GC_StackRoot *sr)
{
#if 1
GC_stack_roots= sr->next;
#else /* paranoid version for broken code warns of mismatched pops with a SEGV */
struct GC_StackRoot *nr= sr->next;
while (nr != GC_stack_roots)
GC_stack_roots= GC_stack_roots->next;
#endif
}
typedef void (*GC_mark_function_t)(void *ptr);
extern GC_mark_function_t GC_mark_function;
typedef void (*GC_free_function_t)(void *ptr);
extern GC_free_function_t GC_free_function;
#endif /* _GC_H_ */

861
lysp.c Normal file
View file

@ -0,0 +1,861 @@
/* 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;
}

145
test.l Normal file
View file

@ -0,0 +1,145 @@
;;; -*- scheme -*-
;;; initial environment contains: t dlsym fsubr subr define
(define nil ())
(define flambda (fsubr (dlsym "flambdaFsubr")))
(define lambda (fsubr (dlsym "lambdaFsubr")))
(define let (fsubr (dlsym "letFsubr")))
(define if (fsubr (dlsym "ifFsubr")))
(define while (fsubr (dlsym "whileFsubr")))
(define setq (fsubr (dlsym "setqFsubr")))
(define cons (subr (dlsym "consSubr")))
(define rplaca (subr (dlsym "rplacaSubr")))
(define rplacd (subr (dlsym "rplacdSubr")))
(define car (subr (dlsym "carSubr")))
(define cdr (subr (dlsym "cdrSubr")))
(define eval (subr (dlsym "evalSubr")))
(define apply (subr (dlsym "applySubr")))
(define map (subr (dlsym "mapSubr")))
(define assq (subr (dlsym "assqSubr")))
(define println (subr (dlsym "printlnSubr")))
(define + (subr (dlsym "addSubr")))
(define - (subr (dlsym "subtractSubr")))
(define * (subr (dlsym "multiplySubr")))
(define / (subr (dlsym "divideSubr")))
(define % (subr (dlsym "modulusSubr")))
(define < (subr (dlsym "lessSubr")))
(define <= (subr (dlsym "lessEqualSubr")))
(define == (subr (dlsym "equalSubr")))
(define != (subr (dlsym "notEqualSubr")))
(define >= (subr (dlsym "greaterEqualSubr")))
(define > (subr (dlsym "greaterSubr")))
(define println (subr (dlsym "printlnSubr")))
(define caar (lambda (x) (car (car x))))
(define cadr (lambda (x) (car (cdr x))))
(define cdar (lambda (x) (cdr (car x))))
(define cddr (lambda (x) (cdr (cdr x))))
(define cadar (lambda (x) (car (cdr (car x)))))
(define caddar (lambda (x) (car (cdr (cdr (car x))))))
(define quote (flambda (form) (car form)))
(define list (lambda args args))
(define global-environment
(let ((globals ((flambda (args env) env))))
(lambda () globals)))
(define double (lambda (x) (+ x x)))
(double 21)
(define make-counter (lambda (n) (lambda () (setq n (+ n 1)))))
(define counter (make-counter 40))
(counter)
(counter)
(counter)
(counter)
(counter)
'(+ 3 4)
(eval '(+ 3 4))
(apply + 3 4)
(let ((x 0))
(while (< x 10)
(println (setq x (+ 1 x)))))
(setq *syntax-table*
(cons (cons 'for
(flambda (form)
(list 'let (list (list (caar form) (cadar form)))
(list 'while (list '<= (caar form) (caddar form))
(cadr form)
(list 'setq (caar form) (list '+ 1 (caar form)))))))
*syntax-table*))
(for (i 0 10) (println i))
(define nfibs
(lambda (n)
(if (< n 2)
1
(+ 1 (nfibs (- n 1)) (nfibs (- n 2))))))
(nfibs 20)
(eval '(+ a b) (cons '(a . 3) (cons '(b . 4) (global-environment))))
(define dict '((foo . 1)(bar . 2)(baz . 3)))
(assq 'bar dict)
(define assqval (lambda (key alist) (cdr (assq key alist))))
(assqval 'foo dict)
(assqval 'bar dict)
(assqval 'baz dict)
(assqval 'qux dict)
(define puts (dlsym "puts"))
(puts "Hello, world")
(define malloc (dlsym "malloc"))
(define free (dlsym "free"))
(define sprintf (dlsym "sprintf"))
(let ((memory (malloc 1024)))
(sprintf memory "Hello %s world %d" "primitive" 42)
(puts memory)
(free memory))
(define set-int (subr (dlsym "intPokeSubr")))
(define get-char (subr (dlsym "charPeekSubr")))
(let ((memory (malloc 1024)))
(set-int memory 0 0x01020304)
(set-int memory 1 0x05060708)
(sprintf memory "%02x %02x %02x %02x %02x %02x %02x %02x"
(get-char memory 0) (get-char memory 1) (get-char memory 2) (get-char memory 3)
(get-char memory 4) (get-char memory 5) (get-char memory 6) (get-char memory 7))
(puts memory)
(free memory))
(define set-char (subr (dlsym "charPokeSubr")))
(define ptr->string (subr (dlsym "primToStringSubr")))
(define make-string
(lambda ()
(let ((memory (malloc 8)))
(set-char memory 0 65)
(set-char memory 1 66)
(set-char memory 2 67)
(set-char memory 3 0)
(puts memory)
(let ((s (ptr->string memory)))
(free memory)
s))))
(define exit (dlsym "exit"))
(exit 0)