+ res)
+ (flet ((actual-package-hashtable-size (size)
+ (loop for n of-type fixnum
+ from (logior (truncate size package-rehash-threshold) 1)
+ by 2
+ when (positive-primep n) return n)))
+ (let* ((n (actual-package-hashtable-size size))
+ (size (truncate (* n package-rehash-threshold)))
+ (table (make-array n))
+ (hash (make-array n
+ :element-type '(unsigned-byte 8)
+ :initial-element 0)))
+ (if res
+ (setf (package-hashtable-table res) table
+ (package-hashtable-hash res) hash
+ (package-hashtable-size res) size
+ (package-hashtable-free res) size
+ (package-hashtable-deleted res) 0)
+ (setf res (%make-package-hashtable table hash size)))
+ res)))
+\f
+;;;; package locking operations, built conditionally on :sb-package-locks
+
+#!+sb-package-locks
+(progn
+(defun package-locked-p (package)
+ #!+sb-doc
+ "Returns T when PACKAGE is locked, NIL otherwise. Signals an error
+if PACKAGE doesn't designate a valid package."
+ (package-lock (find-undeleted-package-or-lose package)))
+
+(defun lock-package (package)
+ #!+sb-doc
+ "Locks PACKAGE and returns T. Has no effect if PACKAGE was already
+locked. Signals an error if PACKAGE is not a valid package designator"
+ (setf (package-lock (find-undeleted-package-or-lose package)) t))
+
+(defun unlock-package (package)
+ #!+sb-doc
+ "Unlocks PACKAGE and returns T. Has no effect if PACKAGE was already
+unlocked. Signals an error if PACKAGE is not a valid package designator."
+ (setf (package-lock (find-undeleted-package-or-lose package)) nil)
+ t)
+
+(defun package-implemented-by-list (package)
+ #!+sb-doc
+ "Returns a list containing the implementation packages of
+PACKAGE. Signals an error if PACKAGE is not a valid package designator."
+ (package-%implementation-packages (find-undeleted-package-or-lose package)))
+
+(defun package-implements-list (package)
+ #!+sb-doc
+ "Returns the packages that PACKAGE is an implementation package
+of. Signals an error if PACKAGE is not a valid package designator."
+ (let ((package (find-undeleted-package-or-lose package)))
+ (loop for x in (list-all-packages)
+ when (member package (package-%implementation-packages x))
+ collect x)))
+
+(defun add-implementation-package (packages-to-add
+ &optional (package *package*))
+ #!+sb-doc
+ "Adds PACKAGES-TO-ADD as implementation packages of PACKAGE. Signals
+an error if PACKAGE or any of the PACKAGES-TO-ADD is not a valid
+package designator."
+ (let ((package (find-undeleted-package-or-lose package))
+ (packages-to-add (package-listify packages-to-add)))
+ (setf (package-%implementation-packages package)
+ (union (package-%implementation-packages package)
+ (mapcar #'find-undeleted-package-or-lose packages-to-add)))))
+
+(defun remove-implementation-package (packages-to-remove
+ &optional (package *package*))
+ #!+sb-doc
+ "Removes PACKAGES-TO-REMOVE from the implementation packages of
+PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-REMOVE
+is not a valid package designator."
+ (let ((package (find-undeleted-package-or-lose package))
+ (packages-to-remove (package-listify packages-to-remove)))
+ (setf (package-%implementation-packages package)
+ (nset-difference
+ (package-%implementation-packages package)
+ (mapcar #'find-undeleted-package-or-lose packages-to-remove)))))
+
+(defmacro with-unlocked-packages ((&rest packages) &body forms)
+ #!+sb-doc
+ "Unlocks PACKAGES for the dynamic scope of the body. Signals an
+error if any of PACKAGES is not a valid package designator."
+ (with-unique-names (unlocked-packages)
+ `(let (,unlocked-packages)
+ (unwind-protect
+ (progn
+ (dolist (p ',packages)
+ (when (package-locked-p p)
+ (push p ,unlocked-packages)
+ (unlock-package p)))
+ ,@forms)
+ (dolist (p ,unlocked-packages)
+ (when (find-package p)
+ (lock-package p)))))))
+
+(defun package-lock-violation (package &key (symbol nil symbol-p)
+ format-control format-arguments)
+ (let ((restart :continue)
+ (cl-violation-p (eq package (find-package :common-lisp))))
+ (flet ((error-arguments ()
+ (append (list (if symbol-p
+ 'symbol-package-locked-error
+ 'package-locked-error)
+ :package package
+ :format-control format-control
+ :format-arguments format-arguments)
+ (when symbol-p (list :symbol symbol))
+ (list :references
+ (append '((:sbcl :node "Package Locks"))
+ (when cl-violation-p
+ '((:ansi-cl :section (11 1 2 1 2)))))))))
+ (restart-case
+ (apply #'cerror "Ignore the package lock." (error-arguments))
+ (:ignore-all ()
+ :report "Ignore all package locks in the context of this operation."
+ (setf restart :ignore-all))
+ (:unlock-package ()
+ :report "Unlock the package."
+ (setf restart :unlock-package)))
+ (ecase restart
+ (:continue
+ (pushnew package *ignored-package-locks*))
+ (:ignore-all
+ (setf *ignored-package-locks* t))
+ (:unlock-package
+ (unlock-package package))))))
+
+(defun package-lock-violation-p (package &optional (symbol nil symbolp))
+ ;; KLUDGE: (package-lock package) needs to be before
+ ;; comparison to *package*, since during cold init this gets
+ ;; called before *package* is bound -- but no package should
+ ;; be locked at that point.
+ (and package
+ (package-lock package)
+ ;; In package or implementation package
+ (not (or (eq package *package*)
+ (member *package* (package-%implementation-packages package))))
+ ;; Runtime disabling
+ (not (eq t *ignored-package-locks*))
+ (or (eq :invalid *ignored-package-locks*)
+ (not (member package *ignored-package-locks*)))
+ ;; declarations for symbols
+ (not (and symbolp (member symbol (disabled-package-locks))))))
+
+(defun disabled-package-locks ()
+ (if (boundp 'sb!c::*lexenv*)
+ (sb!c::lexenv-disabled-package-locks sb!c::*lexenv*)
+ sb!c::*disabled-package-locks*))
+
+) ; progn
+
+;;;; more package-locking these are NOPs unless :sb-package-locks is
+;;;; in target features. Cross-compiler NOPs for these are in cross-misc.
+
+;;; The right way to establish a package lock context is
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR, defined in early-package.lisp
+;;;
+;;; Must be used inside the dynamic contour established by
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR
+(defun assert-package-unlocked (package &optional format-control
+ &rest format-arguments)
+ #!-sb-package-locks
+ (declare (ignore format-control format-arguments))
+ #!+sb-package-locks
+ (when (package-lock-violation-p package)
+ (package-lock-violation package
+ :format-control format-control
+ :format-arguments format-arguments))
+ package)
+
+;;; Must be used inside the dynamic contour established by
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR.
+;;;
+;;; FIXME: Maybe we should establish such contours for he toplevel
+;;; and others, so that %set-fdefinition and others could just use
+;;; this.
+(defun assert-symbol-home-package-unlocked (name format)
+ #!-sb-package-locks
+ (declare (ignore format))
+ #!+sb-package-locks
+ (let* ((symbol (etypecase name
+ (symbol name)
+ (list (if (eq 'setf (first name))
+ (second name)
+ ;; Skip (class-predicate foo), etc.
+ ;; FIXME: MOP and package-lock
+ ;; interaction needs to be thought about.
+ (return-from
+ assert-symbol-home-package-unlocked
+ name)))))
+ (package (symbol-package symbol)))
+ (when (package-lock-violation-p package symbol)
+ (package-lock-violation package
+ :symbol symbol
+ :format-control format
+ :format-arguments (list name))))
+ name)
+
projects / sbcl.git / blobdiff