diff --git a/scheme/last-revision b/scheme/last-revision index 6310a81..8479ac6 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1794 +1795 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 756f00e..c5525f5 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -126,6 +126,7 @@ [set! (set!)] [let-syntax (let-syntax)] [letrec-syntax (letrec-syntax)] + [stale-when (stale-when)] [foreign-call (core-macro . foreign-call)] [quote (core-macro . quote)] [syntax-case (core-macro . syntax-case)] @@ -296,6 +297,7 @@ [define-struct i] [include i] [include-into i] + [stale-when i] [time i] [trace-lambda i] [trace-let i] @@ -1691,7 +1693,7 @@ '()))]) `(install-library ',id ',name ',version ',import-libs ',visit-libs ',invoke-libs - ',subst ',env void void '#f '#f ',visible? '#f))))) + ',subst ',env void void '#f '#f '#f '() ',visible? '#f))))) (let ([code `(library (ikarus primlocs) (export) ;;; must be empty (import diff --git a/scheme/psyntax.compat.ss b/scheme/psyntax.compat.ss index a224719..8ef9225 100644 --- a/scheme/psyntax.compat.ss +++ b/scheme/psyntax.compat.ss @@ -22,6 +22,7 @@ annotation-stripped read-library-source-file library-version-mismatch-warning + library-stale-warning file-locator-resolution-error label-binding set-label-binding! remove-location make-source-position-condition) @@ -29,32 +30,37 @@ (only (ikarus.compiler) eval-core) (only (ikarus.reader.annotated) read-library-source-file) (ikarus)) - + (define (library-version-mismatch-warning name depname filename) (fprintf (current-error-port) "WARNING: library ~s has an inconsistent dependency \ on library ~s; file ~s will be recompiled from \ source.\n" name depname filename)) + + (define (library-stale-warning name filename) + (fprintf (current-error-port) + "WARNING: library ~s is stale; file ~s will be recompiled from source.\n" + name filename)) - (define (file-locator-resolution-error libname failed-list pending-list) - (define-condition-type &library-resolution &condition - make-library-resolution-condition - library-resolution-condition? - (library condition-library) - (files condition-files)) - (define-condition-type &imported-from &condition - make-imported-from-condition imported-from-condition? - (importing-library importing-library)) + (define (file-locator-resolution-error libname failed-list pending-list) + (define-condition-type &library-resolution &condition + make-library-resolution-condition + library-resolution-condition? + (library condition-library) + (files condition-files)) + (define-condition-type &imported-from &condition + make-imported-from-condition imported-from-condition? + (importing-library importing-library)) - (raise - (apply condition (make-error) - (make-who-condition 'expander) - (make-message-condition - "cannot locate library in library-path") - (make-library-resolution-condition - libname failed-list) - (map make-imported-from-condition pending-list)))) + (raise + (apply condition (make-error) + (make-who-condition 'expander) + (make-message-condition + "cannot locate library in library-path") + (make-library-resolution-condition + libname failed-list) + (map make-imported-from-condition pending-list)))) (define-syntax define-record (syntax-rules () diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 4ec5f41..4a6ada4 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -704,7 +704,7 @@ macro! local-macro local-macro! global-macro global-macro! module library set! let-syntax letrec-syntax import export $core-rtd - ctv local-ctv global-ctv) + ctv local-ctv global-ctv stale-when) (values type (binding-value b) id)) (else (values 'call #f #f)))) @@ -2734,6 +2734,8 @@ rator (chi-expr* rands r mr))))))) + + (define chi-expr (lambda (e r mr) (let-values (((type value kwd) (syntax-type e r))) @@ -2766,6 +2768,13 @@ ((_ x x* ...) (build-sequence no-source (chi-expr* (cons x x*) r mr))))) + ((stale-when) + (syntax-match e () + ((_ guard x x* ...) + (begin + (handle-stale-when guard mr) + (build-sequence no-source + (chi-expr* (cons x x*) r mr)))))) ((let-syntax letrec-syntax) (syntax-match e () ((_ ((xlhs* xrhs*) ...) xbody xbody* ...) @@ -3133,6 +3142,14 @@ (chi-body* (append x* (cdr e*)) r mr lex* rhs* mod** kwd* exp* rib mix? sd?)))) + ((stale-when) + (syntax-match e () + ((_ guard x* ...) + (begin + (handle-stale-when guard mr) + (chi-body* (append x* (cdr e*)) + r mr lex* rhs* mod** kwd* exp* rib + mix? sd?))))) ((global-macro global-macro!) (chi-body* (cons (add-subst rib (chi-global-macro value e r)) @@ -3545,6 +3562,7 @@ (assertion-violation 'imp-collector "BUG: not a procedure" x)) x))) + (define chi-library-internal (lambda (e* rib mix?) (let-values (((e* r mr lex* rhs* mod** _kwd* exp*) @@ -3627,18 +3645,44 @@ (list invoke-body))) macro* export-subst export-env)))))))))))))) + (define stale-when-collector (make-parameter #f)) + + (define (make-stale-collector) + (let ([code (build-data no-source #f)] + [req* '()]) + (case-lambda + [() (values code req*)] + [(c r*) + (set! code + (build-conditional no-source + code + (build-data no-source #t) + c)) + (set! req* (set-union r* req*))]))) + + (define (handle-stale-when guard-expr mr) + (let ([stc (make-collector)]) + (let ([core-expr (parameterize ([inv-collector stc]) + (chi-expr guard-expr mr mr))]) + (cond + [(stale-when-collector) => + (lambda (c) (c core-expr (stc)))])))) + (define core-library-expander (case-lambda ((e verify-name) (let-values (((name* exp* imp* b*) (parse-library e))) (let-values (((name ver) (parse-library-name name*))) (verify-name name) - (let-values (((imp* invoke-req* visit-req* invoke-code - visit-code export-subst export-env) - (library-body-expander exp* imp* b* #f))) - (values name ver imp* invoke-req* visit-req* - invoke-code visit-code export-subst - export-env))))))) + (let ([c (make-stale-collector)]) + (let-values (((imp* invoke-req* visit-req* invoke-code + visit-code export-subst export-env) + (parameterize ([stale-when-collector c]) + (library-body-expander exp* imp* b* #f)))) + (let-values ([(guard-code guard-req*) (c)]) + (values name ver imp* invoke-req* visit-req* + invoke-code visit-code export-subst + export-env guard-code guard-req*))))))))) (define (parse-top-level-program e*) (syntax-match e* () @@ -3773,7 +3817,8 @@ (set-symbol-value! loc proc))) macro*)) (let-values (((name ver imp* inv* vis* - invoke-code macro* export-subst export-env) + invoke-code macro* export-subst export-env + guard-code guard-req*) (core-library-expander x verify-name))) (let ((id (gensym)) (name name) @@ -3781,6 +3826,7 @@ (imp* (map library-spec imp*)) (vis* (map library-spec vis*)) (inv* (map library-spec inv*)) + (guard-req* (map library-spec guard-req*)) (visit-proc (lambda () (visit! macro*))) (invoke-proc (lambda () (eval-core (expanded->core invoke-code)))) @@ -3790,10 +3836,12 @@ imp* vis* inv* export-subst export-env visit-proc invoke-proc visit-code invoke-code + guard-code guard-req* #t filename) (values id name ver imp* vis* inv* invoke-code visit-code - export-subst export-env)))) + export-subst export-env + guard-code guard-req*)))) ((x filename) (library-expander x filename (lambda (x) (values)))) ((x) @@ -3803,7 +3851,8 @@ ;;; be) be used in the "next" system. So, we drop it. (define (boot-library-expand x) (let-values (((id name ver imp* vis* inv* - invoke-code visit-code export-subst export-env) + invoke-code visit-code export-subst export-env + guard-code guard-dep*) (library-expander x))) (values name invoke-code export-subst export-env))) diff --git a/scheme/psyntax.library-manager.ss b/scheme/psyntax.library-manager.ss index b1835de..0b89ed0 100644 --- a/scheme/psyntax.library-manager.ss +++ b/scheme/psyntax.library-manager.ss @@ -54,8 +54,8 @@ (define-record library (id name version imp* vis* inv* subst env visit-state - invoke-state visit-code invoke-code visible? - source-file-name) + invoke-state visit-code invoke-code guard-code guard-req* + visible? source-file-name) (lambda (x p wr) (unless (library? x) (assertion-violation 'record-type-printer "not a library")) @@ -177,6 +177,8 @@ (library-env x) (compile (library-visit-code x)) (compile (library-invoke-code x)) + (compile (library-guard-code x)) + (map library-desc (library-guard-req* x)) (library-visible? x))))) ((current-library-collection)))) @@ -188,18 +190,30 @@ filename (case-lambda ((id name ver imp* vis* inv* exp-subst exp-env - visit-proc invoke-proc visible?) + visit-proc invoke-proc guard-proc guard-req* 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*))) + (let f ((deps (append imp* vis* inv* guard-req*))) (cond ((null? deps) - (install-library id name ver imp* vis* inv* - exp-subst exp-env visit-proc invoke-proc - #f #f visible? #f) - #t) + ;;; CHECK + (for-each + (lambda (x) + (let ([label (car x)] [dname (cadr x)]) + (let ([lib (find-library-by-name dname)]) + (invoke-library lib)))) + guard-req*) + (cond + [(guard-proc) ;;; stale + (library-stale-warning name filename) + #f] + [else + (install-library id name ver imp* vis* inv* + exp-subst exp-env visit-proc invoke-proc + #f #f ''#f '() visible? #f) + #t])) (else (let ((d (car deps))) (let ((label (car d)) (dname (cadr d))) @@ -333,10 +347,12 @@ (case-lambda ((id name ver imp* vis* inv* exp-subst exp-env visit-proc invoke-proc visit-code invoke-code + guard-code guard-req* visible? source-file-name) (let ((imp-lib* (map find-library-by-spec/die imp*)) (vis-lib* (map find-library-by-spec/die vis*)) - (inv-lib* (map find-library-by-spec/die inv*))) + (inv-lib* (map find-library-by-spec/die inv*)) + (guard-lib* (map find-library-by-spec/die guard-req*))) (unless (and (symbol? id) (list? name) (list? ver)) (assertion-violation 'install-library "invalid spec with id/name/ver" id name ver)) @@ -345,7 +361,8 @@ "library is already installed" name)) (let ((lib (make-library id name ver imp-lib* vis-lib* inv-lib* exp-subst exp-env visit-proc invoke-proc - visit-code invoke-code visible? source-file-name))) + visit-code invoke-code guard-code guard-lib* + visible? source-file-name))) (install-library-record lib)))))) (define (imported-label->binding lab)