Removed all version names from files
This commit is contained in:
Abdulaziz Ghuloum
parent
10268dfc43
commit
f6a95c07d2
|
|
@ -0,0 +1,7 @@
|
|||
*.tmp
|
||||
*.out
|
||||
*.fasl
|
||||
.gdb_history
|
||||
.bzrignore
|
||||
.bzrignore
|
||||
./ikarus.boot.back
|
||||
|
|
@ -2,7 +2,8 @@
|
|||
all: ikarus.boot
|
||||
|
||||
ikarus.boot: *.ss
|
||||
echo '(load "makefile.ss")' | ../runtime/ikarus ikarus.boot
|
||||
cp ikarus.boot ikarus.boot.back
|
||||
echo '(load "makefile.ss")' | time ../runtime/ikarus ikarus.boot
|
||||
|
||||
clean:
|
||||
rm -f *.fasl
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
2006-08-25
|
||||
|
|
@ -1,290 +0,0 @@
|
|||
|
||||
|
||||
;;; 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-input-file
|
||||
open-output-string get-output-string
|
||||
with-output-to-file call-with-output-file
|
||||
with-input-from-file call-with-input-file
|
||||
date-string
|
||||
|
||||
))
|
||||
|
||||
(define system-primitives
|
||||
'(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
|
||||
vector-memq vector-memv
|
||||
|
||||
;;; must open-code
|
||||
$make-port/input
|
||||
$make-port/output
|
||||
$make-port/both
|
||||
$make-input-port $make-output-port $make-input/output-port
|
||||
$port-handler
|
||||
$port-input-buffer $port-input-index $port-input-size
|
||||
$port-output-buffer $port-output-index $port-output-size
|
||||
$set-port-input-index! $set-port-input-size!
|
||||
$set-port-output-index! $set-port-output-size!
|
||||
|
||||
;;; better open-code
|
||||
$write-char $read-char $peek-char $unread-char
|
||||
|
||||
;;; never open-code
|
||||
$reset-input-port! $close-input-port
|
||||
$close-output-port $flush-output-port
|
||||
*standard-output-port* *standard-error-port* *current-output-port*
|
||||
*standard-input-port* *current-input-port*
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.9.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-8.1.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" #t "libcollect.fasl"]
|
||||
["librecord-6.4.ss" #t "librecord.fasl"]
|
||||
["libcxr-6.0.ss" #t "libcxr.fasl"]
|
||||
["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)))
|
||||
|
||||
(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))))
|
||||
|
|
@ -1,290 +0,0 @@
|
|||
|
||||
|
||||
;;; 8.1: * using chez-style io ports
|
||||
;;; 6.9: * creating a *system* environment
|
||||
;;; 6.8: * creating a core-primitive form in the expander
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
|
||||
|
||||
|
||||
(define macros
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call $apply
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda))
|
||||
|
||||
|
||||
|
||||
(define public-primitives
|
||||
'(null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure?
|
||||
not
|
||||
eof-object eof-object? bwp-object?
|
||||
void
|
||||
fx= fx< fx<= fx> fx>= fxzero?
|
||||
fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo
|
||||
fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
|
||||
integer->char char->integer
|
||||
char=? char<? char<=? char>? char>=?
|
||||
cons car cdr set-car! set-cdr!
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
list list* make-list length list-ref
|
||||
append
|
||||
make-vector vector-ref vector-set! vector-length vector
|
||||
vector->list list->vector
|
||||
make-string string-ref string-set! string-length string list->string
|
||||
uuid
|
||||
string-append substring
|
||||
string=? string<? string<=? string>? string>=?
|
||||
remprop putprop getprop property-list
|
||||
apply
|
||||
map for-each andmap ormap
|
||||
memq memv assq
|
||||
eq? equal?
|
||||
reverse
|
||||
string->symbol symbol->string oblist
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string
|
||||
call-with-values values
|
||||
make-parameter dynamic-wind
|
||||
display write print-graph fasl-write printf format print-error
|
||||
read-token read
|
||||
error exit call/cc
|
||||
current-error-handler
|
||||
eval current-eval interpret compile compile-file new-cafe load
|
||||
system
|
||||
expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment
|
||||
identifier? free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list
|
||||
generate-temporaries
|
||||
record? record-set! record-ref record-length
|
||||
record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output
|
||||
$make-environment
|
||||
features
|
||||
|
||||
port? input-port? output-port?
|
||||
make-input-port make-output-port make-input/output-port
|
||||
port-handler
|
||||
port-input-buffer port-input-index port-input-size
|
||||
port-output-buffer port-output-index port-output-size
|
||||
set-port-input-index! set-port-input-size!
|
||||
set-port-output-index! set-port-output-size!
|
||||
port-name input-port-name output-port-name
|
||||
write-char read-char unread-char peek-char
|
||||
newline
|
||||
reset-input-port! flush-output-port
|
||||
close-input-port close-output-port
|
||||
console-input-port current-input-port
|
||||
standard-output-port standard-error-port
|
||||
console-output-port current-output-port
|
||||
open-output-file open-input-file
|
||||
open-output-string get-output-string
|
||||
with-output-to-file call-with-output-file
|
||||
with-input-from-file call-with-input-file
|
||||
date-string
|
||||
|
||||
))
|
||||
|
||||
(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
|
||||
vector-memq vector-memv
|
||||
|
||||
;;; must open-code
|
||||
$make-port/input
|
||||
$make-port/output
|
||||
$make-port/both
|
||||
$make-input-port $make-output-port $make-input/output-port
|
||||
$port-handler
|
||||
$port-input-buffer $port-input-index $port-input-size
|
||||
$port-output-buffer $port-output-index $port-output-size
|
||||
$set-port-input-index! $set-port-input-size!
|
||||
$set-port-output-index! $set-port-output-size!
|
||||
|
||||
;;; better open-code
|
||||
$write-char $read-char $peek-char $unread-char
|
||||
|
||||
;;; never open-code
|
||||
$reset-input-port! $close-input-port
|
||||
$close-output-port $flush-output-port
|
||||
*standard-output-port* *standard-error-port* *current-output-port*
|
||||
*standard-input-port* *current-input-port*
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.9.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-8.1.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" #t "libcollect.fasl"]
|
||||
["librecord-6.4.ss" #t "librecord.fasl"]
|
||||
["libcxr-6.0.ss" #t "libcxr.fasl"]
|
||||
["libcore-6.9.ss" #t "libcore.fasl"]
|
||||
["libchezio-8.1.ss" #t "libchezio.fasl"]
|
||||
["libhash-6.2.ss" #t "libhash.fasl"]
|
||||
["libwriter-9.0.ss" #t "libwriter.fasl"]
|
||||
["libtokenizer-9.0.ss" #t "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" #t "libassembler.ss"]
|
||||
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" #t "libfasl.fasl"]
|
||||
["libcompile-9.0.ss" #t "libcompile.fasl"]
|
||||
["psyntax-7.1-9.0.ss" #t "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" #t "libcafe.fasl"]
|
||||
["libtrace-6.9.ss" #t "libtrace.fasl"]
|
||||
["libposix-6.0.ss" #t "libposix.fasl"]
|
||||
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (cadr x)
|
||||
(compile-library (car x) (caddr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
[(null? ls) ""]
|
||||
[else
|
||||
(let ([str (open-output-string)])
|
||||
(let f ([a (car ls)] [d (cdr ls)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(display a str)
|
||||
(get-output-string str)]
|
||||
[else
|
||||
(display a str)
|
||||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.fasl"
|
||||
(join " " (map caddr scheme-library-files))))
|
||||
|
|
@ -1,297 +0,0 @@
|
|||
|
||||
|
||||
;;; 9.1: * starting with libnumerics
|
||||
;;; 9.0: * graph marks for both reader and writer
|
||||
;;; * circularity detection during read
|
||||
;;; 8.1: * using chez-style io ports
|
||||
;;; 6.9: * creating a *system* environment
|
||||
;;; 6.8: * creating a core-primitive form in the expander
|
||||
;;; 6.2: * side-effects now modify the dirty-vector
|
||||
;;; * added bwp-object?
|
||||
;;; * added pointer-value
|
||||
;;; * added tcbuckets
|
||||
;;; 6.1: * added case-lambda, dropped lambda
|
||||
;;; 6.0: * basic compiler
|
||||
|
||||
|
||||
|
||||
|
||||
(define macros
|
||||
'(|#primitive| lambda case-lambda set! quote begin define if letrec
|
||||
foreign-call $apply
|
||||
quasiquote unquote unquote-splicing
|
||||
define-syntax identifier-syntax let-syntax letrec-syntax
|
||||
fluid-let-syntax alias meta eval-when with-implicit with-syntax
|
||||
type-descriptor
|
||||
syntax-case syntax-rules module $module import $import import-only
|
||||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda))
|
||||
|
||||
|
||||
|
||||
(define public-primitives
|
||||
'(null? pair? char? fixnum? symbol? gensym? string? vector? list?
|
||||
boolean? procedure?
|
||||
not
|
||||
eof-object eof-object? bwp-object?
|
||||
void
|
||||
fx= fx< fx<= fx> fx>= fxzero?
|
||||
fx+ fx- fx* fxadd1 fxsub1 fxquotient fxremainder fxmodulo
|
||||
fxsll fxsra fxlognot fxlogor fxlogand fxlogxor
|
||||
integer->char char->integer
|
||||
char=? char<? char<=? char>? char>=?
|
||||
cons car cdr set-car! set-cdr!
|
||||
caar cadr cdar cddr
|
||||
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
||||
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
||||
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
||||
list list* make-list length list-ref
|
||||
append
|
||||
make-vector vector-ref vector-set! vector-length vector
|
||||
vector->list list->vector
|
||||
make-string string-ref string-set! string-length string list->string
|
||||
uuid
|
||||
string-append substring
|
||||
string=? string<? string<=? string>? string>=?
|
||||
remprop putprop getprop property-list
|
||||
apply
|
||||
map for-each andmap ormap
|
||||
memq memv assq
|
||||
eq? equal?
|
||||
reverse
|
||||
string->symbol symbol->string oblist
|
||||
top-level-value set-top-level-value! top-level-bound?
|
||||
gensym gensym-count gensym-prefix print-gensym
|
||||
gensym->unique-string
|
||||
call-with-values values
|
||||
make-parameter dynamic-wind
|
||||
display write print-graph fasl-write printf format print-error
|
||||
read-token read
|
||||
error exit call/cc
|
||||
current-error-handler
|
||||
eval current-eval interpret compile compile-file new-cafe load
|
||||
system
|
||||
expand sc-expand current-expand expand-mode
|
||||
environment? interaction-environment
|
||||
identifier? free-identifier=? bound-identifier=? literal-identifier=?
|
||||
datum->syntax-object syntax-object->datum syntax-error
|
||||
syntax->list
|
||||
generate-temporaries
|
||||
record? record-set! record-ref record-length
|
||||
record-type-descriptor make-record-type
|
||||
record-printer record-name record-field-accessor
|
||||
record-field-mutator record-predicate record-constructor
|
||||
record-type-name record-type-symbol record-type-field-names
|
||||
hash-table? make-hash-table get-hash-table put-hash-table!
|
||||
assembler-output
|
||||
$make-environment
|
||||
features
|
||||
|
||||
port? input-port? output-port?
|
||||
make-input-port make-output-port make-input/output-port
|
||||
port-handler
|
||||
port-input-buffer port-input-index port-input-size
|
||||
port-output-buffer port-output-index port-output-size
|
||||
set-port-input-index! set-port-input-size!
|
||||
set-port-output-index! set-port-output-size!
|
||||
port-name input-port-name output-port-name
|
||||
write-char read-char unread-char peek-char
|
||||
newline
|
||||
reset-input-port! flush-output-port
|
||||
close-input-port close-output-port
|
||||
console-input-port current-input-port
|
||||
standard-output-port standard-error-port
|
||||
console-output-port current-output-port
|
||||
open-output-file open-input-file
|
||||
open-output-string get-output-string
|
||||
with-output-to-file call-with-output-file
|
||||
with-input-from-file call-with-input-file
|
||||
date-string
|
||||
|
||||
+ - add1 sub1 * expt number? positive? negative? zero? number->string
|
||||
logand
|
||||
= < > <= >=
|
||||
))
|
||||
|
||||
(define system-primitives
|
||||
'(immediate? $unbound-object? $forward-ptr?
|
||||
pointer-value
|
||||
primitive-ref primitive-set!
|
||||
$fx= $fx< $fx<= $fx> $fx>= $fxzero?
|
||||
$fx+ $fx- $fx* $fxadd1 $fxsub1 $fxquotient $fxremainder $fxmodulo
|
||||
$fxsll $fxsra $fxlognot $fxlogor $fxlogand $fxlogxor
|
||||
$fixnum->char $char->fixnum
|
||||
$char= $char< $char<= $char> $char>=
|
||||
$car $cdr $set-car! $set-cdr!
|
||||
$make-vector $vector-ref $vector-set! $vector-length
|
||||
$make-string $string-ref $string-set! $string-length $string
|
||||
$symbol-string $symbol-unique-string $symbol-value
|
||||
$set-symbol-string! $set-symbol-unique-string! $set-symbol-value!
|
||||
$make-symbol $set-symbol-plist! $symbol-plist
|
||||
$sc-put-cte
|
||||
$record? $record/rtd? $record-set! $record-ref $record-rtd
|
||||
$make-record $record
|
||||
$base-rtd
|
||||
$code? $code-reloc-vector $code-freevars $code-size $code-ref $code-set!
|
||||
$code->closure list*->code*
|
||||
make-code code? set-code-reloc-vector! code-reloc-vector code-freevars
|
||||
code-size code-ref code-set!
|
||||
$frame->continuation $fp-at-base $current-frame $seal-frame-and-call
|
||||
$make-call-with-values-procedure $make-values-procedure
|
||||
do-overflow collect
|
||||
$make-tcbucket $tcbucket-next $tcbucket-key $tcbucket-val
|
||||
$set-tcbucket-next! $set-tcbucket-val! $set-tcbucket-tconc!
|
||||
call/cf trace-symbol! untrace-symbol! make-traced-procedure
|
||||
fixnum->string
|
||||
vector-memq vector-memv
|
||||
|
||||
;;; must open-code
|
||||
$make-port/input
|
||||
$make-port/output
|
||||
$make-port/both
|
||||
$make-input-port $make-output-port $make-input/output-port
|
||||
$port-handler
|
||||
$port-input-buffer $port-input-index $port-input-size
|
||||
$port-output-buffer $port-output-index $port-output-size
|
||||
$set-port-input-index! $set-port-input-size!
|
||||
$set-port-output-index! $set-port-output-size!
|
||||
|
||||
;;; better open-code
|
||||
$write-char $read-char $peek-char $unread-char
|
||||
|
||||
;;; never open-code
|
||||
$reset-input-port! $close-input-port
|
||||
$close-output-port $flush-output-port
|
||||
*standard-output-port* *standard-error-port* *current-output-port*
|
||||
*standard-input-port* *current-input-port*
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (whack-system-env setenv?)
|
||||
(define add-prim
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))])
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* (cons 'core-primitive x)))))
|
||||
(define add-macro
|
||||
(lambda (x)
|
||||
(let ([g (gensym (symbol->string x))]
|
||||
[e (getprop x '*sc-expander*)])
|
||||
(when e
|
||||
(putprop x '|#system| g)
|
||||
(putprop g '*sc-expander* e)))))
|
||||
(define (foo)
|
||||
(eval
|
||||
`(begin
|
||||
(define-syntax compile-time-date-string
|
||||
(lambda (x)
|
||||
#'(quote ,(date-string))))
|
||||
(define-syntax public-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,public-primitives)))
|
||||
(define-syntax system-primitives
|
||||
(lambda (x)
|
||||
#'(quote ,system-primitives)))
|
||||
(define-syntax macros
|
||||
(lambda (x)
|
||||
#'(quote ,macros))))))
|
||||
(set! system-env ($make-environment '|#system| #t))
|
||||
(for-each add-macro macros)
|
||||
(for-each add-prim public-primitives)
|
||||
(for-each add-prim system-primitives)
|
||||
(if setenv?
|
||||
(parameterize ([interaction-environment system-env])
|
||||
(foo))
|
||||
(foo)))
|
||||
|
||||
|
||||
|
||||
(when (eq? "" "")
|
||||
(load "chez-compat.ss")
|
||||
(set! primitive-ref top-level-value)
|
||||
(set! primitive-set! set-top-level-value!)
|
||||
(set! chez-expand sc-expand)
|
||||
(set! chez-current-expand current-expand)
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #f)
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1-6.9.ss")
|
||||
(chez-current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
(whack-system-env #t)
|
||||
(printf "ok\n")
|
||||
(load "libassembler-compat-6.7.ss") ; defines make-code etc.
|
||||
(load "libintelasm-6.9.ss") ; uses make-code, etc.
|
||||
(load "libfasl-6.7.ss") ; uses code? etc.
|
||||
(load "libcompile-8.1.ss") ; uses fasl-write
|
||||
)
|
||||
|
||||
|
||||
(whack-system-env #t)
|
||||
|
||||
(define scheme-library-files
|
||||
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
|
||||
["libcollect-6.1.ss" #t "libcollect.fasl"]
|
||||
["librecord-6.4.ss" #t "librecord.fasl"]
|
||||
["libcxr-6.0.ss" #t "libcxr.fasl"]
|
||||
["libnumerics-9.1.ss" #t "libnumerics.fasl"]
|
||||
["libcore-6.9.ss" #t "libcore.fasl"]
|
||||
["libchezio-8.1.ss" #t "libchezio.fasl"]
|
||||
["libhash-6.2.ss" #t "libhash.fasl"]
|
||||
["libwriter-9.1.ss" #t "libwriter.fasl"]
|
||||
["libtokenizer-9.1.ss" #t "libtokenizer.fasl"]
|
||||
["libassembler-6.7.ss" #t "libassembler.ss"]
|
||||
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
|
||||
["libfasl-6.7.ss" #t "libfasl.fasl"]
|
||||
["libcompile-9.1.ss" #t "libcompile.fasl"]
|
||||
["psyntax-7.1-9.1.ss" #t "psyntax.fasl"]
|
||||
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
|
||||
["libcafe-6.1.ss" #t "libcafe.fasl"]
|
||||
["libtrace-6.9.ss" #t "libtrace.fasl"]
|
||||
["libposix-6.0.ss" #t "libposix.fasl"]
|
||||
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define (compile-library ifile ofile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(printf "compiling ~a ...\n" ifile)
|
||||
(compile-file ifile ofile 'replace)))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (cadr x)
|
||||
(compile-library (car x) (caddr x))))
|
||||
scheme-library-files)
|
||||
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
[(null? ls) ""]
|
||||
[else
|
||||
(let ([str (open-output-string)])
|
||||
(let f ([a (car ls)] [d (cdr ls)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(display a str)
|
||||
(get-output-string str)]
|
||||
[else
|
||||
(display a str)
|
||||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.fasl"
|
||||
(join " " (map caddr scheme-library-files))))
|
||||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -1,207 +0,0 @@
|
|||
|
||||
(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc))])
|
||||
;;; accessors
|
||||
(define get-vec (record-field-accessor hash-rtd 0))
|
||||
(define set-vec! (record-field-mutator hash-rtd 0))
|
||||
(define get-count (record-field-accessor hash-rtd 1))
|
||||
(define set-count! (record-field-mutator hash-rtd 1))
|
||||
(define get-tc (record-field-accessor hash-rtd 2))
|
||||
;;; implementation
|
||||
|
||||
;;; directly from Dybvig's paper
|
||||
(define tc-pop
|
||||
(lambda (tc)
|
||||
(let ([x ($car tc)])
|
||||
(if (eq? x ($cdr tc))
|
||||
#f
|
||||
(let ([v ($car x)])
|
||||
($set-car! tc ($cdr x))
|
||||
($set-car! x #f)
|
||||
($set-cdr! x #f)
|
||||
v)))))
|
||||
|
||||
(define inthash
|
||||
(lambda (key)
|
||||
;static int inthash(int key) { /* from Bob Jenkin's */
|
||||
; key += ~(key << 15);
|
||||
; key ^= (key >> 10);
|
||||
; key += (key << 3);
|
||||
; key ^= (key >> 6);
|
||||
; key += ~(key << 11);
|
||||
; key ^= (key >> 16);
|
||||
; return key;
|
||||
;}
|
||||
(let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
|
||||
[key ($fxlogxor key ($fxsra key 10))]
|
||||
[key ($fx+ key ($fxsll key 3))]
|
||||
[key ($fxlogxor key ($fxsra key 6))]
|
||||
[key ($fx+ key ($fxlognot ($fxsll key 11)))]
|
||||
[key ($fxlogxor key ($fxsra key 16))])
|
||||
key)))
|
||||
|
||||
;;; assq-like lookup
|
||||
(define direct-lookup
|
||||
(lambda (x b)
|
||||
(if (fixnum? b)
|
||||
#f
|
||||
(if (eq? x ($tcbucket-key b))
|
||||
b
|
||||
(direct-lookup x ($tcbucket-next b))))))
|
||||
|
||||
(define rehash-lookup
|
||||
(lambda (h tc x)
|
||||
(cond
|
||||
[(tc-pop tc) =>
|
||||
(lambda (b)
|
||||
(re-add! h b)
|
||||
(if (eq? x ($tcbucket-key b))
|
||||
b
|
||||
(rehash-lookup h tc x)))]
|
||||
[else #f])))
|
||||
|
||||
(define get-bucket-index
|
||||
(lambda (b)
|
||||
(let ([next ($tcbucket-next b)])
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next)))))
|
||||
|
||||
(define replace!
|
||||
(lambda (lb x y)
|
||||
(let ([n ($tcbucket-next lb)])
|
||||
(cond
|
||||
[(eq? n x)
|
||||
($set-tcbucket-next! lb y)
|
||||
(void)]
|
||||
[else
|
||||
(replace! n x y)]))))
|
||||
|
||||
(define re-add!
|
||||
(lambda (h b)
|
||||
(let ([vec (get-vec h)]
|
||||
[next ($tcbucket-next b)])
|
||||
;;; first remove it from its old place
|
||||
(let ([idx
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next))])
|
||||
(let ([fst ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(eq? fst b)
|
||||
($vector-set! vec idx next)]
|
||||
[else
|
||||
(replace! fst b next)])))
|
||||
;;; reset the tcbucket-tconc FIRST
|
||||
($set-tcbucket-tconc! b (get-tc h))
|
||||
;;; then add it to the new place
|
||||
(let ([k ($tcbucket-key b)])
|
||||
(let ([ih (inthash (pointer-value k))])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([n ($vector-ref vec idx)])
|
||||
($set-tcbucket-next! b n)
|
||||
($vector-set! vec idx b)
|
||||
(void))))))))
|
||||
|
||||
(define get-hash
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (get-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($tcbucket-val b))]
|
||||
[else v])))))))
|
||||
|
||||
(define put-hash!
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (get-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($set-tcbucket-val! b v)
|
||||
(void))]
|
||||
[else
|
||||
(let ([bucket
|
||||
($make-tcbucket (get-tc h) x v ($vector-ref vec idx))])
|
||||
(if ($fx= (pointer-value x) pv)
|
||||
($vector-set! vec idx bucket)
|
||||
(let* ([ih (inthash (pointer-value x))]
|
||||
[idx
|
||||
($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
($set-tcbucket-next! bucket ($vector-ref vec idx))
|
||||
($vector-set! vec idx bucket))))
|
||||
(let ([ct (get-count h)])
|
||||
(set-count! h ($fxadd1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))])))))))
|
||||
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x ($tcbucket-key b)]
|
||||
[pv (pointer-value x)]
|
||||
[ih (inthash pv)]
|
||||
[idx ($fxlogand ih mask)]
|
||||
[next ($tcbucket-next b)])
|
||||
($set-tcbucket-next! b ($vector-ref vec idx))
|
||||
($vector-set! vec idx b)
|
||||
(unless (fixnum? next)
|
||||
(insert-b next vec mask)))))
|
||||
|
||||
(define move-all
|
||||
(lambda (vec1 i n vec2 mask)
|
||||
(unless ($fx= i n)
|
||||
(let ([b ($vector-ref vec1 i)])
|
||||
(unless (fixnum? b)
|
||||
(insert-b b vec2 mask))
|
||||
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||||
|
||||
(define enlarge-table
|
||||
(lambda (h)
|
||||
(let* ([vec1 (get-vec h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-vec! h vec2))))
|
||||
|
||||
|
||||
|
||||
(define init-vec
|
||||
(lambda (v i n)
|
||||
(if ($fx= i n)
|
||||
v
|
||||
(begin
|
||||
($vector-set! v i i)
|
||||
(init-vec v ($fxadd1 i) n)))))
|
||||
|
||||
(define make-base-vec
|
||||
(lambda (n)
|
||||
(init-vec (make-vector n) 0 n)))
|
||||
|
||||
;;; public interface
|
||||
(primitive-set! 'hash-table? (record-predicate hash-rtd))
|
||||
(primitive-set! 'make-hash-table
|
||||
(let ([make (record-constructor hash-rtd)])
|
||||
(lambda ()
|
||||
(let ([x (cons #f #f)])
|
||||
(let ([tc (cons x x)])
|
||||
(make (make-base-vec 32) 0 tc))))))
|
||||
(primitive-set! 'get-hash-table
|
||||
(lambda (h x v)
|
||||
(if (hash-table? h)
|
||||
(get-hash h x v)
|
||||
(error 'get-hash-table "~s is not a hash table" h))))
|
||||
(primitive-set! 'put-hash-table!
|
||||
(lambda (h x v)
|
||||
(if (hash-table? h)
|
||||
(put-hash! h x v)
|
||||
(error 'put-hash-table! "~s is not a hash table" h)))))
|
||||
|
|
@ -1,513 +0,0 @@
|
|||
(let ()
|
||||
(define char-whitespace?
|
||||
(lambda (c)
|
||||
(or ($char= #\space c)
|
||||
(memq ($char->fixnum c) '(9 10 11 12 13)))))
|
||||
(define delimiter?
|
||||
(lambda (c)
|
||||
(or (char-whitespace? c)
|
||||
(memq c '(#\( #\) #\[ #\] #\' #\` #\, #\")))))
|
||||
(define digit?
|
||||
(lambda (c)
|
||||
(and ($char<= #\0 c) ($char<= c #\9))))
|
||||
(define char->num
|
||||
(lambda (c)
|
||||
(fx- ($char->fixnum c) ($char->fixnum #\0))))
|
||||
(define initial?
|
||||
(lambda (c)
|
||||
(or (letter? c) (special-initial? c))))
|
||||
(define letter?
|
||||
(lambda (c)
|
||||
(or (and ($char<= #\a c) ($char<= c #\z))
|
||||
(and ($char<= #\A c) ($char<= c #\Z)))))
|
||||
(define af?
|
||||
(lambda (c)
|
||||
(or (and ($char<= #\a c) ($char<= c #\f))
|
||||
(and ($char<= #\A c) ($char<= c #\F)))))
|
||||
(define af->num
|
||||
(lambda (c)
|
||||
(if (and ($char<= #\a c) ($char<= c #\f))
|
||||
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\a)))
|
||||
(fx+ 10 (fx- ($char->fixnum c) ($char->fixnum #\A))))))
|
||||
(define special-initial?
|
||||
(lambda (c)
|
||||
(memq c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
|
||||
(define subsequent?
|
||||
(lambda (c)
|
||||
(or (initial? c) (digit? c) (special-subsequent? c))))
|
||||
(define special-subsequent?
|
||||
(lambda (c)
|
||||
(memq c '(#\+ #\- #\. #\@))))
|
||||
(define tokenize-number
|
||||
(lambda (n p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) n]
|
||||
[(digit? c)
|
||||
(tokenize-number (fx+ (fx* n 10) (char->num c)) p)]
|
||||
[(delimiter? c)
|
||||
(unread-char c p)
|
||||
n]
|
||||
[else
|
||||
(unread-char c p)
|
||||
(error 'tokenize "invalid number syntax: ~a~a" n c)]))))
|
||||
(define tokenize-hex
|
||||
(lambda (n p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) n]
|
||||
[(digit? c)
|
||||
(tokenize-hex (fx+ (fx* n 16) (char->num c)) p)]
|
||||
[(af? c)
|
||||
(tokenize-hex (fx+ (fx* n 16) (af->num c)) p)]
|
||||
[(delimiter? c)
|
||||
(unread-char c p)
|
||||
n]
|
||||
[else
|
||||
(unread-char c p)
|
||||
(error 'tokenize "invalid hex number sequence: ~a~a" n c)]))))
|
||||
(define tokenize-hex-init
|
||||
(lambda (p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(unread-char c p)
|
||||
(error 'tokenize "invalid #x near end of file")]
|
||||
[(digit? c)
|
||||
(cons 'datum (tokenize-hex (char->num c) p))]
|
||||
[(af? c)
|
||||
(cons 'datum (tokenize-hex (af->num c) p))]
|
||||
[($char= c #\-)
|
||||
(cons 'datum (fx- 0 (tokenize-hex 0 p)))]
|
||||
[($char= c #\+)
|
||||
(cons 'datum (tokenize-hex 0 p))]
|
||||
[else
|
||||
(unread-char c p)
|
||||
(error 'tokenize "invalid number syntax: #x~a" c)]))))
|
||||
(define tokenize-identifier
|
||||
(lambda (ls p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) ls]
|
||||
[(subsequent? c)
|
||||
(tokenize-identifier (cons c ls) p)]
|
||||
[(delimiter? c)
|
||||
(unread-char c p)
|
||||
ls]
|
||||
[else
|
||||
(unread-char c p)
|
||||
(error 'tokenize "invalid identifier syntax: ~a"
|
||||
(list->string (reverse (cons c ls))))]))))
|
||||
(define tokenize-string
|
||||
(lambda (ls p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(error 'tokenize "end-of-file while inside a string")]
|
||||
[($char= #\" c) ls]
|
||||
[($char= #\\ c)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[($char= #\" c) (tokenize-string (cons #\" ls) p)]
|
||||
[($char= #\\ c) (tokenize-string (cons #\\ ls) p)]
|
||||
[($char= #\n c) (tokenize-string (cons #\newline ls) p)]
|
||||
[($char= #\t c) (tokenize-string (cons #\tab ls) p)]
|
||||
[else (error 'tokenize "invalid string escape \\~a" c)]))]
|
||||
[else
|
||||
(tokenize-string (cons c ls) p)]))))
|
||||
(define skip-comment
|
||||
(lambda (p)
|
||||
(let ([c (read-char p)])
|
||||
(unless (eof-object? c)
|
||||
(let ([i ($char->fixnum c)])
|
||||
(unless (or (fx= i 10) (fx= i 13))
|
||||
(skip-comment p)))))))
|
||||
(define tokenize-plus
|
||||
(lambda (p)
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) '(datum . +)]
|
||||
[(delimiter? c) '(datum . +)]
|
||||
[(digit? c)
|
||||
(read-char p)
|
||||
(cons 'datum (tokenize-number (char->num c) p))]
|
||||
[else (error 'tokenize "invalid sequence +~a" c)]))))
|
||||
(define tokenize-minus
|
||||
(lambda (p)
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) '(datum . -)]
|
||||
[(delimiter? c) '(datum . -)]
|
||||
[(digit? c)
|
||||
(read-char p)
|
||||
(cons 'datum (fx- 0 (tokenize-number (char->num c) p)))]
|
||||
[else (error 'tokenize "invalid sequence -~a" c)]))))
|
||||
(define tokenize-dot
|
||||
(lambda (p)
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) 'dot]
|
||||
[(delimiter? c) 'dot]
|
||||
[($char= c #\.) ; this is second dot
|
||||
(read-char p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(error 'tokenize "invalid syntax .. near end of file")]
|
||||
[($char= c #\.) ; this is the third
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) '(datum . ...)]
|
||||
[(delimiter? c) '(datum . ...)]
|
||||
[else
|
||||
(error 'tokenize "invalid syntax ...~a" c)]))]
|
||||
[else
|
||||
(unread-char c)
|
||||
(error 'tokenize "invalid syntax ..~a" c)]))]
|
||||
[else
|
||||
(error 'tokenize "invalid syntax .~a" c)]))))
|
||||
(define tokenize-char*
|
||||
(lambda (i str p d)
|
||||
(cond
|
||||
[(fx= i (string-length str))
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) d]
|
||||
[(delimiter? c) d]
|
||||
[else (error 'tokenize "invalid character after #\\~a" str)]))]
|
||||
[else
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(error 'tokenize "invalid eof in the middle of #\\~a" str)]
|
||||
[($char= c (string-ref str i))
|
||||
(tokenize-char* (fxadd1 i) str p d)]
|
||||
[else
|
||||
(error 'tokenize
|
||||
"invalid char ~a while scanning #\\~a" c str)]))])))
|
||||
(define tokenize-char-seq
|
||||
(lambda (p str d)
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) (cons 'datum (string-ref str 0))]
|
||||
[(delimiter? c) (cons 'datum (string-ref str 0))]
|
||||
[($char= (string-ref str 1) c)
|
||||
(read-char p)
|
||||
(tokenize-char* 2 str p d)]
|
||||
[else (error 'tokenize "invalid syntax near #\\~a~a"
|
||||
(string-ref str 0) c)]))))
|
||||
(define tokenize-char
|
||||
(lambda (p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(error 'tokenize "invalid #\\ near end of file")]
|
||||
[($char= #\s c)
|
||||
(tokenize-char-seq p "space" '(datum . #\space))]
|
||||
[($char= #\n c)
|
||||
(tokenize-char-seq p "newline" '(datum . #\newline))]
|
||||
[($char= #\t c)
|
||||
(tokenize-char-seq p "tab" '(datum . #\tab))]
|
||||
[($char= #\r c)
|
||||
(tokenize-char-seq p "return" '(datum . #\return))]
|
||||
[else
|
||||
(let ([n (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? n) (cons 'datum c)]
|
||||
[(delimiter? n) (cons 'datum c)]
|
||||
[else
|
||||
(error 'tokenize "invalid syntax #\\~a~a" c n)]))]))))
|
||||
(define multiline-error
|
||||
(lambda ()
|
||||
(error 'tokenize
|
||||
"end of file encountered while inside a #|-style comment")))
|
||||
(define multiline-comment
|
||||
(lambda (p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) (multiline-error)]
|
||||
[($char= #\| c)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) (multiline-error)]
|
||||
[($char= #\# c) (void)]
|
||||
[else (multiline-comment p)]))]
|
||||
[($char= #\# c)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) (multiline-error)]
|
||||
[($char= #\| c)
|
||||
(multiline-comment p)
|
||||
(multiline-comment p)]
|
||||
[else
|
||||
(multiline-comment p)]))]
|
||||
[else (multiline-comment p)]))))
|
||||
(define read-binary
|
||||
(lambda (ac chars p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) ac]
|
||||
[($char= #\0 c) (read-binary (fxsll ac 1) (cons c chars) p)]
|
||||
[($char= #\1 c) (read-binary (fx+ (fxsll ac 1) 1) (cons c chars) p)]
|
||||
[(delimiter? c) (unread-char c p) ac]
|
||||
[else
|
||||
(unread-char c)
|
||||
(error 'tokenize "invalid syntax #b~a"
|
||||
(list->string (reverse (cons c chars))))]))))
|
||||
(define tokenize-hash
|
||||
(lambda (p)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c) (error 'tokenize "invalid # near end of file")]
|
||||
[($char= c #\t)
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) '(datum . #t)]
|
||||
[(delimiter? c) '(datum . #t)]
|
||||
[else (error 'tokenize "invalid syntax near #t")]))]
|
||||
[($char= c #\f)
|
||||
(let ([c (peek-char p)])
|
||||
(cond
|
||||
[(eof-object? c) '(datum . #f)]
|
||||
[(delimiter? c) '(datum . #f)]
|
||||
[else (error 'tokenize "invalid syntax near #f")]))]
|
||||
[($char= #\\ c) (tokenize-char p)]
|
||||
[($char= #\( c) 'vparen]
|
||||
[($char= #\x c) (tokenize-hex-init p)]
|
||||
[($char= #\' c) '(macro . syntax)]
|
||||
[($char= #\; c) 'hash-semi]
|
||||
[($char= #\% c) '(macro . |#primitive|)]
|
||||
[($char= #\| c) (multiline-comment p) (tokenize p)]
|
||||
[($char= #\b c)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(error 'tokenize "invalid eof while reading #b")]
|
||||
[($char= #\- c)
|
||||
(let ([c (read-char p)])
|
||||
(cond
|
||||
[(eof-object? c)
|
||||
(error 'tokenize "invalid eof while reading #b-")]
|
||||
[($char= #\0 c)
|
||||
(cons 'datum
|
||||
(fx- 0 (read-binary 0 '(#\0 #\-) p)))]
|
||||