Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27385/src/code
Modified Files:
cold-init.lisp condition.lisp cross-misc.lisp debug-int.lisp
defboot.lisp defpackage.lisp defstruct.lisp early-fasl.lisp
early-pprint.lisp early-setf.lisp eval.lisp fdefinition.lisp
fop.lisp macros.lisp package.lisp profile.lisp symbol.lisp
target-package.lisp
Added Files:
early-package.lisp
Log Message:
0.8.12.7: Merge package locks, AKA "what can go wrong with a 3783 line patch?"
... Controlled by the presence of :sb-package-locks in target
features.
... This builds both with and without package locks on both
x86 Linux and SunOS Sparc, with both CMUCL and SBCL
as host -- so chances are it should build elsewhere as
well.
... Remaining TODO: turn package locking errors from lexical
constructs to program errors in the produced code, fix
the bits in SBCL that hit host's SBCL-tyle package locks
(relevant FIXME is in src/cold/shared.lisp).
--- NEW FILE: early-package.lisp ---
;;;; Package (locking) related macros needed on the target before most
;;;; of the package machinery is available.
;;;;
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!IMPL")
(!begin-collecting-cold-init-forms)
;;; Unbound outside package lock context, inside either list of
;;; packages for which locks are ignored, T when locks for
;;; all packages are ignored, and :invalid outside package-lock
;;; context. FIXME: This needs to be rebound for each thread.
(defvar *ignored-package-locks*
(error "*IGNORED-PACKAGE-LOCKS* should be set up in cold-init."))
(!cold-init-forms
(setf *ignored-package-locks* :invalid))
(defmacro with-single-package-locked-error ((&optional kind thing &rest format)
&body body)
#!-sb-package-locks (declare (ignore kind thing format))
#!-sb-package-locks
`(progn ,@body)
#!+sb-package-locks
(with-unique-names (topmost)
`(progn
(/show0 ,(first format))
(let ((,topmost nil))
;; We use assignment and conditional restoration instead of
;; dynamic binding because we want the ignored locks
;; to propagate to the topmost context.
(when (eq :invalid *ignored-package-locks*)
(setf *ignored-package-locks* nil
,topmost t))
(unwind-protect
(progn
,@(ecase kind
(:symbol
`((assert-symbol-home-package-unlocked ,thing ,@format)))
(:package
`((assert-package-unlocked
(find-undeleted-package-or-lose ,thing) ,@format)))
((nil)
`()))
,@body)
(when ,topmost
(setf *ignored-package-locks* :invalid)))))))
(defmacro without-package-locks (&body body)
#!+sb-doc
"Ignores all runtime package lock violations during the execution of
body. Body can begin with declarations."
#!-sb-package-locks
`(progn ,@body)
#!+sb-package-locks
`(let ((*ignored-package-locks* t))
,@body))
(!defun-from-collected-cold-init-forms !early-package-cold-init)
Index: cold-init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- cold-init.lisp 8 Apr 2004 13:26:03 -0000 1.46
+++ cold-init.lisp 29 Jun 2004 08:50:58 -0000 1.47
@@ -111,6 +111,7 @@
;; this to be initialized, so we initialize it right away.
(show-and-call !random-cold-init)
+ (show-and-call !early-package-cold-init)
(show-and-call !package-cold-init)
;; All sorts of things need INFO and/or (SETF INFO).
Index: condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- condition.lisp 26 Jun 2004 17:28:11 -0000 1.45
+++ condition.lisp 29 Jun 2004 08:50:58 -0000 1.46
@@ -274,47 +274,49 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %compiler-define-condition (name direct-supers layout
all-readers all-writers)
- (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
- (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
- (multiple-value-bind (class old-layout)
- (insured-find-classoid name
- #'condition-classoid-p
- #'make-condition-classoid)
- (setf (layout-classoid layout) class)
- (setf (classoid-direct-superclasses class)
- (mapcar #'find-classoid direct-supers))
- (cond ((not old-layout)
- (register-layout layout))
- ((not *type-system-initialized*)
- (setf (layout-classoid old-layout) class)
- (setq layout old-layout)
- (unless (eq (classoid-layout class) layout)
+ (with-single-package-locked-error
+ (:symbol name "defining ~A as a condition")
+ (sb!xc:proclaim `(ftype (function (t) t) ,@all-readers))
+ (sb!xc:proclaim `(ftype (function (t t) t) ,@all-writers))
+ (multiple-value-bind (class old-layout)
+ (insured-find-classoid name
+ #'condition-classoid-p
+ #'make-condition-classoid)
+ (setf (layout-classoid layout) class)
+ (setf (classoid-direct-superclasses class)
+ (mapcar #'find-classoid direct-supers))
+ (cond ((not old-layout)
+ (register-layout layout))
+ ((not *type-system-initialized*)
+ (setf (layout-classoid old-layout) class)
+ (setq layout old-layout)
+ (unless (eq (classoid-layout class) layout)
+ (register-layout layout)))
+ ((redefine-layout-warning "current"
+ old-layout
+ "new"
+ (layout-length layout)
+ (layout-inherits layout)
+ (layout-depthoid layout))
+ (register-layout layout :invalidate t))
+ ((not (classoid-layout class))
(register-layout layout)))
- ((redefine-layout-warning "current"
- old-layout
- "new"
- (layout-length layout)
- (layout-inherits layout)
- (layout-depthoid layout))
- (register-layout layout :invalidate t))
- ((not (classoid-layout class))
- (register-layout layout)))
-
- (setf (layout-info layout)
- (locally
- ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
- ;; names which creates fast but non-cold-loadable, non-compact
- ;; code. In this context, we'd rather have compact, cold-loadable
- ;; code. -- WHN 19990928
- (declare (notinline find-classoid))
- (layout-info (classoid-layout (find-classoid 'condition)))))
-
- (setf (find-classoid name) class)
-
- ;; Initialize CPL slot.
- (setf (condition-classoid-cpl class)
- (remove-if-not #'condition-classoid-p
- (std-compute-class-precedence-list class))))
+
+ (setf (layout-info layout)
+ (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
+ ;; names which creates fast but non-cold-loadable, non-compact
+ ;; code. In this context, we'd rather have compact, cold-loadable
+ ;; code. -- WHN 19990928
+ (declare (notinline find-classoid))
+ (layout-info (classoid-layout (find-classoid 'condition)))))
+
+ (setf (find-classoid name) class)
+
+ ;; Initialize CPL slot.
+ (setf (condition-classoid-cpl class)
+ (remove-if-not #'condition-classoid-p
+ (std-compute-class-precedence-list class)))))
(values))
) ; EVAL-WHEN
@@ -369,49 +371,51 @@
(defun %define-condition (name parent-types layout slots documentation
report default-initargs all-readers all-writers)
- (%compiler-define-condition name parent-types layout all-readers all-writers)
- (let ((class (find-classoid name)))
- (setf (condition-classoid-slots class) slots)
- (setf (condition-classoid-report class) report)
- (setf (condition-classoid-default-initargs class) default-initargs)
- (setf (fdocumentation name 'type) documentation)
-
- (dolist (slot slots)
-
- ;; Set up reader and writer functions.
- (let ((slot-name (condition-slot-name slot)))
- (dolist (reader (condition-slot-readers slot))
- (install-condition-slot-reader reader name slot-name))
- (dolist (writer (condition-slot-writers slot))
- (install-condition-slot-writer writer name slot-name))))
-
- ;; Compute effective slots and set up the class and hairy slots
- ;; (subsets of the effective slots.)
- (let ((eslots (compute-effective-slots class))
- (e-def-initargs
- (reduce #'append
- (mapcar #'condition-classoid-default-initargs
+ (with-single-package-locked-error
+ (:symbol name "defining ~A as a condition")
+ (%compiler-define-condition name parent-types layout all-readers all-writers)
+ (let ((class (find-classoid name)))
+ (setf (condition-classoid-slots class) slots)
+ (setf (condition-classoid-report class) report)
+ (setf (condition-classoid-default-initargs class) default-initargs)
+ (setf (fdocumentation name 'type) documentation)
+
+ (dolist (slot slots)
+
+ ;; Set up reader and writer functions.
+ (let ((slot-name (condition-slot-name slot)))
+ (dolist (reader (condition-slot-readers slot))
+ (install-condition-slot-reader reader name slot-name))
+ (dolist (writer (condition-slot-writers slot))
+ (install-condition-slot-writer writer name slot-name))))
+
+ ;; Compute effective slots and set up the class and hairy slots
+ ;; (subsets of the effective slots.)
+ (let ((eslots (compute-effective-slots class))
+ (e-def-initargs
+ (reduce #'append
+ (mapcar #'condition-classoid-default-initargs
(condition-classoid-cpl class)))))
- (dolist (slot eslots)
- (ecase (condition-slot-allocation slot)
- (:class
- (unless (condition-slot-cell slot)
- (setf (condition-slot-cell slot)
- (list (if (condition-slot-initform-p slot)
- (let ((initform (condition-slot-initform slot)))
- (if (functionp initform)
- (funcall initform)
- initform))
- *empty-condition-slot*))))
- (push slot (condition-classoid-class-slots class)))
- ((:instance nil)
- (setf (condition-slot-allocation slot) :instance)
- (when (or (functionp (condition-slot-initform slot))
- (dolist (initarg (condition-slot-initargs slot) nil)
- (when (functionp (getf e-def-initargs initarg))
- (return t))))
- (push slot (condition-classoid-hairy-slots class))))))))
- name)
+ (dolist (slot eslots)
+ (ecase (condition-slot-allocation slot)
+ (:class
+ (unless (condition-slot-cell slot)
+ (setf (condition-slot-cell slot)
+ (list (if (condition-slot-initform-p slot)
+ (let ((initform (condition-slot-initform slot)))
+ (if (functionp initform)
+ (funcall initform)
+ initform))
+ *empty-condition-slot*))))
+ (push slot (condition-classoid-class-slots class)))
+ ((:instance nil)
+ (setf (condition-slot-allocation slot) :instance)
+ (when (or (functionp (condition-slot-initform slot))
+ (dolist (initarg (condition-slot-initargs slot) nil)
+ (when (functionp (getf e-def-initargs initarg))
+ (return t))))
+ (push slot (condition-classoid-hairy-slots class))))))))
+ name))
(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
&body options)
@@ -886,6 +890,50 @@
(define-condition extension-failure (reference-condition simple-error)
())
+
+#!+sb-package-locks
+(progn
+
+(define-condition package-lock-violation (reference-condition package-error)
+ ((format-control :initform nil :initarg :format-control
+ :reader package-error-format-control)
+ (format-arguments :initform nil :initarg :format-arguments
+ :reader package-error-format-arguments))
+ (:report
+ (lambda (condition stream)
+ (let ((control (package-error-format-control condition))
+ (*print-pretty* nil))
+ (if control
+ (format stream "Package lock on ~S violated when ~?."
+ (package-error-package condition)
+ control
+ (package-error-format-arguments condition))
+ (format stream "Package lock on ~S violated."
+ (package-error-package condition))))))
+ ;; no :default-initargs -- reference-stuff provided by the
+ ;; signalling form in target-package.lisp
+ #!+sb-doc
+ (:documentation
+ "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled
+when a package-lock is violated."))
+
+(define-condition package-locked-error (package-lock-violation) ()
+ #!+sb-doc
+ (:documentation
+ "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
+signalled when an operation on a package violates a package lock."))
+
+
+(define-condition symbol-package-locked-error (package-lock-violation)
+ ((symbol :initarg :symbol :reader package-locked-error-symbol))
+ #!+sb-doc
+ (:documentation
+ "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is
+signalled when an operation on a symbol violates a package lock. The
+symbol that caused the violation is accessed by the function
+SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
+
+) ; progn
;;;; various other (not specified by ANSI) CONDITIONs
;;;;
Index: cross-misc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cross-misc.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- cross-misc.lisp 9 Oct 2003 19:55:09 -0000 1.14
+++ cross-misc.lisp 29 Jun 2004 08:50:58 -0000 1.15
@@ -151,3 +151,34 @@
#!+alpha
(defun sb!vm::ash-left-mod64 (integer amount)
(ldb (byte 64 0) (ash integer amount)))
+
+;;; package locking nops for the cross-compiler
+
+(defmacro without-package-locks (&body body)
+ `(progn ,@body))
+
+(defmacro with-single-package-locked-error ((&optional kind thing &rest format)
+ &body body)
+ (declare (ignore kind thing format))
+ `(progn ,@body))
+
+(defmacro with-deferred-package-lock-violations (&body body)
+ `(flet ((prepend-package-lock-violations (forms) forms)
+ (package-lock-violations () nil))
+ ,@body))
+
+(defun assert-package-unlocked (package &optional control &rest args)
+ (declare (ignore control args))
+ package)
+
+(defun assert-symbol-home-package-unlocked (name format &key continuablep)
+ (declare (ignore format continuablep))
+ name)
+
+(deftype package-lock-violation () nil)
+
+(deftype package-locked-error () nil)
+
+(deftype symbol-package-locked-error () nil)
+
+(declaim (declaration enable-package-locks disable-package-locks))
Index: debug-int.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/debug-int.lisp,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -d -r1.78 -r1.79
--- debug-int.lisp 28 Jun 2004 16:27:30 -0000 1.78
+++ debug-int.lisp 29 Jun 2004 08:50:58 -0000 1.79
@@ -1578,24 +1578,25 @@
(let* ((len (length vars))
(width (length (format nil "~W" (1- len)))))
(dotimes (i len)
- (setf (compiled-debug-var-symbol (svref vars i))
- (intern (format nil "ARG-~V,'0D" width i)
- ;; KLUDGE: It's somewhat nasty to have a bare
- ;; package name string here. It would be
- ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
- ;; instead, since then at least it would transform
- ;; correctly under package renaming and stuff.
- ;; However, genesis can't handle dumped packages..
- ;; -- WHN 20000129
- ;;
- ;; FIXME: Maybe this could be fixed by moving the
- ;; whole debug-int.lisp file to warm init? (after
- ;; which dumping a #.(FIND-PACKAGE ..) expression
- ;; would work fine) If this is possible, it would
- ;; probably be a good thing, since minimizing the
- ;; amount of stuff in cold init is basically good.
- (or (find-package "SB-DEBUG")
- (find-package "SB!DEBUG")))))))
+ (without-package-locks
+ (setf (compiled-debug-var-symbol (svref vars i))
+ (intern (format nil "ARG-~V,'0D" width i)
+ ;; KLUDGE: It's somewhat nasty to have a bare
+ ;; package name string here. It would be
+ ;; nicer to have #.(FIND-PACKAGE "SB!DEBUG")
+ ;; instead, since then at least it would transform
+ ;; correctly under package renaming and stuff.
+ ;; However, genesis can't handle dumped packages..
+ ;; -- WHN 20000129
+ ;;
+ ;; FIXME: Maybe this could be fixed by moving the
+ ;; whole debug-int.lisp file to warm init? (after
+ ;; which dumping a #.(FIND-PACKAGE ..) expression
+ ;; would work fine) If this is possible, it would
+ ;; probably be a good thing, since minimizing the
+ ;; amount of stuff in cold init is basically good.
+ (or (find-package "SB-DEBUG")
+ (find-package "SB!DEBUG"))))))))
;;; Parse the packed representation of DEBUG-VARs from
;;; DEBUG-FUN's SB!C::COMPILED-DEBUG-FUN, returning a vector
Index: defboot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- defboot.lisp 20 May 2004 15:55:44 -0000 1.43
+++ defboot.lisp 29 Jun 2004 08:50:58 -0000 1.44
@@ -212,7 +212,7 @@
;; something sane, (1) doing so doesn't really fix the bug, and
;; (2) doing probably isn't even really safe.
#+nil (setf (%fun-name def) name)
-
+
(when doc
(setf (fdocumentation name 'function) doc))
name)
Index: defpackage.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defpackage.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- defpackage.lisp 27 May 2004 16:06:47 -0000 1.7
+++ defpackage.lisp 29 Jun 2004 08:50:58 -0000 1.8
@@ -28,19 +28,24 @@
nil))
(defmacro defpackage (package &rest options)
- #!+sb-doc
- "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
- following:
- (:NICKNAMES {package-name}*)
- (:SIZE <integer>)
- (: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}*)
- (:DOCUMENTATION doc-string)
- All options except :SIZE and :DOCUMENTATION can be used multiple times."
+ #!+sb-doc
+ #.(format nil
+ "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
+ following: ~{~&~4T~A~}
+ All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
+ times."
+ '((:nicknames "{package-name}*")
+ (:size "<integer>")
+ (: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}*")
+ #!+sb-package-locks (:lock "boolean")
+ (:documentation "doc-string"))
+ '(:size #!+sb-package-locks :lock))
(let ((nicknames nil)
(size nil)
(shadows nil)
@@ -50,7 +55,12 @@
(imports nil)
(interns nil)
(exports nil)
+ (implement (stringify-names (list package) "package"))
+ (implement-p nil)
+ (lock nil)
(doc nil))
+ #!-sb-package-locks
+ (declare (ignore implement-p))
(dolist (option options)
(unless (consp option)
(error 'simple-program-error
@@ -100,6 +110,19 @@
(:export
(let ((new (stringify-names (cdr option) "symbol")))
(setf exports (append exports new))))
+ #!+sb-package-locks
+ (:implement
+ (unless implement-p
+ (setf implement nil))
+ (let ((new (stringify-names (cdr option) "package")))
+ (setf implement (append implement new)
+ implement-p t)))
+ #!+sb-package-locks
+ (:lock
+ (when lock
+ (error 'simple-program-error
+ :format-control "multiple :LOCK options"))
+ (setf lock (coerce (second option) 'boolean)))
(:documentation
(when doc
(error 'simple-program-error
@@ -119,7 +142,7 @@
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%defpackage ,(stringify-name package "package") ',nicknames ',size
',shadows ',shadowing-imports ',(if use-p use :default)
- ',imports ',interns ',exports ',doc))))
+ ',imports ',interns ',exports ',implement ',lock ',doc))))
(defun check-disjoint (&rest args)
;; An arg is (:key . set)
@@ -149,12 +172,14 @@
names))
(defun %defpackage (name nicknames size shadows shadowing-imports
- use imports interns exports doc-string)
+ use imports interns exports implement lock doc-string)
(declare (type simple-base-string name)
(type list nicknames shadows shadowing-imports
imports interns exports)
(type (or list (member :default)) use)
- (type (or simple-base-string null) doc-string))
+ (type (or simple-base-string null) doc-string)
+ #!-sb-package-locks
+ (ignore implement lock))
(let ((package (or (find-package name)
(progn
(when (eq use :default)
@@ -217,6 +242,13 @@
(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))
Index: defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -d -r1.69 -r1.70
--- defstruct.lisp 19 Jun 2004 21:42:49 -0000 1.69
+++ defstruct.lisp 29 Jun 2004 08:50:58 -0000 1.70
@@ -337,15 +337,18 @@
(if (dd-class-p dd)
(let ((inherits (inherits-for-structure dd)))
`(progn
- ;; Note we intentionally call %DEFSTRUCT first, and
- ;; especially before %COMPILER-DEFSTRUCT. %DEFSTRUCT
- ;; has the tests (and resulting CERROR) for collisions
- ;; with LAYOUTs which already exist in the runtime. If
- ;; there are any collisions, we want the user's
- ;; response to CERROR to control what happens.
- ;; Especially, if the user responds to the collision
- ;; with ABORT, we don't want %COMPILER-DEFSTRUCT to
- ;; modify the definition of the class.
+ ;; Note we intentionally enforce package locks and
+ ;; call %DEFSTRUCT first, and especially before
+ ;; %COMPILER-DEFSTRUCT. %DEFSTRUCT has the tests (and
+ ;; resulting CERROR) for collisions with LAYOUTs which
+ ;; already exist in the runtime. If there are any
+ ;; collisions, we want the user's response to CERROR
+ ;; to control what happens. Especially, if the user
+ ;; responds to the collision with ABORT, we don't want
+ ;; %COMPILER-DEFSTRUCT to modify the definition of the
+ ;; class.
+ (with-single-package-locked-error
+ (:symbol ',name "defining ~A as a structure"))
(%defstruct ',dd ',inherits)
(eval-when (:compile-toplevel :load-toplevel :execute)
(%compiler-defstruct ',dd ',inherits))
@@ -358,6 +361,8 @@
(class-method-definitions dd)))
',name))
`(progn
+ (with-single-package-locked-error
+ (:symbol ',name "defining ~A as a structure"))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (info :typed-structure :info ',name) ',dd))
,@(unless expanding-into-code-for-xc-host-p
Index: early-fasl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-fasl.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- early-fasl.lisp 20 May 2004 15:55:49 -0000 1.45
+++ early-fasl.lisp 29 Jun 2004 08:50:58 -0000 1.46
@@ -35,7 +35,7 @@
(macrolet ((define-fasl-format-features ()
(let (;; master value for *F-P-A-F-F*
- (fpaff '(:sb-thread)))
+ (fpaff '(:sb-thread :sb-package-locks)))
`(progn
;; a list of *(SHEBANG-)FEATURES* flags which affect
;; binary compatibility, i.e. which must be the same
@@ -161,6 +161,7 @@
(defvar *load-print* nil
#!+sb-doc
"the default for the :PRINT argument to LOAD")
+
(defvar *load-verbose* nil
;; Note that CMU CL's default for this was T, and ANSI says it's
;; implementation-dependent. We choose NIL on the theory that it's
@@ -169,4 +170,3 @@
"the default for the :VERBOSE argument to LOAD")
(defvar *load-code-verbose* nil)
-
Index: early-pprint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-pprint.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- early-pprint.lisp 20 Oct 2000 23:30:33 -0000 1.2
+++ early-pprint.lisp 29 Jun 2004 08:50:58 -0000 1.3
@@ -96,15 +96,19 @@
(incf ,count-name)
,@(when object
`((pop ,object-var)))))
- (declare (ignorable #',pp-pop-name))
- (macrolet ((pprint-pop ()
- '(,pp-pop-name))
- (pprint-exit-if-list-exhausted ()
- ,(if object
- `'(when (null ,object-var)
- (return-from ,block-name nil))
- `'(return-from ,block-name nil))))
- ,@body)))
+ (locally
+ (declare (disable-package-locks
+ pprint-pop pprint-exit-if-list-exhausted))
+ (macrolet ((pprint-pop ()
+ '(,pp-pop-name))
+ (pprint-exit-if-list-exhausted ()
+ ,(if object
+ `'(when (null ,object-var)
+ (return-from ,block-name nil))
+ `'(return-from ,block-name nil))))
+ (declare (enable-package-locks
+ pprint-pop pprint-exit-if-list-exhausted))
+ ,@body))))
;; FIXME: Don't we need UNWIND-PROTECT to ensure this
;; always gets executed?
(end-logical-block ,stream-var)))))
Index: early-setf.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-setf.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- early-setf.lisp 15 May 2004 12:09:20 -0000 1.22
+++ early-setf.lisp 29 Jun 2004 08:50:58 -0000 1.23
@@ -337,6 +337,8 @@
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
;;; Assign SETF macro information for NAME, making all appropriate checks.
(defun assign-setf-macro (name expander inverse doc)
+ (with-single-package-locked-error
+ (:symbol name "defining a setf-expander for ~A"))
(cond ((gethash name sb!c:*setf-assumed-fboundp*)
(warn
"defining setf macro for ~S when ~S was previously ~
Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- eval.lisp 26 Aug 2003 13:21:18 -0000 1.24
+++ eval.lisp 29 Jun 2004 08:50:58 -0000 1.25
@@ -46,7 +46,7 @@
(eval-in-lexenv (first i) lexenv)
(return (eval-in-lexenv (first i) lexenv)))))
-(defun eval-locally (exp lexenv &optional vars)
+(defun eval-locally (exp lexenv &key vars)
(multiple-value-bind (body decls)
(parse-body (rest exp) :doc-string-allowed nil)
(let ((lexenv
@@ -62,10 +62,10 @@
;; undefined things can be accumulated [and
;; then thrown away, as it happens]). -- CSR,
;; 2002-10-24
- (let ((sb!c:*lexenv* lexenv)
- (sb!c::*free-funs* (make-hash-table :test 'equal))
- (sb!c::*free-vars* (make-hash-table :test 'eq))
- (sb!c::*undefined-warnings* nil))
+ (let* ((sb!c:*lexenv* lexenv)
+ (sb!c::*free-funs* (make-hash-table :test 'equal))
+ (sb!c::*free-vars* (make-hash-table :test 'eq))
+ (sb!c::*undefined-warnings* nil))
;; FIXME: VALUES declaration
(sb!c::process-decls decls
vars
@@ -188,7 +188,7 @@
((macrolet)
(destructuring-bind (definitions &rest body)
(rest exp)
- (let ((lexenv
+ (let ((lexenv
(let ((sb!c:*lexenv* lexenv))
(sb!c::funcall-in-macrolet-lexenv
definitions
@@ -198,8 +198,7 @@
:eval))))
(eval-locally `(locally ,@body) lexenv))))
((symbol-macrolet)
- (destructuring-bind (definitions &rest body)
- (rest exp)
+ (destructuring-bind (definitions &rest body) (rest exp)
(multiple-value-bind (lexenv vars)
(let ((sb!c:*lexenv* lexenv))
(sb!c::funcall-in-symbol-macrolet-lexenv
@@ -207,7 +206,7 @@
(lambda (&key vars)
(values sb!c:*lexenv* vars))
:eval))
- (eval-locally `(locally ,@body) lexenv vars))))
+ (eval-locally `(locally ,@body) lexenv :vars vars))))
(t
(if (and (symbolp name)
(eq (info :function :kind name) :function))
Index: fdefinition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fdefinition.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- fdefinition.lisp 4 May 2004 17:25:58 -0000 1.21
+++ fdefinition.lisp 29 Jun 2004 08:50:58 -0000 1.22
@@ -234,27 +234,28 @@
#!+sb-doc
"Set NAME's global function definition."
(declare (type function new-value) (optimize (safety 1)))
- (let ((fdefn (fdefinition-object name t)))
- ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
- ;; top level forms in the kernel core startup.
- (when (boundp '*setf-fdefinition-hook*)
- (dolist (f *setf-fdefinition-hook*)
- (declare (type function f))
- (funcall f name new-value)))
-
- (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
- (cond (encap-info
- (loop
- (let ((more-info
- (encapsulation-info
- (encapsulation-info-definition encap-info))))
- (if more-info
- (setf encap-info more-info)
- (return
- (setf (encapsulation-info-definition encap-info)
- new-value))))))
- (t
- (setf (fdefn-fun fdefn) new-value))))))
+ (with-single-package-locked-error (:symbol name "setting fdefinition of ~A")
+ (let ((fdefn (fdefinition-object name t)))
+ ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running
+ ;; top level forms in the kernel core startup.
+ (when (boundp '*setf-fdefinition-hook*)
+ (dolist (f *setf-fdefinition-hook*)
+ (declare (type function f))
+ (funcall f name new-value)))
+
+ (let ((encap-info (encapsulation-info (fdefn-fun fdefn))))
+ (cond (encap-info
+ (loop
+ (let ((more-info
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (if more-info
+ (setf encap-info more-info)
+ (return
+ (setf (encapsulation-info-definition encap-info)
+ new-value))))))
+ (t
+ (setf (fdefn-fun fdefn) new-value)))))))
;;;; FBOUNDP and FMAKUNBOUND
@@ -267,8 +268,10 @@
(defun fmakunbound (name)
#!+sb-doc
"Make NAME have no global function definition."
- (let ((fdefn (fdefinition-object name nil)))
- (when fdefn
- (fdefn-makunbound fdefn)))
- (sb!kernel:undefine-fun-name name)
- name)
+ (with-single-package-locked-error
+ (:symbol name "removing the function or macro definition of ~A")
+ (let ((fdefn (fdefinition-object name nil)))
+ (when fdefn
+ (fdefn-makunbound fdefn)))
+ (sb!kernel:undefine-fun-name name)
+ name))
Index: fop.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/fop.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- fop.lisp 5 Apr 2004 23:16:29 -0000 1.29
+++ fop.lisp 29 Jun 2004 08:50:58 -0000 1.30
@@ -198,9 +198,10 @@
(read-string-as-bytes *fasl-input-stream*
,n-buffer
,n-size)
- (push-fop-table (intern* ,n-buffer
- ,n-size
- ,n-package)))))))))
+ (push-fop-table (without-package-locks
+ (intern* ,n-buffer
+ ,n-size
+ ,n-package))))))))))
;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but
;; since they made the behavior of the fasloader depend on the
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/macros.lisp,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -d -r1.39 -r1.40
--- macros.lisp 26 Jun 2004 14:33:42 -0000 1.39
+++ macros.lisp 29 Jun 2004 08:50:59 -0000 1.40
@@ -79,6 +79,8 @@
(error 'simple-type-error :datum name :expected-type 'symbol
:format-control "Symbol macro name is not a symbol: ~S."
:format-arguments (list name)))
+ (with-single-package-locked-error
+ (:symbol name "defining ~A as a symbol-macro"))
(ecase (info :variable :kind name)
((:macro :global nil)
(setf (info :variable :kind name) :macro)
Index: package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/package.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- package.lisp 19 May 2004 14:20:22 -0000 1.16
+++ package.lisp 29 Jun 2004 08:50:59 -0000 1.17
@@ -99,7 +99,12 @@
;; shadowing symbols
(%shadowing-symbols () :type list)
;; documentation string for this package
- (doc-string nil :type (or simple-base-string null)))
+ (doc-string nil :type (or simple-base-string null))
+ ;; package locking
+ #!+sb-package-locks
+ (lock nil :type boolean)
+ #!+sb-package-locks
+ (%implementation-packages nil :type list))
;;;; iteration macros
Index: profile.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/profile.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- profile.lisp 5 Apr 2004 11:08:04 -0000 1.28
+++ profile.lisp 29 Jun 2004 08:50:59 -0000 1.29
@@ -248,8 +248,9 @@
(let ((encapsulated-fun (fdefinition name)))
(multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
(profile-encapsulation-lambdas encapsulated-fun)
- (setf (fdefinition name)
- encapsulation-fun)
+ (without-package-locks
+ (setf (fdefinition name)
+ encapsulation-fun))
(setf (gethash name *profiled-fun-name->info*)
(make-profile-info :name name
:encapsulated-fun encapsulated-fun
@@ -275,7 +276,8 @@
(cond (pinfo
(remhash name *profiled-fun-name->info*)
(if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
- (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))
+ (without-package-locks
+ (setf (fdefinition name) (profile-info-encapsulated-fun pinfo)))
(warn "preserving current definition of redefined function ~S"
name)))
(t
@@ -515,5 +517,6 @@
;;; different machine running at a different speed. We avoid this by
;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
(pushnew (lambda ()
- (makunbound '*overhead*))
+ (without-package-locks
+ (makunbound '*overhead*)))
*before-save-initializations*)
Index: symbol.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/symbol.lisp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- symbol.lisp 21 May 2004 12:17:48 -0000 1.17
+++ symbol.lisp 29 Jun 2004 08:50:59 -0000 1.18
@@ -41,11 +41,12 @@
(defun makunbound (symbol)
#!+sb-doc
"Make SYMBOL unbound, removing any value it may currently have."
- (set symbol
- (%primitive sb!c:make-other-immediate-type
- 0
- sb!vm:unbound-marker-widetag))
- symbol)
+ (with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A")
+ (set symbol
+ (%primitive sb!c:make-other-immediate-type
+ 0
+ sb!vm:unbound-marker-widetag))
+ symbol))
;;; Return the built-in hash value for SYMBOL.
(defun symbol-hash (symbol)
@@ -58,7 +59,9 @@
(defun (setf symbol-function) (new-value symbol)
(declare (type symbol symbol) (type function new-value))
- (setf (%coerce-name-to-fun symbol) new-value))
+ (with-single-package-locked-error
+ (:symbol symbol "setting the symbol-function of ~A")
+ (setf (%coerce-name-to-fun symbol) new-value)))
(defun symbol-plist (symbol)
#!+sb-doc
Index: target-package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-package.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- target-package.lisp 31 May 2004 21:47:06 -0000 1.26
+++ target-package.lisp 29 Jun 2004 08:50:59 -0000 1.27
@@ -70,6 +70,190 @@
(setf res (%make-package-hashtable table hash size)))
res)))
+;;;; 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)
+
+
;;;; miscellaneous PACKAGE operations
(def!method print-object ((package package) stream)
@@ -367,19 +551,28 @@
"Changes the name and nicknames for a package."
(let* ((package (find-undeleted-package-or-lose package))
(name (string name))
- (found (find-package name)))
+ (found (find-package name))
+ (nicks (mapcar #'string nicknames)))
(unless (or (not found) (eq found package))
(error 'simple-package-error
:package name
:format-control "A package named ~S already exists."
:format-arguments (list name)))
- (remhash (package-%name package) *package-names*)
- (dolist (n (package-%nicknames package))
- (remhash n *package-names*))
- (setf (package-%name package) name)
- (setf (gethash name *package-names*) package)
- (setf (package-%nicknames package) ())
- (enter-new-nicknames package nicknames)
+ (with-single-package-locked-error ()
+ (unless (and (string= name (package-name package))
+ (null (set-difference nicks (package-nicknames package)
+ :test #'string=)))
+ (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~
+ ~{~A~^, ~}~]"
+ name (length nicks) nicks))
+ ;; do the renaming
+ (remhash (package-%name package) *package-names*)
+ (dolist (n (package-%nicknames package))
+ (remhash n *package-names*))
+ (setf (package-%name package) name
+ (gethash name *package-names*) package
+ (package-%nicknames package) ())
+ (enter-new-nicknames package nicknames))
package))
(defun delete-package (package-or-name)
@@ -398,42 +591,44 @@
((not (package-name package)) ; already deleted
nil)
(t
- (let ((use-list (package-used-by-list package)))
- (when use-list
- ;; This continuable error is specified by ANSI.
- (with-simple-restart
- (continue "Remove dependency in other packages.")
- (error 'simple-package-error
- :package package
- :format-control
- "Package ~S is used by package(s):~% ~S"
- :format-arguments
- (list (package-name package)
- (mapcar #'package-name use-list))))
- (dolist (p use-list)
- (unuse-package package p))))
- (dolist (used (package-use-list package))
- (unuse-package used package))
- (do-symbols (sym package)
- (unintern sym package))
- (remhash (package-name package) *package-names*)
- (dolist (nick (package-nicknames package))
- (remhash nick *package-names*))
- (setf (package-%name package) nil
- ;; Setting PACKAGE-%NAME to NIL is required in order to
- ;; make PACKAGE-NAME return NIL for a deleted package as
- ;; ANSI requires. Setting the other slots to NIL
- ;; and blowing away the PACKAGE-HASHTABLES is just done
- ;; for tidiness and to help the GC.
- (package-%nicknames package) nil
- (package-%use-list package) nil
- (package-tables package) nil
- (package-%shadowing-symbols package) nil
- (package-internal-symbols package)
- (make-or-remake-package-hashtable 0)
- (package-external-symbols package)
- (make-or-remake-package-hashtable 0))
- t))))
+ (with-single-package-locked-error
+ (:package package "deleting package ~A" package)
+ (let ((use-list (package-used-by-list package)))
+ (when use-list
+ ;; This continuable error is specified by ANSI.
+ (with-simple-restart
+ (continue "Remove dependency in other packages.")
+ (error 'simple-package-error
+ :package package
+ :format-control
+ "Package ~S is used by package(s):~% ~S"
+ :format-arguments
+ (list (package-name package)
+ (mapcar #'package-name use-list))))
+ (dolist (p use-list)
+ (unuse-package package p))))
+ (dolist (used (package-use-list package))
+ (unuse-package used package))
+ (do-symbols (sym package)
+ (unintern sym package))
+ (remhash (package-name package) *package-names*)
+ (dolist (nick (package-nicknames package))
+ (remhash nick *package-names*))
+ (setf (package-%name package) nil
+ ;; Setting PACKAGE-%NAME to NIL is required in order to
+ ;; make PACKAGE-NAME return NIL for a deleted package as
+ ;; ANSI requires. Setting the other slots to NIL
+ ;; and blowing away the PACKAGE-HASHTABLES is just done
+ ;; for tidiness and to help the GC.
+ (package-%nicknames package) nil
+ (package-%use-list package) nil
+ (package-tables package) nil
+ (package-%shadowing-symbols package) nil
+ (package-internal-symbols package)
+ (make-or-remake-package-hashtable 0)
+ (package-external-symbols package)
+ (make-or-remake-package-hashtable 0))
+ t)))))
(defun list-all-packages ()
#!+sb-doc
@@ -452,11 +647,12 @@
;; logic is.
(let ((name (if (simple-string-p name)
name
- (coerce name 'simple-string))))
+ (coerce name 'simple-string)))
+ (package (find-undeleted-package-or-lose package)))
(declare (simple-string name))
- (intern* name
- (length name)
- (find-undeleted-package-or-lose package))))
+ (intern* name
+ (length name)
+ package)))
(defun find-symbol (name &optional (package (sane-package)))
#!+sb-doc
@@ -477,16 +673,20 @@
(defun intern* (name length package)
(declare (simple-string name))
(multiple-value-bind (symbol where) (find-symbol* name length package)
- (if where
- (values symbol where)
- (let ((symbol (make-symbol (subseq name 0 length))))
- (%set-symbol-package symbol package)
- (cond ((eq package *keyword-package*)
- (add-symbol (package-external-symbols package) symbol)
- (%set-symbol-value symbol symbol))
- (t
- (add-symbol (package-internal-symbols package) symbol)))
- (values symbol nil)))))
+ (cond (where
+ (values symbol where))
+ (t
+ (let ((symbol-name (subseq name 0 length)))
+ (with-single-package-locked-error
+ (:package package "interning ~A" symbol-name)
+ (let ((symbol (make-symbol symbol-name)))
+ (%set-symbol-package symbol package)
+ (cond ((eq package *keyword-package*)
+ (add-symbol (package-external-symbols package) symbol)
+ (%set-symbol-value symbol symbol))
+ (t
+ (add-symbol (package-internal-symbols package) symbol)))
+ (values symbol nil))))))))
;;; Check internal and external symbols, then scan down the list
;;; of hashtables for inherited symbols. When an inherited symbol
@@ -540,43 +740,47 @@
(shadowing-symbols (package-%shadowing-symbols package)))
(declare (list shadowing-symbols))
- ;; If a name conflict is revealed, give use a chance to shadowing-import
- ;; one of the accessible symbols.
- (when (member symbol shadowing-symbols)
- (let ((cset ()))
- (dolist (p (package-%use-list package))
- (multiple-value-bind (s w) (find-external-symbol name p)
- (when w (pushnew s cset))))
- (when (cdr cset)
- (loop
- (cerror
- "Prompt for a symbol to SHADOWING-IMPORT."
- "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
- symbol cset)
- (write-string "Symbol to shadowing-import: " *query-io*)
- (let ((sym (read *query-io*)))
- (cond
- ((not (symbolp sym))
- (format *query-io* "~S is not a symbol." sym))
- ((not (member sym cset))
- (format *query-io* "~S is not one of the conflicting symbols." sym))
- (t
- (shadowing-import sym package)
- (return-from unintern t)))))))
- (setf (package-%shadowing-symbols package)
- (remove symbol shadowing-symbols)))
+ (with-single-package-locked-error ()
+ (when (find-symbol name package)
+ (assert-package-unlocked package "uninterning ~A" name))
+
+ ;; If a name conflict is revealed, give use a chance to shadowing-import
+ ;; one of the accessible symbols.
+ (when (member symbol shadowing-symbols)
+ (let ((cset ()))
+ (dolist (p (package-%use-list package))
+ (multiple-value-bind (s w) (find-external-symbol name p)
+ (when w (pushnew s cset))))
+ (when (cdr cset)
+ (loop
+ (cerror
+ "Prompt for a symbol to SHADOWING-IMPORT."
+ "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
+ symbol cset)
+ (write-string "Symbol to shadowing-import: " *query-io*)
+ (let ((sym (read *query-io*)))
+ (cond
+ ((not (symbolp sym))
+ (format *query-io* "~S is not a symbol." sym))
+ ((not (member sym cset))
+ (format *query-io* "~S is not one of the conflicting symbols." sym))
+ (t
+ (shadowing-import sym package)
+ (return-from unintern t)))))))
+ (setf (package-%shadowing-symbols package)
+ (remove symbol shadowing-symbols)))
- (multiple-value-bind (s w) (find-symbol name package)
- (declare (ignore s))
- (cond ((or (eq w :internal) (eq w :external))
- (nuke-symbol (if (eq w :internal)
- (package-internal-symbols package)
- (package-external-symbols package))
- name)
- (if (eq (symbol-package symbol) package)
- (%set-symbol-package symbol nil))
- t)
- (t nil)))))
+ (multiple-value-bind (s w) (find-symbol name package)
+ (declare (ignore s))
+ (cond ((or (eq w :internal) (eq w :external))
+ (nuke-symbol (if (eq w :internal)
+ (package-internal-symbols package)
+ (package-external-symbols package))
+ name)
+ (if (eq (symbol-package symbol) package)
+ (%set-symbol-package symbol nil))
+ t)
+ (t nil))))))
;;; Take a symbol-or-list-of-symbols and return a list, checking types.
(defun symbol-listify (thing)
@@ -588,6 +792,11 @@
(t
(error "~S is neither a symbol nor a list of symbols." thing))))
+(defun string-listify (thing)
+ (mapcar #'string (if (listp thing)
+ thing
+ (list thing))))
+
;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
;;; down the package it is inherited from and uninterns it there. Used
;;; for name-conflict resolution. Shadowing symbols are not uninterned
@@ -618,67 +827,71 @@
(declare (ignore s))
(unless (or w (member sym syms))
(push sym syms))))
- ;; Find symbols and packages with conflicts.
- (let ((used-by (package-%used-by-list package))
- (cpackages ())
- (cset ()))
- (dolist (sym syms)
- (let ((name (symbol-name sym)))
- (dolist (p used-by)
- (multiple-value-bind (s w) (find-symbol name p)
- (when (and w (not (eq s sym))
- (not (member s (package-%shadowing-symbols p))))
- (pushnew sym cset)
- (pushnew p cpackages))))))
- (when cset
- (restart-case
- (error
- 'simple-package-error
- :package package
- :format-control
- "Exporting these symbols from the ~A package:~%~S~%~
- results in name conflicts with these packages:~%~{~A ~}"
- :format-arguments
- (list (package-%name package) cset
- (mapcar #'package-%name cpackages)))
- (unintern-conflicting-symbols ()
- :report "Unintern conflicting symbols."
- (dolist (p cpackages)
- (dolist (sym cset)
- (moby-unintern sym p))))
- (skip-exporting-these-symbols ()
- :report "Skip exporting conflicting symbols."
- (setq syms (nset-difference syms cset))))))
+ (with-single-package-locked-error ()
+ (when syms
+ (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}"
+ (length syms) syms))
+ ;; Find symbols and packages with conflicts.
+ (let ((used-by (package-%used-by-list package))
+ (cpackages ())
+ (cset ()))
+ (dolist (sym syms)
+ (let ((name (symbol-name sym)))
+ (dolist (p used-by)
+ (multiple-value-bind (s w) (find-symbol name p)
+ (when (and w (not (eq s sym))
+ (not (member s (package-%shadowing-symbols p))))
+ (pushnew sym cset)
+ (pushnew p cpackages))))))
+ (when cset
+ (restart-case
+ (error
+ 'simple-package-error
+ :package package
+ :format-control
+ "Exporting these symbols from the ~A package:~%~S~%~
+ results in name conflicts with these packages:~%~{~A ~}"
+ :format-arguments
+ (list (package-%name package) cset
+ (mapcar #'package-%name cpackages)))
+ (unintern-conflicting-symbols ()
+ :report "Unintern conflicting symbols."
+ (dolist (p cpackages)
+ (dolist (sym cset)
+ (moby-unintern sym p))))
+ (skip-exporting-these-symbols ()
+ :report "Skip exporting conflicting symbols."
+ (setq syms (nset-difference syms cset))))))
- ;; Check that all symbols are accessible. If not, ask to import them.
- (let ((missing ())
- (imports ()))
- (dolist (sym syms)
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (cond ((not (and w (eq s sym)))
- (push sym missing))
- ((eq w :inherited)
- (push sym imports)))))
- (when missing
- (with-simple-restart
- (continue "Import these symbols into the ~A package."
- (package-%name package))
- (error 'simple-package-error
- :package package
- :format-control
- "These symbols are not accessible in the ~A package:~%~S"
- :format-arguments
- (list (package-%name package) missing)))
- (import missing package))
- (import imports package))
+ ;; Check that all symbols are accessible. If not, ask to import them.
+ (let ((missing ())
+ (imports ()))
+ (dolist (sym syms)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (cond ((not (and w (eq s sym)))
+ (push sym missing))
+ ((eq w :inherited)
+ (push sym imports)))))
+ (when missing
+ (with-simple-restart
+ (continue "Import these symbols into the ~A package."
+ (package-%name package))
+ (error 'simple-package-error
+ :package package
+ :format-control
+ "These symbols are not accessible in the ~A package:~%~S"
+ :format-arguments
+ (list (package-%name package) missing)))
+ (import missing package))
+ (import imports package))
- ;; And now, three pages later, we export the suckers.
- (let ((internal (package-internal-symbols package))
- (external (package-external-symbols package)))
- (dolist (sym syms)
- (nuke-symbol internal (symbol-name sym))
- (add-symbol external sym)))
- t))
+ ;; And now, three pages later, we export the suckers.
+ (let ((internal (package-internal-symbols package))
+ (external (package-external-symbols package)))
+ (dolist (sym syms)
+ (nuke-symbol internal (symbol-name sym))
+ (add-symbol external sym))))
+ t))
;;; Check that all symbols are accessible, then move from external to internal.
(defun unexport (symbols &optional (package (sane-package)))
@@ -694,12 +907,15 @@
:format-control "~S is not accessible in the ~A package."
:format-arguments (list sym (package-%name package))))
((eq w :external) (pushnew sym syms)))))
-
- (let ((internal (package-internal-symbols package))
- (external (package-external-symbols package)))
- (dolist (sym syms)
- (add-symbol internal sym)
- (nuke-symbol external (symbol-name sym))))
+ (with-single-package-locked-error ()
+ (when syms
+ (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}"
+ (length syms) syms))
+ (let ((internal (package-internal-symbols package))
+ (external (package-external-symbols package)))
+ (dolist (sym syms)
+ (add-symbol internal sym)
+ (nuke-symbol external (symbol-name sym)))))
t))
;;; Check for name conflict caused by the import and let the user
@@ -709,10 +925,11 @@
"Make Symbols accessible as internal symbols in Package. If a symbol
is already accessible then it has no effect. If a name conflict
would result from the importation, then a correctable error is signalled."
- (let ((package (find-undeleted-package-or-lose package))
- (symbols (symbol-listify symbols))
- (syms ())
- (cset ()))
+ (let* ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
+ (homeless (remove-if #'symbol-package symbols))
+ (syms ())
+ (cset ()))
(dolist (sym symbols)
(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
(cond ((not w)
@@ -723,24 +940,29 @@
(push sym syms))))
((not (eq s sym)) (push sym cset))
((eq w :inherited) (push sym syms)))))
- (when cset
- ;; ANSI specifies that this error is correctable.
- (with-simple-restart
- (continue "Import these symbols with Shadowing-Import.")
- (error 'simple-package-error
- :package package
- :format-control
- "Importing these symbols into the ~A package ~
+ (with-single-package-locked-error ()
+ (when (or homeless syms cset)
+ (let ((union (delete-duplicates (append homeless syms cset))))
+ (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}"
+ (length union) union)))
+ (when cset
+ ;; ANSI specifies that this error is correctable.
+ (with-simple-restart
+ (continue "Import these symbols with Shadowing-Import.")
+ (error 'simple-package-error
+ :package package
+ :format-control
+ "Importing these symbols into the ~A package ~
causes a name conflict:~%~S"
- :format-arguments (list (package-%name package) cset))))
- ;; Add the new symbols to the internal hashtable.
- (let ((internal (package-internal-symbols package)))
- (dolist (sym syms)
- (add-symbol internal sym)))
- ;; If any of the symbols are uninterned, make them be owned by Package.
- (dolist (sym symbols)
- (unless (symbol-package sym) (%set-symbol-package sym package)))
- (shadowing-import cset package)))
+ :format-arguments (list (package-%name package) cset))))
+ ;; Add the new symbols to the internal hashtable.
+ (let ((internal (package-internal-symbols package)))
+ (dolist (sym syms)
+ (add-symbol internal sym)))
+ ;; If any of the symbols are uninterned, make them be owned by Package.
+ (dolist (sym homeless)
+ (%set-symbol-package sym package))
+ (shadowing-import cset package))))
;;; If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
@@ -750,17 +972,26 @@
a symbol of the same name is present, then it is uninterned.
The symbols are added to the Package-Shadowing-Symbols."
(let* ((package (find-undeleted-package-or-lose package))
- (internal (package-internal-symbols package)))
- (dolist (sym (symbol-listify symbols))
- (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
- (unless (and w (not (eq w :inherited)) (eq s sym))
- (when (or (eq w :internal) (eq w :external))
- ;; If it was shadowed, we don't want UNINTERN to flame out...
- (setf (package-%shadowing-symbols package)
- (remove s (the list (package-%shadowing-symbols package))))
- (unintern s package))
- (add-symbol internal sym))
- (pushnew sym (package-%shadowing-symbols package)))))
+ (internal (package-internal-symbols package))
+ (symbols (symbol-listify symbols))
+ (lock-asserted-p nil))
+ (with-single-package-locked-error ()
+ (dolist (sym symbols)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (unless (or lock-asserted-p
+ (and (eq s sym)
+ (member s (package-shadowing-symbols package))))
+ (assert-package-unlocked package "shadowing-importing symbol~P ~
+ ~{~A~^, ~}" (length symbols) symbols)
+ (setf lock-asserted-p t))
+ (unless (and w (not (eq w :inherited)) (eq s sym))
+ (when (or (eq w :internal) (eq w :external))
+ ;; If it was shadowed, we don't want UNINTERN to flame out...
+ (setf (package-%shadowing-symbols package)
+ (remove s (the list (package-%shadowing-symbols package))))
+ (unintern s package))
+ (add-symbol internal sym))
+ (pushnew sym (package-%shadowing-symbols package))))))
t)
(defun shadow (symbols &optional (package (sane-package)))
@@ -771,15 +1002,25 @@
the existing symbol is placed in the shadowing symbols list if it is
not already present."
(let* ((package (find-undeleted-package-or-lose package))
- (internal (package-internal-symbols package)))
- (dolist (name (mapcar #'string
- (if (listp symbols) symbols (list symbols))))
- (multiple-value-bind (s w) (find-symbol name package)
- (when (or (not w) (eq w :inherited))
- (setq s (make-symbol name))
- (%set-symbol-package s package)
- (add-symbol internal s))
- (pushnew s (package-%shadowing-symbols package)))))
+ (internal (package-internal-symbols package))
+ (symbols (string-listify symbols))
+ (lock-asserted-p nil))
+ (flet ((present-p (w)
+ (and w (not (eq w :inherited)))))
+ (with-single-package-locked-error ()
+ (dolist (name symbols)
+ (multiple-value-bind (s w) (find-symbol name package)
+ (unless (or lock-asserted-p
+ (and (present-p w)
+ (member s (package-shadowing-symbols package))))
+ (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}"
+ (length symbols) symbols)
+ (setf lock-asserted-p t))
+ (unless (present-p w)
+ (setq s (make-symbol name))
+ (%set-symbol-package s package)
+ (add-symbol internal s))
+ (pushnew s (package-%shadowing-symbols package)))))))
t)
;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
@@ -792,71 +1033,79 @@
(package (find-undeleted-package-or-lose package)))
;; Loop over each package, USE'ing one at a time...
- (dolist (pkg packages)
- (unless (member pkg (package-%use-list package))
- (let ((cset ())
- (shadowing-symbols (package-%shadowing-symbols package))
- (use-list (package-%use-list package)))
-
- ;; If the number of symbols already accessible is less than the
- ;; number to be inherited then it is faster to run the test the
- ;; other way. This is particularly valuable in the case of
- ;; a new package USEing Lisp.
- (cond
- ((< (+ (package-internal-symbol-count package)
- (package-external-symbol-count package)
- (let ((res 0))
- (dolist (p use-list res)
- (incf res (package-external-symbol-count p)))))
- (package-external-symbol-count pkg))
- (do-symbols (sym package)
- (multiple-value-bind (s w)
- (find-external-symbol (symbol-name sym) pkg)
- (when (and w (not (eq s sym))
- (not (member sym shadowing-symbols)))
- (push sym cset))))
- (dolist (p use-list)
- (do-external-symbols (sym p)
- (multiple-value-bind (s w)
- (find-external-symbol (symbol-name sym) pkg)
- (when (and w (not (eq s sym))
- (not (member (find-symbol (symbol-name sym)
- package)
- shadowing-symbols)))
- (push sym cset))))))
- (t
- (do-external-symbols (sym pkg)
- (multiple-value-bind (s w)
- (find-symbol (symbol-name sym) package)
- (when (and w (not (eq s sym))
- (not (member s shadowing-symbols)))
- (push s cset))))))
+ (with-single-package-locked-error ()
+ (dolist (pkg packages)
+ (unless (member pkg (package-%use-list package))
+ (assert-package-unlocked package "using package~P ~{~A~^, ~}"
+ (length packages) packages)
+ (let ((cset ())
+ (shadowing-symbols (package-%shadowing-symbols package))
+ (use-list (package-%use-list package)))
+
+ ;; If the number of symbols already accessible is less than the
+ ;; number to be inherited then it is faster to run the test the
+ ;; other way. This is particularly valuable in the case of
+ ;; a new package USEing Lisp.
+ (cond
+ ((< (+ (package-internal-symbol-count package)
+ (package-external-symbol-count package)
+ (let ((res 0))
+ (dolist (p use-list res)
+ (incf res (package-external-symbol-count p)))))
+ (package-external-symbol-count pkg))
+ (do-symbols (sym package)
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) pkg)
+ (when (and w (not (eq s sym))
+ (not (member sym shadowing-symbols)))
+ (push sym cset))))
+ (dolist (p use-list)
+ (do-external-symbols (sym p)
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) pkg)
+ (when (and w (not (eq s sym))
+ (not (member (find-symbol (symbol-name sym)
+ package)
+ shadowing-symbols)))
+ (push sym cset))))))
+ (t
+ (do-external-symbols (sym pkg)
+ (multiple-value-bind (s w)
+ (find-symbol (symbol-name sym) package)
+ (when (and w (not (eq s sym))
+ (not (member s shadowing-symbols)))
+ (push s cset))))))
- (when cset
- (cerror
- "Unintern the conflicting symbols in the ~2*~A package."
- "Using package ~A results in name conflicts for these symbols:~%~
- ~S"
- (package-%name pkg) cset (package-%name package))
- (dolist (s cset) (moby-unintern s package))))
+ (when cset
+ (cerror
+ "Unintern the conflicting symbols in the ~2*~A package."
+ "Using package ~A results in name conflicts for these symbols:~%~
+ ~S"
+ (package-%name pkg) cset (package-%name package))
+ (dolist (s cset) (moby-unintern s package))))
- (push pkg (package-%use-list package))
- (push (package-external-symbols pkg) (cdr (package-tables package)))
- (push package (package-%used-by-list pkg)))))
+ (push pkg (package-%use-list package))
+ (push (package-external-symbols pkg) (cdr (package-tables package)))
+ (push package (package-%used-by-list pkg))))))
t)
(defun unuse-package (packages-to-unuse &optional (package (sane-package)))
#!+sb-doc
"Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."
- (let ((package (find-undeleted-package-or-lose package)))
- (dolist (p (package-listify packages-to-unuse))
- (setf (package-%use-list package)
- (remove p (the list (package-%use-list package))))
- (setf (package-tables package)
- (delete (package-external-symbols p)
- (the list (package-tables package))))
- (setf (package-%used-by-list p)
- (remove package (the list (package-%used-by-list p)))))
+ (let ((package (find-undeleted-package-or-lose package))
+ (packages (package-listify packages-to-unuse)))
+ (with-single-package-locked-error ()
+ (dolist (p packages)
+ (when (member p (package-use-list package))
+ (assert-package-unlocked package "unusing package~P ~{~A~^, ~}"
+ (length packages) packages))
+ (setf (package-%use-list package)
+ (remove p (the list (package-%use-list package))))
+ (setf (package-tables package)
+ (delete (package-external-symbols p)
+ (the list (package-tables package))))
+ (setf (package-%used-by-list p)
+ (remove package (the list (package-%used-by-list p))))))
t))
(defun find-all-symbols (string-or-symbol)
|