280 lines
10 KiB
Scheme
Executable File
280 lines
10 KiB
Scheme
Executable File
#!/Users/aghuloum/.opt/bin/ikarus --script
|
|
|
|
;;; 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 trace-define))
|
|
|
|
|
|
|
|
(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
|
|
string->list 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
|
|
assv assoc eq? eqv? 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 comment-handler error exit call/cc
|
|
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
|
|
command-line-arguments 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
|
|
file-exists? delete-file + - add1 sub1 * expt
|
|
quotient+remainder quotient remainder number? positive?
|
|
negative? zero? number->string logand = < > <= >=))
|
|
|
|
(define system-primitives
|
|
'(
|
|
|
|
$closure-code 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 $arg-list $seal-frame-and-call
|
|
$make-call-with-values-procedure $make-values-procedure
|
|
do-overflow collect $make-tcbucket $tcbucket-next $tcbucket-key
|
|
$tcbucket-val $set-tcbucket-next! $set-tcbucket-val!
|
|
$set-tcbucket-tconc! $tcbucket-dlink-prev $tcbucket-dlink-next
|
|
$set-tcbucket-dlink-prev! $set-tcbucket-dlink-next! call/cf
|
|
trace-symbol! untrace-symbol! make-traced-procedure
|
|
fixnum->string
|
|
|
|
;;; TODO: 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*
|
|
|
|
;;;
|
|
compiler-giveup-tally
|
|
))
|
|
|
|
|
|
|
|
(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? "" "")
|
|
(error #f "SEVERELY OUT OF DATE!\n")
|
|
(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.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"]
|
|
))
|
|
|
|
|
|
(define (expand-file ifile)
|
|
(with-input-from-file ifile
|
|
(lambda ()
|
|
(let f ()
|
|
(let ([x (read)])
|
|
(unless (eof-object? x)
|
|
(sc-expand x)
|
|
(f)))))))
|
|
|
|
(define (compile-library ifile ofile)
|
|
(parameterize ([assembler-output #f]
|
|
[expand-mode 'bootstrap]
|
|
[interaction-environment system-env])
|
|
(printf "compiling ~a ... " ifile)
|
|
(compile-file ifile ofile 'replace)
|
|
;(expand-file ifile)
|
|
(newline)))
|
|
|
|
(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.boot"
|
|
(join " " (map caddr scheme-library-files))))
|
|
|
|
(#%compiler-giveup-tally)
|
|
|