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

import from compiler4

This commit is contained in:
Abdulaziz Ghuloum 2006-11-23 19:44:29 -05:00
parent 03e9649064
commit 3815bebb4c
84 changed files with 43947 additions and 56974 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Makefile
View File

@ -2,7 +2,7 @@
all: ikarus.fasl
ikarus.fasl:
echo '(load "compiler-6.2.ss")' | petite
echo '(load "compiler-6.9.ss")' | petite
clean:
rm -f *.fasl

2
src/build-date.tmp
View File

@ -1 +1 @@
2006-08-02
2006-08-22

22
src/chez-compat.ss
View File

@ -31,5 +31,27 @@
(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))

3199
src/compiler-6.3.ss Normal file
View File

File diff suppressed because it is too large Load Diff

98
src/compiler-6.4.ss Normal file
View File

@ -0,0 +1,98 @@
;;; 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 Normal file
View File

@ -0,0 +1,96 @@
;;; 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 Normal file
View File

@ -0,0 +1,97 @@
;;; 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 Normal file
View File

@ -0,0 +1,98 @@
;;; 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 Normal file
View File

@ -0,0 +1,98 @@
;;; 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")

256
src/compiler-6.9.ss Normal file
View File

@ -0,0 +1,256 @@
;;;
;;; 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
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
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
))
(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!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
vector-memq vector-memv
))
(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.6.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.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"]
))
(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)
(compile-library (car x) (cadr 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 cadr scheme-library-files))))

261
src/compiler-8.0.ss Normal file
View File

@ -0,0 +1,261 @@
;;;
;;; 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
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
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
))
(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!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
vector-memq vector-memv
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
))
(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.6.ss") ; uses make-code, etc.
(load "libfasl-6.7.ss") ; uses code? etc.
(load "libcompile-6.7.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"]
))
(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)
(compile-library (car x) (cadr 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 cadr scheme-library-files))))

289
src/compiler-8.1.ss Normal file
View File

@ -0,0 +1,289 @@
;;; 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 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-output-string get-output-string
with-output-to-file call-with-output-file
with-input-from-file call-with-input-file
))
(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!
call/cf trace-symbol! untrace-symbol! make-traced-procedure
fixnum->string date-string
vector-memq vector-memv
;;; must open-code
$make-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!
;;; 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.6.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"]
["libcore-6.9.ss" #t "libcore.fasl"]
["libchezio-8.1.ss" #t "libchezio.fasl"]
["libwriter-6.2.ss" #t "libwriter.fasl"]
["libtokenizer-6.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-8.1.ss" #t "libcompile.fasl"]
["psyntax-7.1-6.9.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"]
["libhash-6.2.ss" #t "libhash.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)
(printf "done\n")))
(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))))

7
src/geninstr/gen.pl
View File

@ -48,7 +48,12 @@ sub gen3{
}
}
gen1 "movb \$0, 4(r1)\n";
gen1 "movl \$0x1234, 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";
#gen2 "xorl r1,r2\n";

16
src/geninstr/tmp.dump
View File

@ -4,11 +4,11 @@ tmp.o: file format elf32-i386
Disassembly of section .text:
00000000 <.text>:
0: c6 40 04 00 movb $0x0,0x4(%eax)
4: c6 41 04 00 movb $0x0,0x4(%ecx)
8: c6 42 04 00 movb $0x0,0x4(%edx)
c: c6 43 04 00 movb $0x0,0x4(%ebx)
10: c6 44 24 04 00 movb $0x0,0x4(%esp)
15: c6 45 04 00 movb $0x0,0x4(%ebp)
19: c6 46 04 00 movb $0x0,0x4(%esi)
1d: c6 47 04 00 movb $0x0,0x4(%edi)
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

16
src/geninstr/tmp.s
View File

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

BIN
src/ikarus.fasl
View File

Binary file not shown.

56
src/libassembler-6.7.ss Normal file
View File

