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

imported compiler1

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:38:26 -05:00
parent d3313cd737
commit 3e7726203a
134 changed files with 25820 additions and 109334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.bzrignore
View File

@ -1 +1,3 @@
*.s
*.tmp
*.out

67
src/SuperFastHash.c
View File

@ -1,67 +0,0 @@
#if 0
Taken from
http://www.azillionmonkeys.com/qed/hash.html
#endif
#include <stdint.h>
#include <stdio.h>
#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);
}

199
src/assembler-tests.ss
View File

@ -1,6 +1,77 @@
(load "chez-compat.ss")
(load "libintelasm-5.8.ss")
(load "libfasl-6.0.ss")
(define-record code (code-size reloc-size closure-size code-vec reloc-vec))
(define make-code
(let ([make-code make-code])
(lambda (code-size reloc-size closure-size)
(printf "reloc=~s\n" reloc-size)
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
(make-code
(fxsra code-size 2)
(fxsra reloc-size 2)
closure-size
(make-vector code-size (cons 'byte 0))
(make-vector (fxsra reloc-size 2)))))))
(define set-code-byte!
(lambda (code idx byte)
(vector-set! (code-code-vec code) idx (cons 'byte byte))))
(define set-code-word!
(lambda (code idx x)
(cond
[(fixnum? x)
(set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
(set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
(set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
(set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
[else (error 'set-code-word! "unhandled ~s" x)])))
(define set-code-object!
(lambda (code obj code-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx (list 'object code-idx obj)))))
(define set-code-object+offset/rel!
(lambda (code obj code-idx obj-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx
(list 'object+off/rel code-idx obj obj-idx))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define set-code-object+offset!
(lambda (code obj code-idx obj-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx
(list 'object+off code-idx obj obj-idx))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define make-code-executable!
(lambda (x) (void)))
(define eval-code
(lambda (code)
(with-output-to-file "stst.fasl"
(lambda ()
(fasl-write code))
'replace)
(let ([rv (system "runtime/ikarus stst.fasl > stst.tmp")])
(unless (zero? rv)
(error 'eval-code "Failed to run: ~s" rv)))
(with-input-from-file "stst.tmp" read)))
(let ()
(define verbose #f)
(define verbose #t)
(define passed-tests 0)
(define all-tests 0)
@ -9,9 +80,8 @@
(lambda (code-ls val)
(set! all-tests (fxadd1 all-tests))
(when verbose (printf "Evaluating\n~s\n" code-ls))
(let* ([code (car (#%list*->code* (list code-ls)))]
[proc (code->closure code)]
[v (proc)])
(let* ([code (car (list*->code* (list code-ls)))]
[v (eval-code code)])
(when verbose (printf "evaluated\n"))
(cond
[(equal? v val)
@ -21,10 +91,41 @@
(error 'test-code
"expected ~s, got ~s" val v)]))))
(printf "testing ... \n")
(test-code
'([ret])
'([movl (int 0) %eax]
[ret])
0)
(let ([L1 (gensym)])
(test-code
`([movl (obj 10) %eax]
[jmp (label ,L1)]
[byte 0]
[byte 1]
[byte 2]
[byte 3]
[byte 4]
[byte 5]
[byte 6]
[byte 7]
[byte 8]
[byte 9]
[label ,L1]
[ret])
10))
(test-code
'([movl (obj+ (1 2 3) 3) %eax]
[movl (disp (int 0) %eax) %eax]
[ret])
'(2 3))
(test-code
'([movl (int 40) %eax]
[ret])
@ -282,31 +383,31 @@
[ret])
'list)
(test-code
'([movl (obj list) %eax]
[movl (disp (int 6) %eax) %eax] ; symbol value
[ret])
list)
;; (test-code
;; '([movl (obj list) %eax]
;; [movl (disp (int 6) %eax) %eax] ; symbol value
;; [ret])
;; list)
(test-code
'([movl (obj 10) (disp (int -4) %esp)]
[movl (obj list) %eax]
[movl (disp (int 6) %eax) %edi] ; symbol value
[movl (obj -1) %eax] ; argc
[jmp (disp (int -3) %edi)])
'(10))
;; (test-code
;; '([movl (obj 10) (disp (int -4) %esp)]
;; [movl (obj list) %eax]
;; [movl (disp (int 6) %eax) %edi] ; symbol value
;; [movl (obj -1) %eax] ; argc
;; [jmp (disp (int -3) %edi)])
;; '(10))
(test-code
'([movl (obj 10) (disp (int -4) %esp)]
[movl (obj 20) %eax]
[movl %eax (disp (int -8) %esp)]
[movl (disp (int -8) %esp) %ebx]
[movl %ebx (disp (int -12) %esp)]
[movl (obj list) %eax]
[movl (disp (int 6) %eax) %edi] ; symbol value
[movl (obj -3) %eax] ; argc
[jmp (disp (int -3) %edi)])
'(10 20 20))
;; (test-code
;; '([movl (obj 10) (disp (int -4) %esp)]
;; [movl (obj 20) %eax]
;; [movl %eax (disp (int -8) %esp)]
;; [movl (disp (int -8) %esp) %ebx]
;; [movl %ebx (disp (int -12) %esp)]
;; [movl (obj list) %eax]
;; [movl (disp (int 6) %eax) %edi] ; symbol value
;; [movl (obj -3) %eax] ; argc
;; [jmp (disp (int -3) %edi)])
;; '(10 20 20))
(test-code
'([movl (obj 10) %eax]
@ -362,24 +463,24 @@
`([movl (int 10) %eax]
[cmpl (int 8) %eax]
[jne (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 40) %eax]
[cmpl (obj 10) %eax]
[je (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
@ -387,24 +488,24 @@
[movl (int 30) %ebx]
[cmpl %ebx %eax]
[jge (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 40) (disp (int -4) %esp)]
[cmpl (int 70) (disp (int -4) %esp)]
[jle (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(test-code
'([movl (int 40) (disp (int -4) %esp)]
@ -429,13 +530,13 @@
[cmpl (int 70) (disp (int -1004) %esp)]
[jle (label ,L1)]
[addl (int -1000) %esp]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[addl (int -1000) %esp]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
@ -444,13 +545,13 @@
[cmpl (int 7000) (disp (int -1004) %esp)]
[jle (label ,L1)]
[addl (int -1000) %esp]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[addl (int -1000) %esp]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L1 (gensym)])
(test-code
@ -458,12 +559,12 @@
[movl (int 70) %ebx]
[cmpl (disp (int -4) %esp) %ebx]
[jge (label ,L1)]
[movl (obj #f) %eax]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj #t) %eax]
[movl (obj 1) %eax]
[ret])
#t))
1))
(let ([L_fact (gensym)] [L1 (gensym)])

171
src/assembler.info.ss
View File

@ -1,171 +0,0 @@
;;; Instruction format:
;;; 0,1,2,3,4 byte prefixes
;;; 1,2,3 byte opcode
;;; 0,1 byte ModR/M
;;; 0,1 byte SIB
;;; 0,1,2,4 bytes address displacement
;;; 0,1,2,4 bytes immediate
;;;
;;; Prefixes:
;;; 0 to 4 prefixes are permitted. Up to one prefix from each of the
;;; following groups is permitted (in any order)
;;; Group 1: Lock and Repeat
;;; 0xF0 -- LOCK
;;; 0xF2 -- REPNE/REPNZ (for string instructions)
;;; 0xF3 -- REPE/REPX (for string instructions)
;;; Group 2: Segment override and branch hints
;;; 0x2E -- CS segment override
;;; 0x36 -- SS
;;; 0x3E -- DS
;;; 0x26 -- ES
;;; 0x64 -- FS
;;; 0x65 -- GS
;;; Group 3:
;;; 0x66 -- Operand-size override
;;; Group 4:
;;; 0x67 -- Address-size override
;;;
;;; Opcodes:
;;; * Either 1 byte opcode
;;; * Or 2-bytes formed by 0x0F escape opcode followed by a second opcode
;;; * Or 3-bytes formed by 0x66,0xF2,0xF3 prefix followed by escape opcode,
;;; then a second opcode
;;;
;;; Mod/RM: 1 byte
;;; ._________._____________.___________.
;;; Bits: | 7 6 | 5 4 3 | 2 1 0 |
;;; | mod | reg/opcode | R/M |
;;; `~~~~~~~~~^~~~~~~~~~~~~~^~~~~~~~~~~~'
;;; Refer to table 2-2 Page 39 from IA32 Vol2A instruction set reference
;;;
;;; Mod:
;;; 0b00 -- direct dereference (i.e. [EAX], [ECX], ... , sib, disp32)
;;; 0b01 -- deref + 8-bit disp (i.e. [EAX]+disp8, ...)
;;; 0b10 -- deref + 32-bit disp
;;; 0b11 -- register name (i.e. EAX, ECX, ...)
;;;
;;; R/M: In general, the register names are as follows:
;;; 0b000 -- eax
;;; 0b001 -- ecx
;;; 0b010 -- edx
;;; 0b011 -- ebx
;;; 0b100 -- esp
;;; 0b101 -- ebp
;;; 0b110 -- esi
;;; 0b111 -- edi
;;; Exceptions:
;;; If mod is 0b00, 0b01 or 0b10:
;;; then esp is invalid and 0b100 is used to denote the presence
;;; of an SIB field
;;; If mod is 0b00:
;;; then ebp is invalid and 0b101 is used to denote a disp32 field
;;; that follows the Mod/RM byte and (or the SIB byte if present).
;;;
;;; /r: The /r denoted the register operand, the numbers are the same
;;; as above.
;;;
;;;
;;; SIB: 1 byte
;;; ._________._____________.___________.
;;; Bits: | 7 6 | 5 4 3 | 2 1 0 |
;;; | scale | index | base |
;;; `~~~~~~~~~^~~~~~~~~~~~~~^~~~~~~~~~~~'
;;; Refer to table 2-3 Page 40 from IA32 Vol2A instruction set reference
;;;
;;; Scale:
;;; 0b00: multiply index register by 1 (no scale)
;;; 0b01: multiply index register by 2
;;; 0b10: multiply index register by 4
;;; 0b11: multiply index register by 8
;;;
;;; Index: a register number
;;; (esp or 0b100 is invalid as an index)
;;;
;;; Base: a register number
;;; ebp or 0b101 as a base is interpreted as follows:
;;; If mod == 0b00, then EA = scaled index + disp32 (no base)
;;; If mod == 0b01, then EA = scaled index + disp8 + ebp
;;; If mod == 0b10, then EA = scaled index + disp32 + ebp
;;; If mod == 0b11, then I DON'T KNOW
;;;
;;;
;;;
(define-instr (TMPL1 primary secondary d s)
(cases (d s)
[(AL imm8) => (logor primary #b00000100) s] ; 04 ib
[(EAX imm32) => (logor primary #b00000101) s] ; 05 id
[(reg/mem8 imm8) => #b10000000 secondary ib] ; 80 /0 ib
[(reg/mem32 imm32) => #b10000001 secondary id] ; 81 /0 id
[(reg/mem32 imm8) => #b10000011 secondary ib] ; 83 /0 ib (sign ext.)
[(reg/mem8 reg8) => (logor primary #b00000000) /r ] ; 00 /r
[(reg/mem32 reg32) => (logor primary #b00000001) /r ] ; 01 /r
[(reg8 reg/mem8) => (logor primary #b00000010) /r ] ; 02 /r
[(reg32 reg/mem32) => (logor primary #b00000011) /r ] ; 03 /r
))
(define-insrt (ADD d s) (TMPL1 #b00000000 /0 d s))
(define-insrt (AND d s) (TMPL1 #b00100000 /4 d s))
(define-instr (CMP d s) (TMPL1 #b00111000 /7 d s))
(define-insrt (CALL d)
(cases (d)
[(rel32of) => #b11101000 id] ; E8 id
[(reg/mem32) => #b11111111 /2] ; FF /2
))
(define-instr (CLTD) ; convert long to double
(cases ()
[() => #b10011001] ; 99
))
(define-insrt (IDIV s)
(cases (s)
[(reg/mem8) => #b11110110 /7] ; F6 /7
[(reg/mem32) => #b11110111 /7] ; F7 /7
))
imull
ja
jae
jb
jbe
je
jg
jge
jl
jle
jmp
jne
movb
movl
movswl
movzbl
negl
notl
orl
pop
popl
push
pushl
ret
sall
sarl
sete
setg
setge
setl
setle
shll
shrl
subl
xorl
)

2
src/build-date.tmp
View File

@ -1 +1 @@
2006-07-19
2006-07-27

42
src/chez-compat.ss
View File

@ -3,64 +3,32 @@
[(_ name val)
(set-top-level-value! 'name val)]))
(define primitive-set! set-top-level-value!)
(define (immediate? x)
(or (fixnum? x)
(null? x)
(char? x)
(boolean? x)
(eof-object? x)
(eq? x (void))))
(define-syntax add1 syntax-error)
(define fxadd1
(lambda (x)
(import scheme)
(unless (fixnum? x) (error 'fxadd1 "~s is not a fixnum" x))
(let ([v (+ x 1)])
(unless (fixnum? v) (error 'fxadd1 "overflow"))
v)))
(define-syntax sub1 syntax-error)
(define fxsub1
(lambda (x)
(import scheme)
(unless (fixnum? x) (error 'fxsub1 "~s is not a fixnum" x))
(let ([v (- x 1)])
(unless (fixnum? v) (error 'fxsub1 "overflow"))
v)))
(define-syntax - syntax-error)
(define-syntax fx-
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx- x y)])))
(define-syntax * syntax-error)
(define-syntax fx*
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx* x y)])))
(define-syntax + syntax-error)
(define-syntax fx+
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx+ x y)])))
(define-syntax = syntax-error)
(define-syntax fx=
(let ()
(import scheme)
(syntax-rules ()
[(_ x y) (#%fx= x y)])))
(define-syntax integer? syntax-error)
(define char= char=?)

399
src/collect-5.2.c
View File

@ -1,399 +0,0 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.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 minimum_heap_size (pagesize * 640)
#define align_to_page(x) (((x)/pagesize)*pagesize)
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*pagesize);
if(required_space < minimum_heap_size){
required_space = minimum_heap_size;
}
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(required_space);
pcb->allocation_pointer = new_heap;
pcb->allocation_redline = new_heap + required_space - 2 * pagesize;
pcb->heap_base = new_heap;
pcb->heap_size = (char*) required_space;
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);
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 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_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);
return(move_pointers(x-tag, pcb, size, tag));
}
else if(tag == symbol_tag){
return(move_pointers(x-tag, pcb, symbol_size, tag));
}
else if(tag == vector_tag){
return(move_pointers(x-tag, pcb, disp_vector_data + (int)fst, tag));
}
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;
#if 0
fprintf(stderr, "copying root 0x%08x (%d objs) \n", (int)r, n);
#endif
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 */
#define FRAMESIZE_OFFSET -9
char* fp = pcb->stack_extent;
char* stack_base = pcb->scheme_stack;
while(fp != stack_base){
assert(fp < stack_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
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + FRAMESIZE_OFFSET - 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* 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);
}
}

6
src/collect-5.2.h
View File

@ -1,6 +0,0 @@
#ifndef COLLECT_H
#define COLLECT_H
#include "scheme.h"
void S_add_roots(pcb_t*, int*);
void S_check_roots(pcb_t*, int*);
#endif

572
src/collect-5.3.c
View File

@ -1,572 +0,0 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.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 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)
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){
#define FRAMESIZE_OFFSET -9
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
int framesize = (int) ref(rp, FRAMESIZE_OFFSET); /* UGLY */
assert(fixnump(framesize));
assert(framesize >= 0);
if(framesize > 0){
int bytes_in_mask = ((framesize>>fx_shift)+7)>>3;
char* mask = rp + FRAMESIZE_OFFSET - 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_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);
return (move_pointers(x-tag, pcb, size, tag));
}
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 {
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, FRAMESIZE_OFFSET); /* 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");
*/
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 |
+--------------+
*/

580
src/collect-5.4.c
View File

@ -1,580 +0,0 @@
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.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 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)
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
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_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);
return (move_pointers(x-tag, pcb, size, tag));
}
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 {
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;
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 |
+--------------+
*/

804
src/collect-5.6.c
View File

@ -1,804 +0,0 @@
#include <stdio.h>
#include <stdint.h>
#include <stdlib.h>
#include <string.h>
#include <sys/mman.h>
#include <assert.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
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);
}

2351
src/compiler-5.1.ss
View File

File diff suppressed because it is too large Load Diff

2729
src/compiler-5.2.ss
View File

File diff suppressed because it is too large Load Diff

3188
src/compiler-5.3.ss
View File

File diff suppressed because it is too large Load Diff

3216
src/compiler-5.4.ss
View File

File diff suppressed because it is too large Load Diff

3568
src/compiler-5.5.ss
View File

File diff suppressed because it is too large Load Diff

4015
src/compiler-5.6.ss
View File

File diff suppressed because it is too large Load Diff

3826
src/compiler-5.7.ss
View File

File diff suppressed because it is too large Load Diff

3840
src/compiler-5.8.ss
View File

File diff suppressed because it is too large Load Diff

1774
src/compiler-5.9.ss → src/compiler-6.0.ss
View File

File diff suppressed because it is too large Load Diff

24
src/core-syntax.ss
View File

@ -1,24 +0,0 @@
(module core-syntax (if lambda letrec or let)
(define-syntax if (getprop 'if '*sc-expander*))
(define-syntax lambda (getprop 'lambda '*sc-expander*))
(define-syntax letrec (getprop 'letrec '*sc-expander*))
(define-syntax or
(lambda (x)
(syntax-case x ()
((_) (syntax #f))
((_ e) (syntax e))
((_ e1 e2 e3 ...)
(syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
(define-syntax let
(lambda (x)
(syntax-case x ()
((_ ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (x ...)))
(syntax ((lambda (x ...) e1 e2 ...) v ...)))
((_ f ((x v) ...) e1 e2 ...)
(andmap identifier? (syntax (f x ...)))
(syntax ((letrec ((f (lambda (x ...) e1 e2 ...))) f)
v ...))))))
)

62768
src/dump
View File

File diff suppressed because it is too large Load Diff

68
src/expand.ss
View File

@ -1,68 +0,0 @@
(let ()
(define self-evaluating?
(lambda (x)
(or (fixnum? x) (immediate? x))))
(define syntax-error
(lambda (x)
(error 'expand "invalid syntax ~s" x)))
(define build-quoted-constant
(lambda (x)
(list 'quote x)))
(define build-application
(lambda (rator rand*)
(list 'funcall rator rand*)))
(define empty-env
(lambda () '()))
(define Etop
(lambda (expression global-environment)
(define lookup
(lambda (sym env ctxt)
(cond
[(assq sym env) => cdr]
[(getprop sym (environment-key global-environment))]
[(environment-mutable? global-environment)
(define E
(lambda (x env)
(cond
[(self-evaluating? x)
(build-quoted-constant x)]
[(pair? x)
(let ([a (car x)] [d (cdr x)])
(cond
[(symbol? a)
(let ([b (lookup a env x)])
(case (binding-type b)
[else (bug "invalid binding ~s" b)]))]
[(list? d)
(build-application
(E a env)
(map (lambda (x) (E x env)) d))]
[else (syntax-error x)]))]
[else (syntax-error x)])))
(E expression (empty-env))))
(define env-rtd (make-record-type "environment" '(mutable? key)))
(define environment? (record-predicate env-rtd))
(define environment-mutable? (record-field-accessor env-rtd 0))
(define environment-key (record-field-accessor env-rtd 1))
(define make-environment (record-constructor env-rtd))
(define expand
(lambda (x env)
(unless (environment? env)
(error 'expand "~s is not an environment" env))
(Etop x env)))
)

0
src/foo.ss
View File

9
src/generate-libxcr.ss → src/generate-cxr.ss
View File

@ -16,7 +16,7 @@
(err ',name orig)))])))
(define gen-cxr
(lambda (name ls)
`($pcb-set! ,name (lambda (orig) ,(gen-body name 'orig ls)))))
`(primitive-set! ',name (lambda (orig) ,(gen-body name 'orig ls)))))
(define gen-names-n
(lambda (n)
(cond
@ -44,4 +44,9 @@
,@(map
(lambda (ls) (gen-cxr (ls->name ls) (ls->functions ls)))
(gen-names 4)))))
(with-output-to-file "libcxr-6.0.ss"
(lambda ()
(pretty-print (generate-cxr-definitions)))
'replace)

42
src/geninstr/gen.pl
View File

@ -3,6 +3,9 @@
my @regs =
('%eax', '%ecx', '%edx', '%ebx', '%esp', '%ebp', '%esi', '%edi');
my @regs_no_esp =
('%eax', '%ecx', '%edx', '%ebx', '%ebp', '%esi', '%edi');
print ".text\n";
@ -30,14 +33,37 @@ sub gen2{
}
}
print "sete %al\n";
print "sete %cl\n";
print "sete %dl\n";
print "sete %bl\n";
print "sete %ah\n";
print "sete %ch\n";
print "sete %dh\n";
print "sete %bh\n";
sub gen3{
my $tmpl = shift;
foreach my $r1 (@regs){
foreach my $r3 (@regs_no_esp){
foreach my $r2 (@regs){
my $x = $tmpl;
$x =~ s/r1/$r1/g;
$x =~ s/r2/$r2/g;
$x =~ s/r3/$r3/g;
print $x;
}
}
}
}
gen1 "movb \$0, 4(r1)\n";
#gen1 "movb -2(r1), %ah\n";
#gen2 "xorl r1,r2\n";
#gen3 "movl (r2,r3), r1\n";
#print "sete %al\n";
#print "sete %cl\n";
#print "sete %dl\n";
#print "sete %bl\n";
#print "sete %ah\n";
#print "sete %ch\n";
#print "sete %dh\n";
#print "sete %bh\n";
#gen1 "pop r1\n";
#gen1 "pop 12(r1)\n";

16
src/geninstr/tmp.dump
View File

@ -4,11 +4,11 @@ tmp.o: file format elf32-i386
Disassembly of section .text:
00000000 <.text>:
0: 0f 94 c0 sete %al
3: 0f 94 c1 sete %cl
6: 0f 94 c2 sete %dl
9: 0f 94 c3 sete %bl
c: 0f 94 c4 sete %ah
f: 0f 94 c5 sete %ch
12: 0f 94 c6 sete %dh
15: 0f 94 c7 sete %bh
0: c6 40 04 00 movb $0x0,0x4(%eax)
4: c6 41 04 00 movb $0x0,0x4(%ecx)
8: c6 42 04 00 movb $0x0,0x4(%edx)
c: c6 43 04 00 movb $0x0,0x4(%ebx)
10: c6 44 24 04 00 movb $0x0,0x4(%esp)
15: c6 45 04 00 movb $0x0,0x4(%ebp)
19: c6 46 04 00 movb $0x0,0x4(%esi)
1d: c6 47 04 00 movb $0x0,0x4(%edi)

16
src/geninstr/tmp.s
View File

@ -1,9 +1,9 @@
.text
sete %al
sete %cl
sete %dl
sete %bl
sete %ah
sete %ch
sete %dh
sete %bh
movb $0, 4(%eax)
movb $0, 4(%ecx)
movb $0, 4(%edx)
movb $0, 4(%ebx)
movb $0, 4(%esp)
movb $0, 4(%ebp)
movb $0, 4(%esi)
movb $0, 4(%edi)

BIN
src/ikarus.fasl Normal file
View File

Binary file not shown.

5
src/libintelasm-5.6.ss → src/libassembler-5.8.ss
View File

@ -1,4 +1,8 @@
;;;
;;; 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))
@ -126,4 +130,3 @@
($pcb-set! set-code-object/reloc/relative!
(lambda args (error 'set-code-object/reloc/relative! "not yet")))

56
src/libassembler-compat-6.0.ss Normal file
View File

@ -0,0 +1,56 @@
(define-record code (closure-size code-vec reloc-vec))
(define make-code
(let ([make-code make-code])
(lambda (code-size reloc-size closure-size)
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
(make-code
closure-size
(make-string code-size)
(make-vector (fxsra reloc-size 2)))))))
(define set-code-byte!
(lambda (code idx byte)
(string-set! (code-code-vec code) idx (integer->char byte))))
(define set-code-word!
(lambda (code idx x)
(cond
[(fixnum? x)
(set-code-byte! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
(set-code-byte! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
(set-code-byte! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
(set-code-byte! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
[else (error 'set-code-word! "unhandled ~s" x)])))
(define set-code-object!
(lambda (code obj code-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx (list 'object code-idx obj)))))
(define set-code-foreign-object!
(lambda (code obj code-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx (list 'foreign code-idx obj))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define set-code-object+offset/rel!
(lambda (code obj code-idx obj-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx
(list 'object+off/rel code-idx obj obj-idx))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define set-code-object+offset!
(lambda (code obj code-idx obj-idx reloc-idx)
(let ([v (code-reloc-vec code)])
(vector-set! v reloc-idx
(list 'object+off code-idx obj obj-idx))
(vector-set! v (fxadd1 reloc-idx) '(skip)))))
(define make-code-executable!
(lambda (x) (void)))

39
src/libcafe-4.4.ss
View File

@ -1,39 +0,0 @@
(let ()
(define eval-depth 0)
(define display-prompt
(lambda (i)
(if (fx= i eval-depth)
(display " " (console-output-port))
(begin
(display ">" (console-output-port))
(display-prompt (fx+ i 1))))))
(define wait
(lambda (eval)
(display-prompt 0)
(let ([x (read (console-input-port))])
(cond
[(eof-object? x)
(newline (console-output-port))]
[else
(let ([v (eval x)])
(unless (eq? v (void))
(write v (console-output-port))
(newline (console-output-port))))
(wait eval)]))))
($pcb-set! new-cafe
(lambda args
(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")))])
(set! eval-depth (fxadd1 eval-depth))
(wait eval)
(set! eval-depth (fxsub1 eval-depth))))))

66
src/libcafe-5.3.ss
View File

@ -1,66 +0,0 @@
(let ()
(define with-error-handler
(lambda (p thunk)
(let ([old-error-handler (current-error-handler)])
(dynamic-wind
(lambda ()
(current-error-handler
(lambda args
(current-error-handler old-error-handler)
(apply p args)
(apply error args))))
thunk
(lambda ()
(current-error-handler old-error-handler))))))
(define eval-depth 0)
(define display-prompt
(lambda (i)
(if (fx= i eval-depth)
(display " " (console-output-port))
(begin
(display ">" (console-output-port))
(display-prompt (fx+ i 1))))))
(define wait
(lambda (eval escape-k)
(call/cc
(lambda (k)
(with-error-handler
(lambda args
(apply print-error args)
(k (void)))
(lambda ()
(display-prompt 0)
(let ([x (read (console-input-port))])
(cond
[(eof-object? x)
(newline (console-output-port))
(escape-k (void))]
[else
(let ([v (eval x)])
(unless (eq? v (void))
(write v (console-output-port))
(newline (console-output-port))))]))))))
(wait eval escape-k)))
($pcb-set! new-cafe
(lambda args
(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
(lambda () (set! eval-depth (fxadd1 eval-depth)))
(lambda ()
(call/cc
(lambda (k)
(wait eval k))))
(lambda () (set! eval-depth (fxsub1 eval-depth))))))))

15
src/libcafe-5.6.ss → src/libcafe-6.0.ss
View File

@ -40,13 +40,18 @@
(newline (console-output-port))
(escape-k (void))]
[else
(let ([v (eval x)])
(unless (eq? v (void))
(write v (console-output-port))
(newline (console-output-port))))]))))))
(call-with-values
(lambda () (eval x))
(lambda v*
(unless (andmap (lambda (v) (eq? v (void))) v*)
(for-each
(lambda (v)
(write v (console-output-port))
(newline (console-output-port)))
v*))))]))))))
(wait eval escape-k)))
($pcb-set! new-cafe
(primitive-set! 'new-cafe
(lambda args
(let ([eval
(if (null? args)

BIN
src/libcafe.fasl Normal file
View File

Binary file not shown.

19
src/libcollect-5.2.ss
View File

@ -1,19 +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)))

28
src/libcollect-6.0.ss Normal file
View File

@ -0,0 +1,28 @@
;(primitive-set! 'do-overflow
; (lambda ()
; ($do-overflow 4096)))
(primitive-set! 'do-overflow
(lambda (n)
(foreign-call "ik_collect" n)
(void)))
(primitive-set! 'do-overflow-words
(lambda (n)
(foreign-call "ik_collect" ($fxsll n 2))
(void)))
(primitive-set! 'do-vararg-overflow
(lambda (n)
(foreign-call "ik_collect_vararg" n)
(void)))
(primitive-set! 'collect
(lambda ()
(do-overflow 4096)))
(primitive-set! 'do-stack-overflow
(lambda ()
(foreign-call "ik_stack_overflow")))

BIN
src/libcollect.fasl Normal file
View File

Binary file not shown.

23
src/libcompile-5.9.ss
View File

@ -1,23 +0,0 @@
;;; libcompile should provide: compile-core->asm
;;; it takes one expression in core scheme, and produces a list of
;;; assembly codes (each is a list of instructions).
;;; the resulting lists can then either be fed to the gas backend to
;;; produce assembly files, or to the online assembler to produce
;;; code.
;;;
;;; complications:
;;; * The gas backend does not support 3D objects. The online
;;; assembler does. We provide a parameter, assembler-backend,
;;; that when set to 'online, suppresses removing complex constants
;;; and when set to 'offline, suppresses proucing 3D objects.
;;;
($pcb-set! assembler-backend
(make-parameter
'online
(lambda (x)
(unless (memq x '(online offline))
(error 'assembler-backend "invalid backend ~s" x))
x)))

86
src/libcontrol-5.3.ss
View File

@ -1,86 +0,0 @@
(let ([winders '()])
(define call-with-current-frame
(lambda (f)
(if ($fp-at-base)
(f ($current-frame))
($seal-frame-and-call f))))
(define primitive-call/cc
(lambda (f)
(call-with-current-frame
(lambda (frm)
(f (lambda (value)
($set-current-frame! frm)
($underflow-and-return value)))))))
(define len
(lambda (ls n)
(if (null? ls)
n
(len (cdr ls) (fxadd1 n)))))
(define list-tail
(lambda (ls n)
(if (fxzero? n)
ls
(list-tail (cdr ls) (fxsub1 n)))))
(define drop-uncommon-heads
(lambda (x y)
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))
(define common-tail
(lambda (x y)
(let ([lx (len x 0)] [ly (len y 0)])
(let ([x (if (fx> lx ly) (list-tail x (fx- lx ly)) x)]
[y (if (fx> ly lx) (list-tail y (fx- ly lx)) y)])
(if (eq? x y)
x
(drop-uncommon-heads (cdr x) (cdr y)))))))
(define unwind*
(lambda (ls tail)
(unless (eq? ls tail)
(set! winders (cdr ls))
((cdar ls))
(unwind* (cdr ls) tail))))
(define rewind*
(lambda (ls tail)
(unless (eq? ls tail)
(rewind* (cdr ls) tail)
((caar ls))
(set! winders ls))))
(define do-wind
(lambda (new)
(let ([tail (common-tail new winders)])
(unwind* winders 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 dynamic-wind
(lambda (in body out)
(in)
(set! winders (cons (cons in out) winders))
(let ([v (body)])
(set! winders (cdr winders))
(out)
v)))
($pcb-set! call/cf call-with-current-frame)
($pcb-set! call/cc call/cc)
($pcb-set! dynamic-wind dynamic-wind))

27
src/libcontrol-5.5.ss → src/libcontrol-6.0.ss
View File

@ -69,16 +69,29 @@
(unless (eq? save winders) (do-wind save))
(apply k v*))))))))
;;; (define dynamic-wind
;;; (lambda (in body out)
;;; (in)
;;; (set! winders (cons (cons in out) winders))
;;; (let ([v (body)])
;;; (set! winders (cdr winders))
;;; (out)
;;; v)))
(define dynamic-wind
(lambda (in body out)
(in)
(set! winders (cons (cons in out) winders))
(let ([v (body)])
(set! winders (cdr winders))
(out)
v)))
(call-with-values
body
(lambda v*
(set! winders (cdr winders))
(out)
(apply values 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 Normal file
View File

Binary file not shown.

901
src/libcore-4.4.ss
View File

@ -1,901 +0,0 @@
($pcb-set! error
(lambda args
(foreign-call "S_error" args)))
($pcb-set! exit
(lambda args
(if (null? args)
($exit 0)
(if (null? ($cdr args))
($exit ($car args))
(error 'exit "too many arguments")))))
($pcb-set! eof-object
(lambda () (eof-object)))
($pcb-set! void
(lambda () (void)))
($pcb-set! eof-object?
(lambda (x) (eof-object? x)))
($pcb-set! fxadd1
(lambda (n)
(unless (fixnum? n)
(error 'fxadd1 "~s is not a fixnum" n))
($fxadd1 n)))
($pcb-set! fxsub1
(lambda (n)
(unless (fixnum? n)
(error 'fxsub1 "~s is not a fixnum" n))
($fxsub1 n)))
($pcb-set! fixnum->char
(lambda (n)
(unless (fixnum? n)
(error 'fixnum->char "~s is not a fixnum" n))
(unless (and ($fx>= n 0)
($fx<= n 127))
(error 'fixnum->char "~s is out of range[0..127]" n))
($fixnum->char n)))
($pcb-set! char->fixnum
(lambda (x)
(unless (char? x)
(error 'char->fixnum "~s is not a character" x))
($char->fixnum x)))
($pcb-set! fxlognot
(lambda (x)
(unless (fixnum? x)
(error 'fxlognot "~s is not a fixnum" x))
($fxlognot x)))
($pcb-set! fixnum? (lambda (x) (fixnum? x)))
($pcb-set! fxzero?
(lambda (x)
(unless (fixnum? x)
(error 'fxzero? "~s is not a fixnum" x))
($fxzero? x)))
($pcb-set! boolean? (lambda (x) (boolean? x)))
($pcb-set! char? (lambda (x) (char? x)))
($pcb-set! vector? (lambda (x) (vector? x)))
($pcb-set! string? (lambda (x) (string? x)))
($pcb-set! procedure? (lambda (x) (procedure? x)))
($pcb-set! null? (lambda (x) (null? x)))
($pcb-set! pair? (lambda (x) (pair? x)))
($pcb-set! car
(lambda (x)
(unless (pair? x)
(error 'car "~s is not a pair" x))
($car x)))
($pcb-set! cdr
(lambda (x)
(unless (pair? x)
(error 'cdr "~s is not a pair" x))
($cdr x)))
($pcb-set! caar
(lambda (x)
(unless (pair? x) (error 'caar "incorrect list structure ~s" x))
(let ([a ($car x)])
(unless (pair? a) (error 'caar "incorrect list structure ~s" x))
($car a))))
($pcb-set! cadr
(lambda (x)
(unless (pair? x) (error 'cadr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cadr "incorrect list structure ~s" x))
($car d))))
($pcb-set! cdar
(lambda (x)
(unless (pair? x) (error 'cdar "incorrect list structure ~s" x))
(let ([a ($car x)])
(unless (pair? a) (error 'cdar "incorrect list structure ~s" x))
($cdr a))))
($pcb-set! cddr
(lambda (x)
(unless (pair? x) (error 'cddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cddr "incorrect list structure ~s" x))
($cdr d))))
($pcb-set! caddr
(lambda (x)
(unless (pair? x) (error 'caddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'caddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'caddr "correct list structure ~s" x))
($car dd)))))
($pcb-set! cadddr
(lambda (x)
(unless (pair? x) (error 'cadddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cadddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'cadddr "correct list structure ~s" x))
(let ([ddd ($cdr dd)])
(unless (pair? ddd) (error 'cadddr "correct list structure ~s" x))
($car ddd))))))
($pcb-set! cddddr
(lambda (x)
(unless (pair? x) (error 'cddddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cddddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'cddddr "correct list structure ~s" x))
(let ([ddd ($cdr dd)])
(unless (pair? ddd) (error 'cddddr "correct list structure ~s" x))
($cdr ddd))))))
(let ()
(define fill!
(lambda (v i n fill)
(cond
[($fx= i n) v]
[else
($vector-set! v i fill)
(fill! v ($fx+ i 1) n fill)])))
($pcb-set! make-vector
(lambda (n . opt)
(unless (and (fixnum? n) ($fx>= n 0))
(error 'make-vector "~s is not a valid size" n))
(let ([fill (if (null? opt)
#f
(if (null? ($cdr opt))
($car opt)
(error 'make-vector "too many arguments")))])
(let ([v ($make-vector n)])
(fill! v 0 n fill))))))
($pcb-set! vector-length
(lambda (x)
(unless (vector? x)
(error 'vector-length "~s is not a vector" x))
($vector-length x)))
($pcb-set! make-string
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'make-string "~s is not a valid size" x))
($make-string x)))
($pcb-set! string-length
(lambda (x)
(unless (string? x)
(error 'string-length "~s is not a string" x))
($string-length x)))
($pcb-set! not (lambda (x) (not x)))
($pcb-set! symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "~s is not a symbol" x))
($symbol-string x)))
($pcb-set! top-level-value
(lambda (x)
(unless (symbol? x)
(error 'top-level-value "~s is not a symbol" x))
(let ([v ($symbol-value x)])
(when ($unbound-object? v)
(error 'top-level-value "unbound variable ~s" x))
v)))
($pcb-set! top-level-bound?
(lambda (x)
(unless (symbol? x)
(error 'top-level-bound? "~s is not a symbol" x))
(not ($unbound-object? ($symbol-value x)))))
($pcb-set! set-top-level-value!
(lambda (x v)
(unless (symbol? x)
(error 'set-top-level-value! "~s is not a symbol" x))
($set-symbol-value! x v)))
($pcb-set! symbol? (lambda (x) (symbol? x)))
($pcb-set! fx+
(lambda (x y)
(unless (fixnum? x)
(error 'fx+ "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx+ "~s is not a fixnum" y))
($fx+ x y)))
($pcb-set! fx-
(lambda (x y)
(unless (fixnum? x)
(error 'fx- "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx- "~s is not a fixnum" y))
($fx- x y)))
($pcb-set! fx*
(lambda (x y)
(unless (fixnum? x)
(error 'fx* "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx* "~s is not a fixnum" y))
($fx* x y)))
($pcb-set! fxquotient
(lambda (x y)
(unless (fixnum? x)
(error 'fxquotient "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxquotient "~s is not a fixnum" y))
(when ($fxzero? y)
(error 'fxquotient "zero dividend ~s" y))
($fxquotient x y)))
($pcb-set! fxremainder
(lambda (x y)
(unless (fixnum? x)
(error 'fxremainder "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxremainder "~s is not a fixnum" y))
(when ($fxzero? y)
(error 'fxremainder "zero dividend ~s" y))
(let ([q ($fxquotient x y)])
($fx- x ($fx* q y)))))
($pcb-set! fxlogor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogor "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogor "~s is not a fixnum" y))
($fxlogor x y)))
($pcb-set! fxlogxor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogxor "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogxor "~s is not a fixnum" y))
($fxlogxor x y)))
($pcb-set! fxlogand
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogand "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxlogand "~s is not a fixnum" y))
($fxlogand x y)))
($pcb-set! fxsra
(lambda (x y)
(unless (fixnum? x)
(error 'fxsra "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxsra "~s is not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsra "negative shift not allowed, got ~s" y))
($fxsra x y)))
($pcb-set! fxsll
(lambda (x y)
(unless (fixnum? x)
(error 'fxsll "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fxsll "~s is not a fixnum" y))
(unless ($fx>= y 0)
(error 'fxsll "negative shift not allowed, got ~s" y))
($fxsll x y)))
($pcb-set! fx=
(lambda (x y)
(unless (fixnum? x)
(error 'fx= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx= "~s is not a fixnum" y))
($fx= x y)))
($pcb-set! fx<
(lambda (x y)
(unless (fixnum? x)
(error 'fx< "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx< "~s is not a fixnum" y))
($fx< x y)))
($pcb-set! fx<=
(lambda (x y)
(unless (fixnum? x)
(error 'fx<= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx<= "~s is not a fixnum" y))
($fx<= x y)))
($pcb-set! fx>
(lambda (x y)
(unless (fixnum? x)
(error 'fx> "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx> "~s is not a fixnum" y))
($fx> x y)))
($pcb-set! fx>=
(lambda (x y)
(unless (fixnum? x)
(error 'fx>= "~s is not a fixnum" x))
(unless (fixnum? y)
(error 'fx>= "~s is not a fixnum" y))
($fx>= x y)))
($pcb-set! char=
(lambda (x y)
(unless (char? x)
(error 'char= "~s is not a character" x))
(unless (char? y)
(error 'char= "~s is not a character" y))
($char= x y)))
($pcb-set! char<
(lambda (x y)
(unless (char? x)
(error 'char< "~s is not a character" x))
(unless (char? y)
(error 'char< "~s is not a character" y))
($char< x y)))
($pcb-set! char<=
(lambda (x y)
(unless (char? x)
(error 'char<= "~s is not a character" x))
(unless (char? y)
(error 'char<= "~s is not a character" y))
($char<= x y)))
($pcb-set! char>
(lambda (x y)
(unless (char? x)
(error 'char> "~s is not a character" x))
(unless (char? y)
(error 'char> "~s is not a character" y))
($char> x y)))
($pcb-set! char>=
(lambda (x y)
(unless (char? x)
(error 'char>= "~s is not a character" x))
(unless (char? y)
(error 'char>= "~s is not a character" y))
($char>= x y)))
($pcb-set! cons (lambda (x y) (cons x y)))
($pcb-set! eq? (lambda (x y) (eq? x y)))
($pcb-set! set-car!
(lambda (x y)
(unless (pair? x)
(error 'set-car! "~s is not a pair" x))
($set-car! x y)))
($pcb-set! set-cdr!
(lambda (x y)
(unless (pair? x)
(error 'set-cdr! "~s is not a pair" x))
($set-cdr! x y)))
($pcb-set! vector-ref
(lambda (v i)
(unless (vector? v)
(error 'vector-ref "~s is not a vector" v))
(unless (fixnum? i)
(error 'vector-ref "~s is not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-ref "index ~s is out of range for ~s" i v))
($vector-ref v i)))
($pcb-set! string-ref
(lambda (s i)
(unless (string? s)
(error 'string-ref "~s is not a string" s))
(unless (fixnum? i)
(error 'string-ref "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx<= 0 i))
(error 'string-ref "index ~s is out of range for ~s" i s))
($string-ref s i)))
($pcb-set! vector-set!
(lambda (v i c)
(unless (vector? v)
(error 'vector-set! "~s is not a vector" v))
(unless (fixnum? i)
(error 'vector-set! "~s is not a valid index" i))
(unless (and ($fx< i ($vector-length v))
($fx<= 0 i))
(error 'vector-set! "index ~s is out of range for ~s" i v))
($vector-set! v i c)))
($pcb-set! string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "~s is not a string" s))
(unless (fixnum? i)
(error 'string-set! "~s is not a valid index" i))
(unless (and ($fx< i ($string-length s))
($fx>= i 0))
(error 'string-set! "index ~s is out of range for ~s" i s))
(unless (char? c)
(error 'string-set! "~s is not a character" c))
($string-set! s i c)))
($pcb-set! vector
(letrec ([length
(lambda (ls n)
(cond
[(null? ls) n]
[else (length ($cdr ls) ($fx+ n 1))]))]
[loop
(lambda (v ls i n)
(cond
[($fx= i n) v]
[else
($vector-set! v i ($car ls))
(loop v ($cdr ls) ($fx+ i 1) n)]))])
(lambda ls
(let ([n (length ls 0)])
(let ([v ($make-vector n)])
(loop v ls 0 n))))))
(letrec ([length
(lambda (ls n)
(cond
[(null? ls) n]
[else (length ($cdr ls) ($fx+ n 1))]))]
[loop
(lambda (s ls i n)
(cond
[($fx= i n) s]
[else
(let ([c ($car ls)])
(unless (char? c)
(error 'string "~s is not a character" c))
($string-set! s i c)
(loop s ($cdr ls) ($fx+ i 1) n))]))])
(let ([f
(lambda ls
(let ([n (length ls 0)])
(let ([s ($make-string n)])
(loop s ls 0 n))))])
($pcb-set! string f)))
($pcb-set! list?
(letrec ([race
(lambda (h t)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(and (not (eq? h t))
(race ($cdr h) ($cdr t)))
(null? h)))
(null? h)))])
(lambda (x) (race x x))))
($pcb-set! reverse
(letrec ([race
(lambda (h t ls ac)
(if (pair? h)
(let ([h ($cdr h)] [ac (cons ($car h) ac)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls (cons ($car h) ac))
(error 'reverse "~s is a circular list" ls))
(if (null? h)
ac
(error 'reverse "~s is not a proper list" ls))))
(if (null? h)
ac
(error 'reverse "~s is not a proper list" ls))))])
(lambda (x)
(race x x x '()))))
($pcb-set! memq
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (eq? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memq "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
($pcb-set! list->string
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'reverse "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'reverse "~s is not a proper list" ls))))
(if (null? h)
n
(error 'reverse "~s is not a proper list" ls))))]
[fill
(lambda (s i ls)
(cond
[(null? ls) s]
[else
(let ([c ($car ls)])
(unless (char? c)
(error 'list->string "~s is not a character" c))
($string-set! s i c)
(fill s ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
(let ([n (race ls ls ls 0)])
(let ([s ($make-string n)])
(fill s 0 ls))))))
($pcb-set! length
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'length "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'length "~s is not a proper list" ls))))
(if (null? h)
n
(error 'length "~s is not a proper list" ls))))])
(lambda (ls)
(race ls ls ls 0))))
($pcb-set! apply
(letrec ([fix
(lambda (arg arg*)
(cond
[(null? arg*)
(if (list? arg)
arg
(error 'apply "~s is not a list" arg))]
[else
(cons arg (fix ($car arg*) ($cdr arg*)))]))])
(lambda (f arg . arg*)
($apply f (fix arg arg*)))))
($pcb-set! assq
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assq "malformed alist ~s"
ls)))
(error 'assq "circular list ~s" ls))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))
(error 'assq "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
($pcb-set! string->symbol
(lambda (x)
(unless (string? x)
(error 'string->symbol "~s is not a string" x))
($intern x)))
($pcb-set! gensym
(lambda args
(if (null? args)
($make-symbol "g")
(if (null? ($cdr args))
(let ([a ($car args)])
(if (string? a)
($make-symbol a)
(error 'gensym "~s is not a string" a)))
(error 'gensym "too many arguments")))))
($pcb-set! make-parameter
(letrec ([make-param-no-guard
(lambda (x)
(lambda args
(if (null? args)
x
(if (null? ($cdr args))
(set! x ($car args))
(error #f "too many arguments to parameter")))))]
[make-param-with-guard
(lambda (x g)
(let ([f
(lambda args
(if (null? args)
x
(if (null? ($cdr args))
(set! x (g ($car args)))
(error #f "too many arguments to parameter"))))])
(if (procedure? g)
(begin (set! x (g x)) f)
(error 'make-parameter "not a procedure ~s" g))))])
(lambda args
(if (pair? args)
(let ([x ($car args)] [args ($cdr args)])
(if (null? args)
(make-param-no-guard x)
(let ([g ($car args)])
(if (null? ($cdr args))
(make-param-with-guard x g)
(error 'make-parameter "too many arguments")))))
(error 'make-parameter "insufficient arguments")))))
(let ()
(define vector-loop
(lambda (x y i n)
(or ($fx= i n)
(and (equal? ($vector-ref x i) ($vector-ref y i))
(vector-loop x y ($fxadd1 i) n)))))
(define string-loop
(lambda (x y i n)
(or ($fx= i n)
(and ($char= ($string-ref x i) ($string-ref y i))
(string-loop x y ($fxadd1 i) n)))))
(define equal?
(lambda (x y)
(cond
[(eq? x y) #t]
[(pair? x)
(and (pair? y)
(equal? ($car x) ($car y))
(equal? ($cdr x) ($cdr y)))]
[(vector? x)
(and (vector? y)
(let ([n ($vector-length x)])
(and ($fx= n ($vector-length y))
(vector-loop x y 0 n))))]
[(string? x)
(and (string? y)
(let ([n ($string-length x)])
(and ($fx= n ($string-length y))
(string-loop x y 0 n))))]
[else #f])))
($pcb-set! equal? equal?))
(let ()
(define map1
(lambda (h t ls f)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(cons (f a1) (cons (f a2) (map1 ($cdr h) ($cdr t) ls f))))
(error 'map "circular list ~s" ls))
(if (null? h)
(cons (f a1) '())
(error 'map "~s is not a proper list" ls))))
(if (null? h)
'()
(error 'map "~s is not a proper list" ls)))))
($pcb-set! map
(lambda (f ls . ls*)
(unless (procedure? f)
(error 'map "not a procedure ~s" f))
(if (null? ls*)
(map1 ls ls ls f)
(error 'map "multiarg not supported yet")))))
(let ()
(define for-each1
(lambda (h t ls f)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(f a1)
(f a2)
(for-each1 ($cdr h) ($cdr t) ls f))
(error 'for-each "circular list ~s" ls))
(if (null? h)
(begin (f a1) (void))
(error 'for-each "~s is not a proper list" ls))))
(if (null? h)
(void)
(error 'for-each "~s is not a proper list" ls)))))
($pcb-set! for-each
(lambda (f ls . ls*)
(unless (procedure? f)
(error 'for-each "not a procedure ~s" f))
(if (null? ls*)
(for-each1 ls ls ls f)
(error 'for-each "multiarg not supported yet")))))
(let ()
(define andmap1
(lambda (a h t ls f)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(and (f a)
(f a1)
(andmap1 a2 ($cdr h) ($cdr t) ls f)))
(error 'andmap "circular list ~s" ls))
(if (null? h)
(and (f a) (f a1))
(error 'andmap "~s is not a proper list" ls))))
(if (null? h)
(f a)
(error 'map "~s is not a proper list" ls)))))
($pcb-set! andmap
(lambda (f ls . ls*)
(unless (procedure? f)
(error 'andmap "not a procedure ~s" f))
(if (null? ls*)
(if (null? ls)
#t
(andmap1 (car ls) (cdr ls) (cdr ls) ls f))
(error 'andmap "multiarg not supported yet")))))
(let ()
(define reverse
(lambda (h t ls ac)
(if (pair? h)
(let ([h ($cdr h)] [a1 ($car h)])
(if (pair? h)
(if (not (eq? h t))
(let ([a2 ($car h)])
(reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac))))
(error 'append "circular list ~s" ls))
(if (null? h)
(cons a1 '())
(error 'append "~s is not a proper list" ls))))
(if (null? h)
ac
(error 'append "~s is not a proper list" ls)))))
(define revcons
(lambda (ls ac)
(cond
[(pair? ls)
(revcons ($cdr ls) (cons ($car ls) ac))]
[else ac])))
(define append
(lambda (ls ls*)
(cond
[(null? ls*) ls]
[else
(revcons (reverse ls ls ls '())
(append ($car ls*) ($cdr ls*)))])))
($pcb-set! append
(lambda (ls . ls*)
(append ls ls*))))
($pcb-set! list->vector
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls ($fx+ n 2))
(error 'list->vector "circular list ~s" ls))
(if (null? h)
($fx+ n 1)
(error 'list->vector "~s is not a proper list" ls))))
(if (null? h)
n
(error 'list->vector "~s is not a proper list" ls))))]
[fill
(lambda (v i ls)
(cond
[(null? ls) v]
[else
(let ([c ($car ls)])
($vector-set! v i c)
(fill v ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
(let ([n (race ls ls ls 0)])
(let ([v ($make-vector n)])
(fill v 0 ls))))))
(let ()
(define f
(lambda (v i ls)
(cond
[($fx< i 0) ls]
[else
(f v ($fxsub1 i) (cons ($vector-ref v i) ls))])))
($pcb-set! vector->list
(lambda (v)
(if (vector? v)
(let ([n ($vector-length v)])
(if ($fxzero? n)
'()
(f v ($fxsub1 n) '())))
(error 'vector->list "~s is not a vector" v)))))
(let ()
(define f
(lambda (n fill ls)
(cond
[($fxzero? n) ls]
[else
(f ($fxsub1 n) fill (cons fill ls))])))
($pcb-set! make-list
(lambda (n . args)
(let ([fill
(if (null? args)
(void)
(if (null? (cdr args))
(car args)
(error 'make-list "too many arguments")))])
(if (fixnum? n)
(if ($fx>= n 0)
(f n fill '())
(error 'make-list "negative size ~s" n))
(error 'make-list "invalid size ~s" n))))))
($pcb-set! list (lambda x x))

528
src/libcore-5.6.ss → src/libcore-6.0.ss
View File

@ -1,156 +1,86 @@
($pcb-set! error
(primitive-set! 'call-with-values
($make-call-with-values-procedure))
(primitive-set! 'values
($make-values-procedure))
(primitive-set! 'error
(lambda args
(foreign-call "S_error" args)))
(foreign-call "ik_error" args)))
($pcb-set! exit
(primitive-set! 'exit
(lambda args
(if (null? args)
($exit 0)
(foreign-call "exit" 0)
(if (null? ($cdr args))
($exit ($car args))
(foreign-call "exit" ($car args))
(error 'exit "too many arguments")))))
($pcb-set! eof-object
(primitive-set! 'eof-object
(lambda () (eof-object)))
($pcb-set! void
(primitive-set! 'void
(lambda () (void)))
($pcb-set! eof-object?
(primitive-set! 'eof-object?
(lambda (x) (eof-object? x)))
($pcb-set! fxadd1
(primitive-set! 'fxadd1
(lambda (n)
(unless (fixnum? n)
(error 'fxadd1 "~s is not a fixnum" n))
($fxadd1 n)))
($pcb-set! fxsub1
(primitive-set! 'fxsub1
(lambda (n)
(unless (fixnum? n)
(error 'fxsub1 "~s is not a fixnum" n))
($fxsub1 n)))
($pcb-set! fixnum->char
(primitive-set! 'integer->char
(lambda (n)
(unless (fixnum? n)
(error 'fixnum->char "~s is not a fixnum" n))
(error 'integer->char "~s is not a fixnum" n))
(unless (and ($fx>= n 0)
($fx<= n 127))
(error 'fixnum->char "~s is out of range[0..127]" n))
($fx<= n 255))
(error 'integer->char "~s is out of range[0..255]" n))
($fixnum->char n)))
($pcb-set! char->fixnum
(primitive-set! 'char->integer
(lambda (x)
(unless (char? x)
(error 'char->fixnum "~s is not a character" x))
(error 'char->integer "~s is not a character" x))
($char->fixnum x)))
($pcb-set! fxlognot
(primitive-set! 'fxlognot
(lambda (x)
(unless (fixnum? x)
(error 'fxlognot "~s is not a fixnum" x))
($fxlognot x)))
($pcb-set! fixnum? (lambda (x) (fixnum? x)))
($pcb-set! immediate? (lambda (x) (immediate? x)))
(primitive-set! 'fixnum? (lambda (x) (fixnum? x)))
(primitive-set! 'immediate? (lambda (x) (immediate? x)))
($pcb-set! fxzero?
(primitive-set! 'fxzero?
(lambda (x)
(unless (fixnum? x)
(error 'fxzero? "~s is not a fixnum" x))
($fxzero? x)))
($pcb-set! boolean? (lambda (x) (boolean? x)))
(primitive-set! 'boolean? (lambda (x) (boolean? x)))
($pcb-set! char? (lambda (x) (char? x)))
(primitive-set! 'char? (lambda (x) (char? x)))
($pcb-set! vector? (lambda (x) (vector? x)))
(primitive-set! 'vector? (lambda (x) (vector? x)))
($pcb-set! string? (lambda (x) (string? x)))
(primitive-set! 'string? (lambda (x) (string? x)))
($pcb-set! procedure? (lambda (x) (procedure? x)))
(primitive-set! 'procedure? (lambda (x) (procedure? x)))
($pcb-set! null? (lambda (x) (null? x)))
(primitive-set! 'null? (lambda (x) (null? x)))
($pcb-set! pair? (lambda (x) (pair? x)))
($pcb-set! car
(lambda (x)
(unless (pair? x)
(error 'car "~s is not a pair" x))
($car x)))
($pcb-set! cdr
(lambda (x)
(unless (pair? x)
(error 'cdr "~s is not a pair" x))
($cdr x)))
($pcb-set! caar
(lambda (x)
(unless (pair? x) (error 'caar "incorrect list structure ~s" x))
(let ([a ($car x)])
(unless (pair? a) (error 'caar "incorrect list structure ~s" x))
($car a))))
($pcb-set! cadr
(lambda (x)
(unless (pair? x) (error 'cadr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cadr "incorrect list structure ~s" x))
($car d))))
($pcb-set! cdar
(lambda (x)
(unless (pair? x) (error 'cdar "incorrect list structure ~s" x))
(let ([a ($car x)])
(unless (pair? a) (error 'cdar "incorrect list structure ~s" x))
($cdr a))))
($pcb-set! cddr
(lambda (x)
(unless (pair? x) (error 'cddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cddr "incorrect list structure ~s" x))
($cdr d))))
($pcb-set! caddr
(lambda (x)
(unless (pair? x) (error 'caddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'caddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'caddr "correct list structure ~s" x))
($car dd)))))
($pcb-set! cadddr
(lambda (x)
(unless (pair? x) (error 'cadddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cadddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'cadddr "correct list structure ~s" x))
(let ([ddd ($cdr dd)])
(unless (pair? ddd) (error 'cadddr "correct list structure ~s" x))
($car ddd))))))
($pcb-set! cddddr
(lambda (x)
(unless (pair? x) (error 'cddddr "incorrect list structure ~s" x))
(let ([d ($cdr x)])
(unless (pair? d) (error 'cddddr "incorrect list structure ~s" x))
(let ([dd ($cdr d)])
(unless (pair? dd) (error 'cddddr "correct list structure ~s" x))
(let ([ddd ($cdr dd)])
(unless (pair? ddd) (error 'cddddr "correct list structure ~s" x))
($cdr ddd))))))
(primitive-set! 'pair? (lambda (x) (pair? x)))
(let ()
(define fill!
@ -160,36 +90,46 @@
[else
($vector-set! v i fill)
(fill! v ($fx+ i 1) n fill)])))
($pcb-set! make-vector
(primitive-set! 'make-vector
(lambda (n . opt)
(unless (and (fixnum? n) ($fx>= n 0))
(error 'make-vector "~s is not a valid size" n))
(let ([fill (if (null? opt)
#f
(void)
(if (null? ($cdr opt))
($car opt)
(error 'make-vector "too many arguments")))])
(let ([v ($make-vector n)])
(fill! v 0 n fill))))))
($pcb-set! vector-length
(primitive-set! 'vector-length
(lambda (x)
(unless (vector? x)
(error 'vector-length "~s is not a vector" x))
($vector-length x)))
($pcb-set! make-string
(primitive-set! 'make-string
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'make-string "~s is not a valid size" x))
($make-string x)))
($pcb-set! string-length
(primitive-set! 'string-length
(lambda (x)
(unless (string? x)
(error 'string-length "~s is not a string" x))
($string-length x)))
(primitive-set! 'string->list
(lambda (x)
(unless (string? x)
(error 'string->list "~s is not a string" x))
(let f ([x x] [i ($string-length x)] [ac '()])
(cond
[($fxzero? i) ac]
[else
(let ([i ($fxsub1 i)])
(f x i (cons ($string-ref x i) ac)))]))))
(let ()
(define bstring=?
@ -214,7 +154,7 @@
(and (strings=? s ($cdr s*) n)
(bstring=? s a 0 n))
(check-strings-and-return-false ($cdr s*)))))))
($pcb-set! string=?
(primitive-set! 'string=?
(lambda (s . s*)
(if (string? s)
(strings=? s s* ($string-length s))
@ -245,7 +185,7 @@
(let ([j ($fx+ i n)])
(fill-string s a i j 0)
(fill-strings s ($cdr s*) j))))])))
($pcb-set! string-append
(primitive-set! 'string-append
(lambda s*
(let ([n (length* s* 0)])
(let ([s ($make-string n)])
@ -260,7 +200,7 @@
[else
($string-set! d di ($string-ref s si))
(fill s d ($fxadd1 si) sj ($fxadd1 di))])))
($pcb-set! substring
(primitive-set! 'substring
(lambda (s n m)
(unless (string? s)
(error 'substring "~s is not a string" s))
@ -278,60 +218,59 @@
""
(fill s ($make-string len) n m 0)))))))
($pcb-set! not (lambda (x) (not x)))
(primitive-set! 'not (lambda (x) (not x)))
($pcb-set! symbol->string
(primitive-set! 'symbol->string
(lambda (x)
(unless (symbol? x)
(error 'symbol->string "~s is not a symbol" x))
($symbol-string x)))
(let ([str ($symbol-string x)])
(or str
(let ([ct (gensym-count)])
(let ([str (string-append (gensym-prefix) (fixnum->string ct))])
($set-symbol-string! x str)
(gensym-count ($fxadd1 ct))
str))))))
($pcb-set! gensym?
(primitive-set! 'gensym?
(lambda (x)
(and (symbol? x)
(let ([s ($symbol-unique-string x)])
(and s #t)))))
(let ()
(define generate-id
(let ((digits "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?~_^.+-"))
(let ((base ($string-length digits)) (session-key "::"))
(define make-digit (lambda (x) (string-ref digits x)))
(define fmt
(lambda (n)
(let fmt ((n n) (a '()))
(if ($fx< n base)
(list->string (cons (make-digit n) a))
(let ((r ($fxmodulo n base)) (rest ($fxquotient n base)))
(fmt rest (cons (make-digit r) a)))))))
(let ((n -1))
(lambda ()
(set! n ($fx+ n 1))
(string-append session-key (fmt n)))))))
($pcb-set! gensym->unique-string
(define f
(lambda (n i j)
(cond
[($fxzero? n)
(values (make-string i) j)]
[else
(let ([q ($fxquotient n 10)])
(call-with-values
(lambda () (f q ($fxadd1 i) j))
(lambda (str j)
(let ([r ($fx- n ($fx* q 10))])
(string-set! str j
($fixnum->char ($fx+ r ($char->fixnum #\0))))
(values str ($fxadd1 j))))))])))
(primitive-set! 'fixnum->string
(lambda (x)
(unless (symbol? x)
(error 'gensym->unique-string "~s is not a gensym" x))
(let ([us ($symbol-unique-string x)])
(cond
[(string? us) us]
[(eq? us #t)
(error 'gensym->unique-string "~s is not a symbol" x)]
[else
(let ([guid (generate-id)])
($set-symbol-unique-string! x guid)
guid)])))))
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
(cond
[($fxzero? x) "0"]
[($fx> x 0)
(call-with-values
(lambda () (f x 0 0))
(lambda (str j) str))]
[($fx= x -536870912) "-536870912"]
[else
(call-with-values
(lambda () (f ($fx- 0 x) 1 1))
(lambda (str j)
($string-set! str 0 #\-)
str))]))))
($pcb-set! top-level-value
(primitive-set! 'top-level-value
(lambda (x)
(unless (symbol? x)
(error 'top-level-value "~s is not a symbol" x))
@ -340,21 +279,34 @@
(error 'top-level-value "unbound variable ~s" x))
v)))
($pcb-set! top-level-bound?
(primitive-set! 'top-level-bound?
(lambda (x)
(unless (symbol? x)
(error 'top-level-bound? "~s is not a symbol" x))
(not ($unbound-object? ($symbol-value x)))))
($pcb-set! set-top-level-value!
(primitive-set! 'set-top-level-value!
(lambda (x v)
(unless (symbol? x)
(error 'set-top-level-value! "~s is not a symbol" x))
($set-symbol-value! x v)))
($pcb-set! symbol? (lambda (x) (symbol? x)))
(primitive-set! 'symbol? (lambda (x) (symbol? x)))
($pcb-set! fx+
(primitive-set! 'primitive?
(lambda (x)
(unless (symbol? x)
(error 'primitive? "~s is not a symbol" x))
(procedure? (primitive-ref x))))
(primitive-set! 'primitive-ref
(lambda (x)
(unless (symbol? x)
(error 'primitive-ref "~s is not a symbol" x))
(primitive-ref x)))
(primitive-set! 'fx+
(lambda (x y)
(unless (fixnum? x)
(error 'fx+ "~s is not a fixnum" x))
@ -362,7 +314,7 @@
(error 'fx+ "~s is not a fixnum" y))
($fx+ x y)))
($pcb-set! fx-
(primitive-set! 'fx-
(lambda (x y)
(unless (fixnum? x)
(error 'fx- "~s is not a fixnum" x))
@ -370,7 +322,7 @@
(error 'fx- "~s is not a fixnum" y))
($fx- x y)))
($pcb-set! fx*
(primitive-set! 'fx*
(lambda (x y)
(unless (fixnum? x)
(error 'fx* "~s is not a fixnum" x))
@ -380,7 +332,7 @@
($pcb-set! fxquotient
(primitive-set! 'fxquotient
(lambda (x y)
(unless (fixnum? x)
(error 'fxquotient "~s is not a fixnum" x))
@ -391,7 +343,7 @@
($fxquotient x y)))
($pcb-set! fxremainder
(primitive-set! 'fxremainder
(lambda (x y)
(unless (fixnum? x)
(error 'fxremainder "~s is not a fixnum" x))
@ -403,7 +355,7 @@
($fx- x ($fx* q y)))))
($pcb-set! fxmodulo
(primitive-set! 'fxmodulo
(lambda (x y)
(unless (fixnum? x)
(error 'fxmodulo "~s is not a fixnum" x))
@ -414,7 +366,7 @@
($fxmodulo x y)))
($pcb-set! fxlogor
(primitive-set! 'fxlogor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogor "~s is not a fixnum" x))
@ -422,7 +374,7 @@
(error 'fxlogor "~s is not a fixnum" y))
($fxlogor x y)))
($pcb-set! fxlogxor
(primitive-set! 'fxlogxor
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogxor "~s is not a fixnum" x))
@ -430,7 +382,7 @@
(error 'fxlogxor "~s is not a fixnum" y))
($fxlogxor x y)))
($pcb-set! fxlogand
(primitive-set! 'fxlogand
(lambda (x y)
(unless (fixnum? x)
(error 'fxlogand "~s is not a fixnum" x))
@ -438,7 +390,7 @@
(error 'fxlogand "~s is not a fixnum" y))
($fxlogand x y)))
($pcb-set! fxsra
(primitive-set! 'fxsra
(lambda (x y)
(unless (fixnum? x)
(error 'fxsra "~s is not a fixnum" x))
@ -448,7 +400,7 @@
(error 'fxsra "negative shift not allowed, got ~s" y))
($fxsra x y)))
($pcb-set! fxsll
(primitive-set! 'fxsll
(lambda (x y)
(unless (fixnum? x)
(error 'fxsll "~s is not a fixnum" x))
@ -458,7 +410,7 @@
(error 'fxsll "negative shift not allowed, got ~s" y))
($fxsll x y)))
($pcb-set! fx=
(primitive-set! 'fx=
(lambda (x y)
(unless (fixnum? x)
(error 'fx= "~s is not a fixnum" x))
@ -466,7 +418,7 @@
(error 'fx= "~s is not a fixnum" y))
($fx= x y)))
($pcb-set! fx<
(primitive-set! 'fx<
(lambda (x y)
(unless (fixnum? x)
(error 'fx< "~s is not a fixnum" x))
@ -474,7 +426,7 @@
(error 'fx< "~s is not a fixnum" y))
($fx< x y)))
($pcb-set! fx<=
(primitive-set! 'fx<=
(lambda (x y)
(unless (fixnum? x)
(error 'fx<= "~s is not a fixnum" x))
@ -482,7 +434,7 @@
(error 'fx<= "~s is not a fixnum" y))
($fx<= x y)))
($pcb-set! fx>
(primitive-set! 'fx>
(lambda (x y)
(unless (fixnum? x)
(error 'fx> "~s is not a fixnum" x))
@ -490,7 +442,7 @@
(error 'fx> "~s is not a fixnum" y))
($fx> x y)))
($pcb-set! fx>=
(primitive-set! 'fx>=
(lambda (x y)
(unless (fixnum? x)
(error 'fx>= "~s is not a fixnum" x))
@ -498,7 +450,7 @@
(error 'fx>= "~s is not a fixnum" y))
($fx>= x y)))
($pcb-set! char=
(primitive-set! 'char=
(lambda (x y)
(unless (char? x)
(error 'char= "~s is not a character" x))
@ -506,7 +458,7 @@
(error 'char= "~s is not a character" y))
($char= x y)))
($pcb-set! char<
(primitive-set! 'char<
(lambda (x y)
(unless (char? x)
(error 'char< "~s is not a character" x))
@ -514,7 +466,7 @@
(error 'char< "~s is not a character" y))
($char< x y)))
($pcb-set! char<=
(primitive-set! 'char<=
(lambda (x y)
(unless (char? x)
(error 'char<= "~s is not a character" x))
@ -522,7 +474,7 @@
(error 'char<= "~s is not a character" y))
($char<= x y)))
($pcb-set! char>
(primitive-set! 'char>
(lambda (x y)
(unless (char? x)
(error 'char> "~s is not a character" x))
@ -530,7 +482,7 @@
(error 'char> "~s is not a character" y))
($char> x y)))
($pcb-set! char>=
(primitive-set! 'char>=
(lambda (x y)
(unless (char? x)
(error 'char>= "~s is not a character" x))
@ -538,23 +490,23 @@
(error 'char>= "~s is not a character" y))
($char>= x y)))
($pcb-set! cons (lambda (x y) (cons x y)))
(primitive-set! 'cons (lambda (x y) (cons x y)))
($pcb-set! eq? (lambda (x y) (eq? x y)))
(primitive-set! 'eq? (lambda (x y) (eq? x y)))
($pcb-set! set-car!
(primitive-set! 'set-car!
(lambda (x y)
(unless (pair? x)
(error 'set-car! "~s is not a pair" x))
($set-car! x y)))
($pcb-set! set-cdr!
(primitive-set! 'set-cdr!
(lambda (x y)
(unless (pair? x)
(error 'set-cdr! "~s is not a pair" x))
($set-cdr! x y)))
($pcb-set! vector-ref
(primitive-set! 'vector-ref
(lambda (v i)
(unless (vector? v)
(error 'vector-ref "~s is not a vector" v))
@ -565,7 +517,7 @@
(error 'vector-ref "index ~s is out of range for ~s" i v))
($vector-ref v i)))
($pcb-set! string-ref
(primitive-set! 'string-ref
(lambda (s i)
(unless (string? s)
(error 'string-ref "~s is not a string" s))
@ -576,7 +528,7 @@
(error 'string-ref "index ~s is out of range for ~s" i s))
($string-ref s i)))
($pcb-set! vector-set!
(primitive-set! 'vector-set!
(lambda (v i c)
(unless (vector? v)
(error 'vector-set! "~s is not a vector" v))
@ -588,7 +540,7 @@
($vector-set! v i c)))
($pcb-set! string-set!
(primitive-set! 'string-set!
(lambda (s i c)
(unless (string? s)
(error 'string-set! "~s is not a string" s))
@ -601,7 +553,7 @@
(error 'string-set! "~s is not a character" c))
($string-set! s i c)))
($pcb-set! vector
(primitive-set! 'vector
(letrec ([length
(lambda (ls n)
(cond
@ -616,7 +568,7 @@
(loop v ($cdr ls) ($fx+ i 1) n)]))])
(lambda ls
(let ([n (length ls 0)])
(let ([v ($make-vector n)])
(let ([v (make-vector n)])
(loop v ls 0 n))))))
(letrec ([length
@ -639,9 +591,9 @@
(let ([n (length ls 0)])
(let ([s ($make-string n)])
(loop s ls 0 n))))])
($pcb-set! string f)))
(primitive-set! 'string f)))
($pcb-set! list?
(primitive-set! 'list?
(letrec ([race
(lambda (h t)
(if (pair? h)
@ -655,7 +607,7 @@
($pcb-set! reverse
(primitive-set! 'reverse
(letrec ([race
(lambda (h t ls ac)
(if (pair? h)
@ -673,7 +625,7 @@
(lambda (x)
(race x x x '()))))
($pcb-set! memq
(primitive-set! 'memq
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
@ -695,7 +647,7 @@
(lambda (x ls)
(race ls ls ls x))))
($pcb-set! list->string
(primitive-set! 'list->string
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
@ -725,7 +677,7 @@
(let ([s ($make-string n)])
(fill s 0 ls))))))
($pcb-set! length
(primitive-set! 'length
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
@ -744,7 +696,7 @@
(race ls ls ls 0))))
($pcb-set! list-ref
(primitive-set! 'list-ref
(lambda (list index)
(define f
(lambda (ls i)
@ -764,20 +716,40 @@
($pcb-set! apply
;(primitive-set! 'apply
; (letrec ([fix
; (lambda (arg arg*)
; (cond
; [(null? arg*)
; (if (list? arg)
; arg
; (error 'apply "last arg is not a list"))]
; [else
; (cons arg (fix ($car arg*) ($cdr arg*)))]))])
; (lambda (f arg . arg*)
; (unless (procedure? f)
; (error 'apply "APPLY ~s ~s ~s" f arg arg*))
; ($apply f (fix arg arg*)))))
;
(primitive-set! 'apply
(letrec ([fix
(lambda (arg arg*)
(cond
[(null? arg*)
(if (list? arg)
arg
(error 'apply "~s is not a list" arg))]
(error 'apply "last arg is not a list"))]
[else
(cons arg (fix ($car arg*) ($cdr arg*)))]))])
(lambda (f arg . arg*)
($apply f (fix arg arg*)))))
(unless (procedure? f)
(error 'apply "APPLY ~s ~s ~s" f arg arg*))
(let ([args (fix arg arg*)])
($apply f args)))))
($pcb-set! assq
(primitive-set! 'assq
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
@ -805,18 +777,20 @@
(lambda (x ls)
(race x ls ls ls))))
($pcb-set! string->symbol
(primitive-set! 'string->symbol
(lambda (x)
(unless (string? x)
(error 'string->symbol "~s is not a string" x))
($intern x)))
(foreign-call "ik_intern_string" x)))
($pcb-set! gensym
(primitive-set! 'oblist
(lambda ()
(foreign-call "ik_oblist")))
(primitive-set! 'gensym
(lambda args
(if (null? args)
($make-symbol "g")
($make-symbol #f)
(if (null? ($cdr args))
(let ([a ($car args)])
(if (string? a)
@ -824,7 +798,7 @@
(error 'gensym "~s is not a string" a)))
(error 'gensym "too many arguments")))))
($pcb-set! putprop
(primitive-set! 'putprop
(lambda (x k v)
(unless (symbol? x) (error 'putprop "~s is not a symbol" x))
(unless (symbol? k) (error 'putprop "~s is not a symbol" k))
@ -834,7 +808,7 @@
[else
($set-symbol-plist! x (cons (cons k v) p))]))))
($pcb-set! getprop
(primitive-set! 'getprop
(lambda (x k)
(unless (symbol? x) (error 'getprop "~s is not a symbol" x))
(unless (symbol? k) (error 'getprop "~s is not a symbol" k))
@ -843,7 +817,7 @@
[(assq k p) => cdr]
[else #f]))))
($pcb-set! remprop
(primitive-set! 'remprop
(lambda (x k)
(unless (symbol? x) (error 'remprop "~s is not a symbol" x))
(unless (symbol? k) (error 'remprop "~s is not a symbol" k))
@ -862,7 +836,7 @@
[else
(f p ($cdr p))]))))]))))))
($pcb-set! property-list
(primitive-set! 'property-list
(lambda (x)
(unless (symbol? x)
(error 'property-list "~s is not a symbol" x))
@ -877,7 +851,7 @@
(f ($symbol-plist x) '()))))
($pcb-set! make-parameter
(primitive-set! 'make-parameter
(letrec ([make-param-no-guard
(lambda (x)
(lambda args
@ -939,7 +913,7 @@
(and ($fx= n ($string-length y))
(string-loop x y 0 n))))]
[else #f])))
($pcb-set! equal? equal?))
(primitive-set! 'equal? equal?))
(let ()
@ -996,7 +970,50 @@
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
($pcb-set! map
(define cars
(lambda (ls*)
(cond
[(null? ls*) '()]
[else
(let ([a (car ls*)])
(cond
[(pair? a)
(cons (car a) (cars (cdr ls*)))]
[else
(error 'map "length mismatch")]))])))
(define cdrs
(lambda (ls*)
(cond
[(null? ls*) '()]
[else
(let ([a (car ls*)])
(cond
[(pair? a)
(cons (cdr a) (cdrs (cdr ls*)))]
[else
(error 'map "length mismatch")]))])))
(define mapm
(lambda (f ls ls* n)
(cond
[(null? ls)
(if (andmap null? ls*)
(if (fxzero? n)
'()
(error 'map "lists were mutated during operation"))
(error 'map "length mismatch"))]
[(fxzero? n)
(error 'map "lists were mutated during operation")]
[else
(cons
(apply f (car ls) (cars ls*))
(mapm f (cdr ls) (cdrs ls*) (fxsub1 n)))])))
(define dup
(lambda (ls ac)
(cond
[(null? ls) ac]
[else (dup (cdr ls) (cons '() ac))])))
(primitive-set! 'map
(lambda (f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
@ -1021,7 +1038,15 @@
'()
(error who "length mismatch"))]
[else (error who "not a list")]))]
[else (error who "vararg not supported yet")]))))
[else
(cond
[(pair? ls)
(let ([n (len ls ls 0)])
(mapm f ls ls* n))]
[(null? ls)
(if (andmap null? ls*)
'()
(error who "length mismatch"))])]))))
(let ()
(define who 'for-each)
@ -1079,7 +1104,7 @@
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
($pcb-set! for-each
(primitive-set! 'for-each
(lambda (f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
@ -1140,7 +1165,7 @@
(error who "list was altered"))]
[else (error who "list was altered")])))
($pcb-set! andmap
(primitive-set! 'andmap
(lambda (f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
@ -1186,7 +1211,7 @@
(error who "list was altered"))]
[else (error who "list was altered")])))
($pcb-set! ormap
(primitive-set! 'ormap
(lambda (f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
@ -1232,12 +1257,12 @@
[else
(revcons (reverse ls ls ls '())
(append ($car ls*) ($cdr ls*)))])))
($pcb-set! append
(primitive-set! 'append
(lambda (ls . ls*)
(append ls ls*))))
($pcb-set! list->vector
(primitive-set! 'list->vector
(letrec ([race
(lambda (h t ls n)
(if (pair? h)
@ -1262,7 +1287,7 @@
(fill v ($fxadd1 i) (cdr ls)))]))])
(lambda (ls)
(let ([n (race ls ls ls 0)])
(let ([v ($make-vector n)])
(let ([v (make-vector n)])
(fill v 0 ls))))))
@ -1273,7 +1298,7 @@
[($fx< i 0) ls]
[else
(f v ($fxsub1 i) (cons ($vector-ref v i) ls))])))
($pcb-set! vector->list
(primitive-set! 'vector->list
(lambda (v)
(if (vector? v)
(let ([n ($vector-length v)])
@ -1289,7 +1314,7 @@
[($fxzero? n) ls]
[else
(f ($fxsub1 n) fill (cons fill ls))])))
($pcb-set! make-list
(primitive-set! 'make-list
(lambda (n . args)
(let ([fill
(if (null? args)
@ -1303,4 +1328,65 @@
(error 'make-list "negative size ~s" n))
(error 'make-list "invalid size ~s" n))))))
($pcb-set! list (lambda x x))
(primitive-set! 'list (lambda x x))
(primitive-set! 'uuid
(lambda ()
(let ([s (make-string 36)])
(foreign-call "ik_uuid" s))))
(primitive-set! 'gensym->unique-string
(lambda (x)
(unless (symbol? x)
(error 'gensym->unique-string "~s is not a gensym" x))
(let ([us ($symbol-unique-string x)])
(cond
[(string? us) us]
[(eq? us #t)
(error 'gensym->unique-string "~s is not a gensym" x)]
[else
(let ([id (uuid)])
($set-symbol-unique-string! x id)
id)]))))
(primitive-set! 'gensym-prefix
(make-parameter
"g"
(lambda (x)
(unless (string? x)
(error 'gensym-prefix "~s is not a string" x))
x)))
(primitive-set! 'gensym-count
(make-parameter
0
(lambda (x)
(unless (and (fixnum? x) ($fx>= x 0))
(error 'gensym-count "~s is not a valid count" x))
x)))
(primitive-set! 'print-gensym
(make-parameter
#t
(lambda (x)
(unless (boolean? x)
(error 'print-gensym "~s is not a boolean" x))
x)))
(primitive-set! 'make-hash-table
(lambda ()
(make-hash-table)))
(primitive-set! 'hash-table?
(lambda (x)
(hash-table? x)))
(primitive-set! 'get-hash-table
(lambda (h k v)
(foreign-call "ik_get_hash_table" h k v)))
(primitive-set! 'put-hash-table!
(lambda (h k v)
(foreign-call "ik_put_hash_table" h k v)))

BIN
src/libcore.fasl Normal file
View File

Binary file not shown.

326
src/libcxr-6.0.ss Normal file
View File

@ -0,0 +1,326 @@
(let ([err (lambda (who x)
(error who "invalid list structure ~s" x))])
(primitive-set!
'car
(lambda (orig)
(if (pair? orig) ($car orig) (err 'car orig))))
(primitive-set!
'cdr
(lambda (orig)
(if (pair? orig) ($cdr orig) (err 'cdr orig))))
(primitive-set!
'caar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x) ($car x) (err 'caar orig)))
(err 'caar orig))))
(primitive-set!
'cadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($car x) (err 'cadr orig)))
(err 'cadr orig))))
(primitive-set!
'cdar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x) ($cdr x) (err 'cdar orig)))
(err 'cdar orig))))
(primitive-set!
'cddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($cdr x) (err 'cddr orig)))
(err 'cddr orig))))
(primitive-set!
'caaar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaar orig)))
(err 'caaar orig)))
(err 'caaar orig))))
(primitive-set!
'caadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caadr orig)))
(err 'caadr orig)))
(err 'caadr orig))))
(primitive-set!
'cadar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadar orig)))
(err 'cadar orig)))
(err 'cadar orig))))
(primitive-set!
'caddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'caddr orig)))
(err 'caddr orig)))
(err 'caddr orig))))
(primitive-set!
'cdaar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaar orig)))
(err 'cdaar orig)))
(err 'cdaar orig))))
(primitive-set!
'cdadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdadr orig)))
(err 'cdadr orig)))
(err 'cdadr orig))))
(primitive-set!
'cddar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddar orig)))
(err 'cddar orig)))
(err 'cddar orig))))
(primitive-set!
'cdddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cdddr orig)))
(err 'cdddr orig)))
(err 'cdddr orig))))
(primitive-set!
'caaaar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaaar orig)))
(err 'caaaar orig)))
(err 'caaaar orig)))
(err 'caaaar orig))))
(primitive-set!
'caaadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaadr orig)))
(err 'caaadr orig)))
(err 'caaadr orig)))
(err 'caaadr orig))))
(primitive-set!
'caadar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caadar orig)))
(err 'caadar orig)))
(err 'caadar orig)))
(err 'caadar orig))))
(primitive-set!
'caaddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaddr orig)))
(err 'caaddr orig)))
(err 'caaddr orig)))
(err 'caaddr orig))))
(primitive-set!
'cadaar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadaar orig)))
(err 'cadaar orig)))
(err 'cadaar orig)))
(err 'cadaar orig))))
(primitive-set!
'cadadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadadr orig)))
(err 'cadadr orig)))
(err 'cadadr orig)))
(err 'cadadr orig))))
(primitive-set!
'caddar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'caddar orig)))
(err 'caddar orig)))
(err 'caddar orig)))
(err 'caddar orig))))
(primitive-set!
'cadddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadddr orig)))
(err 'cadddr orig)))
(err 'cadddr orig)))
(err 'cadddr orig))))
(primitive-set!
'cdaaar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaaar orig)))
(err 'cdaaar orig)))
(err 'cdaaar orig)))
(err 'cdaaar orig))))
(primitive-set!
'cdaadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaadr orig)))
(err 'cdaadr orig)))
(err 'cdaadr orig)))
(err 'cdaadr orig))))
(primitive-set!
'cdadar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdadar orig)))
(err 'cdadar orig)))
(err 'cdadar orig)))
(err 'cdadar orig))))
(primitive-set!
'cdaddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaddr orig)))
(err 'cdaddr orig)))
(err 'cdaddr orig)))
(err 'cdaddr orig))))
(primitive-set!
'cddaar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddaar orig)))
(err 'cddaar orig)))
(err 'cddaar orig)))
(err 'cddaar orig))))
(primitive-set!
'cddadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddadr orig)))
(err 'cddadr orig)))
(err 'cddadr orig)))
(err 'cddadr orig))))
(primitive-set!
'cdddar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cdddar orig)))
(err 'cdddar orig)))
(err 'cdddar orig)))
(err 'cdddar orig))))
(primitive-set!
'cddddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddddr orig)))
(err 'cddddr orig)))
(err 'cddddr orig)))
(err 'cddddr orig)))))

BIN
src/libcxr.fasl Normal file
View File

Binary file not shown.

564
src/libeval-4.4.ss
View File

@ -1,564 +0,0 @@
(let ()
(define verify-proper-lambda-bindings
(lambda (fml*)
(void)))
(define keyword?
(lambda (x)
(memq x
'(lambda let let* letrec letrec* if quote when unless
set! begin define or and cond))))
(define self-evaluating?
(lambda (x)
(or (fixnum? x) (null? x) (boolean? x) (char? x) (string? x))))
(define extend-r
(lambda (fml* r)
(cons fml* r)))
(define classify
(lambda (fml* k)
(let f ([fml* fml*] [i 0])
(cond
[(null? fml*) (k i #t)]
[(pair? fml*) (f (cdr fml*) (fx+ i 1))]
[else (k i #f)]))))
(define compile-lambda-binder
(lambda (fml*)
(classify fml*
(lambda (len proper?)
(if proper?
(lambda (args)
(let ([v (make-vector len)])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(if (null? args)
v
(error 'apply
"incorrect number of args to procedure"))]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else (error 'apply "insufficient arguments")]))))
(lambda (args)
(let ([v (make-vector (fx+ len 1))])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(vector-set! v i args)
v]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else
(error 'apply "insufficient arguments")])))))))))
(define compile-lambda
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid function definition ~s" x))
(let ([fml* (car body)] [body* (cdr body)])
(verify-proper-lambda-bindings fml*)
(let ([r (extend-r fml* r)]
[ext (compile-lambda-binder fml*)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(lambda args
(body (cons (ext args) env)))))))))
(define compile-if
(lambda (body r x)
(unless (fx= (length body) 3)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr (cadr body) r)]
[altern (compile-expr (caddr body) r)])
(lambda (env)
(if (test env)
(conseq env)
(altern env))))))
(define compile-when
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr*->last (cdr body) r)])
(lambda (env)
(when (test env)
(conseq env))))))
(define compile-unless
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[altern (compile-expr*->last (cdr body) r)])
(lambda (env)
(unless (test env)
(altern env))))))
(define compile-quote
(lambda (body x)
(unless (fx= (length body) 1)
(error 'eval "invalid quote expression ~s" x))
(let ([v (car body)])
(lambda (env) v))))
(define compile-form
(lambda (k body r x)
(cond
[(eq? k 'quote) (compile-quote body x)]
[(eq? k 'lambda) (compile-lambda body r x)]
[(eq? k 'let) (compile-let body r x)]
[(eq? k 'if) (compile-if body r x)]
[(eq? k 'let*) (compile-let* body r x)]
[(eq? k 'letrec) (compile-letrec body r x)]
[(eq? k 'letrec*) (compile-letrec* body r x)]
[(eq? k 'set!) (compile-assign body r x)]
[(eq? k 'begin) (compile-begin body r x)]
[(eq? k 'or) (compile-or body r x)]
[(eq? k 'and) (compile-and body r x)]
[(eq? k 'cond) (compile-cond body r x)]
[(eq? k 'when) (compile-when body r x)]
[(eq? k 'unless) (compile-unless body r x)]
[(eq? k 'define)
(error 'eval "invalid definition in expression context in ~s" x)]
[else (error 'eval "unhandled keyword ~s" k)])))
(define compile-one-clause
(lambda (cls r x rest)
(unless (and (pair? cls) (list? cls))
(error 'eval "invalid cond clause ~s" cls))
(let ([len (length cls)])
(cond
[(fx= len 1)
(let ([q (compile-expr (car cls) r)])
(lambda (env)
(let ([t (q env)])
(if t t (rest env)))))]
[(and (fx= len 3) (eq? (cadr cls) '=>) (special? '=> r))
(let ([q (compile-expr (car cls) r)]
[f (compile-expr (caddr cls) r)])
(lambda (env)
(let ([t (q env)])
(if t ((f env) t) (rest env)))))]
[else
(let ([q (compile-expr (car cls) r)]
[d (compile-expr*->last (cdr cls) r)])
(lambda (env)
(if (q env)
(d env)
(rest env))))]))))
(define compile-last-cond-clause
(lambda (cls r x)
(unless (and (pair? cls) (list? cls))
(error 'eval "invalid syntax ~s" x))
(cond
[(and (eq? (car cls) 'else) (special? 'else r))
(when (null? (cdr cls))
(error 'eval "invalid syntax ~s" x))
(compile-expr*->last (cdr cls) r)]
[else
(compile-one-clause cls r x
(lambda (env) #f))])))
(define compile-cond
(lambda (cls* r x)
(cond
[(null? cls*) (lambda (env) #f)]
[(null? (cdr cls*))
(compile-last-cond-clause (car cls*) r x)]
[else
(compile-one-clause (car cls*) r x
(compile-cond (cdr cls*) r x))])))
(define compile-and
(lambda (ls r x)
(cond
[(null? ls) (lambda (env) #t)]
[(null? (cdr ls)) (compile-expr (car ls) r)]
[else
(let ([a (compile-expr (car ls) r)]
[d (compile-and (cdr ls) r x)])
(lambda (env)
(and (a env) (d env))))])))
(define compile-or
(lambda (ls r x)
(cond
[(null? ls) (lambda (env) #f)]
[(null? (cdr ls)) (compile-expr (car ls) r)]
[else
(let ([a (compile-expr (car ls) r)]
[d (compile-or (cdr ls) r x)])
(lambda (env)
(or (a env) (d env))))])))
(define compile-begin
(lambda (body r x)
(unless (pair? body) (error 'eval "invalid expression ~s" x))
(compile-expr*->last body r)))
(define compile-expr*->last
(lambda (body* r)
(let f ([a (car body*)] [d (cdr body*)])
(cond
[(null? d) (compile-expr a r)]
[else
(let ([a (compile-expr a r)])
(let ([d (compile-expr*->last d r)])
(lambda (env) (a env) (d env))))]))))
(define compile-expr*->assign
(lambda (body* r)
(let f ([i 0] [a (car body*)] [d (cdr body*)])
(cond
[(null? d)
(let ([v (compile-expr a r)])
(lambda (env)
(vector-set! (car env) i (v env))))]
[else
(let ([v (compile-expr a r)]
[d (f (fxadd1 i) (car d) (cdr d))])
(lambda (env)
(vector-set! (car env) i (v env))
(d env)))]))))
(define vector-assign!
(lambda (v i ls)
(unless (null? ls)
(vector-set! v i (car ls))
(vector-assign! v (fxadd1 i) (cdr ls)))))
(define build-letrec
(lambda (lhs* rhs* r body*)
(cond
[(null? lhs*) (compile-expr*->last body* r)]
[else
(let ([r (extend-r lhs* r)])
(let ([rhs* (compile-expr*->list rhs* r)]
[body (compile-expr*->last body* r)]
[n (length lhs*)]) ;?
(lambda (env)
(let ([v (make-vector n #f)])
(let ([env (cons v env)])
(vector-assign! v 0 (rhs* env))
(body env))))))])))
(define verify-bindings
(lambda (bind* x)
(unless (and (list? bind*)
(andmap
(lambda (x)
(and (list? x) (fx= (length x) 2) (symbol? (car x))))
bind*))
(error 'eval "invalid bindings in ~s" x))))
(define compile-letrec
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(build-letrec (map car bind*) (map cadr bind*) r body*))))
(define compile-letrec*
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(if (null? bind*)
(compile-internal body* r x)
(let ([r (extend-r (map car bind*) r)])
(let ([rhs* (compile-expr*->assign (map cadr bind*) r)])
(let ([body (compile-internal body* r x)]
[n (length bind*)])
(lambda (env)
(let ([env (cons (make-vector n #f) env)])
(rhs* env)
(body env))))))))))
(define compile-let
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(if (null? bind*)
(compile-internal body* r x)
(let ([rhs* (compile-expr*->list (map cadr bind*) r)])
(let ([r (extend-r (map car bind*) r)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(body (cons (list->vector (rhs* env)) env))))))))))
(define compile-let*
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(let f ([bind* bind*] [r r])
(cond
[(null? bind*) (compile-internal body* r x)]
[else
(let ([b (car bind*)])
(let ([lhs (car b)] [rhs (cadr b)])
(let ([rhs (compile-expr rhs r)])
(let ([r (extend-r (list lhs) r)])
(let ([rest (f (cdr bind* r))])
(lambda (env)
(let ([env (cons (vector (rhs env)) env)])
(rest env))))))))])))))
(define compile-expr*->list
(lambda (expr* r)
(when (null? expr*)
(error 'eval "this should nto happen"))
(let f ([a (car expr*)] [d (cdr expr*)])
(cond
[(null? d)
(let ([a (compile-expr a r)])
(lambda (env)
(cons (a env) '())))]
[else
(let ([a (compile-expr a r)]
[d (f (car d) (cdr d))])
(lambda (env)
(cons (a env) (d env))))]))))
(define compile-internal-aux
(lambda (x* r x lhs* rhs*)
(when (null? x*)
(error 'eval "no body in ~s" x))
(let ([a (car x*)] [d (cdr x*)])
(cond
[(and (pair? a)
(eq? (car a) 'define)
(special? 'define r)
(not (memq 'define lhs*)))
(unless (and (list? a) (fx= (length a) 3))
(error 'eval "invalid syntax ~s" a))
(let ([lhs (cadr a)] [rhs (caddr a)])
(unless (symbol? lhs)
(error 'eval "invalid id ~s in ~s" lhs x))
(when (memq lhs lhs*)
(error 'eval "duplicate definition for ~s in ~s ~s" lhs lhs* x))
(compile-internal-aux d r x
(cons lhs lhs*) (cons rhs rhs*)))]
[(and (pair? a)
(eq? (car a) 'begin)
(special? 'begin r)
(not (memq 'begin lhs*)))
(let ([rest (cdr a)])
(unless (list? rest)
(error 'eval "invalid begin syntax ~s" a))
(compile-internal-aux (append rest d) r x lhs* rhs*))]
[else
(build-letrec (reverse lhs*) (reverse rhs*) r x*)]))))
(define special?
(lambda (x r)
(cond
[(top-level-bound? x) #f]
[(lookup x r) #f]
[else #t])))
(define compile-internal
(lambda (x* r x)
(compile-internal-aux x* r x '() '())))
(define lookup
(lambda (x r)
(let f ([r r] [i 0])
(cond
[(null? r) #f]
[else
(or (let f ([ls (car r)] [j 0])
(cond
[(null? ls) #f]
[(pair? ls)
(if (eq? (car ls) x)
(cons i j)
(f (cdr ls) (fx+ j 1)))]
[(eq? ls x) (cons i j)]
[else #f]))
(f (cdr r) (fx+ i 1)))]))))
(define compile-assign
(lambda (body r x)
(unless (fx= (length body) 2)
(error 'eval "invalid assignment ~s" x))
(unless (symbol? (car body))
(error 'eval "invalid syntax ~s" x))
(let ([val (compile-expr (cadr body) r)]
[var (car body)])
(cond
[(lookup var r) =>
(lambda (p)
(build-lexical-assignment p val))]
[(top-level-bound? var)
(lambda (env)
(set-top-level-value! var (val env)))]
[(keyword? var)
(error 'eval "invalid assignment to keyword in ~s" x)]
[else
(lambda (env)
(set-top-level-value! var (val env)))]))))
(define list-ref
(lambda (ls i)
(cond
[(null? ls) (error 'list-ref "index out of range")]
[(fxzero? i) (car ls)]
[else (list-ref (cdr ls) (fx- i 1))])))
(define build-lexical-assignment
(lambda (p val)
(lambda (env)
(vector-set! (list-ref env (car p)) (cdr p) (val env)))))
(define build-lexical-reference
(lambda (p)
(lambda (env)
(vector-ref (list-ref env (car p)) (cdr p)))))
(define compile-expr
(lambda (x r)
(cond
[(self-evaluating? x) (lambda (env) x)]
[(symbol? x)
(cond
[(lookup x r) => build-lexical-reference]
[(top-level-bound? x)
(lambda (env) (top-level-value x))]
[(keyword? x) (error 'eval "invalid reference to keyword ~s" x)]
[else
(lambda (env)
(if (top-level-bound? x)
(top-level-value x)
(error 'eval "reference to unbound variable ~s" x)))])]
[(not (list? x)) (error 'eval "invalid expression ~s" x)]
[(and (symbol? (car x)) (keyword? (car x)) (special? (car x) r))
(compile-form (car x) (cdr x) r x)]
[else
(let ([op (compile-expr (car x) r)]
[rand* (cdr x)]
[n (length (cdr x))])
(cond
[(fx= n 0)
(lambda (env) ((op env)))]
[(fx= n 1)
(let ([r1 (compile-expr (car rand*) r)])
(lambda (env)
((op env) (r1 env))))]
[(fx= n 2)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env))))]
[(fx= n 3)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env) (r3 env))))]
[(fx= n 4)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)]
[r4 (compile-expr (cadddr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env) (r3 env) (r4 env))))]
[else
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)]
[r4 (compile-expr (cadddr rand*) r)]
[r* (compile-expr*->list (cddddr rand*) r)])
(lambda (env)
($apply (op env) (r1 env) (r2 env) (r3 env) (r4 env)
(r* env))))]))])))
(define eval-top
(lambda (x)
(cond
[(and (pair? x) (eq? (car x) 'define) (not (top-level-bound? 'define)))
(unless (and (list? x) (fx= (length x) 3))
(error 'eval "invalid syntax ~s" x))
(let ([var (cadr x)] [val (caddr x)])
(unless (symbol? var) (error 'eval "invalid syntax ~s" x))
(let ([val (compile-expr val '())])
(set-top-level-value! var (val '()))))]
[(and (pair? x) (eq? (car x) 'begin) (not (top-level-bound? 'begin)))
(unless (list? x)
(error 'eval "invalid syntax ~s" x))
(letrec ([f
(lambda (x x*)
(if (null? x*)
(eval-top x)
(begin
(eval-top x)
(f (car x*) (cdr x*)))))])
(let ([d (cdr x)])
(unless (null? d)
(f (car d) (cdr d)))))]
[else
((compile-expr x '()) '())])))
($pcb-set! eval eval-top))
($pcb-set! current-eval
(make-parameter eval
(lambda (f)
(unless (procedure? f)
(error 'current-eval "not a procedure ~s" f))
f)))
(let ()
(define read-and-eval
(lambda (p)
(let ([x (read p)])
(unless (eof-object? x)
((current-eval) x)
(read-and-eval p)))))
($pcb-set! load
(lambda (x)
(unless (string? x)
(error 'load "~s is not a string" x))
(let ([p (open-input-file x)])
(read-and-eval p)
(close-input-port p)))))
#!eof
(define test-suite
(lambda (x)
(printf "performing ~a tests\n" (car x))
(for-each
(lambda (t)
(define x (car t))
(write x)
(newline)
(unless (equal? (caddr t) "")
(let ([v (eval x)] [w (interpret x)])
(unless (equal? v w)
(error #f "got ~s, should be ~s" v w)))))
(cdr x))))
(define test-file
(lambda (x)
(with-input-from-file x
(lambda ()
(let f ()
(let ([x (read)])
(unless (eof-object? x)
(test-suite (cdr x))
(f))))))))
(define fxadd1 (lambda (n) (fx+ n 1)))
(define fxsub1 (lambda (n) (fx- n 1)))
(define fixnum->char integer->char)
(define char->fixnum char->integer)
(define $apply apply)
(define char= char=?)
(define char< char<?)
(define char<= char<=?)
(define char> char>?)
(define char>= char>=?)
(for-each
test-file
'("tests-1.1-req.scm"
"tests-1.2-req.scm"
"tests-1.3-req.scm"
"tests-1.4-req.scm"
"tests-1.5-req.scm"
"tests-1.6-req.scm"
"tests-1.7-req.scm"
"tests-1.8-req.scm"
"tests-1.9-req.scm"
"tests-2.1-req.scm"
"tests-2.2-req.scm"
"tests-2.3-req.scm"
"tests-2.4-req.scm"
"tests-2.6-req.scm"
"tests-2.8-req.scm"
"tests-2.9-req.scm"
"tests-3.1-req.scm"
"tests-3.2-req.scm"
"tests-3.3-req.scm"
"tests-3.4-req.scm"
"tests-4.1-req.scm"
"tests-4.2-req.scm"
"tests-4.3-req.scm"))

644
src/libeval-5.3.ss
View File

@ -1,644 +0,0 @@
(let ()
(define verify-proper-lambda-bindings
(lambda (fml*)
(void)))
(define keyword?
(lambda (x)
(memq x
'(lambda let let* letrec letrec* if quote when unless
set! begin define or and cond case))))
(define self-evaluating?
(lambda (x)
(or (fixnum? x) (null? x) (boolean? x) (char? x) (string? x))))
(define extend-r
(lambda (fml* r)
(cons fml* r)))
(define classify
(lambda (fml* k)
(let f ([fml* fml*] [i 0])
(cond
[(null? fml*) (k i #t)]
[(pair? fml*) (f (cdr fml*) (fx+ i 1))]
[else (k i #f)]))))
(define compile-lambda-binder
(lambda (fml*)
(classify fml*
(lambda (len proper?)
(if proper?
(lambda (args)
(let ([v (make-vector len)])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(if (null? args)
v
(error 'apply
"incorrect number of args to procedure"))]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else (error 'apply "insufficient arguments")]))))
(lambda (args)
(let ([v (make-vector (fx+ len 1))])
(let f ([i 0] [args args])
(cond
[(fx= i len)
(vector-set! v i args)
v]
[(pair? args)
(vector-set! v i (car args))
(f (fx+ i 1) (cdr args))]
[else
(error 'apply "insufficient arguments")])))))))))
(define compile-lambda
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid function definition ~s" x))
(let ([fml* (car body)] [body* (cdr body)])
(verify-proper-lambda-bindings fml*)
(let ([r (extend-r fml* r)]
[ext (compile-lambda-binder fml*)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(lambda args
(body (cons (ext args) env)))))))))
(define compile-if
(lambda (body r x)
(unless (fx= (length body) 3)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr (cadr body) r)]
[altern (compile-expr (caddr body) r)])
(lambda (env)
(if (test env)
(conseq env)
(altern env))))))
(define compile-case
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid expression ~s" x))
(let ([v
(compile-expr (car body) r)]
[body
(compile-case-body (cdr body) r x)])
(lambda (env)
(body (v env) env)))))
(define compile-case-body
(lambda (cls* r x)
(cond
[(null? cls*) (error 'eval "empty body in ~s" x)]
[(null? (cdr cls*))
(compile-case-last-clause (car cls*) r x)]
[else
(compile-case-one-clause (car cls*) r x
(compile-case-body (cdr cls*) r x))])))
(define compile-case-last-clause
(lambda (cls r x)
(cond
[(and (pair? cls)
(eq? (car cls) 'else)
(special? 'else r))
(unless (and (list? cls) (fx>= (length cls) 2))
(error 'eval "invalid else clause in ~s" x))
(let ([body* (compile-expr*->last (cdr cls) r)])
(lambda (v env)
(body* env)))]
[else
(compile-case-one-clause cls r x
(lambda (v env) (void)))])))
(define compile-case-one-clause
(lambda (cls r x k)
(unless (and (list? cls)
(fx>= (length cls) 2)
(list? (car cls)))
(error 'eval "invalid case expression ~s" cls))
(let ([cases (car cls)]
[body (compile-expr*->last (cdr cls) r)])
(lambda (v env)
(if (memq v cases)
(body env)
(k v env))))))
(define compile-when
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[conseq (compile-expr*->last (cdr body) r)])
(lambda (env)
(when (test env)
(conseq env))))))
(define compile-unless
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([test (compile-expr (car body) r)]
[altern (compile-expr*->last (cdr body) r)])
(lambda (env)
(unless (test env)
(altern env))))))
(define compile-quote
(lambda (body x)
(unless (fx= (length body) 1)
(error 'eval "invalid quote expression ~s" x))
(let ([v (car body)])
(lambda (env) v))))
(define compile-form
(lambda (k body r x)
(cond
[(eq? k 'quote) (compile-quote body x)]
[(eq? k 'lambda) (compile-lambda body r x)]
[(eq? k 'let) (compile-let body r x)]
[(eq? k 'if) (compile-if body r x)]
[(eq? k 'let*) (compile-let* body r x)]
[(eq? k 'letrec) (compile-letrec body r x)]
[(eq? k 'letrec*) (compile-letrec* body r x)]
[(eq? k 'set!) (compile-assign body r x)]
[(eq? k 'begin) (compile-begin body r x)]
[(eq? k 'or) (compile-or body r x)]
[(eq? k 'and) (compile-and body r x)]
[(eq? k 'cond) (compile-cond body r x)]
[(eq? k 'case) (compile-case body r x)]
[(eq? k 'when) (compile-when body r x)]
[(eq? k 'unless) (compile-unless body r x)]
[(eq? k 'define)
(error 'eval "invalid definition in expression context in ~s" x)]
[else (error 'eval "unhandled keyword ~s" k)])))
(define compile-one-clause
(lambda (cls r x rest)
(unless (and (pair? cls) (list? cls))
(error 'eval "invalid cond clause ~s" cls))
(let ([len (length cls)])
(cond
[(fx= len 1)
(let ([q (compile-expr (car cls) r)])
(lambda (env)
(let ([t (q env)])
(if t t (rest env)))))]
[(and (fx= len 3) (eq? (cadr cls) '=>) (special? '=> r))
(let ([q (compile-expr (car cls) r)]
[f (compile-expr (caddr cls) r)])
(lambda (env)
(let ([t (q env)])
(if t ((f env) t) (rest env)))))]
[else
(let ([q (compile-expr (car cls) r)]
[d (compile-expr*->last (cdr cls) r)])
(lambda (env)
(if (q env)
(d env)
(rest env))))]))))
(define compile-last-cond-clause
(lambda (cls r x)
(unless (and (pair? cls) (list? cls))
(error 'eval "invalid syntax ~s" x))
(cond
[(and (eq? (car cls) 'else) (special? 'else r))
(when (null? (cdr cls))
(error 'eval "invalid syntax ~s" x))
(compile-expr*->last (cdr cls) r)]
[else
(compile-one-clause cls r x
(lambda (env) #f))])))
(define compile-cond
(lambda (cls* r x)
(cond
[(null? cls*) (lambda (env) #f)]
[(null? (cdr cls*))
(compile-last-cond-clause (car cls*) r x)]
[else
(compile-one-clause (car cls*) r x
(compile-cond (cdr cls*) r x))])))
(define compile-and
(lambda (ls r x)
(cond
[(null? ls) (lambda (env) #t)]
[(null? (cdr ls)) (compile-expr (car ls) r)]
[else
(let ([a (compile-expr (car ls) r)]
[d (compile-and (cdr ls) r x)])
(lambda (env)
(and (a env) (d env))))])))
(define compile-or
(lambda (ls r x)
(cond
[(null? ls) (lambda (env) #f)]
[(null? (cdr ls)) (compile-expr (car ls) r)]
[else
(let ([a (compile-expr (car ls) r)]
[d (compile-or (cdr ls) r x)])
(lambda (env)
(or (a env) (d env))))])))
(define compile-begin
(lambda (body r x)
(unless (pair? body) (error 'eval "invalid expression ~s" x))
(compile-expr*->last body r)))
(define compile-expr*->last
(lambda (body* r)
(let f ([a (car body*)] [d (cdr body*)])
(cond
[(null? d) (compile-expr a r)]
[else
(let ([a (compile-expr a r)])
(let ([d (compile-expr*->last d r)])
(lambda (env) (a env) (d env))))]))))
(define compile-expr*->assign
(lambda (body* r)
(let f ([i 0] [a (car body*)] [d (cdr body*)])
(cond
[(null? d)
(let ([v (compile-expr a r)])
(lambda (env)
(vector-set! (car env) i (v env))))]
[else
(let ([v (compile-expr a r)]
[d (f (fxadd1 i) (car d) (cdr d))])
(lambda (env)
(vector-set! (car env) i (v env))
(d env)))]))))
(define vector-assign!
(lambda (v i ls)
(unless (null? ls)
(vector-set! v i (car ls))
(vector-assign! v (fxadd1 i) (cdr ls)))))
(define build-letrec
(lambda (lhs* rhs* r body*)
(cond
[(null? lhs*) (compile-expr*->last body* r)]
[else
(let ([r (extend-r lhs* r)])
(let ([rhs* (compile-expr*->list rhs* r)]
[body (compile-expr*->last body* r)]
[n (length lhs*)]) ;?
(lambda (env)
(let ([v (make-vector n #f)])
(let ([env (cons v env)])
(vector-assign! v 0 (rhs* env))
(body env))))))])))
(define verify-bindings
(lambda (bind* x)
(unless (and (list? bind*)
(andmap
(lambda (x)
(and (list? x) (fx= (length x) 2) (symbol? (car x))))
bind*))
(error 'eval "invalid bindings in ~s" x))))
(define compile-letrec
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(build-letrec (map car bind*) (map cadr bind*) r body*))))
(define compile-letrec*
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(if (null? bind*)
(compile-internal body* r x)
(let ([r (extend-r (map car bind*) r)])
(let ([rhs* (compile-expr*->assign (map cadr bind*) r)])
(let ([body (compile-internal body* r x)]
[n (length bind*)])
(lambda (env)
(let ([env (cons (make-vector n #f) env)])
(rhs* env)
(body env))))))))))
(define compile-let
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(if (null? bind*)
(compile-internal body* r x)
(let ([rhs* (compile-expr*->list (map cadr bind*) r)])
(let ([r (extend-r (map car bind*) r)])
(let ([body (compile-internal body* r x)])
(lambda (env)
(body (cons (list->vector (rhs* env)) env))))))))))
(define compile-let*
(lambda (body r x)
(unless (fx>= (length body) 2)
(error 'eval "invalid syntax ~s" x))
(let ([bind* (car body)] [body* (cdr body)])
(verify-bindings bind* x)
(let f ([bind* bind*] [r r])
(cond
[(null? bind*) (compile-internal body* r x)]
[else
(let ([b (car bind*)])
(let ([lhs (car b)] [rhs (cadr b)])
(let ([rhs (compile-expr rhs r)])
(let ([r (extend-r (list lhs) r)])
(let ([rest (f (cdr bind*) r)])
(lambda (env)
(let ([env (cons (vector (rhs env)) env)])
(rest env))))))))])))))
(define compile-expr*->list
(lambda (expr* r)
(when (null? expr*)
(error 'eval "this should nto happen"))
(let f ([a (car expr*)] [d (cdr expr*)])
(cond
[(null? d)
(let ([a (compile-expr a r)])
(lambda (env)
(cons (a env) '())))]
[else
(let ([a (compile-expr a r)]
[d (f (car d) (cdr d))])
(lambda (env)
(cons (a env) (d env))))]))))
(define compile-internal-aux
(lambda (x* r x lhs* rhs*)
(when (null? x*)
(error 'eval "no body in ~s" x))
(let ([a (car x*)] [d (cdr x*)])
(cond
[(and (pair? a)
(eq? (car a) 'define)
(special? 'define r)
(not (memq 'define lhs*)))
(unless (and (list? a) (fx= (length a) 3))
(error 'eval "invalid syntax ~s" a))
(let ([lhs (cadr a)] [rhs (caddr a)])
(unless (symbol? lhs)
(error 'eval "invalid id ~s in ~s" lhs x))
(when (memq lhs lhs*)
(error 'eval "duplicate definition for ~s in ~s ~s" lhs lhs* x))
(compile-internal-aux d r x
(cons lhs lhs*) (cons rhs rhs*)))]
[(and (pair? a)
(eq? (car a) 'begin)
(special? 'begin r)
(not (memq 'begin lhs*)))
(let ([rest (cdr a)])
(unless (list? rest)
(error 'eval "invalid begin syntax ~s" a))
(compile-internal-aux (append rest d) r x lhs* rhs*))]
[else
(build-letrec (reverse lhs*) (reverse rhs*) r x*)]))))
(define special?
(lambda (x r)
(cond
[(top-level-bound? x) #f]
[(lookup x r) #f]
[else #t])))
(define compile-internal
(lambda (x* r x)
(compile-internal-aux x* r x '() '())))
(define lookup
(lambda (x r)
(let f ([r r] [i 0])
(cond
[(null? r) #f]
[else
(or (let f ([ls (car r)] [j 0])
(cond
[(null? ls) #f]
[(pair? ls)
(if (eq? (car ls) x)
(cons i j)
(f (cdr ls) (fx+ j 1)))]
[(eq? ls x) (cons i j)]
[else #f]))
(f (cdr r) (fx+ i 1)))]))))
(define compile-assign
(lambda (body r x)
(unless (fx= (length body) 2)
(error 'eval "invalid assignment ~s" x))
(unless (symbol? (car body))
(error 'eval "invalid syntax ~s" x))
(let ([val (compile-expr (cadr body) r)]
[var (car body)])
(cond
[(lookup var r) =>
(lambda (p)
(build-lexical-assignment p val))]
[(top-level-bound? var)
(lambda (env)
(set-top-level-value! var (val env)))]
[(keyword? var)
(error 'eval "invalid assignment to keyword in ~s" x)]
[else
(lambda (env)
(set-top-level-value! var (val env)))]))))
(define list-ref
(lambda (ls i)
(cond
[(null? ls) (error 'list-ref "index out of range")]
[(fxzero? i) (car ls)]
[else (list-ref (cdr ls) (fx- i 1))])))
(define build-lexical-assignment
(lambda (p val)
(lambda (env)
(vector-set! (list-ref env (car p)) (cdr p) (val env)))))
(define build-lexical-reference
(lambda (p)
(lambda (env)
(vector-ref (list-ref env (car p)) (cdr p)))))
(define compile-expr
(lambda (x r)
(cond
[(self-evaluating? x) (lambda (env) x)]
[(symbol? x)
(cond
[(lookup x r) => build-lexical-reference]
[(top-level-bound? x)
(lambda (env) (top-level-value x))]
[(keyword? x) (error 'eval "invalid reference to keyword ~s" x)]
[else
(lambda (env)
(if (top-level-bound? x)
(top-level-value x)
(error 'eval "reference to unbound variable ~s" x)))])]
[(not (list? x)) (error 'eval "invalid expression ~s" x)]
[(and (symbol? (car x)) (keyword? (car x)) (special? (car x) r))
(compile-form (car x) (cdr x) r x)]
[else
(let ([op (compile-expr (car x) r)]
[rand* (cdr x)]
[n (length (cdr x))])
(cond
[(fx= n 0)
(lambda (env) ((op env)))]
[(fx= n 1)
(let ([r1 (compile-expr (car rand*) r)])
(lambda (env)
((op env) (r1 env))))]
[(fx= n 2)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env))))]
[(fx= n 3)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env) (r3 env))))]
[(fx= n 4)
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)]
[r4 (compile-expr (cadddr rand*) r)])
(lambda (env)
((op env) (r1 env) (r2 env) (r3 env) (r4 env))))]
[else
(let ([r1 (compile-expr (car rand*) r)]
[r2 (compile-expr (cadr rand*) r)]
[r3 (compile-expr (caddr rand*) r)]
[r4 (compile-expr (cadddr rand*) r)]
[r* (compile-expr*->list (cddddr rand*) r)])
(lambda (env)
($apply (op env) (r1 env) (r2 env) (r3 env) (r4 env)
(r* env))))]))])))
(define eval-top
(lambda (x)
(cond
[(and (pair? x) (eq? (car x) 'define) (not (top-level-bound? 'define)))
(unless (and (list? x) (fx= (length x) 3))
(error 'eval "invalid syntax ~s" x))
(let ([var (cadr x)] [val (caddr x)])
(unless (symbol? var) (error 'eval "invalid syntax ~s" x))
(let ([val (compile-expr val '())])
(set-top-level-value! var (val '()))))]
[(and (pair? x) (eq? (car x) 'begin) (not (top-level-bound? 'begin)))
(unless (list? x)
(error 'eval "invalid syntax ~s" x))
(letrec ([f
(lambda (x x*)
(if (null? x*)
(eval-top x)
(begin
(eval-top x)
(f (car x*) (cdr x*)))))])
(let ([d (cdr x)])
(unless (null? d)
(f (car d) (cdr d)))))]
[(and (pair? x)
(eq? (car x) 'trace)
(not (top-level-bound? 'trace)))
(unless (list? x)
(error 'eval "invalid syntax ~s" x))
(let ([s* (cdr x)])
(unless (andmap symbol? s*)
(error 'eval "invalid syntax ~s" x))
(for-each trace-symbol! s*))]
[(and (pair? x)
(eq? (car x) 'untrace)
(not (top-level-bound? 'untrace)))
(unless (list? x)
(error 'eval "invalid syntax ~s" x))
(let ([s* (cdr x)])
(unless (andmap symbol? s*)
(error 'eval "invalid syntax ~s" x))
(for-each untrace-symbol! s*))]
[else
((compile-expr x '()) '())])))
(define eval
(lambda (x)
(if (and (list? x)
(fx= (length x) 2)
(string? (car x))
(string=? (car x) "noexpand"))
(eval-top (cadr x))
(eval-top ((current-expand) x)))))
($pcb-set! eval eval))
($pcb-set! current-expand
(make-parameter
(lambda (x) x)
(lambda (f)
(unless (procedure? f)
(error 'current-expand "~s is not a procedure" f))
f)))
($pcb-set! current-eval
(make-parameter eval
(lambda (f)
(unless (procedure? f)
(error 'current-eval "not a procedure ~s" f))
f)))
(let ()
(define read-and-eval
(lambda (p)
(let ([x (read p)])
(unless (eof-object? x)
((current-eval) x)
(read-and-eval p)))))
($pcb-set! load
(lambda (x)
(unless (string? x)
(error 'load "~s is not a string" x))
(let ([p (open-input-file x)])
(read-and-eval p)
(close-input-port p)))))
#!eof
(define test-suite
(lambda (x)
(printf "performing ~a tests\n" (car x))
(for-each
(lambda (t)
(define x (car t))
(write x)
(newline)
(unless (equal? (caddr t) "")
(let ([v (eval x)] [w (interpret x)])
(unless (equal? v w)
(error #f "got ~s, should be ~s" v w)))))
(cdr x))))
(define test-file
(lambda (x)
(with-input-from-file x
(lambda ()
(let f ()
(let ([x (read)])
(unless (eof-object? x)
(test-suite (cdr x))
(f))))))))
(define fxadd1 (lambda (n) (fx+ n 1)))
(define fxsub1 (lambda (n) (fx- n 1)))
(define fixnum->char integer->char)
(define char->fixnum char->integer)
(define $apply apply)
(define char= char=?)
(define char< char<?)
(define char<= char<=?)
(define char> char>?)
(define char>= char>=?)
(for-each
test-file
'("tests-1.1-req.scm"
"tests-1.2-req.scm"
"tests-1.3-req.scm"
"tests-1.4-req.scm"
"tests-1.5-req.scm"
"tests-1.6-req.scm"
"tests-1.7-req.scm"
"tests-1.8-req.scm"
"tests-1.9-req.scm"
"tests-2.1-req.scm"
"tests-2.2-req.scm"
"tests-2.3-req.scm"
"tests-2.4-req.scm"
"tests-2.6-req.scm"
"tests-2.8-req.scm"
"tests-2.9-req.scm"
"tests-3.1-req.scm"
"tests-3.2-req.scm"
"tests-3.3-req.scm"
"tests-3.4-req.scm"
"tests-4.1-req.scm"
"tests-4.2-req.scm"
"tests-4.3-req.scm"))

663
src/libexpand-5.6.ss
View File

@ -1,663 +0,0 @@
;;; Extended: cond case
;;;
;;;
;;; Expand : Scheme -> Core Scheme
;;;
;;; <CS> ::= (quote datum)
;;; | <gensym>
;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...)
;;; | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
;;; | (lambda <FMLS> <CS> <CS> ...)
;;; | (<prim> <CS> <CS> ...)
;;; | (<CS> <CS> ...)
;;; <FML> ::= ()
;;; | <gensym>
;;; | (<gensym> . <FML>)
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
;;; | $pcb-set! | foreign-call | $apply
;;;
;;;
;;; Handled keywords:
;;; Core: lambda set! if quote begin define
;;; Extended: let let* letrec letrec* when unless or and cond case
(let ()
(define *keyword* (gensym "*keyword*"))
(define build-void
(lambda ()
'(void)))
(define build-primref
(lambda (x)
x))
(define build-global-assignment
(lambda (x val)