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