more preparations for separate compilation

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

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

scheme/last-revision

@@ -1 +1 @@
-1392
+1393

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)

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*)
+        (lambda ()
-        (eval-core (expanded->core invoke-code)))))
+          (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

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) 
+  (define (try-load-from-file filename)
-    (error 'load-precompiled-library "not implemented"))
+    (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)
+            [(try-load-from-file file-name)]
-             (load-precompiled-library 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))))