[armedbear-cvs] r14296 - trunk/abcl/src/org/armedbear/lisp

[mevenson at common-lisp.net]

Author: mevenson
Date: Thu Dec  6 01:23:15 2012
New Revision: 14296

Log:
Constrain the logic for when CL:REQUIRE pushes symbols to CL:*MODULES*.

A REQUIRE of ABCL-CONTRIB for an instance of the implementation that
cannot locate the contrib binary artifact as being in the same
directory as the location of the ABCL system jar by
SYS:FIND-SYSTEM-JAR now raises an error.

Fixes #275.

Modified:
   trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp
   trunk/abcl/src/org/armedbear/lisp/require.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp	Wed Dec  5 23:11:38 2012	(r14295)
+++ trunk/abcl/src/org/armedbear/lisp/abcl-contrib.lisp	Thu Dec  6 01:23:15 2012	(r14296)
@@ -2,10 +2,9 @@
 
 (require :asdf)
 
-;;; TODO possibly allow customization in system.lisp?
 (defun find-system-jar () 
+  "Return the pathname of the system jar, one of `abcl.jar` or `abcl-m.n.p.jar` or `abcl-m.n.p-something.jar`."
   (flet ((match-system-jar (p)
-           "Match `abcl.jar` or `abcl-1.0.1.jar` or `abcl-1.0.1-something.jar`"
            (and (pathnamep p)
                 (equal (pathname-type p) "jar")
                 (java:jstatic "matches"
@@ -27,7 +26,8 @@
 Initialized via SYSTEM:FIND-CONTRIB")
 
 (defun find-contrib (&key (verbose nil))
-"Attempt to find the ABCL contrib jar and add its contents to ASDF."
+  "Attempt to find the ABCL contrib jar and add its contents to ASDF.
+Returns the pathname of the contrib if it can be found."
   (unless *abcl-contrib*
     (unless *abcl-jar*
       (setf *abcl-jar* (find-system-jar)))
@@ -50,7 +50,7 @@
                     (push asdf-directory asdf:*central-registry*)
                     (format verbose "~&Added ~A to ASDF.~&" asdf-directory))))
               *abcl-contrib*)
-        (format verbose "Failed to find abcl-contrib at '~A'." abcl-contrib))))))
+            (error "Failed to find abcl-contrib at '~A'." abcl-contrib))))))
 
 (when (find-contrib :verbose t)
   (provide :abcl-contrib))

Modified: trunk/abcl/src/org/armedbear/lisp/require.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/require.lisp	Wed Dec  5 23:11:38 2012	(r14295)
+++ trunk/abcl/src/org/armedbear/lisp/require.lisp	Thu Dec  6 01:23:15 2012	(r14296)
@@ -56,16 +56,23 @@
 (defun require (module-name &optional pathnames)
   (unless (member (string module-name) *modules* :test #'string=)
     (let ((saved-modules (copy-list *modules*)))
-      (cond (pathnames
-             (unless (listp pathnames) (setf pathnames (list pathnames)))
-             (dolist (x pathnames)
-               (load x))
-             (provide module-name))
-            (t
-             (if (some (lambda (p) (funcall p module-name))
+      (cond                
+;;; Since these are files packaged with the system we ensure that
+;;; PROVIDE has been called unless the module has other dependencies
+;;; that must be satisfied to be loaded, which is currently only the
+;;; case with 'abcl-contrib'.
+        (pathnames
+         (unless (listp pathnames) (setf pathnames (list pathnames)))
+         (dolist (x pathnames)
+           (load x))
+         (unless (string-equal module-name "abcl-contrib")
+           (provide module-name)))
+;;; Responsibility for actually calling PROVIDE up to module provider
+;;; function
+        (t
+         (unless (some (lambda (p) (funcall p module-name))
                            (append (list #'module-provide-system)
-                                 sys::*module-provider-functions*))
-                 (provide module-name) ;; Shouldn't hurt
-                 (error "Don't know how to ~S ~A." 'require module-name))))
+                                   sys::*module-provider-functions*))
+               (error "Don't know how to ~S ~A." 'require module-name))))
       (set-difference *modules* saved-modules))))