@ -0,0 +1,56 @@
(primitive-set! 'make-code
(lambda (code-size freevars)
(unless (and (fixnum? code-size) ($fx>= code-size 0))
(error 'make-code "~s is not a valid code size" code-size))
(unless (and (fixnum? freevars) ($fx>= freevars 0))
(error 'make-code "~s is not a valid number of free vars" freevars))
(foreign-call "ikrt_make_code" code-size freevars '#())))
(primitive-set! 'code?
(lambda (x) ($code? x)))
(primitive-set! 'code-reloc-vector
(lambda (x)
(unless ($code? x) (error 'code-reloc-vector "~s is not a code" x))
($code-reloc-vector x)))
(primitive-set! 'code-freevars
(lambda (x)
(unless ($code? x) (error 'code-closure-size "~s is not a code" x))
($code-freevars x)))
(primitive-set! 'code-size
(lambda (x)
(unless ($code? x) (error 'code-size "~s is not a code" x))
($code-size x)))
(primitive-set! 'code-set!
(lambda (x i v)
(unless ($code? x) (error 'code-set! "~s is not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-set! "~s is not a valid index" i))
(unless (and (fixnum? v)
($fx>= v 0)
($fx< v 256))
(error 'code-set! "~s is not a valid byte" v))
($code-set! x i v)))
(primitive-set! 'code-ref
(lambda (x i)
(unless ($code? x) (error 'code-ref "~s is not a code" x))
(unless (and (fixnum? i)
($fx>= i 0)
($fx< i ($code-size x)))
(error 'code-ref "~s is not a valid index" i))
($code-ref x i)))
(primitive-set! 'set-code-reloc-vector!
(lambda (x v)
(unless ($code? x)
(error 'set-code-reloc-vector! "~s is not a code" x))
(unless (vector? v)
(error 'set-code-reloc-vector! "~s is not a vector" v))
(foreign-call "ikrt_set_code_reloc_vector" x v)))

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

@ -1,56 +1,67 @@
(define-record code (closure-size code-vec reloc-vec))
(define make-code
(let ([make-code make-code])
(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)))))))
(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)))
(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 Normal file
View File

@ -0,0 +1,32 @@
(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 Normal file
View File

@ -0,0 +1,32 @@
(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 Normal file
View File

Binary file not shown.

BIN
src/libassembler.ss Normal file
View File

Binary file not shown.

3
src/libcafe-6.1.ss
View File

@ -30,7 +30,6 @@
(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 ()
@ -64,7 +63,7 @@
(primitive-set! 'new-cafe
(case-lambda
[() (new-cafe (current-eval))]
[() (new-cafe eval)]
[(p)
(unless (procedure? p)
(error 'new-cafe "~s is not a procedure" p))

BIN
src/libcafe.fasl
View File

Binary file not shown.

750
src/libchezio-8.1.ss Normal file
View File

@ -0,0 +1,750 @@
(let ()
(include "unsafe-record.ss")
;;;
;;; GENERIC PORTS: BASIC PRIMITIVES
;;;
;;; Exports:
;;; * Constructors:
;;; (make-input-port handler input-buffer)
;;; (make-output-port handler output-buffer)
;;; (make-input/output-port handler input-buffer output-buffer)
;;;
;;; * Predicates:
;;; (port? x)
;;; (input-port? x)
;;; (output-port? x)
;;;
;;; * Accessors:
;;; (port-handler port)
;;; (port-input-buffer port)
;;; (port-input-index port)
;;; (port-input-size port)
;;; (port-output-buffer port)
;;; (port-output-index port)
;;; (port-output-size port)
;;;
;;; * Mutators:
;;; (set-port-input-index! port fixnum)
;;; (set-port-input-size! port fixnum)
;;; (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)))])))
;;;
(primitive-set! 'port?
(lambda (x) (port? x)))
;;;
(primitive-set! 'input-port?
(lambda (x) (input-port? x)))
;;;
(primitive-set! 'output-port?
(lambda (x) (output-port? x)))
;;;
(primitive-set! '$make-input-port
(lambda (handler buffer)
($make-port handler buffer 0 ($string-length buffer) #f 0 0)))
;;;
(primitive-set! 'make-input-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
($make-input-port handler buffer)
(error 'make-input-port "~s is not a string" buffer))
(error 'make-input-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-output-port
(lambda (handler buffer)
($make-port handler #f 0 0 buffer 0 ($string-length buffer))))
;;;
(primitive-set! 'make-output-port
(lambda (handler buffer)
(if (procedure? handler)
(if (string? buffer)
($make-output-port handler buffer)
(error 'make-output-port "~s is not a string" buffer))
(error 'make-output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$make-input/output-port
(lambda (handler input-buffer output-buffer)
($make-port handler
input-buffer 0 ($string-length input-buffer)
output-buffer 0 ($string-length output-buffer))))
(primitive-set! 'make-input/output-port
(lambda (handler input-buffer output-buffer)
(if (procedure? handler)
(if (string? input-buffer)
(if (string? output-buffer)
($make-input/output-port handler input-buffer output-buffer)
(error 'make-input/output-port
"~s is not a string"
output-buffer))
(error 'make-input/output-port "~s is not a string" input-buffer))
(error 'make-input/output-port "~s is not a procedure" handler))))
;;;
(primitive-set! '$port-handler
(lambda (x) ($port-handler x)))
;;;
(primitive-set! 'port-handler
(lambda (x)
(if (port? x)
($port-handler x)
(error 'port-handler "~s is not a port" x))))
;;;
(primitive-set! '$port-input-buffer
(lambda (x) ($port-input-buffer x)))
;;;
(primitive-set! 'port-input-buffer
(lambda (x)
(if (input-port? x)
($port-input-buffer x)
(error 'port-input-buffer "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-index
(lambda (x) ($port-input-index x)))
;;;
(primitive-set! 'port-input-index
(lambda (x)
(if (input-port? x)
($port-input-index x)
(error 'port-input-index "~s is not an input-port" x))))
;;;
(primitive-set! '$port-input-size
(lambda (x) ($port-input-size x)))
;;;
(primitive-set! 'port-input-size
(lambda (x)
(if (input-port? x)
($port-input-size x)
(error 'port-input-size "~s is not an input-port" x))))
;;;
(primitive-set! '$port-output-buffer
(lambda (x) ($port-output-buffer x)))
;;;
(primitive-set! 'port-output-buffer
(lambda (x)
(if (output-port? x)
($port-output-buffer x)
(error 'port-output-buffer "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-index
(lambda (x) ($port-output-index x)))
;;;
(primitive-set! 'port-output-index
(lambda (x)
(if (output-port? x)
($port-output-index x)
(error 'port-output-index "~s is not an output-port" x))))
;;;
(primitive-set! '$port-output-size
(lambda (x) ($port-output-size x)))
;;;
(primitive-set! 'port-output-size
(lambda (x)
(if (output-port? x)
($port-output-size x)
(error 'port-output-size "~s is not an output-port" x))))
;;;
(primitive-set! '$set-port-input-index!
(lambda (p i) ($set-port-input-index! p i)))
;;;
(primitive-set! 'set-port-input-index!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-input-size p))
($set-port-input-index! p i)
(error 'set-port-input-index! "index ~s is too big" i))
(error 'set-port-input-index! "index ~s is negative" i))
(error 'set-port-input-index! "~s is not a valid index" i))
(error 'set-port-input-index! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-input-size!
(lambda (p i)
($set-port-input-index! p 0)
($set-port-input-size! p i)))
;;;
(primitive-set! 'set-port-input-size!
(lambda (p i)
(if (input-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($string-length ($port-input-buffer p)))
(begin
($set-port-input-index! p 0)
($set-port-input-size! p i))
(error 'set-port-input-size! "size ~s is too big" i))
(error 'set-port-input-size! "size ~s is negative" i))
(error 'set-port-input-size! "~s is not a valid size" i))
(error 'set-port-input-size! "~s is not an input-port" p))))
;;;
(primitive-set! '$set-port-output-index!
(lambda (p i) ($set-port-output-index! p i)))
;;;
(primitive-set! 'set-port-output-index!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($port-output-size p))
($set-port-output-index! p i)
(error 'set-port-output-index! "index ~s is too big" i))
(error 'set-port-output-index! "index ~s is negative" i))
(error 'set-port-output-index! "~s is not a valid index" i))
(error 'set-port-output-index! "~s is not an output-port" p))))
;;;
(primitive-set! '$set-port-output-size!
(lambda (p i)
($set-port-output-index! p 0)
($set-port-output-size! p i)))
;;;
(primitive-set! 'set-port-output-size!
(lambda (p i)
(if (output-port? p)
(if (fixnum? i)
(if ($fx>= i 0)
(if ($fx<= i ($string-length ($port-output-buffer p)))
(begin
($set-port-output-index! p 0)
($set-port-output-size! p i))
(error 'set-port-output-size! "size ~s is too big" i))
(error 'set-port-output-size! "size ~s is negative" i))
(error 'set-port-output-size! "~s is not a valid size" i))
(error 'set-port-output-size! "~s is not an output-port" p)))))
(let ()
;;; IO PRIMITIVES
;;;
(primitive-set! '$write-char
(lambda (c p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(($port-handler p) 'write-char c p)))))
;;;
(primitive-set! 'write-char
(case-lambda
[(c)
(if (char? c)
($write-char c (current-output-port))
(error 'write-char "~s is not a character" c))]
[(c p)
(if (char? c)
(if (output-port? p)
($write-char c p)
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]))
;;;
(primitive-set! 'newline
(case-lambda
[()
($write-char #\newline (current-output-port))
($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
(begin
($write-char #\newline p)
($flush-output-port p))
(error 'newline "~s is not an output port" p))]))
;;;
(primitive-set! 'port-name
(lambda (p)
(if (port? p)
(($port-handler p) 'port-name p)
(error 'port-name "~s is not a port" p))))
(primitive-set! 'input-port-name port-name)
(primitive-set! 'output-port-name port-name)
(primitive-set! '$read-char
(lambda (p)
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
(begin
($set-port-input-index! p ($fxadd1 idx))
($string-ref ($port-input-buffer p) idx))
(begin
(($port-handler p) 'read-char p))))))
;;;
(primitive-set! 'read-char
(case-lambda
[() ($read-char (current-input-port))]
[(p)
(if (input-port? p)
($read-char p)
(error 'read-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$unread-char
(lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(($port-handler p) 'unread-char c p)))))
;;;
(primitive-set! 'unread-char
(case-lambda
[(c) (if (char? c)
($unread-char c (current-input-port))
(error 'unread-char "~s is not a character" c))]
[(c p)
(if (input-port? p)
(if (char? c)
($unread-char c p)
(error 'unread-char "~s is not a character" c))
(error 'unread-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$peek-char
(lambda (p)
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
($string-ref ($port-input-buffer p) idx)
(($port-handler p) 'peek-char p)))))
;;;
(primitive-set! 'peek-char
(case-lambda
[() ($peek-char (current-input-port))]
[(p)
(if (input-port? p)
($peek-char p)
(error 'peek-char "~s is not an input-port" p))]))
;;;
(primitive-set! '$unread-char
(lambda (c p)
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(($port-handler p) 'unread-char c p)))))
;;;
(primitive-set! '$reset-input-port!
(lambda (p)
($set-port-input-size! p 0)))
;;;
(primitive-set! 'reset-input-port!
(case-lambda
[() ($reset-input-port! (current-input-port))]
[(p)
(if (input-port? p)
($reset-input-port! p)
(error 'reset-input-port! "~s is not an input-port" p))]))
;;;
(primitive-set! '$close-input-port
(lambda (p)
(($port-handler p) 'close-port p)))
;;;
(primitive-set! 'close-input-port
(case-lambda
[() ($close-input-port (current-input-port))]
[(p)
(if (input-port? p)
($close-input-port p)
(error 'close-input-port! "~s is not an input-port" p))]))
;;;
(primitive-set! '$close-output-port
(lambda (p)
(($port-handler p) 'close-port p)))
;;;
(primitive-set! 'close-output-port
(case-lambda
[() ($close-output-port (current-output-port))]
[(p)
(if (output-port? p)
($close-output-port p)
(error 'close-output-port "~s is not an output-port" p))]))
;;;
(primitive-set! '$flush-output-port
(lambda (p)
(($port-handler p) 'flush-output-port p)))
;;;
(primitive-set! 'flush-output-port
(case-lambda
[() ($flush-output-port (current-output-port))]
[(p)
(if (output-port? p)
($flush-output-port p)
(error 'flush-output-port "~s is not an output-port" p))])))
(let ()
;;; INPUT FILES
(include "message-case.ss")
(define make-input-file-handler
(lambda (fd port-name)
(let ((open? #t))
(lambda (msg . args)
(message-case msg args
[(read-char p)
(unless (input-port? p)
(error 'read-char "~s is not an input port" p))
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
(begin
($set-port-input-index! p ($fxadd1 idx))
($string-ref ($port-input-buffer p) idx))
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
($port-input-buffer p))])
(cond
[(not bytes)
(error 'read-char "Cannot read from ~s" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-input-size! p bytes)
($read-char p)]))
(error 'read-char "port ~s is closed" p))))]
[(peek-char p)
(unless (input-port? p)
(error 'peek-char "~s is not an input port" p))
(let ([idx ($port-input-index p)])
(if ($fx< idx ($port-input-size p))
($string-ref ($port-input-buffer p) idx)
(if open?
(let ([bytes
(foreign-call "ikrt_read" fd
(port-input-buffer p))])
(cond
[(not bytes)
(error 'peek-char
"Cannot read from ~s" port-name)]
[($fx= bytes 0)
(eof-object)]
[else
($set-port-input-size! p bytes)
($peek-char p)]))
(error 'peek-char "port ~s is closed" p))))]
[(unread-char c p)
(unless (input-port? p)
(error 'unread-char "~s is not an input port" p))
(let ([idx ($fxsub1 ($port-input-index p))])
(if (and ($fx>= idx 0)
($fx< idx ($port-input-size p)))
(begin
($set-port-input-index! p idx)
($string-set! ($port-input-buffer p) idx c))
(if open?
(error 'unread-char "port ~s is closed" p)
(error 'unread-char "too many unread-chars"))))]
[(port-name p) port-name]
[(close-port p)
(unless (input-port? p)
(error 'close-input-port "~s is not an input port" p))
(when open?
($set-port-input-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-input-port "cannot close ~s" port-name)))]
[else
(error 'input-file-handler
"message not handled ~s" (cons msg args))])))))
(define open-input-file
(lambda (filename)
(let ([fd/error (foreign-call "ikrt_open_input_file" filename)])
(if (fixnum? fd/error)
(let ([port (make-input-port
(make-input-file-handler fd/error filename)
(make-string 4096))])
(set-port-input-size! port 0)
port)
(error 'open-input-file "cannot open ~s: ~a" filename fd/error)))))
(primitive-set! '*standard-input-port*
(let ([p (make-input-port
(make-input-file-handler 0 '*stdin*)
(make-string 4096))])
(set-port-input-size! p 0)
p))
(primitive-set! 'console-input-port (lambda () *standard-input-port*))
(primitive-set! '*current-input-port* *standard-input-port*)
(primitive-set! 'current-input-port
(case-lambda
[() *current-input-port*]
[(p)
(if (input-port? p)
(primitive-set! '*current-input-port* p)
(error 'current-input-port "~s is not an input-port" p))]))
(primitive-set! 'open-input-file
(lambda (filename)
(if (string? filename)
(open-input-file filename)
(error 'open-input-file "~s is not a string" filename)))))
(let ()
;;; OUTPUT FILES
(include "message-case.ss")
(define do-write-buffer
(lambda (fd port-name p caller)
(let ([bytes (foreign-call "ikrt_write_file"
fd
(port-output-buffer p)
(port-output-index p))])
(if (fixnum? bytes)
(set-port-output-index! p 0)
(error caller "cannot write to file ~s: ~a" port-name bytes)))))
(define make-output-file-handler
(lambda (fd port-name)
(define open? #t)
(define output-file-handler
(lambda (msg . args)
(message-case msg args
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(do-write-buffer fd port-name p 'write-char)
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(if (output-port? p)
(if open?
(do-write-buffer fd port-name p 'flush-output-port)
(error 'flush-output-port "port ~s is closed" p))
(error 'flush-output-port "~s is not an output-port" p))]
[(close-port p)
(when open?
(flush-output-port p)
($set-port-output-size! p 0)
(set! open? #f)
(unless (foreign-call "ikrt_close_file" fd)
(error 'close-output-port "cannot close ~s" port-name)))]
[(port-name p) port-name]
[else (error 'output-file-handler
"unhandled message ~s" (cons msg args))])))
output-file-handler))
(define (option-id x)
(case x
[(error) 0]
[(replace) 1]
[(truncate) 2]
[(append) 3]
[else (error 'open-output-file "~s is not a valid mode" x)]))
(define open-output-file
(lambda (filename options)
(let ([fd/error
(foreign-call "ikrt_open_output_file"
filename
(option-id options))])
(if (fixnum? fd/error)
(make-output-port
(make-output-file-handler fd/error filename)
(make-string 4096))
(error 'open-output-file "cannot open ~s: ~a" filename fd/error)))))
(primitive-set! '*standard-output-port*
(make-output-port
(make-output-file-handler 1 '*stdout*)
(make-string 4096)))
(primitive-set! '*current-output-port* *standard-output-port*)
(primitive-set! '*standard-error-port*
(make-output-port
(make-output-file-handler 2 '*stderr*)
(make-string 4096)))
(primitive-set! 'standard-output-port
(lambda () *standard-output-port*))
(primitive-set! 'standard-error-port
(lambda () *standard-error-port*))
(primitive-set! 'console-output-port
(lambda () *standard-output-port*))
(primitive-set! 'current-output-port
(case-lambda
[() *current-output-port*]
[(p)
(if (output-port? p)
(primitive-set! '*current-output-port* p)
(error 'current-output-port "~s is not an output port" p))]))
(primitive-set! 'open-output-file
(case-lambda
[(filename)
(if (string? filename)
(open-output-file filename 'error)
(error 'open-output-file "~s is not a string" filename))]
[(filename options)
(if (string? filename)
(open-output-file filename options)
(error 'open-output-file "~s is not a string" filename))])))
(let ()
(include "message-case.ss")
;;; OUTPUT STRINGS
(define string-copy
(lambda (s)
(substring s 0 (string-length s))))
(define concat
(lambda (str i ls)
(let ([n (sum i ls)])
(let ([outstr ($make-string n)])
(let f ([n (copy outstr str i n)] [ls ls])
(if (null? ls)
outstr
(let ([a ($car ls)])
(f (copy outstr a ($string-length a) n) ($cdr ls)))))))))
(define sum
(lambda (ac ls)
(cond
[(null? ls) ac]
[else (sum ($fx+ ac ($string-length ($car ls))) ($cdr ls))])))
(define copy
(lambda (dst src n end)
(let f ([di end]
[si n])
(cond
[($fx= si 0) di]
[else
(let ([di ($fxsub1 di)] [si ($fxsub1 si)])
($string-set! dst di ($string-ref src si))
(f di si))]))))
(define make-output-string-handler
(lambda ()
(define buffer-list '())
(define open? #t)
(define output-handler
(lambda (msg . args)
(message-case msg args
[(write-char c p)
(if (char? c)
(if (output-port? p)
(let ([idx ($port-output-index p)])
(if ($fx< idx ($port-output-size p))
(begin
($string-set! ($port-output-buffer p) idx c)
($set-port-output-index! p ($fxadd1 idx)))
(if open?
(begin
(set! buffer-list
(cons (string-copy (port-output-buffer p))
buffer-list))
($set-port-output-size! p
($string-length ($port-output-buffer p)))
($write-char c p))
(error 'write-char "port ~s is closed" p))))
(error 'write-char "~s is not an output-port" p))
(error 'write-char "~s is not a character" c))]
[(flush-output-port p)
(void)]
[(close-port p)
(set! open? #f)]
[(port-name p) 'string-port]
[(get-output-string p)
(concat ($port-output-buffer p)
($port-output-index p)
buffer-list)]
[else (error 'output-handler
"unhandled message ~s" (cons msg args))])))
output-handler))
(primitive-set! 'open-output-string
(lambda ()
(make-output-port
(make-output-string-handler)
(make-string 10))))
(primitive-set! 'get-output-string
(lambda (p)
(if (output-port? p)
(($port-handler p) 'get-output-string p)
(error 'get-output-string "~s is not an output port" p))))
)
(primitive-set! 'with-output-to-file
(lambda (name proc . args)
(unless (string? name)
(error 'with-output-to-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-output-to-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(parameterize ([current-output-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-output-to-file
"cannot reenter")))
proc
(lambda ()
(close-output-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-output-file
(lambda (name proc . args)
(unless (string? name)
(error 'call-with-output-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-output-file "~s is not a procedure" proc))
(let ([p (apply open-output-file name args)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-output-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-output-port p)
(set! shot #t))))))
(primitive-set! 'with-input-from-file
(lambda (name proc)
(unless (string? name)
(error 'with-input-from-file "~s is not a string" name))
(unless (procedure? proc)
(error 'with-input-from-file "~s is not a procedure" proc))
(let ([p (open-input-file name)]
[shot #f])
(parameterize ([current-input-port p])
(dynamic-wind
(lambda ()
(when shot
(error 'with-input-from-file
"cannot reenter")))
proc
(lambda ()
(close-input-port p)
(set! shot #t)))))))
(primitive-set! 'call-with-input-file
(lambda (name proc)
(unless (string? name)
(error 'call-with-input-file "~s is not a string" name))
(unless (procedure? proc)
(error 'call-with-input-file "~s is not a procedure" proc))
(let ([p (open-input-file name)]
[shot #f])
(dynamic-wind
(lambda ()
(when shot
(error 'call-with-input-file "cannot reenter")))
(lambda () (proc p))
(lambda ()
(close-input-port p)
(set! shot #t))))))

BIN
src/libcollect.fasl
View File

Binary file not shown.

3035
src/libcompile-6.4.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3435
src/libcompile-6.5.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3446
src/libcompile-6.6.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3660
src/libcompile-6.7.ss Normal file
View File

File diff suppressed because it is too large Load Diff

3677
src/libcompile-8.1.ss Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
src/libcontrol.fasl
View File

Binary file not shown.

1664
src/libcore-6.9.ss Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
src/libcore.fasl
View File

Binary file not shown.

BIN
src/libcxr.fasl
View File

Binary file not shown.

BIN
src/libexpand.fasl
View File

Binary file not shown.

67
src/libfasl-6.0.ss
View File

@ -1,4 +1,3 @@
;;; not finished yet
;;; FASL
;;;
@ -20,7 +19,10 @@
;;; "V" + 4-bytes(n) + object ... : a vector of length n followed by n
;;; objects
;;; "S" + 4-bytes(n) + char ... : a string
;;; "M" + object + object : a symbol with name field and a unique-name field
;;; "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
;;;
@ -41,7 +43,6 @@
(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)
@ -86,11 +87,11 @@
(f x (fxadd1 i) n)]))]
[(gensym? x)
(write-char #\G p)
(do-write (gensym->unique-name x) p h
(do-write (symbol->string x) p h m))]
(fasl-write (gensym->unique-string x) p h
(fasl-write (symbol->string x) p h m))]
[(symbol? x)
(write-char #\M p)
(do-write (symbol->string x) p h m)]
(fasl-write (symbol->string x) p h m)]
[(code? x)
(write-char #\X p)
(let ([code-vec (code-code-vec x)]
@ -132,6 +133,36 @@
(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)
@ -153,7 +184,7 @@
(write-char #\< p)
(write-int (fx- 0 mark) p)
m]))]
[else (error 'fasl-write "BUG: not in hash table")])))
[else (error 'fasl-write "BUG: not in hash table ~s" x)])))
(define make-graph
(lambda (x h)
(unless (immediate? x)
@ -172,7 +203,9 @@
(unless (fx= i n)
(make-graph (vector-ref x i) h)
(f x (fxadd1 i) n)))]
[(symbol? x) (void)]
[(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)])
@ -188,6 +221,24 @@
(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)

217
src/libfasl-6.6.ss Normal file
View File

@ -0,0 +1,217 @@
;;; 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)])))

217
src/libfasl-6.7.ss Normal file
View File

@ -0,0 +1,217 @@
;;; 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-fixnum (code-freevars 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)])))

45
src/libhandlers-6.9.ss Normal file
View File

@ -0,0 +1,45 @@
(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")))
(primitive-set! 'top-level-value-error
(lambda (x)
(cond
[(symbol? x)
(if (top-level-bound? x)
(error 'top-level-value "BUG in ~s" x)
(error 'top-level-value "~s is unbound" x))]
[else
(error 'top-level-value "~s is not a symbol" x)])))
(primitive-set! 'car-error
(lambda (x)
(error 'car "~s is not a pair" x)))
(primitive-set! 'cdr-error
(lambda (x)
(error 'cdr "~s is not a pair" x)))

BIN
src/libhandlers.fasl
View File

Binary file not shown.

15
src/libhash-6.2.ss
View File

@ -91,6 +91,8 @@
($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))])
@ -98,7 +100,6 @@
(let ([n ($vector-ref vec idx)])
($set-tcbucket-next! b n)
($vector-set! vec idx b)
($set-tcbucket-tconc! b (get-tc h))
(void))))))))
(define get-hash
@ -129,9 +130,15 @@
($set-tcbucket-val! b v)
(void))]
[else
($vector-set! vec idx
($make-tcbucket (get-tc h) x v
($vector-ref vec idx)))
(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 ([ct (get-count h)])
(set-count! h ($fxadd1 ct))
(when ($fx> ct ($vector-length vec))

14
src/libintelasm-6.0.ss
View File

@ -375,13 +375,13 @@
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 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

920
src/libintelasm-6.4.ss Normal file
View File

@ -0,0 +1,920 @@
;;;
;;; 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 Normal file
View File

@ -0,0 +1,932 @@
;;;
;;; 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*)
)

887
src/libintelasm-6.9.ss Normal file
View File

@ -0,0 +1,887 @@
;;;
;;; 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 with-args
; (lambda (ls f)
; (apply f (cdr ls))))
(define-syntax with-args
(syntax-rules (lambda)
[(_ x (lambda (a0 a1) b b* ...))
(let ([t x])
(if (pair? t)
(let ([t ($cdr t)])
(if (pair? t)
(let ([a0 ($car t)] [t ($cdr t)])
(if (pair? t)
(let ([a1 ($car t)])
(if (null? ($cdr t))
(let () b b* ...)
(error 'with-args "too many args")))
(error 'with-args "too few args")))
(error 'with-args "too few args")))
(error 'with-args "too few args")))]))
;(define byte
; (lambda (x)
; (cons 'byte (fxlogand x 255))))
(define-syntax byte
(syntax-rules ()
[(_ x) (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 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)))]
[(imm? i)
(CODE c (ModRM 2 d s (IMM32 i ac)))]
[else (error 'CODErri "invalid i=~s" i)])))
(define CODErr
(lambda (c d s ac)
(CODE c (ModRM 3 d s ac))))
(define CODEri
(lambda (c d i ac)
(CODE+r c d (IMM32 i ac))))
(define RegReg
(lambda (r1 r2 r3 ac)
(cond
[(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")]
[(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")]
[else
(list*
(byte (fxlogor 4 (fxsll (register-index r1) 3)))
(byte (fxlogor (register-index r2)
(fxsll (register-index r3) 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 CODEdi
(lambda (c disp n ac)
(with-args disp
(lambda (a1 a2)
(cond
[(and (reg? a1) (reg? a2))
(error 'CODEdi "unsupported1")]
[(and (imm? a1) (reg? a2))
(CODErri c '/0 a2 a1 (IMM32 n ac))]
[(and (imm? a1) (imm? a2))
(error 'CODEdi "unsupported2")]
[else (error 'CODEdi "unhandled ~s" disp)])))))
(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 2)
(if (fx= (length args) 2)
(proc a ac (car args) (cadr args))
(error 'convert-instruction "incorrect args in ~s" a))]
[(fx= n 1)
(if (fx= (length args) 1)
(proc a ac (car args))
(error 'convert-instruction "incorrect args in ~s" a))]
[(fx= n 0)
(if (fx= (length args) 0)
(proc a ac)
(error 'convert-instruction "incorrect args in ~s" a))]
[else
(if (fx= (length args) n)
(apply proc a ac args)
(error 'convert-instruction "incorrect args in ~s" a))])))]
[else (error 'convert-instruction "unknown instruction in ~s" a)]))
;;; instr/null is for 1-byte instructions that take no arguments
;(define (instr/null code ac)
; (cons code ac))
;(define (instr/ir arg1 arg2 ac ircode)
; (CODE+r ircode arg2 (IMM32 arg1 ac)))
;
;(define (instr/im arg1 arg2 ac imcode)
; (error 'instr/im "not implemented"))
;
;(define (instr/rr arg1 arg2 ac rrcode)
; (CODErr rrcode arg1 arg2 ac))
;
;(define (instr/rm arg1 arg2 ac rmcode)
; (CODErd rmcode arg1 arg2 ac))
(define (instr/2 arg1 arg2 ac ircode imcode rrcode rmcode mrcode)
(cond
[(imm? arg1)
(cond
[(reg? arg2) (CODEri ircode arg2 arg1 ac)]
[(mem? arg2) (CODEdi imcode arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[(reg? arg1)
(cond
[(reg? arg2) (CODErr rrcode arg1 arg2 ac)]
[(mem? arg2) (CODErd rmcode arg1 arg2 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[(mem? arg1)
(cond
[(reg? arg2) (CODErd mrcode arg2 arg1 ac)]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)])]
[else (error 'instr/2 "invalid args ~s ~s" arg1 arg2)]))
(module ()
(define who 'assembler)
(define (conditional-set c dst ac)
(cond
[(reg8? dst)
(CODE #x0F (CODE c (ModRM 3 '/0 dst ac)))]
[else (error who "invalid condition-set to ~s" dst)]))
(define (conditional-jump c dst ac)
(cond
[(imm? dst)
(CODE #x0F (CODE c (IMM32 dst ac)))]
[(label? dst)
(CODE #x0F (CODE c (cons (cons 'relative (label-name dst)) ac)))]
[else (error who "invalid conditional jump target ~s" dst)]))
(add-instructions instr ac
[(ret) (CODE #xC3 ac)]
[(cltd) (CODE #x99 ac)]
[(movl src dst) (instr/2 src dst ac #xB8 #xC7 #x89 #x89 #x8B)]
[(movb src dst)
(cond
[(and (imm8? src) (mem? dst)) (CODEdi8 #xC6 dst src 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
[(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)))]
[(and (reg? src) (reg? dst))
(CODE #x01 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x03 dst src ac)]
[else (error who "invalid ~s" instr)])]
[(subl src dst)
(cond
[(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)))]
[(and (reg? src) (reg? dst))
(CODE #x29 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x2B dst src ac)]
[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 (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? src) (reg? dst))
(CODE #x21 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x23 dst src ac)]
[else (error who "invalid ~s" instr)])]
[(orl src dst)
(cond
[(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)))]
[(and (reg? src) (reg? dst))
(CODE #x09 (ModRM 3 src dst ac))]
[(and (mem? src) (reg? dst))
(CODErd #x0B dst src ac)]
[else (error who "invalid ~s" instr)])]
[(xorl src dst)
(cond
[(and (reg? src) (reg? dst))
(CODE #x31 (ModRM 3 src dst ac))]
[(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)])]
[(jmp 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 target ~s" dst)])]
[(call 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 target ~s" dst)])]
[(seta dst) (conditional-set #x97 dst ac)]
[(setae dst) (conditional-set #x93 dst ac)]
[(setb dst) (conditional-set #x92 dst ac)]
[(setbe dst) (conditional-set #x96 dst ac)]
[(setg dst) (conditional-set #x9F dst ac)]
[(setge dst) (conditional-set #x9D dst ac)]
[(setl dst) (conditional-set #x9C dst ac)]
[(setle dst) (conditional-set #x9E dst ac)]
[(sete dst) (conditional-set #x94 dst ac)]
[(setna dst) (conditional-set #x96 dst ac)]
[(setnae dst) (conditional-set #x92 dst ac)]
[(setnb dst) (conditional-set #x93 dst ac)]
[(setnbe dst) (conditional-set #x97 dst ac)]
[(setng dst) (conditional-set #x9E dst ac)]
[(setnge dst) (conditional-set #x9C dst ac)]
[(setnl dst) (conditional-set #x9D dst ac)]
[(setnle dst) (conditional-set #x9F dst ac)]
[(setne dst) (conditional-set #x95 dst ac)]
[(ja dst) (conditional-jump #x87 dst ac)]
[(jae dst) (conditional-jump #x83 dst ac)]
[(jb dst) (conditional-jump #x82 dst ac)]
[(jbe dst) (conditional-jump #x86 dst ac)]
[(jg dst) (conditional-jump #x8F dst ac)]
[(jge dst) (conditional-jump #x8D dst ac)]
[(jl dst) (conditional-jump #x8C dst ac)]
[(jle dst) (conditional-jump #x8E dst ac)]
[(je dst) (conditional-jump #x84 dst ac)]
[(jna dst) (conditional-jump #x86 dst ac)]
[(jnae dst) (conditional-jump #x82 dst ac)]
[(jnb dst) (conditional-jump #x83 dst ac)]
[(jnbe dst) (conditional-jump #x87 dst ac)]
[(jng dst) (conditional-jump #x8E dst ac)]
[(jnge dst) (conditional-jump #x8C dst ac)]
[(jnl dst) (conditional-jump #x8D dst ac)]
[(jnle dst) (conditional-jump #x8F dst ac)]
[(jne dst) (conditional-jump #x85 dst ac)]
[(byte x)
(unless (byte? x) (error who "~s is not a byte" x))
(cons (byte x) ac)]
[(byte-vector x) (append (map (lambda (x) (byte x)) (vector->list x)) ac)]
[(int a) (IMM32 instr ac)]
[(label L)
(unless (symbol? L) (error who "label ~s is not a symbol" L))
(cons (cons 'label L) ac)]
[(label-address L)
(unless (symbol? L) (error who "label-address ~s is not a symbol" L))
(cons (cons 'label-addr L) ac)]
[(current-frame-offset)
(cons '(current-frame-offset) ac)]
[(nop) ac]
))
(define compute-code-size
(lambda (ls)
(fold (lambda (x ac)
(if (fixnum? x)
(fx+ ac 1)
(case (car x)
[(byte) (fx+ ac 1)]
[(word reloc-word reloc-word+ label-addr foreign-label
relative local-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 (optimize-local-jumps ls)
(define locals '())
(define g (gensym))
(for-each
(lambda (x)
(when (and (pair? x) (eq? (car x) 'label))
(putprop (cdr x) g 'local)
(set! locals (cons (cdr x) locals))))
ls)
(for-each
(lambda (x)
(when (and (pair? x)
(eq? (car x) 'relative)
(eq? (getprop (cdr x) g) 'local))
(set-car! x 'local-relative)))
ls)
(for-each (lambda (x) (remprop x g)) locals)
ls)
(define whack-instructions
(lambda (x ls)
(define f
(lambda (ls idx reloc)
(cond
[(null? ls) reloc]
[else
(let ([a (car ls)])
(if (fixnum? a)
(begin
(code-set! x idx a)
(f (cdr ls) (fxadd1 idx) reloc))
(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))]
[(local-relative 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)
(if (fixnum? 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 local-relative) ac]
[else (error 'compute-reloc-size "unknown instr ~s" x)])))
0
ls)))
(define whack-reloc
(lambda (code 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))]
[(local-relative)
(let ([loc (label-loc v)])
(let ([obj (car loc)] [disp (cdr loc)])
(unless (eq? obj code)
(error 'whack-reloc "local-relative differ"))
(let ([rel (fx- disp (fx+ idx 4))])
(code-set! code (fx+ idx 0) (fxlogand rel #xFF))
(code-set! code (fx+ idx 1) (fxlogand (fxsra rel 8) #xFF))
(code-set! code (fx+ idx 2) (fxlogand (fxsra rel 16) #xFF))
(code-set! code (fx+ idx 3) (fxlogand (fxsra rel 24) #xFF)))))]
[(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*)]
[ls* (map optimize-local-jumps 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 (foo reloc*)
(for-each (whack-reloc (car foo) (cdr foo)) reloc*))
(map cons code* 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*)
)

324
src/libinterpret-6.5.ss Normal file
View File

@ -0,0 +1,324 @@
;;; Changes:
;;; 6.5: handles letrec
;;; 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 'letrec)
(let ([bind* (car d)] [body* (cdr d)])
(if (null? bind*)
(C*->last (car body*) (cdr body*) env)
(let ([lhs* (map car bind*)] [rhs* (map cadr bind*)])
(let ([env (extend-env lhs* env)])
(let ([body* (C*->last (car body*) (cdr body*) env)]
[rhs* (C*->list (car rhs*) (cdr rhs*) env)]
[n (length lhs*)])
(lambda (renv)
(let ([v (make-vector n)])
(let ([renv (cons v renv)])
(let f ([i 0] [ls (rhs* renv)])
(if (null? ls)
(body* renv)
(begin
(vector-set! v i (car ls))
(f (fxadd1 i) (cdr ls))))))))
)))))]
[(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 '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.

407
src/libio-6.9.ss Normal file
View File

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

BIN
src/libio.fasl
View File

Binary file not shown.

53
src/libnumerics-7.1.ss Normal file
View File

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

254
src/librecord-6.4.ss Normal file
View File

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

BIN
src/librecord.fasl
View File

Binary file not shown.

534
src/libsyncase-6.2.ss
View File

@ -1,534 +0,0 @@
;;; 6.2: initial syncase implementation
;;;
;;; Expand : Scheme -> Core Scheme
;;;
;;; <CS> ::= (quote datum)
;;; | <gensym>
;;; | (if <CS> <CS> <CS>)
;;; | (set! <gensym> <CS>)
;;; | (begin <CS> <CS> ...)
;;; | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
;;; | (lambda <FMLS> <CS> <CS> ...)
;;; | (<prim> <CS> <CS> ...)
;;; | (#primitive| <primname>)
;;; | (<CS> <CS> ...)
;;; <FML> ::= ()
;;; | <gensym>
;;; | (<gensym> . <FML>)
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
;;; | primitive-set! | foreign-call | $apply
(let ([*stx* (make-record-type "*stx*" '(e marks ribcage))]
[*rib* (make-record-type "*rib*" '(sym* marks* lab*))]
[*top* (make-record-type "*top*" '())])
(define stx? (record-predicate *stx*))
(define make-stx (record-constructor *stx*))
(define stx-e (record-field-accessor *stx* 'e))
(define stx-marks (record-field-accessor *stx* 'marks))
(define stx-ribcage (record-field-accessor *stx* 'ribcage))
(define make-rib (record-constructor *rib*))
(define rib-sym* (record-field-accessor *rib* 'sym*))
(define rib-marks* (record-field-accessor *rib* 'marks*))
(define rib-lab* (record-field-accessor *rib* 'lab*))
(define *top-ribcage* ((record-constructor *top*)))
(define (top? x) (eq? x *top-ribcage*))
(define *syncase-macro* (gensym "*syncase-macro*"))
(define (build-data x) `(quote ,x))
(define (build-global-ref x) `(top-level-value ',x))
(define (build-lexical-ref x) x)
(define (build-app a d) `(,a . ,d))
(define (build-lambda fml* body)
(cond
[(and (pair? body) (eq? (car body) 'begin))
`(lambda ,fml* . ,(cdr body))]
[else
`(lambda ,fml* ,body)]))
(define (build-begin body*) `(begin . ,body*))
(define (build-void) `(void))
(define (build-if e0 e1 e2) `(if ,e0 ,e1 ,e2))
(define (build-foreign-call e e*) `(foreign-call ,e ,e*))
(define (id? x)
(and (stx? x)
(symbol? (stx-e x))))
(define (stx->datum x) ;;;; use strip
(cond
[(stx? x) (stx-e x)]
[else x]))
(define (stx-pair? x)
(and (stx? x)
(pair? (stx-e x))))
(define (strip x)
(cond
[(stx? x) (stx-e x)]
[else x]))
(define label? string?)
(define (eqmarks? m1* m2*)
(cond
[(null? m1*) (null? m2*)]
[(memq (car m1*) m2*) (eqmarks? (cdr m1*) (remq (car m1*) m2*))]
[else #f]))
(define (rib-lookup sym m* sym* m** lab*)
(and (pair? sym*)
(if (and (eq? sym (car sym*))
(eqmarks? m* (car m**)))
(car lab*)
(rib-lookup sym m* (cdr sym*) (cdr m**) (cdr lab*)))))
(define (ribcage-lookup sym m* rc)
(cond
[(pair? rc)
(let ([r (car rc)])
(cond
[(eq? r 'shift)
(ribcage-lookup sym (cdr m*) (cdr rc))]
[else
(or (rib-lookup sym m* (rib-sym* r) (rib-marks* r) (rib-lab* r))
(ribcage-lookup sym m* (cdr rc)))]))]
[(top? rc) #f]
[else (error "BUG1")]))
(define (resolve x)
(unless (id? x) (error "BUG2"))
(let ([sym (stx-e x)]
[m* (stx-marks x)]
[rc (stx-ribcage x)])
(or (ribcage-lookup sym m* rc) ; bound -> label
(getprop sym *syncase-macro*) ; top-level-macros -> pair
sym ; global -> symbol
)))
(define (remove-last ls)
(let ([d (cdr ls)])
(cond
[(null? d) '()]
[else (cons (car ls) (remove-last d))])))
(define (unshift rc)
(cond
[(pair? rc)
(if (eq? (car rc) 'shift)
(cdr rc)
(cons (car rc) (unshift (cdr rc))))]
[else (error "BUG3: missing shift")]))
(define (push-wrap m r x)
(cond
[(stx? x)
(let ([xm (stx-marks x)])
(cond
[(and (pair? xm) (eq? (car xm) #f))
(make-stx (stx-e x)
(append (remove-last m) (cdr xm))
(unshift (append r (stx-ribcage x))))]
[else
(make-stx (stx-e x)
(append m xm)
(append r (stx-ribcage x)))]))]
[else (make-stx x m r)]))
(define (push-subst sym* marks* lab* x)
(cond
[(stx? x)
(make-stx (stx-e x)
(stx-marks x)
(cons (make-rib sym* marks* lab*) (stx-ribcage x)))]
[else
(make-stx x
'()
(cons (make-rib sym* marks* lab*) '()))]))
(define (push-antimark x)
(cond
[(stx? x)
(make-stx (stx-e x)
(cons #f (stx-marks x))
(stx-ribcage x))]
[else (make-stx x (cons #f '()) '())]))
(define (push-mark m x)
(cond
[(stx? x)
(let ([m* (stx-marks x)])
(cond
[(and (pair? m*) (eq? (car m*) #f))
(make-stx (stx-e x) (cdr m*) (stx-ribcage x))]
[else
(make-stx (stx-e x) (cons m m*) (cons 'shift (stx-ribcage x)))]))]
[else
(make-stx x (list m) '(shift))]))
(define (push-rib rib x)
(cond
[(stx? x)
(make-stx (stx-e x) (stx-marks x) (cons rib (stx-ribcage x)))]
[else (make-stx x '() (list rib))]))
(define (expose-stx x)
(let ([e (stx-e x)])
(cond
[(pair? e)
(let ([m (stx-marks x)]
[r (stx-ribcage x)])
(cons
(push-wrap m r (car e))
(push-wrap m r (cdr e))))]
[(vector? e)
(let ([m (stx-marks x)]
[r (stx-ribcage x)])
(list->vector
(map (lambda (x) (push-wrap m r x))
(vector->list e))))]
[(null? e) e]
[else x])))
(define (expose x)
(cond
[(stx? x) (expose-stx x)]
[else x]))
(define (expose-ls ox)
(let loop ([x (expose ox)])
(cond
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
[(null? x) '()]
[else (error 'expose-ls "BUG: not a list: ~s" x)])))
(define (expose* x)
(cond
[(id? x) x]
[(stx? x) (expose* (expose x))]
[(pair? x) (cons (expose* (car x)) (expose* (cdr x)))]
[(vector? x)
(list->vector (map expose* (vector->list x)))]
[else x]))
(define (lookup lab r)
(define (lookup1 lab lab* g*)
(cond
[(null? lab*) #f]
[(eq? lab (car lab*)) (car g*)]
[else (lookup1 lab (cdr lab*) (cdr g*))]))
(cond
[(null? r) #f]
[(eq? (car r) 'lexical-barrier)
(let ([v (lookup lab (cdr r))])
(cond
[(not (symbol? v)) v]
[else #f]))]
[else
(or (lookup1 lab (caar r) (cdar r))
(lookup lab (cdr r)))]))
(define (genmark) (gensym "M"))
(define (newsym x)
(gensym))
;(gensym (symbol->string x)))
(define (apply-macro proc x r)
(expand-ctx (push-mark (genmark) (proc (push-antimark x))) r))
(define (identifier-macro? x r)
(and (id? x)
(let ([a (resolve x)])
(or (and (label? a)
(let ([a (lookup a r)])
(and (procedure? a) a)))
(and (pair? a)
(eq? (car a) '*user-macro*)
(cdr a))))))
(define (macro-call? x r)
(if (id? x)
(identifier-macro? x r)
(let ([x (expose x)])
(and (pair? x)
(identifier-macro? (car x) r)))))
(define (core? x)
(and (pair? x) (eq? (car x) '*core-macro*)))
(define (apply-core-form a d ctx r)
(unless (core? a) (syntax-error ctx))
((cdr a) a d ctx r))
(define (E* d r ctx)
(let ([d (expose-ls d)])
(map (lambda (x) (E x r)) d)))
(define (extend-core name proc)
(putprop name *syncase-macro* (cons '*core-macro* proc)))
(define (extend-user-macro name proc)
(putprop name *syncase-macro* (cons '*user-macro* proc)))
(define (E ctx r)
(let ([x (expose ctx)])
(cond
[(macro-call? x r) =>
(lambda (proc)
(apply-macro proc ctx r))]
[(pair? x)
(let ([a (car x)] [d (cdr x)])
(cond
[(id? a)
(let ([a (resolve a)])
(cond
[(label? a)
(cond
[(lookup a r) =>
(lambda (g)
(cond
[(symbol? g)
(build-app (build-lexical-ref g)
(E* d r ctx))]
[(and (pair? g) (eq? (car g) 'pat))
(syntax-error ctx)]
[else (error 'expand "BUG4")]))]
[else (syntax-error ctx)])]
[(core? a)
(apply-core-form a d ctx r)]
[(symbol? a)
(build-app (build-global-ref a)
(E* d r ctx))]
[else (syntax-error ctx)]))]
[else
(build-app
(E a r)
(E* d r ctx))]))]
[(id? x)
(let ([a (resolve x)])
(cond
[(label? a)
(cond
[(lookup a r) =>
(lambda (g)
(cond
[(symbol? g) (build-lexical-ref g)]
[(and (pair? g) (eq? (car g) 'pat))
(syntax-error ctx)]
[else (error 'expand "BUG5")]))]
[else (syntax-error ctx)])]
[(core? a) (syntax-error ctx)]
[(symbol? a)
(build-global-ref a)]
[else (syntax-error ctx)]))]
[else (build-data (strip x))])))
(define (core-expand x)
(E (make-stx x '() *top-ribcage*) '()))
(define (process-fml* bind* ctx)
(define (assert-no-dups s m* s* m**)
(unless (null? s*)
(when (and (eq? s (car s*))
(eqmarks? m* (car m**)))
(syntax-error ctx))
(assert-no-dups s m* (cdr s*) (cdr m*))))
(let loop ([bind* (expose bind*)])
(cond
[(null? bind*) (values '() '() '() '() '())]
[(pair? bind*)
(let ([b (car bind*)])
(unless (id? b) (syntax-error ctx))
(let-values ([(fml* s* m** g* lab*)
(loop (expose (cdr bind*)))])
(let ([s (stx-e b)] [m* (stx-marks b)])
(assert-no-dups s m* s* m**)
(let ([lab (string #\i)] [g (newsym s)])
(values (cons g fml*)
(cons s s*)
(cons m* m**)
(cons g g*)
(cons lab lab*))))))]
[else (syntax-error ctx)])))
(define (top-level-macro? x r sym)
(let ([x (expose x)])
(and (pair? x)
(id? (car x))
(let ([loc (resolve (car x))])
(and (or (and (pair? loc)
(eq? (car loc) '*core-macro*))
(symbol? loc))
(eq? (stx->datum (car x)) sym))))))
(define (define? x r)
(top-level-macro? x r 'define))
(define (begin? x r)
(top-level-macro? x r 'begin))
(define (begin-e* x ctx)
(let ([x (expose x)])
(let loop ([x (expose (cdr x))])
(cond
[(null? x) '()]
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
[else (syntax-error ctx)]))))
(define (expand-body* body* ctx r)
(let ([rib (make-rib '() '() '())])
(let loop ([body* (expose (push-rib rib body*))]
[r r]
[lab* '()] [sym* '()] [marks* '()] [vrhs* '()])
(cond
[(null? body*) (syntax-error ctx)]
[(pair? body*)
(let ([a (car body*)] [d (cdr body*)])
(cond
[(macro-call? a r) =>
(lambda (proc)
(loop (cons (push-mark (genmark) (proc (push-antimark a))) d)
r lab* sym* marks* vrhs*))]
[(define? a r)
(let-values ([(lhs rhs) (extract-define a ctx)])
(loop (expose d)
r
(cons (string #\p) lab*)
(cons (stx-e lhs) sym*)
(cons (stx-marks lhs) marks*)
(cons rhs vrhs*)))]
[(begin? a r)
(loop (expose (append (begin-e* a ctx) d))
r lab* sym* marks* vrhs*)]
[else
;;; done
(cond
[(null? sym*)
(let ([body* (E* body* r ctx)])
(build-begin body*))]
[else
(let ([g* (map newsym sym*)])
(let* ([r (cons (cons lab* g*) r)]
[rhs*
(E* (push-subst sym* marks* lab* vrhs*)
r ctx)]
[body*
(E* (push-subst sym* marks* lab* body*)
r ctx)])
(build-letrec g* rhs* (build-begin body*))))])]))]
[else (syntax-error ctx)]))))
(define (extract-bindings bind* ctx)
(let ([bind* (expose bind*)])
(cond
[(null? bind*) (values '() '())]
[(not (pair? bind*)) (syntax-error ctx)]
[else
(let ([a (car bind*)] [d (cdr bind*)])
(let ([a (expose-ls a)])
(cond
[(fx= (length a) 2)
(let-values ([(lhs* rhs*)
(extract-bindings d ctx)])
(values (cons (car a) lhs*)
(cons (cadr a) rhs*)))]
[else (syntax-error ctx)])))])))
(define (core-stx x)
(make-stx x '() *top-ribcage*))
(extend-core 'quote
(lambda (a d ctx r)
(let ([d (expose-ls d)])
(cond
[(and (list? d) (fx= (length d) 1))
(build-data (strip (car d)))]
[else (syntax-error ctx)]))))
(extend-core 'lambda
(lambda (a d ctx r)
(let ([d (expose d)])
(cond
[(pair? d)
(let ([fml* (car d)] [body* (cdr d)])
(let-values ([(fml* s* m** g* lab*)
(process-fml* fml* ctx)])
(let ([body* (push-subst s* m** lab* body*)])
(let ([r (cons (cons lab* g*) r)])
(build-lambda fml*
(expand-body* body* ctx r))))))]
[else (syntax-error ctx)]))))
(extend-core 'if
(lambda (a d ctx r)
(let ([d (expose d)])
(unless (pair? d) (syntax-error ctx))
(let ([test (car d)] [d (expose (cdr d))])
(unless (pair? d) (syntax-error ctx))
(let ([conseq (car d)] [d (expose (cdr d))])
(let ([altern
(cond
[(null? d) (build-void)]
[(pair? d)
(let ([altern (car d)] [d (expose (cdr d))])
(cond
[(null? d) (E altern r)]
[else (syntax-error ctx)]))]
[else (syntax-error ctx)])])
(build-if (E test r) (E conseq r) altern)))))))
(extend-core 'begin
(lambda (a d ctx r)
(let ([d (expose-ls d)])
(when (null? d) (syntax-error ctx))
(build-begin (E* d r ctx)))))
(extend-core 'define
(lambda (a d ctx r) (syntax-error ctx)))
(extend-core 'foreign-call
(lambda (a d ctx r)
(let ([d (expose-ls d)])
(unless (fx>= (length d) 1) (syntax-error ctx))
(build-foreign-call
(E (car d) r)
(E* (cdr d) r ctx)))))
(extend-core 'let
(lambda (a d ctx r)
(let ([d (expose d)])
(unless (pair? d) (syntax-error ctx))
(let ([bind* (car d)] [body* (cdr d)])
(let-values ([(lhs* rhs*)
(extract-bindings bind* ctx)])
(let ([lambda^ (core-stx 'lambda)])
(E `((,lambda^ ,lhs* . ,body*) . ,rhs*) r)))))))
(extend-core 'let*
(lambda (a d ctx r)
(let ([d (expose d)])
(unless (pair? d) (syntax-error ctx))
(let ([bind* (car d)] [body* (cdr d)])
(let-values ([(lhs* rhs*)
(extract-bindings bind* ctx)])
(let ([lambda^ (core-stx 'lambda)])
(E (let f ([lhs* lhs*] [rhs* rhs*])
(cond
[(null? lhs*)
`((,lambda^ () . ,body*))]
[else
`((,lambda^ (,(car lhs*))
,(f (cdr lhs*) (cdr rhs*)))
,(car rhs*))]))
r)))))))
(set! expand core-expand)
)

BIN
src/libtokenizer.fasl
View File

Binary file not shown.

61
src/libtoplevel-6.9.ss Normal file
View File

@ -0,0 +1,61 @@
(for-each
(lambda (x)
($set-symbol-value! x (primitive-ref x)))
(public-primitives))
(let ()
(define add-prim
(lambda (x)
(let ([g (gensym (symbol->string x))])
(putprop x '|#system| g)
(putprop g '*sc-expander* (cons 'core-primitive x)))))
(for-each add-prim (public-primitives))
(for-each add-prim (system-primitives)))
(for-each
(lambda (x)
(cond