Removed all version names from files
This commit is contained in:
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
|
all: ikarus.boot
|
||||||
|
|
||||||
ikarus.boot: *.ss
|
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:
|
clean:
|
||||||
rm -f *.fasl
|
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)))]
|
|
||||||
[($char= #\1 c)
|
|
||||||
(cons 'datum
|
|
||||||
(fx- 0 (read-binary 1 '(#\1 #\-) p)))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid binary syntax #b-~a" c)]))]
|
|
||||||
[($char= #\0 c)
|
|
||||||
(cons 'datum (read-binary 0 '(#\0) p))]
|
|
||||||
[($char= #\1 c)
|
|
||||||
(cons 'datum (read-binary 1 '(#\1) p))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid syntax #b~a" c)]
|
|
||||||
))]
|
|
||||||
[($char= #\! c)
|
|
||||||
(let ([e (read-char p)])
|
|
||||||
(when (eof-object? e)
|
|
||||||
(error 'tokenize "invalid eof near #!"))
|
|
||||||
(unless ($char= #\e e)
|
|
||||||
(error 'tokenize "invalid syntax near #!~a" e))
|
|
||||||
(let ([o (read-char p)])
|
|
||||||
(when (eof-object? o)
|
|
||||||
(error 'tokenize "invalid eof near #!e"))
|
|
||||||
(unless ($char= #\o o)
|
|
||||||
(error 'tokenize "invalid syntax near #!e~a" o))
|
|
||||||
(let ([f (read-char p)])
|
|
||||||
(when (eof-object? f)
|
|
||||||
(error 'tokenize "invalid syntax near #!eo"))
|
|
||||||
(unless ($char= #\f f)
|
|
||||||
(error 'tokenize "invalid syntax near #!eo~a" f))
|
|
||||||
(cons 'datum (eof-object)))))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid syntax #~a" c)]))))
|
|
||||||
(define tokenize-bar
|
|
||||||
(lambda (p ac)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c)
|
|
||||||
(error 'tokenize "unexpected eof while reading symbol")]
|
|
||||||
[($char= #\\ c)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c)
|
|
||||||
(error 'tokenize "unexpected eof while reading symbol")]
|
|
||||||
[else (tokenize-bar p (cons c ac))]))]
|
|
||||||
[($char= #\| c) ac]
|
|
||||||
[else (tokenize-bar p (cons c ac))]))))
|
|
||||||
(define tokenize
|
|
||||||
(lambda (p)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c) (eof-object)]
|
|
||||||
[(char-whitespace? c) (tokenize p)]
|
|
||||||
[($char= #\( c) 'lparen]
|
|
||||||
[($char= #\) c) 'rparen]
|
|
||||||
[($char= #\[ c) 'lbrack]
|
|
||||||
[($char= #\] c) 'rbrack]
|
|
||||||
[($char= #\' c) '(macro . quote)]
|
|
||||||
[($char= #\` c) '(macro . quasiquote)]
|
|
||||||
[($char= #\, c)
|
|
||||||
(let ([c (peek-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c) '(macro . unquote)]
|
|
||||||
[($char= c #\@)
|
|
||||||
(read-char p)
|
|
||||||
'(macro . unquote-splicing)]
|
|
||||||
[else '(macro . unquote)]))]
|
|
||||||
[($char= #\# c) (tokenize-hash p)]
|
|
||||||
[(digit? c)
|
|
||||||
(cons 'datum (tokenize-number (char->num c) p))]
|
|
||||||
[(initial? c)
|
|
||||||
(let ([ls (reverse (tokenize-identifier (cons c '()) p))])
|
|
||||||
(cons 'datum (string->symbol (list->string ls))))]
|
|
||||||
[($char= #\" c)
|
|
||||||
(let ([ls (tokenize-string '() p)])
|
|
||||||
(cons 'datum (list->string (reverse ls))))]
|
|
||||||
[($char= #\; c)
|
|
||||||
(skip-comment p)
|
|
||||||
(tokenize p)]
|
|
||||||
[($char= #\+ c)
|
|
||||||
(tokenize-plus p)]
|
|
||||||
[($char= #\- c)
|
|
||||||
(tokenize-minus p)]
|
|
||||||
[($char= #\. c)
|
|
||||||
(tokenize-dot p)]
|
|
||||||
[($char= #\| c)
|
|
||||||
(let ([ls (reverse (tokenize-bar p '()))])
|
|
||||||
(cons 'datum (string->symbol (list->string ls))))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid syntax ~a" c)]))))
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;;--------------------------------------------------------------* READ *---
|
|
||||||
;;;
|
|
||||||
(define read-list-rest
|
|
||||||
(lambda (p end mis)
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? t)
|
|
||||||
(error 'read "end of file encountered while reading list")]
|
|
||||||
[(eq? t end) '()]
|
|
||||||
[(eq? t mis)
|
|
||||||
(error 'read "paren mismatch")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(let ([d (read p)])
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eq? t end) d]
|
|
||||||
[(eq? t mis)
|
|
||||||
(error 'read "paren mismatch")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(error 'read "cannot have two dots in a list")]
|
|
||||||
[else
|
|
||||||
(error 'read "expecting ~a, got ~a" end t)])))]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(read p)
|
|
||||||
(read-list-rest p end mis)]
|
|
||||||
[else
|
|
||||||
(let ([a (parse-token p t)])
|
|
||||||
(let ([d (read-list-rest p end mis)])
|
|
||||||
(cons a d)))]))))
|
|
||||||
(define read-list-init
|
|
||||||
(lambda (p end mis)
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? t)
|
|
||||||
(error 'read "end of file encountered while reading list")]
|
|
||||||
[(eq? t end) '()]
|
|
||||||
[(eq? t mis)
|
|
||||||
(error 'read "paren mismatch")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(error 'read "invalid dot while reading list")]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(read p)
|
|
||||||
(read-list-init p end mis)]
|
|
||||||
[else
|
|
||||||
(let ([a (parse-token p t)])
|
|
||||||
(cons a (read-list-rest p end mis)))]))))
|
|
||||||
(define vector-put!
|
|
||||||
(lambda (v i ls)
|
|
||||||
(cond
|
|
||||||
[(null? ls) v]
|
|
||||||
[else
|
|
||||||
(vector-set! v i (car ls))
|
|
||||||
(vector-put! v (fxsub1 i) (cdr ls))])))
|
|
||||||
(define read-vector
|
|
||||||
(lambda (p count ls)
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? t)
|
|
||||||
(error 'read "end of file encountered while reading a vector")]
|
|
||||||
[(eq? t 'rparen)
|
|
||||||
(let ([v (make-vector count)])
|
|
||||||
(vector-put! v (fxsub1 count) ls))]
|
|
||||||
[(eq? t 'rbrack)
|
|
||||||
(error 'read "unexpected ] while reading a vector")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(error 'read "unexpected . while reading a vector")]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(read p)
|
|
||||||
(read-vector p count ls)]
|
|
||||||
[else
|
|
||||||
(let ([a (parse-token p t)])
|
|
||||||
(read-vector p (fxadd1 count) (cons a ls)))]))))
|
|
||||||
(define parse-token
|
|
||||||
(lambda (p t)
|
|
||||||
(cond
|
|
||||||
[(eof-object? t) (eof-object)]
|
|
||||||
[(eq? t 'lparen) (read-list-init p 'rparen 'rbrack)]
|
|
||||||
[(eq? t 'lbrack) (read-list-init p 'rbrack 'rparen)]
|
|
||||||
[(eq? t 'vparen) (read-vector p 0 '())]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(read p) ; ignored expression
|
|
||||||
(read p)]
|
|
||||||
[(pair? t)
|
|
||||||
(cond
|
|
||||||
[(eq? (car t) 'datum) (cdr t)]
|
|
||||||
[(eq? (car t) 'macro)
|
|
||||||
(cons (cdr t) (cons (read p) '()))]
|
|
||||||
[else (error 'read "invalid token! ~s" t)])]
|
|
||||||
[else
|
|
||||||
(error 'read "unexpected ~s found" t)])))
|
|
||||||
(define read
|
|
||||||
(lambda (p) (parse-token p (read-token p))))
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;;--------------------------------------------------------------* INIT *---
|
|
||||||
;;;
|
|
||||||
(primitive-set! 'read-token
|
|
||||||
(case-lambda
|
|
||||||
[() (tokenize (current-input-port))]
|
|
||||||
[(p)
|
|
||||||
(if (input-port? p)
|
|
||||||
(tokenize p)
|
|
||||||
(error 'read-token "~s is not an input port" p))]))
|
|
||||||
(primitive-set! 'read
|
|
||||||
(case-lambda
|
|
||||||
[() (read (current-input-port))]
|
|
||||||
[(p)
|
|
||||||
(if (input-port? p)
|
|
||||||
(read p)
|
|
||||||
(error 'read "~s is not an input port" p))]))
|
|
||||||
(let ()
|
|
||||||
(define read-and-eval
|
|
||||||
(lambda (p)
|
|
||||||
(let ([x (read p)])
|
|
||||||
(unless (eof-object? x)
|
|
||||||
(eval x)
|
|
||||||
(read-and-eval p)))))
|
|
||||||
(primitive-set! 'load
|
|
||||||
(lambda (x)
|
|
||||||
(unless (string? x)
|
|
||||||
(error 'load "~s is not a string" x))
|
|
||||||
(let ([p (open-input-file x)])
|
|
||||||
(read-and-eval p)
|
|
||||||
(close-input-port p)))))
|
|
||||||
)
|
|
||||||
|
|
|
@ -1,626 +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)))]
|
|
||||||
[($char= #\1 c)
|
|
||||||
(cons 'datum
|
|
||||||
(fx- 0 (read-binary 1 '(#\1 #\-) p)))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid binary syntax #b-~a" c)]))]
|
|
||||||
[($char= #\0 c)
|
|
||||||
(cons 'datum (read-binary 0 '(#\0) p))]
|
|
||||||
[($char= #\1 c)
|
|
||||||
(cons 'datum (read-binary 1 '(#\1) p))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid syntax #b~a" c)]
|
|
||||||
))]
|
|
||||||
[($char= #\! c)
|
|
||||||
(let ([e (read-char p)])
|
|
||||||
(when (eof-object? e)
|
|
||||||
(error 'tokenize "invalid eof near #!"))
|
|
||||||
(unless ($char= #\e e)
|
|
||||||
(error 'tokenize "invalid syntax near #!~a" e))
|
|
||||||
(let ([o (read-char p)])
|
|
||||||
(when (eof-object? o)
|
|
||||||
(error 'tokenize "invalid eof near #!e"))
|
|
||||||
(unless ($char= #\o o)
|
|
||||||
(error 'tokenize "invalid syntax near #!e~a" o))
|
|
||||||
(let ([f (read-char p)])
|
|
||||||
(when (eof-object? f)
|
|
||||||
(error 'tokenize "invalid syntax near #!eo"))
|
|
||||||
(unless ($char= #\f f)
|
|
||||||
(error 'tokenize "invalid syntax near #!eo~a" f))
|
|
||||||
(cons 'datum (eof-object)))))]
|
|
||||||
[(digit? c)
|
|
||||||
(tokenize-hashnum p (char->num c))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid syntax #~a" c)]))))
|
|
||||||
(define (tokenize-hashnum p n)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c)
|
|
||||||
(error 'tokenize "invalid eof inside #n mark/ref")]
|
|
||||||
[($char= #\= c) (cons 'mark n)]
|
|
||||||
[($char= #\# c) (cons 'ref n)]
|
|
||||||
[(digit? c)
|
|
||||||
(tokenize-hashnum p (fx+ (fx* n 10) (char->num c)))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid char ~a while inside a #n mark/ref" c)])))
|
|
||||||
(define tokenize-bar
|
|
||||||
(lambda (p ac)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c)
|
|
||||||
(error 'tokenize "unexpected eof while reading symbol")]
|
|
||||||
[($char= #\\ c)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c)
|
|
||||||
(error 'tokenize "unexpected eof while reading symbol")]
|
|
||||||
[else (tokenize-bar p (cons c ac))]))]
|
|
||||||
[($char= #\| c) ac]
|
|
||||||
[else (tokenize-bar p (cons c ac))]))))
|
|
||||||
(define tokenize
|
|
||||||
(lambda (p)
|
|
||||||
(let ([c (read-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c) (eof-object)]
|
|
||||||
[(char-whitespace? c) (tokenize p)]
|
|
||||||
[($char= #\( c) 'lparen]
|
|
||||||
[($char= #\) c) 'rparen]
|
|
||||||
[($char= #\[ c) 'lbrack]
|
|
||||||
[($char= #\] c) 'rbrack]
|
|
||||||
[($char= #\' c) '(macro . quote)]
|
|
||||||
[($char= #\` c) '(macro . quasiquote)]
|
|
||||||
[($char= #\, c)
|
|
||||||
(let ([c (peek-char p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? c) '(macro . unquote)]
|
|
||||||
[($char= c #\@)
|
|
||||||
(read-char p)
|
|
||||||
'(macro . unquote-splicing)]
|
|
||||||
[else '(macro . unquote)]))]
|
|
||||||
[($char= #\# c) (tokenize-hash p)]
|
|
||||||
[(digit? c)
|
|
||||||
(cons 'datum (tokenize-number (char->num c) p))]
|
|
||||||
[(initial? c)
|
|
||||||
(let ([ls (reverse (tokenize-identifier (cons c '()) p))])
|
|
||||||
(cons 'datum (string->symbol (list->string ls))))]
|
|
||||||
[($char= #\" c)
|
|
||||||
(let ([ls (tokenize-string '() p)])
|
|
||||||
(cons 'datum (list->string (reverse ls))))]
|
|
||||||
[($char= #\; c)
|
|
||||||
(skip-comment p)
|
|
||||||
(tokenize p)]
|
|
||||||
[($char= #\+ c)
|
|
||||||
(tokenize-plus p)]
|
|
||||||
[($char= #\- c)
|
|
||||||
(tokenize-minus p)]
|
|
||||||
[($char= #\. c)
|
|
||||||
(tokenize-dot p)]
|
|
||||||
[($char= #\| c)
|
|
||||||
(let ([ls (reverse (tokenize-bar p '()))])
|
|
||||||
(cons 'datum (string->symbol (list->string ls))))]
|
|
||||||
[else
|
|
||||||
(unread-char c p)
|
|
||||||
(error 'tokenize "invalid syntax ~a" c)]))))
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;;--------------------------------------------------------------* READ *---
|
|
||||||
;;;
|
|
||||||
(define read-list-rest
|
|
||||||
(lambda (p locs k end mis)
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? t)
|
|
||||||
(error 'read "end of file encountered while reading list")]
|
|
||||||
[(eq? t end) (values '() locs k)]
|
|
||||||
[(eq? t mis)
|
|
||||||
(error 'read "paren mismatch")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(let-values ([(d locs k) (read-expr p locs k)])
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eq? t end) (values d locs k)]
|
|
||||||
[(eq? t mis)
|
|
||||||
(error 'read "paren mismatch")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(error 'read "cannot have two dots in a list")]
|
|
||||||
[else
|
|
||||||
(error 'read "expecting ~a, got ~a" end t)])))]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(let-values ([(ignored locs k) (read-expr p locs k)])
|
|
||||||
(read-list-rest p locs k end mis))]
|
|
||||||
[else
|
|
||||||
(let-values ([(a locs k) (parse-token p locs k t)])
|
|
||||||
(let-values ([(d locs k) (read-list-rest p locs k end mis)])
|
|
||||||
(let ([x (cons a d)])
|
|
||||||
(values x locs
|
|
||||||
(if (or (loc? a) (loc? d))
|
|
||||||
(extend-k-pair x k)
|
|
||||||
k)))))]))))
|
|
||||||
(define read-list-init
|
|
||||||
(lambda (p locs k end mis)
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? t)
|
|
||||||
(error 'read "end of file encountered while reading list")]
|
|
||||||
[(eq? t end) (values '() locs k)]
|
|
||||||
[(eq? t mis)
|
|
||||||
(error 'read "paren mismatch")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(error 'read "invalid dot while reading list")]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(let-values ([(ignored locs k) (read-expr p locs k)])
|
|
||||||
(read-list-init p locs k end mis))]
|
|
||||||
[else
|
|
||||||
(let-values ([(a locs k) (parse-token p locs k t)])
|
|
||||||
(let-values ([(d locs k) (read-list-rest p locs k end mis)])
|
|
||||||
(let ([x (cons a d)])
|
|
||||||
(values x locs
|
|
||||||
(if (or (loc? a) (loc? d))
|
|
||||||
(extend-k-pair x k)
|
|
||||||
k)))))]))))
|
|
||||||
(define extend-k-pair
|
|
||||||
(lambda (x k)
|
|
||||||
(lambda ()
|
|
||||||
(let ([a (car x)])
|
|
||||||
(when (loc? a)
|
|
||||||
(set-car! x (loc-value a))))
|
|
||||||
(let ([d (cdr x)])
|
|
||||||
(when (loc? d)
|
|
||||||
(set-cdr! x (loc-value d))))
|
|
||||||
(k))))
|
|
||||||
(define vector-put
|
|
||||||
(lambda (v k i ls)
|
|
||||||
(cond
|
|
||||||
[(null? ls) k]
|
|
||||||
[else
|
|
||||||
(let ([a (car ls)])
|
|
||||||
(vector-set! v i a)
|
|
||||||
(vector-put v
|
|
||||||
(if (loc? a)
|
|
||||||
(lambda ()
|
|
||||||
(vector-set! v i (loc-value (vector-ref v i)))
|
|
||||||
(k))
|
|
||||||
k)
|
|
||||||
(fxsub1 i) (cdr ls)))])))
|
|
||||||
(define read-vector
|
|
||||||
(lambda (p locs k count ls)
|
|
||||||
(let ([t (read-token p)])
|
|
||||||
(cond
|
|
||||||
[(eof-object? t)
|
|
||||||
(error 'read "end of file encountered while reading a vector")]
|
|
||||||
[(eq? t 'rparen)
|
|
||||||
(let ([v (make-vector count)])
|
|
||||||
(let ([k (vector-put v k (fxsub1 count) ls)])
|
|
||||||
(values v locs k)))]
|
|
||||||
[(eq? t 'rbrack)
|
|
||||||
(error 'read "unexpected ] while reading a vector")]
|
|
||||||
[(eq? t 'dot)
|
|
||||||
(error 'read "unexpected . while reading a vector")]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(let-values ([(ignored locs k) (read-expr p locs k)])
|
|
||||||
(read-vector p locs k count ls))]
|
|
||||||
[else
|
|
||||||
(let-values ([(a locs k) (parse-token p locs k t)])
|
|
||||||
(read-vector p locs k (fxadd1 count) (cons a ls)))]))))
|
|
||||||
(define-record loc (value set?))
|
|
||||||
(define parse-token
|
|
||||||
(lambda (p locs k t)
|
|
||||||
(cond
|
|
||||||
[(eof-object? t) (values (eof-object) locs k)]
|
|
||||||
[(eq? t 'lparen) (read-list-init p locs k 'rparen 'rbrack)]
|
|
||||||
[(eq? t 'lbrack) (read-list-init p locs k 'rbrack 'rparen)]
|
|
||||||
[(eq? t 'vparen) (read-vector p locs k 0 '())]
|
|
||||||
[(eq? t 'hash-semi)
|
|
||||||
(let-values ([(ignored locs k) (read-expr p locs k)])
|
|
||||||
(read-expr p locs k))]
|
|
||||||
[(pair? t)
|
|
||||||
(cond
|
|
||||||
[(eq? (car t) 'datum) (values (cdr t) locs k)]
|
|
||||||
[(eq? (car t) 'macro)
|
|
||||||
(let-values ([(expr locs k) (read-expr p locs k)])
|
|
||||||
(let ([x (list expr)])
|
|
||||||
(values (cons (cdr t) x) locs
|
|
||||||
(if (loc? expr)
|
|
||||||
(lambda ()
|
|
||||||
(set-car! x (loc-value expr))
|
|
||||||
(k))
|
|
||||||
k))))]
|
|
||||||
[(eq? (car t) 'mark)
|
|
||||||
(let ([n (cdr t)])
|
|
||||||
(let-values ([(expr locs k) (read-expr p locs k)])
|
|
||||||
(cond
|
|
||||||
[(assq n locs) =>
|
|
||||||
(lambda (x)
|
|
||||||
(let ([loc (cdr x)])
|
|
||||||
(when (loc-set? loc)
|
|
||||||
(error 'read "duplicate mark ~s" n))
|
|
||||||
(set-loc-value! loc expr)
|
|
||||||
(set-loc-set?! loc #t)
|
|
||||||
(values expr locs k)))]
|
|
||||||
[else
|
|
||||||
(let ([loc (make-loc expr #t)])
|
|
||||||
(let ([locs (cons (cons n loc) locs)])
|
|
||||||
(values expr locs k)))])))]
|
|
||||||
[(eq? (car t) 'ref)
|
|
||||||
(let ([n (cdr t)])
|
|
||||||
(cond
|
|
||||||
[(assq n locs) =>
|
|
||||||
(lambda (x)
|
|
||||||
(values (cdr x) locs k))]
|
|
||||||
[else
|
|
||||||
(let ([loc (make-loc #f #f)])
|
|
||||||
(let ([locs (cons (cons n loc) locs)])
|
|
||||||
(values loc locs k)))]))]
|
|
||||||
[else (error 'read "invalid token! ~s" t)])]
|
|
||||||
[else
|
|
||||||
(error 'read "unexpected ~s found" t)])))
|
|
||||||
(define read-expr
|
|
||||||
(lambda (p locs k)
|
|
||||||
(parse-token p locs k (read-token p))))
|
|
||||||
|
|
||||||
(define reduce-loc!
|
|
||||||
(lambda (x)
|
|
||||||
(let ([loc (cdr x)])
|
|
||||||
(unless (loc-set? loc)
|
|
||||||
(error 'read "referenced mark ~s not set" (car x)))
|
|
||||||
(when (loc? (loc-value loc))
|
|
||||||
(let f ([h loc] [t loc])
|
|
||||||
(if (loc? h)
|
|
||||||
(let ([h1 (loc-value h)])
|
|
||||||
(if (loc? h1)
|
|
||||||
(begin
|
|
||||||
(when (eq? h1 t)
|
|
||||||
(error 'read "circular marks"))
|
|
||||||
(let ([v (f (loc-value h1) (loc-value t))])
|
|
||||||
(set-loc-value! h1 v)
|
|
||||||
(set-loc-value! h v)
|
|
||||||
v))
|
|
||||||
(begin
|
|
||||||
(set-loc-value! h h1)
|
|
||||||
h1)))
|
|
||||||
h))))))
|
|
||||||
|
|
||||||
(define read
|
|
||||||
(lambda (p)
|
|
||||||
(let-values ([(expr locs k) (read-expr p '() void)])
|
|
||||||
(cond
|
|
||||||
[(null? locs) expr]
|
|
||||||
[else
|
|
||||||
(for-each reduce-loc! locs)
|
|
||||||
(k)
|
|
||||||
(if (loc? expr)
|
|
||||||
(loc-value expr)
|
|
||||||
expr)]))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;;--------------------------------------------------------------* INIT *---
|
|
||||||
;;;
|
|
||||||
(primitive-set! 'read-token
|
|
||||||
(case-lambda
|
|
||||||
[() (tokenize (current-input-port))]
|
|
||||||
[(p)
|
|
||||||
(if (input-port? p)
|
|
||||||
(tokenize p)
|
|
||||||
(error 'read-token "~s is not an input port" p))]))
|
|
||||||
(primitive-set! 'read
|
|
||||||
(case-lambda
|
|
||||||
[() (read (current-input-port))]
|
|
||||||
[(p)
|
|
||||||
(if (input-port? p)
|
|
||||||
(read p)
|
|
||||||
(error 'read "~s is not an input port" p))]))
|
|
||||||
(let ()
|
|
||||||
(define read-and-eval
|
|
||||||
(lambda (p)
|
|
||||||
(let ([x (read p)])
|
|
||||||
(unless (eof-object? x)
|
|
||||||
(eval x)
|
|
||||||
(read-and-eval p)))))
|
|
||||||
(primitive-set! 'load
|
|
||||||
(lambda (x)
|
|
||||||
(unless (string? x)
|
|
||||||
(error 'load "~s is not a string" x))
|
|
||||||
(let ([p (open-input-file x)])
|
|
||||||
(read-and-eval p)
|
|
||||||
(close-input-port p)))))
|
|
||||||
)
|
|
||||||
|
|
|
@ -1,373 +0,0 @@
|
||||||
|
|
||||||
;;; 6.2: * added a printer for bwp-objects
|
|
||||||
|
|
||||||
;;; WRITER provides display and write.
|
|
||||||
|
|
||||||
(let ()
|
|
||||||
(define char-table ; first nonprintable chars
|
|
||||||
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
|
|
||||||
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
|
|
||||||
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
|
|
||||||
(define write-character
|
|
||||||
(lambda (x p m)
|
|
||||||
(if m
|
|
||||||
(let ([i ($char->fixnum x)])
|
|
||||||
(write-char #\# p)
|
|
||||||
(cond
|
|
||||||
[(fx< i (vector-length char-table))
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char* (vector-ref char-table i) p)]
|
|
||||||
[(fx< i 127)
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char x p)]
|
|
||||||
[(fx= i 127)
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char* "del" p)]
|
|
||||||
[else
|
|
||||||
(write-char #\+ p)
|
|
||||||
(write-fixnum i p)]))
|
|
||||||
(write-char x p))))
|
|
||||||
(define write-list
|
|
||||||
(lambda (x p m)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(write-char #\space p)
|
|
||||||
(writer (car x) p m)
|
|
||||||
(write-list (cdr x) p m)]
|
|
||||||
[(not (null? x))
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-char #\. p)
|
|
||||||
(write-char #\space p)
|
|
||||||
(writer x p m)])))
|
|
||||||
(define write-vector
|
|
||||||
(lambda (x p m)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\( p)
|
|
||||||
(let ([n (vector-length x)])
|
|
||||||
(when (fx> n 0)
|
|
||||||
(writer (vector-ref x 0) p m)
|
|
||||||
(letrec ([f
|
|
||||||
(lambda (i)
|
|
||||||
(unless (fx= i n)
|
|
||||||
(write-char #\space p)
|
|
||||||
(writer (vector-ref x i) p m)
|
|
||||||
(f (fxadd1 i))))])
|
|
||||||
(f 1))))
|
|
||||||
(write-char #\) p)))
|
|
||||||
(define write-record
|
|
||||||
(lambda (x p m)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\[ p)
|
|
||||||
(writer (record-name x) p m)
|
|
||||||
(let ([n (record-length x)])
|
|
||||||
(letrec ([f
|
|
||||||
(lambda (i)
|
|
||||||
(unless (fx= i n)
|
|
||||||
(write-char #\space p)
|
|
||||||
(writer (record-ref x i) p m)
|
|
||||||
(f (fxadd1 i))))])
|
|
||||||
(f 0)))
|
|
||||||
(write-char #\] p)))
|
|
||||||
(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 digit?
|
|
||||||
(lambda (c)
|
|
||||||
(and ($char<= #\0 c) ($char<= c #\9))))
|
|
||||||
(define special-initial?
|
|
||||||
(lambda (x)
|
|
||||||
(memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
|
|
||||||
(define subsequent?
|
|
||||||
(lambda (x)
|
|
||||||
(or (initial? x)
|
|
||||||
(digit? x)
|
|
||||||
(special-subsequent? x))))
|
|
||||||
(define special-subsequent?
|
|
||||||
(lambda (x)
|
|
||||||
(memq x '(#\+ #\- #\. #\@))))
|
|
||||||
(define subsequent*?
|
|
||||||
(lambda (str i n)
|
|
||||||
(or ($fx= i n)
|
|
||||||
(and (subsequent? ($string-ref str i))
|
|
||||||
(subsequent*? str ($fxadd1 i) n)))))
|
|
||||||
(define valid-symbol-string?
|
|
||||||
(lambda (str)
|
|
||||||
(or (let ([n ($string-length str)])
|
|
||||||
(and ($fx>= n 1)
|
|
||||||
(initial? ($string-ref str 0))
|
|
||||||
(subsequent*? str 1 n)))
|
|
||||||
(string=? str "+")
|
|
||||||
(string=? str "-")
|
|
||||||
(string=? str "..."))))
|
|
||||||
(define write-symbol-esc-loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless ($fx= i n)
|
|
||||||
(let ([c ($string-ref x i)])
|
|
||||||
(when (memq c '(#\\ #\|))
|
|
||||||
(write-char #\\ p))
|
|
||||||
(write-char c p))
|
|
||||||
(write-symbol-esc-loop x ($fxadd1 i) n p))))
|
|
||||||
(define write-symbol-esc
|
|
||||||
(lambda (x p)
|
|
||||||
(write-char #\| p)
|
|
||||||
(write-symbol-esc-loop x 0 ($string-length x) p)
|
|
||||||
(write-char #\| p)))
|
|
||||||
(define write-symbol
|
|
||||||
(lambda (x p m)
|
|
||||||
(let ([str (symbol->string x)])
|
|
||||||
(if m
|
|
||||||
(if (valid-symbol-string? str)
|
|
||||||
(write-char* str p)
|
|
||||||
(write-symbol-esc str p))
|
|
||||||
(write-char* str p)))))
|
|
||||||
(define write-gensym
|
|
||||||
(lambda (x p m)
|
|
||||||
(cond
|
|
||||||
[(and m (print-gensym))
|
|
||||||
(let ([str (symbol->string x)])
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\{ p)
|
|
||||||
(if (valid-symbol-string? str)
|
|
||||||
(write-char* str p)
|
|
||||||
(write-symbol-esc str p))
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-symbol-esc (gensym->unique-string x) p)
|
|
||||||
(write-char #\} p))]
|
|
||||||
[else (write-symbol x p m)])))
|
|
||||||
(define write-string-escape
|
|
||||||
(lambda (x p)
|
|
||||||
(define loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless (fx= i n)
|
|
||||||
(let ([c (string-ref x i)])
|
|
||||||
(cond
|
|
||||||
[(or ($char= #\" c) ($char= #\\ c))
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char c p)]
|
|
||||||
[($char= #\tab c)
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char #\t p)]
|
|
||||||
[else
|
|
||||||
(write-char c p)]))
|
|
||||||
(loop x (fxadd1 i) n p))))
|
|
||||||
(write-char #\" p)
|
|
||||||
(loop x 0 (string-length x) p)
|
|
||||||
(write-char #\" p)))
|
|
||||||
(define write-string
|
|
||||||
(lambda (x p m)
|
|
||||||
(if m
|
|
||||||
(write-string-escape x p)
|
|
||||||
(write-char* x p))))
|
|
||||||
(define write-fixnum
|
|
||||||
(lambda (x p)
|
|
||||||
(define loop
|
|
||||||
(lambda (x p)
|
|
||||||
(unless (fxzero? x)
|
|
||||||
(loop (fxquotient x 10) p)
|
|
||||||
(write-char
|
|
||||||
($fixnum->char
|
|
||||||
($fx+ (fxremainder x 10)
|
|
||||||
($char->fixnum #\0)))
|
|
||||||
p))))
|
|
||||||
(cond
|
|
||||||
[(fxzero? x) (write-char #\0 p)]
|
|
||||||
[(fx< x 0)
|
|
||||||
(write-char #\- p)
|
|
||||||
(if (fx= x -536870912)
|
|
||||||
(write-char* "536870912" p)
|
|
||||||
(loop (fx- 0 x) p))]
|
|
||||||
[else (loop x p)])))
|
|
||||||
(define write-char*
|
|
||||||
(lambda (x p)
|
|
||||||
(define loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless (fx= i n)
|
|
||||||
(write-char (string-ref x i) p)
|
|
||||||
(loop x (fxadd1 i) n p))))
|
|
||||||
(loop x 0 (string-length x) p)))
|
|
||||||
(define macro
|
|
||||||
(lambda (x)
|
|
||||||
(define macro-forms
|
|
||||||
'([quote . "'"]
|
|
||||||
[quasiquote . "`"]
|
|
||||||
[unquote . ","]
|
|
||||||
[unquote-splicing . ",@"]
|
|
||||||
[syntax . "#'"]
|
|
||||||
[|#primitive| . "#%"]))
|
|
||||||
(and (pair? x)
|
|
||||||
(let ([d ($cdr x)])
|
|
||||||
(and (pair? d)
|
|
||||||
(null? ($cdr d))))
|
|
||||||
(assq ($car x) macro-forms))))
|
|
||||||
(define writer
|
|
||||||
(lambda (x p m)
|
|
||||||
(cond
|
|
||||||
[(macro x) =>
|
|
||||||
(lambda (y)
|
|
||||||
(write-char* (cdr y) p)
|
|
||||||
(writer (cadr x) p m))]
|
|
||||||
[(pair? x)
|
|
||||||
(write-char #\( p)
|
|
||||||
(writer (car x) p m)
|
|
||||||
(write-list (cdr x) p m)
|
|
||||||
(write-char #\) p)]
|
|
||||||
[(symbol? x)
|
|
||||||
(if (gensym? x)
|
|
||||||
(write-gensym x p m)
|
|
||||||
(write-symbol x p m))]
|
|
||||||
[(fixnum? x)
|
|
||||||
(write-fixnum x p)]
|
|
||||||
[(string? x)
|
|
||||||
(write-string x p m)]
|
|
||||||
[(boolean? x)
|
|
||||||
(write-char* (if x "#t" "#f") p)]
|
|
||||||
[(char? x)
|
|
||||||
(write-character x p m)]
|
|
||||||
[(procedure? x)
|
|
||||||
(write-char* "#<procedure>" p)]
|
|
||||||
[(output-port? x)
|
|
||||||
(write-char* "#<output-port " p)
|
|
||||||
(writer (output-port-name x) p #t)
|
|
||||||
(write-char #\> p)]
|
|
||||||
[(input-port? x)
|
|
||||||
(write-char* "#<input-port " p)
|
|
||||||
(writer (input-port-name x) p #t)
|
|
||||||
(write-char #\> p)]
|
|
||||||
[(vector? x)
|
|
||||||
(write-vector x p m)]
|
|
||||||
[(null? x)
|
|
||||||
(write-char #\( p)
|
|
||||||
(write-char #\) p)]
|
|
||||||
[(eq? x (void))
|
|
||||||
(write-char* "#<void>" p)]
|
|
||||||
[(eof-object? x)
|
|
||||||
(write-char* "#!eof" p)]
|
|
||||||
[(bwp-object? x)
|
|
||||||
(write-char* "#!bwp" p)]
|
|
||||||
[(record? x)
|
|
||||||
(let ([printer (record-printer x)])
|
|
||||||
(if (procedure? printer)
|
|
||||||
(printer x p)
|
|
||||||
(write-record x p m)))]
|
|
||||||
;[(code? x)
|
|
||||||
; (write-char* "#<code>" p)]
|
|
||||||
[(hash-table? x)
|
|
||||||
(write-char* "#<hash-table>" p)]
|
|
||||||
[($unbound-object? x)
|
|
||||||
(write-char* "#<unbound-object>" p)]
|
|
||||||
[($forward-ptr? x)
|
|
||||||
(write-char* "#<forward-ptr>" p)]
|
|
||||||
[else
|
|
||||||
(write-char* "#<unknown>" p)])))
|
|
||||||
|
|
||||||
(define (write x p)
|
|
||||||
(writer x p #t)
|
|
||||||
(flush-output-port p))
|
|
||||||
(define (display x p)
|
|
||||||
(writer x p #f)
|
|
||||||
(flush-output-port p))
|
|
||||||
;;;
|
|
||||||
(define formatter
|
|
||||||
(lambda (who p fmt args)
|
|
||||||
(let f ([i 0] [args args])
|
|
||||||
(unless (fx= i (string-length fmt))
|
|
||||||
(let ([c (string-ref fmt i)])
|
|
||||||
(cond
|
|
||||||
[($char= c #\~)
|
|
||||||
(let ([i (fxadd1 i)])
|
|
||||||
(when (fx= i (string-length fmt))
|
|
||||||
(error who "invalid ~~ at end of format string ~s" fmt))
|
|
||||||
(let ([c (string-ref fmt i)])
|
|
||||||
(cond
|
|
||||||
[($char= c #\~)
|
|
||||||
(write-char #\~ p)
|
|
||||||
(f (fxadd1 i) args)]
|
|
||||||
[($char= c #\a)
|
|
||||||
(when (null? args)
|
|
||||||
(error who "insufficient arguments"))
|
|
||||||
(display (car args) p)
|
|
||||||
(f (fxadd1 i) (cdr args))]
|
|
||||||
[($char= c #\s)
|
|
||||||
(when (null? args)
|
|
||||||
(error who "insufficient arguments"))
|
|
||||||
(write (car args) p)
|
|
||||||
(f (fxadd1 i) (cdr args))]
|
|
||||||
[else
|
|
||||||
(error who "invalid sequence ~~~a" c)])))]
|
|
||||||
[else
|
|
||||||
(write-char c p)
|
|
||||||
(f (fxadd1 i) args)]))))))
|
|
||||||
|
|
||||||
(define fprintf
|
|
||||||
(lambda (port fmt . args)
|
|
||||||
(unless (output-port? port)
|
|
||||||
(error 'fprintf "~s is not an output port" port))
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'fprintf "~s is not a string" fmt))
|
|
||||||
(formatter 'fprintf port fmt args)))
|
|
||||||
|
|
||||||
(define printf
|
|
||||||
(lambda (fmt . args)
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'printf "~s is not a string" fmt))
|
|
||||||
(formatter 'printf (current-output-port) fmt args)))
|
|
||||||
|
|
||||||
(define format
|
|
||||||
(lambda (fmt . args)
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'format "~s is not a string" fmt))
|
|
||||||
(let ([p (open-output-string)])
|
|
||||||
(formatter 'format p fmt args)
|
|
||||||
(get-output-string p))))
|
|
||||||
|
|
||||||
(define print-error
|
|
||||||
(lambda (who fmt . args)
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'print-error "~s is not a string" fmt))
|
|
||||||
(let ([p (standard-error-port)])
|
|
||||||
(if who
|
|
||||||
(fprintf p "Error in ~a: " who)
|
|
||||||
(fprintf p "Error: "))
|
|
||||||
(formatter 'print-error p fmt args)
|
|
||||||
(write-char #\. p)
|
|
||||||
(newline p))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
(primitive-set! 'format format)
|
|
||||||
(primitive-set! 'printf printf)
|
|
||||||
(primitive-set! 'fprintf fprintf)
|
|
||||||
(primitive-set! 'write
|
|
||||||
(case-lambda
|
|
||||||
[(x) (write x (current-output-port))]
|
|
||||||
[(x p)
|
|
||||||
(unless (output-port? p)
|
|
||||||
(error 'write "~s is not an output port" p))
|
|
||||||
(write x p)]))
|
|
||||||
(primitive-set! 'display
|
|
||||||
(case-lambda
|
|
||||||
[(x) (display x (current-output-port))]
|
|
||||||
[(x p)
|
|
||||||
(unless (output-port? p)
|
|
||||||
(error 'display "~s is not an output port" p))
|
|
||||||
(display x p)]))
|
|
||||||
(primitive-set! 'print-error print-error)
|
|
||||||
(primitive-set! 'current-error-handler
|
|
||||||
(make-parameter
|
|
||||||
(lambda args
|
|
||||||
(apply print-error args)
|
|
||||||
(display "exiting\n" (console-output-port))
|
|
||||||
(flush-output-port (console-output-port))
|
|
||||||
(exit -100))
|
|
||||||
(lambda (x)
|
|
||||||
(if (procedure? x)
|
|
||||||
x
|
|
||||||
(error 'current-error-handler "~s is not a procedure" x)))))
|
|
||||||
(primitive-set! 'error
|
|
||||||
(lambda args
|
|
||||||
(apply (current-error-handler) args))))
|
|
||||||
|
|
|
@ -1,496 +0,0 @@
|
||||||
|
|
||||||
;;; 6.2: * added a printer for bwp-objects
|
|
||||||
|
|
||||||
;;; WRITER provides display and write.
|
|
||||||
|
|
||||||
(let ()
|
|
||||||
(define char-table ; first nonprintable chars
|
|
||||||
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
|
|
||||||
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
|
|
||||||
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
|
|
||||||
(define write-character
|
|
||||||
(lambda (x p m)
|
|
||||||
(if m
|
|
||||||
(let ([i ($char->fixnum x)])
|
|
||||||
(write-char #\# p)
|
|
||||||
(cond
|
|
||||||
[(fx< i (vector-length char-table))
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char* (vector-ref char-table i) p)]
|
|
||||||
[(fx< i 127)
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char x p)]
|
|
||||||
[(fx= i 127)
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char* "del" p)]
|
|
||||||
[else
|
|
||||||
(write-char #\+ p)
|
|
||||||
(write-fixnum i p)]))
|
|
||||||
(write-char x p))))
|
|
||||||
(define write-list
|
|
||||||
(lambda (x p m h i)
|
|
||||||
(cond
|
|
||||||
[(and (pair? x)
|
|
||||||
(or (not (get-hash-table h x #f))
|
|
||||||
(fxzero? (get-hash-table h x 0))))
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-list (cdr x) p m h
|
|
||||||
(writer (car x) p m h i))]
|
|
||||||
[(null? x) i]
|
|
||||||
[else
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-char #\. p)
|
|
||||||
(write-char #\space p)
|
|
||||||
(writer x p m h i)])))
|
|
||||||
(define write-vector
|
|
||||||
(lambda (x p m h i)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\( p)
|
|
||||||
(let ([n (vector-length x)])
|
|
||||||
(let ([i
|
|
||||||
(cond
|
|
||||||
[(fx> n 0)
|
|
||||||
(let f ([idx 1] [i (writer (vector-ref x 0) p m h i)])
|
|
||||||
(cond
|
|
||||||
[(fx= idx n)
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-char #\space p)
|
|
||||||
(f (fxadd1 idx)
|
|
||||||
(writer (vector-ref x idx) p m h i))]))]
|
|
||||||
[else i])])
|
|
||||||
(write-char #\) p)
|
|
||||||
i))))
|
|
||||||
(define write-record
|
|
||||||
(lambda (x p m h i)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\[ p)
|
|
||||||
(let ([i (writer (record-name x) p m h i)])
|
|
||||||
(let ([n (record-length x)])
|
|
||||||
(let f ([idx 0] [i i])
|
|
||||||
(cond
|
|
||||||
[(fx= idx n)
|
|
||||||
(write-char #\] p)
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-char #\space p)
|
|
||||||
(f (fxadd1 idx)
|
|
||||||
(writer (record-ref x idx) p m h i))]))))))
|
|
||||||
(define initial?
|
|
||||||
(lambda (c)
|
|
||||||
(or (letter? c) (special-initial? c))))
|
|
||||||
(define letter?
|
|
||||||
(lambda (c)
|
|
||||||
(or (and ($char<= #\a c) ($char<= c #\z))
|
|
||||||
(and ($char<= #\A c) ($char<= c #\Z)))))
|
|
||||||
(define digit?
|
|
||||||
(lambda (c)
|
|
||||||
(and ($char<= #\0 c) ($char<= c #\9))))
|
|
||||||
(define special-initial?
|
|
||||||
(lambda (x)
|
|
||||||
(memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
|
|
||||||
(define subsequent?
|
|
||||||
(lambda (x)
|
|
||||||
(or (initial? x)
|
|
||||||
(digit? x)
|
|
||||||
(special-subsequent? x))))
|
|
||||||
(define special-subsequent?
|
|
||||||
(lambda (x)
|
|
||||||
(memq x '(#\+ #\- #\. #\@))))
|
|
||||||
(define subsequent*?
|
|
||||||
(lambda (str i n)
|
|
||||||
(or ($fx= i n)
|
|
||||||
(and (subsequent? ($string-ref str i))
|
|
||||||
(subsequent*? str ($fxadd1 i) n)))))
|
|
||||||
(define valid-symbol-string?
|
|
||||||
(lambda (str)
|
|
||||||
(or (let ([n ($string-length str)])
|
|
||||||
(and ($fx>= n 1)
|
|
||||||
(initial? ($string-ref str 0))
|
|
||||||
(subsequent*? str 1 n)))
|
|
||||||
(string=? str "+")
|
|
||||||
(string=? str "-")
|
|
||||||
(string=? str "..."))))
|
|
||||||
(define write-symbol-esc-loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless ($fx= i n)
|
|
||||||
(let ([c ($string-ref x i)])
|
|
||||||
(when (memq c '(#\\ #\|))
|
|
||||||
(write-char #\\ p))
|
|
||||||
(write-char c p))
|
|
||||||
(write-symbol-esc-loop x ($fxadd1 i) n p))))
|
|
||||||
(define write-symbol-esc
|
|
||||||
(lambda (x p)
|
|
||||||
(write-char #\| p)
|
|
||||||
(write-symbol-esc-loop x 0 ($string-length x) p)
|
|
||||||
(write-char #\| p)))
|
|
||||||
(define write-symbol
|
|
||||||
(lambda (x p m)
|
|
||||||
(let ([str (symbol->string x)])
|
|
||||||
(if m
|
|
||||||
(if (valid-symbol-string? str)
|
|
||||||
(write-char* str p)
|
|
||||||
(write-symbol-esc str p))
|
|
||||||
(write-char* str p)))))
|
|
||||||
(define write-gensym
|
|
||||||
(lambda (x p m h i)
|
|
||||||
(cond
|
|
||||||
[(and m (print-gensym))
|
|
||||||
(let ([str (symbol->string x)])
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-char #\{ p)
|
|
||||||
(if (valid-symbol-string? str)
|
|
||||||
(write-char* str p)
|
|
||||||
(write-symbol-esc str p))
|
|
||||||
(write-char #\space p)
|
|
||||||
(write-symbol-esc (gensym->unique-string x) p)
|
|
||||||
(write-char #\} p))
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-symbol x p m)
|
|
||||||
i])))
|
|
||||||
(define write-string-escape
|
|
||||||
(lambda (x p)
|
|
||||||
(define loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless (fx= i n)
|
|
||||||
(let ([c (string-ref x i)])
|
|
||||||
(cond
|
|
||||||
[(or ($char= #\" c) ($char= #\\ c))
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char c p)]
|
|
||||||
[($char= #\tab c)
|
|
||||||
(write-char #\\ p)
|
|
||||||
(write-char #\t p)]
|
|
||||||
[else
|
|
||||||
(write-char c p)]))
|
|
||||||
(loop x (fxadd1 i) n p))))
|
|
||||||
(write-char #\" p)
|
|
||||||
(loop x 0 (string-length x) p)
|
|
||||||
(write-char #\" p)))
|
|
||||||
(define write-string
|
|
||||||
(lambda (x p m)
|
|
||||||
(if m
|
|
||||||
(write-string-escape x p)
|
|
||||||
(write-char* x p))))
|
|
||||||
(define write-fixnum
|
|
||||||
(lambda (x p)
|
|
||||||
(define loop
|
|
||||||
(lambda (x p)
|
|
||||||
(unless (fxzero? x)
|
|
||||||
(loop (fxquotient x 10) p)
|
|
||||||
(write-char
|
|
||||||
($fixnum->char
|
|
||||||
($fx+ (fxremainder x 10)
|
|
||||||
($char->fixnum #\0)))
|
|
||||||
p))))
|
|
||||||
(cond
|
|
||||||
[(fxzero? x) (write-char #\0 p)]
|
|
||||||
[(fx< x 0)
|
|
||||||
(write-char #\- p)
|
|
||||||
(if (fx= x -536870912)
|
|
||||||
(write-char* "536870912" p)
|
|
||||||
(loop (fx- 0 x) p))]
|
|
||||||
[else (loop x p)])))
|
|
||||||
(define write-char*
|
|
||||||
(lambda (x p)
|
|
||||||
(define loop
|
|
||||||
(lambda (x i n p)
|
|
||||||
(unless (fx= i n)
|
|
||||||
(write-char (string-ref x i) p)
|
|
||||||
(loop x (fxadd1 i) n p))))
|
|
||||||
(loop x 0 (string-length x) p)))
|
|
||||||
(define macro
|
|
||||||
(lambda (x)
|
|
||||||
(define macro-forms
|
|
||||||
'([quote . "'"]
|
|
||||||
[quasiquote . "`"]
|
|
||||||
[unquote . ","]
|
|
||||||
[unquote-splicing . ",@"]
|
|
||||||
[syntax . "#'"]
|
|
||||||
[|#primitive| . "#%"]))
|
|
||||||
(and (pair? x)
|
|
||||||
(let ([d ($cdr x)])
|
|
||||||
(and (pair? d)
|
|
||||||
(null? ($cdr d))))
|
|
||||||
(assq ($car x) macro-forms))))
|
|
||||||
(define write-pair
|
|
||||||
(lambda (x p m h i)
|
|
||||||
(write-char #\( p)
|
|
||||||
(let ([i (writer (car x) p m h i)])
|
|
||||||
(let ([i (write-list (cdr x) p m h i)])
|
|
||||||
(write-char #\) p)
|
|
||||||
i))))
|
|
||||||
(define write-ref
|
|
||||||
(lambda (n p)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-fixnum (fx- -1 n) p)
|
|
||||||
(write-char #\# p)))
|
|
||||||
(define write-mark
|
|
||||||
(lambda (n p)
|
|
||||||
(write-char #\# p)
|
|
||||||
(write-fixnum (fx- -1 n) p)
|
|
||||||
(write-char #\= p)))
|
|
||||||
(define write-shareable
|
|
||||||
(lambda (x p m h i k)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(cond
|
|
||||||
[(fx< n 0)
|
|
||||||
(write-ref n p)
|
|
||||||
i]
|
|
||||||
[(fx= n 0)
|
|
||||||
(k x p m h i)]
|
|
||||||
[else
|
|
||||||
(let ([i (fx- i 1)])
|
|
||||||
(put-hash-table! h x i)
|
|
||||||
(write-mark i p)
|
|
||||||
(k x p m h i))]))]
|
|
||||||
[else (k x p m h i)])))
|
|
||||||
(define writer
|
|
||||||
(lambda (x p m h i)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(write-shareable x p m h i write-pair)]
|
|
||||||
[(symbol? x)
|
|
||||||
(if (gensym? x)
|
|
||||||
(write-gensym x p m h i)
|
|
||||||
(begin (write-symbol x p m) i))]
|
|
||||||
[(fixnum? x)
|
|
||||||
(write-fixnum x p)
|
|
||||||
i]
|
|
||||||
[(string? x)
|
|
||||||
(write-string x p m)
|
|
||||||
i]
|
|
||||||
[(boolean? x)
|
|
||||||
(write-char* (if x "#t" "#f") p)
|
|
||||||
i]
|
|
||||||
[(char? x)
|
|
||||||
(write-character x p m)
|
|
||||||
i]
|
|
||||||
[(procedure? x)
|
|
||||||
(write-char* "#<procedure>" p)
|
|
||||||
i]
|
|
||||||
[(output-port? x)
|
|
||||||
(write-char* "#<output-port " p)
|
|
||||||
(let ([i (writer (output-port-name x) p #t h i)])
|
|
||||||
(write-char #\> p)
|
|
||||||
i)]
|
|
||||||
[(input-port? x)
|
|
||||||
(write-char* "#<input-port " p)
|
|
||||||
(let ([i (writer (input-port-name x) p #t h i)])
|
|
||||||
(write-char #\> p)
|
|
||||||
i)]
|
|
||||||
[(vector? x)
|
|
||||||
(write-shareable x p m h i write-vector)]
|
|
||||||
[(null? x)
|
|
||||||
(write-char #\( p)
|
|
||||||
(write-char #\) p)
|
|
||||||
i]
|
|
||||||
[(eq? x (void))
|
|
||||||
(write-char* "#<void>" p)
|
|
||||||
i]
|
|
||||||
[(eof-object? x)
|
|
||||||
(write-char* "#!eof" p)
|
|
||||||
i]
|
|
||||||
[(bwp-object? x)
|
|
||||||
(write-char* "#!bwp" p)
|
|
||||||
i]
|
|
||||||
[(record? x)
|
|
||||||
(let ([printer (record-printer x)])
|
|
||||||
(if (procedure? printer)
|
|
||||||
(begin (printer x p) i)
|
|
||||||
(write-shareable x p m h i write-record)))]
|
|
||||||
;[(code? x)
|
|
||||||
; (write-char* "#<code>" p)]
|
|
||||||
[(hash-table? x)
|
|
||||||
(write-char* "#<hash-table>" p)
|
|
||||||
i]
|
|
||||||
[($unbound-object? x)
|
|
||||||
(write-char* "#<unbound-object>" p)
|
|
||||||
i]
|
|
||||||
[($forward-ptr? x)
|
|
||||||
(write-char* "#<forward-ptr>" p)
|
|
||||||
i]
|
|
||||||
[else
|
|
||||||
(write-char* "#<unknown>" p)
|
|
||||||
i])))
|
|
||||||
|
|
||||||
(define print-graph (make-parameter #f))
|
|
||||||
|
|
||||||
(define (hasher x h)
|
|
||||||
(define (vec-graph x i j h)
|
|
||||||
(unless (fx= i j)
|
|
||||||
(graph (vector-ref x i) h)
|
|
||||||
(vec-graph x (fxadd1 i) j h)))
|
|
||||||
(define (vec-dynamic x i j h)
|
|
||||||
(unless (fx= i j)
|
|
||||||
(dynamic (vector-ref x i) h)
|
|
||||||
(vec-dynamic x (fxadd1 i) j h)))
|
|
||||||
(define (graph x h)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(graph (car x) h)
|
|
||||||
(graph (cdr x) h)])]
|
|
||||||
[(vector? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(vec-graph x 0 (vector-length x) h)])]
|
|
||||||
[(gensym? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))])]))
|
|
||||||
(define (dynamic x h)
|
|
||||||
(cond
|
|
||||||
[(pair? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(dynamic (car x) h)
|
|
||||||
(dynamic (cdr x) h)
|
|
||||||
(when (and (get-hash-table h x #f)
|
|
||||||
(fxzero? (get-hash-table h x #f)))
|
|
||||||
(put-hash-table! h x #f))])]
|
|
||||||
[(vector? x)
|
|
||||||
(cond
|
|
||||||
[(get-hash-table h x #f) =>
|
|
||||||
(lambda (n)
|
|
||||||
(put-hash-table! h x (fxadd1 n)))]
|
|
||||||
[else
|
|
||||||
(put-hash-table! h x 0)
|
|
||||||
(vec-dynamic x 0 (vector-length x) h)
|
|
||||||
(when (and (get-hash-table h x #f)
|
|
||||||
(fxzero? (get-hash-table h x #f)))
|
|
||||||
(put-hash-table! h x #f))])]))
|
|
||||||
(if (print-graph)
|
|
||||||
(graph x h)
|
|
||||||
(dynamic x h)))
|
|
||||||
|
|
||||||
(define (write x p)
|
|
||||||
(let ([h (make-hash-table)])
|
|
||||||
(hasher x h)
|
|
||||||
(writer x p #t h 0))
|
|
||||||
(flush-output-port p))
|
|
||||||
;;;
|
|
||||||
(define (display x p)
|
|
||||||
(let ([h (make-hash-table)])
|
|
||||||
(hasher x h)
|
|
||||||
(writer x p #f h 0))
|
|
||||||
(flush-output-port p))
|
|
||||||
;;;
|
|
||||||
(define formatter
|
|
||||||
(lambda (who p fmt args)
|
|
||||||
(let f ([i 0] [args args])
|
|
||||||
(unless (fx= i (string-length fmt))
|
|
||||||
(let ([c (string-ref fmt i)])
|
|
||||||
(cond
|
|
||||||
[($char= c #\~)
|
|
||||||
(let ([i (fxadd1 i)])
|
|
||||||
(when (fx= i (string-length fmt))
|
|
||||||
(error who "invalid ~~ at end of format string ~s" fmt))
|
|
||||||
(let ([c (string-ref fmt i)])
|
|
||||||
(cond
|
|
||||||
[($char= c #\~)
|
|
||||||
(write-char #\~ p)
|
|
||||||
(f (fxadd1 i) args)]
|
|
||||||
[($char= c #\a)
|
|
||||||
(when (null? args)
|
|
||||||
(error who "insufficient arguments"))
|
|
||||||
(display (car args) p)
|
|
||||||
(f (fxadd1 i) (cdr args))]
|
|
||||||
[($char= c #\s)
|
|
||||||
(when (null? args)
|
|
||||||
(error who "insufficient arguments"))
|
|
||||||
(write (car args) p)
|
|
||||||
(f (fxadd1 i) (cdr args))]
|
|
||||||
[else
|
|
||||||
(error who "invalid sequence ~~~a" c)])))]
|
|
||||||
[else
|
|
||||||
(write-char c p)
|
|
||||||
(f (fxadd1 i) args)]))))))
|
|
||||||
|
|
||||||
(define fprintf
|
|
||||||
(lambda (port fmt . args)
|
|
||||||
(unless (output-port? port)
|
|
||||||
(error 'fprintf "~s is not an output port" port))
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'fprintf "~s is not a string" fmt))
|
|
||||||
(formatter 'fprintf port fmt args)))
|
|
||||||
|
|
||||||
(define printf
|
|
||||||
(lambda (fmt . args)
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'printf "~s is not a string" fmt))
|
|
||||||
(formatter 'printf (current-output-port) fmt args)))
|
|
||||||
|
|
||||||
(define format
|
|
||||||
(lambda (fmt . args)
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'format "~s is not a string" fmt))
|
|
||||||
(let ([p (open-output-string)])
|
|
||||||
(formatter 'format p fmt args)
|
|
||||||
(get-output-string p))))
|
|
||||||
|
|
||||||
(define print-error
|
|
||||||
(lambda (who fmt . args)
|
|
||||||
(unless (string? fmt)
|
|
||||||
(error 'print-error "~s is not a string" fmt))
|
|
||||||
(let ([p (standard-error-port)])
|
|
||||||
(if who
|
|
||||||
(fprintf p "Error in ~a: " who)
|
|
||||||
(fprintf p "Error: "))
|
|
||||||
(formatter 'print-error p fmt args)
|
|
||||||
(write-char #\. p)
|
|
||||||
(newline p))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
(primitive-set! 'format format)
|
|
||||||
(primitive-set! 'printf printf)
|
|
||||||
(primitive-set! 'fprintf fprintf)
|
|
||||||
(primitive-set! 'print-graph print-graph)
|
|
||||||
(primitive-set! 'write
|
|
||||||
(case-lambda
|
|
||||||
[(x) (write x (current-output-port))]
|
|
||||||
[(x p)
|
|
||||||
(unless (output-port? p)
|
|
||||||
(error 'write "~s is not an output port" p))
|
|
||||||
(write x p)]))
|
|
||||||
(primitive-set! 'display
|
|
||||||
(case-lambda
|
|
||||||
[(x) (display x (current-output-port))]
|
|
||||||
[(x p)
|
|
||||||
(unless (output-port? p)
|
|
||||||
(error 'display "~s is not an output port" p))
|
|
||||||
(display x p)]))
|
|
||||||
(primitive-set! 'print-error print-error)
|
|
||||||
(primitive-set! 'current-error-handler
|
|
||||||
(make-parameter
|
|
||||||
(lambda args
|
|
||||||
(apply print-error args)
|
|
||||||
(display "exiting\n" (console-output-port))
|
|
||||||
(flush-output-port (console-output-port))
|
|
||||||
(exit -100))
|
|
||||||
(lambda (x)
|
|
||||||
(if (procedure? x)
|
|
||||||
x
|
|
||||||
(error 'current-error-handler "~s is not a procedure" x)))))
|
|
||||||
(primitive-set! 'error
|
|
||||||
(lambda args
|
|
||||||
(apply (current-error-handler) args))))
|
|
||||||
|
|
|
@ -241,27 +241,27 @@
|
||||||
(whack-system-env #t)
|
(whack-system-env #t)
|
||||||
|
|
||||||
(define scheme-library-files
|
(define scheme-library-files
|
||||||
'(["libhandlers-6.9.ss" #t "libhandlers.fasl"]
|
'(["libhandlers.ss" #t "libhandlers.fasl"]
|
||||||
["libcontrol-6.1.ss" #t "libcontrol.fasl"]
|
["libcontrol.ss" #t "libcontrol.fasl"]
|
||||||
["libcollect-6.1.ss" #t "libcollect.fasl"]
|
["libcollect.ss" #t "libcollect.fasl"]
|
||||||
["librecord-6.4.ss" #t "librecord.fasl"]
|
["librecord.ss" #t "librecord.fasl"]
|
||||||
["libcxr-6.0.ss" #t "libcxr.fasl"]
|
["libcxr.ss" #t "libcxr.fasl"]
|
||||||
["libnumerics-9.1.ss" #t "libnumerics.fasl"]
|
["libnumerics.ss" #t "libnumerics.fasl"]
|
||||||
["libcore-6.9.ss" #t "libcore.fasl"]
|
["libcore.ss" #t "libcore.fasl"]
|
||||||
["libchezio-8.1.ss" #t "libchezio.fasl"]
|
["libchezio.ss" #t "libchezio.fasl"]
|
||||||
["libhash-9.2.ss" #t "libhash.fasl"]
|
["libhash.ss" #t "libhash.fasl"]
|
||||||
["libwriter-9.1.ss" #t "libwriter.fasl"]
|
["libwriter.ss" #t "libwriter.fasl"]
|
||||||
["libtokenizer-9.1.ss" #t "libtokenizer.fasl"]
|
["libtokenizer.ss" #t "libtokenizer.fasl"]
|
||||||
["libassembler-6.7.ss" #t "libassembler.fasl"]
|
["libassembler.ss" #t "libassembler.fasl"]
|
||||||
["libintelasm-6.9.ss" #t "libintelasm.fasl"]
|
["libintelasm.ss" #t "libintelasm.fasl"]
|
||||||
["libfasl-6.7.ss" #t "libfasl.fasl"]
|
["libfasl.ss" #t "libfasl.fasl"]
|
||||||
["libcompile-9.1.ss" #t "libcompile.fasl"]
|
["libcompile.ss" #t "libcompile.fasl"]
|
||||||
["psyntax-7.1-9.1.ss" #t "psyntax.fasl"]
|
["psyntax-7.1.ss" #t "psyntax.fasl"]
|
||||||
["libinterpret-6.5.ss" #t "libinterpret.fasl"]
|
["libinterpret.ss" #t "libinterpret.fasl"]
|
||||||
["libcafe-6.1.ss" #t "libcafe.fasl"]
|
["libcafe.ss" #t "libcafe.fasl"]
|
||||||
["libtrace-6.9.ss" #t "libtrace.fasl"]
|
["libtrace.ss" #t "libtrace.fasl"]
|
||||||
["libposix-6.0.ss" #t "libposix.fasl"]
|
["libposix.ss" #t "libposix.fasl"]
|
||||||
["libtoplevel-6.9.ss" #t "libtoplevel.fasl"]
|
["libtoplevel.ss" #t "libtoplevel.fasl"]
|
||||||
))
|
))
|
||||||
|
|
||||||
|
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue