diff --git a/src/ikarus.boot b/src/ikarus.boot index 7c5e585..d5d42c8 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index df8bc74..7718ffb 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -1570,14 +1570,20 @@ [else (error who "invalid tail ~s" x)])] [else (error who "invalid tail ~s" x)])) ;;; + (define (properize args proper ac) + (cond + [proper ac] + [else + (error 'properize "not yet") + ac])) + ;;; (define (ClambdaCase x) (record-case x [(clambda-case info body) (record-case info [(case-info L args proper) - (unless proper (error who "improper lambda")) - (cons (label L) - (T body '()))])])) + (properize args proper + (cons (label L) (T body '())))])])) ;;; (define (Clambda x) (record-case x diff --git a/src/libcompile.ss b/src/libcompile.ss index 6706626..f8cc50a 100644 --- a/src/libcompile.ss +++ b/src/libcompile.ss @@ -5221,7 +5221,21 @@ (close-input-port ip) (close-output-port op)))) +(define alt-compile-file + (lambda (input-file output-file . rest) + (let ([ip (open-input-file input-file)] + [op (apply open-output-file output-file rest)]) + (let f () + (let ([x (read ip)]) + (unless (eof-object? x) + (fasl-write (alt-compile-expr x) op) + (f)))) + (close-input-port ip) + (close-output-port op)))) + + (primitive-set! 'compile-file compile-file) +(primitive-set! 'alt-compile-file alt-compile-file) (primitive-set! 'assembler-output (make-parameter #f)) (primitive-set! 'compile (lambda (x) diff --git a/src/libcxr.ss b/src/libcxr.ss index 84853ea..d2dada9 100644 --- a/src/libcxr.ss +++ b/src/libcxr.ss @@ -1,17 +1,18 @@ -(primitive-set! 'car (lambda (x) (car x))) -(primitive-set! 'cdr (lambda (x) (cdr x))) -(primitive-set! 'cadr (lambda (x) (cadr x))) +;(primitive-set! 'car (lambda (x) (car x))) +;(primitive-set! 'cdr (lambda (x) (cdr x))) +;(primitive-set! 'cadr (lambda (x) (cadr x))) + (let ([err (lambda (who x) (error who "invalid list structure ~s" x))]) - ;(primitive-set! - ; 'car - ; (lambda (orig) - ; (if (pair? orig) ($car orig) (err 'car orig)))) - ;(primitive-set! - ; 'cdr - ; (lambda (orig) - ; (if (pair? orig) ($cdr orig) (err 'cdr orig)))) + (primitive-set! + 'car + (lambda (orig) + (if (pair? orig) ($car orig) (err 'car orig)))) + (primitive-set! + 'cdr + (lambda (orig) + (if (pair? orig) ($cdr orig) (err 'cdr orig)))) (primitive-set! 'caar (lambda (orig) @@ -19,13 +20,13 @@ (let ([x ($car orig)]) (if (pair? x) ($car x) (err 'caar orig))) (err 'caar orig)))) - ;(primitive-set! - ; 'cadr - ; (lambda (orig) - ; (if (pair? orig) - ; (let ([x ($cdr orig)]) - ; (if (pair? x) ($car x) (err 'cadr orig))) - ; (err 'cadr orig)))) + (primitive-set! + 'cadr + (lambda (orig) + (if (pair? orig) + (let ([x ($cdr orig)]) + (if (pair? x) ($car x) (err 'cadr orig))) + (err 'cadr orig)))) (primitive-set! 'cdar (lambda (orig) diff --git a/src/makefile.ss b/src/makefile.ss index a8e8c88..50689ae 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -56,6 +56,7 @@ dynamic-wind display write print-graph fasl-write printf fprintf format print-error read-token read comment-handler error warning exit call/cc error-handler eval current-eval compile alt-compile compile-file + alt-compile-file new-cafe load system expand sc-expand current-expand expand-mode environment? interaction-environment identifier? free-identifier=? bound-identifier=? literal-identifier=? @@ -225,29 +226,29 @@ (whack-system-env #t) (define scheme-library-files - '(["libhandlers.ss" "libhandlers.fasl" p0] - ["libcontrol.ss" "libcontrol.fasl" p0] - ["libcollect.ss" "libcollect.fasl" p0] - ["librecord.ss" "librecord.fasl" p0] - ["libcxr.ss" "libcxr.fasl" p0] - ["libnumerics.ss" "libnumerics.fasl" p0] - ["libguardians.ss" "libguardians.fasl" p0] - ["libcore.ss" "libcore.fasl" p0] - ["libchezio.ss" "libchezio.fasl" p0] - ["libhash.ss" "libhash.fasl" p0] - ["libwriter.ss" "libwriter.fasl" p0] - ["libtokenizer.ss" "libtokenizer.fasl" p0] - ["libassembler.ss" "libassembler.fasl" p0] - ["libintelasm.ss" "libintelasm.fasl" p0] - ["libfasl.ss" "libfasl.fasl" p0] - ["libtrace.ss" "libtrace.fasl" p0] - ["libcompile.ss" "libcompile.fasl" p1] - ["psyntax-7.1.ss" "psyntax.fasl" p0] - ["libpp.ss" "libpp.fasl" p0] - ["libcafe.ss" "libcafe.fasl" p0] - ["libposix.ss" "libposix.fasl" p0] - ["libtimers.ss" "libtimers.fasl" p0] - ["libtoplevel.ss" "libtoplevel.fasl" p0] + '(["libhandlers.ss" "libhandlers.fasl" p0 onepass] + ["libcontrol.ss" "libcontrol.fasl" p0 onepass] + ["libcollect.ss" "libcollect.fasl" p0 onepass] + ["librecord.ss" "librecord.fasl" p0 onepass] + ["libcxr.ss" "libcxr.fasl" p0 onepass] + ["libnumerics.ss" "libnumerics.fasl" p0 onepass] + ["libguardians.ss" "libguardians.fasl" p0 onepass] + ["libcore.ss" "libcore.fasl" p0 onepass] + ["libchezio.ss" "libchezio.fasl" p0 onepass] + ["libhash.ss" "libhash.fasl" p0 onepass] + ["libwriter.ss" "libwriter.fasl" p0 onepass] + ["libtokenizer.ss" "libtokenizer.fasl" p0 onepass] + ["libassembler.ss" "libassembler.fasl" p0 onepass] + ["libintelasm.ss" "libintelasm.fasl" p0 onepass] + ["libfasl.ss" "libfasl.fasl" p0 onepass] + ["libtrace.ss" "libtrace.fasl" p0 onepass] + ["libcompile.ss" "libcompile.fasl" p1 onepass] + ["psyntax-7.1.ss" "psyntax.fasl" p0 onepass] + ["libpp.ss" "libpp.fasl" p0 onepass] + ["libcafe.ss" "libcafe.fasl" p0 onepass] + ["libposix.ss" "libposix.fasl" p0 onepass] + ["libtimers.ss" "libtimers.fasl" p0 onepass] + ["libtoplevel.ss" "libtoplevel.fasl" p0 onepass] )) @@ -263,12 +264,18 @@ (define (expand-file ifile) (map sc-expand (read-file ifile))) -(define (compile-library ifile ofile) +(define (compile-library ifile ofile which-compile) (parameterize ([assembler-output #f] [expand-mode 'bootstrap] [interaction-environment system-env]) - (printf "compiling ~a ... \n" ifile) - (compile-file ifile ofile 'replace))) + (let ([proc + (case which-compile + [(onepass) compile-file] + [(chaitin) alt-compile-file] + [else (error 'compile-library "unknown compile ~s" + which-compile)])]) + (printf "compiling ~a ... \n" ifile) + (proc ifile ofile 'replace)))) @@ -277,7 +284,7 @@ (for-each (lambda (x) (when (eq? who (caddr x)) - (compile-library (car x) (cadr x)))) + (compile-library (car x) (cadr x) (cadddr x)))) scheme-library-files)) (define (time x) x) (fork