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

[mevenson at common-lisp.net]

Author: mevenson
Date: Tue Feb 26 08:13:50 2013
New Revision: 14404

Log:
Fix error on form redefition introduced with r14403.

Addresses #282 comment 5.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Extensions.java
   trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Extensions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Extensions.java	Tue Feb 26 06:53:59 2013	(r14403)
+++ trunk/abcl/src/org/armedbear/lisp/Extensions.java	Tue Feb 26 08:13:50 2013	(r14404)
@@ -176,10 +176,16 @@
     }
   }
 
-  // ### source-pathname
-  public static final Primitive SOURCE_PATHNAME = new source_pathname();
-  private static class source_pathname extends Primitive {
-    source_pathname() {
+  // XXX rename to something else as it doesn't always refer to a pathname.
+  public static final Primitive SOURCE_PATHNAME = new pf_source_pathname();
+  @DocString(
+    name="source-pathname",
+    args="symbol",
+    doc="Returns either the pathname corresponding to the file from which this symbol was compiled,"
+    + "or the keyword :TOP-LEVEL."
+  )
+  private static class pf_source_pathname extends Primitive {
+    pf_source_pathname() {
       super("source-pathname", PACKAGE_EXT, true);
     }
     @Override

Modified: trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp	Tue Feb 26 06:53:59 2013	(r14403)
+++ trunk/abcl/src/org/armedbear/lisp/fdefinition.lisp	Tue Feb 26 08:13:50 2013	(r14404)
@@ -37,7 +37,9 @@
   (when (and *warn-on-redefinition* (fboundp name) (not (autoloadp name)))
     (cond ((symbolp name)
            (let ((old-source 
-                  (truename (source-pathname name)))
+                  (if (keywordp (source-pathname name))
+                      (source-pathname name)
+                      (truename (source-pathname name))))
                  (current-source 
                   (if (not *source*) 
                       :top-level