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

imported compiler5

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:48:14 -05:00
parent 3815bebb4c
commit 1101ba6edb
102 changed files with 4809 additions and 40922 deletions
.bzrignore
src
assembler-tests.ssbuild-date.tmpchez-compat.sscompiler-6.0.sscompiler-6.1.sscompiler-6.2.sscompiler-6.3.sscompiler-6.4.sscompiler-6.5.sscompiler-6.6.sscompiler-6.7.sscompiler-6.8.sscompiler-8.1.sscompiler-9.0.sscompiler-9.1.sscompiler-9.2.ssfact.ssgenerate-cxr.ss
geninstr
gen.pltmp.dumptmp.s
ikarus.fasllibassembler-compat-6.0.sslibassembler-compat-6.6.sslibassembler-compat-6.7.sslibassembler-compat.sslibassembler.sslibcafe-6.0.sslibcafe-6.1.sslibcafe.fasllibchezio-8.1.sslibcollect-6.0.sslibcollect.fasllibcompile-6.4.sslibcompile-6.5.sslibcompile-8.1.sslibcompile-9.0.sslibcompile-9.1.sslibcontrol-6.0.sslibcontrol.fasllibcore-6.0.sslibcore-6.1.sslibcore-6.2.sslibcore-6.9.sslibcore.fasllibcxr.fasllibexpand-6.0.sslibexpand-6.1.sslibexpand-6.2.sslibfasl-6.0.sslibfasl-6.6.sslibhandlers-6.0.sslibhandlers.fasllibhash-6.2.sslibhash-9.2.sslibintelasm-6.0.sslibintelasm-6.4.sslibintelasm-6.6.sslibintelasm-6.9.sslibinterpret-6.0.sslibinterpret-6.1.sslibinterpret.fasllibio-6.0.sslibio-6.1.sslibio-6.9.sslibio.fasllibnumerics-7.1.sslibnumerics-9.1.sslibrecord-6.0.sslibrecord-6.1.sslibrecord.fasllibtokenizer-6.1.sslibtokenizer-9.0.sslibtokenizer-9.1.sslibtokenizer.fasllibtoplevel-6.0.sslibtoplevel.fasllibwriter-6.2.sslibwriter-9.0.sslibwriter-9.1.sslibwriter.faslmakepp.sspsyntax-7.1-6.9.sspsyntax-7.1-9.0.sspsyntax-7.1-9.1.sspsyntax-7.1.ssrecord-case.chez.ss
runtime
Makefileikarusikarus-collect.cikarus-data.hikarus-fasl.cikarus-main.cikarus-numerics.cikarus-runtime.cikarus-symbol-table.cikarus.htags.txt
test.ss
Show More

1
.bzrignore
View File

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

756
src/assembler-tests.ss
View File

@ -1,756 +0,0 @@
(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 #t)
(define passed-tests 0)
(define all-tests 0)
(define test-code
(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)))]
[v (eval-code code)])
(when verbose (printf "evaluated\n"))
(cond
[(equal? v val)
(set! passed-tests (fxadd1 passed-tests))
(when verbose (printf "OK\n"))]
[else
(error 'test-code
"expected ~s, got ~s" val v)]))))
(printf "testing ... \n")
(test-code
'([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])
10)
(test-code
'([movl (obj 40) %eax]
[ret])
40)
(test-code
'([movl (obj 40) %ebx]
[movl %ebx %eax]
[ret])
40)
(test-code
'([movl (obj (1 2 3)) %eax]
[ret])
'(1 2 3))
(test-code
'([movl (obj (1 2 3)) %ebx]
[movl (disp (int -1) %ebx) %eax]
[ret])
'1)
(test-code
'([movl (obj (1 2 3)) %ebx]
[movl (disp (int 3) %ebx) %eax]
[ret])
'(2 3))
(test-code
'([movl (obj (1 2 3)) %ebx]
[movl (int 120) %eax]
[movl %eax (disp (int 3) %ebx)]
[movl %ebx %eax]
[ret])
'(1 . 30))
(test-code
'([movl (obj (1 2 3)) %eax]
[movl (int 120) (disp (int -1) %eax)]
[ret])
'(30 2 3))
(test-code
'([movl (obj (1 2 3)) %eax]
[movl (int 120000) (disp (int -1) %eax)]
[ret])
'(30000 2 3))
(test-code
'([movl (int 40) %eax]
[addl (int 80) %eax]
[ret])
30)
(test-code
'([movl (int 40) %eax]
[addl (obj 20) %eax]
[ret])
30)
(test-code
'([movl (int 40) %eax]
[movl (obj 20) %ebx]
[addl %ebx %eax]
[ret])
30)
(test-code
'([movl (obj (1 2 3)) %eax]
[movl (obj 10) %ebx]
[addl (disp (int -1) %eax) %ebx]
[movl %ebx %eax]
[ret])
'11)
(test-code
'([movl (obj (1 2 3)) %eax]
[addl (int 1000) %eax]
[movl (obj 10) %ebx]
[addl (disp (int -1001) %eax) %ebx]
[movl %ebx %eax]
[ret])
'11)
(test-code
'([movl (obj 10) %eax]
[sall (int 1) %eax]
[ret])
20)
(test-code
'([movl (obj 10) %eax]
[sall (int 3) %eax]
[ret])
80)
(test-code
'([movl (obj 10) %eax]
[movl (int 3) %ecx]
[sall %cl %eax]
[ret])
80)
(test-code
'([movl (obj #xF0) %eax]
[sarl (int 1) %eax]
[ret])
#x78)
(test-code
'([movl (obj #xF0) %eax]
[sarl (int 4) %eax]
[ret])
#x0F)
(test-code
'([movl (obj #xF0) %eax]
[movl (int 4) %ecx]
[sarl %cl %eax]
[ret])
#x0F)
(test-code
'([movl (obj #xFFFF) %eax]
[andl (obj #xF0F0) %eax]
[ret])
#xF0F0)
(test-code
'([movl (obj #xFFFF) %eax]
[movl (obj #x7654) %ebx]
[andl %ebx %eax]
[ret])
#x7654)
(test-code
'([movl (obj #xFFFF) %eax]
[andl (int #x3F) %eax]
[ret])
#xF)
(test-code
'([movl (obj #xFFFF) %eax]
[movl (obj (#xF707F)) %ebx]
[andl (disp (int -1) %ebx) %eax]
[ret])
#x707F)
(test-code
'([movl (obj #xFFFF) %eax]
[movl (obj (#xF707F)) %ebx]
[addl (int 1000) %ebx]
[andl (disp (int -1001) %ebx) %eax]
[ret])
#x707F)
(test-code
'([movl (int 3) %eax]
[notl %eax]
[ret])
-1)
(test-code
'([movl (obj 1942) %eax]
[negl %eax]
[ret])
-1942)
(test-code
'([movl (obj 10) %eax]
[jmp (int 10)]
[byte 0]
[byte 1]
[byte 2]
[byte 3]
[byte 4]
[byte 5]
[byte 6]
[byte 7]
[byte 8]
[byte 9]
[ret])
10)
(test-code
'([movl (obj 10) %eax]
[jmp (int 10)]
[byte 0]
[byte 1]
[byte 2]
[byte 3]
[byte 4]
[byte 5]
[ret]
[byte 7]
[byte 8]
[byte 9]
[jmp (int -9)])
10)
(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))
(let ([L2 (gensym)]
[L3 (gensym)])
(test-code
`([movl (obj 10) %eax]
[jmp (label ,L2)]
[byte 0]
[byte 1]
[byte 2]
[byte 3]
[byte 4]
[byte 5]
[label ,L3]
[ret]
[byte 7]
[byte 8]
[byte 9]
[label ,L2]
[jmp (label ,L3)])
10))
(test-code
'([movl (obj 10) (disp (int -4) %esp)]
[movl (obj list) %eax]
[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 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]
[imull (int 3) %eax]
[ret])
30)
(test-code
'([movl (obj 10) %eax]
[imull (obj 10) %eax]
[ret])
400)
(test-code
'([movl (obj 10) %eax]
[movl (obj 20) %ebx]
[imull %ebx %eax]
[ret])
800)
(test-code
'([movl (obj 10) %eax]
[movl (obj 20) (disp (int -4) %esp)]
[imull (disp (int -4) %esp) %eax]
[ret])
800)
(test-code
'([movl (obj 10) %eax]
[cltd]
[ret])
10)
(test-code
'([movl (obj 10) %eax]
[movl (obj 100) %edx]
[cltd]
[movl %edx %eax]
[ret])
0)
(test-code
'([movl (obj -10) %eax]
[movl (obj 100) %edx]
[cltd]
[movl %edx %eax]
[sall (int 2) %eax]
[ret])
-1)
(let ([L1 (gensym)])
(test-code
`([movl (int 10) %eax]
[cmpl (int 8) %eax]
[jne (label ,L1)]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj 1) %eax]
[ret])
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 40) %eax]
[cmpl (obj 10) %eax]
[je (label ,L1)]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj 1) %eax]
[ret])
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 40) %eax]
[movl (int 30) %ebx]
[cmpl %ebx %eax]
[jge (label ,L1)]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj 1) %eax]
[ret])
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 0) %eax]
[ret]
[label ,L1]
[movl (obj 1) %eax]
[ret])
1))
(test-code
'([movl (int 40) (disp (int -4) %esp)]
[addl (int 10) %esp]
[movl (disp (int -14) %esp) %eax]
[addl (int -10) %esp]
[ret])
10)
(test-code
'([movl (int 40) (disp (int -4) %esp)]
[addl (int 1000) %esp]
[movl (disp (int -1004) %esp) %eax]
[addl (int -1000) %esp]
[ret])
10)
(let ([L1 (gensym)])
(test-code
`([movl (int 40) (disp (int -4) %esp)]
[addl (int 1000) %esp]
[cmpl (int 70) (disp (int -1004) %esp)]
[jle (label ,L1)]
[addl (int -1000) %esp]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[addl (int -1000) %esp]
[movl (obj 1) %eax]
[ret])
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 4000) (disp (int -4) %esp)]
[addl (int 1000) %esp]
[cmpl (int 7000) (disp (int -1004) %esp)]
[jle (label ,L1)]
[addl (int -1000) %esp]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[addl (int -1000) %esp]
[movl (obj 1) %eax]
[ret])
1))
(let ([L1 (gensym)])
(test-code
`([movl (int 40) (disp (int -4) %esp)]
[movl (int 70) %ebx]
[cmpl (disp (int -4) %esp) %ebx]
[jge (label ,L1)]
[movl (obj 0) %eax]
[ret]
[label ,L1]
[movl (obj 1) %eax]
[ret])
1))
(let ([L_fact (gensym)] [L1 (gensym)])
(test-code
`([movl (int 5) %eax]
[call (label ,L_fact)]
[sall (int 2) %eax]
[ret]
[label ,L_fact]
[cmpl (int 0) %eax]
[jne (label ,L1)]
[movl (int 1) %eax]
[ret]
[label ,L1]
[movl %eax (disp (int -4) %esp)]
[addl (int -4) %esp]
[addl (int -1) %eax]
[call (label ,L_fact)]
[addl (int 4) %esp]
[imull (disp (int -4) %esp) %eax]
[ret])
120))
(test-code
'([movl (int 16) %eax]
[cltd]
[movl (int 4) %ebx]
[idivl %ebx]
[ret])
1)
(test-code
'([movl (int 16) %eax]
[cltd]
[movl (obj (1)) %ebx]
[idivl (disp (int -1) %ebx)]
[ret])
1)
(test-code
'([movl (int 16) %eax]
[cltd]
[movl (int 4) (disp (int -4) %esp)]
[idivl (disp (int -4) %esp)]
[ret])
1)
(test-code
'([movl (int #x30) %ebx]
[orl (int #x4) %ebx]
[movl %ebx %eax]
[ret])
(fxsra #x34 2))
(test-code
'([movl (int #x30) %eax]
[orl (int #x4) %eax]
[ret])
(fxsra #x34 2))
(test-code
'([movl (int #x30) %eax]
[orl (obj #x1) %eax]
[ret])
(fxsra #x34 2))
(test-code
'([movl (int #x30) %ebx]
[orl (obj #x1) %ebx]
[movl %ebx %eax]
[ret])
(fxsra #x34 2))
(test-code
'([movl (obj (#xC)) %ebx]
[movl (int #x4) %eax]
[orl (disp (int -1) %ebx) %eax]
[ret])
(fxsra #x34 2))
(test-code
'([movl (int #x30) (disp (int -4) %esp)]
[movl (int #x4) %eax]
[orl (disp (int -4) %esp) %eax]
[ret])
(fxsra #x34 2))
(test-code
'([pushl (int 8)]
[movl (disp (int 0) %esp) %eax]
[addl (int 4) %esp]
[ret])
2)
(test-code
'([pushl (int 8000)]
[movl (disp (int 0) %esp) %eax]
[addl (int 4) %esp]
[ret])
2000)
(test-code
'([movl (int 8000) %ebx]
[pushl %ebx]
[movl (disp (int 0) %esp) %eax]
[addl (int 4) %esp]
[ret])
2000)
(test-code
'([movl (obj (1 2 3)) %eax]
[pushl (disp (int 3) %eax)]
[addl (int 4) %esp]
[movl (disp (int -4) %esp) %eax]
[ret])
'(2 3))
(test-code
'([movl (obj (1 2 3)) %eax]
[addl (int -1000) %eax]
[pushl (disp (int 1003) %eax)]
[addl (int 4) %esp]
[movl (disp (int -4) %esp) %eax]
[ret])
'(2 3))
(test-code
'([pushl (obj 100)]
[popl %eax]
[ret])
100)
(test-code
'([pushl (obj 100)]
[popl (disp (int -32) %esp)]
[movl (disp (int -32) %esp) %eax]
[ret])
100)
(test-code
'([movl (int 4) %eax]
[cmpl (int 5) %eax]
[sete %al]
[andl (int 1) %eax]
[sall (int 2) %eax]
[ret])
0)
(test-code
'([movl (int 4) %eax]
[cmpl (int 5) %eax]
[setle %al]
[andl (int 1) %eax]
[sall (int 2) %eax]
[ret])
1)
(test-code
'([movl (obj+ (1 2 3) 3) %eax]
[movl (disp (int 0) %eax) %eax]
[ret])
'(2 3))
(let ([L_entry (gensym)] [L_no (gensym)])
(test-code
`([movl (obj 10) %eax]
[ret]
[label ,L_entry]
[cmpl (int 1) %eax]
[jne (label ,L_no)]
[movl (obj foo) %eax]
[ret]
[label ,L_no]
[movl (obj bar) %eax]
[ret])
10)
(test-code
`([movl (int 1) %eax]
[jmp (label ,L_entry)])
'foo)
(test-code
`([movl (int 0) %eax]
[jmp (label ,L_entry)])
'bar))
(printf "Passed ~s/~s tests in assembler\n" passed-tests all-tests)
)

2
src/build-date.tmp
View File

@ -1 +1 @@
2006-08-22
2006-08-25

57
src/chez-compat.ss
View File

@ -1,57 +0,0 @@
(define-syntax $pcb-set!
(syntax-rules ()
[(_ 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 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 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 char= char=?)
(set! $base-rtd #%$base-rtd)
(define-syntax |#primitive|
(syntax-rules ()
[(_ n prim) prim]
[(_ prim) prim]))
(define (date-string)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char=? x #\newline)
'()
(cons x (f))))))))
(define ($record rtd . args)
(apply (record-constructor rtd) args))
(define ($record/rtd? x rtd)
(and (record? x) (eq? (record-type-descriptor x) rtd)))
(define ($record-ref x i)
((record-field-accessor (record-type-descriptor x) i) x))
(define ($record-set! x i v)
((record-field-mutator (record-type-descriptor x) i) x v))

3890
src/compiler-6.0.ss
View File

File diff suppressed because it is too large Load Diff

3132
src/compiler-6.1.ss
View File

File diff suppressed because it is too large Load Diff

3185
src/compiler-6.2.ss
View File

File diff suppressed because it is too large Load Diff

3199
src/compiler-6.3.ss
View File

File diff suppressed because it is too large Load Diff

98
src/compiler-6.4.ss
View File

