* added a "current-library-collection" primitive.

Calling (current-library-collection) returns a procedure that:
    - when called with no arguments, it returns a list of the set of
      libraries in the collection.
    - when called with a single argument, it adds that library to
      the set of libraries in the collection.
  Calling (current-library-collection f) sets the current library 
   collection to be the procedure f which must follow the protocol
   above.

src/library-manager.ss

@@ -1,8 +1,30 @@
 
+
+
+
 (library (ikarus library-manager)
   (export)
   (import (scheme))
 
+
+  (define (make-collection)
+    (let ([set '()])
+      (define (set-cons x ls)
+        (cond
+          [(memq x ls) ls]
+          [else (cons x ls)]))
+      (case-lambda
+        [() set]
+        [(x) (set! set (set-cons x set))])))
+
+  (define lm:current-library-collection
+    (make-parameter (make-collection) 
+      (lambda (x)
+        (unless (procedure? x)
+          (error 'current-library-collection 
+            "~s is not a procedure" x))
+        x)))
+
   (define-record library 
     (id name ver imp* vis* inv* subst env visit-state invoke-state))
 
@@ -11,10 +33,8 @@
       [(null? ls) '()]
       [else (error 'find-dependencies "cannot handle deps yet")]))
 
-  (define *all-libraries* '())
-
   (define (find-library-by pred)
-    (let f ([ls *all-libraries*])
+    (let f ([ls ((lm:current-library-collection))])
       (cond
         [(null? ls) #f]
         [(pred (car ls)) (car ls)]
@@ -45,8 +65,7 @@
         (error 'install-library "~s is already installed" name))
       (let ([lib (make-library id name ver imp-lib* vis-lib* inv-lib* 
                     exp-subst exp-env visit-code invoke-code)])
-        (set! *all-libraries* (cons lib *all-libraries*))
-        )))
+        ((lm:current-library-collection) lib))))
 
   (define scheme-env ; the-env
     '([define        define-label        (define)]
@@ -491,10 +510,11 @@
       [imported-label->binding  imported-label->binding-label (core-prim . imported-label->binding)] 
       [imported-loc->library  imported-loc->library-label (core-prim . imported-loc->library)] 
       [library-spec library-spec-label (core-prim . library-spec)]
+      [current-library-collection current-library-collection-label (core-prim . current-library-collection)]
       [invoke-library invoke-library-label (core-prim . invoke-library)]
       ))
   (define (lm:imported-label->binding lab)
-    (let f ([ls *all-libraries*])
+    (let f ([ls ((lm:current-library-collection))])
       (cond
         [(null? ls) #f]
         [(assq lab (library-env (car ls))) => cdr]
@@ -508,7 +528,7 @@
                (or (and (eq? (car binding) 'global)
                         (eq? (cdr binding) loc))
                    (loc-in-env? (cdr ls)))))))
-    (let f ([ls *all-libraries*])
+    (let f ([ls ((lm:current-library-collection))])
       (cond
         [(null? ls) #f]
         [(loc-in-env? (library-env (car ls))) (car ls)]
@@ -541,7 +561,7 @@
                         void void))
 
   (primitive-set! 'installed-libraries 
-    (lambda () *all-libraries*))
+    (lambda () ((lm:current-library-collection))))
   (primitive-set! 'library-subst/env
     (lambda (x) 
       (unless (library? x)
@@ -556,5 +576,6 @@
   (primitive-set! 'imported-label->binding lm:imported-label->binding)
   (primitive-set! 'imported-loc->library lm:imported-loc->library)
   (primitive-set! 'invoke-library lm:invoke-library)
+  (primitive-set! 'current-library-collection lm:current-library-collection)
   (primitive-set! 'install-library lm:install-library))
 

src/libsyntax.ss

@@ -2018,7 +2018,7 @@
                                         (map build-export lex*)
                                         (chi-expr* init* r mr))))])
                       (let-values ([(export-subst export-env) 
-                                    (find-exports rib r exp-int* exp-ext*)])
+                                    (find-exports exp-int* exp-ext* rib r)])
                         (values
                           name imp* (rtc)
                           (build-letrec no-source lex* rhs* body)
@@ -2027,10 +2027,6 @@
     (lambda (x) 
       (let-values ([(name imp* run* invoke-code export-subst export-env)
                     (core-library-expander x)])
-        ;;; we need: name/ver/id, 
-        ;;;    imports, visit, invoke  name/ver/id
-        ;;;    export-subst, export-env
-        ;;;    visit-code, invoke-code
         (let ([id (gensym)]
               [name name]
               [ver '()]  ;;; FIXME
@@ -2050,22 +2046,7 @@
     (lambda (x)
       ;;; exports use the same gensym
       `(#%$set-symbol-value! ',x ,x)))
-  (define find-export
-    (lambda (rib r)
-      (lambda (sym)
-        (let* ([id (stx sym top-mark* (list rib))]
-               [label (id->label id)]
-               [b (label->binding label r)]
-               [type (binding-type b)])
-          (unless label 
-            (stx-error id "cannot export unbound identifier"))
-          (case type
-            [(lexical)
-             ;;; exports use the same gensym
-             (list sym label 'global (binding-value b))]
-            [else (error #f "cannot export ~s of type ~s" sym type)])))))
-  (define (find-exports rib r int* ext*)
-    ;;; FIXME: check unique exports
+  (define (find-exports int* ext* rib r)
     (let f ([int* int*] [ext* ext*] [subst '()] [env '()])
       (cond
         [(null? int*) (values subst env)]