Initial commit of Lysp v1.1 (http://piumarta.com/software/lysp/) code.
This commit is contained in:
commit
29552c0757
7 changed files with 1543 additions and 0 deletions
23
.gitignore
vendored
Normal file
23
.gitignore
vendored
Normal 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
30
00_README
Normal 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
17
bench.l
Normal 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
413
gc.c
Normal 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
54
gc.h
Normal 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
861
lysp.c
Normal 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
145
test.l
Normal 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)
|
Loading…
Reference in a new issue