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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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)))