[armedbear-cvs] r14431 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sun Mar 10 08:52:36 2013
New Revision: 14431

Log:
Make add-package-local-nicknames errors continuable

- partly fixes #307

Modified:
   trunk/abcl/src/org/armedbear/lisp/Package.java
   trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java
   trunk/abcl/src/org/armedbear/lisp/Symbol.java
   trunk/abcl/src/org/armedbear/lisp/package.lisp
   trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Package.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Package.java	Sat Mar  9 05:02:45 2013	(r14430)
+++ trunk/abcl/src/org/armedbear/lisp/Package.java	Sun Mar 10 08:52:36 2013	(r14431)
@@ -780,16 +780,6 @@
 
   public LispObject addLocalPackageNickname(String name, Package pack)
   {
-    if (name.equals("CL") || name.equals("COMMON-LISP")
-        || name.equals("KEYWORD")) {
-      return error(new LispError("Trying to define a local nickname for "
-                                 + name));
-    }
-    if (name.equals(this.name)
-        || (nicknames != null && nicknames.contains(name))) {
-      return error(new LispError("Trying to override package name or nickname with a local nickname "
-                                 + name));
-    }
     if (localNicknames == null) {
       localNicknames = new ConcurrentHashMap<String, Package>();
     }

Modified: trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java	Sat Mar  9 05:02:45 2013	(r14430)
+++ trunk/abcl/src/org/armedbear/lisp/PackageFunctions.java	Sun Mar 10 08:52:36 2013	(r14431)
@@ -285,7 +285,7 @@
   // ### add-package-local-nickname
   // add-package-local-nickname local-nickname package &optional package-designator => package
   private static final Primitive ADD_PACKAGE_LOCAL_NICKNAME =
-    new Primitive("add-package-local-nickname", PACKAGE_EXT, true,
+    new Primitive("%add-package-local-nickname", PACKAGE_SYS, false,
                   "local-nickname package &optional package-designator")
     {
       @Override

Modified: trunk/abcl/src/org/armedbear/lisp/Symbol.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Symbol.java	Sat Mar  9 05:02:45 2013	(r14430)
+++ trunk/abcl/src/org/armedbear/lisp/Symbol.java	Sun Mar 10 08:52:36 2013	(r14431)
@@ -2968,6 +2968,8 @@
     PACKAGE_EXT.addExternalSymbol("URL-PATHNAME");
   public static final Symbol WEAK_REFERENCE =
     PACKAGE_EXT.addExternalSymbol("WEAK-REFERENCE");
+  public static final Symbol ADD_PACKAGE_LOCAL_NICKNAME =
+    PACKAGE_EXT.addExternalSymbol("ADD-PACKAGE-LOCAL-NICKNAME");
 
   // MOP.
   public static final Symbol CLASS_LAYOUT =

Modified: trunk/abcl/src/org/armedbear/lisp/package.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/package.lisp	Sat Mar  9 05:02:45 2013	(r14430)
+++ trunk/abcl/src/org/armedbear/lisp/package.lisp	Sun Mar 10 08:52:36 2013	(r14431)
@@ -96,3 +96,24 @@
 (defun delete-package (package)
   (with-simple-restart (continue "Ignore missing package.")
     (sys::%delete-package package)))
+
+(defun add-package-local-nickname (local-nickname actual-package
+                                   &optional (package-designator *package*))
+  (let* ((local-nickname (string local-nickname))
+         (package-designator (or (find-package package-designator)
+                                 (error "Package ~A not found" package-designator)))
+         (actual-package (or (find-package actual-package)
+                             (error "Package ~A not found" actual-package))))
+    (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD")
+                  :test #'string=)
+      (cerror "Continue anyway"
+              "Trying to define a local nickname called ~A" local-nickname))
+    (when (member local-nickname (list* (package-name package-designator)
+                                        (package-nicknames package-designator))
+                  :test #'string=)
+      (cerror "Continue anyway"
+              "Trying to override the name or nickname ~A  for package ~A ~
+               with a local nickname for another package ~A"
+              local-nickname package-designator actual-package))
+    (sys::%add-package-local-nickname local-nickname actual-package
+                                      package-designator)))

Modified: trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp	Sat Mar  9 05:02:45 2013	(r14430)
+++ trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp	Sun Mar 10 08:52:36 2013	(r14431)
@@ -151,31 +151,29 @@
                       (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)
                     (error ()
                       :oops))))
-      ;; TODO: add continuable errors for this
-      ;; (handler-bind ((error #'continue))
-      ;;   (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
-      ;; (assert (eq (intern "FOO" p2)
-      ;;             (let ((*package* p1))
-      ;;               (intern "FOO" :own-name-as-nickname1))))
+      (handler-bind ((error #'continue))
+        (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
+      (assert (eq (intern "FOO" p2)
+                  (let ((*package* p1))
+                    (intern "FOO" :own-name-as-nickname1))))
       :success)
   :success)
 
 
 
 (deftest pln-own-nickname-as-local-nickname
-  (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
-                                        :nicknames '("OWN-NICKNAME")))
-                      (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
-    (assert (eq :oops
-                (handler-case
-                    (add-package-local-nickname :own-nickname p2 p1)
-                  (error ()
-                    :oops))))
-    ;; TODO: make errors continuable
-    ;; (handler-bind ((error #'continue))
-    ;;   (add-package-local-nickname :own-nickname p2 p1))
-    ;; (assert (eq (intern "FOO" p2)
-    ;;             (let ((*package* p1))
-    ;;               (intern "FOO" :own-nickname))))
-    :success)
+    (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
+                                          :nicknames '("OWN-NICKNAME")))
+                        (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
+      (assert (eq :oops
+                  (handler-case
+                      (ext:add-package-local-nickname :own-nickname p2 p1)
+                    (error ()
+                      :oops))))
+      (handler-bind ((error #'continue))
+        (ext:add-package-local-nickname :own-nickname p2 p1))
+      (assert (eq (intern "FOO" p2)
+                  (let ((*package* p1))
+                    (intern "FOO" :own-nickname))))
+      :success)
   :success)