X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefpackage.lisp;h=58600c4252dc7eaa3f0710fd4dfa7963cd037a92;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=e1988d8176dfbfecd952056cb1eddcd5564d5bcf;hpb=1596e9fdeb2265c4a00e441bc8a1dbdc5364afa7;p=sbcl.git

diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp
index e1988d8..58600c4 100644
--- a/src/code/defpackage.lisp
+++ b/src/code/defpackage.lisp
@@ -34,19 +34,21 @@
    following: ~{~&~4T~A~}
    All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
    times."
-  '((:nicknames "{package-name}*")
-    (:size "<integer>")
+  '((:use "{package-name}*")
+    (:export "{symbol-name}*")
+    (:import-from "<package-name> {symbol-name}*")
     (:shadow "{symbol-name}*")
     (:shadowing-import-from "<package-name> {symbol-name}*")
-    (:use "{package-name}*")
-    (:import-from "<package-name> {symbol-name}*")
-    (:intern "{symbol-name}*")
-    (:export "{symbol-name}*")
-    #!+sb-package-locks (:implement "{package-name}*")
+    (:local-nicknames "{local-nickname actual-package-name}*")
     #!+sb-package-locks (:lock "boolean")
-    (:documentation "doc-string"))
+    #!+sb-package-locks (:implement "{package-name}*")
+    (:documentation "doc-string")
+    (:intern "{symbol-name}*")
+    (:size "<integer>")
+    (:nicknames "{package-name}*"))
   '(:size #!+sb-package-locks :lock))
   (let ((nicknames nil)
+        (local-nicknames nil)
         (size nil)
         (shadows nil)
         (shadowing-imports nil)
@@ -69,6 +71,14 @@
       (case (car option)
         (:nicknames
          (setf nicknames (stringify-package-designators (cdr option))))
+        (:local-nicknames
+         (setf local-nicknames
+               (append local-nicknames
+                       (mapcar (lambda (spec)
+                                 (destructuring-bind (nick name) spec
+                                   (cons (stringify-package-designator nick)
+                                         (stringify-package-designator name))))
+                               (cdr option)))))
         (:size
          (cond (size
                 (error 'simple-program-error
@@ -142,7 +152,8 @@
     `(eval-when (:compile-toplevel :load-toplevel :execute)
        (%defpackage ,(stringify-string-designator package) ',nicknames ',size
                     ',shadows ',shadowing-imports ',(if use-p use :default)
-                    ',imports ',interns ',exports ',implement ',lock ',doc
+                    ',imports ',interns ',exports ',implement ',local-nicknames
+                    ',lock ',doc
                     (sb!c:source-location)))))
 
 (defun check-disjoint (&rest args)
@@ -183,91 +194,223 @@
 (defun stringify-package-designators (package-designators)
   (mapcar #'stringify-package-designator package-designators))
 
+(defun import-list-symbols (import-list)
+  (let ((symbols nil))
+    (dolist (import import-list symbols)
+      (destructuring-bind (package-name &rest symbol-names)
+          import
+        (let ((package (find-undeleted-package-or-lose package-name)))
+          (mapcar (lambda (name)
+                    (push (find-or-make-symbol name package) symbols))
+                  symbol-names))))))
+
+(defun use-list-packages (package package-designators)
+  (cond ((listp package-designators)
+         (mapcar #'find-undeleted-package-or-lose package-designators))
+        (package
+         ;; :default for an existing package means preserve the
+         ;; existing use list
+         (package-use-list package))
+        (t
+         ;; :default for a new package is the *default-package-use-list*
+         '#.*default-package-use-list*)))
+
+(defun update-package (package nicknames source-location
+                       shadows shadowing-imports
+                       use
+                       imports interns
+                       exports implement local-nicknames
+                       lock doc-string)
+  (declare #!-sb-package-locks
+           (ignore implement lock))
+  (%enter-new-nicknames package nicknames)
+  ;; 1. :shadow and :shadowing-import-from
+  ;;
+  ;; shadows is a list of strings, shadowing-imports is a list of symbols.
+  (shadow shadows package)
+  (shadowing-import shadowing-imports package)
+  ;; 2. :use
+  ;;
+  ;; use is a list of package objects.
+  (use-package use package)
+  ;; 3. :import-from and :intern
+  ;;
+  ;; imports is a list of symbols. interns is a list of strings.
+  (import imports package)
+  (dolist (intern interns)
+    (intern intern package))
+  ;; 4. :export
+  ;;
+  ;; exports is a list of strings
+  (export (mapcar (lambda (symbol-name) (intern symbol-name package))
+                  exports)
+          package)
+  ;; Everything was created: update metadata
+  (sb!c:with-source-location (source-location)
+    (setf (package-source-location package) source-location))
+  (setf (package-doc-string package) doc-string)
+  #!+sb-package-locks
+  (progn
+    ;; Handle packages this is an implementation package of
+    (dolist (p implement)
+      (add-implementation-package package p))
+    ;; Handle lock
+    (setf (package-lock package) lock))
+  ;; Local nicknames. Throw out the old ones.
+  (setf (package-%local-nicknames package) nil)
+  (dolist (spec local-nicknames)
+    (add-package-local-nickname (car spec) (cdr spec) package))
+  package)
+
+(declaim (type list *on-package-variance*))
+(defvar *on-package-variance* '(:warn t)
+  "Specifies behavior when redefining a package using DEFPACKAGE and the
+definition is in variance with the current state of the package.
+
+The value should be of the form:
+
+  (:WARN [T | packages-names] :ERROR [T | package-names])
+
+specifying which packages get which behaviour -- with T signifying the default unless
+otherwise specified. If default is not specified, :WARN is used.
+
+:WARN keeps as much state as possible and causes SBCL to signal a full warning.
+
+:ERROR causes SBCL to signal an error when the variant DEFPACKAGE form is executed,
+with restarts provided for user to specify what action should be taken.
+
+Example:
+
+  (setf *on-package-variance* '(:warn (:swank :swank-backend) :error t))
+
+specifies to signal a warning if SWANK package is in variance, and an error otherwise.")
+
+(defun note-package-variance (&rest args &key package &allow-other-keys)
+  (let ((pname (package-name package)))
+    (destructuring-bind (&key warn error) *on-package-variance*
+      (let ((what (cond ((and (listp error) (member pname error :test #'string=))
+                         :error)
+                        ((and (listp warn) (member pname warn :test #'string=))
+                         :warn)
+                        ((eq t error)
+                         :error)
+                        (t
+                         :warn))))
+        (ecase what
+          (:error
+           (apply #'error 'sb!kernel::package-at-variance-error args))
+          (:warn
+           (apply #'warn 'sb!kernel::package-at-variance args)))))))
+
+(defun update-package-with-variance (package name nicknames source-location
+                                     shadows shadowing-imports
+                                     use
+                                     imports interns
+                                     exports
+                                     implement local-nicknames
+                                     lock doc-string)
+  (unless (string= (the string (package-name package)) name)
+    (error 'simple-package-error
+           :package name
+           :format-control "~A is a nickname for the package ~A"
+           :format-arguments (list name (package-name name))))
+  (let ((no-longer-shadowed
+          (set-difference (package-%shadowing-symbols package)
+                          (append shadows shadowing-imports)
+                          :test #'string=)))
+    (when no-longer-shadowed
+      (restart-case
+          (let ((*package* (find-package :keyword)))
+            (note-package-variance
+             :format-control "~A also shadows the following symbols:~%  ~S"
+             :format-arguments (list name no-longer-shadowed)
+             :package package))
+        (drop-them ()
+          :report "Stop shadowing them by uninterning them."
+          (dolist (sym no-longer-shadowed)
+            (unintern sym package)))
+        (keep-them ()
+          :report "Keep shadowing them."))))
+  (let ((no-longer-used (set-difference (package-use-list package) use)))
+    (when no-longer-used
+      (restart-case
+          (note-package-variance
+           :format-control "~A also uses the following packages:~%  ~A"
+           :format-arguments (list name (mapcar #'package-name no-longer-used))
+           :package package)
+        (drop-them ()
+          :report "Stop using them."
+          (unuse-package no-longer-used package))
+        (keep-them ()
+          :report "Keep using them."))))
+  (let (old-exports)
+    (do-external-symbols (s package)
+      (push s old-exports))
+    (let ((no-longer-exported (set-difference old-exports exports :test #'string=)))
+     (when no-longer-exported
+       (restart-case
+           (note-package-variance
+            :format-control "~A also exports the following symbols:~%  ~S"
+            :format-arguments (list name no-longer-exported)
+            :package package)
+         (drop-them ()
+           :report "Unexport them."
+           (unexport no-longer-exported package))
+         (keep-them ()
+           :report "Keep exporting them.")))))
+  (let ((old-implements
+          (set-difference (package-implements-list package)
+                          (mapcar #'find-undeleted-package-or-lose implement))))
+    (when old-implements
+      (restart-case
+          (note-package-variance
+           :format-control "~A is also an implementation package for:~% ~{~S~^~%  ~}"
+           :format-arguments (list name old-implements)
+           :package package)
+        (drop-them ()
+          :report "Stop being an implementation package for them."
+          (dolist (p old-implements)
+            (remove-implementation-package package p)))
+        (keep-them ()
+          :report "Keep exporting them."))))
+  (update-package package nicknames source-location
+                  shadows shadowing-imports
+                  use imports interns exports
+                  implement local-nicknames
+                  lock doc-string))
 
 (defun %defpackage (name nicknames size shadows shadowing-imports
-                    use imports interns exports implement lock doc-string
+                    use imports interns exports implement local-nicknames
+                    lock doc-string
                     source-location)
   (declare (type simple-string name)
            (type list nicknames shadows shadowing-imports
                  imports interns exports)
            (type (or list (member :default)) use)
-           (type (or simple-string null) doc-string)
-           #!-sb-package-locks
-           (ignore implement lock))
-  (let ((package (or (find-package name)
-                     (progn
-                       (when (eq use :default)
-                         (setf use '#.*default-package-use-list*))
-                       (make-package name
-                                     :use nil
-                                     :internal-symbols (or size 10)
-                                     :external-symbols (length exports))))))
-    (sb!c:with-source-location (source-location)
-      (setf (package-source-location package) source-location))
-    (unless (string= (the string (package-name package)) name)
-      (error 'simple-package-error
-             :package name
-             :format-control "~A is a nickname for the package ~A"
-             :format-arguments (list name (package-name name))))
-    (enter-new-nicknames package nicknames)
-    ;; Handle shadows and shadowing-imports.
-    (let ((old-shadows (package-%shadowing-symbols package)))
-      (shadow shadows package)
-      (dolist (sym-name shadows)
-        (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
-      (dolist (simports-from shadowing-imports)
-        (let ((other-package (find-undeleted-package-or-lose
-                              (car simports-from))))
-          (dolist (sym-name (cdr simports-from))
-            (let ((sym (find-or-make-symbol sym-name other-package)))
-              (shadowing-import sym package)
-              (setf old-shadows (remove sym old-shadows))))))
-      (when old-shadows
-        (warn 'package-at-variance
-              :format-control "~A also shadows the following symbols:~%  ~S"
-              :format-arguments (list name old-shadows))))
-    ;; Handle USE.
-    (unless (eq use :default)
-      (let ((old-use-list (package-use-list package))
-            (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
-        (use-package (set-difference new-use-list old-use-list) package)
-        (let ((laterize (set-difference old-use-list new-use-list)))
-          (when laterize
-            (unuse-package laterize package)
-            (warn 'package-at-variance
-                  :format-control "~A used to use the following packages:~%  ~S"
-                  :format-arguments (list name laterize))))))
-    ;; Handle IMPORT and INTERN.
-    (dolist (sym-name interns)
-      (intern sym-name package))
-    (dolist (imports-from imports)
-      (let ((other-package (find-undeleted-package-or-lose (car
-                                                            imports-from))))
-        (dolist (sym-name (cdr imports-from))
-          (import (list (find-or-make-symbol sym-name other-package))
-                  package))))
-    ;; Handle exports.
-    (let ((old-exports nil)
-          (exports (mapcar (lambda (sym-name) (intern sym-name package))
-                           exports)))
-      (do-external-symbols (sym package)
-        (push sym old-exports))
-      (export exports package)
-      (let ((diff (set-difference old-exports exports)))
-        (when diff
-          (warn 'package-at-variance
-                :format-control "~A also exports the following symbols:~%  ~S"
-                :format-arguments (list name diff)))))
-    #!+sb-package-locks
-    (progn
-      ;; Handle packages this is an implementation package of
-      (dolist (p implement)
-        (add-implementation-package package p))
-      ;; Handle lock
-      (setf (package-lock package) lock))
-    ;; Handle documentation.
-    (setf (package-doc-string package) doc-string)
-    package))
+           (type (or simple-string null) doc-string))
+  (with-package-graph ()
+    (let* ((existing-package (find-package name))
+           (use (use-list-packages existing-package use))
+           (shadowing-imports (import-list-symbols shadowing-imports))
+           (imports (import-list-symbols imports)))
+      (if existing-package
+          (update-package-with-variance existing-package name
+                                        nicknames source-location
+                                        shadows shadowing-imports
+                                        use imports interns exports
+                                        implement local-nicknames
+                                        lock doc-string)
+          (let ((package (make-package name
+                                       :use nil
+                                       :internal-symbols (or size 10)
+                                       :external-symbols (length exports))))
+            (update-package package
+                            nicknames
+                            source-location
+                            shadows shadowing-imports
+                            use imports interns exports
+                            implement local-nicknames
+                            lock doc-string))))))
 
 (defun find-or-make-symbol (name package)
   (multiple-value-bind (symbol how) (find-symbol name package)