X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=6a56f8e466d0722bbb2bff67b2f8e33296c2e6b0;hb=b0b221088b889b6d3ae67e551b93fe1a6cfec878;hp=4569a11a41757114128fad39d382990ea3a6fcd2;hpb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;p=sbcl.git

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 4569a11..6a56f8e 100644
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -61,9 +61,6 @@
   (declare (function function))
   ;; FIXME: Since name conflicts can be signalled while holding the
   ;; mutex, user code can be run leading to lock ordering problems.
-  ;;
-  ;; This used to be a spinlock, but there it can be held for a long
-  ;; time while the debugger waits for user input.
   (sb!thread:with-recursive-lock (*package-graph-lock*)
     (funcall function)))
 
@@ -338,12 +335,135 @@ error if any of PACKAGES is not a valid package designator."
 ;;; most other operations, are unspecified for deleted packages. We
 ;;; just do the easy thing and signal errors in that case.
 (macrolet ((def (ext real)
-             `(defun ,ext (x) (,real (find-undeleted-package-or-lose x)))))
+             `(defun ,ext (package-designator)
+                (,real (find-undeleted-package-or-lose package-designator)))))
   (def package-nicknames package-%nicknames)
   (def package-use-list package-%use-list)
   (def package-used-by-list package-%used-by-list)
   (def package-shadowing-symbols package-%shadowing-symbols))
 
