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 na... [truncated message content] |