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

[rschlatte at common-lisp.net]

Author: rschlatte
Date: Sun Mar 10 09:07:43 2013
New Revision: 14432

Log:
Some more package-local-nickname error checking in defpackage

Modified:
   trunk/abcl/src/org/armedbear/lisp/defpackage.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/defpackage.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/defpackage.lisp	Sun Mar 10 08:52:36 2013	(r14431)
+++ trunk/abcl/src/org/armedbear/lisp/defpackage.lisp	Sun Mar 10 09:07:43 2013	(r14432)
@@ -129,14 +129,20 @@
            (unless (= (length nickdecl) 2)
              (error 'program-error "Malformed local nickname declaration ~A"
                     nickdecl))
-           (let ((nickname (string (first nickdecl)))
+           (let ((local-nickname (string (first nickdecl)))
                  (package-name (designated-package-name (second nickdecl))))
-             (when (member nickname '("CL" "COMMON-LISP" "KEYWORD")
-                           :test #'string-equal)
+             (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD")
+                           :test #'string=)
                (cerror "Continue anyway"
                        (format nil "Trying to define a local nickname for package ~A"
-                               package-name)))
-             (push (list nickname package-name) local-nicknames))))
+                               local-nickname)))
+             (when (member local-nickname (list* package nicknames)
+                           :test #'string=)
+               (cerror "Continue anyway"
+                       "Trying to override the name or a nickname (~A) ~
+                        with a local nickname for another package ~A"
+                       local-nickname package-name))
+             (push (list local-nickname package-name) local-nicknames))))
         (t
          (error 'program-error "bad DEFPACKAGE option: ~S" option))))
     (check-disjoint `(:intern , at interns) `(:export  , at exports))