+(defun package-local-nicknames (package-designator)
+  "Returns an alist of \(local-nickname . actual-package) describing the
+nicknames local to the designated package.
+
+When in the designated package, calls to FIND-PACKAGE with the any of the
+local-nicknames will return the corresponding actual-package instead. This
+also affects all implied calls to FIND-PACKAGE, including those performed by
+the reader.
+
+When printing a package prefix for a symbol with a package local nickname, the
+local nickname is used instead of the real name in order to preserve
+read/print consistency.
+
+See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCALLY-NICKNAMED-BY,
+REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES.
+
+Experimental: interface subject to change."
+  (copy-tree
+   (package-%local-nicknames
+    (find-undeleted-package-or-lose package-designator))))
+
+(defun package-locally-nicknamed-by (package-designator)
+  "Returns a list of packages which have a local nickname for the designated
+package.
+
+See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES,
+REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES.
+
+Experimental: interface subject to change."
+  (copy-list
+   (package-%locally-nicknamed-by
+    (find-undeleted-package-or-lose package-designator))))
+
+(defun add-package-local-nickname (local-nickname actual-package
+                                   &optional (package-designator (sane-package)))
+  "Adds LOCAL-NICKNAME for ACTUAL-PACKAGE in the designated package, defaulting
+to current package. LOCAL-NICKNAME must be a string designator, and
+ACTUAL-PACKAGE must be a package designator.
+
+Returns the designated package.
+
+Signals a continuable error if LOCAL-NICKNAME is already a package local
+nickname for a different package, or if LOCAL-NICKNAME is one of \"CL\",
+\"COMMON-LISP\", or, \"KEYWORD\".
+
+When in the designated package, calls to FIND-PACKAGE with the LOCAL-NICKNAME
+will return the package the designated ACTUAL-PACKAGE instead. This also
+affects all implied calls to FIND-PACKAGE, including those performed by the
+reader.
+
+When printing a package prefix for a symbol with a package local nickname,
+local nickname is used instead of the real name in order to preserve
+read/print consistency.
+
+See also: PACKAGE-LOCAL-NICKNAMES, PACKAGE-LOCALLY-NICKNAMED-BY,
+REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES.
+
+Experimental: interface subject to change."
+  (let* ((nick (string local-nickname))
+         (actual (find-package-using-package actual-package nil))
+         (package (find-undeleted-package-or-lose package-designator))
+         (existing (package-%local-nicknames package))
+         (cell (assoc nick existing :test #'string=)))
+    (unless (package-name actual)
+      (error "Cannot add ~A as local nickname for a deleted package: ~S"
+             nick actual))
+    (with-single-package-locked-error
+        (:package package "adding ~A as a local nickname for ~A"
+                  nick actual))
+    (when (member nick '("CL" "COMMON-LISP" "KEYWORD") :test #'string=)
+      (cerror "Continue, use it as local nickname anyways."
+              "Attempt to use ~A as a package local nickname." nick))
+    (when (and cell (neq actual (cdr cell)))
+      (restart-case
+          (error "~@<Cannot add ~A as local nickname for ~A in ~S: already nickname for ~A.~:@>"
+                 nick actual package (cdr cell))
+        (keep-old ()
+          :report (lambda (s)
+                    (format s "Keep ~A as local nicname for ~A."
+                            nick (cdr cell))))
+        (change-nick ()
+          :report (lambda (s)
+                    (format s "Use ~A as local nickname for ~A instead."
+                            nick actual))
+          (let ((old (cdr cell)))
+            (with-package-graph ()
+              (setf (package-%locally-nicknamed-by old)
+                    (delete package (package-%locally-nicknamed-by old)))
+              (push package (package-%locally-nicknamed-by actual))
+              (setf (cdr cell) actual)))))
+      (return-from add-package-local-nickname package))
+    (unless cell
+      (with-package-graph ()
+        (push (cons nick actual) (package-%local-nicknames package))
+        (push package (package-%locally-nicknamed-by actual))))
+    package))
+
+(defun remove-package-local-nickname (old-nickname
+                                      &optional (package-designator (sane-package)))
+  "If the designated package had OLD-NICKNAME as a local nickname for
+another package, it is removed. Returns true if the nickname existed and was
+removed, and NIL otherwise.
+
+See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES,
+PACKAGE-LOCALLY-NICKNAMED-BY, and the DEFPACKAGE option :LOCAL-NICKNAMES.
+
+Experimental: interface subject to change."
+  (let* ((nick (string old-nickname))
+         (package (find-undeleted-package-or-lose package-designator))
+         (existing (package-%local-nicknames package))
+         (cell (assoc nick existing :test #'string=)))
+    (when cell
+      (with-single-package-locked-error
+          (:package package "removing local nickname ~A for ~A"
+                    nick (cdr cell)))
+      (with-package-graph ()
+        (let ((old (cdr cell)))
+          (setf (package-%local-nicknames package) (delete cell existing))
+          (setf (package-%locally-nicknamed-by old)
+                (delete package (package-%locally-nicknamed-by old)))))
+      t)))
+
 (defun %package-hashtable-symbol-count (table)
   (let ((size (the fixnum
                 (- (package-hashtable-size table)
@@ -385,9 +505,37 @@ error if any of PACKAGES is not a valid package designator."
    (find-restart-or-control-error 'debootstrap-package condition)))
 
 (defun find-package (package-designator)
+  "If PACKAGE-DESIGNATOR is a package, it is returned. Otherwise PACKAGE-DESIGNATOR
+must be a string designator, in which case the package it names is located and returned.
+
+As an SBCL extension, the current package may effect the way a package name is
+resolved: if the current package has local nicknames specified, package names
+matching those are resolved to the packages associated with them instead.
+
+Example:
+
+  (defpackage :a)
+  (defpackage :example (:use :cl) (:local-nicknames (:x :a)))
+  (let ((*package* (find-package :example)))
+    (find-package :x)) => #<PACKAGE A>
+
+See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES,
+REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES."
+  (find-package-using-package package-designator
+                              (when (boundp '*package*)
+                                *package*)))
+
+;;; This is undocumented and unexported for now, but the idea is that by
+;;; making this a generic function then packages with custom package classes
+;;; could hook into this to provide their own resolution.
+(defun find-package-using-package (package-designator base)
   (flet ((find-package-from-string (string)
            (declare (type string string))
-           (let ((packageoid (gethash string *package-names*)))
+           (let* ((nicknames (when base
+                               (package-%local-nicknames base)))
+                  (nicknamed (when nicknames
+                               (cdr (assoc string nicknames :test #'string=))))
+                  (packageoid (or nicknamed (gethash string *package-names*))))
              (when (and (null packageoid)
                         (not *in-package-init*) ; KLUDGE
                         (let ((mismatch (mismatch "SB!" string)))
@@ -395,7 +543,7 @@ error if any of PACKAGES is not a valid package designator."
                (restart-case
                    (signal 'bootstrap-package-not-found :name string)
                  (debootstrap-package ()
-                   (return-from find-package
+                   (return-from find-package-using-package
                      (if (string= string "SB!XC")
                          (find-package "COMMON-LISP")
                          (find-package
@@ -708,6 +856,8 @@ implementation it is ~S." *default-package-use-list*)
                                               (mapcar #'package-name use-list))))
                     (dolist (p use-list)
                       (unuse-package package p))))
+                (dolist (p (package-implements-list package))
+                  (remove-implementation-package package p))
                 (with-package-graph ()
                   ;; Check for races, restart if necessary.
                   (let ((package2 (find-package package-designator)))
@@ -715,6 +865,15 @@ implementation it is ~S." *default-package-use-list*)
                       (go :restart)))
                   (dolist (used (package-use-list package))
                     (unuse-package used package))
+                  (dolist (namer (package-%locally-nicknamed-by package))
+                    (setf (package-%local-nicknames namer)
+                          (delete package (package-%local-nicknames namer) :key #'cdr)))
+                  (setf (package-%locally-nicknamed-by package) nil)
+                  (dolist (cell (package-%local-nicknames package))
+                    (let ((actual (cdr cell)))
+                      (setf (package-%locally-nicknamed-by actual)
+                            (delete package (package-%locally-nicknamed-by actual)))))
+                  (setf (package-%local-nicknames package) nil)
                   (do-symbols (sym package)
                     (unintern sym package))
                   (with-package-names (names)
@@ -779,7 +938,7 @@ implementation it is ~S." *default-package-use-list*)
 
 ;;; If the symbol named by the first LENGTH characters of NAME doesn't exist,
 ;;; then create it, special-casing the keyword package.
-(defun intern* (name length package)
+(defun intern* (name length package &key no-copy)
   (declare (simple-string name))
   (multiple-value-bind (symbol where) (find-symbol* name length package)
     (cond (where
@@ -793,7 +952,18 @@ implementation it is ~S." *default-package-use-list*)
              (setf (values symbol where) (find-symbol* name length package))
              (if where
                  (values symbol where)
-                 (let ((symbol-name (subseq name 0 length)))
+                 (let ((symbol-name (cond (no-copy
+                                           (aver (= (length name) length))
+                                           name)
+                                          (t
+                                           ;; This so that SUBSEQ is inlined,
+                                           ;; because we need it fixed for cold init.
+                                           (string-dispatch
+                                               ((simple-array base-char (*))
+                                                (simple-array character (*)))
+                                               name
+                                             (declare (optimize speed))
+                                             (subseq name 0 length))))))
                    (with-single-package-locked-error
                        (:package package "interning ~A" symbol-name)
                      (let ((symbol (make-symbol symbol-name)))
@@ -885,56 +1055,107 @@ implementation it is ~S." *default-package-use-list*)
              (name-conflict-symbols c)))))
 
 (defun name-conflict (package function datum &rest symbols)
-  (restart-case
-      (error 'name-conflict :package package :symbols symbols
-             :function function :datum datum)
-    (resolve-conflict (chosen-symbol)
-      :report "Resolve conflict."
-      :interactive
-      (lambda ()
-        (let* ((len (length symbols))
-               (nlen (length (write-to-string len :base 10)))
-               (*print-pretty* t))
-          (format *query-io* "~&~@<Select a symbol to be made accessible in ~
+  (flet ((importp (c)
+           (declare (ignore c))
+           (eq 'import function))
+         (use-or-export-p (c)
+           (declare (ignore c))
+           (or (eq 'use-package function)
+               (eq 'export function)))
+         (old-symbol ()
+           (car (remove datum symbols))))
+    (let ((pname (package-name package)))
+      (restart-case
+          (error 'name-conflict :package package :symbols symbols
+                                :function function :datum datum)
+        ;; USE-PACKAGE and EXPORT
+        (keep-old ()
+          :report (lambda (s)
+                    (ecase function
+                      (export
+                       (format s "Keep ~S accessible in ~A (shadowing ~S)."
+                               (old-symbol) pname datum))
+                      (use-package
+                       (format s "Keep symbols already accessible ~A (shadowing others)."
+                               pname))))
+          :test use-or-export-p
+          (dolist (s (remove-duplicates symbols :test #'string=))
+            (shadow (symbol-name s) package)))
+        (take-new ()
+          :report (lambda (s)
+                    (ecase function
+                      (export
+                       (format s "Make ~S accessible in ~A (uninterning ~S)."
+                               datum pname (old-symbol)))
+                      (use-package
+                       (format s "Make newly exposed symbols accessible in ~A, ~
+                                  uninterning old ones."
+                               pname))))
+          :test use-or-export-p
+          (dolist (s symbols)
+            (when (eq s (find-symbol (symbol-name s) package))
+              (unintern s package))))
+        ;; IMPORT
+        (shadowing-import-it ()
+          :report (lambda (s)
+                    (format s "Shadowing-import ~S, uninterning ~S."
+                            datum (old-symbol)))
+          :test importp
+          (shadowing-import datum package))
+        (dont-import-it ()
+          :report (lambda (s)
+                    (format s "Don't import ~S, keeping ~S."
+                            datum
+                            (car (remove datum symbols))))
+          :test importp)
+        ;; General case. This is exposed via SB-EXT.
+        (resolve-conflict (chosen-symbol)
+          :report "Resolve conflict."
+          :interactive
+          (lambda ()
+            (let* ((len (length symbols))
+                   (nlen (length (write-to-string len :base 10)))
+                   (*print-pretty* t))
+              (format *query-io* "~&~@<Select a symbol to be made accessible in ~
                               package ~A:~2I~@:_~{~{~V,' D. ~
                               ~/sb-impl::print-symbol-with-prefix/~}~@:_~}~
                               ~@:>"
-                (package-name package)
-                (loop for s in symbols
-                      for i upfrom 1
-                      collect (list nlen i s)))
-          (loop
-           (format *query-io* "~&Enter an integer (between 1 and ~D): " len)
-           (finish-output *query-io*)
-           (let ((i (parse-integer (read-line *query-io*) :junk-allowed t)))
-             (when (and i (<= 1 i len))
-               (return (list (nth (1- i) symbols))))))))
-      (multiple-value-bind (package-symbol status)
-          (find-symbol (symbol-name chosen-symbol) package)
-        (let* ((accessiblep status)     ; never NIL here
-               (presentp (and accessiblep
-                              (not (eq :inherited status)))))
-          (ecase function
-            ((unintern)
-             (if presentp
-                 (if (eq package-symbol chosen-symbol)
-                     (shadow (list package-symbol) package)
-                     (shadowing-import (list chosen-symbol) package))
-                 (shadowing-import (list chosen-symbol) package)))
-            ((use-package export)
-             (if presentp
-                 (if (eq package-symbol chosen-symbol)
-                     (shadow (list package-symbol) package) ; CLHS 11.1.1.2.5
-                     (if (eq (symbol-package package-symbol) package)
-                         (unintern package-symbol package) ; CLHS 11.1.1.2.5
-                         (shadowing-import (list chosen-symbol) package)))
-                 (shadowing-import (list chosen-symbol) package)))
-            ((import)
-             (if presentp
-                 (if (eq package-symbol chosen-symbol)
-                     nil                ; re-importing the same symbol
-                     (shadowing-import (list chosen-symbol) package))
-                 (shadowing-import (list chosen-symbol) package)))))))))
+                      (package-name package)
+                      (loop for s in symbols
+                            for i upfrom 1
+                            collect (list nlen i s)))
+              (loop
+                (format *query-io* "~&Enter an integer (between 1 and ~D): " len)
+                (finish-output *query-io*)
+                (let ((i (parse-integer (read-line *query-io*) :junk-allowed t)))
+                  (when (and i (<= 1 i len))
+                    (return (list (nth (1- i) symbols))))))))
+          (multiple-value-bind (package-symbol status)
+              (find-symbol (symbol-name chosen-symbol) package)
+            (let* ((accessiblep status)     ; never NIL here
+                   (presentp (and accessiblep
+                                  (not (eq :inherited status)))))
+              (ecase function
+                ((unintern)
+                 (if presentp
+                     (if (eq package-symbol chosen-symbol)
+                         (shadow (list package-symbol) package)
+                         (shadowing-import (list chosen-symbol) package))
+                     (shadowing-import (list chosen-symbol) package)))
+                ((use-package export)
+                 (if presentp
+                     (if (eq package-symbol chosen-symbol)
+                         (shadow (list package-symbol) package) ; CLHS 11.1.1.2.5
+                         (if (eq (symbol-package package-symbol) package)
+                             (unintern package-symbol package) ; CLHS 11.1.1.2.5
+                             (shadowing-import (list chosen-symbol) package)))
+                     (shadowing-import (list chosen-symbol) package)))
+                ((import)
+                 (if presentp
+                     (if (eq package-symbol chosen-symbol)
+                         nil                ; re-importing the same symbol
+                         (shadowing-import (list chosen-symbol) package))
+                     (shadowing-import (list chosen-symbol) package)))))))))))
 
 ;;; If we are uninterning a shadowing symbol, then a name conflict can
 ;;; result, otherwise just nuke the symbol.