@ -1,98 +0,0 @@
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!)
(set! chez-expand sc-expand)
(set! chez-current-expand current-expand)
(set! $base-rtd (eval '#%$base-rtd))
; (set! $base-rtd #%$base-rtd)
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1.ss")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "ok\n")
(load "libassembler-compat-6.0.ss") ; defines make-code etc.
(load "libintelasm-6.0.ss") ; uses make-code, etc.
(load "libfasl-6.0.ss") ; uses code? etc.
(load "libcompile-6.4.ss") ; uses fasl-write
)
(define scheme-library-files
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.2.ss" "libcore.fasl"]
["libio-6.1.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-compat-6.0.ss" "libassembler-compat.ss"]
["libintelasm-6.4.ss" "libintelasm.fasl"]
["libfasl-6.0.ss" "libfasl.fasl"]
["libcompile-6.4.ss" "libcompile.fasl"]
["psyntax-7.1.ss" "psyntax.fasl"]
["libinterpret-6.1.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
))
(define (compile-library ifile ofile)
(parameterize ([assembler-output #f] [expand-mode 'bootstrap])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
scheme-library-files)
(system "rm -f ikarus.fasl")
(for-each
(lambda (x)
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
scheme-library-files)
(define (get-date)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char=? x #\newline)
'()
(cons x (f))))))))
(with-output-to-file "petite-ikarus.ss"
(lambda ()
(write
`(begin
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(new-cafe))))
'replace)
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")

96
src/compiler-6.5.ss
View File

@ -1,96 +0,0 @@
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!)
(set! chez-expand sc-expand)
(set! chez-current-expand current-expand)
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1-6.5.ss")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "ok\n")
(load "libassembler-compat-6.0.ss") ; defines make-code etc.
(load "libintelasm-6.0.ss") ; uses make-code, etc.
(load "libfasl-6.0.ss") ; uses code? etc.
(load "libcompile-6.5.ss") ; uses fasl-write
)
(define scheme-library-files
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.2.ss" "libcore.fasl"]
["libio-6.1.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-compat-6.0.ss" "libassembler-compat.ss"]
["libintelasm-6.4.ss" "libintelasm.fasl"]
["libfasl-6.0.ss" "libfasl.fasl"]
["libcompile-6.5.ss" "libcompile.fasl"]
["psyntax-7.1-6.5.ss" "psyntax.fasl"]
["libinterpret-6.5.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
))
(define (compile-library ifile ofile)
(parameterize ([assembler-output #f] [expand-mode 'bootstrap])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
scheme-library-files)
(system "rm -f ikarus.fasl")
(for-each
(lambda (x)
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
scheme-library-files)
(define (get-date)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char=? x #\newline)
'()
(cons x (f))))))))
(with-output-to-file "petite-ikarus.ss"
(lambda ()
(write
`(begin
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(new-cafe))))
'replace)
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")

97
src/compiler-6.6.ss
View File

@ -1,97 +0,0 @@
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!)
(set! chez-expand sc-expand)
(set! chez-current-expand current-expand)
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1-6.5.ss")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "ok\n")
(load "libassembler-compat-6.6.ss") ; defines make-code etc.
(load "libintelasm-6.6.ss") ; uses make-code, etc.
(load "libfasl-6.6.ss") ; uses code? etc.
(load "libcompile-6.6.ss") ; uses fasl-write
)
(define scheme-library-files
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.2.ss" "libcore.fasl"]
["libio-6.1.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-compat-6.6.ss" "libassembler-compat.ss"]
["libintelasm-6.6.ss" "libintelasm.fasl"]
["libfasl-6.6.ss" "libfasl.fasl"]
["libcompile-6.6.ss" "libcompile.fasl"]
["psyntax-7.1-6.5.ss" "psyntax.fasl"]
["libinterpret-6.5.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
))
(define (compile-library ifile ofile)
(parameterize ([assembler-output #f] [expand-mode 'bootstrap])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
scheme-library-files)
(system "rm -f ikarus.fasl")
(for-each
(lambda (x)
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
scheme-library-files)
(define (get-date)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char=? x #\newline)
'()
(cons x (f))))))))
(with-output-to-file "petite-ikarus.ss"
(lambda ()
(write
`(begin
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(new-cafe))))
'replace)
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")

98
src/compiler-6.7.ss
View File

@ -1,98 +0,0 @@
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!)
(set! chez-expand sc-expand)
(set! chez-current-expand current-expand)
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1-6.5.ss")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "ok\n")
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
(load "libintelasm-6.6.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.ss") ; uses fasl-write
)
(define scheme-library-files
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.2.ss" "libcore.fasl"]
["libio-6.1.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-6.7.ss" "libassembler.ss"]
["libintelasm-6.6.ss" "libintelasm.fasl"]
["libfasl-6.7.ss" "libfasl.fasl"]
["libcompile-6.7.ss" "libcompile.fasl"]
["psyntax-7.1-6.5.ss" "psyntax.fasl"]
["libinterpret-6.5.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
))
(define (compile-library ifile ofile)
(parameterize ([assembler-output #f]
[expand-mode 'bootstrap])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
scheme-library-files)
(system "rm -f ikarus.fasl")
(for-each
(lambda (x)
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
scheme-library-files)
(define (get-date)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char=? x #\newline)
'()
(cons x (f))))))))
(with-output-to-file "petite-ikarus.ss"
(lambda ()
(write
`(begin
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(new-cafe))))
'replace)
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")

98
src/compiler-6.8.ss
View File

@ -1,98 +0,0 @@
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!)
(set! chez-expand sc-expand)
(set! chez-current-expand current-expand)
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1-6.5.ss")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "ok\n")
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
(load "libintelasm-6.6.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.ss") ; uses fasl-write
)
(define scheme-library-files
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.2.ss" "libcore.fasl"]
["libio-6.1.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-6.7.ss" "libassembler.ss"]
["libintelasm-6.6.ss" "libintelasm.fasl"]
["libfasl-6.7.ss" "libfasl.fasl"]
["libcompile-6.7.ss" "libcompile.fasl"]
["psyntax-7.1-6.8.ss" "psyntax.fasl"]
["libinterpret-6.5.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
; ["libtrace-5.3.ss" "libtrace-5.3.s" "libtrace" ]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.0.ss" "libtoplevel.fasl"]
))
(define (compile-library ifile ofile)
(parameterize ([assembler-output #f]
[expand-mode 'bootstrap])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
scheme-library-files)
(system "rm -f ikarus.fasl")
(for-each
(lambda (x)
(system (format "cat ~a >> ikarus.fasl" (cadr x))))
scheme-library-files)
(define (get-date)
(system "date +\"%F\" > build-date.tmp")
(let ([ip (open-input-file "build-date.tmp")])
(list->string
(let f ()
(let ([x (read-char ip)])
(if (char=? x #\newline)
'()
(cons x (f))))))))
(with-output-to-file "petite-ikarus.ss"
(lambda ()
(write
`(begin
(display ,(format "Petite Ikarus Scheme (Build ~a)\n" (get-date)))
(display "Copyright (c) 2006 Abdulaziz Ghuloum\n\n")
(new-cafe))))
'replace)
(compile-library "petite-ikarus.ss" "petite-ikarus.fasl")

17
src/compiler-8.1.ss
View File

@ -100,11 +100,11 @@
console-input-port current-input-port
standard-output-port standard-error-port
console-output-port current-output-port
open-output-file
open-output-file open-input-file
open-output-string get-output-string
with-output-to-file call-with-output-file
with-input-from-file call-with-input-file
date-string
))
@ -137,11 +137,13 @@
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
fixnum->string
vector-memq vector-memv
;;; must open-code
$make-port
$make-port/input
$make-port/output
$make-port/both
$make-input-port $make-output-port $make-input/output-port
$port-handler
$port-input-buffer $port-input-index $port-input-size
@ -179,7 +181,7 @@
`(begin
(define-syntax compile-time-date-string
(lambda (x)
#'(quote ,(#%date-string))))
#'(quote ,(date-string))))
(define-syntax public-primitives
(lambda (x)
#'(quote ,public-primitives)))
@ -220,7 +222,7 @@
(whack-system-env #t)
(printf "ok\n")
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
(load "libintelasm-6.6.ss") ; uses make-code, etc.
(load "libintelasm-6.9.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-8.1.ss") ; uses fasl-write
)
@ -258,8 +260,7 @@
[expand-mode 'bootstrap]
[interaction-environment system-env])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)
(printf "done\n")))
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)

108
src/compiler-6.9.ss → src/compiler-9.0.ss
View File

@ -1,6 +1,6 @@
;;;
;;; 8.1: * using chez-style io ports
;;; 6.9: * creating a *system* environment
;;; 6.8: * creating a core-primitive form in the expander
;;; 6.2: * side-effects now modify the dirty-vector
@ -63,16 +63,7 @@
gensym->unique-string
call-with-values values
make-parameter dynamic-wind
output-port? current-output-port standard-output-port console-output-port
open-output-file close-output-port flush-output-port output-port-name
with-output-to-file with-input-from-file
input-port? current-input-port standard-input-port console-input-port
reset-input-port!
open-input-file close-input-port input-port-name
standard-error-port
open-output-string get-output-string
newline write-char peek-char read-char unread-char
display write fasl-write printf format print-error
display write print-graph fasl-write printf format print-error
read-token read
error exit call/cc
current-error-handler
@ -93,6 +84,28 @@
assembler-output
$make-environment
features
port? input-port? output-port?
make-input-port make-output-port make-input/output-port
port-handler
port-input-buffer port-input-index port-input-size
port-output-buffer port-output-index port-output-size
set-port-input-index! set-port-input-size!
set-port-output-index! set-port-output-size!
port-name input-port-name output-port-name
write-char read-char unread-char peek-char
newline
reset-input-port! flush-output-port
close-input-port close-output-port
console-input-port current-input-port
standard-output-port standard-error-port
console-output-port current-output-port
open-output-file open-input-file
open-output-string get-output-string
with-output-to-file call-with-output-file
with-input-from-file call-with-input-file
date-string
))
(define system-primitives
@ -124,8 +137,28 @@
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
fixnum->string
vector-memq vector-memv
;;; must open-code
$make-port/input
$make-port/output
$make-port/both
$make-input-port $make-output-port $make-input/output-port
$port-handler
$port-input-buffer $port-input-index $port-input-size
$port-output-buffer $port-output-index $port-output-size
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size!
;;; better open-code
$write-char $read-char $peek-char $unread-char
;;; never open-code
$reset-input-port! $close-input-port
$close-output-port $flush-output-port
*standard-output-port* *standard-error-port* *current-output-port*
*standard-input-port* *current-input-port*
))
@ -148,7 +181,7 @@
`(begin
(define-syntax compile-time-date-string
(lambda (x)
#'(quote ,(#%date-string))))
#'(quote ,(date-string))))
(define-syntax public-primitives
(lambda (x)
#'(quote ,public-primitives)))
@ -189,35 +222,35 @@
(whack-system-env #t)
(printf "ok\n")
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
(load "libintelasm-6.6.ss") ; uses make-code, etc.
(load "libintelasm-6.9.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.ss") ; uses fasl-write
(load "libcompile-8.1.ss") ; uses fasl-write
)
(whack-system-env #t)
(define scheme-library-files
'(["libhandlers-6.9.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.9.ss" "libcore.fasl"]
["libio-6.9.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-6.7.ss" "libassembler.ss"]
["libintelasm-6.9.ss" "libintelasm.fasl"]
["libfasl-6.7.ss" "libfasl.fasl"]
["libcompile-6.7.ss" "libcompile.fasl"]
["psyntax-7.1-6.9.ss" "psyntax.fasl"]
["libinterpret-6.5.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
["libtrace-6.9.ss" "libtrace.fasl"]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.9.ss" "libtoplevel.fasl"]
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
["libcollect-6.1.ss" #t "libcollect.fasl"]
["librecord-6.4.ss" #t "librecord.fasl"]
["libcxr-6.0.ss" #t "libcxr.fasl"]
["libcore-6.9.ss" #t "libcore.fasl"]
["libchezio-8.1.ss" #t "libchezio.fasl"]
["libhash-6.2.ss" #t "libhash.fasl"]
["libwriter-9.0.ss" #t "libwriter.fasl"]
["libtokenizer-9.0.ss" #t "libtokenizer.fasl"]
["libassembler-6.7.ss" #t "libassembler.ss"]
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
["libfasl-6.7.ss" #t "libfasl.fasl"]
["libcompile-9.0.ss" #t "libcompile.fasl"]
["psyntax-7.1-9.0.ss" #t "psyntax.fasl"]
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
["libcafe-6.1.ss" #t "libcafe.fasl"]
["libtrace-6.9.ss" #t "libtrace.fasl"]
["libposix-6.0.ss" #t "libposix.fasl"]
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
))
@ -231,7 +264,8 @@
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
(when (cadr x)
(compile-library (car x) (caddr x))))
scheme-library-files)
@ -253,4 +287,4 @@
(system
(format "cat ~a > ikarus.fasl"
(join " " (map cadr scheme-library-files))))
(join " " (map caddr scheme-library-files))))

114
src/compiler-8.0.ss → src/compiler-9.1.ss
View File

@ -1,6 +1,9 @@
;;;
;;; 9.1: * starting with libnumerics
;;; 9.0: * graph marks for both reader and writer
;;; * circularity detection during read
;;; 8.1: * using chez-style io ports
;;; 6.9: * creating a *system* environment
;;; 6.8: * creating a core-primitive form in the expander
;;; 6.2: * side-effects now modify the dirty-vector
@ -63,16 +66,7 @@
gensym->unique-string
call-with-values values
make-parameter dynamic-wind
output-port? current-output-port standard-output-port console-output-port
open-output-file close-output-port flush-output-port output-port-name
with-output-to-file with-input-from-file
input-port? current-input-port standard-input-port console-input-port
reset-input-port!
open-input-file close-input-port input-port-name
standard-error-port
open-output-string get-output-string
newline write-char peek-char read-char unread-char
display write fasl-write printf format print-error
display write print-graph fasl-write printf format print-error
read-token read
error exit call/cc
current-error-handler
@ -93,6 +87,31 @@
assembler-output
$make-environment
features
port? input-port? output-port?
make-input-port make-output-port make-input/output-port
port-handler
port-input-buffer port-input-index port-input-size
port-output-buffer port-output-index port-output-size
set-port-input-index! set-port-input-size!
set-port-output-index! set-port-output-size!
port-name input-port-name output-port-name
write-char read-char unread-char peek-char
newline
reset-input-port! flush-output-port
close-input-port close-output-port
console-input-port current-input-port
standard-output-port standard-error-port
console-output-port current-output-port
open-output-file open-input-file
open-output-string get-output-string
with-output-to-file call-with-output-file
with-input-from-file call-with-input-file
date-string
+ - add1 sub1 * expt number? positive? negative? zero? number->string
logand
= < > <= >=
))
(define system-primitives
@ -124,13 +143,28 @@
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
fixnum->string
vector-memq vector-memv
;;; must open-code
$make-port/input
$make-port/output
$make-port/both
$make-input-port $make-output-port $make-input/output-port
$port-handler
$port-input-buffer $port-input-index $port-input-size
$port-output-buffer $port-output-index $port-output-size
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size!
;;; better open-code
$write-char $read-char $peek-char $unread-char
port? input-port? output-port? $make-input-port make-input-port $make-output-port make-output-port $make-input/output-port make-input/output-port $port-handler port-handler $port-input-buffer port-input-buffer $port-input-index port-input-index $port-input-size port-input-size $port-output-buffer port-output-buffer $port-output-index port-output-index $port-output-size port-output-size $set-port-input-index! set-port-input-index! $set-port-input-size! set-port-input-size! $set-port-output-index! set-port-output-index! $set-port-output-size! set-port-output-size! $write-char write-char newline port-name input-port-name output-port-name $read-char read-char $unread-char unread-char $peek-char peek-char $unread-char $reset-input-port! reset-input-port! $close-input-port close-input-port $close-output-port close-output-port $flush-output-port flush-output-port *standard-input-port* console-input-port *current-input-port* current-input-port *standard-output-port* *current-output-port* *standard-error-port* standard-output-port standard-error-port console-output-port current-output-port *current-output-port* open-output-file open-output-string get-output-string with-output-to-file call-with-output-file with-input-from-file call-with-input-file
;;; never open-code
$reset-input-port! $close-input-port
$close-output-port $flush-output-port
*standard-output-port* *standard-error-port* *current-output-port*
*standard-input-port* *current-input-port*
))
@ -153,7 +187,7 @@ port? input-port? output-port? $make-input-port make-input-port $make-output-
`(begin
(define-syntax compile-time-date-string
(lambda (x)
#'(quote ,(#%date-string))))
#'(quote ,(date-string))))
(define-syntax public-primitives
(lambda (x)
#'(quote ,public-primitives)))
@ -194,35 +228,36 @@ port? input-port? output-port? $make-input-port make-input-port $make-output-
(whack-system-env #t)
(printf "ok\n")
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
(load "libintelasm-6.6.ss") ; uses make-code, etc.
(load "libintelasm-6.9.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.ss") ; uses fasl-write
(load "libcompile-8.1.ss") ; uses fasl-write
)
(whack-system-env #t)
(define scheme-library-files
'(["libhandlers-6.9.ss" "libhandlers.fasl"]
["libcontrol-6.1.ss" "libcontrol.fasl"]
["libcollect-6.1.ss" "libcollect.fasl"]
["librecord-6.4.ss" "librecord.fasl"]
["libcxr-6.0.ss" "libcxr.fasl"]
["libcore-6.9.ss" "libcore.fasl"]
["libio-6.9.ss" "libio.fasl"]
["libwriter-6.2.ss" "libwriter.fasl"]
["libtokenizer-6.1.ss" "libtokenizer.fasl"]
["libassembler-6.7.ss" "libassembler.ss"]
["libintelasm-6.9.ss" "libintelasm.fasl"]
["libfasl-6.7.ss" "libfasl.fasl"]
["libcompile-6.7.ss" "libcompile.fasl"]
["psyntax-7.1-6.9.ss" "psyntax.fasl"]
["libinterpret-6.5.ss" "libinterpret.fasl"]
["libcafe-6.1.ss" "libcafe.fasl"]
["libtrace-6.9.ss" "libtrace.fasl"]
["libposix-6.0.ss" "libposix.fasl"]
["libhash-6.2.ss" "libhash.fasl"]
["libtoplevel-6.9.ss" "libtoplevel.fasl"]
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
["libcollect-6.1.ss" #t "libcollect.fasl"]
["librecord-6.4.ss" #t "librecord.fasl"]
["libcxr-6.0.ss" #t "libcxr.fasl"]
["libnumerics-9.1.ss" #t "libnumerics.fasl"]
["libcore-6.9.ss" #t "libcore.fasl"]
["libchezio-8.1.ss" #t "libchezio.fasl"]
["libhash-6.2.ss" #t "libhash.fasl"]
["libwriter-9.1.ss" #t "libwriter.fasl"]
["libtokenizer-9.1.ss" #t "libtokenizer.fasl"]
["libassembler-6.7.ss" #t "libassembler.ss"]
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
["libfasl-6.7.ss" #t "libfasl.fasl"]
["libcompile-9.1.ss" #t "libcompile.fasl"]
["psyntax-7.1-9.1.ss" #t "psyntax.fasl"]
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
["libcafe-6.1.ss" #t "libcafe.fasl"]
["libtrace-6.9.ss" #t "libtrace.fasl"]
["libposix-6.0.ss" #t "libposix.fasl"]
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
))
@ -236,7 +271,8 @@ port? input-port? output-port? $make-input-port make-input-port $make-output-
(for-each
(lambda (x)
(compile-library (car x) (cadr x)))
(when (cadr x)
(compile-library (car x) (caddr x))))
scheme-library-files)
@ -258,4 +294,4 @@ port? input-port? output-port? $make-input-port make-input-port $make-output-
(system
(format "cat ~a > ikarus.fasl"
(join " " (map cadr scheme-library-files))))
(join " " (map caddr scheme-library-files))))

301
src/compiler-9.2.ss Normal file
View File

@ -0,0 +1,301 @@
;;; 9.1: * starting with libnumerics
;;; 9.0: * graph marks for both reader and writer
;;; * circularity detection during read
;;; 8.1: * using chez-style io ports
;;; 6.9: * creating a *system* environment
;;; 6.8: * creating a core-primitive form in the expander
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
;;; * added pointer-value
;;; * added tcbuckets
;;; 6.1: * added case-lambda, dropped lambda
;;; 6.0: * basic compiler
(define macros
'(|#primitive| lambda case-lambda set! quote begin define if letrec
foreign-call $apply
quasiquote unquote unquote-splicing
define-syntax identifier-syntax let-syntax letrec-syntax
fluid-let-syntax alias meta eval-when with-implicit with-syntax
type-descriptor
syntax-case syntax-rules module $module import $import import-only
syntax quasisyntax unsyntax unsyntax-splicing datum
let let* let-values cond case define-record or and when unless do
include parameterize trace untrace trace-lambda))
(define public-primitives
'(null? pair? char? fixnum? symbol? gensym? string? vector? list?
boolean? procedure?
not
eof-object eof-object? bwp-object?
void
fx= fx< fx<= fx> fx>= fxzero?
fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo
fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
integer->char char->integer
char=? char<? char<=? char>? char>=?
cons car cdr set-car! set-cdr!
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
list list* make-list length list-ref
append
make-vector vector-ref vector-set! vector-length vector
vector->list list->vector
make-string string-ref string-set! string-length string list->string
uuid
string-append substring
string=? string<? string<=? string>? string>=?
remprop putprop getprop property-list
apply
map for-each andmap ormap
memq memv assq
eq? equal?
reverse
string->symbol symbol->string oblist
top-level-value set-top-level-value! top-level-bound?
gensym gensym-count gensym-prefix print-gensym
gensym->unique-string
call-with-values values
make-parameter dynamic-wind
display write print-graph fasl-write printf format print-error
read-token read
error exit call/cc
current-error-handler
eval current-eval interpret compile compile-file new-cafe load
system
expand sc-expand current-expand expand-mode
environment? interaction-environment
identifier? free-identifier=? bound-identifier=? literal-identifier=?
datum->syntax-object syntax-object->datum syntax-error
syntax->list
generate-temporaries
record? record-set! record-ref record-length
record-type-descriptor make-record-type
record-printer record-name record-field-accessor
record-field-mutator record-predicate record-constructor
record-type-name record-type-symbol record-type-field-names
hash-table? make-hash-table get-hash-table put-hash-table!
assembler-output
$make-environment
features
port? input-port? output-port?
make-input-port make-output-port make-input/output-port
port-handler
port-input-buffer port-input-index port-input-size
port-output-buffer port-output-index port-output-size
set-port-input-index! set-port-input-size!
set-port-output-index! set-port-output-size!
port-name input-port-name output-port-name
write-char read-char unread-char peek-char
newline
reset-input-port! flush-output-port
close-input-port close-output-port
console-input-port current-input-port
standard-output-port standard-error-port
console-output-port current-output-port
open-output-file open-input-file
open-output-string get-output-string
with-output-to-file call-with-output-file
with-input-from-file call-with-input-file
date-string
+ - add1 sub1 * expt number? positive? negative? zero? number->string
logand
= < > <= >=
))
(define system-primitives
'(immediate? $unbound-object? $forward-ptr?
pointer-value
primitive-ref primitive-set!
$fx= $fx< $fx<= $fx> $fx>= $fxzero?
$fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo
$fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
$fixnum->char $char->fixnum
$char= $char< $char<= $char> $char>=
$car $cdr $set-car! $set-cdr!
$make-vector $vector-ref $vector-set! $vector-length
$make-string $string-ref $string-set! $string-length $string
$symbol-string $symbol-unique-string $symbol-value
$set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
$make-symbol $set-symbol-plist! $symbol-plist
$sc-put-cte
$record? $record/rtd? $record-set! $record-ref $record-rtd
$make-record $record
$base-rtd
$code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
$code->closure list*->code*
make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
code-size code-ref code-set!
$frame->continuation $fp-at-base $current-frame $seal-frame-and-call
$make-call-with-values-procedure $make-values-procedure
do-overflow collect
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
$tcbucket-dlink-prev
$tcbucket-dlink-next
$set-tcbucket-dlink-prev!
$set-tcbucket-dlink-next!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string
vector-memq vector-memv
;;; must open-code
$make-port/input
$make-port/output
$make-port/both
$make-input-port $make-output-port $make-input/output-port
$port-handler
$port-input-buffer $port-input-index $port-input-size
$port-output-buffer $port-output-index $port-output-size
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size!
;;; better open-code
$write-char $read-char $peek-char $unread-char
;;; never open-code
$reset-input-port! $close-input-port
$close-output-port $flush-output-port
*standard-output-port* *standard-error-port* *current-output-port*
*standard-input-port* *current-input-port*
))
(define (whack-system-env setenv?)
(define add-prim
(lambda (x)
(let ([g (gensym (symbol->string x))])
(putprop x '|#system| g)
(putprop g '*sc-expander* (cons 'core-primitive x)))))
(define add-macro
(lambda (x)
(let ([g (gensym (symbol->string x))]
[e (getprop x '*sc-expander*)])
(when e
(putprop x '|#system| g)
(putprop g '*sc-expander* e)))))
(define (foo)
(eval
`(begin
(define-syntax compile-time-date-string
(lambda (x)
#'(quote ,(date-string))))
(define-syntax public-primitives
(lambda (x)
#'(quote ,public-primitives)))
(define-syntax system-primitives
(lambda (x)
#'(quote ,system-primitives)))
(define-syntax macros
(lambda (x)
#'(quote ,macros))))))
(set! system-env ($make-environment '|#system| #t))
(for-each add-macro macros)
(for-each add-prim public-primitives)
(for-each add-prim system-primitives)
(if setenv?
(parameterize ([interaction-environment system-env])
(foo))
(foo)))
(when (eq? "" "")
(load "chez-compat.ss")
(set! primitive-ref top-level-value)
(set! primitive-set! set-top-level-value!)
(set! chez-expand sc-expand)
(set! chez-current-expand current-expand)
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(whack-system-env #f)
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1-6.9.ss")
(chez-current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(whack-system-env #t)
(printf "ok\n")
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
(load "libintelasm-6.9.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-8.1.ss") ; uses fasl-write
)
(whack-system-env #t)
(define scheme-library-files
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
["libcollect-6.1.ss" #t "libcollect.fasl"]
["librecord-6.4.ss" #t "librecord.fasl"]
["libcxr-6.0.ss" #t "libcxr.fasl"]
["libnumerics-9.1.ss" #t "libnumerics.fasl"]
["libcore-6.9.ss" #t "libcore.fasl"]
["libchezio-8.1.ss" #t "libchezio.fasl"]
["libhash-9.2.ss" #t "libhash.fasl"]
["libwriter-9.1.ss" #t "libwriter.fasl"]
["libtokenizer-9.1.ss" #t "libtokenizer.fasl"]
["libassembler-6.7.ss" #t "libassembler.ss"]
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
["libfasl-6.7.ss" #t "libfasl.fasl"]
["libcompile-9.1.ss" #t "libcompile.fasl"]
["psyntax-7.1-9.1.ss" #t "psyntax.fasl"]
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
["libcafe-6.1.ss" #t "libcafe.fasl"]
["libtrace-6.9.ss" #t "libtrace.fasl"]
["libposix-6.0.ss" #t "libposix.fasl"]
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
))
(define (compile-library ifile ofile)
(parameterize ([assembler-output #f]
[expand-mode 'bootstrap]
[interaction-environment system-env])
(printf "compiling ~a ...\n" ifile)
(compile-file ifile ofile 'replace)))
(for-each
(lambda (x)
(when (cadr x)
(compile-library (car x) (caddr x))))
scheme-library-files)
(define (join s ls)
(cond
[(null? ls) ""]
[else
(let ([str (open-output-string)])
(let f ([a (car ls)] [d (cdr ls)])
(cond
[(null? d)
(display a str)
(get-output-string str)]
[else
(display a str)
(display s str)
(f (car d) (cdr d))])))]))
(system
(format "cat ~a > ikarus.fasl"
(join " " (map caddr scheme-library-files))))

6
src/fact.ss Normal file
View File

@ -0,0 +1,6 @@
(define (fact n ac)
(if (zero? n)
ac
(fact (- n 1) (* n ac))))
(begin (fact 10000 1) #f)

52
src/generate-cxr.ss
View File

@ -1,52 +0,0 @@
(define generate-cxr-definitions
(lambda ()
(define gen-body
(lambda (name arg ls)
(cond
[(null? (cdr ls))
`(if (pair? ,arg)
(,(car ls) ,arg)
(err ',name orig))]
[else
(let ([a (car ls)])
`(if (pair? ,arg)
(let ([x (,a ,arg)])
,(gen-body name 'x (cdr ls)))
(err ',name orig)))])))
(define gen-cxr
(lambda (name ls)
`(primitive-set! ',name (lambda (orig) ,(gen-body name 'orig ls)))))
(define gen-names-n
(lambda (n)
(cond
[(fx= n 0) '(())]
[else
(let ([ls (gen-names-n (fx- n 1))])
(append
(map (lambda (x) (cons #\a x)) ls)
(map (lambda (x) (cons #\d x)) ls)))])))
(define gen-names
(lambda (n)
(cond
[(fx= n 0) '()]
[else (append (gen-names (fx- n 1)) (gen-names-n n))])))
(define ls->name
(lambda (ls)
(string->symbol (list->string (append '(#\c) ls '(#\r))))))
(define ls->functions
(lambda (ls)
(reverse
(map (lambda (c) (string->symbol (format "$c~ar" c))) ls))))
`(let ([err
(lambda (who x)
(error who "invalid list structure ~s" x))])
,@(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)

6
src/geninstr/gen.pl
View File

@ -48,10 +48,8 @@ sub gen3{
}
}
gen1 "movl \$0x1234, r1\n";
#gen1 "movl \$27, 4(r1)\n";
#gen1 "movl \$27, 4000(r1)\n";
gen1 "movl \$27, 4(r1)\n";
gen1 "movl \$27, 4000(r1)\n";
#gen1 "movb \$0, 4(r1)\n";
#gen1 "movb -2(r1), %ah\n";

33
src/geninstr/tmp.dump
View File

@ -4,11 +4,28 @@ tmp.o: file format elf32-i386
Disassembly of section .text:
00000000 <.text>:
0: b8 34 12 00 00 mov $0x1234,%eax
5: b9 34 12 00 00 mov $0x1234,%ecx
a: ba 34 12 00 00 mov $0x1234,%edx
f: bb 34 12 00 00 mov $0x1234,%ebx
14: bc 34 12 00 00 mov $0x1234,%esp
19: bd 34 12 00 00 mov $0x1234,%ebp
1e: be 34 12 00 00 mov $0x1234,%esi
23: bf 34 12 00 00 mov $0x1234,%edi
0: c7 40 04 1b 00 00 00 movl $0x1b,0x4(%eax)
7: c7 41 04 1b 00 00 00 movl $0x1b,0x4(%ecx)
e: c7 42 04 1b 00 00 00 movl $0x1b,0x4(%edx)
15: c7 43 04 1b 00 00 00 movl $0x1b,0x4(%ebx)
1c: c7 44 24 04 1b 00 00 movl $0x1b,0x4(%esp)
23: 00
24: c7 45 04 1b 00 00 00 movl $0x1b,0x4(%ebp)
2b: c7 46 04 1b 00 00 00 movl $0x1b,0x4(%esi)
32: c7 47 04 1b 00 00 00 movl $0x1b,0x4(%edi)
39: c7 80 a0 0f 00 00 1b movl $0x1b,0xfa0(%eax)
40: 00 00 00
43: c7 81 a0 0f 00 00 1b movl $0x1b,0xfa0(%ecx)
4a: 00 00 00
4d: c7 82 a0 0f 00 00 1b movl $0x1b,0xfa0(%edx)
54: 00 00 00
57: c7 83 a0 0f 00 00 1b movl $0x1b,0xfa0(%ebx)
5e: 00 00 00
61: c7 84 24 a0 0f 00 00 movl $0x1b,0xfa0(%esp)
68: 1b 00 00 00
6c: c7 85 a0 0f 00 00 1b movl $0x1b,0xfa0(%ebp)
73: 00 00 00
76: c7 86 a0 0f 00 00 1b movl $0x1b,0xfa0(%esi)
7d: 00 00 00
80: c7 87 a0 0f 00 00 1b movl $0x1b,0xfa0(%edi)
87: 00 00 00

24
src/geninstr/tmp.s
View File

@ -1,9 +1,17 @@
.text
movl $0x1234, %eax
movl $0x1234, %ecx
movl $0x1234, %edx
movl $0x1234, %ebx
movl $0x1234, %esp
movl $0x1234, %ebp
movl $0x1234, %esi
movl $0x1234, %edi
movl $27, 4(%eax)
movl $27, 4(%ecx)
movl $27, 4(%edx)
movl $27, 4(%ebx)
movl $27, 4(%esp)
movl $27, 4(%ebp)
movl $27, 4(%esi)
movl $27, 4(%edi)
movl $27, 4000(%eax)
movl $27, 4000(%ecx)
movl $27, 4000(%edx)
movl $27, 4000(%ebx)
movl $27, 4000(%esp)
movl $27, 4000(%ebp)
movl $27, 4000(%esi)
movl $27, 4000(%edi)

BIN
src/ikarus.fasl
View File

Binary file not shown.

67
src/libassembler-compat-6.0.ss
View File

@ -1,67 +0,0 @@
(let ()
(define-record code (closure-size code-vec reloc-vec))
(define 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 (integer->char 0))
(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)))
(primitive-set! 'make-code make-code^)
(primitive-set! 'code? code?)
(primitive-set! 'code-code-vec code-code-vec)
(primitive-set! 'code-reloc-vec code-reloc-vec)
(primitive-set! 'code-closure-size code-closure-size)
(primitive-set! 'set-code-byte! set-code-byte!)
(primitive-set! 'set-code-word! set-code-word!)
(primitive-set! 'set-code-object! set-code-object!)
(primitive-set! 'set-code-foreign-object! set-code-foreign-object!)
(primitive-set! 'set-code-object+offset/rel! set-code-object+offset/rel!)
(primitive-set! 'set-code-object+offset! set-code-object+offset!)
(primitive-set! 'make-code-executable! make-code-executable!))

32
src/libassembler-compat-6.6.ss
View File

@ -1,32 +0,0 @@
(let ()
(define-record code (closure-size code-string reloc-vector))
(define make-code^
(lambda (code-size closure-size)
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
(make-code
closure-size
(make-string code-size)
#f))))
(define code-set!
(lambda (code idx byte)
(string-set! (code-code-string code) idx (integer->char byte))))
(define code-ref
(lambda (code idx)
(char->integer (string-ref (code-code-string code) idx))))
(define (code-size code)
(string-length (code-code-string code)))
(primitive-set! 'make-code make-code^)
(primitive-set! 'code? code?)
(primitive-set! 'code-reloc-vector code-reloc-vector)
(primitive-set! 'code-closure-size code-closure-size)
(primitive-set! 'code-size code-size)
(primitive-set! 'code-set! code-set!)
(primitive-set! 'code-ref code-ref)
(primitive-set! 'set-code-reloc-vector! set-code-reloc-vector!))

32
src/libassembler-compat-6.7.ss
View File

@ -1,32 +0,0 @@
(let ()
(define-record code (freevars code-string reloc-vector))
(define make-code^
(lambda (code-size freevars)
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
(make-code
freevars
(make-string code-size)
#f))))
(define code-set!
(lambda (code idx byte)
(string-set! (code-code-string code) idx (integer->char byte))))
(define code-ref
(lambda (code idx)
(char->integer (string-ref (code-code-string code) idx))))
(define (code-size code)
(string-length (code-code-string code)))
(primitive-set! 'make-code make-code^)
(primitive-set! 'code? code?)
(primitive-set! 'code-reloc-vector code-reloc-vector)
(primitive-set! 'code-freevars code-freevars)
(primitive-set! 'code-size code-size)
(primitive-set! 'code-set! code-set!)
(primitive-set! 'code-ref code-ref)
(primitive-set! 'set-code-reloc-vector! set-code-reloc-vector!))

BIN
src/libassembler-compat.ss
View File

Binary file not shown.

BIN
src/libassembler.ss
View File

Binary file not shown.

72
src/libcafe-6.0.ss
View File

@ -1,72 +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
(reset-input-port! (console-input-port))
(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
(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)))
(primitive-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))))))))

1
src/libcafe-6.1.ss
View File

@ -30,6 +30,7 @@
(with-error-handler
(lambda args
(reset-input-port! (console-input-port))
;(display "repl catch\n" (console-output-port))
(apply print-error args)
(k (void)))
(lambda ()

BIN
src/libcafe.fasl
View File

Binary file not shown.

45
src/libchezio-8.1.ss
View File

@ -26,27 +26,30 @@
;;; (port-output-size port)
;;;
;;; * Mutators:
;;; (set-port-handler! port proc)
;;; (set-port-input-buffer! port string)
;;; (set-port-input-index! port fixnum)
;;; (set-port-input-size! port fixnum)
;;; (set-port-output-buffer! port string)
;;; (set-port-output-index! port fixnum)
;;; (set-port-output-size! port fixnum)
;;;
;;; (begin
;;; ;;; uncomment this form to use the compiler's definition
;;; ;;; of ports; otherwise, ports are represented as vanilla
;;; ;;; records.
;;; ($define-record-syntax port
;;; (handler input-buffer input-index input-size
;;; output-buffer output-index output-size))
;;; (define-syntax port? (identifier-syntax $port?))
;;; (define-syntax input-port?
;;; (syntax-rules ()
;;; [(_ x) (identifier? #'x)
;;; (and ($port? x) (string? ($port-input-buffer x)))]))
;;; (define-syntax output-port?
;;; (syntax-rules ()
;;; [(_ x) (identifier? #'x)
;;; (and ($port? x) (string? ($port-output-buffer x)))])))
#;(begin
;;; uncomment this form to use the compiler's definition
;;; of ports; otherwise, ports are represented as vanilla
;;; records.
($define-record-syntax port
(handler input-buffer input-index input-size
output-buffer output-index output-size))
(define-syntax port? (identifier-syntax $port?))
(define-syntax input-port?
(syntax-rules ()
[(_ x) (identifier? #'x)
(and ($port? x) (string? ($port-input-buffer x)))]))
(define-syntax output-port?
(syntax-rules ()
[(_ x) (identifier? #'x)
(and ($port? x) (string? ($port-output-buffer x)))])))
;;;
(primitive-set! 'port?
(lambda (x) (port? x)))
@ -59,7 +62,7 @@
;;;
(primitive-set! '$make-input-port
(lambda (handler buffer)
($make-port handler buffer 0 ($string-length buffer) #f 0 0)))
($make-port/input handler buffer 0 ($string-length buffer) #f 0 0)))
;;;
(primitive-set! 'make-input-port
(lambda (handler buffer)
@ -71,7 +74,7 @@
;;;
(primitive-set! '$make-output-port
(lambda (handler buffer)
($make-port handler #f 0 0 buffer 0 ($string-length buffer))))
($make-port/output handler #f 0 0 buffer 0 ($string-length buffer))))
;;;
(primitive-set! 'make-output-port
(lambda (handler buffer)
@ -83,7 +86,7 @@
;;;
(primitive-set! '$make-input/output-port
(lambda (handler input-buffer output-buffer)
($make-port handler
($make-port/both handler
input-buffer 0 ($string-length input-buffer)
output-buffer 0 ($string-length output-buffer))))
(primitive-set! 'make-input/output-port
@ -235,7 +238,7 @@
;;;
(primitive-set! '$write-char
(lambda (c p)
(let ([idx ($port-output-index p)])
(let ([idx (port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
@ -286,7 +289,7 @@
;;;
(primitive-set! 'read-char
(case-lambda
[() ($read-char (current-input-port))]
[() ($read-char *current-input-port*)]
[(p)
(if (input-port? p)
($read-char p)

28
src/libcollect-6.0.ss
View File

@ -1,28 +0,0 @@
;(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
View File

Binary file not shown.

3035
src/libcompile-6.4.ss
View File

File diff suppressed because it is too large Load Diff

3435
src/libcompile-6.5.ss
View File

File diff suppressed because it is too large Load Diff

110
src/libcompile-8.1.ss
View File

@ -126,7 +126,9 @@
[port? 1 pred]
[input-port? 1 pred]
[output-port? 1 pred]
[$make-port 7 value]
[$make-port/input 7 value]
[$make-port/output 7 value]
[$make-port/both 7 value]
[$port-handler 1 value]
[$port-input-buffer 1 value]
[$port-input-index 1 value]
@ -362,8 +364,8 @@
[(top-level-value)
(let ([var (quoted-sym (cadr x))])
(if (eq? (expand-mode) 'bootstrap)
;(error 'compile "reference to ~s in bootstrap mode" var)
(make-primref var)
(error 'compile "reference to ~s in bootstrap mode" var)
;(make-primref var)
(make-funcall
(make-primref 'top-level-value)
(list (make-constant var)))))]
@ -1096,7 +1098,14 @@
[(fixnum? immediate? boolean? char? vector? string? procedure?
null? pair? not cons eq? vector symbol? error eof-object eof-object?
void $unbound-object? $code? $forward-ptr? bwp-object?
pointer-value top-level-value car cdr list* list $record)
pointer-value top-level-value car cdr list* list $record
port? input-port? output-port?
$make-port/input $make-port/output $make-port/both
$port-handler
$port-input-buffer $port-input-index $port-input-size
$port-output-buffer $port-output-index $port-output-size
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size! )
'#t]
[($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx*
$fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit)
@ -1468,6 +1477,8 @@
(check-bytes (fxadd1 disp-string-data) (car arg*) x)])]
[($string)
(check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)]
[($make-port/input $make-port/output $make-port/both)
(check-const port-size x)]
[($make-vector)
(record-case (car arg*)
[(constant i)
@ -1551,7 +1562,7 @@
s))
(define (check? x)
(cond
[(primref? x) #t] ;;;; PRIMREF CHECK
[(primref? x) #f] ;;;; PRIMREF CHECK
[else #t]))
(define (do-new-frame op rand* si r call-convention rp-convention orig-live)
(make-new-frame (fxadd1 si) (fx+ (length rand*) 2)
@ -1967,6 +1978,19 @@
(define disp-code-relocsize 8)
(define disp-code-freevars 12)
(define disp-code-data 16)
(define port-tag #x3F)
(define input-port-tag #x7F)
(define output-port-tag #xBF)
(define input/output-port-tag #xFF)
(define port-mask #x3F)
(define disp-port-handler 4)
(define disp-port-input-buffer 8)
(define disp-port-input-index 12)
(define disp-port-input-size 16)
(define disp-port-output-buffer 20)
(define disp-port-output-index 24)
(define disp-port-output-size 28)
(define port-size 32)
(define disp-tcbucket-tconc 0)
(define disp-tcbucket-key 4)
(define disp-tcbucket-val 8)
@ -2220,6 +2244,15 @@
[($record?)
(indirect-type-pred record-pmask record-ptag record-pmask record-ptag
rand* Lt Lf ac)]
[(output-port?)
(indirect-type-pred
vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)]
[(input-port?)
(indirect-type-pred
vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)]
[(port?)
(indirect-type-pred
vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)]
[($record/rtd?)
(cond
[Lf
@ -2352,6 +2385,23 @@
(movl (Simple (car arg*)) eax)
(movl (mem off eax) eax)
ac))
(define (do-make-port tag args ac)
(let f ([args args] [idx disp-vector-data])
(cond
[(null? args)
(if (fx= idx port-size)
(list*
(movl (int tag) (mem 0 apr))
(movl apr eax)
(addl (int port-size) apr)
(addl (int vector-tag) eax)
ac)
(error 'do-make-port "BUG"))]
[else
(list*
(movl (Simple (car args)) eax)
(movl eax (mem idx apr))
(f (cdr args) (fx+ idx wordsize)))])))
(define (do-value-prim op arg* ac)
(case op
[(eof-object) (cons (movl (int eof) eax) ac)]
@ -2489,6 +2539,20 @@
(indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)]
[($tcbucket-next)
(indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)]
[($port-handler)
(indirect-ref arg* (fx- disp-port-handler vector-tag) ac)]
[($port-input-buffer)
(indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)]
[($port-input-index)
(indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)]
[($port-input-size)
(indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)]
[($port-output-buffer)
(indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)]
[($port-output-index)
(indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)]
[($port-output-size)
(indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)]
[(pointer-value)
(list*
(movl (Simple (car arg*)) eax)
@ -2668,6 +2732,9 @@
(addl (int symbol-tag) eax)
(addl (int (align symbol-size)) apr)
ac)]
[($make-port/input) (do-make-port input-port-tag arg* ac)]
[($make-port/output) (do-make-port output-port-tag arg* ac)]
[($make-port/both) (do-make-port input/output-port-tag arg* ac)]
[($make-tcbucket)
(list* (movl (Simple (car arg*)) eax)
(movl eax (mem disp-tcbucket-tconc apr))
@ -2781,13 +2848,15 @@
$set-symbol-value! $set-symbol-plist!
$code-set! primitive-set!
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
$record-set!)
$record-set!
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size!)
(do-effect-prim op arg*
(cons (movl (int void-object) eax) ac))]
[(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol?
procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq?
$char= $char< $char<= $char> $char>= $unbound-object? $code?
$record? $record/rtd? bwp-object?)
$record? $record/rtd? bwp-object? port? input-port? output-port?)
(do-pred->value-prim op arg* ac)]
[($code->closure)
(list*
@ -2881,7 +2950,32 @@
(indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)]
[($set-tcbucket-tconc!)
(indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)]
[($set-port-input-index!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-port-input-index vector-tag) eax))
ac)]
[($set-port-input-size!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax))
(movl ebx (mem (fx- disp-port-input-size vector-tag) eax))
ac)]
[($set-port-output-index!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-port-output-index vector-tag) eax))
ac)]
[($set-port-output-size!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax))
(movl ebx (mem (fx- disp-port-output-size vector-tag) eax))
ac)]
[($set-symbol-value!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)

126
src/libcompile-6.7.ss → src/libcompile-9.0.ss
View File

@ -1,4 +1,7 @@
;;; 9.0: * calls (gensym <symbol>) instead of
;;; (gensym (symbol->string <symbol>)) in order to avoid incrementing
;;; gensym-count.
;;; 6.7: * open-coded top-level-value, car, cdr
;;; 6.2: * side-effects now modify the dirty-vector
;;; * added bwp-object?
@ -122,6 +125,24 @@
[primitive-ref 1 value]
[primitive-set! 2 effect]
[top-level-value 1 value]
;;; ports
[port? 1 pred]
[input-port? 1 pred]
[output-port? 1 pred]
[$make-port/input 7 value]
[$make-port/output 7 value]
[$make-port/both 7 value]
[$port-handler 1 value]
[$port-input-buffer 1 value]
[$port-input-index 1 value]
[$port-input-size 1 value]
[$port-output-buffer 1 value]
[$port-output-index 1 value]
[$port-output-size 1 value]
[$set-port-input-index! 2 effect]
[$set-port-input-size! 2 effect]
[$set-port-output-index! 2 effect]
[$set-port-output-size! 2 effect]
;;; tcbuckets
[$make-tcbucket 4 value]
[$tcbucket-key 1 value]
@ -215,7 +236,7 @@
(define-record assign (lhs rhs))
(define (unique-var x)
(make-var (gensym (symbol->string x)) #f))
(make-var (gensym x) #f))
(define (make-bind^ lhs* rhs* body)
@ -347,6 +368,7 @@
(let ([var (quoted-sym (cadr x))])
(if (eq? (expand-mode) 'bootstrap)
(error 'compile "reference to ~s in bootstrap mode" var)
;(make-primref var)
(make-funcall
(make-primref 'top-level-value)
(list (make-constant var)))))]
@ -1079,7 +1101,14 @@
[(fixnum? immediate? boolean? char? vector? string? procedure?
null? pair? not cons eq? vector symbol? error eof-object eof-object?
void $unbound-object? $code? $forward-ptr? bwp-object?
pointer-value top-level-value car cdr list* list $record)
pointer-value top-level-value car cdr list* list $record
port? input-port? output-port?
$make-port/input $make-port/output $make-port/both
$port-handler
$port-input-buffer $port-input-index $port-input-size
$port-output-buffer $port-output-index $port-output-size
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size! )
'#t]
[($fxadd1 $fxsub1 $fxzero? $fxlognot $fxlogor $fxlogand $fx+ $fx- $fx*
$fx= $fx< $fx<= $fx> $fx>= $fxquotient $fxmodulo $fxsll $fxsra $fxlogxor $exit)
@ -1451,6 +1480,8 @@
(check-bytes (fxadd1 disp-string-data) (car arg*) x)])]
[($string)
(check-const (fx+ (length arg*) (fx+ disp-string-data 1)) x)]
[($make-port/input $make-port/output $make-port/both)
(check-const port-size x)]
[($make-vector)
(record-case (car arg*)
[(constant i)
@ -1950,11 +1981,24 @@
(define disp-code-relocsize 8)
(define disp-code-freevars 12)
(define disp-code-data 16)
(define port-tag #x3F)
(define input-port-tag #x7F)
(define output-port-tag #xBF)
(define input/output-port-tag #xFF)
(define port-mask #x3F)
(define disp-port-handler 4)
(define disp-port-input-buffer 8)
(define disp-port-input-index 12)
(define disp-port-input-size 16)
(define disp-port-output-buffer 20)
(define disp-port-output-index 24)
(define disp-port-output-size 28)
(define port-size 32)
(define disp-tcbucket-tconc 0)
(define disp-tcbucket-key 4)
(define disp-tcbucket-val 8)
(define disp-tcbucket-next 12)
(define tcbucket-size 16)
(define tcbucket-size 24)
(define record-ptag 5)
(define record-pmask 7)
(define disp-record-rtd 0)
@ -2203,6 +2247,15 @@
[($record?)
(indirect-type-pred record-pmask record-ptag record-pmask record-ptag
rand* Lt Lf ac)]
[(output-port?)
(indirect-type-pred
vector-mask vector-tag #f output-port-tag rand* Lt Lf ac)]
[(input-port?)
(indirect-type-pred
vector-mask vector-tag #f input-port-tag rand* Lt Lf ac)]
[(port?)
(indirect-type-pred
vector-mask vector-tag port-mask port-tag rand* Lt Lf ac)]
[($record/rtd?)
(cond
[Lf
@ -2335,6 +2388,23 @@
(movl (Simple (car arg*)) eax)
(movl (mem off eax) eax)
ac))
(define (do-make-port tag args ac)
(let f ([args args] [idx disp-vector-data])
(cond
[(null? args)
(if (fx= idx port-size)
(list*
(movl (int tag) (mem 0 apr))
(movl apr eax)
(addl (int port-size) apr)
(addl (int vector-tag) eax)
ac)
(error 'do-make-port "BUG"))]
[else
(list*
(movl (Simple (car args)) eax)
(movl eax (mem idx apr))
(f (cdr args) (fx+ idx wordsize)))])))
(define (do-value-prim op arg* ac)
(case op
[(eof-object) (cons (movl (int eof) eax) ac)]
@ -2472,6 +2542,20 @@
(indirect-ref arg* (fx- disp-tcbucket-val vector-tag) ac)]
[($tcbucket-next)
(indirect-ref arg* (fx- disp-tcbucket-next vector-tag) ac)]
[($port-handler)
(indirect-ref arg* (fx- disp-port-handler vector-tag) ac)]
[($port-input-buffer)
(indirect-ref arg* (fx- disp-port-input-buffer vector-tag) ac)]
[($port-input-index)
(indirect-ref arg* (fx- disp-port-input-index vector-tag) ac)]
[($port-input-size)
(indirect-ref arg* (fx- disp-port-input-size vector-tag) ac)]
[($port-output-buffer)
(indirect-ref arg* (fx- disp-port-output-buffer vector-tag) ac)]
[($port-output-index)
(indirect-ref arg* (fx- disp-port-output-index vector-tag) ac)]
[($port-output-size)
(indirect-ref arg* (fx- disp-port-output-size vector-tag) ac)]
[(pointer-value)
(list*
(movl (Simple (car arg*)) eax)
@ -2651,6 +2735,9 @@
(addl (int symbol-tag) eax)
(addl (int (align symbol-size)) apr)
ac)]
[($make-port/input) (do-make-port input-port-tag arg* ac)]
[($make-port/output) (do-make-port output-port-tag arg* ac)]
[($make-port/both) (do-make-port input/output-port-tag arg* ac)]
[($make-tcbucket)
(list* (movl (Simple (car arg*)) eax)
(movl eax (mem disp-tcbucket-tconc apr))
@ -2764,13 +2851,15 @@
$set-symbol-value! $set-symbol-plist!
$code-set! primitive-set!
$set-code-object! $set-code-object+offset! $set-code-object+offset/rel!
$record-set!)
$record-set!
$set-port-input-index! $set-port-input-size!
$set-port-output-index! $set-port-output-size!)
(do-effect-prim op arg*
(cons (movl (int void-object) eax) ac))]
[(fixnum? immediate? $fxzero? boolean? char? pair? vector? string? symbol?
procedure? null? not eof-object? $fx= $fx< $fx<= $fx> $fx>= eq?
$char= $char< $char<= $char> $char>= $unbound-object? $code?
$record? $record/rtd? bwp-object?)
$record? $record/rtd? bwp-object? port? input-port? output-port?)
(do-pred->value-prim op arg* ac)]
[($code->closure)
(list*
@ -2864,7 +2953,32 @@
(indirect-assignment arg* (fx- disp-tcbucket-next vector-tag) ac)]
[($set-tcbucket-tconc!)
(indirect-assignment arg* (fx- disp-tcbucket-tconc vector-tag) ac)]
[($set-port-input-index!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-port-input-index vector-tag) eax))
ac)]
[($set-port-input-size!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl (int 0) (mem (fx- disp-port-input-index vector-tag) eax))
(movl ebx (mem (fx- disp-port-input-size vector-tag) eax))
ac)]
[($set-port-output-index!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl ebx (mem (fx- disp-port-output-index vector-tag) eax))
ac)]
[($set-port-output-size!)
(list*
(movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)
(movl (int 0) (mem (fx- disp-port-output-index vector-tag) eax))
(movl ebx (mem (fx- disp-port-output-size vector-tag) eax))
ac)]
[($set-symbol-value!)
(list* (movl (Simple (car arg*)) eax)
(movl (Simple (cadr arg*)) ebx)

1128
src/libcompile-6.6.ss → src/libcompile-9.1.ss
View File

File diff suppressed because it is too large Load Diff

97
src/libcontrol-6.0.ss
View File

@ -1,97 +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 ($frame->continuation frm))))))
(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)))
(define dynamic-wind
(lambda (in body out)
(in)
(set! winders (cons (cons in out) winders))
(call-with-values
body
(lambda v*
(set! winders (cdr winders))
(out)
(apply values v*)))))
(primitive-set! 'call/cf call-with-current-frame)
(primitive-set! 'call/cc call/cc)
(primitive-set! 'dynamic-wind dynamic-wind)
;($install-underflow-handler)
(void))

BIN
src/libcontrol.fasl
View File

Binary file not shown.

1392
src/libcore-6.0.ss
View File

File diff suppressed because it is too large Load Diff

1596
src/libcore-6.1.ss
View File

File diff suppressed because it is too large Load Diff

1628
src/libcore-6.2.ss
View File

File diff suppressed because it is too large Load Diff

4
src/libcore-6.9.ss
View File

@ -1036,7 +1036,9 @@
[(s)
(if (string? s)
($make-symbol s)
(error 'gensym "~s is not a string" s))]))
(if (symbol? s)
($make-symbol ($symbol-string s))
(error 'gensym "~s is neither a string nor a symbol" s)))]))
(primitive-set! 'putprop
(lambda (x k v)

BIN
src/libcore.fasl
View File

Binary file not shown.

BIN
src/libcxr.fasl
View File

Binary file not shown.

1061
src/libexpand-6.0.ss
View File

File diff suppressed because it is too large Load Diff

1074
src/libexpand-6.1.ss
View File

File diff suppressed because it is too large Load Diff

1099
src/libexpand-6.2.ss
View File

File diff suppressed because it is too large Load Diff

261
src/libfasl-6.0.ss
View File

@ -1,261 +0,0 @@
;;; FASL
;;;
;;; A fasl object is a header followed by one or more objects followed by an
;;; end-of-fasl marker
;;;
;;; The header is the string "#@IK01"
;;; The end of fasl marker is "@"
;;;
;;; An object is either:
;;; "N" : denoting the empty list
;;; "T" : denoting #t
;;; "F" : denoting #f
;;; "E" : denoting the end of file object
;;; "U" : denoting the unspecified value
;;; "I" + 4-bytes : denoting a fixnum (in host byte order)
;;; "C" + 1-byte : denoting a character
;;; "P" + object1 + object2 : a pair
;;; "V" + 4-bytes(n) + object ... : a vector of length n followed by n
;;; objects
;;; "S" + 4-bytes(n) + char ... : a string
;;; "M" + symbol-name : a symbol
;;; "G" + pretty-name + unique-name : a gensym
;;; "R" + rtd-name + rtd-symbol + field-count + field-names
;;; "{" + field-count + rtd + fields
;;; ">" + 4-bytes(i) : mark the next object with index i
;;; "<" + 4-bytes(i) : dereference the object marked with index i
;;;
(let ()
(define write-fixnum
(lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
(write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p)
(write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p)))
(define write-int
(lambda (x p)
(unless (fixnum? x) (error 'write-int "not a fixnum ~s" x))
(write-char (integer->char (fxlogand x #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p)))
(define fasl-write-immediate
(lambda (x p)
(cond
[(null? x) (write-char #\N p)]
[(fixnum? x)
(write-char #\I p)
(write-fixnum x p)]
[(char? x)
(write-char #\C p)
(write-char x p)]
[(boolean? x)
(write-char (if x #\T #\F) p)]
[(eof-object? x) (write-char #\E p)]
[(eq? x (void)) (write-char #\U p)]
[else (error 'fasl-write "~s is not a fasl-writable immediate" x)])))
(define do-write
(lambda (x p h m)
(cond
[(pair? x)
(write-char #\P p)
(fasl-write (cdr x) p h
(fasl-write (car x) p h m))]
[(vector? x)
(write-char #\V p)
(write-int (vector-length x) p)
(let f ([x x] [i 0] [n (vector-length x)] [m m])
(cond
[(fx= i n) m]
[else
(f x (fxadd1 i) n
(fasl-write (vector-ref x i) p h m))]))]
[(string? x)
(write-char #\S p)
(write-int (string-length x) p)
(let f ([x x] [i 0] [n (string-length x)])
(cond
[(fx= i n) m]
[else
(write-char (string-ref x i) p)
(f x (fxadd1 i) n)]))]
[(gensym? x)
(write-char #\G p)
(fasl-write (gensym->unique-string x) p h
(fasl-write (symbol->string x) p h m))]
[(symbol? x)
(write-char #\M p)
(fasl-write (symbol->string x) p h m)]
[(code? x)
(write-char #\X p)
(let ([code-vec (code-code-vec x)]
[reloc-vec (code-reloc-vec x)]
[closure-size (code-closure-size x)])
(write-int (string-length code-vec) p)
(write-int (fx* (vector-length reloc-vec) 4) p)
(write-int closure-size p)
(let f ([i 0] [n (string-length code-vec)])
(unless (fx= i n)
(write-char (string-ref code-vec i) p)
(f (fxadd1 i) n)))
(let f ([i 0] [n (vector-length reloc-vec)] [m m])
(if (fx= i n)
m
(let ([b (vector-ref reloc-vec i)])
(case (car b)
[(object)
(let ([code-idx (cadr b)] [object (caddr b)])
(write-char #\O p)
(write-int code-idx p)
(let ([m (fasl-write object p h m)])
(f (fxadd1 i) n m)))]
[(foreign)
(let ([code-idx (cadr b)] [object (caddr b)])
(write-char #\F p)
(write-int code-idx p)
(let ([m (fasl-write object p h m)])
(f (fx+ i 2) n m)))]
[(object+off/rel object+off)
(let ([code-idx (cadr b)]
[object (caddr b)]
[object-off (cadddr b)])
(if (eq? (car b) 'object+off/rel)
(write-char #\J p)
(write-char #\D p))
(write-int code-idx p)
(write-int object-off p)
(let ([m (fasl-write object p h m)])
(f (fx+ i 2) n m)))]
[else (error 'fasl-write "invalid reloc byte ~s" b)])))))]
[(record? x)
(let ([rtd (record-type-descriptor x)])
(cond
[(eq? rtd #%$base-rtd)
;;; rtd record
(write-char #\R p)
(let ([names (record-type-field-names x)]
[m
(fasl-write (record-type-symbol x) p h
(fasl-write (record-type-name x) p h m))])
(write-int (length names) p)
(let f ([names names] [m m])
(cond
[(null? names) m]
[else
(f (cdr names)
(fasl-write (car names) p h m))])))]
[else
;;; non-rtd record
(write-char #\{ p)
(write-int (length (record-type-field-names rtd)) p)
(let f ([names (record-type-field-names rtd)]
[m (fasl-write rtd p h m)])
(cond
[(null? names) m]
[else
(f (cdr names)
(fasl-write
((record-field-accessor rtd (car names)) x)
p h m))]))]))]
[else (error 'fasl-write "~s is not fasl-writable" x)])))
(define fasl-write
(lambda (x p h m)
(cond
[(immediate? x) (fasl-write-immediate x p) m]
[(get-hash-table h x #f) =>
(lambda (mark)
(unless (fixnum? mark)
(error 'fasl-write "BUG: invalid mark ~s" mark))
(cond
[(fx= mark 0) ; singly referenced
(do-write x p h m)]
[(fx> mark 0) ; marked but not written
(put-hash-table! h x (fx- 0 m))
(write-char #\> p)
(write-int m p)
(do-write x p h (fxadd1 m))]
[else
(write-char #\< p)
(write-int (fx- 0 mark) p)
m]))]
[else (error 'fasl-write "BUG: not in hash table ~s" x)])))
(define make-graph
(lambda (x h)
(unless (immediate? x)
(cond
[(get-hash-table h x #f) =>
(lambda (i)
(put-hash-table! h x (fxadd1 i)))]
[else
(put-hash-table! h x 0)
(cond
[(pair? x)
(make-graph (car x) h)
(make-graph (cdr x) h)]
[(vector? x)
(let f ([x x] [i 0] [n (vector-length x)])
(unless (fx= i n)
(make-graph (vector-ref x i) h)
(f x (fxadd1 i) n)))]
[(symbol? x)
(make-graph (symbol->string x) h)
(when (gensym? x) (make-graph (gensym->unique-string x) h))]
[(string? x) (void)]
[(code? x)
(let ([x (code-reloc-vec x)])
(let f ([i 0] [n (vector-length x)])
(unless (fx= i n)
(let ([b (vector-ref x i)])
(case (car b)
[(object)
(make-graph (caddr b) h)
(f (fxadd1 i) n)]
[(object+off/rel object+off foreign)
(make-graph (caddr b) h)
(f (fx+ i 2) n)]
[else (error 'fasl-write "unrecognized reloc ~s" b)]
)))))]
[(record? x)
(when (eq? x #%$base-rtd)
(error 'fasl-write "$base-rtd is not writable"))
(let ([rtd (record-type-descriptor x)])
(cond
[(eq? rtd #%$base-rtd)
;;; this is an rtd
(make-graph (record-type-name x) h)
(make-graph (record-type-symbol x) h)
(for-each (lambda (x) (make-graph x h))
(record-type-field-names x))]
[else
;;; this is a record
(make-graph rtd h)
(for-each
(lambda (name)
(make-graph ((record-field-accessor rtd name) x) h))
(record-type-field-names rtd))]))]
[else (error 'fasl-write "~s is not fasl-writable" x)])]))))
(define do-fasl-write
(lambda (x port)
(let ([h (make-hash-table)])
(make-graph x h)
(write-char #\# port)
(write-char #\@ port)
(write-char #\I port)
(write-char #\K port)
(write-char #\0 port)
(write-char #\1 port)
(fasl-write x port h 1))))
(primitive-set! 'fasl-write
(case-lambda
[(x) (do-fasl-write x (current-output-port))]
[(x port)
(unless (output-port? port)
(error 'fasl-write "~s is not an output port" port))
(do-fasl-write x port)])))

217
src/libfasl-6.6.ss
View File

@ -1,217 +0,0 @@
;;; FASL
;;;
;;; A fasl object is a header followed by one or more objects followed by an
;;; end-of-fasl marker
;;;
;;; The header is the string "#@IK01"
;;; The end of fasl marker is "@"
;;;
;;; An object is either:
;;; "N" : denoting the empty list
;;; "T" : denoting #t
;;; "F" : denoting #f
;;; "E" : denoting the end of file object
;;; "U" : denoting the unspecified value
;;; "I" + 4-bytes : denoting a fixnum (in host byte order)
;;; "C" + 1-byte : denoting a character
;;; "P" + object1 + object2 : a pair
;;; "V" + 4-bytes(n) + object ... : a vector of length n followed by n
;;; objects
;;; "S" + 4-bytes(n) + char ... : a string
;;; "M" + symbol-name : a symbol
;;; "G" + pretty-name + unique-name : a gensym
;;; "R" + rtd-name + rtd-symbol + field-count + field-names
;;; "{" + field-count + rtd + fields
;;; ">" + 4-bytes(i) : mark the next object with index i
;;; "<" + 4-bytes(i) : dereference the object marked with index i
;;;
(let ()
(define write-fixnum
(lambda (x p)
(unless (fixnum? x) (error 'write-fixnum "not a fixnum ~s" x))
(write-char (integer->char (fxsll (fxlogand x #x3F) 2)) p)
(write-char (integer->char (fxlogand (fxsra x 6) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 14) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 22) #xFF)) p)))
(define write-int
(lambda (x p)
(unless (fixnum? x) (error 'write-int "not a fixnum ~s" x))
(write-char (integer->char (fxlogand x #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 8) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 16) #xFF)) p)
(write-char (integer->char (fxlogand (fxsra x 24) #xFF)) p)))
(define fasl-write-immediate
(lambda (x p)
(cond
[(null? x) (write-char #\N p)]
[(fixnum? x)
(write-char #\I p)
(write-fixnum x p)]
[(char? x)
(write-char #\C p)
(write-char x p)]
[(boolean? x)
(write-char (if x #\T #\F) p)]
[(eof-object? x) (write-char #\E p)]
[(eq? x (void)) (write-char #\U p)]
[else (error 'fasl-write "~s is not a fasl-writable immediate" x)])))
(define do-write
(lambda (x p h m)
(cond
[(pair? x)
(write-char #\P p)
(fasl-write (cdr x) p h
(fasl-write (car x) p h m))]
[(vector? x)
(write-char #\V p)
(write-int (vector-length x) p)
(let f ([x x] [i 0] [n (vector-length x)] [m m])
(cond
[(fx= i n) m]
[else
(f x (fxadd1 i) n
(fasl-write (vector-ref x i) p h m))]))]
[(string? x)
(write-char #\S p)
(write-int (string-length x) p)
(let f ([x x] [i 0] [n (string-length x)])
(cond
[(fx= i n) m]
[else
(write-char (string-ref x i) p)
(f x (fxadd1 i) n)]))]
[(gensym? x)
(write-char #\G p)
(fasl-write (gensym->unique-string x) p h
(fasl-write (symbol->string x) p h m))]
[(symbol? x)
(write-char #\M p)
(fasl-write (symbol->string x) p h m)]
[(code? x)
(write-char #\x p)
(write-int (code-size x) p)
(write-int (code-closure-size x) p)
(let f ([i 0] [n (code-size x)])
(unless (fx= i n)
(write-char (integer->char (code-ref x i)) p)
(f (fxadd1 i) n)))
(fasl-write (code-reloc-vector x) p h m)]
[(record? x)
(let ([rtd (record-type-descriptor x)])
(cond
[(eq? rtd #%$base-rtd)
;;; rtd record
(write-char #\R p)
(let ([names (record-type-field-names x)]
[m
(fasl-write (record-type-symbol x) p h
(fasl-write (record-type-name x) p h m))])
(write-int (length names) p)
(let f ([names names] [m m])
(cond
[(null? names) m]
[else
(f (cdr names)
(fasl-write (car names) p h m))])))]
[else
;;; non-rtd record
(write-char #\{ p)
(write-int (length (record-type-field-names rtd)) p)
(let f ([names (record-type-field-names rtd)]
[m (fasl-write rtd p h m)])
(cond
[(null? names) m]
[else
(f (cdr names)
(fasl-write
((record-field-accessor rtd (car names)) x)
p h m))]))]))]
[else (error 'fasl-write "~s is not fasl-writable" x)])))
(define fasl-write
(lambda (x p h m)
(cond
[(immediate? x) (fasl-write-immediate x p) m]
[(get-hash-table h x #f) =>
(lambda (mark)
(unless (fixnum? mark)
(error 'fasl-write "BUG: invalid mark ~s" mark))
(cond
[(fx= mark 0) ; singly referenced
(do-write x p h m)]
[(fx> mark 0) ; marked but not written
(put-hash-table! h x (fx- 0 m))
(write-char #\> p)
(write-int m p)
(do-write x p h (fxadd1 m))]
[else
(write-char #\< p)
(write-int (fx- 0 mark) p)
m]))]
[else (error 'fasl-write "BUG: not in hash table ~s" x)])))
(define make-graph
(lambda (x h)
(unless (immediate? x)
(cond
[(get-hash-table h x #f) =>
(lambda (i)
(put-hash-table! h x (fxadd1 i)))]
[else
(put-hash-table! h x 0)
(cond
[(pair? x)
(make-graph (car x) h)
(make-graph (cdr x) h)]
[(vector? x)
(let f ([x x] [i 0] [n (vector-length x)])
(unless (fx= i n)
(make-graph (vector-ref x i) h)
(f x (fxadd1 i) n)))]
[(symbol? x)
(make-graph (symbol->string x) h)
(when (gensym? x) (make-graph (gensym->unique-string x) h))]
[(string? x) (void)]
[(code? x)
(make-graph (code-reloc-vector x) h)]
[(record? x)
(when (eq? x #%$base-rtd)
(error 'fasl-write "$base-rtd is not writable"))
(let ([rtd (record-type-descriptor x)])
(cond
[(eq? rtd #%$base-rtd)
;;; this is an rtd
(make-graph (record-type-name x) h)
(make-graph (record-type-symbol x) h)
(for-each (lambda (x) (make-graph x h))
(record-type-field-names x))]
[else
;;; this is a record
(make-graph rtd h)
(for-each
(lambda (name)
(make-graph ((record-field-accessor rtd name) x) h))
(record-type-field-names rtd))]))]
[else (error 'fasl-write "~s is not fasl-writable" x)])]))))
(define do-fasl-write
(lambda (x port)
(let ([h (make-hash-table)])
(make-graph x h)
(write-char #\# port)
(write-char #\@ port)
(write-char #\I port)
(write-char #\K port)
(write-char #\0 port)
(write-char #\1 port)
(fasl-write x port h 1))))
(primitive-set! 'fasl-write
(case-lambda
[(x) (do-fasl-write x (current-output-port))]
[(x port)
(unless (output-port? port)
(error 'fasl-write "~s is not an output port" port))
(do-fasl-write x port)])))

28
src/libhandlers-6.0.ss
View File

@ -1,28 +0,0 @@
(primitive-set! 'error
(lambda args
(foreign-call "ik_error" args)))
(primitive-set! '$apply-nonprocedure-error-handler
(lambda (x)
(error 'apply "~s is not a procedure" x)))
(primitive-set! '$incorrect-args-error-handler
(lambda (p n)
(error 'apply "incorrect number of argument (~s) to ~s" n p)))
(primitive-set! '$multiple-values-error
(lambda args
(error 'apply
"incorrect number of values ~s returned to single value context"
args)))
(primitive-set! '$debug
(lambda (x)
(foreign-call "ik_error" (cons "DEBUG" x))))
(primitive-set! '$underflow-misaligned-error
(lambda ()
(foreign-call "ik_error" "misaligned")))

BIN
src/libhandlers.fasl
View File

Binary file not shown.

4
src/libhash-6.2.ss
View File

@ -8,7 +8,7 @@
(define get-tc (record-field-accessor hash-rtd 2))
;;; implementation
;;; directly from Dybvig's
;;; directly from Dybvig's paper
(define tc-pop
(lambda (tc)
(let ([x ($car tc)])
@ -22,7 +22,7 @@
(define inthash
(lambda (key)
;static int inthash(int key) {
;static int inthash(int key) { /* from Bob Jenkin's */
; key += ~(key << 15);
; key ^= (key >> 10);
; key += (key << 3);

244
src/libhash-9.2.ss Normal file
View File

@ -0,0 +1,244 @@
(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc dlink))])
;;; accessors
(define get-vec (record-field-accessor hash-rtd 0))
(define set-vec! (record-field-mutator hash-rtd 0))
(define get-count (record-field-accessor hash-rtd 1))
(define set-count! (record-field-mutator hash-rtd 1))
(define get-tc (record-field-accessor hash-rtd 2))
(define get-dlink (record-field-accessor hash-rtd 3))
;;; implementation
;;; directly from Dybvig's paper
(define tc-pop
(lambda (tc)
(let ([x ($car tc)])
(if (eq? x ($cdr tc))
#f
(let ([v ($car x)])
($set-car! tc ($cdr x))
($set-car! x #f)
($set-cdr! x #f)
v)))))
(define inthash
(lambda (key)
;static int inthash(int key) { /* from Bob Jenkin's */
; key += ~(key << 15);
; key ^= (key >> 10);
; key += (key << 3);
; key ^= (key >> 6);
; key += ~(key << 11);
; key ^= (key >> 16);
; return key;
;}
(let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
[key ($fxlogxor key ($fxsra key 10))]
[key ($fx+ key ($fxsll key 3))]
[key ($fxlogxor key ($fxsra key 6))]
[key ($fx+ key ($fxlognot ($fxsll key 11)))]
[key ($fxlogxor key ($fxsra key 16))])
key)))
;;; assq-like lookup
(define direct-lookup
(lambda (x b)
(if (fixnum? b)
#f
(if (eq? x ($tcbucket-key b))
b
(direct-lookup x ($tcbucket-next b))))))
(define rehash-lookup
(lambda (h tc x)
(cond
[(tc-pop tc) =>
(lambda (b)
(if (eq? ($tcbucket-next b) #f)
(rehash-lookup h tc x)
(begin
(re-add! h b)
(if (eq? x ($tcbucket-key b))
b
(rehash-lookup h tc x)))))]
[else #f])))
(define get-bucket-index
(lambda (b)
(let ([next ($tcbucket-next b)])
(if (fixnum? next)
next
(get-bucket-index next)))))
(define replace!
(lambda (lb x y)
(let ([n ($tcbucket-next lb)])
(cond
[(eq? n x)
($set-tcbucket-next! lb y)
(void)]
[else
(replace! n x y)]))))
(define re-add!
(lambda (h b)
(let ([vec (get-vec h)]
[next ($tcbucket-next b)])
;;; first remove it from its old place
(let ([idx
(if (fixnum? next)
next
(get-bucket-index next))])
(let ([fst ($vector-ref vec idx)])
(cond
[(eq? fst b)
($vector-set! vec idx next)]
[else
(replace! fst b next)])))
;;; reset the tcbucket-tconc FIRST
($set-tcbucket-tconc! b (get-tc h))
;;; then add it to the new place
(let ([k ($tcbucket-key b)])
(let ([ih (inthash (pointer-value k))])
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
(let ([n ($vector-ref vec idx)])
($set-tcbucket-next! b n)
($vector-set! vec idx b)
(void))))))))
;(define hash-remove!
; (lambda (h x)
; (let ([vec (get-vec h)]
; [next ($tcbucket-next b)])
; ;;; first remove it from its old place
; (let ([idx
; (if (fixnum? next)
; next
; (get-bucket-index next))])
; (let ([fst ($vector-ref vec idx)])
; (cond
; [(eq? fst b)
; ($vector-set! vec idx next)]
; [else
; (replace! fst b next)]))))
; (let ([b1 ($tcbucket-dlink-next b)]
; [b2 ($tcbucket-dlink-prev b)])
; ($set-tcbucket-dlink-next! b2 b1)
; ($set-tcbucket-dlink-prev! b1 b2)
; (void))))
(define get-hash
(lambda (h x v)
(let ([pv (pointer-value x)]
[vec (get-vec h)])
(let ([ih (inthash pv)])
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
(let ([b ($vector-ref vec idx)])
(cond
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
=>
(lambda (b)
($tcbucket-val b))]
[else v])))))))
(define put-hash!
(lambda (h x v)
(let ([pv (pointer-value x)]
[vec (get-vec h)])
(let ([ih (inthash pv)])
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
(let ([b ($vector-ref vec idx)])
(cond
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
=>
(lambda (b)
($set-tcbucket-val! b v)
(void))]
[else
(let ([bucket
($make-tcbucket (get-tc h) x v ($vector-ref vec idx))])
(if ($fx= (pointer-value x) pv)
($vector-set! vec idx bucket)
(let* ([ih (inthash (pointer-value x))]
[idx
($fxlogand ih ($fx- ($vector-length vec) 1))])
($set-tcbucket-next! bucket ($vector-ref vec idx))
($vector-set! vec idx bucket)))
(let ([b1 (get-dlink h)])
(let ([b2 ($tcbucket-dlink-next b1)])
($set-tcbucket-dlink-next! bucket b2)
($set-tcbucket-dlink-prev! bucket b1)
($set-tcbucket-dlink-next! b1 bucket)
($set-tcbucket-dlink-prev! b2 bucket))))
(let ([ct (get-count h)])
(set-count! h ($fxadd1 ct))
(when ($fx> ct ($vector-length vec))
(enlarge-table h)))])))))))
(define insert-b
(lambda (b vec mask)
(let* ([x ($tcbucket-key b)]
[pv (pointer-value x)]
[ih (inthash pv)]
[idx ($fxlogand ih mask)]
[next ($tcbucket-next b)])
($set-tcbucket-next! b ($vector-ref vec idx))
($vector-set! vec idx b)
(unless (fixnum? next)
(insert-b next vec mask)))))
(define move-all
(lambda (vec1 i n vec2 mask)
(unless ($fx= i n)
(let ([b ($vector-ref vec1 i)])
(unless (fixnum? b)
(insert-b b vec2 mask))
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
(define enlarge-table
(lambda (h)
(let* ([vec1 (get-vec h)]
[n1 ($vector-length vec1)]
[n2 ($fxsll n1 1)]
[vec2 (make-base-vec n2)])
(move-all vec1 0 n1 vec2 ($fx- n2 1))
(set-vec! h vec2))))
(define init-vec
(lambda (v i n)
(if ($fx= i n)
v
(begin
($vector-set! v i i)
(init-vec v ($fxadd1 i) n)))))
(define make-base-vec
(lambda (n)
(init-vec (make-vector n) 0 n)))
;;; public interface
(primitive-set! 'hash-table? (record-predicate hash-rtd))
(primitive-set! 'make-hash-table
(let ([make (record-constructor hash-rtd)])
(lambda ()
(let ([x (cons #f #f)])
(let ([tc (cons x x)])
(make (make-base-vec 32) 0 tc
(let ([b ($make-tcbucket tc #f #f #f)])
($set-tcbucket-dlink-next! b b)
($set-tcbucket-dlink-prev! b b)
b)))))))
(primitive-set! 'get-hash-table
(lambda (h x v)
(if (hash-table? h)
(get-hash h x v)
(error 'get-hash-table "~s is not a hash table" h))))
(primitive-set! 'put-hash-table!
(lambda (h x v)
(if (hash-table? h)
(put-hash! h x v)
(error 'put-hash-table! "~s is not a hash table" h)))))

921
src/libintelasm-6.0.ss
View File

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

920
src/libintelasm-6.4.ss
View File

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

932
src/libintelasm-6.6.ss
View File

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

2
src/libintelasm-6.9.ss
View File

@ -558,6 +558,8 @@
(CODE #x83 (ModRM 3 '/7 dst (IMM8 src ac)))]
[(and (imm? src) (eq? dst '%eax))
(CODE #x3D (IMM32 src ac))]
[(and (imm? src) (reg? dst))
(CODE #x81 (ModRM 3 '/7 dst (IMM32 src ac)))]
[(and (reg? src) (reg? dst))
(CODE #x39 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))

277
src/libinterpret-6.0.ss
View File

@ -1,277 +0,0 @@
;;; Expand : Scheme -> Core Scheme
;;;
;;; <CS> ::= (quote datum)
;;; | <gensym>
;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...)
;;; | (lambda <FMLS> <CS> <CS> ...)
;;; | (<prim> <CS> <CS> ...)
;;; | (primref <primname>)
;;; | (<CS> <CS> ...)
;;; <FML> ::= ()
;;; | <gensym>
;;; | (<gensym> . <FML>)
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
;;;
(let ()
(define syntax-error
(lambda (x)
(error 'interpret "invalid syntax ~s" x)))
;;;
(define C*->last
(lambda (a d env)
(cond
[(null? d) (C a env)]
[else
(let ([a (C a env)]
[d (C*->last (car d) (cdr d) env)])
(lambda (renv)
(a renv)
(d renv)))])))
;;;
(define C*->list
(lambda (a d env)
(cond
[(null? d)
(let ([a (C a env)])
(lambda (renv)
(list (a renv))))]
[else
(let ([a (C a env)]
[d (C*->list (car d) (cdr d) env)])
(lambda (renv)
(cons (a renv) (d renv))))])))
;;;
(define extend-env
(lambda (fml* env)
(cons fml* env)))
;;;
(define fml-length
(lambda (fml* x)
(cond
[(pair? fml*) (fxadd1 (fml-length (cdr fml*) x))]
[(null? fml*) 0]
[(symbol? fml*) 1]
[else (syntax-error x)])))
;;;
(define whack-proper
(lambda (v ls i j)
(cond
[(null? ls)
(if (fx= i j)
v
(error 'apply1 "incorrect number of arguments to procedure"))]
[(fx= i j)
(error 'apply2 "incorrect number of arguments to procedure")]
[else
(vector-set! v i (car ls))
(whack-proper v (cdr ls) (fxadd1 i) j)])))
;;;
(define whack-improper
(lambda (v ls i j)
(cond
[(fx= i j) (vector-set! v i ls) v]
[(null? ls)
(error 'apply3 "incorrect number of arguments to procedure")]
[else
(vector-set! v i (car ls))
(whack-improper v (cdr ls) (fxadd1 i) j)])))
;;;
(define lookup
(lambda (x env)
(define Lj
(lambda (x fml* j)
(cond
[(pair? fml*)
(if (eq? (car fml*) x)
j
(Lj x (cdr fml*) (fxadd1 j)))]
[(eq? x fml*) j]
[else #f])))
(define Li
(lambda (x env i)
(cond
[(null? env) #f]
[(Lj x (car env) 0) =>
(lambda (j)
(cons i j))]
[else (Li x (cdr env) (fxadd1 i))])))
(Li x env 0)))
;;;
(define C
(lambda (x env)
(cond
[(gensym? x)
(cond
[(lookup x env) =>
(lambda (b)
(let ([i (car b)] [j (cdr b)])
(lambda (renv)
(vector-ref (list-ref renv i) j))))]
[else (syntax-error x)])]
[(pair? x)
(let ([a (car x)] [d (cdr x)])
(unless (list? d) (syntax-error x))
(cond
[(eq? a 'quote)
(unless (fx= (length d) 1) (syntax-error x))
(let ([v (car d)])
(lambda (renv) v))]
[(eq? a 'if)
(unless (fx= (length d) 3) (syntax-error x))
(let ([test (C (car d) env)]
[conseq (C (cadr d) env)]
[altern (C (caddr d) env)])
(lambda (renv)
(if (test renv)
(conseq renv)
(altern renv))))]
[(eq? a 'set!)
(unless (fx= (length d) 2) (syntax-error x))
(let ([var (car d)] [val (C (cadr d) env)])
(cond
[(lookup var env) =>
(lambda (b)
(let ([i (car b)] [j (cdr b)])
(lambda (renv)
(vector-set! (list-ref renv i) j (val renv)))))]
[else (syntax-error x)]))]
[(eq? a 'begin)
(unless (fx>= (length d) 1) (syntax-error x))
(C*->last (car d) (cdr d) env)]
[(eq? a 'lambda)
(unless (fx>= (length d) 2) (syntax-error x))
(let ([fml* (car d)] [body* (cdr d)])
(let ([env (extend-env fml* env)]
[n (fml-length fml* x)])
(let ([body* (C*->last (car body*) (cdr body*) env)])
(if (list? fml*)
(lambda (renv)
(lambda args
(body*
(cons (whack-proper (make-vector n) args 0 n)
renv))))
(lambda (renv)
(lambda args
(body*
(cons
(whack-improper
(make-vector n) args 0 (fxsub1 n))
renv))))))))]
[(eq? a 'void)
(unless (fx= (length d) 0) (syntax-error x))
(lambda (renv) (void))]
[(eq? a 'memv)
(unless (fx= (length d) 2) (syntax-error x))
(let ([val (C (car d) env)] [list (C (cadr d) env)])
(lambda (renv)
(memq (val renv) (list renv))))]
[(eq? a 'top-level-value)
(unless (fx= (length d) 1) (syntax-error x))
(let ([qsym (car d)])
(unless (and (pair? qsym)
(fx= (length qsym) 2)
(eq? (car qsym) 'quote)
(symbol? (cadr qsym)))
(syntax-error x))
(let ([sym (cadr qsym)])
(if (top-level-bound? sym)
(lambda (renv)
(top-level-value sym))
(lambda (renv)
(if (top-level-bound? sym)
(top-level-value sym)
(error #f "~s is unbound" sym))))))]
[(memq a '(set-top-level-value!))
(unless (fx= (length d) 2) (syntax-error x))
(let ([qsym (car d)] [val (C (cadr d) env)])
(unless (and (pair? qsym)
(fx= (length qsym) 2)
(eq? (car qsym) 'quote)
(symbol? (cadr qsym)))
(syntax-error x))
(let ([sym (cadr qsym)])
(lambda (renv)
(set-top-level-value! sym (val renv)))))]
;;; [(eq? a '$pcb-set!)
;;; (unless (fx= (length d) 2) (syntax-error x))
;;; (let ([sym (car d)] [val (C (cadr d) env)])
;;; (unless (symbol? sym) (syntax-error x))
;;; (lambda (renv)
;;; (set-top-level-value! sym (val renv))))]
[(eq? a '|#primitive|)
(unless (fx= (length d) 1) (syntax-error x))
(let ([sym (car d)])
(let ([prim (primitive-ref sym)])
(if (procedure? prim)
(lambda (renv) prim)
(syntax-error x))))]
[(memq a '(foreign-call $apply))
(error 'interpret "~a form is not supported" a)]
;;; [else
;;; (let ([rator (C a env)] [n (length d)])
;;; (cond
;;; [(fx= n 0)
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p)))]
;;; [(fx= n 1)
;;; (let ([arg1 (C (car d) env)])
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p (arg1 renv)))))]
;;; [(fx= n 2)
;;; (let ([arg1 (C (car d) env)]
;;; [arg2 (C (cadr d) env)])
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p (arg1 renv) (arg2 renv)))))]
;;; [else
;;; (let ([arg* (C*->list (car d) (cdr d) env)])
;;; (lambda (renv)
;;; (apply (rator renv) (arg* renv))))]))]
[else
(let ([rator (C a env)] [n (length d)])
(cond
[(fx= n 0)
(lambda (renv)
(apply (rator renv) '()))]
;[(fx= n 1)
; (let ([arg1 (C (car d) env)])
; (lambda (renv)
; ((rator renv) (arg1 renv))))]
;[(fx= n 2)
; (let ([arg1 (C (car d) env)]
; [arg2 (C (cadr d) env)])
; (lambda (renv)
; ((rator renv) (arg1 renv) (arg2 renv))))]
[else
(let ([arg* (C*->list (car d) (cdr d) env)])
(lambda (renv)
(apply (rator renv) (arg* renv))))]))]
))]
[else (syntax-error x)])))
;;;
(primitive-set! 'interpret
(lambda (x)
(let ([x (expand x)])
(let ([p (C x '())])
(p '())))))
;;;
(primitive-set! 'current-eval
(make-parameter
interpret
(lambda (f)
(unless (procedure? f)
(error 'current-eval "~s is not a procedure" f))
f)))
;;;
(primitive-set! 'eval
(lambda (x)
((current-eval) x))))

324
src/libinterpret-6.1.ss
View File

@ -1,324 +0,0 @@
;;; Changes:
;;; 6.1: adding case-lambda, dropping lambda
;;; 6.0: basic version working
;;;
;;; Expand : Scheme -> Core Scheme
;;;
;;; <CS> ::= (quote datum)
;;; | <gensym>
;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...)
;;; | (case-lambda (<FML> <CS>) (<FML> <CS>) ...)
;;; | (<prim> <CS> <CS> ...)
;;; | (primref <primname>)
;;; | (<CS> <CS> ...)
;;; <FML> ::= ()
;;; | <gensym>
;;; | (<gensym> . <FML>)
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
;;;
(let ()
(define syntax-error
(lambda (x)
(error 'interpret "invalid syntax ~s" x)))
;;;
(define C*->last
(lambda (a d env)
(cond
[(null? d) (C a env)]
[else
(let ([a (C a env)]
[d (C*->last (car d) (cdr d) env)])
(lambda (renv)
(a renv)
(d renv)))])))
;;;
(define C*->list
(lambda (a d env)
(cond
[(null? d)
(let ([a (C a env)])
(lambda (renv)
(list (a renv))))]
[else
(let ([a (C a env)]
[d (C*->list (car d) (cdr d) env)])
(lambda (renv)
(cons (a renv) (d renv))))])))
;;;
(define extend-env
(lambda (fml* env)
(cons fml* env)))
;;;
(define fml-length
(lambda (fml* x)
(cond
[(pair? fml*) (fxadd1 (fml-length (cdr fml*) x))]
[(null? fml*) 0]
[(symbol? fml*) 1]
[else (syntax-error x)])))
;;;
(define whack-proper
(lambda (v ls i j)
(cond
[(null? ls)
(if (fx= i j)
v
(error 'apply1 "incorrect number of arguments to procedure"))]
[(fx= i j)
(error 'apply2 "incorrect number of arguments to procedure")]
[else
(vector-set! v i (car ls))
(whack-proper v (cdr ls) (fxadd1 i) j)])))
;;;
(define whack-improper
(lambda (v ls i j)
(cond
[(fx= i j) (vector-set! v i ls) v]
[(null? ls)
(error 'apply3 "incorrect number of arguments to procedure")]
[else
(vector-set! v i (car ls))
(whack-improper v (cdr ls) (fxadd1 i) j)])))
;;;
(define lookup
(lambda (x env)
(define Lj
(lambda (x fml* j)
(cond
[(pair? fml*)
(if (eq? (car fml*) x)
j
(Lj x (cdr fml*) (fxadd1 j)))]
[(eq? x fml*) j]
[else #f])))
(define Li
(lambda (x env i)
(cond
[(null? env) #f]
[(Lj x (car env) 0) =>
(lambda (j)
(cons i j))]
[else (Li x (cdr env) (fxadd1 i))])))
(Li x env 0)))
;;;
(define C
(lambda (x env)
(cond
[(gensym? x)
(cond
[(lookup x env) =>
(lambda (b)
(let ([i (car b)] [j (cdr b)])
(lambda (renv)
(vector-ref (list-ref renv i) j))))]
[else (syntax-error x)])]
[(pair? x)
(let ([a (car x)] [d (cdr x)])
(unless (list? d) (syntax-error x))
(cond
[(eq? a 'quote)
(unless (fx= (length d) 1) (syntax-error x))
(let ([v (car d)])
(lambda (renv) v))]
[(eq? a 'if)
(unless (fx= (length d) 3) (syntax-error x))
(let ([test (C (car d) env)]
[conseq (C (cadr d) env)]
[altern (C (caddr d) env)])
(lambda (renv)
(if (test renv)
(conseq renv)
(altern renv))))]
[(eq? a 'set!)
(unless (fx= (length d) 2) (syntax-error x))
(let ([var (car d)] [val (C (cadr d) env)])
(cond
[(lookup var env) =>
(lambda (b)
(let ([i (car b)] [j (cdr b)])
(lambda (renv)
(vector-set! (list-ref renv i) j (val renv)))))]
[else (syntax-error x)]))]
[(eq? a 'begin)
(unless (fx>= (length d) 1) (syntax-error x))
(C*->last (car d) (cdr d) env)]
[(eq? a 'case-lambda)
(unless (fx>= (length d) 1) (syntax-error x))
(let ()
(define generate
(lambda (d)
(cond
[(null? d)
(lambda (n args renv)
(error 'apply
"incorrect number of arguments ~s to procedure"
n))]
[else
(let ([k (generate (cdr d))]
[a (car d)])
(let ([fml (car a)] [body* (cdr a)])
(let ([env (extend-env fml env)]
[n (fml-length fml x)])
(let ([body*
(C*->last (car body*) (cdr body*) env)])
(if (list? fml)
(lambda (m args renv)
(if (fx= n m)
(body* (cons (list->vector args) renv))
(k m args renv)))
(let ([q (fxsub1 n)])
(lambda (m args renv)
(if (fx>= m q)
(let ([v (make-vector n)])
(let f ([i 0] [args args])
(cond
[(fx= i q)
(vector-set! v q args)]
[else
(vector-set! v i (car args))
(f (fxadd1 i) (cdr args))]))
(body* (cons v renv)))
(k m args renv)))))))))])))
(let ([dispatch (generate d)])
(lambda (renv)
(lambda args
(dispatch (length args) args renv)))))]
[(eq? a 'lambda)
(syntax-error x)
(unless (fx>= (length d) 2) (syntax-error x))
(let ([fml* (car d)] [body* (cdr d)])
(let ([env (extend-env fml* env)]
[n (fml-length fml* x)])
(let ([body* (C*->last (car body*) (cdr body*) env)])
(if (list? fml*)
(lambda (renv)
(lambda args
(body*
(cons (whack-proper (make-vector n) args 0 n)
renv))))
(lambda (renv)
(lambda args
(body*
(cons
(whack-improper
(make-vector n) args 0 (fxsub1 n))
renv))))))))]
[(eq? a 'void)
(unless (fx= (length d) 0) (syntax-error x))
(lambda (renv) (void))]
[(eq? a 'memv)
(unless (fx= (length d) 2) (syntax-error x))
(let ([val (C (car d) env)] [list (C (cadr d) env)])
(lambda (renv)
(memq (val renv) (list renv))))]
[(eq? a 'top-level-value)
(unless (fx= (length d) 1) (syntax-error x))
(let ([qsym (car d)])
(unless (and (pair? qsym)
(fx= (length qsym) 2)
(eq? (car qsym) 'quote)
(symbol? (cadr qsym)))
(syntax-error x))
(let ([sym (cadr qsym)])
(if (top-level-bound? sym)
(lambda (renv)
(top-level-value sym))
(lambda (renv)
(if (top-level-bound? sym)
(top-level-value sym)
(error #f "~s is unbound" sym))))))]
[(memq a '(set-top-level-value!))
(unless (fx= (length d) 2) (syntax-error x))
(let ([qsym (car d)] [val (C (cadr d) env)])
(unless (and (pair? qsym)
(fx= (length qsym) 2)
(eq? (car qsym) 'quote)
(symbol? (cadr qsym)))
(syntax-error x))
(let ([sym (cadr qsym)])
(lambda (renv)
(set-top-level-value! sym (val renv)))))]
;;; [(eq? a '$pcb-set!)
;;; (unless (fx= (length d) 2) (syntax-error x))
;;; (let ([sym (car d)] [val (C (cadr d) env)])
;;; (unless (symbol? sym) (syntax-error x))
;;; (lambda (renv)
;;; (set-top-level-value! sym (val renv))))]
[(eq? a '|#primitive|)
(unless (fx= (length d) 1) (syntax-error x))
(let ([sym (car d)])
(let ([prim (primitive-ref sym)])
(if (procedure? prim)
(lambda (renv) prim)
(syntax-error x))))]
[(memq a '(foreign-call $apply))
(error 'interpret "~a form is not supported" a)]
;;; [else
;;; (let ([rator (C a env)] [n (length d)])
;;; (cond
;;; [(fx= n 0)
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p)))]
;;; [(fx= n 1)
;;; (let ([arg1 (C (car d) env)])
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p (arg1 renv)))))]
;;; [(fx= n 2)
;;; (let ([arg1 (C (car d) env)]
;;; [arg2 (C (cadr d) env)])
;;; (lambda (renv)
;;; (let ([p (rator renv)])
;;; (p (arg1 renv) (arg2 renv)))))]
;;; [else
;;; (let ([arg* (C*->list (car d) (cdr d) env)])
;;; (lambda (renv)
;;; (apply (rator renv) (arg* renv))))]))]
[else
(let ([rator (C a env)] [n (length d)])
(cond
[(fx= n 0)
(lambda (renv)
(apply (rator renv) '()))]
;[(fx= n 1)
; (let ([arg1 (C (car d) env)])
; (lambda (renv)
; ((rator renv) (arg1 renv))))]
;[(fx= n 2)
; (let ([arg1 (C (car d) env)]
; [arg2 (C (cadr d) env)])
; (lambda (renv)
; ((rator renv) (arg1 renv) (arg2 renv))))]
[else
(let ([arg* (C*->list (car d) (cdr d) env)])
(lambda (renv)
(apply (rator renv) (arg* renv))))]))]
))]
[else (syntax-error x)])))
;;;
(primitive-set! 'interpret
(lambda (x)
(let ([x (expand x)])
(let ([p (C x '())])
(p '())))))
;;;
(primitive-set! 'current-eval
(make-parameter
interpret
(lambda (f)
(unless (procedure? f)
(error 'current-eval "~s is not a procedure" f))
f)))
;;;
(primitive-set! 'eval
(lambda (x)
((current-eval) x))))

BIN
src/libinterpret.fasl
View File

Binary file not shown.

510
src/libio-6.0.ss
View File

@ -1,510 +0,0 @@
;;; OUTPUT PORTS
(let ()
;;; only file-based ports are supported at this point
;;;
;;; an output port is a vector with the following fields:
;;; 0. id
;;; 1. file-name
;;; 2. file-descriptor
;;; 3. open?
;;; 4. buffer
;;; 5. buffer-size
;;; 6. index
;;; 7. flush-proc
;;; 8. close-proc
(define output-port-id (gensym "output-port"))
(define output-port?
(lambda (x)
(and (vector? x)
(fx= (vector-length x) 9)
(eq? (vector-ref x 0) output-port-id))))
(define output-port-name
(lambda (p) (vector-ref p 1)))
(define output-port-fd
(lambda (p) (vector-ref p 2)))
(define set-output-port-fd!
(lambda (p x) (vector-set! p 2 x)))
(define output-port-open?
(lambda (p) (vector-ref p 3)))
(define set-output-port-open?!
(lambda (p b) (vector-set! p 3 b)))
(define output-port-buffer
(lambda (p) (vector-ref p 4)))
(define set-output-port-buffer!
(lambda (p b) (vector-set! p 4 b)))
(define output-port-size
(lambda (p) (vector-ref p 5)))
(define output-port-index
(lambda (p) (vector-ref p 6)))
(define output-port-flush-proc
(lambda (p) (vector-ref p 7)))
(define output-port-close-proc
(lambda (p) (vector-ref p 8)))
(define set-output-port-index!
(lambda (p i) (vector-set! p 6 i)))
(define fd->port
(lambda (fd filename)
(vector output-port-id ; id
filename
fd
#t
(make-string 4096)
4096
0
fd-flush-proc
fd-close-proc)))
(define open-output-string
(lambda ()
(vector output-port-id
'*string-port*
'()
#t
(make-string 4096)
4096
0
str-flush-proc
(lambda (port) (void)))))
(define get-output-string
(lambda (p)
(define fill
(lambda (dst src di si sj)
(cond
[(fx= si sj) dst]
[else
(string-set! dst di (string-ref src si))
(fill dst src (fxadd1 di) (fxadd1 si) sj)])))
(unless (output-port? p)
(error 'get-output-string "~s is not an output port" p))
(let ([ls (output-port-fd p)])
(unless (list? ls)
(error 'get-output-string "~s is not an output port" p))
(let f ([ls (reverse ls)] [n 0])
(cond
[(null? ls)
(let ([idx (output-port-index p)]
[buf (output-port-buffer p)])
(let ([str (make-string (fx+ n idx))])
(fill str buf n 0 idx)))]
[else
(let ([buf (car ls)])
(let ([idx (string-length buf)])
(let ([str (f (cdr ls) (fx+ n idx))])
(fill str buf n 0 idx))))])))))
(define open-output-file
(lambda (filename . rest)
(unless (string? filename)
(error 'open-output-file "invalid filename ~s" filename))
(let ([mode
(let ([fst
(cond
[(null? rest) 'error]
[(null? (cdr rest)) (car rest)]
[else
(error 'open-output-file "too many arguments")])]
[mode-map
'([error . 0] [append . 1] [replace . 2] [truncate . 3])])
(cond
[(assq fst mode-map) => cdr]
[else (error 'open-output-file "invalid mode ~s" fst)]))])
(let ([fh (foreign-call "ik_open_file" filename mode)])
(fd->port fh filename)))))
(define write-char
(lambda (c . port)
(let ([port
(cond
[(null? port) (current-output-port)]
[(null? (cdr port))
(let ([p (car port)])
(if (output-port? p)
p
(error 'write-char "not a port: ~s" p)))]
[else
(error 'write-char "too many arguments")])])
(unless (char? c)
(error 'write-char "not a char: ~s" c))
(unless (output-port-open? port)
(error 'write-char "port ~s closed" port))
(let ([idx (output-port-index port)] [size (output-port-size port)])
(if (fx< idx size)
(begin
(string-set! (output-port-buffer port) idx c)
(set-output-port-index! port (fxadd1 idx))
(when (char= c #\newline)
(flush-output-port port)))
(begin
(flush-output-port port)
(write-char c port)))))))
(define fd-flush-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(foreign-call "ik_write"
(output-port-fd port)
idx
(output-port-buffer port))))
(set-output-port-index! port 0)))
(define str-flush-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(let ([str (output-port-buffer port)])
(when (fx= idx (string-length str))
(set-output-port-fd! port
(cons str (output-port-fd port)))
(set-output-port-buffer! port
(make-string (string-length str)))
(set-output-port-index! port 0)))))))
(define fd-close-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(foreign-call "ik_write"
(output-port-fd port)
idx
(output-port-buffer port))))
(foreign-call "ik_close" (output-port-fd port))))
(define flush-output-port
(lambda port
(let ([port
(cond
[(null? port) (current-output-port)]
[(null? (cdr port))
(let ([p (car port)])
(if (output-port? p)
p
(error 'flush-output-port "not a port: ~s" p)))]
[else
(error 'flush-output-port "too many arguments")])])
(unless (output-port-open? port)
(error 'flush-output-port "port ~s closed" port))
((output-port-flush-proc port) port))))
(define close-output-port
(lambda (port)
(unless (output-port? port)
(error 'close-output-port "not a port ~s" port))
(when (output-port-open? port)
((output-port-close-proc port) port)
(set-output-port-open?! port #f))))
;;; init section
(primitive-set! 'close-output-port close-output-port)
(primitive-set! 'output-port? output-port?)
(primitive-set! 'open-output-file open-output-file)
(primitive-set! 'write-char write-char)
(primitive-set! 'flush-output-port flush-output-port)
(primitive-set! 'standard-output-port
(let ([p (fd->port 1 '*stdout*)])
(lambda () p)))
(primitive-set! 'standard-error-port
(let ([p (fd->port 2 '*stderr*)])
(lambda () p)))
(primitive-set! 'current-output-port
(make-parameter (standard-output-port)
(lambda (p)
(unless (output-port? p)
(error 'current-output-port "not a port ~s" p))
p)))
(primitive-set! 'console-output-port
(make-parameter (standard-output-port)
(lambda (p)
(unless (output-port? p)
(error 'console-output-port "not a port ~s" p))
p)))
(primitive-set! 'newline
(lambda args
(if (null? args)
(write-char #\newline (current-output-port))
(if (null? (cdr args))
(let ([p (car args)])
(if (output-port? p)
(write-char #\newline p)
(error 'newline "not an output port ~s" p)))
(error 'newline "too many arguments")))))
(primitive-set! 'open-output-string open-output-string)
(primitive-set! 'get-output-string get-output-string)
(primitive-set! 'output-port-name
(lambda (x)
(if (output-port? x)
(output-port-name x)
(error 'output-port-name "~s is not an output port" x)))))
;;; INPUT PORTS
(let ()
;;; input ports are similar to output ports, with the exception of
;;; the ungetchar buffer
;;; Fields:
;;; 0. id
;;; 1. file-name
;;; 2. file-descriptor
;;; 3. open?
;;; 4. buffer
;;; 5. buffer-size
;;; 6. index
;;; 7. unget
(define input-port-id (gensym "input-port"))
(define input-port?
(lambda (x)
(and (vector? x)
(fx= (vector-length x) 8)
(eq? (vector-ref x 0) input-port-id))))
(define input-port-name
(lambda (x)
(vector-ref x 1)))
(define input-port-fd
(lambda (x)
(vector-ref x 2)))
(define input-port-open?
(lambda (x)
(vector-ref x 3)))
(define input-port-buffer
(lambda (x)
(vector-ref x 4)))
(define input-port-size
(lambda (x)
(vector-ref x 5)))
(define set-input-port-size!
(lambda (x i)
(vector-set! x 5 i)))
(define input-port-index
(lambda (x)
(vector-ref x 6)))
(define set-input-port-index!
(lambda (x i)
(vector-set! x 6 i)))
(define set-input-port-returned-char!
(lambda (x i)
(vector-set! x 7 i)))
(define input-port-returned-char
(lambda (x)
(vector-ref x 7)))
(define fd->port
(lambda (fd filename)
(vector input-port-id
filename
fd
#t
(make-string 4096)
0
0
#f)))
(define open-input-file
(lambda (filename)
(unless (string? filename)
(error 'open-input-file "not a string: ~s" filename))
(let ([fd (foreign-call "ik_open_file" filename 4)])
(fd->port fd filename))))
(define close-input-port
(lambda port
(let ([port
(if (null? port)
(current-input-port)
(if (null? ($cdr port))
(let ([p ($car port)])
(if (input-port? p)
p
(error 'close-input-port "not an input port: ~s" p)))
(error 'close-input-port "too many arguments")))])
(foreign-call "ik_close" (input-port-fd port))
(void))))
(define read-char
(lambda port
(let ([port
(if (null? port)
(current-input-port)
(if (null? ($cdr port))
(let ([p ($car port)])
(if (input-port? p)
p
(error 'read-char "not an input port: ~s" p)))
(error 'read-char "too many arguments")))])
(unless (input-port-open? port)
(error 'read-char "port closed"))
(cond
[(input-port-returned-char port) =>
(lambda (c)
(set-input-port-returned-char! port #f)
c)]
[else
(let ([idx (input-port-index port)]
[size (input-port-size port)]
[buf (input-port-buffer port)])
(if ($fx< idx size)
(let ([c ($string-ref buf idx)])
(set-input-port-index! port ($fxadd1 idx))
c)
(let ([bytes
(foreign-call "ik_read"
(input-port-fd port)
buf
($string-length buf))])
(set-input-port-size! port bytes)
(if ($fxzero? bytes)
(begin
(set-input-port-index! port 0)
(eof-object))
(begin
(let ([c ($string-ref buf 0)])
(set-input-port-index! port 1)
c))))))]))))
(define peek-char
(lambda port
(let ([port
(if (null? port)
(current-input-port)
(if (null? (cdr port))
(let ([p (car port)])
(if (input-port? p)
p
(error 'peek-char "not an input port: ~s" p)))
(error 'peek-char "too many arguments")))])
(unless (input-port-open? port)
(error 'peek-char "port closed"))
(cond
[(input-port-returned-char port) =>
(lambda (c) c)]
[else
(let ([idx (input-port-index port)]
[size (input-port-size port)]
[buf (input-port-buffer port)])
(if (fx< idx size)
(string-ref buf idx)
(let ([bytes
(foreign-call "ik_read"
(input-port-fd port)
buf
($string-length buf))])
(set-input-port-size! port bytes)
(set-input-port-index! port 0)
(if (fxzero? bytes)
(eof-object)
(string-ref buf 0)))))]))))
(define reset-input-port!
(lambda (p)
(unless (input-port? p)
(error 'reset-input-port! "~s is not an input port" p))
(set-input-port-index! p 0)
(set-input-port-size! p 0)
(set-input-port-returned-char! p #f)))
(define unread-char
(lambda (c . port)
(let ([port
(if (null? port)
(current-input-port)
(if (null? (cdr port))
(let ([p (car port)])
(if (input-port? p)
p
(error 'unread-char "not an input port: ~s" p)))
(error 'unread-char "too many arguments")))])
(unless (char? c)
(error 'unread-char "not a character ~s" c))
(unless (input-port-open? port)
(error 'unread-char "port closed"))
(when (input-port-returned-char port)
(error 'unread-char "cannot unread twice"))
(set-input-port-returned-char! port c))))
(primitive-set! 'open-input-file open-input-file)
(primitive-set! 'close-input-port close-input-port)
(primitive-set! 'input-port? input-port?)
(primitive-set! 'read-char read-char)
(primitive-set! 'unread-char unread-char)
(primitive-set! 'peek-char peek-char)
(primitive-set! 'standard-input-port
(let ([p (fd->port 0 '*stdin*)])
(lambda () p)))
(primitive-set! 'current-input-port
(make-parameter (standard-input-port)
(lambda (x)
(unless (input-port? x)
(error 'current-input-port "not an input port ~s" x))
x)))
(primitive-set! 'console-input-port
(make-parameter (standard-input-port)
(lambda (x)
(unless (input-port? x)
(error 'console-input-port "not an input port ~s" x))
x)))
(primitive-set! 'input-port-name
(lambda (x)
(if (input-port? x)
(input-port-name x)
(error 'input-port-name "~s is not an input port" x))))
(primitive-set! 'reset-input-port! reset-input-port!))
(primitive-set! 'with-output-to-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-output-to-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-output-to-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(parameterize ([current-output-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-output-to-file
"cannot reenter")))
proc
(lambda ()
(close-output-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-output-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-output-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-output-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-output-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-output-port p)
(set! shot #t))))))
(primitive-set! 'with-input-from-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-input-from-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "~s is not a procedure" proc))
(let ([p (apply open-input-file name args)]
[shot #f])
(parameterize ([current-input-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-input-from-file
"cannot reenter")))
proc
(lambda ()
(close-input-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-input-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-input-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "~s is not a procedure" proc))
(let ([p (apply open-input-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-input-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-input-port p)
(set! shot #t))))))

497
src/libio-6.1.ss
View File

@ -1,497 +0,0 @@
;;; OUTPUT PORTS
(let ()
;;; only file-based ports are supported at this point
;;;
;;; an output port is a vector with the following fields:
;;; 0. id
;;; 1. file-name
;;; 2. file-descriptor
;;; 3. open?
;;; 4. buffer
;;; 5. buffer-size
;;; 6. index
;;; 7. flush-proc
;;; 8. close-proc
(define output-port-id (gensym "output-port"))
(define output-port?
(lambda (x)
(and (vector? x)
(fx= (vector-length x) 9)
(eq? (vector-ref x 0) output-port-id))))
(define output-port-name
(lambda (p) (vector-ref p 1)))
(define output-port-fd
(lambda (p) (vector-ref p 2)))
(define set-output-port-fd!
(lambda (p x) (vector-set! p 2 x)))
(define output-port-open?
(lambda (p) (vector-ref p 3)))
(define set-output-port-open?!
(lambda (p b) (vector-set! p 3 b)))
(define output-port-buffer
(lambda (p) (vector-ref p 4)))
(define set-output-port-buffer!
(lambda (p b) (vector-set! p 4 b)))
(define output-port-size
(lambda (p) (vector-ref p 5)))
(define output-port-index
(lambda (p) (vector-ref p 6)))
(define output-port-flush-proc
(lambda (p) (vector-ref p 7)))
(define output-port-close-proc
(lambda (p) (vector-ref p 8)))
(define set-output-port-index!
(lambda (p i) (vector-set! p 6 i)))
(define fd->port
(lambda (fd filename)
(vector output-port-id ; id
filename
fd
#t
(make-string 4096)
4096
0
fd-flush-proc
fd-close-proc)))
(define open-output-string
(lambda ()
(vector output-port-id
'*string-port*
'()
#t
(make-string 4096)
4096
0
str-flush-proc
(lambda (port) (void)))))
(define get-output-string
(lambda (p)
(define fill
(lambda (dst src di si sj)
(cond
[(fx= si sj) dst]
[else
(string-set! dst di (string-ref src si))
(fill dst src (fxadd1 di) (fxadd1 si) sj)])))
(unless (output-port? p)
(error 'get-output-string "~s is not an output port" p))
(let ([ls (output-port-fd p)])
(unless (list? ls)
(error 'get-output-string "~s is not an output port" p))
(let f ([ls (reverse ls)] [n 0])
(cond
[(null? ls)
(let ([idx (output-port-index p)]
[buf (output-port-buffer p)])
(let ([str (make-string (fx+ n idx))])
(fill str buf n 0 idx)))]
[else
(let ([buf (car ls)])
(let ([idx (string-length buf)])
(let ([str (f (cdr ls) (fx+ n idx))])
(fill str buf n 0 idx))))])))))
(define open-output-file
(lambda (name mode)
(unless (string? name)
(error 'open-output-file "~s is not a valid file name" name))
(let ([mode
(cond
[(assq mode '([error 0] [append 1] [replace 2] [truncate 3]))
=> cadr]
[else
(error 'open-output-file "~s is not a valid mode" mode)])])
(let ([fh (foreign-call "ik_open_file" name mode)])
(fd->port fh name)))))
(define write-char
(lambda (c port)
(unless (char? c)
(error 'write-char "not a char: ~s" c))
(unless (output-port-open? port)
(error 'write-char "port ~s closed" port))
(let ([idx (output-port-index port)] [size (output-port-size port)])
(if (fx< idx size)
(begin
(string-set! (output-port-buffer port) idx c)
(set-output-port-index! port (fxadd1 idx))
(when ($char= c #\newline)
(flush-output-port port)))
(begin
(flush-output-port port)
(write-char c port))))))
(define fd-flush-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(foreign-call "ik_write"
(output-port-fd port)
idx
(output-port-buffer port))))
(set-output-port-index! port 0)))
(define str-flush-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(let ([str (output-port-buffer port)])
(when (fx= idx (string-length str))
(set-output-port-fd! port
(cons str (output-port-fd port)))
(set-output-port-buffer! port
(make-string (string-length str)))
(set-output-port-index! port 0)))))))
(define fd-close-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(foreign-call "ik_write"
(output-port-fd port)
idx
(output-port-buffer port))))
(foreign-call "ik_close" (output-port-fd port))))
(define flush-output-port
(lambda (port)
(unless (output-port-open? port)
(error 'flush-output-port "port ~s closed" port))
((output-port-flush-proc port) port)))
(define close-output-port
(lambda (port)
(when (output-port-open? port)
((output-port-close-proc port) port)
(set-output-port-open?! port #f))))
;;; init section
(primitive-set! 'close-output-port
(case-lambda
[() (close-output-port (current-output-port))]
[(p)
(unless (output-port? p)
(error 'close-output-port "~s is not an output port" p))
(close-output-port p)]))
(primitive-set! 'output-port? output-port?)
(primitive-set! 'open-output-file
(case-lambda
[(filename) (open-output-file filename 'error)]
[(filename mode) (open-output-file filename mode)]))
(primitive-set! 'write-char
(case-lambda
[(c) (write-char c (current-output-port))]
[(c p)
(unless (output-port? p)
(error 'write-char "~s is not an output port" p))
(write-char c p)]))
(primitive-set! 'flush-output-port
(case-lambda
[() (flush-output-port (current-output-port))]
[(p)
(unless (output-port? p)
(error 'flush-output-port "~s is not an output port" p))
(flush-output-port p)]))
(primitive-set! 'standard-output-port
(let ([p (fd->port 1 '*stdout*)])
(lambda () p)))
(primitive-set! 'standard-error-port
(let ([p (fd->port 2 '*stderr*)])
(lambda () p)))
(primitive-set! 'current-output-port
(make-parameter (standard-output-port)
(lambda (p)
(unless (output-port? p)
(error 'current-output-port "not a port ~s" p))
p)))
(primitive-set! 'console-output-port
(make-parameter (standard-output-port)
(lambda (p)
(unless (output-port? p)
(error 'console-output-port "not a port ~s" p))
p)))
(primitive-set! 'newline
(case-lambda
[() (write-char #\newline (current-output-port))]
[(p)
(unless (output-port? p)
(error 'newline "~s is not an output port" p))
(write-char #\newline p)]))
(primitive-set! 'open-output-string open-output-string)
(primitive-set! 'get-output-string get-output-string)
(primitive-set! 'output-port-name
(lambda (x)
(if (output-port? x)
(output-port-name x)
(error 'output-port-name "~s is not an output port" x)))))
;;; INPUT PORTS
(let ()
;;; input ports are similar to output ports, with the exception of
;;; the ungetchar buffer
;;; Fields:
;;; 0. id
;;; 1. file-name
;;; 2. file-descriptor
;;; 3. open?
;;; 4. buffer
;;; 5. buffer-size
;;; 6. index
;;; 7. unget
(define input-port-id (gensym "input-port"))
(define input-port?
(lambda (x)
(and (vector? x)
(fx= (vector-length x) 8)
(eq? (vector-ref x 0) input-port-id))))
(define input-port-name
(lambda (x)
(vector-ref x 1)))
(define input-port-fd
(lambda (x)
(vector-ref x 2)))
(define input-port-open?
(lambda (x)
(vector-ref x 3)))
(define input-port-buffer
(lambda (x)
(vector-ref x 4)))
(define input-port-size
(lambda (x)
(vector-ref x 5)))
(define set-input-port-size!
(lambda (x i)
(vector-set! x 5 i)))
(define input-port-index
(lambda (x)
(vector-ref x 6)))
(define set-input-port-index!
(lambda (x i)
(vector-set! x 6 i)))
(define set-input-port-returned-char!
(lambda (x i)
(vector-set! x 7 i)))
(define input-port-returned-char
(lambda (x)
(vector-ref x 7)))
(define fd->port
(lambda (fd filename)
(vector input-port-id
filename
fd
#t
(make-string 4096)
0
0
#f)))
(define open-input-file
(lambda (filename)
(unless (string? filename)
(error 'open-input-file "not a string: ~s" filename))
(let ([fd (foreign-call "ik_open_file" filename 4)])
(fd->port fd filename))))
(define close-input-port
(lambda port
(let ([port
(if (null? port)
(current-input-port)
(if (null? ($cdr port))
(let ([p ($car port)])
(if (input-port? p)
p
(error 'close-input-port "not an input port: ~s" p)))
(error 'close-input-port "too many arguments")))])
(foreign-call "ik_close" (input-port-fd port))
(void))))
(define read-char
(lambda (port)
(unless (input-port-open? port)
(error 'read-char "port closed"))
(cond
[(input-port-returned-char port) =>
(lambda (c)
(set-input-port-returned-char! port #f)
c)]
[else
(let ([idx (input-port-index port)]
[size (input-port-size port)]
[buf (input-port-buffer port)])
(if ($fx< idx size)
(let ([c ($string-ref buf idx)])
(set-input-port-index! port ($fxadd1 idx))
c)
(let ([bytes
(foreign-call "ik_read"
(input-port-fd port)
buf
($string-length buf))])
(set-input-port-size! port bytes)
(if ($fxzero? bytes)
(begin
(set-input-port-index! port 0)
(eof-object))
(begin
(let ([c ($string-ref buf 0)])
(set-input-port-index! port 1)
c))))))])))
(define peek-char
(lambda (port)
(unless (input-port-open? port)
(error 'peek-char "port closed"))
(cond
[(input-port-returned-char port) =>
(lambda (c) c)]
[else
(let ([idx (input-port-index port)]
[size (input-port-size port)]
[buf (input-port-buffer port)])
(if (fx< idx size)
(string-ref buf idx)
(let ([bytes
(foreign-call "ik_read"
(input-port-fd port)
buf
($string-length buf))])
(set-input-port-size! port bytes)
(set-input-port-index! port 0)
(if (fxzero? bytes)
(eof-object)
(string-ref buf 0)))))])))
(define reset-input-port!
(lambda (p)
(unless (input-port? p)
(error 'reset-input-port! "~s is not an input port" p))
(set-input-port-index! p 0)
(set-input-port-size! p 0)
(set-input-port-returned-char! p #f)))
(define unread-char
(lambda (c port)
(unless (char? c)
(error 'unread-char "not a character ~s" c))
(unless (input-port-open? port)
(error 'unread-char "port closed"))
(when (input-port-returned-char port)
(error 'unread-char "cannot unread twice"))
(set-input-port-returned-char! port c)))
(primitive-set! 'open-input-file open-input-file)
(primitive-set! 'close-input-port
(case-lambda
[() (close-input-port (current-input-port))]
[(p)
(unless (input-port? p)
(error 'close-input-port "~s is not an input port" p))
(close-input-port p)]))
(primitive-set! 'input-port? input-port?)
(primitive-set! 'read-char
(case-lambda
[() (read-char (current-input-port))]
[(p)
(unless (input-port? p)
(error 'read-char "~s is not an input port" p))
(read-char p)]))
(primitive-set! 'peek-char
(case-lambda
[() (peek-char (current-input-port))]
[(p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(peek-char p)]))
(primitive-set! 'unread-char
(case-lambda
[(c) (unread-char c (current-input-port))]
[(c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(unread-char c p)]))
(primitive-set! 'standard-input-port
(let ([p (fd->port 0 '*stdin*)])
(lambda () p)))
(primitive-set! 'current-input-port
(make-parameter (standard-input-port)
(lambda (x)
(unless (input-port? x)
(error 'current-input-port "not an input port ~s" x))
x)))
(primitive-set! 'console-input-port
(make-parameter (standard-input-port)
(lambda (x)
(unless (input-port? x)
(error 'console-input-port "not an input port ~s" x))
x)))
(primitive-set! 'input-port-name
(lambda (x)
(if (input-port? x)
(input-port-name x)
(error 'input-port-name "~s is not an input port" x))))
(primitive-set! 'reset-input-port! reset-input-port!))
(primitive-set! 'with-output-to-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-output-to-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-output-to-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(parameterize ([current-output-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-output-to-file
"cannot reenter")))
proc
(lambda ()
(close-output-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-output-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-output-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-output-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-output-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-output-port p)
(set! shot #t))))))
(primitive-set! 'with-input-from-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-input-from-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "~s is not a procedure" proc))
(let ([p (apply open-input-file name args)]
[shot #f])
(parameterize ([current-input-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-input-from-file
"cannot reenter")))
proc
(lambda ()
(close-input-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-input-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-input-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "~s is not a procedure" proc))
(let ([p (apply open-input-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-input-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-input-port p)
(set! shot #t))))))

407
src/libio-6.9.ss
View File

@ -1,407 +0,0 @@
;;; OUTPUT PORTS
(let ()
;;; only file-based ports are supported at this point
;;;
;;; an output port is a vector with the following fields:
;;; 0. id
;;; 1. file-name
;;; 2. file-descriptor
;;; 3. open?
;;; 4. buffer
;;; 5. buffer-size
;;; 6. index
;;; 7. flush-proc
;;; 8. close-proc
(define-record output-port
(name fd open?
buffer size index flush-proc close-proc))
(define fd->port
(lambda (fd filename)
(make-output-port filename fd #t
(make-string 4096) 4096 0
fd-flush-proc fd-close-proc)))
(define open-output-string
(lambda ()
(make-output-port '*string-port* '() #t
(make-string 4096) 4096 0
str-flush-proc (lambda (port) (void)))))
(define get-output-string
(lambda (p)
(define fill
(lambda (dst src di si sj)
(cond
[(fx= si sj) dst]
[else
(string-set! dst di (string-ref src si))
(fill dst src (fxadd1 di) (fxadd1 si) sj)])))
(unless (output-port? p)
(error 'get-output-string "~s is not an output port" p))
(let ([ls (output-port-fd p)])
(unless (list? ls)
(error 'get-output-string "~s is not an output port" p))
(let f ([ls (reverse ls)] [n 0])
(cond
[(null? ls)
(let ([idx (output-port-index p)]
[buf (output-port-buffer p)])
(let ([str (make-string (fx+ n idx))])
(fill str buf n 0 idx)))]
[else
(let ([buf (car ls)])
(let ([idx (string-length buf)])
(let ([str (f (cdr ls) (fx+ n idx))])
(fill str buf n 0 idx))))])))))
(define open-output-file
(lambda (name mode)
(unless (string? name)
(error 'open-output-file "~s is not a valid file name" name))
(let ([mode
(cond
[(assq mode '([error 0] [append 1] [replace 2] [truncate 3]))
=> cadr]
[else
(error 'open-output-file "~s is not a valid mode" mode)])])
(let ([fh (foreign-call "ik_open_file" name mode)])
(fd->port fh name)))))
(define write-char
(lambda (c port)
(unless (char? c)
(error 'write-char "not a char: ~s" c))
(unless (output-port-open? port)
(error 'write-char "port ~s closed" port))
(let ([idx (output-port-index port)] [size (output-port-size port)])
(if (fx< idx size)
(begin
(string-set! (output-port-buffer port) idx c)
(set-output-port-index! port (fxadd1 idx))
(when ($char= c #\newline)
(flush-output-port port)))
(begin
(flush-output-port port)
(write-char c port))))))
(define fd-flush-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(foreign-call "ik_write"
(output-port-fd port)
idx
(output-port-buffer port))))
(set-output-port-index! port 0)))
(define str-flush-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(let ([str (output-port-buffer port)])
(when (fx= idx (string-length str))
(set-output-port-fd! port
(cons str (output-port-fd port)))
(set-output-port-buffer! port
(make-string (string-length str)))
(set-output-port-index! port 0)))))))
(define fd-close-proc
(lambda (port)
(let ([idx (output-port-index port)])
(when (fx> idx 0)
(foreign-call "ik_write"
(output-port-fd port)
idx
(output-port-buffer port))))
(foreign-call "ik_close" (output-port-fd port))))
(define flush-output-port
(lambda (port)
(unless (output-port-open? port)
(error 'flush-output-port "port ~s closed" port))
((output-port-flush-proc port) port)))
(define close-output-port
(lambda (port)
(when (output-port-open? port)
((output-port-close-proc port) port)
(set-output-port-open?! port #f))))
;;; init section
(primitive-set! 'close-output-port
(case-lambda
[() (close-output-port (current-output-port))]
[(p)
(unless (output-port? p)
(error 'close-output-port "~s is not an output port" p))
(close-output-port p)]))
(primitive-set! 'output-port? output-port?)
(primitive-set! 'open-output-file
(case-lambda
[(filename) (open-output-file filename 'error)]
[(filename mode) (open-output-file filename mode)]))
(primitive-set! 'write-char
(case-lambda
[(c) (write-char c (current-output-port))]
[(c p)
(unless (output-port? p)
(error 'write-char "~s is not an output port" p))
(write-char c p)]))
(primitive-set! 'flush-output-port
(case-lambda
[() (flush-output-port (current-output-port))]
[(p)
(unless (output-port? p)
(error 'flush-output-port "~s is not an output port" p))
(flush-output-port p)]))
(primitive-set! 'standard-output-port
(let ([p (fd->port 1 '*stdout*)])
(lambda () p)))
(primitive-set! 'standard-error-port
(let ([p (fd->port 2 '*stderr*)])
(lambda () p)))
(primitive-set! 'current-output-port
(make-parameter (standard-output-port)
(lambda (p)
(unless (output-port? p)
(error 'current-output-port "not a port ~s" p))
p)))
(primitive-set! 'console-output-port
(make-parameter (standard-output-port)
(lambda (p)
(unless (output-port? p)
(error 'console-output-port "not a port ~s" p))
p)))
(primitive-set! 'newline
(case-lambda
[() (write-char #\newline (current-output-port))]
[(p)
(unless (output-port? p)
(error 'newline "~s is not an output port" p))
(write-char #\newline p)]))
(primitive-set! 'open-output-string open-output-string)
(primitive-set! 'get-output-string get-output-string)
(primitive-set! 'output-port-name
(lambda (x)
(if (output-port? x)
(output-port-name x)
(error 'output-port-name "~s is not an output port" x)))))
;;; INPUT PORTS
(let ()
;;; input ports are similar to output ports, with the exception of
;;; the ungetchar buffer
;;; Fields:
;;; 0. id
;;; 1. file-name
;;; 2. file-descriptor
;;; 3. open?
;;; 4. buffer
;;; 5. buffer-size
;;; 6. index
;;; 7. unget
(define-record input-port
(name fd open? buffer size index returned-char))
(define fd->port
(lambda (fd filename)
(make-input-port filename fd #t (make-string 4096) 0 0 #f)))
(define open-input-file
(lambda (filename)
(unless (string? filename)
(error 'open-input-file "not a string: ~s" filename))
(let ([fd (foreign-call "ik_open_file" filename 4)])
(fd->port fd filename))))
(define close-input-port
(lambda (port)
(foreign-call "ik_close" (input-port-fd port))
(set-input-port-open?! port #f)
(set-input-port-returned-char! port #f)
(set-input-port-index! port (input-port-size port))))
(define read-char
(lambda (port)
(if (input-port-returned-char port)
(let ([c (input-port-returned-char port)])
(set-input-port-returned-char! port #f)
c)
(let ([index (input-port-index port)])
(if ($fx< index (input-port-size port))
(begin
(set-input-port-index! port ($fxadd1 index))
($string-ref (input-port-buffer port) index))
(if (input-port-open? port)
(let* ([buffer (input-port-buffer port)]
[bytes
(foreign-call "ik_read"
(input-port-fd port)
buffer
($string-length buffer))])
(set-input-port-size! port bytes)
(if ($fxzero? bytes)
(begin
(set-input-port-index! port 0)
(eof-object))
(let ([c ($string-ref buffer 0)])
(set-input-port-index! port 1)
c)))
(error 'read-char "input port ~s is not open" port)))))))
(define peek-char
(lambda (port)
(unless (input-port-open? port)
(error 'peek-char "port closed"))
(cond
[(input-port-returned-char port) =>
(lambda (c) c)]
[else
(let ([idx (input-port-index port)]
[size (input-port-size port)]
[buf (input-port-buffer port)])
(if (fx< idx size)
(string-ref buf idx)
(let ([bytes
(foreign-call "ik_read"
(input-port-fd port)
buf
($string-length buf))])
(set-input-port-size! port bytes)
(set-input-port-index! port 0)
(if (fxzero? bytes)
(eof-object)
(string-ref buf 0)))))])))
(define reset-input-port!
(lambda (p)
(unless (input-port? p)
(error 'reset-input-port! "~s is not an input port" p))
(set-input-port-index! p 0)
(set-input-port-size! p 0)
(set-input-port-returned-char! p #f)))
(define unread-char
(lambda (c port)
(unless (char? c)
(error 'unread-char "not a character ~s" c))
(unless (input-port-open? port)
(error 'unread-char "port closed"))
(when (input-port-returned-char port)
(error 'unread-char "cannot unread twice"))
(set-input-port-returned-char! port c)))
(define *current-input-port* #f)
(primitive-set! 'open-input-file open-input-file)
(primitive-set! 'close-input-port
(case-lambda
[() (close-input-port *current-input-port*)]
[(p)
(unless (input-port? p)
(error 'close-input-port "~s is not an input port" p))
(close-input-port p)]))
(primitive-set! 'input-port? input-port?)
(primitive-set! 'read-char
(case-lambda
[() (read-char *current-input-port*)]
[(p) (if (input-port? p)
(read-char p)
(error 'read-char "~s is not an input-port" p))]))
(primitive-set! 'peek-char
(case-lambda
[() (peek-char *current-input-port*)]
[(p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(peek-char p)]))
(primitive-set! 'unread-char
(case-lambda
[(c) (unread-char c *current-input-port*)]
[(c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(unread-char c p)]))
(primitive-set! 'standard-input-port
(let ([p (fd->port 0 '*stdin*)])
(lambda () p)))
(set! *current-input-port* (standard-input-port))
(primitive-set! 'current-input-port
(case-lambda
[() *current-input-port*]
[(x) (if (input-port? x)
(set! *current-input-port* x)
(error 'current-input-port "~s is not an input port" x))]))
(primitive-set! 'console-input-port
(make-parameter (standard-input-port)
(lambda (x)
(unless (input-port? x)
(error 'console-input-port "not an input port ~s" x))
x)))
(primitive-set! 'input-port-name
(lambda (x)
(if (input-port? x)
(input-port-name x)
(error 'input-port-name "~s is not an input port" x))))
(primitive-set! 'reset-input-port! reset-input-port!))
(primitive-set! 'with-output-to-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-output-to-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-output-to-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(parameterize ([current-output-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-output-to-file
"cannot reenter")))
proc
(lambda ()
(close-output-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-output-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-output-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-output-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-output-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-output-port p)
(set! shot #t))))))
(primitive-set! 'with-input-from-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-input-from-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "~s is not a procedure" proc))
(let ([p (apply open-input-file name args)]
[shot #f])
(parameterize ([current-input-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-input-from-file
"cannot reenter")))
proc
(lambda ()
(close-input-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-input-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-input-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "~s is not a procedure" proc))
(let ([p (apply open-input-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-input-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-input-port p)
(set! shot #t))))))

BIN
src/libio.fasl
View File

Binary file not shown.

53
src/libnumerics-7.1.ss
View File

@ -1,53 +0,0 @@
(let ()
(define (generic+ a b)
(cond
[(fixnum? a)
(cond
[(fixnum? b) (foreign-call "iknum_add_fx_fx" a b)]
[(bignum? b) (foreign-call "iknum_add_fx_bn" a b)]
[else (error '+ "~s is not a number" b)])]
[(bignum? a)
(cond
[(fixnum? b) (foreign-call "iknum_add_fx_bn" b a)]
[(bignum? b) (foreign-call "iknum_add_bn_bn" a b)]
[else (error '+ "~s is not a number" b)])]
[else (error '+ "~s is not a number" a)]))
(primitive-set! '+
(case-lambda
[(a b) (generic+ a b)]
[(a b c) (generic+ a (generic+ b c))]
[(a) (if (number? a) a (error '+ "~s is not a number" a))]
[() 0]
[(a b . rest)
(let f ([a a] [b b] [rest rest])
(generic+ a
(if (null? rest)
b
(f b ($car rest) ($cdr rest)))))]))
(primitive-set! 'add1
(lambda (a)
(cond
[(fixnum? a)
(if ($fx< a (most-positive-fixnum))
($fxadd1 a)
(foreign-call "iknum_add_fx_fx" a 1))]
[(bignum? a)
(foreign-call "iknum_add_fx_bn" 1 a)]
[else (error 'add1 "~s is not a number" a)])))
(primitive-set! 'sub1
(lambda (a)
(cond
[(fixnum? a)
(if ($fx> a (most-negative-fixnum))
($fxsub1 a)
(foreign-call "iknum_add_fx_fx" a -1))]
[(bignum? a)
(foreign-call "iknum_add_fx_bn" -1 a)]
[else (error 'add1 "~s is not a number" a)])))
)

376
src/libnumerics-9.1.ss Normal file
View File

@ -0,0 +1,376 @@
(let ()
(define bignum?
; FIXME: temporary definition. Compiler should be made aware
; of numeric representation once it's stable enough.
(lambda (x)
(foreign-call "ikrt_isbignum" x)))
(define binary+
(lambda (x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_fxfxplus" x y)]
[(bignum? y)
(foreign-call "ikrt_fxbnplus" x y)]
[else
(error '+ "~s is not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_fxbnplus" y x)]
[(bignum? y)
(foreign-call "ikrt_bnbnplus" x y)]
[else
(error '+ "~s is not a number" y)])]
[else (error '+ "~s is not a number" x)])))
(define binary-logand
(lambda (x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y) (#%$fxlogand x y)]
[(bignum? y)
(foreign-call "ikrt_fxbnlogand" x y)]
[else
(error 'logand "~s is not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_fxbnlogand" y x)]
[(bignum? y)
(foreign-call "ikrt_bnbnlogand" x y)]
[else
(error 'logand "~s is not a number" y)])]
[else (error 'logand "~s is not a number" x)])))
(define binary-
(lambda (x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_fxfxminus" x y)]
[(bignum? y)
(foreign-call "ikrt_fxbnminus" x y)]
[else
(error '- "~s is not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_bnfxminus" x y)]
[(bignum? y)
(foreign-call "ikrt_bnbnminus" x y)]
[else
(error '- "~s is not a number" y)])]
[else (error '- "~s is not a number" x)])))
(define binary*
(lambda (x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_fxfxmult" x y)]
[(bignum? y)
(foreign-call "ikrt_fxbnmult" x y)]
[else
(error '* "~s is not a number" y)])]
[(bignum? x)
(cond
[(fixnum? y)
(foreign-call "ikrt_fxbnmult" y x)]
[(bignum? y)
(foreign-call "ikrt_bnbnmult" x y)]
[else
(error '* "~s is not a number" y)])]
[else (error '* "~s is not a number" x)])))
(define +
(case-lambda
[(x y) (binary+ x y)]
[(x y z) (binary+ (binary+ x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (error '+ "~s is not a number" a)])]
[() 0]
[(a b c d . e*)
(let f ([ac (binary+ (binary+ (binary+ a b) c) d)]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary+ ac (car e*)) (cdr e*))]))]))
(define logand
(case-lambda
[(x y) (binary-logand x y)]
[(x y z) (binary-logand (binary-logand x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (error 'logand "~s is not a number" a)])]
[() -1]
[(a b c d . e*)
(let f ([ac (binary-logand (binary-logand (binary-logand a b) c) d)]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary-logand ac (car e*)) (cdr e*))]))]))
(define -
(case-lambda
[(x y) (binary- x y)]
[(x y z) (binary- (binary- x y) z)]
[(a) (binary- 0 a)]
[(a b c d . e*)
(let f ([ac (binary- (binary- (binary- a b) c) d)]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary- ac (car e*)) (cdr e*))]))]))
(define *
(case-lambda
[(x y) (binary* x y)]
[(x y z) (binary* (binary* x y) z)]
[(a)
(cond
[(fixnum? a) a]
[(bignum? a) a]
[else (error '* "~s is not a number" a)])]
[() 1]
[(a b c d . e*)
(let f ([ac (binary* (binary* (binary* a b) c) d)]
[e* e*])
(cond
[(null? e*) ac]
[else (f (binary* ac (car e*)) (cdr e*))]))]))
(define expt
(lambda (n m)
(cond
[(#%$fxzero? m) 1]
[(#%$fxzero? (#%$fxlogand m 1))
(expt (binary* n n) (#%$fxsra m 1))]
[else
(binary* n (expt (binary* n n) (#%$fxsra m 1)))])))
(define number?
(lambda (x)
(or (fixnum? x)
(bignum? x))))
(define positive-bignum?
(lambda (x)
(foreign-call "ikrt_positive_bn" x)))
(define even-bignum?
(lambda (x) (error 'even-bignum? "not implemented")))
(define number->string
(lambda (x)
(cond
[(fixnum? x) (fixnum->string x)]
[(bignum? x) (foreign-call "ikrt_bntostring" x)]
[else (error 'number->string "~s is not a number" x)])))
(define-syntax mk<
(syntax-rules ()
[(_ name fxfx< fxbn< bnfx< bnbn<)
(let ()
(define err
(lambda (x) (error 'name "~s is not a number" x)))
(define fxloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(fxfx< x y)
(if (fxfx< x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(fxbn< x y)
(if (fxbn< x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[else (err y)])))
(define bnloopt
(lambda (x y ls)
(cond
[(fixnum? y)
(if (null? ls)
(bnfx< x y)
(if (bnfx< x y)
(fxloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(bignum? y)
(if (null? ls)
(bnbn< x y)
(if (bnbn< x y)
(bnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[else (err y)])))
(define loopf
(lambda (x ls)
(cond
[(number? x)
(or (null? ls) (loopf (car ls) (cdr ls)))]
[else (err x)])))
(case-lambda
[(x y)
(cond
[(fixnum? x)
(cond
[(fixnum? y) (fxfx< x y)]
[(bignum? y) (fxbn< x y)]
[else (err y)])]
[(bignum? x)
(cond
[(fixnum? y) (bnfx< x y)]
[(bignum? y) (bnbn< x y)]
[else (err y)])]
[else (err x)])]
[(x y z)
(cond
[(fixnum? x)
(cond
[(fixnum? y)
(cond
[(fixnum? z) (and (fxfx< x y) (fxfx< y z))]
[(bignum? z)
(and (fxfx< x y) (fxbn< y z))]
[else (err z)])]
[(bignum? y)
(cond
[(fixnum? z) #f]
[(bignum? z)
(and (fxbn< x y) (bnbn< y z))]
[else (err z)])]
[else (err y)])]
[(bignum? x)
(cond
[(fixnum? y)
(cond
[(fixnum? z) (and (fxfx< y z) (bnfx< x y))]
[(bignum? z)
(and (bnfx< x y) (bnfx< y z))]
[else (err z)])]
[(bignum? y)
(cond
[(fixnum? z) (and (bnfx< y z) (bnbn< x y))]
[(bignum? z) (and (bnbn< x y) (bnbn< y z))]
[else (err z)])]
[else (err y)])]
[else (err x)])]
[(x) (if (number? x) #t (err x))]
[(x y . ls)
(cond
[(fixnum? x) (fxloopt x y ls)]
[(bignum? x) (bnloopt x y ls)]
[else (err x)])]))]))
(define-syntax false (syntax-rules () [(_ x y) #f]))
(define-syntax bnbncmp
(syntax-rules ()
[(_ x y cmp)
(cmp (foreign-call "ikrt_bnbncomp" x y) 0)]))
(define-syntax bnbn= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx=)]))
(define-syntax bnbn< (syntax-rules () [(_ x y) (bnbncmp x y #%$fx<)]))
(define-syntax bnbn> (syntax-rules () [(_ x y) (bnbncmp x y #%$fx>)]))
(define-syntax bnbn<= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx<=)]))
(define-syntax bnbn>= (syntax-rules () [(_ x y) (bnbncmp x y #%$fx>=)]))
(define-syntax fxbn< (syntax-rules () [(_ x y) (positive-bignum? y)]))
(define-syntax bnfx< (syntax-rules () [(_ x y) (not (positive-bignum? x))]))
(define-syntax fxbn> (syntax-rules () [(_ x y) (not (positive-bignum? y))]))
(define-syntax bnfx> (syntax-rules () [(_ x y) (positive-bignum? x)]))
(primitive-set! '+ +)
(primitive-set! '- -)
(primitive-set! '* *)
(primitive-set! '= (mk< = #%$fx= false false bnbn=))
(primitive-set! '< (mk< < #%$fx< fxbn< bnfx< bnbn<))
(primitive-set! '> (mk< > #%$fx> fxbn> bnfx> bnbn>))
(primitive-set! '<= (mk< <= #%$fx<= fxbn< bnfx< bnbn<=))
(primitive-set! '>= (mk< >= #%$fx>= fxbn> bnfx> bnbn>=))
(primitive-set! 'logand logand)
(primitive-set! 'number? number?)
(primitive-set! 'number->string number->string)
(primitive-set! 'add1
(lambda (x)
(cond
[(fixnum? x)
(foreign-call "ikrt_fxfxplus" x 1)]
[(bignum? x)
(foreign-call "ikrt_fxbnplus" 1 x)]
[else (error 'add1 "~s is not a number" x)])))
(primitive-set! 'sub1
(lambda (x)
(cond
[(fixnum? x)
(foreign-call "ikrt_fxfxplus" x -1)]
[(bignum? x)
(foreign-call "ikrt_fxbnplus" -1 x)]
[else (error 'sub1 "~s is not a number" x)])))
(primitive-set! 'zero?
(lambda (x)
(cond
[(fixnum? x) (eq? x 0)]
[(bignum? x) #f]
[else (error 'zero? "~s is not a number" x)])))
(primitive-set! 'expt
(lambda (n m)
(unless (number? n)
(error 'expt "~s is not a numebr" n))
(cond
[(fixnum? m)
(if (#%$fx>= m 0)
(expt n m)
(error 'expt "power should be positive, got ~s" m))]
[(bignum? m)
(cond
[(eq? n 0) 0]
[(eq? n 1) 1]
[(eq? n -1)
(if (positive-bignum? m)
(if (even-bignum? m)
1
-1)
(error 'expt "power should be positive, got ~s" m))]
[else
(if (positive-bignum? m)
(error 'expt "(expt ~s ~s) is too big to compute" n m)
(error 'expt "power should be positive, got ~s" m))])]
[else (error 'expt "~s is not a number" m)])))
(primitive-set! 'positive?
(lambda (x)
(cond
[(fixnum? x) (#%$fx> x 0)]
[(bignum? x) (positive-bignum? x)]
[else (error 'positive? "~s is not a number" x)])))
(primitive-set! 'negative?
(lambda (x)
(cond
[(fixnum? x) (#%$fx< x 0)]
[(bignum? x) (not (positive-bignum? x))]
[else (error 'negative? "~s is not a number" x)])))
)

228
src/librecord-6.0.ss
View File

@ -1,228 +0,0 @@
(let ()
(define record-type-rtd
(let ([rtd ($make-record #f 4)])
($record-set! rtd -1 rtd)
($record-set! rtd 0 "record-type")
($record-set! rtd 1 4)
($record-set! rtd 2 '(name length fields printer))
($record-set! rtd 3 #f)
rtd))
(define rtd?
(lambda (x)
(and ($record? x)
(eq? ($record-rtd x) record-type-rtd))))
(define rtd-name
(lambda (rtd)
($record-ref rtd 0)))
(define rtd-length
(lambda (rtd)
($record-ref rtd 1)))
(define rtd-fields
(lambda (rtd)
($record-ref rtd 2)))
(define rtd-printer
(lambda (rtd)
($record-ref rtd 3)))
(define set-rtd-name!
(lambda (rtd name)
($record-set! rtd 0 name)))
(define set-rtd-length!
(lambda (rtd n)
($record-set! rtd 1 n)))
(define set-rtd-fields!
(lambda (rtd fields)
($record-set! rtd 2 fields)))
(define set-rtd-printer!
(lambda (rtd printer)
($record-set! rtd 3 printer)))
(define make-rtd
(lambda (name fields printer)
(let ([rtd ($make-record record-type-rtd 4)])
($record-set! rtd 0 name)
($record-set! rtd 1 (length fields))
($record-set! rtd 2 fields)
($record-set! rtd 3 printer)
rtd)))
(define verify-field
(lambda (x)
(unless (symbol? x)
(error 'make-record-type "~s is not a valid field name" x))))
(define set-fields
(lambda (r f* i n)
(cond
[(null? f*)
(if ($fx= i n)
r
#f)]
[($fx< i n)
(if (null? f*)
#f
(begin
($record-set! r i ($car f*))
(set-fields r ($cdr f*) ($fxadd1 i) n)))]
[else #f])))
(define make-record-type
(lambda (name fields)
(unless (string? name)
(error 'make-record-type "name must be a string, got ~s" name))
(unless (list? fields)
(error 'make-record-type "fields must be a list, got ~s" fields))
(for-each verify-field fields)
(make-rtd name fields #f)))
(define record-constructor
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-constructor "~s is not an rtd"))
(lambda args
(let ([n (rtd-length rtd)])
(let ([r ($make-record rtd n)])
(or (set-fields r args 0 n)
(error 'record-constructor
"incorrect number of arguments to the constructor of ~s"
rtd)))))))
(define record-predicate
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-predicate "~s is not an rtd"))
(lambda (x)
(and ($record? x)
(eq? ($record-rtd x) rtd)))))
(define field-index
(lambda (i rtd who)
(cond
[(fixnum? i)
(unless (and ($fx>= i 0) ($fx< i (rtd-length rtd)))
(error who "~s is out of range for rtd ~s" rtd))
i]
[(symbol? i)
(letrec ([lookup
(lambda (n ls)
(cond
[(null? ls)
(error who "~s is not a field in ~s" rtd)]
[(eq? i ($car ls)) n]
[else (lookup ($fx+ n 1) ($cdr ls))]))])
(lookup 0 (rtd-fields rtd)))]
[else (error who "~s is not a valid index" i)])))
(define record-field-accessor
(lambda (rtd i)
(unless (rtd? rtd)
(error 'record-field-accessor "~s is not an rtd" rtd))
(let ([i (field-index i rtd 'record-field-accessor)])
(lambda (x)
(unless (and ($record? x)
(eq? ($record-rtd x) rtd))
(error 'record-field-accessor "~s is not of type ~s" x rtd))
($record-ref x i)))))
(define record-field-mutator
(lambda (rtd i)
(unless (rtd? rtd)
(error 'record-field-mutator "~s is not an rtd" rtd))
(let ([i (field-index i rtd 'record-field-mutator)])
(lambda (x v)
(unless (and ($record? x)
(eq? ($record-rtd x) rtd))
(error 'record-field-mutator "~s is not of type ~s" x rtd))
($record-set! x i v)))))
(define record?
(lambda (x . rest)
(if (null? rest)
($record? x)
(let ([rtd ($car rest)])
(unless (null? ($cdr rest))
(error 'record? "too many arguments"))
(unless (rtd? rtd)
(error 'record? "~s is not an rtd"))
(and ($record? x)
(eq? ($record-rtd x) rtd))))))
(define record-rtd
(lambda (x)
(if ($record? x)
($record-rtd x)
(error 'record-rtd "~s is not a record" x))))
(define record-length
(lambda (x)
(if ($record? x)
(rtd-length ($record-rtd x))
(error 'record-length "~s is not a record" x))))
(define record-name
(lambda (x)
(if ($record? x)
(rtd-name ($record-rtd x))
(error 'record-name "~s is not a record" x))))
(define record-printer
(lambda (x)
(if ($record? x)
(rtd-printer ($record-rtd x))
(error 'record-printer "~s is not a record" x))))
(define record-ref
(lambda (x i)
(unless ($record? x) (error 'record-ref "~s is not a record" x))
(unless (fixnum? i) (error 'record-ref "~s is not a valid index" i))
(let ([n (rtd-length ($record-rtd x))])
(unless (and ($fx>= i 0) ($fx< i n))
(error 'record-ref "index ~s is out of range for ~s" i x))
($record-ref x i))))
(define record-set!
(lambda (x i v)
(unless ($record? x) (error 'record-set! "~s is not a record" x))
(unless (fixnum? i) (error 'record-set! "~s is not a valid index" i))
(let ([n (rtd-length ($record-rtd x))])
(unless (and ($fx>= i 0) ($fx< i n))
(error 'record-set! "index ~s is out of range for ~s" i x))
($record-set! x i v))))
(primitive-set! 'make-record-type make-record-type)
(primitive-set! 'record-constructor record-constructor)
(primitive-set! 'record-predicate record-predicate)
(primitive-set! 'record-field-accessor record-field-accessor)
(primitive-set! 'record-field-mutator record-field-mutator)
(primitive-set! 'record? record?)
(primitive-set! 'record-rtd record-rtd)
(primitive-set! 'record-name record-name)
(primitive-set! 'record-printer record-printer)
(primitive-set! 'record-length record-length)
(primitive-set! 'record-ref record-ref)
(primitive-set! 'record-set! record-set!)
(set-rtd-printer! record-type-rtd
(lambda (x p)
(unless (rtd? x)
(error 'record-type-printer "not an rtd"))
(display "#<" p)
(display (rtd-name x) p)
(display " rtd>" p)))
)

222
src/librecord-6.1.ss
View File

@ -1,222 +0,0 @@
(let ()
(define rtd?
(lambda (x)
(and ($record? x)
(eq? ($record-rtd x) $base-rtd))))
(define rtd-name
(lambda (rtd)
($record-ref rtd 0)))
(define rtd-length
(lambda (rtd)
($record-ref rtd 1)))
(define rtd-fields
(lambda (rtd)
($record-ref rtd 2)))
(define rtd-printer
(lambda (rtd)
($record-ref rtd 3)))
(define set-rtd-name!
(lambda (rtd name)
($record-set! rtd 0 name)))
(define set-rtd-length!
(lambda (rtd n)
($record-set! rtd 1 n)))
(define set-rtd-fields!
(lambda (rtd fields)
($record-set! rtd 2 fields)))
(define set-rtd-printer!
(lambda (rtd printer)
($record-set! rtd 3 printer)))
(define make-rtd
(lambda (name fields printer)
(let ([rtd ($make-record $base-rtd 4)])
($record-set! rtd 0 name)
($record-set! rtd 1 (length fields))
($record-set! rtd 2 fields)
($record-set! rtd 3 printer)
rtd)))
(define verify-field
(lambda (x)
(unless (symbol? x)
(error 'make-record-type "~s is not a valid field name" x))))
(define set-fields
(lambda (r f* i n)
(cond
[(null? f*)
(if ($fx= i n)
r
#f)]
[($fx< i n)
(if (null? f*)
#f
(begin
($record-set! r i ($car f*))
(set-fields r ($cdr f*) ($fxadd1 i) n)))]
[else #f])))
(define make-record-type
(lambda (name fields)
(unless (string? name)
(error 'make-record-type "name must be a string, got ~s" name))
(unless (list? fields)
(error 'make-record-type "fields must be a list, got ~s" fields))
(for-each verify-field fields)
(make-rtd name fields #f)))
(define record-constructor
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-constructor "~s is not an rtd"))
(lambda args
(let ([n (rtd-length rtd)])
(let ([r ($make-record rtd n)])
(or (set-fields r args 0 n)
(error 'record-constructor
"incorrect number of arguments to the constructor of ~s"
rtd)))))))
(define record-predicate
(lambda (rtd)
(unless (rtd? rtd)
(error 'record-predicate "~s is not an rtd"))
(lambda (x)
(and ($record? x)
(eq? ($record-rtd x) rtd)))))
(define field-index
(lambda (i rtd who)
(cond
[(fixnum? i)
(unless (and ($fx>= i 0) ($fx< i (rtd-length rtd)))
(error who "~s is out of range for rtd ~s" rtd))
i]
[(symbol? i)
(letrec ([lookup
(lambda (n ls)
(cond
[(null? ls)
(error who "~s is not a field in ~s" rtd)]
[(eq? i ($car ls)) n]
[else (lookup ($fx+ n 1) ($cdr ls))]))])
(lookup 0 (rtd-fields rtd)))]
[else (error who "~s is not a valid index" i)])))
(define record-field-accessor
(lambda (rtd i)
(unless (rtd? rtd)
(error 'record-field-accessor "~s is not an rtd" rtd))
(let ([i (field-index i rtd 'record-field-accessor)])
(lambda (x)
(unless (and ($record? x)
(eq? ($record-rtd x) rtd))
(error 'record-field-accessor "~s is not of type ~s" x rtd))
($record-ref x i)))))
(define record-field-mutator
(lambda (rtd i)
(unless (rtd? rtd)
(error 'record-field-mutator "~s is not an rtd" rtd))
(let ([i (field-index i rtd 'record-field-mutator)])
(lambda (x v)
(unless (and ($record? x)
(eq? ($record-rtd x) rtd))
(error 'record-field-mutator "~s is not of type ~s" x rtd))
($record-set! x i v)))))
(define record?
(lambda (x . rest)
(if (null? rest)
($record? x)
(let ([rtd ($car rest)])
(unless (null? ($cdr rest))
(error 'record? "too many arguments"))
(unless (rtd? rtd)
(error 'record? "~s is not an rtd"))
(and ($record? x)
(eq? ($record-rtd x) rtd))))))
(define record-rtd
(lambda (x)
(if ($record? x)
($record-rtd x)
(error 'record-rtd "~s is not a record" x))))
(define record-length
(lambda (x)
(if ($record? x)
(rtd-length ($record-rtd x))
(error 'record-length "~s is not a record" x))))
(define record-name
(lambda (x)
(if ($record? x)
(rtd-name ($record-rtd x))
(error 'record-name "~s is not a record" x))))
(define record-printer
(lambda (x)
(if ($record? x)
(rtd-printer ($record-rtd x))
(error 'record-printer "~s is not a record" x))))
(define record-ref
(lambda (x i)
(unless ($record? x) (error 'record-ref "~s is not a record" x))
(unless (fixnum? i) (error 'record-ref "~s is not a valid index" i))
(let ([n (rtd-length ($record-rtd x))])
(unless (and ($fx>= i 0) ($fx< i n))
(error 'record-ref "index ~s is out of range for ~s" i x))
($record-ref x i))))
(define record-set!
(lambda (x i v)
(unless ($record? x) (error 'record-set! "~s is not a record" x))
(unless (fixnum? i) (error 'record-set! "~s is not a valid index" i))
(let ([n (rtd-length ($record-rtd x))])
(unless (and ($fx>= i 0) ($fx< i n))
(error 'record-set! "index ~s is out of range for ~s" i x))
($record-set! x i v))))
(primitive-set! 'make-record-type make-record-type)
(primitive-set! 'record-constructor record-constructor)
(primitive-set! 'record-predicate record-predicate)
(primitive-set! 'record-field-accessor record-field-accessor)
(primitive-set! 'record-field-mutator record-field-mutator)
(primitive-set! 'record? record?)
(primitive-set! 'record-rtd record-rtd)
(primitive-set! 'record-name record-name)
(primitive-set! 'record-printer record-printer)
(primitive-set! 'record-length record-length)
(primitive-set! 'record-ref record-ref)
(primitive-set! 'record-set! record-set!)
(set-rtd-fields! $base-rtd '(name fields length printer))
(set-rtd-name! $base-rtd "base-rtd")
(set-rtd-printer! $base-rtd
(lambda (x p)
(unless (rtd? x)
(error 'record-type-printer "not an rtd"))
(display "#<" p)
(display (rtd-name x) p)
(display " rtd>" p)))
)

BIN
src/librecord.fasl
View File

Binary file not shown.

2
src/libtokenizer-6.1.ss
View File

@ -359,7 +359,7 @@
(read-char p)
'(macro . unquote-splicing)]
[else '(macro . unquote)]))]
[($char= #\# c) (tokenize-hash p)]
[($char= #\# c) (tokenize-hash p)]
[(digit? c)
(cons 'datum (tokenize-number (char->num c) p))]
[(initial? c)

374
src/libtokenizer-6.0.ss → src/libtokenizer-9.0.ss
View File

@ -1,7 +1,7 @@
(let ()
(define char-whitespace?
(lambda (c)
(or (char= #\space c)
(or ($char= #\space c)
(memq ($char->fixnum c) '(9 10 11 12 13)))))
(define delimiter?
(lambda (c)
@ -9,7 +9,7 @@
(memq c '(#\( #\) #\[ #\] #\' #\` #\, #\")))))
(define digit?
(lambda (c)
(and (char<= #\0 c) (char<= c #\9))))
(and ($char<= #\0 c) ($char<= c #\9))))
(define char->num
(lambda (c)
(fx- ($char->fixnum c) ($char->fixnum #\0))))
@ -18,15 +18,15 @@
(or (letter? c) (special-initial? c))))
(define letter?
(lambda (c)
(or (and (char<= #\a c) (char<= c #\z))
(and (char<= #\A c) (char<= c #\Z)))))
(or (and ($char<= #\a c) ($char<= c #\z))
(and ($char<= #\A c) ($char<= c #\Z)))))
(define af?
(lambda (c)
(or (and (char<= #\a c) (char<= c #\f))
(and (char<= #\A c) (char<= c #\F)))))
(or (and ($char<= #\a c) ($char<= c #\f))
(and ($char<= #\A c) ($char<= c #\F)))))
(define af->num
(lambda (c)
(if (and (char<= #\a c) (char<= c #\f))
(if (and ($char<= #\a c) ($char<= c #\f))
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
(define special-initial?
@ -77,9 +77,9 @@
(cons 'datum (tokenize-hex (char->num c) p))]
[(af? c)
(cons 'datum (tokenize-hex (af->num c) p))]
[(char= c #\-)
[($char= c #\-)
(cons 'datum (fx- 0 (tokenize-hex 0 p)))]
[(char= c #\+)
[($char= c #\+)
(cons 'datum (tokenize-hex 0 p))]
[else
(unread-char c p)
@ -104,14 +104,14 @@
(cond
[(eof-object? c)
(error 'tokenize "end-of-file while inside a string")]
[(char= #\" c) ls]
[(char= #\\ c)
[($char= #\" c) ls]
[($char= #\\ c)
(let ([c (read-char p)])
(cond
[(char= #\" c) (tokenize-string (cons #\" ls) p)]
[(char= #\\ c) (tokenize-string (cons #\\ ls) p)]
[(char= #\n c) (tokenize-string (cons #\newline ls) p)]
[(char= #\t c) (tokenize-string (cons #\tab ls) p)]
[($char= #\" c) (tokenize-string (cons #\" ls) p)]
[($char= #\\ c) (tokenize-string (cons #\\ ls) p)]
[($char= #\n c) (tokenize-string (cons #\newline ls) p)]
[($char= #\t c) (tokenize-string (cons #\tab ls) p)]
[else (error 'tokenize "invalid string escape \\~a" c)]))]
[else
(tokenize-string (cons c ls) p)]))))
@ -148,13 +148,13 @@
(cond
[(eof-object? c) 'dot]
[(delimiter? c) 'dot]
[(char= c #\.) ; this is second dot
[($char= c #\.) ; this is second dot
(read-char p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid syntax .. near end of file")]
[(char= c #\.) ; this is the third
[($char= c #\.) ; this is the third
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . ...)]
@ -180,7 +180,7 @@
(cond
[(eof-object? c)
(error 'tokenize "invalid eof in the middle of #\\~a" str)]
[(char= c (string-ref str i))
[($char= c (string-ref str i))
(tokenize-char* (fxadd1 i) str p d)]
[else
(error 'tokenize
@ -191,7 +191,7 @@
(cond
[(eof-object? c) (cons 'datum (string-ref str 0))]
[(delimiter? c) (cons 'datum (string-ref str 0))]
[(char= (string-ref str 1) c)
[($char= (string-ref str 1) c)
(read-char p)
(tokenize-char* 2 str p d)]
[else (error 'tokenize "invalid syntax near #\\~a~a"
@ -202,13 +202,13 @@
(cond
[(eof-object? c)
(error 'tokenize "invalid #\\ near end of file")]
[(char= #\s c)
[($char= #\s c)
(tokenize-char-seq p "space" '(datum . #\space))]
[(char= #\n c)
[($char= #\n c)
(tokenize-char-seq p "newline" '(datum . #\newline))]
[(char= #\t c)
[($char= #\t c)
(tokenize-char-seq p "tab" '(datum . #\tab))]
[(char= #\r c)
[($char= #\r c)
(tokenize-char-seq p "return" '(datum . #\return))]
[else
(let ([n (peek-char p)])
@ -226,17 +226,17 @@
(let ([c (read-char p)])
(cond
[(eof-object? c) (multiline-error)]
[(char= #\| c)
[($char= #\| c)
(let ([c (read-char p)])
(cond
[(eof-object? c) (multiline-error)]
[(char= #\# c) (void)]
[($char= #\# c) (void)]
[else (multiline-comment p)]))]
[(char= #\# c)
[($char= #\# c)
(let ([c (read-char p)])
(cond
[(eof-object? c) (multiline-error)]
[(char= #\| c)
[($char= #\| c)
(multiline-comment p)
(multiline-comment p)]
[else
@ -247,8 +247,8 @@
(let ([c (read-char p)])
(cond
[(eof-object? c) ac]
[(char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)]
[(char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)]
[($char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)]
[($char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)]
[(delimiter? c) (unread-char c p) ac]
[else
(unread-char c)
@ -259,85 +259,99 @@
(let ([c (read-char p)])
(cond
[(eof-object? c) (error 'tokenize "invalid # near end of file")]
[(char= c #\t)
[($char= c #\t)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . #t)]
[(delimiter? c) '(datum . #t)]
[else (error 'tokenize "invalid syntax near #t")]))]
[(char= c #\f)
[($char= c #\f)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . #f)]
[(delimiter? c) '(datum . #f)]
[else (error 'tokenize "invalid syntax near #f")]))]
[(char= #\\ c) (tokenize-char p)]
[(char= #\( c) 'vparen]
[(char= #\x c) (tokenize-hex-init p)]
[(char= #\' c) '(macro . syntax)]
[(char= #\; c) 'hash-semi]
[(char= #\% c) '(macro . |#primitive|)]
[(char= #\| c) (multiline-comment p) (tokenize p)]
[(char= #\b c)
[($char= #\\ c) (tokenize-char p)]
[($char= #\( c) 'vparen]
[($char= #\x c) (tokenize-hex-init p)]
[($char= #\' c) '(macro . syntax)]
[($char= #\; c) 'hash-semi]
[($char= #\% c) '(macro . |#primitive|)]
[($char= #\| c) (multiline-comment p) (tokenize p)]
[($char= #\b c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof while reading #b")]
[(char= #\- c)
[($char= #\- c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof while reading #b-")]
[(char= #\0 c)
[($char= #\0 c)
(cons 'datum
(fx- 0 (read-binary 0 '(#\0 #\-) p)))]
[(char= #\1 c)
[($char= #\1 c)
(cons 'datum
(fx- 0 (read-binary 1 '(#\1 #\-) p)))]
[else
(unread-char c p)
(error 'tokenize "invalid binary syntax #b-~a" c)]))]
[(char= #\0 c)
[($char= #\0 c)
(cons 'datum (read-binary 0 '(#\0) p))]
[(char= #\1 c)
[($char= #\1 c)
(cons 'datum (read-binary 1 '(#\1) p))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax #b~a" c)]
))]
[(char= #\! c)
[($char= #\! c)
(let ([e (read-char p)])
(when (eof-object? e)
(error 'tokenize "invalid eof near #!"))
(unless (char= #\e e)
(unless ($char= #\e e)
(error 'tokenize "invalid syntax near #!~a" e))
(let ([o (read-char p)])
(when (eof-object? o)
(error 'tokenize "invalid eof near #!e"))
(unless (char= #\o o)
(unless ($char= #\o o)
(error 'tokenize "invalid syntax near #!e~a" o))
(let ([f (read-char p)])
(when (eof-object? f)
(error 'tokenize "invalid syntax near #!eo"))
(unless (char= #\f f)
(unless ($char= #\f f)
(error 'tokenize "invalid syntax near #!eo~a" f))
(cons 'datum (eof-object)))))]
[(digit? c)
(tokenize-hashnum p (char->num c))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax #~a" c)]))))
(define (tokenize-hashnum p n)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside #n mark/ref")]
[($char= #\= c) (cons 'mark n)]
[($char= #\# c) (cons 'ref n)]
[(digit? c)
(tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))]
[else
(unread-char c p)
(error 'tokenize "invalid char ~a while inside a #n mark/ref" c)])))
(define tokenize-bar
(lambda (p ac)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")]
[(char= #\\ c)
[($char= #\\ c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")]
[else (tokenize-bar p (cons c ac))]))]
[(char= #\| c) ac]
[($char= #\| c) ac]
[else (tokenize-bar p (cons c ac))]))))
(define tokenize
(lambda (p)
@ -345,39 +359,39 @@
(cond
[(eof-object? c) (eof-object)]
[(char-whitespace? c) (tokenize p)]
[(char= #\( c) 'lparen]
[(char= #\) c) 'rparen]
[(char= #\[ c) 'lbrack]
[(char= #\] c) 'rbrack]
[(char= #\' c) '(macro . quote)]
[(char= #\` c) '(macro . quasiquote)]
[(char= #\, c)
[($char= #\( c) 'lparen]
[($char= #\) c) 'rparen]
[($char= #\[ c) 'lbrack]
[($char= #\] c) 'rbrack]
[($char= #\' c) '(macro . quote)]
[($char= #\` c) '(macro . quasiquote)]
[($char= #\, c)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(macro . unquote)]
[(char= c #\@)
[($char= c #\@)
(read-char p)
'(macro . unquote-splicing)]
[else '(macro . unquote)]))]
[(char= #\# c) (tokenize-hash p)]
[($char= #\# c) (tokenize-hash p)]
[(digit? c)
(cons 'datum (tokenize-number (char->num c) p))]
[(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))]
[(char= #\" c)
[($char= #\" c)
(let ([ls (tokenize-string '() p)])
(cons 'datum (list->string (reverse ls))))]
[(char= #\; c)
[($char= #\; c)
(skip-comment p)
(tokenize p)]
[(char= #\+ c)
[($char= #\+ c)
(tokenize-plus p)]
[(char= #\- c)
[($char= #\- c)
(tokenize-minus p)]
[(char= #\. c)
[($char= #\. c)
(tokenize-dot p)]
[(char= #\| c)
[($char= #\| c)
(let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))]
[else
@ -388,122 +402,212 @@
;;;--------------------------------------------------------------* READ *---
;;;
(define read-list-rest
(lambda (p end mis)
(lambda (p locs k end mis)
(let ([t (read-token p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading list")]
[(eq? t end) '()]
[(eq? t end) (values '() locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
[(eq? t 'dot)
(let ([d (read p)])
(let-values ([(d locs k) (read-expr p locs k)])
(let ([t (read-token p)])
(cond
[(eq? t end) d]
[(eq? t mis)
[(eq? t end) (values d locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
[(eq? t 'dot)
(error 'read "cannot have two dots in a list")]
[else
(error 'read "expecting ~a, got ~a" end t)])))]
[(eq? t 'hash-semi)
(read p)
(read-list-rest p end mis)]
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-list-rest p locs k end mis))]
[else
(let ([a (parse-token p t)])
(let ([d (read-list-rest p end mis)])
(cons a d)))]))))
(let-values ([(a locs k) (parse-token p locs k t)])
(let-values ([(d locs k) (read-list-rest p locs k end mis)])
(let ([x (cons a d)])
(values x locs
(if (or (loc? a) (loc? d))
(extend-k-pair x k)
k)))))]))))
(define read-list-init
(lambda (p end mis)
(lambda (p locs k end mis)
(let ([t (read-token p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading list")]
[(eq? t end) '()]
[(eq? t end) (values '() locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
[(eq? t 'dot)
(error 'read "invalid dot while reading list")]
[(eq? t 'hash-semi)
(read p)
(read-list-init p end mis)]
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-list-init p locs k end mis))]
[else
(let ([a (parse-token p t)])
(cons a (read-list-rest p end mis)))]))))
(define vector-put!
(lambda (v i ls)
(let-values ([(a locs k) (parse-token p locs k t)])
(let-values ([(d locs k) (read-list-rest p locs k end mis)])
(let ([x (cons a d)])
(values x locs
(if (or (loc? a) (loc? d))
(extend-k-pair x k)
k)))))]))))
(define extend-k-pair
(lambda (x k)
(lambda ()
(let ([a (car x)])
(when (loc? a)
(set-car! x (loc-value a))))
(let ([d (cdr x)])
(when (loc? d)
(set-cdr! x (loc-value d))))
(k))))
(define vector-put
(lambda (v k i ls)
(cond
[(null? ls) v]
[(null? ls) k]
[else
(vector-set! v i (car ls))
(vector-put! v (fxsub1 i) (cdr ls))])))
(let ([a (car ls)])
(vector-set! v i a)
(vector-put v
(if (loc? a)
(lambda ()
(vector-set! v i (loc-value (vector-ref v i)))
(k))
k)
(fxsub1 i) (cdr ls)))])))
(define read-vector
(lambda (p count ls)
(lambda (p locs k count ls)
(let ([t (read-token p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading a vector")]
[(eq? t 'rparen)
(let ([v (make-vector count)])
(vector-put! v (fxsub1 count) ls))]
[(eq? t 'rbrack)
(error 'read "unexpected ] while reading a vector")]
[(eq? t 'dot)
(error 'read "unexpected . while reading a vector")]
[(eq? t 'hash-semi)
(read p)
(read-vector p count ls)]
[else
(let ([a (parse-token p t)])
(read-vector p (fxadd1 count) (cons a ls)))]))))
[(eof-object? t)
(error 'read "end of file encountered while reading a vector")]
[(eq? t 'rparen)
(let ([v (make-vector count)])
(let ([k (vector-put v k (fxsub1 count) ls)])
(values v locs k)))]
[(eq? t 'rbrack)
(error 'read "unexpected ] while reading a vector")]
[(eq? t 'dot)
(error 'read "unexpected . while reading a vector")]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-vector p locs k count ls))]
[else
(let-values ([(a locs k) (parse-token p locs k t)])
(read-vector p locs k (fxadd1 count) (cons a ls)))]))))
(define-record loc (value set?))
(define parse-token
(lambda (p t)
(lambda (p locs k t)
(cond
[(eof-object? t) (eof-object)]
[(eq? t 'lparen) (read-list-init p 'rparen 'rbrack)]
[(eq? t 'lbrack) (read-list-init p 'rbrack 'rparen)]
[(eq? t 'vparen) (read-vector p 0 '())]
[(eq? t 'hash-semi)
(read p) ; ignored expression
(read p)]
[(eof-object? t) (values (eof-object) locs k)]
[(eq? t 'lparen) (read-list-init p locs k 'rparen 'rbrack)]
[(eq? t 'lbrack) (read-list-init p locs k 'rbrack 'rparen)]
[(eq? t 'vparen) (read-vector p locs k 0 '())]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-expr p locs k))]
[(pair? t)
(cond
[(eq? (car t) 'datum) (cdr t)]
[(eq? (car t) 'datum) (values (cdr t) locs k)]
[(eq? (car t) 'macro)
(cons (cdr t) (cons (read p) '()))]
(let-values ([(expr locs k) (read-expr p locs k)])
(let ([x (list expr)])
(values (cons (cdr t) x) locs
(if (loc? expr)
(lambda ()
(set-car! x (loc-value expr))
(k))
k))))]
[(eq? (car t) 'mark)
(let ([n (cdr t)])
(let-values ([(expr locs k) (read-expr p locs k)])
(cond
[(assq n locs) =>
(lambda (x)
(let ([loc (cdr x)])
(when (loc-set? loc)
(error 'read "duplicate mark ~s" n))
(set-loc-value! loc expr)
(set-loc-set?! loc #t)
(values expr locs k)))]
[else
(let ([loc (make-loc expr #t)])
(let ([locs (cons (cons n loc) locs)])
(values expr locs k)))])))]
[(eq? (car t) 'ref)
(let ([n (cdr t)])
(cond
[(assq n locs) =>
(lambda (x)
(values (cdr x) locs k))]
[else
(let ([loc (make-loc #f #f)])
(let ([locs (cons (cons n loc) locs)])
(values loc locs k)))]))]
[else (error 'read "invalid token! ~s" t)])]
[else
(error 'read "unexpected ~s found" t)])))
(define read
(lambda (p) (parse-token p (read-token p))))
(define read-expr
(lambda (p locs k)
(parse-token p locs k (read-token p))))
(define reduce-loc!
(lambda (x)
(let ([loc (cdr x)])
(unless (loc-set? loc)
(error 'read "referenced mark ~s not set" (car x)))
(when (loc? (loc-value loc))
(let f ([h loc] [t loc])
(if (loc? h)
(let ([h1 (loc-value h)])
(if (loc? h1)
(begin
(when (eq? h1 t)
(error 'read "circular marks"))
(let ([v (f (loc-value h1) (loc-value t))])
(set-loc-value! h1 v)
(set-loc-value! h v)
v))
(begin
(set-loc-value! h h1)
h1)))
h))))))
(define read
(lambda (p)
(let-values ([(expr locs k) (read-expr p '() void)])
(cond
[(null? locs) expr]
[else
(for-each reduce-loc! locs)
(k)
(if (loc? expr)
(loc-value expr)
expr)]))))
;;;
;;;--------------------------------------------------------------* INIT *---
;;;
(primitive-set! 'read-token
(lambda p
(if (null? p)
(tokenize (current-input-port))
(if (null? (cdr p))
(let ([a (car p)])
(if (input-port? a)
(tokenize a)
(error 'read-token
"not an input port: ~s ~s ~s"
(vector? a) (vector-length a) a)))
(error 'read-token "too many arguments")))))
(case-lambda
[() (tokenize (current-input-port))]
[(p)
(if (input-port? p)
(tokenize p)
(error 'read-token "~s is not an input port" p))]))
(primitive-set! 'read
(lambda p
(if (null? p)
(read (current-input-port))
(if (null? (cdr p))
(let ([a (car p)])
(if (input-port? a)
(read a)
(error 'read "not an input port: ~s" a)))
(error 'read "too many arguments")))))
(case-lambda
[() (read (current-input-port))]
[(p)
(if (input-port? p)
(read p)
(error 'read "~s is not an input port" p))]))
(let ()
(define read-and-eval
(lambda (p)

630
src/libtokenizer-9.1.ss Normal file
View File

@ -0,0 +1,630 @@
;;; 9.1: bignum reader
;;; 9.0: graph marks/refs
;;;
(let ()
(define char-whitespace?
(lambda (c)
(or ($char= #\space c)
(memq ($char->fixnum c) '(9 10 11 12 13)))))
(define delimiter?
(lambda (c)
(or (char-whitespace? c)
(memq c '(#\( #\) #\[ #\] #\' #\` #\, #\")))))
(define digit?
(lambda (c)
(and ($char<= #\0 c) ($char<= c #\9))))
(define char->num
(lambda (c)
(fx- ($char->fixnum c) ($char->fixnum #\0))))
(define initial?
(lambda (c)
(or (letter? c) (special-initial? c))))
(define letter?
(lambda (c)
(or (and ($char<= #\a c) ($char<= c #\z))
(and ($char<= #\A c) ($char<= c #\Z)))))
(define af?
(lambda (c)
(or (and ($char<= #\a c) ($char<= c #\f))
(and ($char<= #\A c) ($char<= c #\F)))))
(define af->num
(lambda (c)
(if (and ($char<= #\a c) ($char<= c #\f))
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
(define special-initial?
(lambda (c)
(memq c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
(define subsequent?
(lambda (c)
(or (initial? c) (digit? c) (special-subsequent? c))))
(define special-subsequent?
(lambda (c)
(memq c '(#\+ #\- #\. #\@))))
(define tokenize-number
(lambda (n p)
(let ([c (read-char p)])
(cond
[(eof-object? c) n]
[(digit? c)
(tokenize-number (+ (* n 10) (char->num c)) p)]
[(delimiter? c)
(unread-char c p)
n]
[else
(unread-char c p)
(error 'tokenize "invalid number syntax: ~a~a" n c)]))))
(define tokenize-hex
(lambda (n p)
(let ([c (read-char p)])
(cond
[(eof-object? c) n]
[(digit? c)
(tokenize-hex (+ (* n 16) (char->num c)) p)]
[(af? c)
(tokenize-hex (+ (* n 16) (af->num c)) p)]
[(delimiter? c)
(unread-char c p)
n]
[else
(unread-char c p)
(error 'tokenize "invalid hex number sequence: ~a~a" n c)]))))
(define tokenize-hex-init
(lambda (p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(unread-char c p)
(error 'tokenize "invalid #x near end of file")]
[(digit? c)
(cons 'datum (tokenize-hex (char->num c) p))]
[(af? c)
(cons 'datum (tokenize-hex (af->num c) p))]
[($char= c #\-)
(cons 'datum (* -1 (tokenize-hex 0 p)))]
[($char= c #\+)
(cons 'datum (tokenize-hex 0 p))]
[else
(unread-char c p)
(error 'tokenize "invalid number syntax: #x~a" c)]))))
(define tokenize-identifier
(lambda (ls p)
(let ([c (read-char p)])
(cond
[(eof-object? c) ls]
[(subsequent? c)
(tokenize-identifier (cons c ls) p)]
[(delimiter? c)
(unread-char c p)
ls]
[else
(unread-char c p)
(error 'tokenize "invalid identifier syntax: ~a"
(list->string (reverse (cons c ls))))]))))
(define tokenize-string
(lambda (ls p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "end-of-file while inside a string")]
[($char= #\" c) ls]
[($char= #\\ c)
(let ([c (read-char p)])
(cond
[($char= #\" c) (tokenize-string (cons #\" ls) p)]
[($char= #\\ c) (tokenize-string (cons #\\ ls) p)]
[($char= #\n c) (tokenize-string (cons #\newline ls) p)]
[($char= #\t c) (tokenize-string (cons #\tab ls) p)]
[else (error 'tokenize "invalid string escape \\~a" c)]))]
[else
(tokenize-string (cons c ls) p)]))))
(define skip-comment
(lambda (p)
(let ([c (read-char p)])
(unless (eof-object? c)
(let ([i ($char->fixnum c)])
(unless (or (fx= i 10) (fx= i 13))
(skip-comment p)))))))
(define tokenize-plus
(lambda (p)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . +)]
[(delimiter? c) '(datum . +)]
[(digit? c)
(read-char p)
(cons 'datum (tokenize-number (char->num c) p))]
[else (error 'tokenize "invalid sequence +~a" c)]))))
(define tokenize-minus
(lambda (p)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . -)]
[(delimiter? c) '(datum . -)]
[(digit? c)
(read-char p)
(cons 'datum (* -1 (tokenize-number (char->num c) p)))]
[else (error 'tokenize "invalid sequence -~a" c)]))))
(define tokenize-dot
(lambda (p)
(let ([c (peek-char p)])
(cond
[(eof-object? c) 'dot]
[(delimiter? c) 'dot]
[($char= c #\.) ; this is second dot
(read-char p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid syntax .. near end of file")]
[($char= c #\.) ; this is the third
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . ...)]
[(delimiter? c) '(datum . ...)]
[else
(error 'tokenize "invalid syntax ...~a" c)]))]
[else
(unread-char c)
(error 'tokenize "invalid syntax ..~a" c)]))]
[else
(error 'tokenize "invalid syntax .~a" c)]))))
(define tokenize-char*
(lambda (i str p d)
(cond
[(fx= i (string-length str))
(let ([c (peek-char p)])
(cond
[(eof-object? c) d]
[(delimiter? c) d]
[else (error 'tokenize "invalid character after #\\~a" str)]))]
[else
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof in the middle of #\\~a" str)]
[($char= c (string-ref str i))
(tokenize-char* (fxadd1 i) str p d)]
[else
(error 'tokenize
"invalid char ~a while scanning #\\~a" c str)]))])))
(define tokenize-char-seq
(lambda (p str d)
(let ([c (peek-char p)])
(cond
[(eof-object? c) (cons 'datum (string-ref str 0))]
[(delimiter? c) (cons 'datum (string-ref str 0))]
[($char= (string-ref str 1) c)
(read-char p)
(tokenize-char* 2 str p d)]
[else (error 'tokenize "invalid syntax near #\\~a~a"
(string-ref str 0) c)]))))
(define tokenize-char
(lambda (p)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid #\\ near end of file")]
[($char= #\s c)
(tokenize-char-seq p "space" '(datum . #\space))]
[($char= #\n c)
(tokenize-char-seq p "newline" '(datum . #\newline))]
[($char= #\t c)
(tokenize-char-seq p "tab" '(datum . #\tab))]
[($char= #\r c)
(tokenize-char-seq p "return" '(datum . #\return))]
[else
(let ([n (peek-char p)])
(cond
[(eof-object? n) (cons 'datum c)]
[(delimiter? n) (cons 'datum c)]
[else
(error 'tokenize "invalid syntax #\\~a~a" c n)]))]))))
(define multiline-error
(lambda ()
(error 'tokenize
"end of file encountered while inside a #|-style comment")))
(define multiline-comment
(lambda (p)
(let ([c (read-char p)])
(cond
[(eof-object? c) (multiline-error)]
[($char= #\| c)
(let ([c (read-char p)])
(cond
[(eof-object? c) (multiline-error)]
[($char= #\# c) (void)]
[else (multiline-comment p)]))]
[($char= #\# c)
(let ([c (read-char p)])
(cond
[(eof-object? c) (multiline-error)]
[($char= #\| c)
(multiline-comment p)
(multiline-comment p)]
[else
(multiline-comment p)]))]
[else (multiline-comment p)]))))
(define read-binary
(lambda (ac chars p)
(let ([c (read-char p)])
(cond
[(eof-object? c) ac]
[($char= #\0 c) (read-binary (* ac 2) (cons c chars) p)]
[($char= #\1 c) (read-binary (+ (* ac 2) 1) (cons c chars) p)]
[(delimiter? c) (unread-char c p) ac]
[else
(unread-char c)
(error 'tokenize "invalid syntax #b~a"
(list->string (reverse (cons c chars))))]))))
(define tokenize-hash
(lambda (p)
(let ([c (read-char p)])
(cond
[(eof-object? c) (error 'tokenize "invalid # near end of file")]
[($char= c #\t)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . #t)]
[(delimiter? c) '(datum . #t)]
[else (error 'tokenize "invalid syntax near #t")]))]
[($char= c #\f)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(datum . #f)]
[(delimiter? c) '(datum . #f)]
[else (error 'tokenize "invalid syntax near #f")]))]
[($char= #\\ c) (tokenize-char p)]
[($char= #\( c) 'vparen]
[($char= #\x c) (tokenize-hex-init p)]
[($char= #\' c) '(macro . syntax)]
[($char= #\; c) 'hash-semi]
[($char= #\% c) '(macro . |#primitive|)]
[($char= #\| c) (multiline-comment p) (tokenize p)]
[($char= #\b c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof while reading #b")]
[($char= #\- c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof while reading #b-")]
[($char= #\0 c)
(cons 'datum
(* -1 (read-binary 0 '(#\0 #\-) p)))]
[($char= #\1 c)
(cons 'datum
(* -1 (read-binary 1 '(#\1 #\-) p)))]
[else
(unread-char c p)
(error 'tokenize "invalid binary syntax #b-~a" c)]))]
[($char= #\0 c)
(cons 'datum (read-binary 0 '(#\0) p))]
[($char= #\1 c)
(cons 'datum (read-binary 1 '(#\1) p))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax #b~a" c)]
))]
[($char= #\! c)
(let ([e (read-char p)])
(when (eof-object? e)
(error 'tokenize "invalid eof near #!"))
(unless ($char= #\e e)
(error 'tokenize "invalid syntax near #!~a" e))
(let ([o (read-char p)])
(when (eof-object? o)
(error 'tokenize "invalid eof near #!e"))
(unless ($char= #\o o)
(error 'tokenize "invalid syntax near #!e~a" o))
(let ([f (read-char p)])
(when (eof-object? f)
(error 'tokenize "invalid syntax near #!eo"))
(unless ($char= #\f f)
(error 'tokenize "invalid syntax near #!eo~a" f))
(cons 'datum (eof-object)))))]
[(digit? c)
(tokenize-hashnum p (char->num c))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax #~a" c)]))))
(define (tokenize-hashnum p n)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "invalid eof inside #n mark/ref")]
[($char= #\= c) (cons 'mark n)]
[($char= #\# c) (cons 'ref n)]
[(digit? c)
(tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))]
[else
(unread-char c p)
(error 'tokenize "invalid char ~a while inside a #n mark/ref" c)])))
(define tokenize-bar
(lambda (p ac)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")]
[($char= #\\ c)
(let ([c (read-char p)])
(cond
[(eof-object? c)
(error 'tokenize "unexpected eof while reading symbol")]
[else (tokenize-bar p (cons c ac))]))]
[($char= #\| c) ac]
[else (tokenize-bar p (cons c ac))]))))
(define tokenize
(lambda (p)
(let ([c (read-char p)])
(cond
[(eof-object? c) (eof-object)]
[(char-whitespace? c) (tokenize p)]
[($char= #\( c) 'lparen]
[($char= #\) c) 'rparen]
[($char= #\[ c) 'lbrack]
[($char= #\] c) 'rbrack]
[($char= #\' c) '(macro . quote)]
[($char= #\` c) '(macro . quasiquote)]
[($char= #\, c)
(let ([c (peek-char p)])
(cond
[(eof-object? c) '(macro . unquote)]
[($char= c #\@)
(read-char p)
'(macro . unquote-splicing)]
[else '(macro . unquote)]))]
[($char= #\# c) (tokenize-hash p)]
[(digit? c)
(cons 'datum (tokenize-number (char->num c) p))]
[(initial? c)
(let ([ls (reverse (tokenize-identifier (cons c '()) p))])
(cons 'datum (string->symbol (list->string ls))))]
[($char= #\" c)
(let ([ls (tokenize-string '() p)])
(cons 'datum (list->string (reverse ls))))]
[($char= #\; c)
(skip-comment p)
(tokenize p)]
[($char= #\+ c)
(tokenize-plus p)]
[($char= #\- c)
(tokenize-minus p)]
[($char= #\. c)
(tokenize-dot p)]
[($char= #\| c)
(let ([ls (reverse (tokenize-bar p '()))])
(cons 'datum (string->symbol (list->string ls))))]
[else
(unread-char c p)
(error 'tokenize "invalid syntax ~a" c)]))))
;;;
;;;--------------------------------------------------------------* READ *---
;;;
(define read-list-rest
(lambda (p locs k end mis)
(let ([t (read-token p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading list")]
[(eq? t end) (values '() locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
[(eq? t 'dot)
(let-values ([(d locs k) (read-expr p locs k)])
(let ([t (read-token p)])
(cond
[(eq? t end) (values d locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
[(eq? t 'dot)
(error 'read "cannot have two dots in a list")]
[else
(error 'read "expecting ~a, got ~a" end t)])))]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-list-rest p locs k end mis))]
[else
(let-values ([(a locs k) (parse-token p locs k t)])
(let-values ([(d locs k) (read-list-rest p locs k end mis)])
(let ([x (cons a d)])
(values x locs
(if (or (loc? a) (loc? d))
(extend-k-pair x k)
k)))))]))))
(define read-list-init
(lambda (p locs k end mis)
(let ([t (read-token p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading list")]
[(eq? t end) (values '() locs k)]
[(eq? t mis)
(error 'read "paren mismatch")]
[(eq? t 'dot)
(error 'read "invalid dot while reading list")]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-list-init p locs k end mis))]
[else
(let-values ([(a locs k) (parse-token p locs k t)])
(let-values ([(d locs k) (read-list-rest p locs k end mis)])
(let ([x (cons a d)])
(values x locs
(if (or (loc? a) (loc? d))
(extend-k-pair x k)
k)))))]))))
(define extend-k-pair
(lambda (x k)
(lambda ()
(let ([a (car x)])
(when (loc? a)
(set-car! x (loc-value a))))
(let ([d (cdr x)])
(when (loc? d)
(set-cdr! x (loc-value d))))
(k))))
(define vector-put
(lambda (v k i ls)
(cond
[(null? ls) k]
[else
(let ([a (car ls)])
(vector-set! v i a)
(vector-put v
(if (loc? a)
(lambda ()
(vector-set! v i (loc-value (vector-ref v i)))
(k))
k)
(fxsub1 i) (cdr ls)))])))
(define read-vector
(lambda (p locs k count ls)
(let ([t (read-token p)])
(cond
[(eof-object? t)
(error 'read "end of file encountered while reading a vector")]
[(eq? t 'rparen)
(let ([v (make-vector count)])
(let ([k (vector-put v k (fxsub1 count) ls)])
(values v locs k)))]
[(eq? t 'rbrack)
(error 'read "unexpected ] while reading a vector")]
[(eq? t 'dot)
(error 'read "unexpected . while reading a vector")]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-vector p locs k count ls))]
[else
(let-values ([(a locs k) (parse-token p locs k t)])
(read-vector p locs k (fxadd1 count) (cons a ls)))]))))
(define-record loc (value set?))
(define parse-token
(lambda (p locs k t)
(cond
[(eof-object? t) (values (eof-object) locs k)]
[(eq? t 'lparen) (read-list-init p locs k 'rparen 'rbrack)]
[(eq? t 'lbrack) (read-list-init p locs k 'rbrack 'rparen)]
[(eq? t 'vparen) (read-vector p locs k 0 '())]
[(eq? t 'hash-semi)
(let-values ([(ignored locs k) (read-expr p locs k)])
(read-expr p locs k))]
[(pair? t)
(cond
[(eq? (car t) 'datum) (values (cdr t) locs k)]
[(eq? (car t) 'macro)
(let-values ([(expr locs k) (read-expr p locs k)])
(let ([x (list expr)])
(values (cons (cdr t) x) locs
(if (loc? expr)
(lambda ()
(set-car! x (loc-value expr))
(k))
k))))]
[(eq? (car t) 'mark)
(let ([n (cdr t)])
(let-values ([(expr locs k) (read-expr p locs k)])
(cond
[(assq n locs) =>
(lambda (x)
(let ([loc (cdr x)])
(when (loc-set? loc)
(error 'read "duplicate mark ~s" n))
(set-loc-value! loc expr)
(set-loc-set?! loc #t)
(values expr locs k)))]
[else
(let ([loc (make-loc expr #t)])
(let ([locs (cons (cons n loc) locs)])
(values expr locs k)))])))]
[(eq? (car t) 'ref)
(let ([n (cdr t)])
(cond
[(assq n locs) =>
(lambda (x)
(values (cdr x) locs k))]
[else
(let ([loc (make-loc #f #f)])
(let ([locs (cons (cons n loc) locs)])
(values loc locs k)))]))]
[else (error 'read "invalid token! ~s" t)])]
[else
(error 'read "unexpected ~s found" t)])))
(define read-expr
(lambda (p locs k)
(parse-token p locs k (read-token p))))
(define reduce-loc!
(lambda (x)
(let ([loc (cdr x)])
(unless (loc-set? loc)
(error 'read "referenced mark ~s not set" (car x)))
(when (loc? (loc-value loc))
(let f ([h loc] [t loc])
(if (loc? h)
(let ([h1 (loc-value h)])
(if (loc? h1)
(begin
(when (eq? h1 t)
(error 'read "circular marks"))
(let ([v (f (loc-value h1) (loc-value t))])
(set-loc-value! h1 v)
(set-loc-value! h v)
v))
(begin
(set-loc-value! h h1)
h1)))
h))))))
(define read
(lambda (p)
(let-values ([(expr locs k) (read-expr p '() void)])
(cond
[(null? locs) expr]
[else
(for-each reduce-loc! locs)
(k)
(if (loc? expr)
(loc-value expr)
expr)]))))
;;;
;;;--------------------------------------------------------------* INIT *---
;;;
(primitive-set! 'read-token
(case-lambda
[() (tokenize (current-input-port))]
[(p)
(if (input-port? p)
(tokenize p)
(error 'read-token "~s is not an input port" p))]))
(primitive-set! 'read
(case-lambda
[() (read (current-input-port))]
[(p)
(if (input-port? p)
(read p)
(error 'read "~s is not an input port" p))]))
(let ()
(define read-and-eval
(lambda (p)
(let ([x (read p)])
(unless (eof-object? x)
(eval x)
(read-and-eval p)))))
(primitive-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)))))
)

BIN
src/libtokenizer.fasl
View File

Binary file not shown.

8
src/libtoplevel-6.0.ss
View File

@ -1,8 +0,0 @@
(for-each
(lambda (x)
(let ([v (primitive-ref x)])
(when (procedure? v)
(set-top-level-value! x v))))
(oblist))

BIN
src/libtoplevel.fasl
View File

Binary file not shown.

9
src/libwriter-6.2.ss
View File

@ -308,15 +308,13 @@
(error 'fprintf "~s is not an output port" port))
(unless (string? fmt)
(error 'fprintf "~s is not a string" fmt))
(formatter 'fprintf port fmt args)
(flush-output-port port)))
(formatter 'fprintf port fmt args)))
(define printf
(lambda (fmt . args)
(unless (string? fmt)
(error 'printf "~s is not a string" fmt))
(formatter 'printf (current-output-port) fmt args)
(flush-output-port (current-output-port))))
(formatter 'printf (current-output-port) fmt args)))
(define format
(lambda (fmt . args)
@ -371,6 +369,5 @@
(error 'current-error-handler "~s is not a procedure" x)))))
(primitive-set! 'error
(lambda args
(apply (current-error-handler) args)))
)
(apply (current-error-handler) args))))

257
src/libwriter-6.1.ss → src/libwriter-9.0.ss
View File

@ -1,4 +1,6 @@
;;; 6.2: * added a printer for bwp-objects
;;; WRITER provides display and write.
(let ()
@ -26,46 +28,54 @@
(write-fixnum i p)]))
(write-char x p))))
(define write-list
(lambda (x p m)
(lambda (x p m h i)
(cond
[(pair? x)
[(and (pair? x)
(or (not (get-hash-table h x #f))
(fxzero? (get-hash-table h x 0))))
(write-char #\space p)
(writer (car x) p m)
(write-list (cdr x) p m)]
[(not (null? x))
(write-list (cdr x) p m h
(writer (car x) p m h i))]
[(null? x) i]
[else
(write-char #\space p)
(write-char #\. p)
(write-char #\space p)
(writer x p m)])))
(writer x p m h i)])))
(define write-vector
(lambda (x p m)
(lambda (x p m h i)
(write-char #\# p)
(write-char #\( p)
(let ([n (vector-length x)])
(when (fx> n 0)
(writer (vector-ref x 0) p m)
(letrec ([f
(lambda (i)
(unless (fx= i n)
(write-char #\space p)
(writer (vector-ref x i) p m)
(f (fxadd1 i))))])
(f 1))))
(write-char #\) p)))
(let ([i
(cond
[(fx> n 0)
(let f ([idx 1] [i (writer (vector-ref x 0) p m h i)])
(cond
[(fx= idx n)
i]
[else
(write-char #\space p)
(f (fxadd1 idx)
(writer (vector-ref x idx) p m h i))]))]
[else i])])
(write-char #\) p)
i))))
(define write-record
(lambda (x p m)
(lambda (x p m h i)
(write-char #\# p)
(write-char #\[ p)
(writer (record-name x) p m)
(let ([n (record-length x)])
(letrec ([f
(lambda (i)
(unless (fx= i n)
(write-char #\space p)
(writer (record-ref x i) p m)
(f (fxadd1 i))))])
(f 0)))
(write-char #\] p)))
(let ([i (writer (record-name x) p m h i)])
(let ([n (record-length x)])
(let f ([idx 0] [i i])
(cond
[(fx= idx n)
(write-char #\] p)
i]
[else
(write-char #\space p)
(f (fxadd1 idx)
(writer (record-ref x idx) p m h i))]))))))
(define initial?
(lambda (c)
(or (letter? c) (special-initial? c))))
@ -123,7 +133,7 @@
(write-symbol-esc str p))
(write-char* str p)))))
(define write-gensym
(lambda (x p m)
(lambda (x p m h i)
(cond
[(and m (print-gensym))
(let ([str (symbol->string x)])
@ -134,8 +144,11 @@
(write-symbol-esc str p))
(write-char #\space p)
(write-symbol-esc (gensym->unique-string x) p)
(write-char #\} p))]
[else (write-symbol x p m)])))
(write-char #\} p))
i]
[else
(write-symbol x p m)
i])))
(define write-string-escape
(lambda (x p)
(define loop
@ -201,70 +214,183 @@
(and (pair? d)
(null? ($cdr d))))
(assq ($car x) macro-forms))))
(define writer
(lambda (x p m)
(define write-pair
(lambda (x p m h i)
(write-char #\( p)
(let ([i (writer (car x) p m h i)])
(let ([i (write-list (cdr x) p m h i)])
(write-char #\) p)
i))))
(define write-ref
(lambda (n p)
(write-char #\# p)
(write-fixnum (fx- -1 n) p)
(write-char #\# p)))
(define write-mark
(lambda (n p)
(write-char #\# p)
(write-fixnum (fx- -1 n) p)
(write-char #\= p)))
(define write-shareable
(lambda (x p m h i k)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(cond
[(fx< n 0)
(write-ref n p)
i]
[(fx= n 0)
(k x p m h i)]
[else
(let ([i (fx- i 1)])
(put-hash-table! h x i)
(write-mark i p)
(k x p m h i))]))]
[else (k x p m h i)])))
(define writer
(lambda (x p m h i)
(cond
[(macro x) =>
(lambda (y)
(write-char* (cdr y) p)
(writer (cadr x) p m))]
[(pair? x)
(write-char #\( p)
(writer (car x) p m)
(write-list (cdr x) p m)
(write-char #\) p)]
[(symbol? x)
(write-shareable x p m h i write-pair)]
[(symbol? x)
(if (gensym? x)
(write-gensym x p m)
(write-symbol x p m))]
(write-gensym x p m h i)
(begin (write-symbol x p m) i))]
[(fixnum? x)
(write-fixnum x p)]
(write-fixnum x p)
i]
[(string? x)
(write-string x p m)]
(write-string x p m)
i]
[(boolean? x)
(write-char* (if x "#t" "#f") p)]
(write-char* (if x "#t" "#f") p)
i]
[(char? x)
(write-character x p m)]
(write-character x p m)
i]
[(procedure? x)
(write-char* "#<procedure>" p)]
(write-char* "#<procedure>" p)
i]
[(output-port? x)
(write-char* "#<output-port " p)
(writer (output-port-name x) p #t)
(write-char #\> p)]
(let ([i (writer (output-port-name x) p #t h i)])
(write-char #\> p)
i)]
[(input-port? x)
(write-char* "#<input-port " p)
(writer (input-port-name x) p #t)
(write-char #\> p)]
(let ([i (writer (input-port-name x) p #t h i)])
(write-char #\> p)
i)]
[(vector? x)
(write-vector x p m)]
(write-shareable x p m h i write-vector)]
[(null? x)
(write-char #\( p)
(write-char #\) p)]
(write-char #\) p)
i]
[(eq? x (void))
(write-char* "#<void>" p)]
(write-char* "#<void>" p)
i]
[(eof-object? x)
(write-char* "#!eof" p)]
(write-char* "#!eof" p)
i]
[(bwp-object? x)
(write-char* "#!bwp" p)
i]
[(record? x)
(let ([printer (record-printer x)])
(if (procedure? printer)
(printer x p)
(write-record x p m)))]
(begin (printer x p) i)
(write-shareable x p m h i write-record)))]
;[(code? x)
; (write-char* "#<code>" p)]
[(hash-table? x)
(write-char* "#<hash-table>" p)]
(write-char* "#<hash-table>" p)
i]
[($unbound-object? x)
(write-char* "#<unbound-object>" p)]
(write-char* "#<unbound-object>" p)
i]
[($forward-ptr? x)
(write-char* "#<forward-ptr>" p)]
(write-char* "#<forward-ptr>" p)
i]
[else
(write-char* "#<unknown>" p)])))
(write-char* "#<unknown>" p)
i])))
(define print-graph (make-parameter #f))
(define (hasher x h)
(define (vec-graph x i j h)
(unless (fx= i j)
(graph (vector-ref x i) h)
(vec-graph x (fxadd1 i) j h)))
(define (vec-dynamic x i j h)
(unless (fx= i j)
(dynamic (vector-ref x i) h)
(vec-dynamic x (fxadd1 i) j h)))
(define (graph x h)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(graph (car x) h)
(graph (cdr x) h)])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(vec-graph x 0 (vector-length x) h)])]
[(gensym? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))])]))
(define (dynamic x h)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(dynamic (car x) h)
(dynamic (cdr x) h)
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(vec-dynamic x 0 (vector-length x) h)
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]))
(if (print-graph)
(graph x h)
(dynamic x h)))
(define (write x p)
(writer x p #t)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p #t h 0))
(flush-output-port p))
;;;
(define (display x p)
(writer x p #f)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p #f h 0))
(flush-output-port p))
;;;
(define formatter
@ -337,6 +463,7 @@
(primitive-set! 'format format)
(primitive-set! 'printf printf)
(primitive-set! 'fprintf fprintf)
(primitive-set! 'print-graph print-graph)
(primitive-set! 'write
(case-lambda
[(x) (write x (current-output-port))]

309
src/libwriter-6.0.ss → src/libwriter-9.1.ss
View File

@ -1,4 +1,6 @@
;;; 6.2: * added a printer for bwp-objects
;;; WRITER provides display and write.
(let ()
@ -26,46 +28,54 @@
(write-fixnum i p)]))
(write-char x p))))
(define write-list
(lambda (x p m)
(lambda (x p m h i)
(cond
[(pair? x)
[(and (pair? x)
(or (not (get-hash-table h x #f))
(fxzero? (get-hash-table h x 0))))
(write-char #\space p)
(writer (car x) p m)
(write-list (cdr x) p m)]
[(not (null? x))
(write-list (cdr x) p m h
(writer (car x) p m h i))]
[(null? x) i]
[else
(write-char #\space p)
(write-char #\. p)
(write-char #\space p)
(writer x p m)])))
(writer x p m h i)])))
(define write-vector
(lambda (x p m)
(lambda (x p m h i)
(write-char #\# p)
(write-char #\( p)
(let ([n (vector-length x)])
(when (fx> n 0)
(writer (vector-ref x 0) p m)
(letrec ([f
(lambda (i)
(unless (fx= i n)
(write-char #\space p)
(writer (vector-ref x i) p m)
(f (fxadd1 i))))])
(f 1))))
(write-char #\) p)))
(let ([i
(cond
[(fx> n 0)
(let f ([idx 1] [i (writer (vector-ref x 0) p m h i)])
(cond
[(fx= idx n)
i]
[else
(write-char #\space p)
(f (fxadd1 idx)
(writer (vector-ref x idx) p m h i))]))]
[else i])])
(write-char #\) p)
i))))
(define write-record
(lambda (x p m)
(lambda (x p m h i)
(write-char #\# p)
(write-char #\[ p)
(writer (record-name x) p m)
(let ([n (record-length x)])
(letrec ([f
(lambda (i)
(unless (fx= i n)
(write-char #\space p)
(writer (record-ref x i) p m)
(f (fxadd1 i))))])
(f 0)))
(write-char #\] p)))
(let ([i (writer (record-name x) p m h i)])
(let ([n (record-length x)])
(let f ([idx 0] [i i])
(cond
[(fx= idx n)
(write-char #\] p)
i]
[else
(write-char #\space p)
(f (fxadd1 idx)
(writer (record-ref x idx) p m h i))]))))))
(define initial?
(lambda (c)
(or (letter? c) (special-initial? c))))
@ -123,7 +133,7 @@
(write-symbol-esc str p))
(write-char* str p)))))
(define write-gensym
(lambda (x p m)
(lambda (x p m h i)
(cond
[(and m (print-gensym))
(let ([str (symbol->string x)])
@ -134,8 +144,11 @@
(write-symbol-esc str p))
(write-char #\space p)
(write-symbol-esc (gensym->unique-string x) p)
(write-char #\} p))]
[else (write-symbol x p m)])))
(write-char #\} p))
i]
[else
(write-symbol x p m)
i])))
(define write-string-escape
(lambda (x p)
(define loop
@ -143,10 +156,10 @@
(unless (fx= i n)
(let ([c (string-ref x i)])
(cond
[(or (char= #\" c) (char= #\\ c))
[(or ($char= #\" c) ($char= #\\ c))
(write-char #\\ p)
(write-char c p)]
[(char= #\tab c)
[($char= #\tab c)
(write-char #\\ p)
(write-char #\t p)]
[else
@ -201,78 +214,187 @@
(and (pair? d)
(null? ($cdr d))))
(assq ($car x) macro-forms))))
(define writer
(lambda (x p m)
(define write-pair
(lambda (x p m h i)
(write-char #\( p)
(let ([i (writer (car x) p m h i)])
(let ([i (write-list (cdr x) p m h i)])
(write-char #\) p)
i))))
(define write-ref
(lambda (n p)
(write-char #\# p)
(write-fixnum (fx- -1 n) p)
(write-char #\# p)))
(define write-mark
(lambda (n p)
(write-char #\# p)
(write-fixnum (fx- -1 n) p)
(write-char #\= p)))
(define write-shareable
(lambda (x p m h i k)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(cond
[(fx< n 0)
(write-ref n p)
i]
[(fx= n 0)
(k x p m h i)]
[else
(let ([i (fx- i 1)])
(put-hash-table! h x i)
(write-mark i p)
(k x p m h i))]))]
[else (k x p m h i)])))
(define writer
(lambda (x p m h i)
(cond
[(macro x) =>
(lambda (y)
(write-char* (cdr y) p)
(writer (cadr x) p m))]
[(pair? x)
(write-char #\( p)
(writer (car x) p m)
(write-list (cdr x) p m)
(write-char #\) p)]
[(symbol? x)
(write-shareable x p m h i write-pair)]
[(symbol? x)
(if (gensym? x)
(write-gensym x p m)
(write-symbol x p m))]
(write-gensym x p m h i)
(begin (write-symbol x p m) i))]
[(fixnum? x)
(write-fixnum x p)]
(write-fixnum x p)
i]
[(string? x)
(write-string x p m)]
(write-string x p m)
i]
[(boolean? x)
(write-char* (if x "#t" "#f") p)]
(write-char* (if x "#t" "#f") p)
i]
[(char? x)
(write-character x p m)]
(write-character x p m)
i]
[(procedure? x)
(write-char* "#<procedure>" p)]
(write-char* "#<procedure>" p)
i]
[(output-port? x)
(write-char* "#<output-port " p)
(writer (output-port-name x) p #t)
(write-char #\> p)]
(let ([i (writer (output-port-name x) p #t h i)])
(write-char #\> p)
i)]
[(input-port? x)
(write-char* "#<input-port " p)
(writer (input-port-name x) p #t)
(write-char #\> p)]
(let ([i (writer (input-port-name x) p #t h i)])
(write-char #\> p)
i)]
[(vector? x)
(write-vector x p m)]
(write-shareable x p m h i write-vector)]
[(null? x)
(write-char #\( p)
(write-char #\) p)]
(write-char #\) p)
i]
[(eq? x (void))
(write-char* "#<void>" p)]
(write-char* "#<void>" p)
i]
[(eof-object? x)
(write-char* "#!eof" p)]
(write-char* "#!eof" p)
i]
[(bwp-object? x)
(write-char* "#!bwp" p)
i]
[(record? x)
(let ([printer (record-printer x)])
(if (procedure? printer)
(printer x p)
(write-record x p m)))]
(begin (printer x p) i)
(write-shareable x p m h i write-record)))]
;[(code? x)
; (write-char* "#<code>" p)]
[(hash-table? x)
(write-char* "#<hash-table>" p)]
(write-char* "#<hash-table>" p)
i]
[($unbound-object? x)
(write-char* "#<unbound-object>" p)]
(write-char* "#<unbound-object>" p)
i]
[($forward-ptr? x)
(write-char* "#<forward-ptr>" p)]
(write-char* "#<forward-ptr>" p)
i]
[(number? x)
(write-char* (number->string x) p)
i]
[else
(write-char* "#<unknown>" p)])))
(define generic-writer
(lambda (who)
(lambda (x . p)
(let ([port
(if (null? p)
(current-output-port)
(if (null? (cdr p))
(let ([p (car p)])
(if (output-port? p)
p
(error who "not an output port ~s" p)))
(error who "too many arguments")))])
(writer x port (eq? who 'write))
(flush-output-port port)))))
(write-char* "#<unknown>" p)
i])))
(define print-graph (make-parameter #f))
(define (hasher x h)
(define (vec-graph x i j h)
(unless (fx= i j)
(graph (vector-ref x i) h)
(vec-graph x (fxadd1 i) j h)))
(define (vec-dynamic x i j h)
(unless (fx= i j)
(dynamic (vector-ref x i) h)
(vec-dynamic x (fxadd1 i) j h)))
(define (graph x h)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(graph (car x) h)
(graph (cdr x) h)])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(vec-graph x 0 (vector-length x) h)])]
[(gensym? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))])]))
(define (dynamic x h)
(cond
[(pair? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(dynamic (car x) h)
(dynamic (cdr x) h)
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]
[(vector? x)
(cond
[(get-hash-table h x #f) =>
(lambda (n)
(put-hash-table! h x (fxadd1 n)))]
[else
(put-hash-table! h x 0)
(vec-dynamic x 0 (vector-length x) h)
(when (and (get-hash-table h x #f)
(fxzero? (get-hash-table h x #f)))
(put-hash-table! h x #f))])]))
(if (print-graph)
(graph x h)
(dynamic x h)))
(define (write x p)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p #t h 0))
(flush-output-port p))
;;;
(define (display x p)
(let ([h (make-hash-table)])
(hasher x h)
(writer x p #f h 0))
(flush-output-port p))
;;;
(define formatter
(lambda (who p fmt args)
@ -280,21 +402,21 @@
(unless (fx= i (string-length fmt))
(let ([c (string-ref fmt i)])
(cond
[(char= c #\~)
[($char= c #\~)
(let ([i (fxadd1 i)])
(when (fx= i (string-length fmt))
(error who "invalid ~~ at end of format string ~s" fmt))
(let ([c (string-ref fmt i)])
(cond
[(char= c #\~)
[($char= c #\~)
(write-char #\~ p)
(f (fxadd1 i) args)]
[(char= c #\a)
[($char= c #\a)
(when (null? args)
(error who "insufficient arguments"))
(display (car args) p)
(f (fxadd1 i) (cdr args))]
[(char= c #\s)
[($char= c #\s)
(when (null? args)
(error who "insufficient arguments"))
(write (car args) p)
@ -344,15 +466,28 @@
(primitive-set! 'format format)
(primitive-set! 'printf printf)
(primitive-set! 'fprintf fprintf)
(primitive-set! 'display (generic-writer 'display))
(primitive-set! 'write (generic-writer 'write))
(primitive-set! 'print-graph print-graph)
(primitive-set! 'write
(case-lambda
[(x) (write x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'write "~s is not an output port" p))
(write x p)]))
(primitive-set! 'display
(case-lambda
[(x) (display x (current-output-port))]
[(x p)
(unless (output-port? p)
(error 'display "~s is not an output port" p))
(display x p)]))
(primitive-set! 'print-error print-error)
(primitive-set! 'current-error-handler
(make-parameter
(lambda args
(apply print-error args)
(display "exiting\n")
(flush-output-port)
(display "exiting\n" (console-output-port))
(flush-output-port (console-output-port))
(exit -100))
(lambda (x)
(if (procedure? x)

BIN
src/libwriter.fasl
View File

Binary file not shown.

34
src/makepp.ss
View File

@ -1,34 +0,0 @@
(define primitive-set! set-top-level-value!)
(define chez-expand sc-expand)
(define-syntax |#primitive|
(lambda (x)
(syntax-case x ()
[(_ n) #'n])))
(printf "loading psyntax.pp ...\n")
(load "psyntax-7.1.pp")
(current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "loading psyntax.ss ...\n")
(load "psyntax-7.1.ss")
(current-expand
(lambda (x . args)
(apply chez-expand (sc-expand x) args)))
(printf "making xpsyntax.pp ...\n")
(with-output-to-file "xpsyntax.pp"
(lambda ()
(load "psyntax-7.1.ss"
(lambda (x)
(parameterize ([print-gensym #f]
[print-graph #f]
[expand-mode 'bootstrap]
[print-vector-length #f])
(pretty-print (sc-expand x))
(newline)))))
'replace)

2
src/psyntax-7.1-6.9.ss
View File

@ -4637,6 +4637,7 @@
"~s is not a record of type ~s" x 'rtd)))) ...
)))])))
(define-syntax $define-record-syntax
(lambda (x)
(syntax-case x ()
@ -4688,7 +4689,6 @@
[(_ x v) ($record-set! x i v)])) ...
)))])))
(define-syntax trace
(lambda (x)
(syntax-case x ()

115
src/psyntax-7.1-6.8.ss → src/psyntax-7.1-9.0.ss
View File

@ -663,7 +663,7 @@
;;; AZIZ
(define generate-id
(lambda (name)
(if name (gensym (symbol->string name)) (gensym))))
(if name (gensym name) (gensym))))
)
@ -768,8 +768,9 @@
;;; ((_ ae level name) name)))
(define-syntax build-primref
(syntax-rules ()
[(_ ae name) `(|#primitive| ,name)]
[(_ ae level name) `(|#primitive| ,name)]))
[(_ ae name) (build-primref ae 1 name)]
[(_ ae level name)
`(|#primitive| ,name)]))
;;; AZIZ
@ -3110,8 +3111,12 @@
(global-extend 'core '|#primitive|
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ e) (id? #'e)
(build-primref ae (strip (syntax e) w)))
((_ name) (id? #'name)
(let ([name (strip (syntax name) w)])
(if (or (memq name (public-primitives))
(memq name (system-primitives)))
(build-primref ae name)
(syntax-error (source-wrap e w ae)))))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'core 'syntax
@ -4576,7 +4581,6 @@
(define-syntax define-record
(lambda (x)
(syntax-case x ()
@ -4593,6 +4597,12 @@
(datum->syntax-object #'name
(string->symbol
(string-append namestr "?")))]
[(i ...)
(datum->syntax-object #'name
(let f ([i 0] [f* fieldstr*])
(cond
[(null? f*) '()]
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
[(getters ...)
(datum->syntax-object #'name
(map (lambda (x)
@ -4608,9 +4618,94 @@
[rtd rtd])
#'(begin
(define-syntax name (cons '$rtd 'rtd))
(define constr (record-constructor 'rtd))
(define pred (record-predicate 'rtd))
(define getters (record-field-accessor 'rtd 'field*)) ...
(define setters (record-field-mutator 'rtd 'field*)) ...
(define constr
(lambda (field* ...)
($record 'rtd field* ...)))
(define pred
(lambda (x) ($record/rtd? x 'rtd)))
(define getters
(lambda (x)
(if ($record/rtd? x 'rtd)
($record-ref x i)
(error 'getters
"~s is not a record of type ~s" x 'rtd)))) ...
(define setters
(lambda (x v)
(if ($record/rtd? x 'rtd)
($record-set! x i v)
(error 'setters
"~s is not a record of type ~s" x 'rtd)))) ...
)))])))
(define-syntax $define-record-syntax
(lambda (x)
(syntax-case x ()
[(_ name (field* ...))
(let* ([namestr (symbol->string (syntax-object->datum #'name))]
[fields (syntax-object->datum #'(field* ...))]
[fieldstr* (map symbol->string fields)]
[rtd (make-record-type namestr fields)])
(with-syntax ([constr
(datum->syntax-object #'name
(string->symbol
(string-append "make-" namestr)))]
[pred
(datum->syntax-object #'name
(string->symbol
(string-append namestr "?")))]
[(i ...)
(datum->syntax-object #'name
(let f ([i 0] [f* fieldstr*])
(cond
[(null? f*) '()]
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
[(getters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append namestr "-" x)))
fieldstr*))]
[(setters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append "set-" namestr "-" x "!")))
fieldstr*))]
[rtd rtd])
#'(begin
(define-syntax name (cons '$rtd 'rtd))
(define-syntax constr
(syntax-rules ()
[(_ field* ...) ($record 'rtd field* ...)]))
(define-syntax pred
(syntax-rules ()
[(_ x) ($record/rtd? x 'rtd)]))
(define-syntax getters
(syntax-rules ()
[(_ x) ($record-ref x i)])) ...
(define-syntax setters
(syntax-rules ()
[(_ x v) ($record-set! x i v)])) ...
)))])))
(define-syntax trace
(lambda (x)
(syntax-case x ()
[(_ id) (identifier? #'id)
#'(trace-symbol! 'id)])))
(define-syntax untrace
(lambda (x)
(syntax-case x ()
[(_ id) (identifier? #'id)
#'(untrace-symbol! 'id)])))
(define-syntax trace-lambda
(lambda (x)
(syntax-case x ()
[(_ name args body body* ...)
#'(make-traced-procedure 'name (lambda args body body* ...))])))

122
src/psyntax-7.1-6.5.ss → src/psyntax-7.1-9.1.ss
View File

@ -663,7 +663,7 @@
;;; AZIZ
(define generate-id
(lambda (name)
(if name (gensym (symbol->string name)) (gensym))))
(if name (gensym name) (gensym))))
)
@ -768,8 +768,9 @@
;;; ((_ ae level name) name)))
(define-syntax build-primref
(syntax-rules ()
[(_ ae name) `(|#primitive| ,name)]
[(_ ae level name) `(|#primitive| ,name)]))
[(_ ae name) (build-primref ae 1 name)]
[(_ ae level name)
`(|#primitive| ,name)]))
;;; AZIZ
@ -790,7 +791,7 @@
(if (null? (cdr exps))
(car exps)
; weed out leading void calls, assuming ordinary list representation
(if (equal? (car exps) '(void))
(if (equal? (car exps) '(#%void))
(loop (cdr exps))
`(begin ,@exps))))))
@ -846,7 +847,7 @@
(syntax-rules ()
((_ e)
(let ((x e))
(or (boolean? x) (fixnum? x) (string? x) (char? x) (null? x))))))
(or (boolean? x) (fixnum? x) (string? x) (char? x) (null? x) (number? x))))))
)
(define-syntax unannotate
@ -2458,6 +2459,9 @@
(case type
((lexical)
(build-lexical-reference 'value ae value))
;;; AZIZ
((core-primitive)
(build-primref ae value))
((core) (value e r mr w ae m?))
((lexical-call)
(chi-application
@ -3107,8 +3111,12 @@
(global-extend 'core '|#primitive|
(lambda (e r mr w ae m?)
(syntax-case e ()
((_ e) (id? #'e)
(build-primref ae (strip (syntax e) w)))
((_ name) (id? #'name)
(let ([name (strip (syntax name) w)])
(if (or (memq name (public-primitives))
(memq name (system-primitives)))
(build-primref ae name)
(syntax-error (source-wrap e w ae)))))
(_ (syntax-error (source-wrap e w ae))))))
(global-extend 'core 'syntax
@ -4573,7 +4581,6 @@
(define-syntax define-record
(lambda (x)
(syntax-case x ()
@ -4590,6 +4597,12 @@
(datum->syntax-object #'name
(string->symbol
(string-append namestr "?")))]
[(i ...)
(datum->syntax-object #'name
(let f ([i 0] [f* fieldstr*])
(cond
[(null? f*) '()]
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
[(getters ...)
(datum->syntax-object #'name
(map (lambda (x)
@ -4605,9 +4618,94 @@
[rtd rtd])
#'(begin
(define-syntax name (cons '$rtd 'rtd))
(define constr (record-constructor 'rtd))
(define pred (record-predicate 'rtd))
(define getters (record-field-accessor 'rtd 'field*)) ...
(define setters (record-field-mutator 'rtd 'field*)) ...
(define constr
(lambda (field* ...)
($record 'rtd field* ...)))
(define pred
(lambda (x) ($record/rtd? x 'rtd)))
(define getters
(lambda (x)
(if ($record/rtd? x 'rtd)
($record-ref x i)
(error 'getters
"~s is not a record of type ~s" x 'rtd)))) ...
(define setters
(lambda (x v)
(if ($record/rtd? x 'rtd)
($record-set! x i v)
(error 'setters
"~s is not a record of type ~s" x 'rtd)))) ...
)))])))
(define-syntax $define-record-syntax
(lambda (x)
(syntax-case x ()
[(_ name (field* ...))
(let* ([namestr (symbol->string (syntax-object->datum #'name))]
[fields (syntax-object->datum #'(field* ...))]
[fieldstr* (map symbol->string fields)]
[rtd (make-record-type namestr fields)])
(with-syntax ([constr
(datum->syntax-object #'name
(string->symbol
(string-append "make-" namestr)))]
[pred
(datum->syntax-object #'name
(string->symbol
(string-append namestr "?")))]
[(i ...)
(datum->syntax-object #'name
(let f ([i 0] [f* fieldstr*])
(cond
[(null? f*) '()]
[else (cons i (f (fxadd1 i) (cdr f*)))])))]
[(getters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append namestr "-" x)))
fieldstr*))]
[(setters ...)
(datum->syntax-object #'name
(map (lambda (x)
(string->symbol
(string-append "set-" namestr "-" x "!")))
fieldstr*))]
[rtd rtd])
#'(begin
(define-syntax name (cons '$rtd 'rtd))
(define-syntax constr
(syntax-rules ()
[(_ field* ...) ($record 'rtd field* ...)]))
(define-syntax pred
(syntax-rules ()
[(_ x) ($record/rtd? x 'rtd)]))
(define-syntax getters
(syntax-rules ()
[(_ x) ($record-ref x i)])) ...
(define-syntax setters
(syntax-rules ()
[(_ x v) ($record-set! x i v)])) ...
)))])))
(define-syntax trace
(lambda (x)
(syntax-case x ()
[(_ id) (identifier? #'id)
#'(trace-symbol! 'id)])))
(define-syntax untrace
(lambda (x)
(syntax-case x ()
[(_ id) (identifier? #'id)
#'(untrace-symbol! 'id)])))
(define-syntax trace-lambda
(lambda (x)
(syntax-case x ()
[(_ name args body body* ...)
#'(make-traced-procedure 'name (lambda args body body* ...))])))

4608
src/psyntax-7.1.ss
View File

File diff suppressed because it is too large Load Diff

26
src/record-case.chez.ss
View File

@ -1,26 +0,0 @@
(define-syntax record-case
(lambda (x)
(define (enumerate fld* i)
(syntax-case fld* ()
[() #'()]
[(x . x*)
(with-syntax ([i i] [i* (enumerate #'x* (fx+ i 1))])
#'(i . i*))]))
(define (generate-body ctxt cls*)
(syntax-case cls* (else)
[() (with-syntax ([x x]) #'(error #f "unmatched ~s in ~s" v #'x))]
[([else b b* ...]) #'(begin b b* ...)]
[([(rec-name rec-field* ...) b b* ...] . rest) (identifier? #'rec-name)
(with-syntax ([altern (generate-body ctxt #'rest)]
[(id* ...) (enumerate #'(rec-field* ...) 0)]
[rtd #'(type-descriptor rec-name)])
#'(if ((record-predicate rtd) v)
(let ([rec-field* ;($record-ref v id*)] ...)
((record-field-accessor rtd id*) v)] ...)
b b* ...)
altern))]))
(syntax-case x ()
[(_ expr cls* ...)
(with-syntax ([body (generate-body #'_ #'(cls* ...))])
#'(let ([v expr]) body))])))

14
src/runtime/Makefile
View File

@ -1,17 +1,18 @@
#CFLAGS = -Wall -DNDEBUG -O3
CFLAGS = -Wall -g
LDFLAGS = -g -ldl -rdynamic
CFLAGS = -Wall -DNDEBUG -O3
#CFLAGS = -Wall -g
LDFLAGS = -g -ldl -lgmp -rdynamic
CC = gcc
all: ikarus
ikarus: ikarus-collect.o ikarus-runtime.o ikarus-main.o ikarus-fasl.o \
ikarus-exec.o ikarus-print.o ikarus-enter.s ikarus-symbol-table.o \
ikarus-weak-pairs.o
ikarus-weak-pairs.o ikarus-numerics.o
$(CC) $(LDFLAGS) -o ikarus \
ikarus-main.o ikarus-runtime.o \
ikarus-fasl.o ikarus-exec.o ikarus-print.o ikarus-enter.s \
ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o
ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o \
ikarus-numerics.o
ikarus-main.o: ikarus-main.c ikarus.h
$(CC) $(CFLAGS) -c ikarus-main.c
@ -37,6 +38,9 @@ ikarus-weak-pairs.o: ikarus-weak-pairs.c ikarus.h
ikarus-symbol-table.o: ikarus-symbol-table.c ikarus.h
$(CC) $(CFLAGS) -c ikarus-symbol-table.c
ikarus-numerics.o: ikarus-numerics.c ikarus.h
$(CC) $(CFLAGS) -c ikarus-numerics.c
ikarus.h: ikarus-data.h
touch ikarus.h

BIN
src/runtime/ikarus
View File

Binary file not shown.

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

@ -758,6 +758,8 @@ add_object(gc_t* gc, ikp x){
ref(y,off_tcbucket_key) = key;
ref(y,off_tcbucket_val) = ref(x, off_tcbucket_val);
ref(y,off_tcbucket_next) = ref(x, off_tcbucket_next);
ref(y,off_tcbucket_dlink_next) = ref(x, off_tcbucket_dlink_next);
ref(y,off_tcbucket_dlink_prev) = ref(x, off_tcbucket_dlink_prev);
if((! is_fixnum(key)) && (tagof(key) != immediate_tag)){
unsigned int kt = gc->segment_vector[page_index(key)];
if((kt & gen_mask) <= gc->collect_gen){
@ -769,6 +771,26 @@ add_object(gc_t* gc, ikp x){
ref(x, wordsize-vector_tag) = y;
return y;
}
else if((((int)fst) & port_mask) == port_tag){
ikp y = gc_alloc_new_ptr(port_size, gen, gc) + vector_tag;
ref(y, -vector_tag) = fst;
int i;
for(i=wordsize; i<port_size; i+=wordsize){
ref(y, i-vector_tag) = ref(x, i-vector_tag);
}
ref(x, -vector_tag) = forward_ptr;
ref(x, wordsize-vector_tag) = y;
return y;
}
else if((((int)fst) & bignum_mask) == bignum_tag){
int len = ((unsigned int)fst) >> bignum_length_shift;
int memreq = align(disp_bignum_data + len*wordsize);
ikp new = gc_alloc_new_data(memreq, gen, gc) + vector_tag;
memcpy(new-vector_tag, x, memreq);
ref(x, 0) = forward_ptr;
ref(x, wordsize) = new;
return new;
}
else {
fprintf(stderr, "unhandled vector with fst=0x%08x\n", (int)fst);
exit(-1);

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

@ -87,7 +87,7 @@
#define IK_DISP_CDR 4
#define IK_OFF_CAR (IK_DISP_CAR - IK_PAIR_TAG)
#define IK_OFF_CDR (IK_DISP_CDR - IK_PAIR_TAG)
#define IK_HEAP_EXT_SIZE (16 * 4096)
#define IK_HEAP_EXT_SIZE (32 * 4096)
#define IK_PAIRP(x) (IK_PTAG(x) == IK_PAIR_TAG)
#define IK_CHARP(x) (IK_MASK(x,IK_CHAR_MASK) == IK_CHAR_TAG)
#define IK_STRING_TAG 6
@ -173,24 +173,30 @@
#define disp_frame_size -17
#define htable_tag ((ikp) 0x3F)
#define disp_htable_count 4
#define disp_htable_size 8
#define disp_htable_mem 12
#define htable_size 16
#define off_htable_count (disp_htable_count - vector_tag)
#define off_htable_size (disp_htable_size - vector_tag)
#define off_htable_mem (disp_htable_mem - vector_tag)
#define port_tag 0x3F
#define port_mask 0x3F
#define port_size 32
#define disp_tcbucket_tconc 0
#define disp_tcbucket_key 4
#define disp_tcbucket_val 8
#define disp_tcbucket_next 12
#define tcbucket_size 16
#define off_tcbucket_tconc (disp_tcbucket_tconc - vector_tag)
#define off_tcbucket_key (disp_tcbucket_key - vector_tag)
#define off_tcbucket_val (disp_tcbucket_val - vector_tag)
#define off_tcbucket_next (disp_tcbucket_next - vector_tag)
#define disp_tcbucket_tconc 0
#define disp_tcbucket_key 4
#define disp_tcbucket_val 8
#define disp_tcbucket_next 12
#define disp_tcbucket_dlink_prev 16
#define disp_tcbucket_dlink_next 20
#define tcbucket_size 24
#define off_tcbucket_tconc (disp_tcbucket_tconc - vector_tag)
#define off_tcbucket_key (disp_tcbucket_key - vector_tag)
#define off_tcbucket_val (disp_tcbucket_val - vector_tag)
#define off_tcbucket_next (disp_tcbucket_next - vector_tag)
#define off_tcbucket_dlink_next (disp_tcbucket_dlink_next - vector_tag)
#define off_tcbucket_dlink_prev (disp_tcbucket_dlink_prev - vector_tag)
#define bignum_mask 0x7
#define bignum_tag 0x2
#define bignum_sign_mask 0x8
#define bignum_sign_shift 3
#define bignum_length_shift 4
#define disp_bignum_data wordsize
#endif

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

@ -80,7 +80,7 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
exit(-10);
}
if(p.marks){
ik_munmap(p.marks, pagesize);
ik_munmap(p.marks, p.marks_size*sizeof(ikp*));
}
{
int err = munmap(mem, mapsize);
@ -203,30 +203,26 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
fprintf(stderr, "fasl_read: invalid index %d\n", idx);
exit(-1);
}
if(idx >= 1024){
fprintf(stderr, "BUG: mark too big: %d\n", idx);
exit(-1);
}
if(idx < p->marks_size){
if(p->marks[idx] != 0){
fprintf(stderr, "mark %d already set (fileoff=%d)\n",
idx,
(int)p->memp - (int)p->membase - 6);
ik_print(p->marks[idx]);
if(p->marks){
if(idx >= p->marks_size){
fprintf(stderr, "BUG: mark too big: %d\n", idx);
exit(-1);
}
}
if(idx < p->marks_size){
if(p->marks[idx] != 0){
fprintf(stderr, "mark %d already set (fileoff=%d)\n",
idx,
(int)p->memp - (int)p->membase - 6);
ik_print(p->marks[idx]);
exit(-1);
}
}
}
else {
/* allocate marks */
if(p->marks){
fprintf(stderr, "BUG: extension to marks not implemented\n");
exit(-1);
}
else {
p->marks = ik_mmap(pagesize);
bzero(p->marks, pagesize);
p->marks_size = 1024;
}
p->marks = ik_mmap(pagesize*sizeof(ikp*));
bzero(p->marks, pagesize*sizeof(ikp*));
p->marks_size = pagesize;
}
}
if(c == 'x'){

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

@ -8,13 +8,19 @@
#include <fcntl.h>
#include <string.h>
#include <errno.h>
#include <gmp.h>
int main(int argc, char** argv){
if(argc < 2){
fprintf(stderr, "insufficient arguments\n");
exit(-1);
}
if(sizeof(mp_limb_t) != sizeof(int)){
fprintf(stderr, "ERROR: limb size\n");
}
if(mp_bits_per_limb != (8*sizeof(int))){
fprintf(stderr, "ERROR: bits_per_limb=%d\n", mp_bits_per_limb);
}
ikpcb* pcb = ik_make_pcb();
int i;
for(i=1; i<argc; i++){

1075
src/runtime/ikarus-numerics.c Normal file
View File

File diff suppressed because it is too large Load Diff

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

@ -122,8 +122,7 @@ ik_mmap_code(int size, int gen, ikpcb* pcb){
void*
ik_mmap_mixed(int size, ikpcb* pcb){
assert(0);
return 0;
return ik_mmap_typed(size, mainheap_mt, pcb);
}
@ -307,9 +306,11 @@ ik_alloc(ikpcb* pcb, int size){
return ap;
}
else {
fprintf(stderr, "EXT\n");
assert(0);
#if 0
static int did_warn = 0;
if(! did_warn){
fprintf(stderr, "Extension causes leak? %d bytes\n", size);
did_warn = 1;
}
if(ap){
ikpages* p = ik_malloc(sizeof(ikpages));
p->base = pcb->heap_base;
@ -327,7 +328,6 @@ ik_alloc(ikpcb* pcb, int size){
nap = ap + size;
pcb->allocation_pointer = nap;
return ap;
#endif
}
}

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

@ -47,7 +47,7 @@ static ikp ik_make_symbol(ikp str, ikpcb* pcb){
ikp sym = ik_alloc(pcb, symbol_size) + symbol_tag;
ref(sym, off_symbol_string) = str;
ref(sym, off_symbol_ustring) = false_object;
ref(sym, off_symbol_value) = unbound_object;
ref(sym, off_symbol_value) = str; //unbound_object;
ref(sym, off_symbol_plist) = null_object;
ref(sym, off_symbol_system_value) = str;
ref(sym, off_symbol_system_plist) = null_object;

1
src/runtime/ikarus.h
View File

@ -93,6 +93,7 @@ typedef struct {
ikp weak_pairs_ep;
ikp heap_base;
int heap_size;
ikpages* heap_pages;
ikp stack_base;
int stack_size;
ikp oblist;

25
src/runtime/tags.txt Normal file
View File

@ -0,0 +1,25 @@
xxxxxxxx xxxxxxx xxxxxxxx xxxxxx00 : vectors
xxxxxxxx xxxxxxx xxxxxxxx xxxxx001 : tconcs pair_tag
xxxxxxxx xxxxxxx xxxxxxxx xxxxx101 : records/rtds vector_tag
xxxxxxxx xxxxxxx xxxxxxxx xxxxxx10 : nonimmediate number
00000000 0000000 00000000 00001111 : free
00000000 0000000 00000000 00011111 : continuation 0x1F
00000000 0000000 00000000 00101111 : code 0x2F
00000000 0000000 00000000 00111111 : port (input=0, output=0) useless
00000000 0000000 00000000 01001111 : free
00000000 0000000 00000000 01011111 : free
00000000 0000000 00000000 01101111 : free
00000000 0000000 00000000 01111111 : port (input=1, output=0)
00000000 0000000 00000000 10001111 : free
00000000 0000000 00000000 10011111 : free
00000000 0000000 00000000 10101111 : free
00000000 0000000 00000000 10111111 : port (input=0, output=1)
00000000 0000000 00000000 11001111 : free
00000000 0000000 00000000 11011111 : free
00000000 0000000 00000000 11101111 : free
00000000 0000000 00000000 11111111 : port (input=1, output=1)
xxxxxxxx xxxxxxx xxxxxxxx xxxxxx10 : nonimmediate number
xxxxxxxx xxxxxxx xxxxxxxx xxxxs010 : bignum

2
src/test.ss
View File

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

Some files were not shown because too many files have changed in this diff Show More