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

scheme/last-revision

@@ -1 +1 @@
-1794
+1795

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 

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 (file-locator-resolution-error libname failed-list pending-list)
-      (define-condition-type &library-resolution &condition
+    (define-condition-type &library-resolution &condition
-         make-library-resolution-condition
+       make-library-resolution-condition
-         library-resolution-condition?
+       library-resolution-condition?
-         (library condition-library)
+       (library condition-library)
-         (files condition-files))
+       (files condition-files))
-      (define-condition-type &imported-from &condition
+    (define-condition-type &imported-from &condition
-         make-imported-from-condition imported-from-condition?
+       make-imported-from-condition imported-from-condition?
-         (importing-library importing-library))
+       (importing-library importing-library))
 
-      (raise 
+    (raise 
-        (apply condition (make-error)
+      (apply condition (make-error)
-          (make-who-condition 'expander)
+        (make-who-condition 'expander)
-          (make-message-condition
+        (make-message-condition
-            "cannot locate library in library-path")
+          "cannot locate library in library-path")
-          (make-library-resolution-condition 
+        (make-library-resolution-condition 
-            libname failed-list)
+          libname failed-list)
-          (map make-imported-from-condition pending-list))))
+        (map make-imported-from-condition pending-list))))
 
   (define-syntax define-record
     (syntax-rules ()

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
+           (let ([c (make-stale-collector)])
-                               visit-code export-subst export-env)
+             (let-values (((imp* invoke-req* visit-req* invoke-code
-                         (library-body-expander exp* imp* b* #f)))
+                                 visit-code export-subst export-env)
-              (values name ver imp* invoke-req* visit-req* 
+                           (parameterize ([stale-when-collector c])
-                      invoke-code visit-code export-subst
+                             (library-body-expander exp* imp* b* #f))))
-                      export-env)))))))
+               (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)))
   

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?
+        invoke-state visit-code invoke-code guard-code guard-req*
-        source-file-name)
+        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* 
+              ;;; CHECK
-                exp-subst exp-env visit-proc invoke-proc 
+              (for-each
-                #f #f visible? #f)
+                (lambda (x)
-              #t)
+                  (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)