conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

import from compiler2

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:40:06 -05:00
parent 3e7726203a
commit bd94bedc04
66 changed files with 4447 additions and 23873 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Makefile
View File

@ -1,2 +1,8 @@
stst: stst.s scheme.c scheme_asm.s runtime-5.4.c collect-5.7.c libtoplevel.s libcxr.s -luuid libsymboltable-5.6.s libhandlers-5.5.s libcontrol-5.8.s libintelasm-5.8.s libcollect-5.3.s librecord-5.6.s libcore-5.7.s libio-5.8.s libwriter-5.7.s libtokenizer-5.7.s libexpand-5.8.s libinterpret-5.8.s libcafe-5.8.s libtrace-5.3.s libposix-5.3.s
gcc -Wall -o stst stst.s scheme.c scheme_asm.s runtime-5.4.c collect-5.7.c libtoplevel.s libcxr.s -luuid libsymboltable-5.6.s libhandlers-5.5.s libcontrol-5.8.s libintelasm-5.8.s libcollect-5.3.s librecord-5.6.s libcore-5.7.s libio-5.8.s libwriter-5.7.s libtokenizer-5.7.s libexpand-5.8.s libinterpret-5.8.s libcafe-5.8.s libtrace-5.3.s libposix-5.3.s all: ikarus.fasl
ikarus.fasl:
echo '(load "compiler-6.1.ss")' | petite
clean:
rm -f *.fasl

2
src/build-date.tmp
View File

@ -1 +1 @@
2006-07-27 2006-07-28

839
src/collect-5.7.c
View File

@ -1,839 +0,0 @@
#include <stdio.h>
#include <stdint.h>
#include <stdlib.h>
#include <unistd.h>
#include <string.h>
#include <sys/mman.h>
#include <sys/types.h>
#include <assert.h>
#include <uuid/uuid.h>
#include "scheme.h"
typedef struct root_t{
int count;
char** start;
struct root_t* next;
} root_t;
void S_add_roots(pcb_t* pcb, int* f){
int n = *f;
if(n == 0) return;
root_t* t = malloc(sizeof(root_t));
if(t == NULL){
fprintf(stderr, "Error mallocing\n");
exit(-1);
}
t->count = n;
t->start = (char**)(f+1);
t->next = (root_t*) pcb->roots;
pcb->roots = (char*) t;
int i;
for(i=1; i<=n; i++){
assert(f[i] == 0);
}
}
void S_check_roots(pcb_t* pcb, int* f){
int n = *f;
int i;
for(i=1; i<=n; i++){
assert(f[i] != 0);
}
}
/* S_collect is called from scheme under the following conditions:
* 1. An attempt is made to allocate a small object and the ap is above
* the red line.
* 2. The current frame of the call is dead, so, upon return from S_collect,
* the caller returns to its caller.
* 3. The frame-pointer of the caller to S_collect is saved at
* pcb->stack_extent. No variables are live at that frame except for
* the return point (at *(pcb->stack_extent)).
* 4. S_collect must return a new ap (in pcb->allocation_pointer) that has
* at least 2 pages of memory free.
* 5. S_collect must also update pcb->allocaton_red_line to be 2 pages below
* the real end of heap.
* 6. S_collect should not move the stack.
*/
#define pagesize 4096
#define pageshift 12
#define minimum_heap_size (pagesize * 1024 * 4)
#define maximum_heap_size (pagesize * 1024 * 8)
#define minimum_stack_size (pagesize * 128)
#define align_to_page(x) (((x)/pagesize)*pagesize)
#define align_to_next_page(x) \
(((pagesize - 1 + (unsigned int)(x)) >> pageshift) << pageshift)
#define align_to_prev_page(x) \
((((unsigned int)(x)) >> pageshift) << pageshift)
static char* allocate_unprotected_space(int size);
static void deallocate_unprotected_space(char* p, int size);
static void deallocate_string_pages(char*);
static void copy_roots(pcb_t* pcb);
static char* move_object(char* x, pcb_t* pcb);
pcb_t* S_collect(int req, pcb_t* pcb){
#if 0
fprintf(stderr, "S_collect entry %d (pcb=0x%08x)\n", req, (int)pcb);
#endif
char* heap_base = pcb->heap_base;
#if 0
int heap_size = (int)pcb->heap_size;
fprintf(stderr, "heapsize=0x%08x (0x%08x .. 0x%08x)\n",
heap_size,
(int) heap_base,
(int) (heap_base + heap_size - 1));
#endif
int used_space = (int)(pcb->allocation_pointer - heap_base);
{
int bytes = (int) pcb->allocated_bytes + (used_space & 0xFFFFF);
pcb->allocated_megs += (bytes >> 20);
pcb->allocated_bytes = (char*) (bytes & 0xFFFFF);
#if 0
fprintf(stderr, "allocated %d megs and %d bytes so far\n",
(int) pcb->allocated_megs,
(int) pcb->allocated_bytes);
#endif
}
int required_space = align_to_page(used_space + 2 * req + 2 * pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
if(required_space > maximum_heap_size){
fprintf(stderr, "Maximum heapsize exceeded\n");
exit(-1);
}
char* old_heap = pcb->heap_base;
int old_size = (int)pcb->heap_size;
char* old_string_pages = pcb->string_pages;
pcb->string_pages = 0;
char* new_heap = allocate_unprotected_space(maximum_heap_size);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + maximum_heap_size - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) maximum_heap_size;
copy_roots(pcb);
char** p = (char**) new_heap;
while(p != (char**) pcb->allocation_pointer){
*p = move_object(*p, pcb);
p++;
}
deallocate_unprotected_space(old_heap, old_size);
deallocate_string_pages(old_string_pages);
{
int free_space =
(int)pcb->allocation_redline - (int)pcb->allocation_pointer;
int diff = align_to_page(free_space - minimum_heap_size);
if(diff > 0){
deallocate_unprotected_space(
pcb->heap_base + (int)pcb->heap_size - diff,
diff);
pcb->allocation_redline -= diff;
pcb->heap_size -= diff;
}
}
#if 0
fprintf(stderr, "ap=0x%08x limit=0x%08x\n",
(int)pcb->allocation_pointer,
(int)pcb->heap_base+(int)pcb->heap_size-wordsize);
#endif
return pcb;
}
#define fixnump(x) ((((int)(x)) & fx_mask) == fx_tag)
#define closurep(x) ((((int)(x)) & closure_mask) == closure_tag)
#define immediatep(x) ((((int)(x)) & 7) == 7)
#define tagof(x) (((int) (x)) & 7)
#define ref(x,t) (*((char**)(((char*)(x))+((int)(t)))))
#define align(x) ((((x)+object_alignment-1)>>align_shift)<<align_shift)
typedef struct page_t{
char* base;
char* end;
struct page_t* next;
} page_t;
static page_t* make_page_t(){
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate page");
exit(-1);
}
return p;
}
static void deallocate_string_pages(char* old_string_pages){
page_t* p;
p = (page_t*) old_string_pages;
while(p){
deallocate_unprotected_space(p->base, p->end - p->base);
p=p->next;
}
p = (page_t*) old_string_pages;
while(p){
page_t* n = p->next;
free(p);
p = n;
}
}
#if 0
static char* extend_pointer_ap(pcb_t* pcb, int size){
if(pcb->pointer_base){
page_t* p = make_page_t();
p->base = pcb->pointer_base;
p->end = pcb->pointer_ap;
p->next = (page_t*) pcb->pointer_pages;
pcb->pointer_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->pointer_base = ap;
pcb->pointer_ap = ap;
pcb->pointer_eap = ap + size;
return ap;
}
#endif
static char* alloc_large_string(pcb_t* pcb, int size){
char* ap = allocate_unprotected_space(size);
page_t* p = make_page_t();
p->base = ap;
p->end = ap+size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
return ap;
}
static char* extend_string_ap(pcb_t* pcb, int size){
if(pcb->string_base){
page_t* p = make_page_t();
p->base = pcb->string_base;
p->end = pcb->string_ap;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
char* ap = allocate_unprotected_space(size);
pcb->string_base = ap;
pcb->string_ap = ap;
pcb->string_eap = ap + size;
return ap;
}
static char* move_string(char* s, pcb_t* pcb){
int len = (int) ref(s, -string_tag);
int sz = align((len>>fx_shift)+disp_string_data+1);
if(sz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + sz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + sz;
}
pcb->string_ap = nap;
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
else {
char* ap = alloc_large_string(pcb, sz);
memcpy(ap, s-string_tag, sz);
ref(s,-string_tag) = (char*)-1;
ref(s,wordsize-string_tag) = ap+string_tag;
return ap + string_tag;
}
}
static void munch_stack(char* fp, pcb_t* pcb, char* frame_base){
while(fp != frame_base){
assert(fp < frame_base);
#if 0
fprintf(stderr, "copying frame at 0x%08x of 0x%08x\n",
(int)fp, (int)stack_base);
#endif
char* rp = ref(fp, 0);
#if 0
fprintf(stderr, "return-point = 0x%08x\n", (int)rp);
#endif
char* rp_offset = ref(rp, disp_frame_offset);
assert(rp_offset == 0);
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + disp_frame_size - bytes_in_mask;
fp = fp + framesize;
char** fpp = (char**) fp;
int i;
for(i=0; i<bytes_in_mask; i++){
unsigned char m = mask[i];
if(m){
if (m & 0x01) {
fpp[0] = move_object(fpp[0], pcb);
}
if (m & 0x02) {
fpp[-1] = move_object(fpp[-1], pcb);
}
if (m & 0x04) {
fpp[-2] = move_object(fpp[-2], pcb);
}
if (m & 0x08) {
fpp[-3] = move_object(fpp[-3], pcb);
}
if (m & 0x10) {
fpp[-4] = move_object(fpp[-4], pcb);
}
if (m & 0x20) {
fpp[-5] = move_object(fpp[-5], pcb);
}
if (m & 0x40) {
fpp[-6] = move_object(fpp[-6], pcb);
}
if (m & 0x80) {
fpp[-7] = move_object(fpp[-7], pcb);
}
}
fpp -= 8;
}
}
else if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
assert(framesize > 0);
#if 0
/* move cp */
{
char* cp = ref(fp, 2*wordsize);
assert(closurep(cp));
ref(fp, 2*wordsize) = move_object(cp, pcb);
}
#endif
fp += framesize;
int i;
for(i=wordsize; i<(framesize); i+=wordsize){
ref(fp, -i) = move_object(ref(fp,-i), pcb);
}
}
else {
fprintf(stderr, "Error: framesize is %d\n", framesize);
exit(-10);
}
}
}
static char* move_stack(char* s, pcb_t* pcb, int sz){
char* ns;
int asz = align(sz);
if(asz < pagesize){
char* ap = pcb->string_ap;
char* nap = ap + asz;
if(nap > pcb->string_eap){
ap = extend_string_ap(pcb, pagesize);
pcb->string_eap = ap + pagesize;
nap = ap + asz;
}
pcb->string_ap = nap;
ns = ap;
}
else {
ns = alloc_large_string(pcb, asz);
}
memcpy(ns, s, sz);
munch_stack(ns, pcb, ns+sz);
return ns;
}
static char* move_pointers(char* x, pcb_t* pcb, int size, int tag){
int sz = align(size);
char* ap = pcb->allocation_pointer;
char* nap = ap + sz;
pcb->allocation_pointer = nap;
ref(nap, -wordsize) = 0;
memcpy(ap, x, size);
ref(x,0) = (char*)-1;
ref(x,wordsize) = ap + tag;
return ap + tag;
}
static char* move_continuation(char* x, pcb_t* pcb){
int sz = (int) ref(x, disp_continuation_size);
char* top = ref(x, disp_continuation_top);
char* r = move_pointers(x, pcb, continuation_size, vector_tag);
ref(r, disp_continuation_top - vector_tag) = move_stack(top, pcb, sz);
return r;
}
static char* move_code(char* x, pcb_t* pcb){
int instrsize = (int) ref(x, disp_code_instrsize);
if(instrsize == 0){
return (x + vector_tag);
}
int relocsize = (int) ref(x, disp_code_relocsize);
int reqspace = instrsize + relocsize + disp_code_data;
char* nx = allocate_unprotected_space(reqspace);
{
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to alloc a page_t\n");
exit(-1);
}
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
p->base = nx;
p->end = nx + reqspace;
}
memcpy(nx, x, reqspace);
ref(x, 0) = (char*)-1;
ref(x, wordsize) = nx + vector_tag;
{
char* p = nx + disp_code_data + instrsize;
char* pe = p + relocsize;
while(p < pe){
int r = (int) ref(p,0);
if(r == 0){
p = pe;
}
else {
int rtag = r & 3;
if(rtag == 0){
/* undisplaced pointer */
int code_offset = r >> 2;
char* old_object = ref(nx, disp_code_data + code_offset);
char* new_object = move_object(old_object, pcb);
ref(nx, disp_code_data + code_offset) = new_object;
p += wordsize;
}
else if(rtag == 1){
/* displaced pointer */
int code_offset = r >> 2;
int object_offset = (int) ref(p, wordsize);
char* old_displaced_object = ref(nx, disp_code_data + code_offset);
char* old_object = old_displaced_object - object_offset;
char* new_object = move_object(old_object, pcb);
char* new_displaced_object = new_object + object_offset;
ref(nx, disp_code_data + code_offset) = new_displaced_object;
p += (2 * wordsize);
}
else if(rtag == 2){
/* displaced relative pointer */
int code_offset = r >> 2;
int relative_offset = (int) ref(p, wordsize);
char* old_relative_pointer = ref(nx, disp_code_data + code_offset);
char* old_relative_object = old_relative_pointer - relative_offset;
char* old_addr = x + disp_code_data + code_offset + wordsize;
char* old_object = old_relative_object + (unsigned int) old_addr;
char* new_object = move_object(old_object, pcb);
char* new_disp_object = new_object + relative_offset;
char* next_word = nx + disp_code_data + code_offset + wordsize;
char* new_relative_pointer =
new_disp_object - (unsigned int) next_word;
ref(next_word, -wordsize) = new_relative_pointer;
p += (2 * wordsize);
}
else {
fprintf(stderr, "invalid rtag %d in 0x%08x\n", rtag, r);
exit(-1);
}
}
}
}
int err = mprotect(nx,
align_to_next_page(reqspace),
PROT_READ | PROT_WRITE | PROT_EXEC);
if(err == -1){
perror("Cannot set code executable");
exit(-1);
}
return nx + vector_tag;
}
static char* move_object(char* x, pcb_t* pcb){
if(fixnump(x)){
return x;
}
else if(immediatep(x)){
return x;
}
else {
int tag = tagof(x);
char* fst = ref(x, -tag);
if(fst == (char*)-1){
return ref(x,wordsize-tag);
}
else if(tag == pair_tag){
return(move_pointers(x-tag, pcb, pair_size, tag));
}
else if(tag == closure_tag){
//assert(ref(fst, -2*wordsize) == 0);
int size = (int) ref(fst, -wordsize);
assert(fixnump(size));
assert(size > 0);
char* new_closure = move_pointers(x-tag, pcb, size, tag);
char* code_entry = ref(new_closure, -closure_tag);
char* code_object = code_entry - disp_code_data + vector_tag;
char* new_code_object = move_object(code_object, pcb);
char* new_code_entry = new_code_object + disp_code_data - vector_tag;
ref(new_closure, -closure_tag) = new_code_entry;
return new_closure;
}
else if(tag == symbol_tag){
return (move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
if(fixnump(fst)){
return (move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
else if(fst == (char*) continuation_tag){
return (move_continuation(x-tag, pcb));
}
else if(fst == (char*) code_tag){
return (move_code(x-tag, pcb));
}
else if(((int)fst & record_pmask) == record_ptag){
int len;
{
char* rtd = fst;
char* rtd_fst = ref(rtd, -record_ptag);
if(rtd_fst == (char*) -1){
rtd = ref(rtd, wordsize-record_ptag);
}
len = (int) ref(rtd, disp_record_data - record_ptag);
}
return (move_pointers(x-tag, pcb, disp_record_data + len, tag));
}
else {
fprintf(stderr, "nonvec 0x%08x 0x%08x\n", (int)x, (int)fst);
exit(-1);
}
}
else if(tag == string_tag){
return (move_string(x, pcb));
}
else {
fprintf(stderr, "here tag=%d\n", tag);
exit(-1);
}
}
}
static void copy_roots(pcb_t* pcb){
/* first, the constants */
root_t* r = (root_t*)pcb->roots;
while(r){
int n = r->count;
char** f = r->start;
int i;
for(i=0; i<n; i++){
f[i] = move_object(f[i], pcb);
}
r = r->next;
}
/* next, the pcb-primitives */
char** fst = &pcb->scheme_objects;
char** end = &pcb->scheme_objects_end;
fst++;
while(fst < end){
*fst = move_object(*fst, pcb);
fst++;
}
/* next, the stack */
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
munch_stack(fp, pcb, frame_base);
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}
void S_stack_overflow(pcb_t* pcb){
// fprintf(stderr, "stack overflow detected\n");
char* stack_top = pcb->stack_top;
int stack_size = (int) pcb->stack_size;
char* fp = pcb->frame_pointer;
char* frame_base = pcb->frame_base;
assert(fp != frame_base);
char* rp = ref(fp, 0);
int framesize = (int) ref(rp, disp_frame_size); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize == 0){
framesize = (int)ref(fp, wordsize);
assert(fixnump(framesize));
}
// fprintf(stderr, "framesize = %d bytes\n", framesize);
{ /* capture continuation */
char* next_frame_top = fp + framesize;
if(next_frame_top == frame_base){
fprintf(stderr, "continuation already captured\n");
} else {
//fprintf(stderr, "capturing continuation ... ");
char* cont = pcb->allocation_pointer;
pcb->allocation_pointer += continuation_size;
ref(cont, 0) = (char*) continuation_tag;
ref(cont, disp_continuation_top) = next_frame_top;
ref(cont, disp_continuation_next) = pcb->next_continuation;
ref(cont, disp_continuation_size) =
frame_base - (int)next_frame_top;
pcb->next_continuation = cont + vector_tag;
//fprintf(stderr, "done (sz=0x%08x)\n",
// (int) ref(cont, disp_continuation_size));
}
}
int req_stack_size = align_to_page(framesize * 4 + 2 * pagesize);
if(req_stack_size < minimum_stack_size){
req_stack_size = minimum_stack_size;
}
char* new_stack = allocate_unprotected_space(req_stack_size);
char* new_frame_redline = new_stack + 2 * pagesize;
char* new_frame_base = new_stack + req_stack_size - wordsize;
ref(new_frame_base, 0) = ref(frame_base, 0); /* underflow handler */
memcpy(new_frame_base - framesize, fp, framesize);
pcb->stack_top = new_stack;
pcb->stack_size = (char*)req_stack_size;
pcb->frame_base = new_frame_base;
pcb->frame_pointer = new_frame_base - framesize;
pcb->frame_redline = new_frame_redline;
/*
fprintf(stderr, "stack=0x%08x .. 0x%08x (redline=0x%08x) fp=0x%08x\n",
(int) pcb->frame_base,
(int) pcb->stack_top,
(int) pcb->frame_redline,
(int) pcb->frame_pointer);
fprintf(stderr, "returning ... \n");
*/
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "cannot malloc page_t\n");
exit(-1);
}
p->base = stack_top;
p->end = stack_top + stack_size;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
//fprintf(stderr, "done\n");
return;
}
/*
On overflow:
+--------------+
| unused |
| area |
| |
+--------------+
| rp | <-- frame pointer on overflow
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| rp_next | <-- capture next conitnuation here
+--------------+ (unless we're at base already)
| ... |
| ... |
| ... |
+--------------+
| underflow |
+--------------+
New stack:
+--------------+
| unused |
| area |
| |
| |
| |
| |
| |
| |
| |
| |
+--------------+
| rp | <-- frame pointer on return
+--------------+
| frame |
| when |
| overflow |
| occured |
+--------------+
| underflow |
+--------------+
*/
char* S_make_code(int fxcsize, int fxrsize, int fxclsize, pcb_t* pcb){
int csize = fxcsize >> fx_shift;
csize = (((csize + (1 << fx_shift) - 1) >> fx_shift) << fx_shift);
int reqspace = csize + fxrsize + disp_code_data;
char* code = allocate_unprotected_space(reqspace);
{
page_t* p = malloc(sizeof(page_t));
if(p == NULL){
fprintf(stderr, "failed to allocate a page\n");
exit(-1);
}
p->base = code;
p->end = code + reqspace;
p->next = (page_t*) pcb->string_pages;
pcb->string_pages = (char*) p;
}
memset(code, 0, reqspace);
ref(code, 0) = (char*)code_tag;
ref(code, disp_code_instrsize) = (char*) csize;
ref(code, disp_code_relocsize) = (char*) fxrsize;
ref(code, disp_code_closuresize) = (char*) fxclsize;
return(code + vector_tag);
}
char* S_make_code_executable(char* x, pcb_t* pcb){
int instrsize = (int) ref(x, disp_code_instrsize - vector_tag);
char* code_start = x + disp_code_data - vector_tag;
char* code_end = code_start + instrsize;
char* page_start = (char*) align_to_prev_page(code_start);
char* page_end = (char*) align_to_next_page(code_end);
int err = mprotect(page_start,
(int) (page_end - page_start),
PROT_READ | PROT_WRITE | PROT_EXEC);
if(err == -1){
perror("Cannot set code executable");
exit(-1);
}
return bool_t;
}
#if 0
SUPER FAST HASH
Taken from
http://www.azillionmonkeys.com/qed/hash.html
#endif
#undef get16bits
#if (defined(__GNUC__) && defined(__i386__)) || defined(__WATCOMC__) \
|| defined(_MSC_VER) || defined (__BORLANDC__) || defined (__TURBOC__)
#define get16bits(d) (*((const uint16_t *) (d)))
#endif
#if !defined (get16bits)
#define get16bits(d) ((((const uint8_t *)(d))[1] << UINT32_C(8))\
+((const uint8_t *)(d))[0])
#endif
char* SuperFastHash (char* str) {
char* data = str + disp_string_data - string_tag;
int len = (int) ref(str, disp_string_length - string_tag);
len = len >> fx_shift;
uint32_t hash = len, tmp;
int rem;
if (len <= 0 || data == NULL) return 0;
rem = len & 3;
len >>= 2;
/* Main loop */
for (;len > 0; len--) {
hash += get16bits (data);
tmp = (get16bits (data+2) << 11) ^ hash;
hash = (hash << 16) ^ tmp;
data += 2*sizeof (uint16_t);
hash += hash >> 11;
}
/* Handle end cases */
switch (rem) {
case 3: hash += get16bits (data);
hash ^= hash << 16;
hash ^= data[sizeof (uint16_t)] << 18;
hash += hash >> 11;
break;
case 2: hash += get16bits (data);
hash ^= hash << 11;
hash += hash >> 17;
break;
case 1: hash += *data;
hash ^= hash << 10;
hash += hash >> 1;
}
/* Force "avalanching" of final 127 bits */
hash ^= hash << 3;
hash += hash >> 5;
hash ^= hash << 4;
hash += hash >> 17;
hash ^= hash << 25;
hash += hash >> 6;
return (char*)(hash<<fx_shift);
}
char* S_uuid(char* str){
assert((36 << fx_shift) == (int) ref(str, disp_string_length - string_tag));
uuid_t u;
uuid_clear(u);
uuid_generate(u);
uuid_unparse_upper(u, str + disp_string_data - string_tag);
return str;
}
char* S_fork(){
pid_t pid = fork();
int fxpid = pid << fx_shift;
if(pid != (fxpid >> fx_shift)){
fprintf(stderr, "BUG: pid out of range in fork\n");
exit(-1);
}
return (char*) fxpid;
}
char* S_system(char* str){
int status = system(str + disp_string_data - string_tag);
int fxstatus = status << fx_shift;
if(status != (fxstatus >> fx_shift)){
fprintf(stderr, "BUG: rv out of range in system\n");
exit(-1);
}
return (char*) fxstatus;
}

5
src/compiler-6.0.ss
View File

@ -3888,8 +3888,3 @@
(system "cp stst petite-ikarus-fresh") (system "cp stst petite-ikarus-fresh")
(define (asm-helper-code)
)

3132
src/compiler-6.1.ss Normal file
View File

File diff suppressed because it is too large Load Diff

19933
src/dump
View File

File diff suppressed because it is too large Load Diff

12
src/dynamic-load/Makefile
View File

@ -1,12 +0,0 @@
all: library1.so library2.so client
library1.so: library1.c
gcc -Wall -shared -o library1.so library1.c
library2.so: library2.c
gcc -Wall -shared -o library2.so library2.c
client: client.c
gcc -Wall -ldl -o client client.c

BIN
src/dynamic-load/client
View File

Binary file not shown.

36
src/dynamic-load/client.c
View File

@ -1,36 +0,0 @@
#include <stdio.h>
#include <stdlib.h>
#include <dlfcn.h>
void do_lib(char* libname){
fprintf(stderr, "loading %s... ", libname);
void* dh = dlopen(libname, RTLD_NOW | RTLD_LOCAL);
if(dh == NULL){
fprintf(stderr, "failed: %s\n", dlerror());
exit(-1);
}
fprintf(stderr, "0x%08x\n", (int)dh);
fprintf(stderr, "loading library_print ... ");
int(*my_print)(char*) = dlsym(dh, "library_print");
if(my_print == NULL){
fprintf(stderr, "failed: %s\n", dlerror());
exit(-1);
}
fprintf(stderr, "0x%08x\n", (int)my_print);
fprintf(stderr, "Calling it ... ");
my_print("Hello There");
fprintf(stderr, "done\n");
}
int main(int argc, char** argv){
do_lib("./library1.so");
do_lib("./library2.so");
do_lib("./library1.so");
return 0;
}

8
src/dynamic-load/library1.c
View File

@ -1,8 +0,0 @@
#include <stdio.h>
int library_print(char* x){
fprintf(stderr, "LIB1: %s\n", x);
return 0;
}

8
src/dynamic-load/library2.c
View File

@ -1,8 +0,0 @@
#include <stdio.h>
int library_print(char* x){
fprintf(stderr, "LIB2: %s\n", x);
return 0;
}

BIN
src/ikarus.fasl
View File

Binary file not shown.

132
src/libassembler-5.8.ss
View File

