diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index 12961a7..acab56a 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.load.ss b/scheme/ikarus.load.ss index 4363960..da1c431 100644 --- a/scheme/ikarus.load.ss +++ b/scheme/ikarus.load.ss @@ -18,7 +18,7 @@ (export load load-r6rs-top-level) (import (except (ikarus) load) - (only (psyntax expander) eval-top-level eval-r6rs-top-level) + (only (psyntax expander) eval-top-level compile-r6rs-top-level) (only (ikarus reader) read-initial)) (define load-handler @@ -45,7 +45,7 @@ (read-and-eval p eval-proc))) (close-input-port p))])) (define load-r6rs-top-level - (lambda (x) + (lambda (x how) (define (read-file) (let ([p (open-input-file x)]) (let ([x (read-script-annotated p)]) @@ -60,5 +60,9 @@ '()] [else (cons x (f))])))))))) (let ([prog (read-file)]) - (eval-r6rs-top-level prog)))) + (let ([thunk (compile-r6rs-top-level prog)]) + (case how + [(run) (thunk)] + [(compile) (error 'load-r6rs "not yet")] + [else (error 'load-r6rs-top-level "invali argument" how)]))))) ) diff --git a/scheme/ikarus.main.ss b/scheme/ikarus.main.ss index 0e82773..3af5f7f 100644 --- a/scheme/ikarus.main.ss +++ b/scheme/ikarus.main.ss @@ -90,13 +90,25 @@ (die 'ikarus "--r6rs-script requires a script name")] [else (values '() (car d) 'r6rs-script (cdr d))]))] + [(string=? (car args) "--compile-r6rs-script") + (let ([d (cdr args)]) + (cond + [(null? d) + (die 'ikarus + "--compile-r6rs-script requires a script name")] + [else + (values '() (car d) 'compile-r6rs-script (cdr d))]))] [else (let-values ([(f* script script-type a*) (f (cdr args))]) (values (cons (car args) f*) script script-type a*))]))]) (cond [(eq? script-type 'r6rs-script) (command-line-arguments (cons script args)) - (load-r6rs-top-level script) + (load-r6rs-top-level script 'run) + (exit 0)] + [(eq? script-type 'compile-r6rs-script) + (command-line-arguments (cons script args)) + (load-r6rs-top-level script 'compile) (exit 0)] [(eq? script-type 'script) ; no greeting, no cafe (command-line-arguments (cons script args)) diff --git a/scheme/last-revision b/scheme/last-revision index 8fef301..f252370 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1392 +1393 diff --git a/scheme/psyntax.compat.ss b/scheme/psyntax.compat.ss index ab3630f..616fd03 100644 --- a/scheme/psyntax.compat.ss +++ b/scheme/psyntax.compat.ss @@ -19,11 +19,13 @@ eval-core symbol-value set-symbol-value! file-options-spec make-struct-type read-annotated annotation? annotation-expression annotation-source - annotation-stripped) + annotation-stripped load-precompiled-library) (import (only (ikarus.compiler) eval-core) (ikarus)) + (define (load-precompiled-library filename sk) #f) + (define-syntax define-record (syntax-rules () [(_ name (field* ...) printer) diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index c3b2ef7..0911786 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -24,7 +24,7 @@ bound-identifier=? datum->syntax syntax-error syntax-violation syntax->datum make-variable-transformer - eval-r6rs-top-level boot-library-expand eval-top-level + compile-r6rs-top-level boot-library-expand eval-top-level null-environment scheme-report-environment ellipsis-map) (import (except (rnrs) @@ -3759,11 +3759,12 @@ (define syntax->datum (lambda (x) (stx->datum x))) - (define eval-r6rs-top-level + (define compile-r6rs-top-level (lambda (x*) (let-values (((lib* invoke-code) (top-level-expander x*))) - (for-each invoke-library lib*) - (eval-core (expanded->core invoke-code))))) + (lambda () + (for-each invoke-library lib*) + (eval-core (expanded->core invoke-code)))))) ;;; The interaction-library is a parameter that is either #f ;;; (the default, for r6rs scripts) or set to an extensible library diff --git a/scheme/psyntax.library-manager.ss b/scheme/psyntax.library-manager.ss index 7cfa3bd..44c9acb 100644 --- a/scheme/psyntax.library-manager.ss +++ b/scheme/psyntax.library-manager.ss @@ -24,7 +24,8 @@ find-library-by-name install-library library-spec invoke-library extend-library-subst! extend-library-env! current-library-expander current-library-collection library-path library-extensions) - (import (rnrs) (psyntax compat) (rnrs r5rs)) + (import (rnrs) (psyntax compat) (rnrs r5rs) + (only (ikarus) printf)) (define (make-collection) (let ((set '())) @@ -155,10 +156,38 @@ f (assertion-violation 'file-locator "not a procedure" f))))) - (define (library-precompiled? x) #f) - (define (load-precompiled-library x) - (error 'load-precompiled-library "not implemented")) + (define (try-load-from-file filename) + (load-precompiled-library filename + (case-lambda + [(id name ver imp* vis* inv* exp-subst exp-env + visit-proc invoke-proc visible?) + ;;; make sure all dependencies are met + ;;; if all is ok, install the library + ;;; otherwise, return #f so that the + ;;; library gets recompiled. + (let f ([deps (append imp* vis* inv*)]) + (cond + [(null? deps) + (install-library id name ver imp* vis* inv* + exp-subst exp-env visit-proc invoke-proc + #f #f visible?) + #t] + [else + (let ([d (car deps)]) + (let ([label (car d)] [dname (cadr d)]) + (let ([l (find-library-by-name dname)]) + (cond + [(and (library? l) (eq? label (library-id l))) + (f (cdr deps))] + [else + (printf + "WARNING: missing or inconsistent dependency \ + on library ~s. \ + Library ~s in file ~s will be recompiled.\n" + dname name filename) + #f]))))]))] + [others #f]))) (define library-loader (make-parameter @@ -167,10 +196,9 @@ (cond [(not file-name) (assertion-violation #f "cannot file library" x)] - [(library-precompiled? file-name) - (load-precompiled-library file-name)] + [(try-load-from-file file-name)] [else - ((current-library-expander) + ((current-library-expander) (with-input-from-file file-name read-annotated))]))) (lambda (f) (if (procedure? f) @@ -218,7 +246,8 @@ (let ((id (car spec))) (or (find-library-by (lambda (x) (eq? id (library-id x)))) - (assertion-violation #f "cannot find library with required spec" spec)))) + (assertion-violation #f + "cannot find library with required spec" spec)))) (define label->binding-table (make-eq-hashtable)) @@ -278,7 +307,8 @@ (lambda () (assertion-violation 'invoke "circularity detected" lib))) (for-each invoke-library (library-inv* lib)) (set-library-invoke-state! lib - (lambda () (assertion-violation 'invoke "first invoke did not return" lib))) + (lambda () + (assertion-violation 'invoke "first invoke did not return" lib))) (invoke) (set-library-invoke-state! lib #t)))) @@ -290,7 +320,8 @@ (lambda () (assertion-violation 'visit "circularity detected" lib))) (for-each invoke-library (library-vis* lib)) (set-library-visit-state! lib - (lambda () (assertion-violation 'invoke "first visit did not return" lib))) + (lambda () + (assertion-violation 'invoke "first visit did not return" lib))) (visit) (set-library-visit-state! lib #t))))