(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)))
(defmacro with-package-names ((names &key) &body body)
`(let ((,names *package-names*))
- (with-locked-hash-table (,names)
+ (with-locked-system-table (,names)
,@body)))
\f
;;;; PACKAGE-HASHTABLE stuff
;;; 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)
(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)))
(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
(cerror "Clobber existing package."
"A package named ~S already exists" name)
(setf clobber t))
- (with-packages ()
+ (with-package-graph ()
;; Check for race, signal the error outside the lock.
(when (and (not clobber) (find-package name))
(go :restart))
(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)))
(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)
;;; 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
(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)))
(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.
projects / sbcl.git / blobdiff