@ -1,132 +0,0 @@
;;;
;;; the interface for creating and managing code objects
;;;
($pcb-set! make-code
(lambda (code-size reloc-size closure-size)
(unless (and (fixnum? code-size) (fx> code-size 0))
(error 'make-code "invalid code size ~s" code-size))
(unless (and (fixnum? reloc-size) (fx>= reloc-size 0))
(error 'make-code "invalid relocation table size ~s" reloc-size))
(unless (and (fixnum? closure-size) (fx>= closure-size 0))
(error 'make-code "invalid closure size ~s" closure-size))
(foreign-call "S_make_code" code-size reloc-size closure-size)))
($pcb-set! make-code-executable!
(lambda (x)
(unless (code? x) (error 'make-code-executable! "~s is not a code" x))
(unless (foreign-call "S_make_code_executable" x)
(error 'make-code-executable "Failed!"))))
($pcb-set! code-instr-size
(lambda (x)
(unless (code? x)
(error 'code-instr-size "~s is not a code" x))
($code-instr-size x)))
($pcb-set! code-reloc-size
(lambda (x)
(unless (code? x)
(error 'code-reloc-size "~s is not a code" x))
($code-reloc-size x)))
($pcb-set! code-closure-size
(lambda (x)
(unless (code? x)
(error 'code-closure-size "~s is not a code" x))
($code-closure-size x)))
($pcb-set! code?
(lambda (x)
(code? x)))
($pcb-set! code->closure
(lambda (x)
(unless (code? x) (error 'code->closure "~s is not a code"))
(unless ($fx= ($code-closure-size x) 1)
(error 'code->closure "code contains free variables"))
($code->closure x)))
($pcb-set! set-code-byte!
(lambda (x i b)
(unless (code? x) (error 'set-code-byte! "~s is not a code" x))
(unless (and (fixnum? i) ($fx>= i 0))
(error 'set-code-byte! "~s is not a valid index" i))
(unless (and (fixnum? b) ($fx>= b 0) ($fx<= b 255))
(error 'set-code-byte! "~s is not a valid byte" b))
(unless ($fx< i ($code-instr-size x))
(error 'set-code-byte! "~s is out of range for a code of size ~s"
i
($code-instr-size x)))
($set-code-byte! x i b)))
($pcb-set! set-code-word!
(lambda (x i w)
(unless (code? x) (error 'set-code-word! "~s is not a code" x))
(unless (and (fixnum? i) ($fx>= i 0))
(error 'set-code-word! "~s is not a valid index" i))
(unless (and ($fx< i ($code-instr-size x))
($fx< ($fx+ i 3) ($code-instr-size x)))
(error 'set-code-word! "~s is out of range for a code of size ~s"
i
($code-instr-size x)))
($set-code-word! x i w)))
($pcb-set! set-code-object!
(lambda (code object code-offset reloc-index)
(unless (code? code)
(error 'set-code-object! "~s is not a code" code))
(unless (and (fixnum? code-offset)
($fx> code-offset 0)
($fx< code-offset ($code-instr-size code))
($fx< ($fx+ code-offset 3) ($code-instr-size code)))
(error 'set-code-object! "~s is not a valid code offset" code-offset))
(unless (and (fixnum? reloc-index)
($fx>= reloc-index 0)
($fx< reloc-index ($code-reloc-size code)))
(error 'set-code-object! "~s is not a valid reloc index" reloc-index))
($set-code-object! code object code-offset reloc-index)))
($pcb-set! set-code-object+offset!
(lambda (code object code-offset object-offset reloc-index)
(unless (code? code)
(error 'set-code-object+offset! "~s is not a code" code))
(unless (and (fixnum? code-offset)
($fx> code-offset 0)
($fx< code-offset ($code-instr-size code))
($fx< ($fx+ code-offset 3) ($code-instr-size code)))
(error 'set-code-object+offset!
"~s is not a valid code offset" code-offset))
(unless (and (fixnum? reloc-index)
($fx>= reloc-index 0)
($fx< reloc-index ($fx- ($code-reloc-size code) 1)))
(error 'set-code-object+offset!
"~s is not a valid reloc index" reloc-index))
($set-code-object+offset! code object
code-offset object-offset reloc-index)))
($pcb-set! set-code-object+offset/rel!
(lambda (code object code-offset object-offset reloc-index)
(unless (code? code)
(error 'set-code-object+offset/rel! "~s is not a code" code))
(unless (and (fixnum? code-offset)
($fx> code-offset 0)
($fx< code-offset ($code-instr-size code))
($fx< ($fx+ code-offset 3) ($code-instr-size code)))
(error 'set-code-object+offset/rel!
"~s is not a valid code offset" code-offset))
(unless (and (fixnum? reloc-index)
($fx>= reloc-index 0)
($fx< reloc-index ($fx- ($code-reloc-size code) 1)))
(error 'set-code-object+offset/rel!
"~s is not a valid reloc index" reloc-index))
($set-code-object+offset/rel! code object
code-offset object-offset reloc-index)))
($pcb-set! set-code-object/reloc/relative!
(lambda args (error 'set-code-object/reloc/relative! "not yet")))

25
src/libcafe-5.8.ss → src/libcafe-6.1.ss
View File

@ -30,6 +30,7 @@
(with-error-handler (with-error-handler
(lambda args (lambda args
(reset-input-port! (console-input-port)) (reset-input-port! (console-input-port))
(display "repl catch\n" (console-output-port))
(apply print-error args) (apply print-error args)
(k (void))) (k (void)))
(lambda () (lambda ()
@ -51,22 +52,22 @@
v*))))])))))) v*))))]))))))
(wait eval escape-k))) (wait eval escape-k)))
($pcb-set! new-cafe (define new-cafe
(lambda args (lambda (eval)
(let ([eval
(if (null? args)
(current-eval)
(if (null? (cdr args))
(let ([f (car args)])
(if (procedure? f)
f
(error 'new-cafe "not a procedure ~s" f)))
(error 'new-cafe "too many arguments")))])
(dynamic-wind (dynamic-wind
(lambda () (set! eval-depth (fxadd1 eval-depth))) (lambda () (set! eval-depth (fxadd1 eval-depth)))
(lambda () (lambda ()
(call/cc (call/cc
(lambda (k) (lambda (k)
(wait eval k)))) (wait eval k))))
(lambda () (set! eval-depth (fxsub1 eval-depth)))))))) (lambda () (set! eval-depth (fxsub1 eval-depth))))))
(primitive-set! 'new-cafe
(case-lambda
[() (new-cafe (current-eval))]
[(p)
(unless (procedure? p)
(error 'new-cafe "~s is not a procedure" p))
(new-cafe p)]))
)

BIN
src/libcafe.fasl
View File

Binary file not shown.

23
src/libcollect-5.3.ss
View File

@ -1,23 +0,0 @@
;($pcb-set! do-overflow
; (lambda ()
; ($do-overflow 4096)))
($pcb-set! do-overflow
(lambda ()
(foreign-call "S_collect" 4096)
(void)))
($pcb-set! collect
(lambda ()
(do-overflow)))
($pcb-set! do-overflow-with-byte-count
(lambda (n)
(foreign-call "S_collect" n)
(void)))
($pcb-set! do-stack-overflow
(lambda ()
(foreign-call "S_stack_overflow")))

BIN
src/libcollect.fasl
View File

Binary file not shown.

46
src/libcontrol-5.8.ss → src/libcontrol-6.1.ss
View File

@ -60,14 +60,28 @@
(unwind* winders tail) (unwind* winders tail)
(rewind* new tail)))) (rewind* new tail))))
;;; (define call/cc
;;; (lambda (f)
;;; (primitive-call/cc
;;; (lambda (k)
;;; (let ([save winders])
;;; (f (lambda v*
;;; (unless (eq? save winders) (do-wind save))
;;; (apply k v*))))))))
(define call/cc (define call/cc
(lambda (f) (lambda (f)
(primitive-call/cc (primitive-call/cc
(lambda (k) (lambda (k)
(let ([save winders]) (let ([save winders])
(f (lambda v* (f (case-lambda
[(v) (unless (eq? save winders) (do-wind save)) (k v)]
[() (unless (eq? save winders) (do-wind save)) (k)]
[(v1 v2 . v*)
(unless (eq? save winders) (do-wind save)) (unless (eq? save winders) (do-wind save))
(apply k v*)))))))) (apply k v1 v2 v*)])))))))
;;; (define dynamic-wind ;;; (define dynamic-wind
;;; (lambda (in body out) ;;; (lambda (in body out)
@ -78,18 +92,36 @@
;;; (out) ;;; (out)
;;; v))) ;;; v)))
;;; (define dynamic-wind
;;; (lambda (in body out)
;;; (in)
;;; (set! winders (cons (cons in out) winders))
;;; (call-with-values
;;; body
;;; (lambda v*
;;; (set! winders (cdr winders))
;;; (out)
;;; (apply values v*)))))
(define dynamic-wind (define dynamic-wind
(lambda (in body out) (lambda (in body out)
(in) (in)
(set! winders (cons (cons in out) winders)) (set! winders (cons (cons in out) winders))
(call-with-values (call-with-values
body body
(lambda v* (case-lambda
[(v) (set! winders (cdr winders)) (out) v]
[() (set! winders (cdr winders)) (out) (values)]
[(v1 v2 . v*)
(set! winders (cdr winders)) (set! winders (cdr winders))
(out) (out)
(apply values v*))))) (apply values v1 v2 v*)]))))
($pcb-set! call/cf call-with-current-frame)
($pcb-set! call/cc call/cc)
($pcb-set! dynamic-wind dynamic-wind)) (primitive-set! 'call/cf call-with-current-frame)
(primitive-set! 'call/cc call/cc)
(primitive-set! 'dynamic-wind dynamic-wind)
;($install-underflow-handler)
(void))

BIN
src/libcontrol.fasl
View File

Binary file not shown.

836
src/libcore-5.7.ss → src/libcore-6.1.ss
View File

File diff suppressed because it is too large Load Diff

BIN
src/libcore.fasl
View File

Binary file not shown.

BIN
src/libcxr.fasl
View File

Binary file not shown.

46
src/libexpand-5.8.ss → src/libexpand-6.1.ss
View File

@ -1,4 +1,6 @@
;;; 6.1: case-lambda
;;;
;;; Extended: cond case ;;; Extended: cond case
;;; ;;;
@ -19,11 +21,11 @@
;;; | <gensym> ;;; | <gensym>
;;; | (<gensym> . <FML>) ;;; | (<gensym> . <FML>)
;;; <prim> ::= void | memv | top-level-value | set-top-level-value! ;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
;;; | $pcb-set! | foreign-call | $apply ;;; | primitive-set! '| foreign-call | $apply
;;; ;;;
;;; ;;;
;;; Handled keywords: ;;; Handled keywords:
;;; Core: lambda set! if quote begin define ;;; Core: case-lambda lambda set! if quote begin define
;;; Extended: let let* letrec letrec* when unless or and cond case ;;; Extended: let let* letrec letrec* when unless or and cond case
;;; define-record record-case ;;; define-record record-case
@ -40,9 +42,6 @@
(lambda (x val) (lambda (x val)
(list 'set-top-level-value! (list 'set-top-level-value!
(build-constant x) val))) (build-constant x) val)))
(define build-pcb-set!
(lambda (x val)
(list '$pcb-set! x val)))
(define build-foreign-call (define build-foreign-call
(lambda (name rand*) (lambda (name rand*)
(cons 'foreign-call (cons 'foreign-call
@ -92,7 +91,10 @@
(list 'if test conseq altern))) (list 'if test conseq altern)))
(define build-function (define build-function
(lambda (fml* body) (lambda (fml* body)
(list 'lambda fml* body))) (build-case-lambda (list (list fml* body)))))
(define build-case-lambda
(lambda (cases)
(cons 'case-lambda cases)))
(define build-assignments (define build-assignments
(lambda (lhs* rhs* body) (lambda (lhs* rhs* body)
(cond (cond
@ -372,14 +374,21 @@
;;; ;;;
(define E-lambda (define E-lambda
(lambda (d env x) (lambda (d env x)
(unless (fx>= (length d) 2) (syntax-error x)) (build-case-lambda
(list ((lambda-clause env x) d)))))
(define (lambda-clause env x)
(lambda (d)
(unless (and (list? d) (fx>= (length d) 2)) (syntax-error x))
(let ([fml* (car d)] [body* (cdr d)]) (let ([fml* (car d)] [body* (cdr d)])
(verify-fml* fml* x) (verify-fml* fml* x)
(let ([nfml* (gen-fml* fml*)]) (let ([nfml* (gen-fml* fml*)])
(let ([env (extend-env-fml* fml* nfml* env)]) (let ([env (extend-env-fml* fml* nfml* env)])
(build-function (list nfml* (E-internal body* env x)))))))
nfml* (define E-case-lambda
(E-internal body* env x))))))) (lambda (d env x)
(unless (fx>= (length d) 1) (syntax-error x))
(build-case-lambda
(map (lambda-clause env x) d))))
(define verify-fml* (define verify-fml*
(lambda (fml* x) (lambda (fml* x)
(let ([g (gensym)]) (let ([g (gensym)])
@ -841,13 +850,6 @@
(build-lexical-reference v) (build-lexical-reference v)
(build-constant x))))])))) (build-constant x))))]))))
;;; ;;;
(define E-pcb-set!
(lambda (d env x)
(unless (fx= (length d) 2) (syntax-error x))
(let ([name (car d)] [val (cadr d)])
(unless (symbol? name) (syntax-error x))
(build-pcb-set! (build-constant name) (E val env)))))
;;;
(define E-foreign-call (define E-foreign-call
(lambda (d env x) (lambda (d env x)
(unless (fx>= (length d) 1) (syntax-error x)) (unless (fx>= (length d) 1) (syntax-error x))
@ -902,6 +904,7 @@
[(eq? a 'set!) (E-set! d env x)] [(eq? a 'set!) (E-set! d env x)]
[(eq? a 'begin) (E-begin d env x)] [(eq? a 'begin) (E-begin d env x)]
[(eq? a 'lambda) (E-lambda d env x)] [(eq? a 'lambda) (E-lambda d env x)]
[(eq? a 'case-lambda) (E-case-lambda d env x)]
[(eq? a 'let) (E-let d env x)] [(eq? a 'let) (E-let d env x)]
[(eq? a 'letrec) (E-letrec d env x)] [(eq? a 'letrec) (E-letrec d env x)]
[(eq? a 'let*) (E-let* d env x)] [(eq? a 'let*) (E-let* d env x)]
@ -918,7 +921,6 @@
[(eq? a 'record-case) (E-record-case d env x)] [(eq? a 'record-case) (E-record-case d env x)]
[(eq? a 'foreign-call) (E-foreign-call d env x)] [(eq? a 'foreign-call) (E-foreign-call d env x)]
[(eq? a '|#primitive|) (E-primref d env x)] [(eq? a '|#primitive|) (E-primref d env x)]
[(eq? a '$pcb-set!) (E-pcb-set! d env x)]
[(eq? a '$apply) (E-apply d env x)] [(eq? a '$apply) (E-apply d env x)]
[else (syntax-error x)])] [else (syntax-error x)])]
[else [else
@ -1047,9 +1049,9 @@
(E* d empty-env))]))] (E* d empty-env))]))]
[else (syntax-error x)]))) [else (syntax-error x)])))
;;; ;;;
($pcb-set! core-expand E-top) (primitive-set! 'core-expand E-top)
;;; ;;;
($pcb-set! current-expand (primitive-set! 'current-expand
(make-parameter (make-parameter
core-expand core-expand
(lambda (x) (lambda (x)
@ -1057,7 +1059,7 @@
(error 'current-expand "~s is not a procedure" x)) (error 'current-expand "~s is not a procedure" x))
x))) x)))
;;; ;;;
($pcb-set! expand (primitive-set! 'expand
(lambda (x) (lambda (x)
((current-expand) x))) ((current-expand) x)))
;;; ;;;
@ -1065,7 +1067,7 @@
(lambda (x) (lambda (x)
(putprop x *keyword* x)) (putprop x *keyword* x))
'(lambda set! let let* letrec letrec* if quote when unless set! begin '(lambda set! let let* letrec letrec* if quote when unless set! begin
define or and cond case $pcb-set! foreign-call $apply |#primitive| case-lambda define or and cond case foreign-call $apply |#primitive|
define-record record-case define-record record-case
quasiquote unquote unquote-splicing let-values parameterize quasiquote unquote unquote-splicing let-values parameterize
))) )))

BIN
src/libexpand.fasl
View File

Binary file not shown.

16
src/libhandlers-5.5.ss
View File

@ -1,16 +0,0 @@
($pcb-set! $apply-nonprocedure-error-handler
(lambda (x)
(error 'apply "~s is not a procedure" x)))
($pcb-set! $incorrect-args-error-handler
(lambda (p n)
(error 'apply "incorrect number of argument (~s) to ~s" n p)))
($pcb-set! $multiple-values-error
(lambda args
(error 'apply
"incorrect number of values ~s returned to single value context"
args)))

BIN
src/libhandlers.fasl
View File

Binary file not shown.

883
src/libintelasm-5.8.ss
View File

@ -1,883 +0,0 @@
;;;
;;; assuming the existence of a code manager, this file defines an assember
;;; that takes lists of assembly code and produces a list of code objects
;;;
;;; add
;;; and
;;; cmp
;;; call
;;; cltd
;;; idiv
;;; imull
;;; ja
;;; jae
;;; jb
;;; jbe
;;; je
;;; jg
;;; jge
;;; jl
;;; jle
;;; jne
;;; jmp
;;; movb
;;; movl
;;; negl
;;; notl
;;; orl
;;; popl
;;; pushl
;;; ret
;;; sall
;;; sarl
;;; sete
;;; setg
(let ()
(define fold
(lambda (f init ls)
(cond
[(null? ls) init]
[else
(f (car ls) (fold f init (cdr ls)))])))
(define convert-instructions
(lambda (ls)
(fold convert-instruction '() ls)))
(define register-mapping
'([%eax 32 0]
[%ecx 32 1]
[%edx 32 2]
[%ebx 32 3]
[%esp 32 4]
[%ebp 32 5]
[%esi 32 6]
[%edi 32 7]
[%al 8 0]
[%cl 8 1]
[%dl 8 2]
[%bl 8 3]
[%ah 8 4]
[%ch 8 5]
[%dh 8 6]
[%bh 8 7]
[/0 0 0]
[/1 0 1]
[/2 0 2]
[/3 0 3]
[/4 0 4]
[/5 0 5]
[/6 0 6]
[/7 0 7]
))
(define register-index
(lambda (x)
(cond
[(assq x register-mapping) => caddr]
[else (error 'register-index "not a register ~s" x)])))
(define reg32?
(lambda (x)
(cond
[(assq x register-mapping) =>
(lambda (x) (fx= (cadr x) 32))]
[else #f])))
(define reg8?
(lambda (x)
(cond
[(assq x register-mapping) =>
(lambda (x) (fx= (cadr x) 8))]
[else #f])))
(define reg?
(lambda (x)
(assq x register-mapping)))
(define check-len
(lambda (x)
(define instr-len
'([ret]
[movl s d]
[movb s d]
[addl s d]
[subl s d]
[sall s d]
[sarl s d]
[andl s d]
[orl s d]
[cmpl s d]
[imull s d]
[notl d]
[negl d]
[idivl d]
[pushl d]
[popl d]
[jmp d]
[call d]
[ja d]
[jae d]
[jb d]
[jbe d]
[je d]
[jg d]
[jge d]
[jl d]
[jle d]
[jna d]
[jnae d]
[jnb d]
[jnbe d]
[jne d]
[jng d]
[jnge d]
[jnl d]
[jnle d]
[seta d]
[setae d]
[setb d]
[setbe d]
[sete d]
[setg d]
[setge d]
[setl d]
[setle d]
[setna d]
[setnae d]
[setnb d]
[setnbe d]
[setne d]
[setng d]
[setnge d]
[setnl d]
[setnle d]
[cltd]
[byte x]
[byte-vector x]
[int x]
[label x]
[label-address x]
[current-frame-offset]
))
(cond
[(assq (car x) instr-len) =>
(lambda (p)
(unless (fx= (length x) (length p))
(error 'assembler "invalid instruction format ~s" x)))]
[else (error 'assembler "unknown instruction ~s" x)])))
(define with-args
(lambda (ls f)
(apply f (cdr ls))))
(define byte
(lambda (x)
(cons 'byte (fxlogand x 255))))
(define word
(lambda (x)
(cons 'word x)))
(define reloc-word
(lambda (x)
(cons 'reloc-word x)))
(define reloc-word+
(lambda (x d)
(list* 'reloc-word+ x d)))
(define list*-aux
(lambda (ls ls*)
(cond
[(null? ls*) ls]
[else (cons ls (list*-aux (car ls*) (cdr ls*)))])))
(define list*
(lambda (ls . ls*)
(list*-aux ls ls*)))
(define byte?
(lambda (x)
(and (fixnum? x)
(fx<= x 127)
(fx<= -128 x))))
(define mem?
(lambda (x)
(and (list? x)
(fx= (length x) 3)
(eq? (car x) 'disp)
(or (imm? (cadr x))
(reg? (cadr x)))
(or (imm? (caddr x))
(reg? (caddr x))))))
(define small-disp?
(lambda (x)
(and (mem? x)
(byte? (cadr x)))))
(define CODE
(lambda (n ac)
(cons (byte n) ac)))
(define CODE+r
(lambda (n r ac)
(cons (byte (fxlogor n (register-index r))) ac)))
(define ModRM
(lambda (mod reg r/m ac)
(cons (byte (fxlogor
(register-index r/m)
(fxlogor
(fxsll (register-index reg) 3)
(fxsll mod 6))))
(if (and (not (fx= mod 3)) (eq? r/m '%esp))
(cons (byte #x24) ac)
ac))))
(define IMM32
(lambda (n ac)
(cond
[(int? n)
(let ([n (cadr n)])
(list* (byte n)
(byte (fxsra n 8))
(byte (fxsra n 16))
(byte (fxsra n 24))
ac))]
[(obj? n)
(let ([v (cadr n)])
(if (immediate? v)
(cons (word v) ac)
(cons (reloc-word v) ac)))]
[(obj+? n)
(let ([v (cadr n)] [d (caddr n)])
(cons (reloc-word+ v d) ac))]
[(label-address? n)
(cons (cons 'label-addr (label-name n)) ac)]
[(foreign? n)
(cons (cons 'foreign-label (label-name n)) ac)]
[else (error 'IMM32 "invalid ~s" n)])))
(define IMM8
(lambda (n ac)
(cond
[(int? n)
(let ([n (cadr n)])
(list* (byte n) ac))]
[else (error 'IMM8 "invalid ~s" n)])))
(define imm?
(lambda (x)
(or (int? x)
(obj? x)
(obj+? x)
(label-address? x)
(foreign? x))))
(define foreign?
(lambda (x)
(and (pair? x) (eq? (car x) 'foreign-label))))
(define imm8?
(lambda (x)
(and (int? x) (byte? (cadr x)))))
(define label?
(lambda (x)
(cond
[(and (pair? x) (eq? (car x) 'label))
(let ([d (cdr x)])
(unless (and (null? (cdr d))
(symbol? (car d)))
(error 'assemble "invalid label ~s" x)))
#t]
[else #f])))
(define label-address?
(lambda (x)
(cond
[(and (pair? x) (eq? (car x) 'label-address))
(let ([d (cdr x)])
(unless (and (null? (cdr d))
(or (symbol? (car d))
(string? (car d))))
(error 'assemble "invalid label-address ~s" x)))
#t]
[else #f])))
(define label-name
(lambda (x) (cadr x)))
(define int?
(lambda (x)
(and (pair? x) (eq? (car x) 'int))))
(define obj?
(lambda (x)
(and (pair? x) (eq? (car x) 'obj))))
(define obj+?
(lambda (x)
(and (pair? x) (eq? (car x) 'obj+))))
(define CODErri
(lambda (c d s i ac)
(cond
[(imm8? i)
(CODE c (ModRM 1 d s (IMM8 i ac)))]
[(reg? i)
(CODE c (ModRM i d s ac))]
[else
(CODE c (ModRM 2 d s (IMM32 i ac)))])))
(define CODErr
(lambda (c d s ac)
(CODE c (ModRM 3 d s ac))))
(define CODEri
(lambda (c d i ac)
(CODE+r c d (IMM32 i ac))))
(define RegReg
(lambda (r1 r2 r3 ac)
(cond
[(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")]
[(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")]
[else
(list*
(byte (fxlogor 4 (fxsll (register-index r1) 3)))
(byte (fxlogor (register-index r2)
(fxsll (register-index r3) 4)))
ac)])))
#;(define CODErd
(lambda (c r1 disp ac)
(with-args disp
(lambda (i/r r2)
(if (reg? i/r)
(CODE c (RegReg r1 i/r r2 ac))
(CODErri c r1 r2 i/r ac))))))
(define IMM32*2
(lambda (i1 i2 ac)
(cond
[(and (int? i1) (obj? i2))
(let ([d (cadr i1)] [v (cadr i2)])
(cons (reloc-word+ v d) ac))]
[else (error 'assemble "IMM32*2 ~s ~s" i1 i2)])))
(define CODErd
(lambda (c r1 disp ac)
(with-args disp
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(CODE c (RegReg r1 a1 a2 ac))]
[(and (imm? a1) (reg? a2))
(CODErri c r1 a2 a1 ac)]
[(and (imm? a1) (imm? a2))
(CODE c
(ModRM 0 r1 '/5
(IMM32*2 a1 a2 ac)))]
[else (error 'CODErd "unhandled ~s" disp)])))))
(define CODEdi
(lambda (c disp n ac)
(with-args disp
(lambda (i r)
(CODErri c '/0 r i (IMM32 n ac))))))
(define convert-instruction
(lambda (a ac)
(define who 'assemble)
(check-len a)
(case (car a)
[(ret) (CODE #xC3 ac)]
[(cltd) (CODE #x99 ac)]
[(movl)
(with-args a
(lambda (src dst)
(cond
[(and (imm? src) (reg? dst)) (CODEri #xB8 dst src ac)]
[(and (imm? src) (mem? dst)) (CODEdi #xC7 dst src ac)]
[(and (reg? src) (reg? dst)) (CODErr #x89 src dst ac)]
[(and (reg? src) (mem? dst)) (CODErd #x89 src dst ac)]
[(and (mem? src) (reg? dst)) (CODErd #x8B dst src ac)]
[else (error who "invalid ~s" a)])))]
[(movb)
(with-args a
(lambda (src dst)
(cond
[(and (imm8? src) (reg8? dst)) (CODEri #xB0 dst src ac)]
[(and (imm8? src) (mem? dst)) (CODEdi #xC6 dst src ac)]
[(and (reg8? src) (reg8? dst)) (CODErr #x88 src dst ac)]
[(and (reg8? src) (mem? dst)) (CODErd #x88 src dst ac)]
[(and (mem? src) (reg8? dst)) (CODErd #x8A dst src ac)]
[else (error who "invalid ~s" a)])))]
[(addl)
(with-args a
(lambda (src dst)
(cond
;;; add imm -> reg
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/0 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
(CODE #x05 (IMM32 src ac))]
[(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/0 dst (IMM32 src ac)))]
;;; add reg -> reg
[(and (reg? src) (reg? dst))
(CODE #x01 (ModRM 3 src dst ac))]
;;; add mem -> reg
[(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)]
;;; add imm -> mem (not needed)
;;; add reg -> mem (not needed)
[else (error who "invalid ~s" a)])))]
[(subl)
(with-args a
(lambda (src dst)
(cond
;;; imm -> reg
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/5 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
(CODE #x2D (IMM32 src ac))]
[(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/5 dst (IMM32 src ac)))]
;;; reg -> reg
[(and (reg? src) (reg? dst))
(CODE #x29 (ModRM 3 src dst ac))]
;;; mem -> reg
[(and (mem? src) (reg? dst))
(CODErd #x2B dst src ac)]
;;; imm -> mem (not needed)
;;; reg -> mem (not needed)
[else (error who "invalid ~s" a)])))]
[(sall)
(with-args a
(lambda (src dst)
(cond
[(and (equal? '(int 1) src) (reg? dst))
(CODE #xD1 (ModRM 3 '/4 dst ac))]
[(and (imm8? src) (reg? dst))
(CODE #xC1 (ModRM 3 '/4 dst (IMM8 src ac)))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/4 dst ac))]
[else (error who "invalid ~s" a)])))]
[(sarl)
(with-args a
(lambda (src dst)
(cond
[(and (equal? '(int 1) src) (reg? dst))
(CODE #xD1 (ModRM 3 '/7 dst ac))]
[(and (imm8? src) (reg? dst))
(CODE #xC1 (ModRM 3 '/7 dst (IMM8 src ac)))]
[(and (eq? src '%cl) (reg? dst))
(CODE #xD3 (ModRM 3 '/7 dst ac))]
[else (error who "invalid ~s" a)])))]
[(andl) ; similar to add
(with-args a
(lambda (src dst)
(cond
;;; and imm -> reg
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/4 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
(CODE #x25 (IMM32 src ac))]
[(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/4 dst (IMM32 src ac)))]
;;; and reg -> reg
[(and (reg? src) (reg? dst))
(CODE #x21 (ModRM 3 src dst ac))]
;;; and mem -> reg
[(and (mem? src) (reg? dst))
(CODErd #x23 dst src ac)]
[else (error who "invalid ~s" a)])))]
[(orl) ; similar to add
(with-args a
(lambda (src dst)
(cond
;;; or imm -> reg
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/1 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
(CODE #x0D (IMM32 src ac))]
[(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/1 dst (IMM32 src ac)))]
;;; or reg -> reg
[(and (reg? src) (reg? dst))
(CODE #x09 (ModRM 3 src dst ac))]
;;; or mem -> reg
[(and (mem? src) (reg? dst))
(CODErd #x0B dst src ac)]
[else (error who "invalid ~s" a)])))]
[(cmpl)
(with-args a
(lambda (src dst)
(cond
[(and (imm8? src) (reg? dst))
(CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
(CODE #x3D (IMM32 src ac))]
[(and (reg? src) (reg? dst))
(CODE #x39 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x3B dst src ac)]
[(and (imm8? src) (mem? dst))
(CODErd #x83 '/7 dst (IMM8 src ac))]
[(and (imm? src) (mem? dst))
(CODErd #x81 '/7 dst (IMM32 src ac))]
[else (error who "invalid ~s" a)])))]
[(imull)
(with-args a
(lambda (src dst)
(cond
[(and (imm8? src) (reg? dst))
(CODE #x6B (ModRM 3 dst dst (IMM8 src ac)))]
[(and (imm? src) (reg? dst))
(CODE #x69 (ModRM 3 dst dst (IMM32 src ac)))]
[(and (reg? src) (reg? dst))
(CODE #x0F (CODE #xAF (ModRM 3 dst src ac)))]
[(and (mem? src) (reg? dst))
(CODE #x0F (CODErd #xAF dst src ac))]
[else (error who "invalid ~s" a)])))]
[(idivl)
(with-args a
(lambda (dst)
(cond
[(reg? dst)
(CODErr #xF7 '/7 dst ac)]
[(mem? dst)
(CODErd #xF7 '/7 dst ac)]
[else (error who "invalid ~s" a)])))]
[(pushl)
(with-args a
(lambda (dst)
(cond
[(imm8? dst)
(CODE #x6A (IMM8 dst ac))]
[(imm? dst)
(CODE #x68 (IMM32 dst ac))]
[(reg? dst)
(CODE+r #x50 dst ac)]
[(mem? dst)
(CODErd #xFF '/6 dst ac)]
[else (error who "invalid ~s" a)])))]
[(popl)
(with-args a
(lambda (dst)
(cond
[(reg? dst)
(CODE+r #x58 dst ac)]
[(mem? dst)
(CODErd #x8F '/0 dst ac)]
[else (error who "invalid ~s" a)])))]
[(notl)
(with-args a
(lambda (dst)
(cond
[(reg? dst)
(CODE #xF7 (ModRM 3 '/2 dst ac))]
[(mem? dst)
(CODErd #xF7 '/7 dst ac)]
[else (error who "invalid ~s" a)])))]
[(negl)
(with-args a
(lambda (dst)
(cond
[(reg? dst)
(CODE #xF7 (ModRM 3 '/3 dst ac))]
[else (error who "invalid ~s" a)])))]
[(jmp)
(with-args a
(lambda (dst)
(cond
[(label? dst)
(CODE #xE9 (cons (cons 'relative (label-name dst)) ac))]
[(imm? dst)
(CODE #xE9 (IMM32 dst ac))]
[(mem? dst)
(CODErd #xFF '/4 dst ac)]
[else (error who "invalid jmp in ~s" a)])))]
[(call)
(with-args a
(lambda (dst)
(cond
[(imm? dst)
(CODE #xE8 (IMM32 dst ac))]
[(label? dst)
(CODE #xE8 (cons (cons 'relative (label-name dst)) ac))]
[(mem? dst)
(CODErd #xFF '/2 dst ac)]
[(reg? dst)
(CODE #xFF (ModRM 3 '/2 dst ac))]
[else (error who "invalid jmp in ~s" a)])))]
[(seta setae setb setbe sete setg setge setl setle
setna setnae setnb setnbe setne setng setnge setnl setnle)
(let* ([table
'([seta #x97] [setna #x96]
[setae #x93] [setnae #x92]
[setb #x92] [setnb #x93]
[setbe #x96] [setnbe #x97]
[setg #x9F] [setng #x9E]
[setge #x9D] [setnge #x9C]
[setl #x9C] [setnl #x9D]
[setle #x9E] [setnle #x9F]
[sete #x94] [setne #x95])]
[lookup
(lambda (x)
(cond
[(assq x table) => cadr]
[else (error who "invalid cset ~s" x)]))])
(with-args a
(lambda (dst)
(cond
[(reg8? dst)
(CODE #x0F
(CODE (lookup (car a))
(ModRM 3 '/0 dst ac)))]
[else (error who "invalid ~s" a)]))))]
[(ja jae jb jbe je jg jge jl jle
jna jnae jnb jnbe jne jng jnge jnl jnle)
(let* ([table
'([je #x84] [jne #x85]
[ja #x87] [jna #x86]
[jae #x83] [jnae #x82]
[jb #x82] [jnb #x83]
[jbe #x86] [jnbe #x87]
[jg #x8F] [jng #x8E]
[jge #x8D] [jnge #x8C]
[jl #x8C] [jnl #x8D]
[jle #x8E] [jnle #x8F])]
[lookup
(lambda (x)
(cond
[(assq x table) => cadr]
[else (error who "invalid cmp ~s" x)]))])
(with-args a
(lambda (dst)
(cond
[(imm? dst)
(CODE #x0F (CODE (lookup (car a)) (IMM32 dst ac)))]
[(label? dst)
(CODE #x0F
(CODE (lookup (car a))
(cons (cons 'relative (label-name dst)) ac)))]
[else (error who "invalid ~s" a)]))))]
[(byte)
(with-args a
(lambda (x)
(unless (byte? x) (error who "invalid instruction ~s" a))
(cons (byte x) ac)))]
[(byte-vector)
(with-args a
(lambda (x) (append (map byte (vector->list x)) ac)))]
[(int) (IMM32 a ac)]
[(label)
(with-args a
(lambda (L)
(unless (symbol? L) (error who "invalid instruction ~s" a))
(cons (cons 'label L) ac)))]
[(label-address)
(with-args a
(lambda (L)
(unless (symbol? L) (error who "invalid instruction ~s" a))
(cons (cons 'label-addr L) ac)))]
[(current-frame-offset)
(cons '(current-frame-offset) ac)]
[else
(error who "unknown instruction ~s" a)])))
(define diff
(lambda (ls x)
(cond
[(eq? ls x) '()]
[else (cons (car ls) (diff (cdr ls) x))])))
(define hex-table
'#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7
#\8 #\9 #\A #\B #\C #\D #\E #\F))
(define write/x
(lambda (x)
(case (car x)
[(byte)
(display "0x")
(display (vector-ref hex-table (fxsra (cdr x) 4)))
(display (vector-ref hex-table (fxlogand (cdr x) 15)))
(display " ")]
[else (write x)])))
(define convert-instruction**
(let ([convert-instruction convert-instruction])
(lambda (x ac)
(display "Convert ")
(write x)
(newline)
(let ([nc (convert-instruction x ac)])
(for-each write/x (diff nc ac))
(newline)
nc))))
(define compute-code-size
(lambda (ls)
(fold (lambda (x ac)
(case (car x)
[(byte) (fx+ ac 1)]
[(word reloc-word reloc-word+ label-addr foreign-label
relative current-frame-offset)
(fx+ ac 4)]
[(label) ac]
[else (error 'compute-code-size "unknown instr ~s" x)]))
0
ls)))
(define compute-reloc-size
(lambda (ls)
(fold (lambda (x ac)
(case (car x)
[(reloc-word foreign-label) (fx+ ac 4)]
[(reloc-word+) (fx+ ac 8)]
[(relative label-addr) (fx+ ac 8)]
[(word byte label current-frame-offset) ac]
[else (error 'compute-reloc-size "unknown instr ~s" x)]))
0
ls)))
(define set-label-loc!
(lambda (x loc)
(when (getprop x '*label-loc*)
(error 'compile "label ~s is already defined" x))
(putprop x '*label-loc* loc)))
(define label-loc
(lambda (x)
(or (getprop x '*label-loc*)
(error 'compile "undefined label ~s" x))))
(define unset-label-loc!
(lambda (x)
(remprop x '*label-loc*)))
(define whack-instructions
(lambda (x ls)
(define f
(lambda (ls idx reloc)
(cond
[(null? ls) reloc]
[else
(let ([a (car ls)])
(case (car a)
[(byte)
(set-code-byte! x idx (cdr a))
(f (cdr ls) (fx+ idx 1) reloc)]
[(reloc-word reloc-word+)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
[(relative label-addr foreign-label)
(f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
[(word)
(let ([v (cdr a)])
(set-code-word! x idx v)
(f (cdr ls) (fx+ idx 4) reloc))]
[(current-frame-offset)
(set-code-word! x idx idx)
(f (cdr ls) (fx+ idx 4) reloc)]
[(label)
(set-label-loc! (cdr a) (cons x idx))
(f (cdr ls) idx reloc)]
[else
(error 'whack-instructions "unknown instr ~s" a)]))])))
(f ls 0 '())))
(define wordsize 4)
(define whack-reloc
(lambda (code)
(define reloc-idx 0)
(lambda (r)
(let ([idx (car r)] [type (cadr r)] [v (cddr r)])
(case type
[(reloc-word)
(set-code-object! code v idx reloc-idx)
(set! reloc-idx (fxadd1 reloc-idx))]
[(foreign-label)
(set-code-foreign-object! code v idx reloc-idx)
(set! reloc-idx (fxadd1 reloc-idx))]
[(reloc-word+)
(let ([obj (car v)] [disp (cdr v)])
(set-code-object+offset! code obj idx disp reloc-idx)
(set! reloc-idx (fx+ reloc-idx 2)))]
[(label-addr)
(let ([loc (label-loc v)])
(let ([obj (car loc)] [off (cdr loc)])
(set-code-object+offset!
code obj idx (fx+ off 11) reloc-idx)))
(set! reloc-idx (fx+ reloc-idx 2))]
[(relative)
(let ([loc (label-loc v)])
(let ([obj (car loc)] [off (cdr loc)])
(set-code-object+offset/rel!
code obj idx (fx+ off 11) reloc-idx)))
(set! reloc-idx (fx+ reloc-idx 2))]
[else (error 'whack-reloc "invalid reloc type ~s" type)]))
)))
;;; (define list->code
;;; (lambda (ls)
;;; (let ([ls (convert-instructions ls)])
;;; (let ([n (compute-code-size ls)]
;;; [m (compute-reloc-size ls)])
;;; (let ([x (make-code n m 1)])
;;; (let ([reloc* (whack-instructions x ls)])
;;; (for-each (whack-reloc x) reloc*))
;;; (make-code-executable! x)
;;; x)))))
(define list*->code*
(lambda (ls*)
(let ([closure-size* (map car ls*)]
[ls* (map cdr ls*)])
(let ([ls* (map convert-instructions ls*)])
(let ([n* (map compute-code-size ls*)]
[m* (map compute-reloc-size ls*)])
(let ([code* (map (lambda (n m c) (make-code n m c))
n*
m*
closure-size*)])
(let ([reloc** (map whack-instructions code* ls*)])
(for-each
(lambda (code reloc*)
(for-each (whack-reloc code) reloc*))
code* reloc**)
(for-each make-code-executable! code*)
code*)))))))
(define list->code
(lambda (ls)
(car (list*->code* (list ls)))))
($pcb-set! list*->code* list*->code*)
)

11
src/libintelasm-6.0.ss
View File

@ -762,17 +762,6 @@
(display " ")] (display " ")]
[else (write x)]))) [else (write x)])))
(define convert-instruction**
(let ([convert-instruction convert-instruction])
(lambda (x ac)
(display "Convert ")
(write x)
(newline)
(let ([nc (convert-instruction x ac)])
(for-each write/x (diff nc ac))
(newline)
nc))))
(define compute-code-size (define compute-code-size
(lambda (ls) (lambda (ls)

BIN
src/libintelasm.fasl
View File

Binary file not shown.

111
src/libinterpret-5.8.ss → src/libinterpret-6.1.ss
View File

@ -1,4 +1,9 @@
;;; Changes:
;;; 6.1: adding case-lambda, dropping lambda
;;; 6.0: basic version working
;;;
;;; Expand : Scheme -> Core Scheme ;;; Expand : Scheme -> Core Scheme
;;; ;;;
;;; <CS> ::= (quote datum) ;;; <CS> ::= (quote datum)
@ -6,7 +11,7 @@
;;; | (if <CS> <CS> <CS>) ;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>) ;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...) ;;; | (begin <CS> <CS> ...)
;;; | (lambda <FMLS> <CS> <CS> ...) ;;; | (case-lambda (<FML> <CS>) (<FML> <CS>) ...)
;;; | (<prim> <CS> <CS> ...) ;;; | (<prim> <CS> <CS> ...)
;;; | (primref <primname>) ;;; | (primref <primname>)
;;; | (<CS> <CS> ...) ;;; | (<CS> <CS> ...)
@ -64,9 +69,9 @@
[(null? ls) [(null? ls)
(if (fx= i j) (if (fx= i j)
v v
(error 'apply "incorrect number of arguments to procedure"))] (error 'apply1 "incorrect number of arguments to procedure"))]
[(fx= i j) [(fx= i j)
(error 'apply "incorrect number of arguments to procedure")] (error 'apply2 "incorrect number of arguments to procedure")]
[else [else
(vector-set! v i (car ls)) (vector-set! v i (car ls))
(whack-proper v (cdr ls) (fxadd1 i) j)]))) (whack-proper v (cdr ls) (fxadd1 i) j)])))
@ -76,7 +81,7 @@
(cond (cond
[(fx= i j) (vector-set! v i ls) v] [(fx= i j) (vector-set! v i ls) v]
[(null? ls) [(null? ls)
(error 'apply "incorrect number of arguments to procedure")] (error 'apply3 "incorrect number of arguments to procedure")]
[else [else
(vector-set! v i (car ls)) (vector-set! v i (car ls))
(whack-improper v (cdr ls) (fxadd1 i) j)]))) (whack-improper v (cdr ls) (fxadd1 i) j)])))
@ -143,7 +148,49 @@
[(eq? a 'begin) [(eq? a 'begin)
(unless (fx>= (length d) 1) (syntax-error x)) (unless (fx>= (length d) 1) (syntax-error x))
(C*->last (car d) (cdr d) env)] (C*->last (car d) (cdr d) env)]
[(eq? a 'case-lambda)
(unless (fx>= (length d) 1) (syntax-error x))
(let ()
(define generate
(lambda (d)
(cond
[(null? d)
(lambda (n args renv)
(error 'apply
"incorrect number of arguments ~s to procedure"
n))]
[else
(let ([k (generate (cdr d))]
[a (car d)])
(let ([fml (car a)] [body* (cdr a)])
(let ([env (extend-env fml env)]
[n (fml-length fml x)])
(let ([body*
(C*->last (car body*) (cdr body*) env)])
(if (list? fml)
(lambda (m args renv)
(if (fx= n m)
(body* (cons (list->vector args) renv))
(k m args renv)))
(let ([q (fxsub1 n)])
(lambda (m args renv)
(if (fx>= m q)
(let ([v (make-vector n)])
(let f ([i 0] [args args])
(cond
[(fx= i q)
(vector-set! v q args)]
[else
(vector-set! v i (car args))
(f (fxadd1 i) (cdr args))]))
(body* (cons v renv)))
(k m args renv)))))))))])))
(let ([dispatch (generate d)])
(lambda (renv)
(lambda args
(dispatch (length args) args renv)))))]
[(eq? a 'lambda) [(eq? a 'lambda)
(syntax-error x)
(unless (fx>= (length d) 2) (syntax-error x)) (unless (fx>= (length d) 2) (syntax-error x))
(let ([fml* (car d)] [body* (cdr d)]) (let ([fml* (car d)] [body* (cdr d)])
(let ([env (extend-env fml* env)] (let ([env (extend-env fml* env)]
@ -186,7 +233,7 @@
(if (top-level-bound? sym) (if (top-level-bound? sym)
(top-level-value sym) (top-level-value sym)
(error #f "~s is unbound" sym))))))] (error #f "~s is unbound" sym))))))]
[(memq a '(set-top-level-value! $pcb-set!)) [(memq a '(set-top-level-value!))
(unless (fx= (length d) 2) (syntax-error x)) (unless (fx= (length d) 2) (syntax-error x))
(let ([qsym (car d)] [val (C (cadr d) env)]) (let ([qsym (car d)] [val (C (cadr d) env)])
(unless (and (pair? qsym) (unless (and (pair? qsym)
@ -206,40 +253,64 @@
[(eq? a '|#primitive|) [(eq? a '|#primitive|)
(unless (fx= (length d) 1) (syntax-error x)) (unless (fx= (length d) 1) (syntax-error x))
(let ([sym (car d)]) (let ([sym (car d)])
(let ([prim (primitive sym)]) (let ([prim (primitive-ref sym)])
(if (procedure? prim) (if (procedure? prim)
(lambda (renv) prim) (lambda (renv) prim)
(syntax-error x))))] (syntax-error x))))]
[(memq a '(foreign-call $apply)) [(memq a '(foreign-call $apply))
(error 'interpret "~a form is not supported" a)] (error 'interpret "~a form is not supported" a)]
;;; [else
;;; (let ([rator (C a env)] [n (length d)])
;;; (cond
;;; [(fx= n 0)
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p)))]
;;; [(fx= n 1)
;;; (let ([arg1 (C (car d) env)])
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p (arg1 renv)))))]
;;; [(fx= n 2)
;;; (let ([arg1 (C (car d) env)]
;;; [arg2 (C (cadr d) env)])
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p (arg1 renv) (arg2 renv)))))]
;;; [else
;;; (let ([arg* (C*->list (car d) (cdr d) env)])
;;; (lambda (renv)
;;; (apply (rator renv) (arg* renv))))]))]
[else [else
(let ([rator (C a env)] [n (length d)]) (let ([rator (C a env)] [n (length d)])
(cond (cond
[(fx= n 0) [(fx= n 0)
(lambda (renv) (lambda (renv)
((rator renv)))] (apply (rator renv) '()))]
[(fx= n 1) ;[(fx= n 1)
(let ([arg1 (C (car d) env)]) ; (let ([arg1 (C (car d) env)])
(lambda (renv) ; (lambda (renv)
((rator renv) (arg1 renv))))] ; ((rator renv) (arg1 renv))))]
[(fx= n 2) ;[(fx= n 2)
(let ([arg1 (C (car d) env)] ; (let ([arg1 (C (car d) env)]
[arg2 (C (cadr d) env)]) ; [arg2 (C (cadr d) env)])
(lambda (renv) ; (lambda (renv)
((rator renv) (arg1 renv) (arg2 renv))))] ; ((rator renv) (arg1 renv) (arg2 renv))))]
[else [else
(let ([arg* (C*->list (car d) (cdr d) env)]) (let ([arg* (C*->list (car d) (cdr d) env)])
(lambda (renv) (lambda (renv)
(apply (rator renv) (arg* renv))))]))]))] (apply (rator renv) (arg* renv))))]))]
))]
[else (syntax-error x)]))) [else (syntax-error x)])))
;;; ;;;
($pcb-set! interpret (primitive-set! 'interpret
(lambda (x) (lambda (x)
(let ([x (expand x)]) (let ([x (expand x)])
(let ([p (C x '())]) (let ([p (C x '())])
(p '()))))) (p '())))))
;;; ;;;
($pcb-set! current-eval (primitive-set! 'current-eval
(make-parameter (make-parameter
interpret interpret
(lambda (f) (lambda (f)
@ -247,7 +318,7 @@
(error 'current-eval "~s is not a procedure" f)) (error 'current-eval "~s is not a procedure" f))
f))) f)))
;;; ;;;
($pcb-set! eval (primitive-set! 'eval
(lambda (x) (lambda (x)
((current-eval) x)))) ((current-eval) x))))

BIN
src/libinterpret.fasl
View File

Binary file not shown.

227
src/libio-5.8.ss → src/libio-6.1.ss
View File

@ -58,7 +58,7 @@
(define open-output-string (define open-output-string
(lambda () (lambda ()
(vector output-port-id (vector output-port-id
"*string-port*" '*string-port*
'() '()
#t #t
(make-string 4096) (make-string 4096)
@ -92,37 +92,20 @@
(let ([idx (string-length buf)]) (let ([idx (string-length buf)])
(let ([str (f (cdr ls) (fx+ n idx))]) (let ([str (f (cdr ls) (fx+ n idx))])
(fill str buf n 0 idx))))]))))) (fill str buf n 0 idx))))])))))
(define open-output-file (define open-output-file
(lambda (filename . rest) (lambda (name mode)
(unless (string? filename) (unless (string? name)
(error 'open-output-file "invalid filename ~s" filename)) (error 'open-output-file "~s is not a valid file name" name))
(let ([mode (let ([mode
(let ([fst
(cond (cond
[(null? rest) 'error] [(assq mode '([error 0] [append 1] [replace 2] [truncate 3]))
[(null? (cdr rest)) (car rest)] => cadr]
[else [else
(error 'open-output-file "too many arguments")])] (error 'open-output-file "~s is not a valid mode" mode)])])
[mode-map (let ([fh (foreign-call "ik_open_file" name mode)])
'([error . 0] [append . 1] [replace . 2] [truncate . 3])]) (fd->port fh name)))))
(cond
[(assq fst mode-map) => cdr]
[else (error 'open-output-file "invalid mode ~s" fst)]))])
(let ([fh (foreign-call "S_open_file" filename mode)])
(fd->port fh filename)))))
(define write-char (define write-char
(lambda (c . port) (lambda (c port)
(let ([port
(cond
[(null? port) (current-output-port)]
[(null? (cdr port))
(let ([p (car port)])
(if (output-port? p)
p
(error 'write-char "not a port: ~s" p)))]
[else
(error 'write-char "too many arguments")])])
(unless (char? c) (unless (char? c)
(error 'write-char "not a char: ~s" c)) (error 'write-char "not a char: ~s" c))
(unless (output-port-open? port) (unless (output-port-open? port)
@ -132,16 +115,16 @@
(begin (begin
(string-set! (output-port-buffer port) idx c) (string-set! (output-port-buffer port) idx c)
(set-output-port-index! port (fxadd1 idx)) (set-output-port-index! port (fxadd1 idx))
(when (char= c #\newline) (when ($char= c #\newline)
(flush-output-port port))) (flush-output-port port)))
(begin (begin
(flush-output-port port) (flush-output-port port)
(write-char c port))))))) (write-char c port))))))
(define fd-flush-proc (define fd-flush-proc
(lambda (port) (lambda (port)
(let ([idx (output-port-index port)]) (let ([idx (output-port-index port)])
(when (fx> idx 0) (when (fx> idx 0)
(foreign-call "S_write" (foreign-call "ik_write"
(output-port-fd port) (output-port-fd port)
idx idx
(output-port-buffer port)))) (output-port-buffer port))))
@ -161,72 +144,79 @@
(lambda (port) (lambda (port)
(let ([idx (output-port-index port)]) (let ([idx (output-port-index port)])
(when (fx> idx 0) (when (fx> idx 0)
(foreign-call "S_write" (foreign-call "ik_write"
(output-port-fd port) (output-port-fd port)
idx idx
(output-port-buffer port)))) (output-port-buffer port))))
(foreign-call "S_close" (output-port-fd port)))) (foreign-call "ik_close" (output-port-fd port))))
(define flush-output-port (define flush-output-port
(lambda port (lambda (port)
(let ([port
(cond
[(null? port) (current-output-port)]
[(null? (cdr port))
(let ([p (car port)])
(if (output-port? p)
p
(error 'flush-output-port "not a port: ~s" p)))]
[else
(error 'flush-output-port "too many arguments")])])
(unless (output-port-open? port) (unless (output-port-open? port)
(error 'flush-output-port "port ~s closed" port)) (error 'flush-output-port "port ~s closed" port))
((output-port-flush-proc port) port)))) ((output-port-flush-proc port) port)))
(define close-output-port (define close-output-port
(lambda (port) (lambda (port)
(unless (output-port? port)
(error 'close-output-port "not a port ~s" port))
(when (output-port-open? port) (when (output-port-open? port)
((output-port-close-proc port) port) ((output-port-close-proc port) port)
(set-output-port-open?! port #f)))) (set-output-port-open?! port #f))))
;;; init section ;;; init section
($pcb-set! close-output-port close-output-port) (primitive-set! 'close-output-port
($pcb-set! output-port? output-port?) (case-lambda
($pcb-set! open-output-file open-output-file) [() (close-output-port (current-output-port))]
($pcb-set! write-char write-char) [(p)
($pcb-set! flush-output-port flush-output-port) (unless (output-port? p)
($pcb-set! standard-output-port (error 'close-output-port "~s is not an output port" p))
(close-output-port p)]))
(primitive-set! 'output-port? output-port?)
(primitive-set! 'open-output-file
(case-lambda
[(filename) (open-output-file filename 'error)]
[(filename mode) (open-output-file filename mode)]))
(primitive-set! 'write-char
(case-lambda
[(c) (write-char c (current-output-port))]
[(c p)
(unless (output-port? p)
(error 'write-char "~s is not an output port" p))
(write-char c p)]))
(primitive-set! 'flush-output-port
(case-lambda
[() (flush-output-port (current-output-port))]
[(p)
(unless (output-port? p)
(error 'flush-output-port "~s is not an output port" p))
(flush-output-port p)]))
(primitive-set! 'standard-output-port
(let ([p (fd->port 1 '*stdout*)]) (let ([p (fd->port 1 '*stdout*)])
(lambda () p))) (lambda () p)))
($pcb-set! standard-error-port (primitive-set! 'standard-error-port
(let ([p (fd->port 2 '*stderr*)]) (let ([p (fd->port 2 '*stderr*)])
(lambda () p))) (lambda () p)))
($pcb-set! current-output-port (primitive-set! 'current-output-port
(make-parameter (standard-output-port) (make-parameter (standard-output-port)
(lambda (p) (lambda (p)
(unless (output-port? p) (unless (output-port? p)
(error 'current-output-port "not a port ~s" p)) (error 'current-output-port "not a port ~s" p))
p))) p)))
($pcb-set! console-output-port (primitive-set! 'console-output-port
(make-parameter (standard-output-port) (make-parameter (standard-output-port)
(lambda (p) (lambda (p)
(unless (output-port? p) (unless (output-port? p)
(error 'console-output-port "not a port ~s" p)) (error 'console-output-port "not a port ~s" p))
p))) p)))
($pcb-set! newline (primitive-set! 'newline
(lambda args (case-lambda
(if (null? args) [() (write-char #\newline (current-output-port))]
(write-char #\newline (current-output-port)) [(p)
(if (null? (cdr args)) (unless (output-port? p)
(let ([p (car args)]) (error 'newline "~s is not an output port" p))
(if (output-port? p) (write-char #\newline p)]))
(write-char #\newline p)
(error 'newline "not an output port ~s" p))) (primitive-set! 'open-output-string open-output-string)
(error 'newline "too many arguments"))))) (primitive-set! 'get-output-string get-output-string)
($pcb-set! open-output-string open-output-string) (primitive-set! 'output-port-name
($pcb-set! get-output-string get-output-string)
($pcb-set! output-port-name
(lambda (x) (lambda (x)
(if (output-port? x) (if (output-port? x)
(output-port-name x) (output-port-name x)
@ -296,7 +286,7 @@
(lambda (filename) (lambda (filename)
(unless (string? filename) (unless (string? filename)
(error 'open-input-file "not a string: ~s" filename)) (error 'open-input-file "not a string: ~s" filename))
(let ([fd (foreign-call "S_open_file" filename 4)]) (let ([fd (foreign-call "ik_open_file" filename 4)])
(fd->port fd filename)))) (fd->port fd filename))))
(define close-input-port (define close-input-port
(lambda port (lambda port
@ -309,19 +299,10 @@
p p
(error 'close-input-port "not an input port: ~s" p))) (error 'close-input-port "not an input port: ~s" p)))
(error 'close-input-port "too many arguments")))]) (error 'close-input-port "too many arguments")))])
(foreign-call "S_close" (input-port-fd port)) (foreign-call "ik_close" (input-port-fd port))
(void)))) (void))))
(define read-char (define read-char
(lambda port (lambda (port)
(let ([port
(if (null? port)
(current-input-port)
(if (null? ($cdr port))
(let ([p ($car port)])
(if (input-port? p)
p
(error 'read-char "not an input port: ~s" p)))
(error 'read-char "too many arguments")))])
(unless (input-port-open? port) (unless (input-port-open? port)
(error 'read-char "port closed")) (error 'read-char "port closed"))
(cond (cond
@ -338,7 +319,7 @@
(set-input-port-index! port ($fxadd1 idx)) (set-input-port-index! port ($fxadd1 idx))
c) c)
(let ([bytes (let ([bytes
(foreign-call "S_read" (foreign-call "ik_read"
(input-port-fd port) (input-port-fd port)
buf buf
($string-length buf))]) ($string-length buf))])
@ -350,18 +331,9 @@
(begin (begin
(let ([c ($string-ref buf 0)]) (let ([c ($string-ref buf 0)])
(set-input-port-index! port 1) (set-input-port-index! port 1)
c))))))])))) c))))))])))
(define peek-char (define peek-char
(lambda port (lambda (port)
(let ([port
(if (null? port)
(current-input-port)
(if (null? (cdr port))
(let ([p (car port)])
(if (input-port? p)
p
(error 'peek-char "not an input port: ~s" p)))
(error 'peek-char "too many arguments")))])
(unless (input-port-open? port) (unless (input-port-open? port)
(error 'peek-char "port closed")) (error 'peek-char "port closed"))
(cond (cond
@ -374,7 +346,7 @@
(if (fx< idx size) (if (fx< idx size)
(string-ref buf idx) (string-ref buf idx)
(let ([bytes (let ([bytes
(foreign-call "S_read" (foreign-call "ik_read"
(input-port-fd port) (input-port-fd port)
buf buf
($string-length buf))]) ($string-length buf))])
@ -382,7 +354,7 @@
(set-input-port-index! port 0) (set-input-port-index! port 0)
(if (fxzero? bytes) (if (fxzero? bytes)
(eof-object) (eof-object)
(string-ref buf 0)))))])))) (string-ref buf 0)))))])))
(define reset-input-port! (define reset-input-port!
(lambda (p) (lambda (p)
(unless (input-port? p) (unless (input-port? p)
@ -391,52 +363,67 @@
(set-input-port-size! p 0) (set-input-port-size! p 0)
(set-input-port-returned-char! p #f))) (set-input-port-returned-char! p #f)))
(define unread-char (define unread-char
(lambda (c . port) (lambda (c port)
(let ([port
(if (null? port)
(current-input-port)
(if (null? (cdr port))
(let ([p (car port)])
(if (input-port? p)
p
(error 'unread-char "not an input port: ~s" p)))
(error 'unread-char "too many arguments")))])
(unless (char? c) (unless (char? c)
(error 'unread-char "not a character ~s" c)) (error 'unread-char "not a character ~s" c))
(unless (input-port-open? port) (unless (input-port-open? port)
(error 'unread-char "port closed")) (error 'unread-char "port closed"))
(when (input-port-returned-char port) (when (input-port-returned-char port)
(error 'unread-char "cannot unread twice")) (error 'unread-char "cannot unread twice"))
(set-input-port-returned-char! port c)))) (set-input-port-returned-char! port c)))
($pcb-set! open-input-file open-input-file) (primitive-set! 'open-input-file open-input-file)
($pcb-set! close-input-port close-input-port) (primitive-set! 'close-input-port
($pcb-set! input-port? input-port?) (case-lambda
($pcb-set! read-char read-char) [() (close-input-port (current-input-port))]
($pcb-set! unread-char unread-char) [(p)
($pcb-set! peek-char peek-char) (unless (input-port? p)
($pcb-set! standard-input-port (error 'close-input-port "~s is not an input port" p))
(close-input-port p)]))
(primitive-set! 'input-port? input-port?)
(primitive-set! 'read-char
(case-lambda
[() (read-char (current-input-port))]
[(p)
(unless (input-port? p)
(error 'read-char "~s is not an input port" p))
(read-char p)]))
(primitive-set! 'peek-char
(case-lambda
[() (peek-char (current-input-port))]
[(p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(peek-char p)]))
(primitive-set! 'unread-char
(case-lambda
[(c) (unread-char c (current-input-port))]
[(c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(unread-char c p)]))
(primitive-set! 'standard-input-port
(let ([p (fd->port 0 '*stdin*)]) (let ([p (fd->port 0 '*stdin*)])
(lambda () p))) (lambda () p)))
($pcb-set! current-input-port (primitive-set! 'current-input-port
(make-parameter (standard-input-port) (make-parameter (standard-input-port)
(lambda (x) (lambda (x)
(unless (input-port? x) (unless (input-port? x)
(error 'current-input-port "not an input port ~s" x)) (error 'current-input-port "not an input port ~s" x))
x))) x)))
($pcb-set! console-input-port (primitive-set! 'console-input-port
(make-parameter (standard-input-port) (make-parameter (standard-input-port)
(lambda (x) (lambda (x)
(unless (input-port? x) (unless (input-port? x)
(error 'console-input-port "not an input port ~s" x)) (error 'console-input-port "not an input port ~s" x))
x))) x)))
($pcb-set! input-port-name (primitive-set! 'input-port-name
(lambda (x) (lambda (x)
(if (input-port? x) (if (input-port? x)
(input-port-name x) (input-port-name x)
(error 'input-port-name "~s is not an input port" x)))) (error 'input-port-name "~s is not an input port" x))))
($pcb-set! reset-input-port! reset-input-port!)) (primitive-set! 'reset-input-port! reset-input-port!))
($pcb-set! with-output-to-file (primitive-set! 'with-output-to-file
(lambda (name proc . args) (lambda (name proc . args)
(unless (string? name) (unless (string? name)
(error 'with-output-to-file "~s is not a string" name)) (error 'with-output-to-file "~s is not a string" name))
@ -455,7 +442,7 @@
(close-output-port p) (close-output-port p)
(set! shot #t))))))) (set! shot #t)))))))
($pcb-set! call-with-output-file (primitive-set! 'call-with-output-file
(lambda (name proc . args) (lambda (name proc . args)
(unless (string? name) (unless (string? name)
(error 'call-with-output-file "~s is not a string" name)) (error 'call-with-output-file "~s is not a string" name))
@ -472,7 +459,7 @@
(close-output-port p) (close-output-port p)
(set! shot #t)))))) (set! shot #t))))))
($pcb-set! with-input-from-file (primitive-set! 'with-input-from-file
(lambda (name proc . args) (lambda (name proc . args)
(unless (string? name) (unless (string? name)
(error 'with-input-from-file "~s is not a string" name)) (error 'with-input-from-file "~s is not a string" name))
@ -491,7 +478,7 @@
(close-input-port p) (close-input-port p)
(set! shot #t))))))) (set! shot #t)))))))
($pcb-set! call-with-input-file (primitive-set! 'call-with-input-file
(lambda (name proc . args) (lambda (name proc . args)
(unless (string? name) (unless (string? name)
(error 'call-with-input-file "~s is not a string" name)) (error 'call-with-input-file "~s is not a string" name))

BIN
src/libio.fasl
View File

Binary file not shown.

23
src/libposix-5.7.ss
View File

@ -1,23 +0,0 @@
($pcb-set! posix-fork
(lambda ()
(foreign-call "S_fork")))
($pcb-set! fork
(lambda (parent-proc child-proc)
(let ([pid (posix-fork)])
(cond
[(fx= pid 0) (child-proc)]
[(fx= pid -1)
(error 'fork "failed")]
[else (parent-proc pid)]))))
($pcb-set! system
(lambda (x)
(unless (string? x)
(error 'system "~s is not a string" x))
(let ([rv (foreign-call "S_system" x)])
(if (fx= rv -1)
(error 'system "failed")
rv))))

23
src/libposix-6.0.ss Normal file
View File

@ -0,0 +1,23 @@
;;; ($pcb-set! posix-fork
;;; (lambda ()
;;; (foreign-call "S_fork")))
;;;
;;; ($pcb-set! fork
;;; (lambda (parent-proc child-proc)
;;; (let ([pid (posix-fork)])
;;; (cond
;;; [(fx= pid 0) (child-proc)]
;;; [(fx= pid -1)
;;; (error 'fork "failed")]
;;; [else (parent-proc pid)]))))
(primitive-set! 'system
(lambda (x)
(unless (string? x)
(error 'system "~s is not a string" x))
(let ([rv (foreign-call "ik_system" x)])
(if (fx= rv -1)
(error 'system "failed")
rv))))

58
src/librecord-5.6.ss → src/librecord-6.1.ss
View File

@ -2,25 +2,17 @@
(let () (let ()
(define record-type-rtd
(let ([rtd ($make-record #f 4)])
($record-set! rtd -1 rtd)
($record-set! rtd 0 4)
($record-set! rtd 1 "record-type")
($record-set! rtd 2 '(length name fields printer))
($record-set! rtd 3 #f)
rtd))
(define rtd? (define rtd?
(lambda (x) (lambda (x)
(and ($record? x) (and ($record? x)
(eq? ($record-rtd x) record-type-rtd)))) (eq? ($record-rtd x) $base-rtd))))
(define rtd-length (define rtd-name
(lambda (rtd) (lambda (rtd)
($record-ref rtd 0))) ($record-ref rtd 0)))
(define rtd-name (define rtd-length
(lambda (rtd) (lambda (rtd)
($record-ref rtd 1))) ($record-ref rtd 1)))
@ -32,13 +24,13 @@
(lambda (rtd) (lambda (rtd)
($record-ref rtd 3))) ($record-ref rtd 3)))
(define set-rtd-length!
(lambda (rtd n)
($record-set! rtd 0 n)))
(define set-rtd-name! (define set-rtd-name!
(lambda (rtd name) (lambda (rtd name)
($record-set! rtd 1 name))) ($record-set! rtd 0 name)))
(define set-rtd-length!
(lambda (rtd n)
($record-set! rtd 1 n)))
(define set-rtd-fields! (define set-rtd-fields!
(lambda (rtd fields) (lambda (rtd fields)
@ -50,9 +42,9 @@
(define make-rtd (define make-rtd
(lambda (name fields printer) (lambda (name fields printer)
(let ([rtd ($make-record record-type-rtd 4)]) (let ([rtd ($make-record $base-rtd 4)])
($record-set! rtd 0 (length fields)) ($record-set! rtd 0 name)
($record-set! rtd 1 name) ($record-set! rtd 1 (length fields))
($record-set! rtd 2 fields) ($record-set! rtd 2 fields)
($record-set! rtd 3 printer) ($record-set! rtd 3 printer)
rtd))) rtd)))
@ -202,21 +194,23 @@
(error 'record-set! "index ~s is out of range for ~s" i x)) (error 'record-set! "index ~s is out of range for ~s" i x))
($record-set! x i v)))) ($record-set! x i v))))
($pcb-set! make-record-type make-record-type) (primitive-set! 'make-record-type make-record-type)
($pcb-set! record-constructor record-constructor) (primitive-set! 'record-constructor record-constructor)
($pcb-set! record-predicate record-predicate) (primitive-set! 'record-predicate record-predicate)
($pcb-set! record-field-accessor record-field-accessor) (primitive-set! 'record-field-accessor record-field-accessor)
($pcb-set! record-field-mutator record-field-mutator) (primitive-set! 'record-field-mutator record-field-mutator)
($pcb-set! record? record?) (primitive-set! 'record? record?)
($pcb-set! record-rtd record-rtd) (primitive-set! 'record-rtd record-rtd)
($pcb-set! record-name record-name) (primitive-set! 'record-name record-name)
($pcb-set! record-printer record-printer) (primitive-set! 'record-printer record-printer)
($pcb-set! record-length record-length) (primitive-set! 'record-length record-length)
($pcb-set! record-ref record-ref) (primitive-set! 'record-ref record-ref)
($pcb-set! record-set! record-set!) (primitive-set! 'record-set! record-set!)
(set-rtd-printer! record-type-rtd (set-rtd-fields! $base-rtd '(name fields length printer))
(set-rtd-name! $base-rtd "base-rtd")
(set-rtd-printer! $base-rtd
(lambda (x p) (lambda (x p)
(unless (rtd? x) (unless (rtd? x)
(error 'record-type-printer "not an rtd")) (error 'record-type-printer "not an rtd"))

BIN
src/librecord.fasl
View File

Binary file not shown.

93
src/libsymboltable-5.6.ss
View File

@ -1,93 +0,0 @@
(let ()
;;; (define hash-loop
;;; (lambda (str i j h)
;;; (cond
;;; [($fx= i j) h]
;;;; ($fxlogxor h ($fxsra h 15))]
;;; [else
;;; (hash-loop str ($fxadd1 i) j
;;; ($fxlogxor
;;; ($char->fixnum ($string-ref str i))
;;; ($fxlogxor
;;; ($fxsll h 5)
;;; ($fxsra h 23))))])))
(define hash-loop
(lambda (str i j h)
(cond
[($fx= i j)
(let* ([h ($fx+ h ($fxsll h 3))]
[h ($fxlogxor h ($fxsra h 11))]
[h ($fx+ h ($fxsll h 15))])
h)]
[else
(hash-loop str ($fxadd1 i) j
(let ([h ($fx+ h ($char->fixnum ($string-ref str i)))])
(let ([h ($fx+ h ($fxsll h 10))])
($fxlogxor h ($fxsra h 6)))))])))
(define hash-function
(lambda (str)
(let ([n ($string-length str)])
(hash-loop str 0 n 0))))
(define str=
(lambda (s1 s2 i n)
(or ($fx= i n)
(and ($char= ($string-ref s1 i) ($string-ref s2 i))
(str= s1 s2 ($fxadd1 i) n)))))
(define bucket-lookup
(lambda (str strlen ls)
(if (null? ls)
'#f
(let ([a ($car ls)])
(let ([str2 ($symbol-string a)])
(if (and ($fx= ($string-length str2) strlen)
(str= str str2 0 strlen))
a
(bucket-lookup str strlen ($cdr ls))))))))
(define intern
(lambda (str htable)
(let ([h (hash-function str)])
(let ([idx ($fxlogand h ($fx- ($vector-length htable) 1))])
(let ([bucket ($vector-ref htable idx)])
(or (bucket-lookup str ($string-length str) bucket)
(let ([sym ($make-symbol str)])
($vector-set! htable idx (cons sym bucket))
($set-symbol-unique-string! sym #f)
sym)))))))
(define old-intern
(lambda (str htable)
(or (bucket-lookup str ($string-length str) ($vector-ref htable 0))
(let ([sym ($make-symbol str)])
($vector-set! htable 0 (cons sym ($vector-ref htable 0)))
sym))))
(define init-vec
(lambda (v i n)
(unless ($fx= i n)
($vector-set! v i '())
(init-vec v ($fxadd1 i) n))))
(define revappend
(lambda (ls ac)
(cond
[(null? ls) ac]
[else (revappend ($cdr ls) (cons ($car ls) ac))])))
(define vec->list
(lambda (v i j ls)
(cond
[($fx= i j) ls]
[else
(vec->list v ($fxadd1 i) j
(revappend ($vector-ref v i) ls))])))
(define hash-vec ($make-vector 4096))
(init-vec hash-vec 0 4096)
($pcb-set! $intern
(lambda (str)
(intern str hash-vec)))
($pcb-set! oblist
(lambda ()
(vec->list hash-vec 0 4096 '()))))

169
src/libtokenizer-5.7.ss → src/libtokenizer-6.1.ss
View File

@ -1,7 +1,7 @@
(let () (let ()
(define char-whitespace? (define char-whitespace?
(lambda (c) (lambda (c)
(or (char= #\space c) (or ($char= #\space c)
(memq ($char->fixnum c) '(9 10 11 12 13))))) (memq ($char->fixnum c) '(9 10 11 12 13)))))
(define delimiter? (define delimiter?
(lambda (c) (lambda (c)
@ -9,7 +9,7 @@
(memq c '(#\( #\) #\[ #\] #\' #\` #\, #\"))))) (memq c '(#\( #\) #\[ #\] #\' #\` #\, #\")))))
(define digit? (define digit?
(lambda (c) (lambda (c)
(and (char<= #\0 c) (char<= c #\9)))) (and ($char<= #\0 c) ($char<= c #\9))))
(define char->num (define char->num
(lambda (c) (lambda (c)
(fx- ($char->fixnum c) ($char->fixnum #\0)))) (fx- ($char->fixnum c) ($char->fixnum #\0))))
@ -18,15 +18,15 @@
(or (letter? c) (special-initial? c)))) (or (letter? c) (special-initial? c))))
(define letter? (define letter?
(lambda (c) (lambda (c)
(or (and (char<= #\a c) (char<= c #\z)) (or (and ($char<= #\a c) ($char<= c #\z))
(and (char<= #\A c) (char<= c #\Z))))) (and ($char<= #\A c) ($char<= c #\Z)))))
(define af? (define af?
(lambda (c) (lambda (c)
(or (and (char<= #\a c) (char<= c #\f)) (or (and ($char<= #\a c) ($char<= c #\f))
(and (char<= #\A c) (char<= c #\F))))) (and ($char<= #\A c) ($char<= c #\F)))))
(define af->num (define af->num
(lambda (c) (lambda (c)
(if (and (char<= #\a c) (char<= c #\f)) (if (and ($char<= #\a c) ($char<= c #\f))
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a))) (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A)))))) (fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
(define special-initial? (define special-initial?
@ -77,9 +77,9 @@
(cons 'datum (tokenize-hex (char->num c) p))] (cons 'datum (tokenize-hex (char->num c) p))]
[(af? c) [(af? c)
(cons 'datum (tokenize-hex (af->num c) p))] (cons 'datum (tokenize-hex (af->num c) p))]
[(char= c #\-) [($char= c #\-)
(cons 'datum (fx- 0 (tokenize-hex 0 p)))] (cons 'datum (fx- 0 (tokenize-hex 0 p)))]
[(char= c #\+) [($char= c #\+)
(cons 'datum (tokenize-hex 0 p))] (cons 'datum (tokenize-hex 0 p))]
[else [else
(unread-char c p) (unread-char c p)
@ -104,14 +104,14 @@
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "end-of-file while inside a string")] (error 'tokenize "end-of-file while inside a string")]
[(char= #\" c) ls] [($char= #\" c) ls]
[(char= #\\ c) [($char= #\\ c)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(char= #\" c) (tokenize-string (cons #\" ls) p)] [($char= #\" c) (tokenize-string (cons #\" ls) p)]
[(char= #\\ c) (tokenize-string (cons #\\ ls) p)] [($char= #\\ c) (tokenize-string (cons #\\ ls) p)]
[(char= #\n c) (tokenize-string (cons #\newline ls) p)] [($char= #\n c) (tokenize-string (cons #\newline ls) p)]
[(char= #\t c) (tokenize-string (cons #\tab ls) p)] [($char= #\t c) (tokenize-string (cons #\tab ls) p)]
[else (error 'tokenize "invalid string escape \\~a" c)]))] [else (error 'tokenize "invalid string escape \\~a" c)]))]
[else [else
(tokenize-string (cons c ls) p)])))) (tokenize-string (cons c ls) p)]))))
@ -148,13 +148,13 @@
(cond (cond
[(eof-object? c) 'dot] [(eof-object? c) 'dot]
[(delimiter? c) 'dot] [(delimiter? c) 'dot]
[(char= c #\.) ; this is second dot [($char= c #\.) ; this is second dot
(read-char p) (read-char p)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "invalid syntax .. near end of file")] (error 'tokenize "invalid syntax .. near end of file")]
[(char= c #\.) ; this is the third [($char= c #\.) ; this is the third
(let ([c (peek-char p)]) (let ([c (peek-char p)])
(cond (cond
[(eof-object? c) '(datum . ...)] [(eof-object? c) '(datum . ...)]
@ -180,7 +180,7 @@
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "invalid eof in the middle of #\\~a" str)] (error 'tokenize "invalid eof in the middle of #\\~a" str)]
[(char= c (string-ref str i)) [($char= c (string-ref str i))
(tokenize-char* (fxadd1 i) str p d)] (tokenize-char* (fxadd1 i) str p d)]
[else [else
(error 'tokenize (error 'tokenize
@ -191,7 +191,7 @@
(cond (cond
[(eof-object? c) (cons 'datum (string-ref str 0))] [(eof-object? c) (cons 'datum (string-ref str 0))]
[(delimiter? c) (cons 'datum (string-ref str 0))] [(delimiter? c) (cons 'datum (string-ref str 0))]
[(char= (string-ref str 1) c) [($char= (string-ref str 1) c)
(read-char p) (read-char p)
(tokenize-char* 2 str p d)] (tokenize-char* 2 str p d)]
[else (error 'tokenize "invalid syntax near #\\~a~a" [else (error 'tokenize "invalid syntax near #\\~a~a"
@ -202,13 +202,13 @@
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "invalid #\\ near end of file")] (error 'tokenize "invalid #\\ near end of file")]
[(char= #\s c) [($char= #\s c)
(tokenize-char-seq p "space" '(datum . #\space))] (tokenize-char-seq p "space" '(datum . #\space))]
[(char= #\n c) [($char= #\n c)
(tokenize-char-seq p "newline" '(datum . #\newline))] (tokenize-char-seq p "newline" '(datum . #\newline))]
[(char= #\t c) [($char= #\t c)
(tokenize-char-seq p "tab" '(datum . #\tab))] (tokenize-char-seq p "tab" '(datum . #\tab))]
[(char= #\r c) [($char= #\r c)
(tokenize-char-seq p "return" '(datum . #\return))] (tokenize-char-seq p "return" '(datum . #\return))]
[else [else
(let ([n (peek-char p)]) (let ([n (peek-char p)])
@ -226,17 +226,17 @@
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) (multiline-error)] [(eof-object? c) (multiline-error)]
[(char= #\| c) [($char= #\| c)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) (multiline-error)] [(eof-object? c) (multiline-error)]
[(char= #\# c) (void)] [($char= #\# c) (void)]
[else (multiline-comment p)]))] [else (multiline-comment p)]))]
[(char= #\# c) [($char= #\# c)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) (multiline-error)] [(eof-object? c) (multiline-error)]
[(char= #\| c) [($char= #\| c)
(multiline-comment p) (multiline-comment p)
(multiline-comment p)] (multiline-comment p)]
[else [else
@ -247,8 +247,8 @@
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) ac] [(eof-object? c) ac]
[(char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)] [($char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)]
[(char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)] [($char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)]
[(delimiter? c) (unread-char c p) ac] [(delimiter? c) (unread-char c p) ac]
[else [else
(unread-char c) (unread-char c)
@ -259,67 +259,67 @@
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) (error 'tokenize "invalid # near end of file")] [(eof-object? c) (error 'tokenize "invalid # near end of file")]
[(char= c #\t) [($char= c #\t)
(let ([c (peek-char p)]) (let ([c (peek-char p)])
(cond (cond
[(eof-object? c) '(datum . #t)] [(eof-object? c) '(datum . #t)]
[(delimiter? c) '(datum . #t)] [(delimiter? c) '(datum . #t)]
[else (error 'tokenize "invalid syntax near #t")]))] [else (error 'tokenize "invalid syntax near #t")]))]
[(char= c #\f) [($char= c #\f)
(let ([c (peek-char p)]) (let ([c (peek-char p)])
(cond (cond
[(eof-object? c) '(datum . #f)] [(eof-object? c) '(datum . #f)]
[(delimiter? c) '(datum . #f)] [(delimiter? c) '(datum . #f)]
[else (error 'tokenize "invalid syntax near #f")]))] [else (error 'tokenize "invalid syntax near #f")]))]
[(char= #\\ c) (tokenize-char p)] [($char= #\\ c) (tokenize-char p)]
[(char= #\( c) 'vparen] [($char= #\( c) 'vparen]
[(char= #\x c) (tokenize-hex-init p)] [($char= #\x c) (tokenize-hex-init p)]
[(char= #\' c) '(macro . syntax)] [($char= #\' c) '(macro . syntax)]
[(char= #\; c) 'hash-semi] [($char= #\; c) 'hash-semi]
[(char= #\% c) '(macro . |#primitive|)] [($char= #\% c) '(macro . |#primitive|)]
[(char= #\| c) (multiline-comment p) (tokenize p)] [($char= #\| c) (multiline-comment p) (tokenize p)]
[(char= #\b c) [($char= #\b c)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "invalid eof while reading #b")] (error 'tokenize "invalid eof while reading #b")]
[(char= #\- c) [($char= #\- c)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "invalid eof while reading #b-")] (error 'tokenize "invalid eof while reading #b-")]
[(char= #\0 c) [($char= #\0 c)
(cons 'datum (cons 'datum
(fx- 0 (read-binary 0 '(#\0 #\-) p)))] (fx- 0 (read-binary 0 '(#\0 #\-) p)))]
[(char= #\1 c) [($char= #\1 c)
(cons 'datum (cons 'datum
(fx- 0 (read-binary 1 '(#\1 #\-) p)))] (fx- 0 (read-binary 1 '(#\1 #\-) p)))]
[else [else
(unread-char c p) (unread-char c p)
(error 'tokenize "invalid binary syntax #b-~a" c)]))] (error 'tokenize "invalid binary syntax #b-~a" c)]))]
[(char= #\0 c) [($char= #\0 c)
(cons 'datum (read-binary 0 '(#\0) p))] (cons 'datum (read-binary 0 '(#\0) p))]
[(char= #\1 c) [($char= #\1 c)
(cons 'datum (read-binary 1 '(#\1) p))] (cons 'datum (read-binary 1 '(#\1) p))]
[else [else
(unread-char c p) (unread-char c p)
(error 'tokenize "invalid syntax #b~a" c)] (error 'tokenize "invalid syntax #b~a" c)]
))] ))]
[(char= #\! c) [($char= #\! c)
(let ([e (read-char p)]) (let ([e (read-char p)])
(when (eof-object? e) (when (eof-object? e)
(error 'tokenize "invalid eof near #!")) (error 'tokenize "invalid eof near #!"))
(unless (char= #\e e) (unless ($char= #\e e)
(error 'tokenize "invalid syntax near #!~a" e)) (error 'tokenize "invalid syntax near #!~a" e))
(let ([o (read-char p)]) (let ([o (read-char p)])
(when (eof-object? o) (when (eof-object? o)
(error 'tokenize "invalid eof near #!e")) (error 'tokenize "invalid eof near #!e"))
(unless (char= #\o o) (unless ($char= #\o o)
(error 'tokenize "invalid syntax near #!e~a" o)) (error 'tokenize "invalid syntax near #!e~a" o))
(let ([f (read-char p)]) (let ([f (read-char p)])
(when (eof-object? f) (when (eof-object? f)
(error 'tokenize "invalid syntax near #!eo")) (error 'tokenize "invalid syntax near #!eo"))
(unless (char= #\f f) (unless ($char= #\f f)
(error 'tokenize "invalid syntax near #!eo~a" f)) (error 'tokenize "invalid syntax near #!eo~a" f))
(cons 'datum (eof-object)))))] (cons 'datum (eof-object)))))]
[else [else
@ -331,13 +331,13 @@
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")] (error 'tokenize "unexpected eof while reading symbol")]
[(char= #\\ c) [($char= #\\ c)
(let ([c (read-char p)]) (let ([c (read-char p)])
(cond (cond
[(eof-object? c) [(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")] (error 'tokenize "unexpected eof while reading symbol")]
[else (tokenize-bar p (cons c ac))]))] [else (tokenize-bar p (cons c ac))]))]
[(char= #\| c) ac] [($char= #\| c) ac]
[else (tokenize-bar p (cons c ac))])))) [else (tokenize-bar p (cons c ac))]))))
(define tokenize (define tokenize
(lambda (p) (lambda (p)
@ -345,39 +345,39 @@
(cond (cond
[(eof-object? c) (eof-object)] [(eof-object? c) (eof-object)]
[(char-whitespace? c) (tokenize p)] [(char-whitespace? c) (tokenize p)]
[(char= #\( c) 'lparen] [($char= #\( c) 'lparen]
[(char= #\) c) 'rparen] [($char= #\) c) 'rparen]
[(char= #\[ c) 'lbrack] [($char= #\[ c) 'lbrack]
[(char= #\] c) 'rbrack] [($char= #\] c) 'rbrack]
[(char= #\' c) '(macro . quote)] [($char= #\' c) '(macro . quote)]
[(char= #\` c) '(macro . quasiquote)] [($char= #\` c) '(macro . quasiquote)]
[(char= #\, c) [($char= #\, c)
(let ([c (peek-char p)]) (let ([c (peek-char p)])
(cond (cond
[(eof-object? c) '(macro . unquote)] [(eof-object? c) '(macro . unquote)]
[(char= c #\@) [($char= c #\@)
(read-char p) (read-char p)
'(macro . unquote-splicing)] '(macro . unquote-splicing)]
[else '(macro . unquote)]))] [else '(macro . unquote)]))]
[(char= #\# c) (tokenize-hash p)] [($char= #\# c) (tokenize-hash p)]
[(digit? c) [(digit? c)
(cons 'datum (tokenize-number (char->num c) p))] (cons 'datum (tokenize-number (char->num c) p))]
[(initial? c) [(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))]) (let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))] (cons 'datum (string->symbol (list->string ls))))]
[(char= #\" c) [($char= #\" c)
(let ([ls (tokenize-string '() p)]) (let ([ls (tokenize-string '() p)])
(cons 'datum (list->string (reverse ls))))] (cons 'datum (list->string (reverse ls))))]
[(char= #\; c) [($char= #\; c)
(skip-comment p) (skip-comment p)
(tokenize p)] (tokenize p)]
[(char= #\+ c) [($char= #\+ c)
(tokenize-plus p)] (tokenize-plus p)]
[(char= #\- c) [($char= #\- c)
(tokenize-minus p)] (tokenize-minus p)]
[(char= #\. c) [($char= #\. c)
(tokenize-dot p)] (tokenize-dot p)]
[(char= #\| c) [($char= #\| c)
(let ([ls (reverse (tokenize-bar p '()))]) (let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))] (cons 'datum (string->symbol (list->string ls))))]
[else [else
@ -481,29 +481,20 @@
;;; ;;;
;;;--------------------------------------------------------------* INIT *--- ;;;--------------------------------------------------------------* INIT *---
;;; ;;;
($pcb-set! read-token (primitive-set! 'read-token
(lambda p (case-lambda
(if (null? p) [() (tokenize (current-input-port))]
(tokenize (current-input-port)) [(p)
(if (null? (cdr p)) (if (input-port? p)
(let ([a (car p)]) (tokenize p)
(if (input-port? a) (error 'read-token "~s is not an input port" p))]))
(tokenize a) (primitive-set! 'read
(error 'read-token (case-lambda
"not an input port: ~s ~s ~s" [() (read (current-input-port))]
(vector? a) (vector-length a) a))) [(p)
(error 'read-token "too many arguments"))))) (if (input-port? p)
($pcb-set! read (read p)
(lambda p (error 'read "~s is not an input port" p))]))
(if (null? p)
(read (current-input-port))
(if (null? (cdr p))
(let ([a (car p)])
(if (input-port? a)
(read a)
(error 'read "not an input port: ~s" a)))
(error 'read "too many arguments")))))
(let () (let ()
(define read-and-eval (define read-and-eval
(lambda (p) (lambda (p)
@ -511,7 +502,7 @@
(unless (eof-object? x) (unless (eof-object? x)
(eval x) (eval x)
(read-and-eval p))))) (read-and-eval p)))))
($pcb-set! load (primitive-set! 'load
(lambda (x) (lambda (x)
(unless (string? x) (unless (string? x)
(error 'load "~s is not a string" x)) (error 'load "~s is not a string" x))

BIN
src/libtokenizer.fasl
View File

Binary file not shown.

BIN
src/libtoplevel.fasl
View File

Binary file not shown.

89
src/libtrace-5.3.ss
View File

@ -1,89 +0,0 @@
(let ()
(define k* '())
(define display-prefix
(lambda (ls t)
(unless (null? ls)
(display (if t "|" " "))
(display-prefix (cdr ls) (not t)))))
(define display-trace
(lambda (k* v)
(display-prefix k* #t)
(write v)
(newline)))
(define make-traced-procedure
(lambda (name proc)
(lambda args
(call/cf
(lambda (f)
(cond
[(memq f k*) =>
(lambda (ls)
(display-trace ls (cons name args))
(apply proc args))]
[else
(display-trace (cons 1 k*) (cons name args))
(dynamic-wind
(lambda () (set! k* (cons f k*)))
(lambda ()
(let ([v
(call/cf
(lambda (nf)
(set! f nf)
(set-car! k* nf)
(apply proc args)))])
(display-trace k* v)
v))
(lambda () (set! k* (cdr k*))))]))))))
(define traced-symbols '())
(define trace-symbol!
(lambda (s)
(cond
[(assq s traced-symbols) =>
(lambda (pr)
(let ([a (cdr pr)] [v (top-level-value s)])
(unless (eq? (cdr a) v)
(unless (procedure? v)
(error 'trace
"the top-level value of ~s is ~s (not a procedure)"
s v))
(let ([p (make-traced-procedure s v)])
(set-car! a v)
(set-cdr! a p)
(set-top-level-value! s p)))))]
[else
(unless (top-level-bound? s)
(error 'trace "~s is unbound" s))
(let ([v (top-level-value s)])
(unless (procedure? v)
(error 'trace "the top-level value of ~s is ~s (not a procedure)"
s v))
(let ([p (make-traced-procedure s v)])
(set! traced-symbols
(cons (cons s (cons v p)) traced-symbols))
(set-top-level-value! s p)))])))
(define untrace-symbol!
(lambda (s)
(define loop
(lambda (ls)
(cond
[(null? ls) '()]
[(eq? s (caar ls))
(let ([a (cdar ls)])
(when (eq? (cdr a) (top-level-value s))
(set-top-level-value! s (car a)))
(cdr ls))]
[else (cons (car ls) (loop (cdr ls)))])))
(set! traced-symbols (loop traced-symbols))))
($pcb-set! make-traced-procedure make-traced-procedure)
($pcb-set! trace-symbol! trace-symbol!)
($pcb-set! untrace-symbol! untrace-symbol!))

83
src/libwriter-5.7.ss → src/libwriter-6.1.ss
View File

@ -11,16 +11,19 @@
(if m (if m
(let ([i ($char->fixnum x)]) (let ([i ($char->fixnum x)])
(write-char #\# p) (write-char #\# p)
(write-char #\\ p)
(cond (cond
[(fx< i (vector-length char-table)) [(fx< i (vector-length char-table))
(write-char #\\ p)
(write-char* (vector-ref char-table i) p)] (write-char* (vector-ref char-table i) p)]
[(fx< i 127) [(fx< i 127)
(write-char #\\ p)
(write-char x p)] (write-char x p)]
[(fx= i 127) [(fx= i 127)
(write-char #\\ p)
(write-char* "del" p)] (write-char* "del" p)]
[else [else
(error 'writer "invalid character index ~s" i)])) (write-char #\+ p)
(write-fixnum i p)]))
(write-char x p)))) (write-char x p))))
(define write-list (define write-list
(lambda (x p m) (lambda (x p m)
@ -140,10 +143,10 @@
(unless (fx= i n) (unless (fx= i n)
(let ([c (string-ref x i)]) (let ([c (string-ref x i)])
(cond (cond
[(or (char= #\" c) (char= #\\ c)) [(or ($char= #\" c) ($char= #\\ c))
(write-char #\\ p) (write-char #\\ p)
(write-char c p)] (write-char c p)]
[(char= #\tab c) [($char= #\tab c)
(write-char #\\ p) (write-char #\\ p)
(write-char #\t p)] (write-char #\t p)]
[else [else
@ -246,24 +249,23 @@
(if (procedure? printer) (if (procedure? printer)
(printer x p) (printer x p)
(write-record x p m)))] (write-record x p m)))]
[(code? x) ;[(code? x)
(write-char* "#<code>" p)] ; (write-char* "#<code>" p)]
[(hash-table? x)
(write-char* "#<hash-table>" p)]
[($unbound-object? x)
(write-char* "#<unbound-object>" p)]
[($forward-ptr? x)
(write-char* "#<forward-ptr>" p)]
[else [else
(write-char* "#<unknown>" p)]))) (write-char* "#<unknown>" p)])))
(define generic-writer
(lambda (who) (define (write x p)
(lambda (x . p) (writer x p #t)
(let ([port (flush-output-port p))
(if (null? p) (define (display x p)
(current-output-port) (writer x p #f)
(if (null? (cdr p)) (flush-output-port p))
(let ([p (car p)])
(if (output-port? p)
p
(error who "not an output port ~s" p)))
(error who "too many arguments")))])
(writer x port (eq? who 'write))
(flush-output-port port)))))
;;; ;;;
(define formatter (define formatter
(lambda (who p fmt args) (lambda (who p fmt args)
@ -271,21 +273,21 @@
(unless (fx= i (string-length fmt)) (unless (fx= i (string-length fmt))
(let ([c (string-ref fmt i)]) (let ([c (string-ref fmt i)])
(cond (cond
[(char= c #\~) [($char= c #\~)
(let ([i (fxadd1 i)]) (let ([i (fxadd1 i)])
(when (fx= i (string-length fmt)) (when (fx= i (string-length fmt))
(error who "invalid ~~ at end of format string ~s" fmt)) (error who "invalid ~~ at end of format string ~s" fmt))
(let ([c (string-ref fmt i)]) (let ([c (string-ref fmt i)])
(cond (cond
[(char= c #\~) [($char= c #\~)
(write-char #\~ p) (write-char #\~ p)
(f (fxadd1 i) args)] (f (fxadd1 i) args)]
[(char= c #\a) [($char= c #\a)
(when (null? args) (when (null? args)
(error who "insufficient arguments")) (error who "insufficient arguments"))
(display (car args) p) (display (car args) p)
(f (fxadd1 i) (cdr args))] (f (fxadd1 i) (cdr args))]
[(char= c #\s) [($char= c #\s)
(when (null? args) (when (null? args)
(error who "insufficient arguments")) (error who "insufficient arguments"))
(write (car args) p) (write (car args) p)
@ -318,7 +320,6 @@
(formatter 'format p fmt args) (formatter 'format p fmt args)
(get-output-string p)))) (get-output-string p))))
(define print-error (define print-error
(lambda (who fmt . args) (lambda (who fmt . args)
(unless (string? fmt) (unless (string? fmt)
@ -333,24 +334,36 @@
;;; ;;;
($pcb-set! format format) (primitive-set! 'format format)
($pcb-set! printf printf) (primitive-set! 'printf printf)
($pcb-set! fprintf fprintf) (primitive-set! 'fprintf fprintf)
($pcb-set! display (generic-writer 'display)) (primitive-set! 'write
($pcb-set! write (generic-writer 'write)) (case-lambda
($pcb-set! print-error print-error) [(x) (write x (current-output-port))]
($pcb-set! current-error-handler [(x p)
(unless (output-port? p)
(error 'write "~s is not an output port" p))
(write x p)]))
(primitive-set! 'display
(case-lambda
[(x) (display x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'display "~s is not an output port" p))
(display x p)]))
(primitive-set! 'print-error print-error)
(primitive-set! 'current-error-handler
(make-parameter (make-parameter
(lambda args (lambda args
(apply print-error args) (apply print-error args)
(display "exiting\n") (display "exiting\n" (console-output-port))
(flush-output-port) (flush-output-port (console-output-port))
(exit -100)) (exit -100))
(lambda (x) (lambda (x)
(if (procedure? x) (if (procedure? x)
x x
(error 'current-error-handler "~s is not a procedure" x))))) (error 'current-error-handler "~s is not a procedure" x)))))
($pcb-set! error (primitive-set! 'error
(lambda args (lambda args
(apply (current-error-handler) args)))) (apply (current-error-handler) args))))

BIN
src/libwriter.fasl
View File

Binary file not shown.

BIN
src/petite-ikarus.fasl
View File

Binary file not shown.

2
src/record-case.ss
View File

@ -10,7 +10,7 @@
#'(i . i*))])) #'(i . i*))]))
(define (generate-body ctxt cls*) (define (generate-body ctxt cls*)
(syntax-case cls* (else) (syntax-case cls* (else)
[() #'(error #f "unmatched ~s" v)] [() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v #'x))]
[([else b b* ...]) #'(begin b b* ...)] [([else b b* ...]) #'(begin b b* ...)]
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name) [([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
(with-syntax ([altern (generate-body ctxt #'rest)] (with-syntax ([altern (generate-body ctxt #'rest)]

421
src/runtime-5.4.c
View File

@ -1,421 +0,0 @@
#include <stdio.h>
#include <sys/mman.h>
#include <stdlib.h>
#include <signal.h>
#include <unistd.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include "scheme.h"
#define mask(x,m) (((int)(x)) & (int)(m))
#define unshift(n) (((int)(n)) >> fx_shift)
#define shift(n) ((ptr)((n) << fx_shift))
#define ref(x,i) (*((ptr*)((x)+(i))))
#define pagesize 4096
static void install_handlers();
static char* char_string[128] = {
"#\\nul","#\\soh","#\\stx","#\\etx","#\\eot","#\\enq","#\\ack","#\\bel",
"#\\bs", "#\\tab","#\\lf", "#\\vt", "#\\ff", "#\\cr", "#\\so", "#\\si",
"#\\dle","#\\dc1","#\\dc2","#\\dc3","#\\dc4","#\\nak","#\\syn","#\\etb",
"#\\can","#\\em", "#\\sub","#\\esc","#\\fs", "#\\gs", "#\\rs", "#\\us",
"#\\space","#\\!","#\\\"","#\\#","#\\$","#\\%","#\\&","#\\'",
"#\\(","#\\)","#\\*","#\\+","#\\,","#\\-","#\\.","#\\/",
"#\\0","#\\1","#\\2","#\\3","#\\4","#\\5","#\\6","#\\7",
"#\\8","#\\9","#\\:","#\\;","#\\<","#\\=","#\\>","#\\?",
"#\\@","#\\A","#\\B","#\\C","#\\D","#\\E","#\\F","#\\G",
"#\\H","#\\I","#\\J","#\\K","#\\L","#\\M","#\\N","#\\O",
"#\\P","#\\Q","#\\R","#\\S","#\\T","#\\U","#\\V","#\\W",
"#\\X","#\\Y","#\\Z","#\\[","#\\\\","#\\]","#\\^","#\\_",
"#\\`","#\\a","#\\b","#\\c","#\\d","#\\e","#\\f","#\\g",
"#\\h","#\\i","#\\j","#\\k","#\\l","#\\m","#\\n","#\\o",
"#\\p","#\\q","#\\r","#\\s","#\\t","#\\u","#\\v","#\\w",
"#\\x","#\\y","#\\z","#\\{","#\\|","#\\}","#\\~","#\\del"};
static ptr s_car(ptr x){
ptr* p = (ptr*)(x - pair_tag);
return p[0];
}
static ptr s_cdr(ptr x){
ptr* p = (ptr*)(x - pair_tag);
return p[1];
}
static void print_object(ptr x);
static void print_rest(ptr x){
while(1){
if (x == empty_list) {
return;
} else if(mask(x,pair_mask) == pair_tag){
printf(" ");
print_object(s_car(x));
x = s_cdr(x);
} else {
printf(" . ");
print_object(x);
return;
}
}
}
static void print_vector(ptr p){
int len = (int) ref(p, disp_vector_length - vector_tag);
int i;
printf("#(");
if(len > 0){
print_object(ref(p, disp_vector_data - vector_tag));
for(i=disp_vector_data; i<len; i+=wordsize){
printf(" ");
print_object(ref(p, disp_vector_data + i - vector_tag));
}
}
printf(")");
}
static void print_string(ptr x){
int len = (int) ref(x, disp_string_length - string_tag);
len = unshift(len);
printf("\"");
int i;
for(i=0; i<len; i++){
char c = x[disp_string_data + i - string_tag];
if((c == '"') || (c == '\\')){
printf("\\");
}
printf("%c", c);
}
printf("\"");
}
static void print_symbol(ptr x){
ptr str = ref(x, disp_symbol_string - symbol_tag);
int len = (int) ref(str, disp_string_length - string_tag);
len = unshift(len);
int i;
for(i=0; i<len; i++){
char c = str[disp_string_data + i - string_tag];
printf("%c", c);
}
}
static void print_object(ptr x){
if(mask(x, fx_mask) == fx_tag){
printf("%d", unshift(x));
} else if(x == bool_f){
printf("#f");
} else if(x == bool_t){
printf("#t");
} else if(x == empty_list){
printf("()");
} else if(mask(x,char_mask) == char_tag){
printf("%s", char_string[((int)x >> char_shift) & 127]);
} else if(((int)x & pair_mask) == pair_tag){
printf("(");
print_object(s_car(x));
print_rest(s_cdr(x));
printf(")");
} else if(mask(x, vector_mask) == vector_tag){
print_vector(x);
} else if(mask(x, string_mask) == string_tag){
print_string(x);
} else if(mask(x, symbol_mask) == symbol_tag){
print_symbol(x);
} else {
printf("#<unknown 0x%08x>", (int)x);
}
}
static void print_ptr(ptr x){
print_object(x);
printf("\n");
return;
print_ptr(x);
}
static char* allocate_unprotected_space(int size){
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_unprotected_space failed to mmap");
exit(-10);
}
return p;
}
static char* allocate_protected_space(int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
char* p = mmap(0, aligned_size + 2*pagesize,
PROT_READ | PROT_WRITE,
MAP_ANONYMOUS | MAP_PRIVATE,
0, 0);
if(p == MAP_FAILED){
perror("allocate_protected_space failed to mmap");
exit(-10);
}
status = mprotect(p, pagesize, PROT_NONE);
if(status != 0){
perror("allocate_protected_space failed to protect");
exit(-10);
}
status = mprotect(p+pagesize+aligned_size, pagesize, PROT_NONE);
if(status != 0){
perror("allocate_protected_space failed to protect");
exit(-10);
}
return (p + pagesize);
}
static void deallocate_unprotected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p, aligned_size);
if(status != 0){
perror("deallocate_unprotected_space failed to unmap");
exit(-10);
}
}
static void deallocate_protected_space(char* p, int size){
int status;
int aligned_size = ((size + pagesize - 1) / pagesize) * pagesize;
status = munmap(p-pagesize, aligned_size + 2*pagesize);
if(status != 0){
perror("deallocate_protected_space failed to unmap");
exit(-10);
}
}
char* global_heap_start;
char* global_heap_end;
char* global_stak_start;
char* global_stak_end;
int main(int argc, char** argv){
install_handlers();
if (pagesize != getpagesize()){
fprintf(stderr, "Pagesize Mismatch\n");
exit(-1);
}
int stak_size = (256 * pagesize); /* holds 128k cells */
int heap_size = (640 * pagesize); /* holds 1M cells */
char* heap = allocate_unprotected_space(heap_size);
char* stak = allocate_unprotected_space(stak_size);
global_heap_start = heap;
global_stak_start = stak;
global_heap_end = heap+heap_size;
global_stak_end = stak+stak_size;
pcb_t* pcb = (pcb_t*) allocate_protected_space(sizeof(pcb_t));
pcb->heap_base = heap;
pcb->heap_size = (char*) heap_size;
pcb->allocation_pointer = heap;
pcb->allocation_redline = heap + heap_size - 2 * pagesize;
pcb->stack_top = stak;
pcb->stack_size = (char*) stak_size;
pcb->frame_redline = stak + 2 * pagesize;
pcb->frame_base = stak + stak_size - wordsize;
#if 0
fprintf(stderr, "stack=0x%08x .. 0x%08x (redline=0x%08x)\n",
(int) pcb->frame_base,
(int) pcb->stack_top,
(int) pcb->frame_redline);
#endif
scheme_main(pcb);
#if 0
fprintf(stderr, "%d bytes used\n", pcb->allocation_pointer - heap);
#endif
deallocate_unprotected_space(stak, stak_size);
deallocate_unprotected_space(pcb->heap_base, (int) pcb->heap_size);
deallocate_protected_space((char*)pcb, sizeof(pcb_t));
return 0;
}
ptr S_error(ptr args){
if(mask(args,pair_mask) != pair_tag){
fprintf(stderr, "Error in Error: no arguments\n");
exit(-1);
}
ptr fst = ref(args, disp_car - pair_tag);
if(fst == bool_f){
fprintf(stderr, "Error\n");
exit(0);
}
if(mask(fst, symbol_mask) == symbol_tag){
ptr str = ref(fst, disp_symbol_string - symbol_tag);
fprintf(stderr, "Error in %s\n", str+disp_string_data-string_tag);
exit(0);
}
fprintf(stderr, "Invalid argument 0x%08x to S_error\n", (int)fst);
exit(-1);
}
/*
* From the manpages:
*
* int open(const char *pathname, int flags);
* int open(const char *pathname, int flags, mode_t mode);
* flags = (O_RDONLY | O_WRONLY | O_RDWR) ? O_CREAT ? O_TRUNC ? O_APPEND
* return -1 on failure
*
* int unlink(const char *pathname);
*/
ptr S_open_file(ptr str, ptr flagptr){
int flags;
int f = unshift(flagptr);
char* path = str + disp_string_data - string_tag;
if(f == 0){
flags = O_WRONLY;
} else if(f == 1){
flags = O_WRONLY | O_APPEND;
} else if(f == 2){
unlink(path);
flags = O_WRONLY | O_CREAT;
} else if(f == 3){
flags = O_WRONLY | O_TRUNC;
} else if(f == 4){
flags = O_RDONLY;
} else {
fprintf(stderr, "Error in S_open_file: invalid mode 0x%08x\n",
(int)flagptr);
exit(-10);
}
int fd = open(path, flags, S_IRUSR | S_IWUSR | S_IRGRP | S_IROTH);
if(fd == -1){
fprintf(stderr, "Cannot open %s\n", path);
perror("S_open_file");
exit(-10);
}
if(fd != unshift(shift(fd))){
fprintf(stderr, "fd %d too big\n", fd);
exit(-10);
}
return shift(fd);
}
ptr S_write(ptr fdptr, ptr idx, ptr str){
int fd = unshift(fdptr);
int len = unshift(idx);
char* buf = str+disp_string_data-string_tag;
int bytes = write(fd, buf, len);
if(bytes != len){
perror("S_write");
exit(-10);
}
return bool_t;
}
ptr S_read(ptr fdptr, ptr bufptr, ptr lenptr){
int fd = unshift(fdptr);
int len = unshift(lenptr);
char* buf = bufptr+disp_string_data-string_tag;
int bytes = read(fd, buf, len);
if(bytes == -1){
perror("S_read");
exit(-10);
}
return shift(bytes);
}
ptr S_close(ptr fd){
int err = close(unshift(fd));
if(err != 0){
perror("S_close");
exit(-10);
}
return bool_t;
}
/*
* From the manpage:
*
* int sigaction(int signum, const struct sigaction *act, struct sigaction *oldact);
* int sigprocmask(int how, const sigset_t *set, sigset_t *oldset);
* int sigpending(sigset_t *set);
* int sigsuspend(const sigset_t *mask);
struct sigaction {
void (*sa_handler)(int);
void (*sa_sigaction)(int, siginfo_t *, void *);
sigset_t sa_mask;
int sa_flags;
void (*sa_restorer)(void);
}
siginfo_t {
int si_signo;
int si_errno;
int si_code;
pid_t si_pid;
uid_t si_uid;
int si_status;
clock_t si_utime;
clock_t si_stime;
sigval_t si_value;
int si_int;
void * si_ptr;
void * si_addr;
int si_band;
int si_fd;
}
si_code:
SEGV_MAPERR | address not mapped to object
SEGV_ACCERR | invalid permissions for mapped object
*/
void segv_handler(int signum, siginfo_t * info, void* ctxt){
fprintf(stderr, "segv cought\n");
fprintf(stderr, "address of fault = 0x%08x\n", (int) info->si_addr);
fprintf(stderr, "heap is 0x%08x .. 0x%08x\n",
(int) global_heap_start,
(int) global_heap_end - 1);
fprintf(stderr, "stak is 0x%08x .. 0x%08x\n",
(int) global_stak_start,
(int) global_stak_end - 1);
fprintf(stderr, "caused by: %s\n",
(info->si_code == SEGV_MAPERR)
? "unmapped object"
: "invalid permission");
exit(-10);
}
static void install_handlers(){
return;
stack_t ss;
ss.ss_sp = malloc(SIGSTKSZ);
if (ss.ss_sp == NULL){
fprintf(stderr, "Error allocating altstack\n");
exit(-10);
}
ss.ss_size = SIGSTKSZ;
ss.ss_flags = 0;
if (sigaltstack(&ss, NULL) == -1) {
fprintf(stderr, "Error installing altstack\n");
exit(-10);
}
struct sigaction act;
sigset_t set;
sigemptyset(&set);
act.sa_sigaction = segv_handler;
act.sa_flags = SA_RESTART | SA_SIGINFO | SA_ONSTACK;
act.sa_mask = set;
int err = sigaction(SIGSEGV, &act, NULL);
if(err){
perror("installing handlers failed");
exit(-10);
}
}

3
src/runtime/Makefile
View File

@ -35,3 +35,6 @@ ikarus-hash-tables.o: ikarus-hash-tables.c ikarus.h
ikarus.h: ikarus-data.h ikarus.h: ikarus-data.h
touch ikarus.h touch ikarus.h
clean:
rm -f *.o ikarus

133
src/runtime/dump
View File

@ -1,133 +0,0 @@
SYM 0x080492fc
SYM 0x080492fc
SYM 0x080492fc
SYM 0x080492fc
SYM 0x0804b03d
SYM 0x0804b03d
SYM 0x0804935d
SYM 0x080492fc
SYM 0xa7e4b3d0
SYM 0xa7e4b3d0
SYM 0x0804ad75
SYM 0x0804acdf
SYM 0x08049394
SYM 0x080494c4
SYM 0x08049460
SYM 0x080495f2
SYM 0x08049460
SYM 0x080494c4
SYM 0x080495f2
SYM 0x080493fd
SYM 0x080493fd
ik_collect entry 16384 (pcb=0x0804e008)
current heap is 0xa7a1e000 + 4194304 = 0xa7e1e000
add_code_entry 0xa7508018 (pre=0xa7508000)
add_code_entry 0xa727e018 (pre=0xa727e000)
add_code_entry 0xa70e5018 (pre=0xa70e5000)
add_code_entry 0xa70e2018 (pre=0xa70e2000)
add_code_entry 0xa70f3018 (pre=0xa70f3000)
add_code_entry 0xa761b018 (pre=0xa761b000)
collect loop entering
scan_code 0xa761b008
add_code_entry 0xa761a018 (pre=0xa761a000)
add_code_entry 0xa7619018 (pre=0xa7619000)
add_code_entry 0xa7618018 (pre=0xa7618000)
scan_code done
scan_code 0xa7618008
scan_code done
scan_code 0xa7619008
scan_code done
scan_code 0xa761a008
scan_code done
scan_code 0xa70f3008
add_code_entry 0xa70fb018 (pre=0xa70fb000)
add_code_entry 0xa70f9018 (pre=0xa70f9000)
add_code_entry 0xa70f8018 (pre=0xa70f8000)
scan_code done
scan_code 0xa70f8008
scan_code done
scan_code 0xa70f9008
scan_code done
scan_code 0xa70fb008
scan_code done
scan_code 0xa70e2008
add_code_entry 0xa70fa018 (pre=0xa70fa000)
scan_code done
scan_code 0xa70fa008
scan_code done
scan_code 0xa70e5008
add_code_entry 0xa70e4018 (pre=0xa70e4000)
add_code_entry 0xa70e3018 (pre=0xa70e3000)
add_code_entry 0xa70e1018 (pre=0xa70e1000)
add_code_entry 0xa70e0018 (pre=0xa70e0000)
add_code_entry 0xa70df018 (pre=0xa70df000)
add_code_entry 0xa70de018 (pre=0xa70de000)
add_code_entry 0xa70dd018 (pre=0xa70dd000)
add_code_entry 0xa70dc018 (pre=0xa70dc000)
add_code_entry 0xa70db018 (pre=0xa70db000)
add_code_entry 0xa70da018 (pre=0xa70da000)
add_code_entry 0xa70d8018 (pre=0xa70d8000)
add_code_entry 0xa70d6018 (pre=0xa70d6000)
add_code_entry 0xa70d5018 (pre=0xa70d5000)
add_code_entry 0xa70d4018 (pre=0xa70d4000)
add_code_entry 0xa70d3018 (pre=0xa70d3000)
scan_code done
scan_code 0xa70d3008
scan_code done
scan_code 0xa70d4008
scan_code done
scan_code 0xa70d5008
scan_code done
scan_code 0xa70d6008
scan_code done
scan_code 0xa70d8008
add_code_entry 0xa70d7018 (pre=0xa70d7000)
scan_code done
scan_code 0xa70d7008
scan_code done
scan_code 0xa70da008
add_code_entry 0xa70d9018 (pre=0xa70d9000)
scan_code done
scan_code 0xa70d9008
scan_code done
scan_code 0xa70db008
scan_code done
scan_code 0xa70dc008
scan_code done
scan_code 0xa70dd008
scan_code done
scan_code 0xa70de008
scan_code done
scan_code 0xa70df008
scan_code done
scan_code 0xa70e0008
scan_code done
scan_code 0xa70e1008
scan_code done
scan_code 0xa70e3008
scan_code done
scan_code 0xa70e4008
scan_code done
scan_code 0xa727e008
add_code_entry 0xa7282018 (pre=0xa7282000)
add_code_entry 0xa7280018 (pre=0xa7280000)
add_code_entry 0xa727f018 (pre=0xa727f000)
scan_code done
scan_code 0xa727f008
scan_code done
scan_code 0xa7280008
scan_code done
scan_code 0xa7282008
scan_code done
scan_code 0xa7508008
add_code_entry 0xa7507018 (pre=0xa7507000)
add_code_entry 0xa7506018 (pre=0xa7506000)
add_code_entry 0xa7505018 (pre=0xa7505000)
scan_code done
scan_code 0xa7505008
scan_code done
scan_code 0xa7506008
scan_code done
scan_code 0xa7507008
scan_code done
collect loop exiting

BIN
src/runtime/ikarus
View File

Binary file not shown.

81
src/runtime/ikarus-collect.c
View File

@ -16,6 +16,17 @@
#define maximum_heap_size (pagesize * 1024 * 8) #define maximum_heap_size (pagesize * 1024 * 8)
#define minimum_stack_size (pagesize * 128) #define minimum_stack_size (pagesize * 128)
#define accounting 1
static int pair_count = 0;
static int symbol_count = 0;
static int closure_count = 0;
static int vector_count = 0;
static int record_count = 0;
static int continuation_count = 0;
static int string_count = 0;
static int htable_count = 0;
typedef struct qupages_t{ typedef struct qupages_t{
ikp p; /* pointer to the scan start */ ikp p; /* pointer to the scan start */
ikp q; /* pointer to the scan end */ ikp q; /* pointer to the scan end */
@ -162,7 +173,6 @@ init_gc(gc_t* gc){
ikpcb* ik_collect(int req, ikpcb* pcb); ikpcb* ik_collect(int req, ikpcb* pcb);
ikpcb* ik_collect_vararg(int req, ikpcb* pcb){ ikpcb* ik_collect_vararg(int req, ikpcb* pcb){
fprintf(stderr, "VARARG COLLECT req=%d\n", req);
return ik_collect(req, pcb); return ik_collect(req, pcb);
} }
@ -223,12 +233,35 @@ ik_collect(int req, ikpcb* pcb){
// fprintf(stderr, "heap base=0x%08x end=0x%08x\n", // fprintf(stderr, "heap base=0x%08x end=0x%08x\n",
// (int)pcb->heap_base, // (int)pcb->heap_base,
// (int)pcb->heap_base + pcb->heap_size); // (int)pcb->heap_base + pcb->heap_size);
bzero(pcb->heap_base, pcb->heap_size); // bzero(pcb->heap_base, pcb->heap_size);
// memset(pcb->heap_base, -1, pcb->heap_size); // memset(pcb->heap_base, -1, pcb->heap_size);
fprintf(stderr, "allocated %d pages and %d bytes (heap=0x%08x .. 0x%08x) (ht=%d)\n", // fprintf(stderr, "allocated %d pages and %d bytes (heap=0x%08x .. 0x%08x) (ht=%d)\n",
total_allocated_pages, total_malloced, // total_allocated_pages, total_malloced,
(int)pcb->heap_base, (int)pcb->heap_base+pcb->heap_size, // (int)pcb->heap_base, (int)pcb->heap_base+pcb->heap_size,
hash_table_count); // hash_table_count);
if(accounting){
fprintf(stderr,
"[%d cons|%d sym|%d cls|%d vec|%d rec|%d cck|%d str|%d htb]\n",
pair_count,
symbol_count,
closure_count,
vector_count,
record_count,
continuation_count,
string_count,
htable_count);
pair_count = 0;
symbol_count = 0;
closure_count = 0;
vector_count = 0;
record_count = 0;
continuation_count = 0;
string_count = 0;
htable_count = 0;
}
return pcb; return pcb;
} }
@ -438,20 +471,14 @@ static void collect_stack(gc_t* gc, ikp top, ikp end){
} }
else if(framesize == 0){ else if(framesize == 0){
framesize = (int)ref(top, wordsize); framesize = (int)ref(top, wordsize);
fprintf(stderr, "special frame of size %d\n", framesize);
if(framesize <= 0){ if(framesize <= 0){
fprintf(stderr, "invalid redirected framesize=%d\n", framesize); fprintf(stderr, "invalid redirected framesize=%d\n", framesize);
exit(-1); exit(-1);
} }
ikp base = top + framesize - wordsize; ikp base = top + framesize - wordsize;
while(base > top){ while(base > top){
fprintf(stderr, "obj at 0x%08x = 0x%08x\n",
(int)base, (int)ref(base,0));
ikp new_obj = add_object(gc,ref(base,0)); ikp new_obj = add_object(gc,ref(base,0));
ref(base,0) = new_obj; ref(base,0) = new_obj;
if(tagof(new_obj) == string_tag){
fprintf(stderr, "STRING %s\n", string_data(new_obj));
}
base -= wordsize; base -= wordsize;
} }
} else { } else {
@ -510,6 +537,9 @@ add_object(gc_t* gc, ikp x){
ref(y,off_cdr) = snd; ref(y,off_cdr) = snd;
ref(x,off_car) = forward_ptr; ref(x,off_car) = forward_ptr;
ref(x,off_cdr) = y; ref(x,off_cdr) = y;
if(accounting){
pair_count++;
}
return y; return y;
} }
else if(tag == symbol_tag){ else if(tag == symbol_tag){
@ -522,6 +552,9 @@ add_object(gc_t* gc, ikp x){
ref(y, off_symbol_system_plist) = ref(x, off_symbol_system_plist); ref(y, off_symbol_system_plist) = ref(x, off_symbol_system_plist);
ref(x, -symbol_tag) = forward_ptr; ref(x, -symbol_tag) = forward_ptr;
ref(x, wordsize-symbol_tag) = y; ref(x, wordsize-symbol_tag) = y;
if(accounting){
symbol_count++;
}
return y; return y;
} }
else if(tag == closure_tag){ else if(tag == closure_tag){
@ -540,6 +573,9 @@ add_object(gc_t* gc, ikp x){
ref(y,-closure_tag) = add_code_entry(gc, ref(y,-closure_tag)); ref(y,-closure_tag) = add_code_entry(gc, ref(y,-closure_tag));
ref(x,-closure_tag) = forward_ptr; ref(x,-closure_tag) = forward_ptr;
ref(x,wordsize-closure_tag) = y; ref(x,wordsize-closure_tag) = y;
if(accounting){
closure_count++;
}
return y; return y;
} }
else if(tag == vector_tag){ else if(tag == vector_tag){
@ -555,6 +591,9 @@ add_object(gc_t* gc, ikp x){
memcpy(y-vector_tag, x-vector_tag, size + disp_vector_data); memcpy(y-vector_tag, x-vector_tag, size + disp_vector_data);
ref(x,-vector_tag) = forward_ptr; ref(x,-vector_tag) = forward_ptr;
ref(x,wordsize-vector_tag) = y; ref(x,wordsize-vector_tag) = y;
if(accounting){
vector_count++;
}
return y; return y;
} }
else if(tagof(fst) == rtd_tag){ else if(tagof(fst) == rtd_tag){
@ -569,6 +608,9 @@ add_object(gc_t* gc, ikp x){
memcpy(y-vector_tag, x-vector_tag, size+wordsize); memcpy(y-vector_tag, x-vector_tag, size+wordsize);
ref(x,-vector_tag) = forward_ptr; ref(x,-vector_tag) = forward_ptr;
ref(x,wordsize-vector_tag) = y; ref(x,wordsize-vector_tag) = y;
if(accounting){
record_count++;
}
return y; return y;
} }
else if(fst == code_tag){ else if(fst == code_tag){
@ -594,6 +636,9 @@ add_object(gc_t* gc, ikp x){
ref(y, off_continuation_top) = new_top; ref(y, off_continuation_top) = new_top;
ref(y, off_continuation_size) = (ikp) size; ref(y, off_continuation_size) = (ikp) size;
ref(y, off_continuation_next) = next; ref(y, off_continuation_next) = next;
if(accounting){
continuation_count++;
}
return y; return y;
} }
else if(fst == htable_tag){ else if(fst == htable_tag){
@ -614,6 +659,9 @@ add_object(gc_t* gc, ikp x){
p->next = gc->htables_queue; p->next = gc->htables_queue;
gc->htables_queue = p; gc->htables_queue = p;
} }
if(accounting){
htable_count++;
}
return y; return y;
} }
else { else {
@ -635,10 +683,14 @@ add_object(gc_t* gc, ikp x){
strlen + 1); strlen + 1);
ref(x, -string_tag) = forward_ptr; ref(x, -string_tag) = forward_ptr;
ref(x, wordsize-string_tag) = new_str; ref(x, wordsize-string_tag) = new_str;
if(accounting){
string_count++;
}
return new_str; return new_str;
} }
else { else {
fprintf(stderr, "unhandled string with fst=0x%08x\n", (int)fst); fprintf(stderr, "unhandled string 0x%08x with fst=0x%08x\n",
(int)x, (int)fst);
exit(-1); exit(-1);
} }
} }
@ -742,7 +794,7 @@ rehash_hash_table(gc_t* gc, ikbucket** table, int size){
ikp new_val = add_object(gc, q->val); ikp new_val = add_object(gc, q->val);
q->key = new_key; q->key = new_key;
q->val = new_val; q->val = new_val;
int idx = inthash(new_key) & (size-1); int idx = inthash((int)new_key) & (size-1);
q->next = table[idx]; q->next = table[idx];
table[idx] = q; table[idx] = q;
q = next; q = next;
@ -759,7 +811,6 @@ collect_loop(gc_t* gc){
{ /* scan the pending pointer pages */ { /* scan the pending pointer pages */
qupages_t* qu = gc->ptr_queue; qupages_t* qu = gc->ptr_queue;
if(qu){ if(qu){
fprintf(stderr, "PTRQUEUE\n");
done = 0; done = 0;
gc->ptr_queue = 0; gc->ptr_queue = 0;
do{ do{

8
src/runtime/ikarus-data.h
View File

@ -146,13 +146,15 @@
#define disp_rtd_rtd 0 #define disp_rtd_rtd 0
#define disp_rtd_name 4 #define disp_rtd_name 4
#define disp_rtd_length 8 #define disp_rtd_length 8
#define disp_rtd_field 12 #define disp_rtd_fields 12
#define rtd_size 16 #define disp_rtd_printer 16
#define rtd_size 20
#define off_rtd_rtd (disp_rtd_rtd - rtd_tag) #define off_rtd_rtd (disp_rtd_rtd - rtd_tag)
#define off_rtd_name (disp_rtd_name - rtd_tag) #define off_rtd_name (disp_rtd_name - rtd_tag)
#define off_rtd_length (disp_rtd_length - rtd_tag) #define off_rtd_length (disp_rtd_length - rtd_tag)
#define off_rtd_field (disp_rtd_field - rtd_tag) #define off_rtd_fields (disp_rtd_fields - rtd_tag)
#define off_rtd_printer (disp_rtd_printer - rtd_tag)
#define continuation_tag ((ikp)0x1F) #define continuation_tag ((ikp)0x1F)
#define disp_continuation_top 4 #define disp_continuation_top 4

2
src/runtime/ikarus-exec.c
View File

@ -25,7 +25,6 @@ ikp ik_exec_code(ikpcb* pcb, ikp code_ptr){
exit(-1); exit(-1);
} }
if(framesize < k->size){ if(framesize < k->size){
fprintf(stderr, "SPLIT ");
cont* nk = (cont*) ik_alloc(pcb, sizeof(cont)); cont* nk = (cont*) ik_alloc(pcb, sizeof(cont));
nk->tag = k->tag; nk->tag = k->tag;
nk->next = k->next; nk->next = k->next;
@ -34,7 +33,6 @@ ikp ik_exec_code(ikpcb* pcb, ikp code_ptr){
k->size = framesize; k->size = framesize;
k->next = vector_tag + (ikp)nk; k->next = vector_tag + (ikp)nk;
} }
fprintf(stderr, "UF\n");
pcb->next_k = k->next; pcb->next_k = k->next;
ikp fbase = pcb->frame_base - wordsize; ikp fbase = pcb->frame_base - wordsize;
ikp new_fbase = fbase - framesize; ikp new_fbase = fbase - framesize;

1
src/runtime/ikarus-fasl.c
View File

@ -72,6 +72,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
ik_print(val); ik_print(val);
} }
} }
if(p.memp != p.memq){ if(p.memp != p.memq){
fprintf(stderr, "fasl-read did not reach eof!\n"); fprintf(stderr, "fasl-read did not reach eof!\n");
exit(-10); exit(-10);

11
src/runtime/ikarus-hash-tables.c
View File

@ -4,17 +4,6 @@
/* from http://www.concentric.net/~Ttwang/tech/inthash.htm */ /* from http://www.concentric.net/~Ttwang/tech/inthash.htm */
int
inthash(int key) {
key += ~(key << 15);
key ^= (key >> 10);
key += (key << 3);
key ^= (key >> 6);
key += ~(key << 11);
key ^= (key >> 16);
return key;
}
ikp ikp
ik_get_hash_table(ikp ht, ikp k, ikp def, ikpcb* pcb){ ik_get_hash_table(ikp ht, ikp k, ikp def, ikpcb* pcb){
ikp size = ref(ht, off_htable_size); ikp size = ref(ht, off_htable_size);

1
src/runtime/ikarus-main.c
View File

@ -16,7 +16,6 @@ int main(int argc, char** argv){
exit(-1); exit(-1);
} }
ikpcb* pcb = ik_make_pcb(); ikpcb* pcb = ik_make_pcb();
fprintf(stderr, "MAIN PCB=0x%08x\n", (int)pcb);
int i; int i;
for(i=1; i<argc; i++){ for(i=1; i<argc; i++){
char* fasl_file = argv[i]; char* fasl_file = argv[i];

18
src/runtime/ikarus-runtime.c
View File

@ -116,9 +116,19 @@ ikpcb* ik_make_pcb(){
ikdl* codes = &(pcb->codes); ikdl* codes = &(pcb->codes);
codes->next = codes; codes->next = codes;
codes->prev = codes; codes->prev = codes;
// pcb->underflow_handler = ik_underflow_handler;
// pcb->return_point = ik_return_point;
/* initialize base rtd */
{
ikp s = ik_cstring_to_symbol("$base-rtd", pcb);
ikp r = ik_alloc(pcb, align(rtd_size)) + rtd_tag;
ref(r, off_rtd_rtd) = r;
ref(r, off_rtd_length) = (ikp) (rtd_size-wordsize);
ref(r, off_rtd_name) = 0;
ref(r, off_rtd_fields) = 0;
ref(r, off_rtd_printer) = 0;
ref(s, off_symbol_system_value) = r;
ref(s, off_symbol_value) = r;
}
return pcb; return pcb;
} }
@ -261,3 +271,7 @@ ikp ik_close(ikp fd){
return true_object; return true_object;
} }
ikp
ik_system(ikp str){
return fix(system(string_data(str)));
}

10
src/runtime/ikarus-symbol-table.c
View File

@ -104,3 +104,13 @@ ikp ik_intern_string(ikp str, ikpcb* pcb){
return sym; return sym;
} }
ikp
ik_cstring_to_symbol(char* str, ikpcb* pcb){
int n = strlen(str);
int size = n + disp_string_data + 1;
ikp s = ik_alloc(pcb, align(size)) + string_tag;
ref(s, off_string_length) = fix(n);
memcpy(s+off_string_data, str, n+1);
ikp sym = ik_intern_string(s, pcb);
return sym;
}

18
src/runtime/ikarus.h
View File

@ -8,6 +8,21 @@ extern int total_allocated_pages;
extern int total_malloced; extern int total_malloced;
extern int hash_table_count; extern int hash_table_count;
static int
inthash(int key) {
key += ~(key << 15);
key ^= (key >> 10);
key += (key << 3);
key ^= (key >> 6);
key += ~(key << 11);
key ^= (key >> 16);
return key;
return inthash(key);
}
typedef unsigned char* ikp; typedef unsigned char* ikp;
void ik_error(ikp args); void ik_error(ikp args);
@ -96,6 +111,9 @@ void ik_print(ikp x);
void ik_fprint(FILE*, ikp x); void ik_fprint(FILE*, ikp x);
ikp ik_intern_string(ikp, ikpcb*); ikp ik_intern_string(ikp, ikpcb*);
ikp ik_cstring_to_symbol(char*, ikpcb*);
ikp ik_asm_enter(ikpcb*, ikp code_object, ikp arg); ikp ik_asm_enter(ikpcb*, ikp code_object, ikp arg);
ikp ik_asm_reenter(ikpcb*, ikp code_object, ikp val); ikp ik_asm_reenter(ikpcb*, ikp code_object, ikp val);
ikp ik_underflow_handler(ikpcb*); ikp ik_underflow_handler(ikpcb*);

BIN
src/runtime/tmp.fasl
View File

Binary file not shown.

10
src/runtime/typescript
View File

@ -1,10 +0,0 @@
Script started on Sat 22 Jul 2006 03:35:23 PM EDT
aghuloum@titus:~/compiler-1/runtime$ rlwrap runtime/ikarus ikarus.fasl petite-ika arus.fasl  aghuloum@titus:~/compiler-1/runtime$ gdb runtime/ikarus
 aghuloum@titus:~/compiler-1/runtime$ gdb runtime/ikarus                  ./ikarus ../ikarus.fasl ../petite-ikarus.fas sl
Petite Ikarus Scheme (Build 2006-07-22)
Copyright (c) 2006 Abdulaziz Ghuloum
> (load
aghuloum@titus:~/compiler-1/runtime$ exit
Script done on Sat 22 Jul 2006 03:35:46 PM EDT

99
src/scheme.c
View File

@ -1,99 +0,0 @@
/* automatically generated, do not edit */
#include "scheme.h"
#include <stdio.h>
ptr scheme_main(pcb_t* pcb){
extern void S_add_roots(pcb_t*,int*);
extern void S_check_roots(pcb_t*,int*);
extern void SL_values();
extern void SL_call_with_values();
extern void libsymboltable_entry(pcb_t*);
extern int libsymboltable_constant_count;
extern void libhandlers_entry(pcb_t*);
extern int libhandlers_constant_count;
extern void libcontrol_entry(pcb_t*);
extern int libcontrol_constant_count;
extern void libintelasm_entry(pcb_t*);
extern int libintelasm_constant_count;
extern void libcollect_entry(pcb_t*);
extern int libcollect_constant_count;
extern void librecord_entry(pcb_t*);
extern int librecord_constant_count;
extern void libcore_entry(pcb_t*);
extern int libcore_constant_count;
extern void libio_entry(pcb_t*);
extern int libio_constant_count;
extern void libwriter_entry(pcb_t*);
extern int libwriter_constant_count;
extern void libtokenizer_entry(pcb_t*);
extern int libtokenizer_constant_count;
extern void libexpand_entry(pcb_t*);
extern int libexpand_constant_count;
extern void libinterpret_entry(pcb_t*);
extern int libinterpret_constant_count;
extern void libcafe_entry(pcb_t*);
extern int libcafe_constant_count;
extern void libtrace_entry(pcb_t*);
extern int libtrace_constant_count;
extern void libposix_entry(pcb_t*);
extern int libposix_constant_count;
extern void libtoplevel_entry(pcb_t*);
extern void libcxr_entry(pcb_t*);
char** ap = (char**) pcb->allocation_pointer;
ap[0] = (char*) SL_values;
ap[1] = 0;
pcb->prim_208 = ((char*)ap) + closure_tag;
ap += 2;
ap[0] = (char*) SL_call_with_values;
ap[1] = 0;
pcb->prim_209 = ((char*)ap) + closure_tag;
ap += 2;
pcb->allocation_pointer = (char*)ap;
S_add_roots(pcb, &libsymboltable_constant_count);
libsymboltable_entry(pcb);
S_check_roots(pcb, &libsymboltable_constant_count);
S_add_roots(pcb, &libhandlers_constant_count);
libhandlers_entry(pcb);
S_check_roots(pcb, &libhandlers_constant_count);
S_add_roots(pcb, &libcontrol_constant_count);
libcontrol_entry(pcb);
S_check_roots(pcb, &libcontrol_constant_count);
S_add_roots(pcb, &libintelasm_constant_count);
libintelasm_entry(pcb);
S_check_roots(pcb, &libintelasm_constant_count);
S_add_roots(pcb, &libcollect_constant_count);
libcollect_entry(pcb);
S_check_roots(pcb, &libcollect_constant_count);
S_add_roots(pcb, &librecord_constant_count);
librecord_entry(pcb);
S_check_roots(pcb, &librecord_constant_count);
S_add_roots(pcb, &libcore_constant_count);
libcore_entry(pcb);
S_check_roots(pcb, &libcore_constant_count);
S_add_roots(pcb, &libio_constant_count);
libio_entry(pcb);
S_check_roots(pcb, &libio_constant_count);
S_add_roots(pcb, &libwriter_constant_count);
libwriter_entry(pcb);
S_check_roots(pcb, &libwriter_constant_count);
S_add_roots(pcb, &libtokenizer_constant_count);
libtokenizer_entry(pcb);
S_check_roots(pcb, &libtokenizer_constant_count);
S_add_roots(pcb, &libexpand_constant_count);
libexpand_entry(pcb);
S_check_roots(pcb, &libexpand_constant_count);
S_add_roots(pcb, &libinterpret_constant_count);
libinterpret_entry(pcb);
S_check_roots(pcb, &libinterpret_constant_count);
S_add_roots(pcb, &libcafe_constant_count);
libcafe_entry(pcb);
S_check_roots(pcb, &libcafe_constant_count);
S_add_roots(pcb, &libtrace_constant_count);
libtrace_entry(pcb);
S_check_roots(pcb, &libtrace_constant_count);
S_add_roots(pcb, &libposix_constant_count);
libposix_entry(pcb);
S_check_roots(pcb, &libposix_constant_count);
libcxr_entry(pcb);
libtoplevel_entry(pcb);
return scheme_entry(pcb);
}

305
src/scheme.h
View File

@ -1,305 +0,0 @@
/* automatically generated, do not edit */
#ifndef SCHEME_H
#define SCHEME_H
typedef char* ptr;
#define fx_shift 2
#define fx_mask 3
#define fx_tag 0
#define bool_f ((ptr)47)
#define bool_t ((ptr)63)
#define bool_mask 239
#define bool_tag 47
#define bool_shift 4
#define empty_list ((ptr)79)
#define wordsize 4
#define char_shift 8
#define char_tag 15
#define char_mask 255
#define pair_mask 7
#define pair_tag 1
#define disp_car 0
#define disp_cdr 4
#define pair_size 8
#define symbol_mask 7
#define symbol_tag 2
#define disp_symbol_string 0
#define disp_symbol_value 8
#define symbol_size 16
#define vector_tag 5
#define vector_mask 7
#define disp_vector_length 0
#define disp_vector_data 4
#define string_mask 7
#define string_tag 6
#define disp_string_length 0
#define disp_string_data 4
#define closure_mask 7
#define closure_tag 3
#define disp_closure_data 4
#define disp_closure_code 0
#define record_pmask 7
#define record_ptag 5
#define disp_record_data 4
#define disp_record_rtd 0
#define continuation_tag 31
#define disp_continuation_top 4
#define disp_continuation_size 8
#define disp_continuation_next 12
#define continuation_size 16
#define code_tag 47
#define disp_code_instrsize 4
#define disp_code_relocsize 8
#define disp_code_closuresize 12
#define disp_code_data 16
#define disp_frame_offset -13
#define disp_frame_size -17
#define object_alignment 8
#define align_shift 3
typedef struct {
ptr system_stack;
ptr stack_top;
ptr stack_size;
ptr frame_base;
ptr frame_redline;
ptr frame_pointer;
ptr heap_base;
ptr heap_size;
ptr allocation_redline;
ptr allocation_pointer;
ptr roots;
ptr string_base;
ptr string_ap;
ptr string_eap;
ptr string_pages;
ptr allocated_megs;
ptr allocated_bytes;
ptr reclaimed_megs;
ptr reclaimed_bytes;
ptr scheme_objects;
ptr next_continuation;
ptr prim_21;
ptr prim_22;
ptr prim_23;
ptr prim_24;
ptr prim_25;
ptr prim_26;
ptr prim_27;
ptr prim_28;
ptr prim_29;
ptr prim_30;
ptr prim_31;
ptr prim_32;
ptr prim_33;
ptr prim_34;
ptr prim_35;
ptr prim_36;
ptr prim_37;
ptr prim_38;
ptr prim_39;
ptr prim_40;
ptr prim_41;
ptr prim_42;
ptr prim_43;
ptr prim_44;
ptr prim_45;
ptr prim_46;
ptr prim_47;
ptr prim_48;
ptr prim_49;
ptr prim_50;
ptr prim_51;
ptr prim_52;
ptr prim_53;
ptr prim_54;
ptr prim_55;
ptr prim_56;
ptr prim_57;
ptr prim_58;
ptr prim_59;
ptr prim_60;
ptr prim_61;
ptr prim_62;
ptr prim_63;
ptr prim_64;
ptr prim_65;
ptr prim_66;
ptr prim_67;
ptr prim_68;
ptr prim_69;
ptr prim_70;
ptr prim_71;
ptr prim_72;
ptr prim_73;
ptr prim_74;
ptr prim_75;
ptr prim_76;
ptr prim_77;
ptr prim_78;
ptr prim_79;
ptr prim_80;
ptr prim_81;
ptr prim_82;
ptr prim_83;
ptr prim_84;
ptr prim_85;
ptr prim_86;
ptr prim_87;
ptr prim_88;
ptr prim_89;
ptr prim_90;
ptr prim_91;
ptr prim_92;
ptr prim_93;
ptr prim_94;
ptr prim_95;
ptr prim_96;
ptr prim_97;
ptr prim_98;
ptr prim_99;
ptr prim_100;
ptr prim_101;
ptr prim_102;
ptr prim_103;
ptr prim_104;
ptr prim_105;
ptr prim_106;
ptr prim_107;
ptr prim_108;
ptr prim_109;
ptr prim_110;
ptr prim_111;
ptr prim_112;
ptr prim_113;
ptr prim_114;
ptr prim_115;
ptr prim_116;
ptr prim_117;
ptr prim_118;
ptr prim_119;
ptr prim_120;
ptr prim_121;
ptr prim_122;
ptr prim_123;
ptr prim_124;
ptr prim_125;
ptr prim_126;
ptr prim_127;
ptr prim_128;
ptr prim_129;
ptr prim_130;
ptr prim_131;
ptr prim_132;
ptr prim_133;
ptr prim_134;
ptr prim_135;
ptr prim_136;
ptr prim_137;
ptr prim_138;
ptr prim_139;
ptr prim_140;
ptr prim_141;
ptr prim_142;
ptr prim_143;
ptr prim_144;
ptr prim_145;
ptr prim_146;
ptr prim_147;
ptr prim_148;
ptr prim_149;
ptr prim_150;
ptr prim_151;
ptr prim_152;
ptr prim_153;
ptr prim_154;
ptr prim_155;
ptr prim_156;
ptr prim_157;
ptr prim_158;
ptr prim_159;
ptr prim_160;
ptr prim_161;
ptr prim_162;
ptr prim_163;
ptr prim_164;
ptr prim_165;
ptr prim_166;
ptr prim_167;
ptr prim_168;
ptr prim_169;
ptr prim_170;
ptr prim_171;
ptr prim_172;
ptr prim_173;
ptr prim_174;
ptr prim_175;
ptr prim_176;
ptr prim_177;
ptr prim_178;
ptr prim_179;
ptr prim_180;
ptr prim_181;
ptr prim_182;
ptr prim_183;
ptr prim_184;
ptr prim_185;
ptr prim_186;
ptr prim_187;
ptr prim_188;
ptr prim_189;
ptr prim_190;
ptr prim_191;
ptr prim_192;
ptr prim_193;
ptr prim_194;
ptr prim_195;
ptr prim_196;
ptr prim_197;
ptr prim_198;
ptr prim_199;
ptr prim_200;
ptr prim_201;
ptr prim_202;
ptr prim_203;
ptr prim_204;
ptr prim_205;
ptr prim_206;
ptr prim_207;
ptr prim_208;
ptr prim_209;
ptr prim_210;
ptr prim_211;
ptr prim_212;
ptr prim_213;
ptr prim_214;
ptr prim_215;
ptr prim_216;
ptr prim_217;
ptr prim_218;
ptr prim_219;
ptr prim_220;
ptr prim_221;
ptr prim_222;
ptr prim_223;
ptr prim_224;
ptr prim_225;
ptr prim_226;
ptr prim_227;
ptr prim_228;
ptr prim_229;
ptr prim_230;
ptr prim_231;
ptr prim_232;
ptr prim_233;
ptr prim_234;
ptr prim_235;
ptr prim_236;
ptr prim_237;
ptr prim_238;
ptr prim_239;
ptr prim_240;
ptr prim_241;
ptr scheme_objects_end;
} pcb_t;
ptr scheme_entry(pcb_t* pcb);
extern ptr scheme_main(pcb_t* pcb);
#endif /* SCHEME_H */

BIN
src/stst
View File

Binary file not shown.

BIN
src/stst.fasl
View File

Binary file not shown.

2
src/test.ss Normal file
View File

@ -0,0 +1,2 @@
(define (asm-helpers)
)