- Added stale-when:

syntax:  (stale-when guard-expr e* ...)   ;; in definition context
            (stale-when guard-expr e e* ...) ;; in expression context

   semantics:
     When a stale-when form is encountered while expanding any code
     (expressions, macros, macros in macros, etc.) in a library
     body, the guard-expr is expanded (but not evaluated) and
     serialized along with the library.  When the library is later
     reloaded from fasl and before it is installed, the guard-expr
     is evaluated.  If guard-expr returns true, the fasl content is
     ignored and the library is recompiled afresh from source.
This commit is contained in:
Abdulaziz Ghuloum 2009-05-28 09:02:47 +03:00
parent f759815a8c
commit 24ece86772
5 changed files with 114 additions and 40 deletions

View File

@ -1 +1 @@
1794
1795

View File

@ -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

View File

@ -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 ()

View File

@ -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)))

View File

@ -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)