~ chicken-core (chicken-5) 648ca198945f6b51634b45dbe60eb6e7c792cfbc

commit 648ca198945f6b51634b45dbe60eb6e7c792cfbc
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Feb 9 07:29:54 2016 +1300
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:35 2016 +1300

    Better tracking for statically-provided requirements
    
    Adds a tracking list for provided library requirements and consults
    that in addition to the set of used-units when checking for static
    availability of requirements in `##core#require`.

diff --git a/core.scm b/core.scm
index 9541644e..9fc85544 100644
--- a/core.scm
+++ b/core.scm
@@ -298,7 +298,7 @@
      extended-bindings standard-bindings
 
      ;; non-booleans set by the (batch) driver, and read by the (c) backend
-     target-heap-size target-stack-size unit-name used-units
+     target-heap-size target-stack-size unit-name used-units provided
 
      ;; bindings, set by the (c) platform
      default-extended-bindings default-standard-bindings internal-bindings
@@ -420,6 +420,7 @@
 (define toplevel-scope #t)
 (define toplevel-lambda-id #f)
 (define file-requirements #f)
+(define provided '())
 
 (define unlikely-variables '(unquote unquote-splicing))
 
@@ -654,7 +655,12 @@
 				    (hide-variable var)
 				    var) ] ) ) )
 
-			((##core#callunit ##core#provide ##core#primitive ##core#undefined) x)
+			((##core#callunit ##core#primitive ##core#undefined) x)
+
+			((##core#provide)
+			 (let ((id (cadr x)))
+			   (set! provided (lset-adjoin/eq? provided id))
+			   `(##core#provide ,id)))
 
 			((##core#inline_ref)
 			 `(##core#inline_ref
@@ -673,7 +679,7 @@
 			 (let ((id         (cadr x))
 			       (alternates (cddr x)))
 			   (let-values (((exp found type)
-					 (##sys#process-require id #t alternates used-units)))
+					 (##sys#process-require id #t alternates provided)))
 			     (unless (not type)
 			       (##sys#hash-table-update!
 				file-requirements type
@@ -983,7 +989,6 @@
 			    (let ((body
 				   (canonicalize-begin-body
 				    (append
-				     `((##core#provide ,req))
 				     (parameterize ((##sys#current-module #f)
 						    (##sys#macro-environment
 						     (##sys#meta-macro-environment)))
@@ -993,8 +998,8 @@
 					   x
 					   e ;?
 					   (##sys#current-meta-environment) #f #f h ln) )
-					module-registration))
-				     body))))
+					(cons `(##core#provide ,req) module-registration)))
+				      body))))
 			      (do ((cs compiler-syntax (cdr cs)))
 				  ((eq? cs csyntax))
 				(##sys#put! (caar cs) '##compiler#compiler-syntax (cdar cs)))
@@ -1427,14 +1432,14 @@
        (syntax-error "invalid declaration specification" spec) )
      (case (strip-syntax (car spec)) ; no global aliasing
        ((uses)
-	(let ((us (stripu (cdr spec))))
+	(let ((us (lset-difference/eq? (stripu (cdr spec)) used-units)))
 	  (when (pair? us)
+	    (set! provided (append provided us))
+	    (set! used-units (append used-units us))
 	    (##sys#hash-table-update!
 	     file-requirements 'static
 	     (cut lset-union/eq? us <>)
-	     (lambda () us))
-	    (set! used-units
-	      (append used-units us)))))
+	     (lambda () us)))))
        ((unit)
 	(check-decl spec 1 1)
 	(let ((u (stripu (cadr spec))))
diff --git a/eval.scm b/eval.scm
index 80f7c25c..485afb67 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1283,16 +1283,16 @@
 ;;   - a library id if the library was found, #f otherwise
 ;;   - a requirement type (e.g. 'dynamic) or #f if provided statically
 ;;
-(define (##sys#process-require lib #!optional compiling? (alternates '()) (static-units '()))
+(define (##sys#process-require lib #!optional compiling? (alternates '()) (provided '()))
   (let ((id (library-id lib)))
     (cond
       ((assq id core-unit-requirements) =>
        (lambda (x) (values (cdr x) id #f)))
       ((memq id builtin-features)
        (values '(##core#undefined) id #f))
-      ((memq id static-units)
+      ((memq id provided)
        (values '(##core#undefined) id #f))
-      ((any (cut memq <> static-units) alternates)
+      ((any (cut memq <> provided) alternates)
        (values '(##core#undefined) id #f))
       ((memq id core-units)
        (values