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

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun Jan 30 08:17:50 2011
New Revision: 13190

Log:
Detect loops in autoloads and requires (and remove some trailing whitespace).

Modified:
   trunk/abcl/src/org/armedbear/lisp/Autoload.java
   trunk/abcl/src/org/armedbear/lisp/require.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Autoload.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Autoload.java	(original)
+++ trunk/abcl/src/org/armedbear/lisp/Autoload.java	Sun Jan 30 08:17:50 2011
@@ -45,6 +45,12 @@
 
     private final Symbol symbol;
 
+    private final static Symbol AUTOLOADS_IN_PROGRESS
+            = PACKAGE_SYS.addInternalSymbol("*AUTOLOADS-IN-PROGRESS*");
+    {
+        AUTOLOADS_IN_PROGRESS.setSymbolValue(NIL);
+    }
+
     protected Autoload(Symbol symbol)
     {
         super();
@@ -133,12 +139,34 @@
         out._finishOutput();
     }
 
+    private void detectCircularity(LispThread thread) {
+        SimpleString val = new SimpleString((getFileName() == null)
+                ? className : getFileName());
+        LispObject autoloads = AUTOLOADS_IN_PROGRESS.symbolValue(thread);
+        LispObject list = autoloads;
+        while (list != NIL) {
+            if (val.equal(list.car()))
+                Lisp.error(new SimpleString("Autoloading circularity detected while resolving "
+                        + symbol.getQualifiedName() + "; autoloads in "
+                        + "progress: " + autoloads.writeToString()));
+
+            list = list.cdr();
+        }
+
+        return;
+    }
+
     public void load()
     {
         final LispThread thread = LispThread.currentThread();
+
+        detectCircularity(thread);
+
         final SpecialBindingsMark mark = thread.markSpecialBindings();
         int loadDepth = Fixnum.getValue(_LOAD_DEPTH_.symbolValue());
         thread.bindSpecial(_LOAD_DEPTH_, Fixnum.getInstance(++loadDepth));
+        thread.pushSpecial(AUTOLOADS_IN_PROGRESS,
+                new SimpleString((getFileName() == null) ? className : getFileName()));
         try {
             if (_AUTOLOAD_VERBOSE_.symbolValue(thread) != NIL
                 || "Y".equals(System.getProperty("abcl.autoload.verbose")))

Modified: trunk/abcl/src/org/armedbear/lisp/require.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/require.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/require.lisp	Sun Jan 30 08:17:50 2011
@@ -36,23 +36,30 @@
   (pushnew (string module-name) *modules* :test #'string=)
   t)
 
-(defun module-provide-system (module) 
+(defun module-provide-system (module)
   (let ((*readtable* (copy-readtable nil)))
-    (handler-case 
+    (handler-case
         (load-system-file (string-downcase (string module)))
-      (t (e) 
+      (t (e)
         (unless (and (typep e 'error)
                      (search "Failed to find loadable system file"
                              (format nil "~A" e)))
-          (format *error-output* "Failed to require  ~A because '~A'~%" 
+          (format *error-output* "Failed to require  ~A because '~A'~%"
                   module e))
         nil))))
-    
+
 (defvar *module-provider-functions* nil)
+(defvar *requires-in-progress* nil)
 
 (defun require (module-name &optional pathnames)
   (unless (member (string module-name) *modules* :test #'string=)
-    (let ((saved-modules (copy-list *modules*)))
+    (unless (member (string module-name) *requires-in-progress*
+                    :test #'string=)
+      (error "Circularity detected while requiring ~A; ~
+              nesting list: ~S." module-name *requires-in-progress*))
+    (let ((saved-modules (copy-list *modules*))
+          (*requires-in-progress* (cons (string module-name)
+                                        *requires-in-progress*)))
       (cond (pathnames
              (unless (listp pathnames) (setf pathnames (list pathnames)))
              (dolist (x pathnames)