- 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
parent
f759815a8c
commit
24ece86772
|
|
@ -1 +1 @@
|
|||
1794
|
||||
1795
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -37,6 +38,11 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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 ([c (make-stale-collector)])
|
||||
(let-values (((imp* invoke-req* visit-req* invoke-code
|
||||
visit-code export-subst export-env)
|
||||
(library-body-expander exp* imp* b* #f)))
|
||||
(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)))))))
|
||||
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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
;;; 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 visible? #f)
|
||||
#t)
|
||||
#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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue