From 807d6f0f10baa4f1d80c0d698bdd10a9b7b1fe2c Mon Sep 17 00:00:00 2001 From: emarsden <emarsden> Date: Mon, 12 May 2003 16:30:42 +0000 Subject: [PATCH] Add package locks. Bootfile boot8.lisp allows this to build without a cross-compile (or just select the CLOBBER-IT restart). - two extra PACKAGE-LOCK and PACKAGE-DEFINITION-LOCK slots added to the package structure. These can be modified using the EXT:PACKAGE-LOCK and EXT:PACKAGE-DEFINITION-LOCK accessors. - macro EXT:WITHOUT-PACKAGE-LOCKS that evaluates forms with all package locks disabled (this is done by binding the global variable CL::*ENABLE-PACKAGE-LOCKED-ERRORS*) - new PACKAGE-LOCKED-ERROR condition - in SETF-FDEFINITION-HOOK and in the DEFMACRO, DEFSTRUCT, DEFTYPE and DEFCLASS defining forms, check whether the definition would modify a package whose definition-lock is enabled, and signal a package-locked-error condition with restarts that allow you to unlock the package or ignore the lock - in EXPORT, UNEXPORT etc check whether the target package is guarded by a package-lock, and signal an error - disable package locks when loading a subsystem - disable package locks in certain areas of PCL and in the MAKE-LOAD-FORM support of the compiler, where code is generated inside system packages at runtime --- bootfiles/18e/boot8.lisp | 41 ++++++++ code/defstruct.lisp | 16 ++- code/exports.lisp | 9 +- code/macros.lisp | 36 ++++++- code/module.lisp | 5 +- code/package.lisp | 206 +++++++++++++++++++++++++++++++-------- compiler/main.lisp | 22 +++-- pcl/braid.lisp | 19 ++-- pcl/cache.lisp | 8 +- pcl/ctor.lisp | 17 ++-- pcl/defclass.lisp | 5 +- pcl/low.lisp | 31 +++--- 12 files changed, 317 insertions(+), 98 deletions(-) create mode 100644 bootfiles/18e/boot8.lisp diff --git a/bootfiles/18e/boot8.lisp b/bootfiles/18e/boot8.lisp new file mode 100644 index 000000000..92980c5a5 --- /dev/null +++ b/bootfiles/18e/boot8.lisp @@ -0,0 +1,41 @@ +;;; +;;; Bootfile for adding package locks. +;;; Use this file as bootstrap.lisp using Pierre Mai's build scripts, +;;; + +(in-package :lisp) + +(defvar *enable-package-locked-errors* nil) + +;;; +;;; Like DEFSTRUCT, but silently clobber old definitions. +;;; +(defmacro defstruct! (name &rest stuff) + `(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::clobber-it)))) + (defstruct ,name ,@stuff))) + + +(defstruct! (package + (:constructor internal-make-package) + (:predicate packagep) + (:print-function %print-package) + (:make-load-form-fun + (lambda (package) + (values `(package-or-lose ',(package-name package)) + nil)))) + (tables (list nil)) + (%name nil :type (or simple-string null)) + (%nicknames () :type list) + (%use-list () :type list) + (%used-by-list () :type list) + (internal-symbols (required-argument) :type package-hashtable) + (external-symbols (required-argument) :type package-hashtable) + (%shadowing-symbols () :type list) + (lock nil :type boolean) + (definition-lock nil :type boolean) + (doc-string nil :type (or simple-string null))) + + +;;; end of file diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 42432d9d2..df0c350ac 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.84 2003/03/30 18:43:59 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.85 2003/05/12 16:30:41 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -453,8 +453,20 @@ (let* ((defstruct (parse-name-and-options (if (atom name-and-options) (list name-and-options) - name-and-options))) + name-and-options))) (name (dd-name defstruct))) + (when cl::*enable-package-locked-errors* + (when (ext:package-definition-lock (symbol-package name)) + (restart-case + (error 'cl::package-locked-error + :package (symbol-package name) + :format-control "defining structure ~A" + :format-arguments (list name)) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Disable package's lock then continue" + (setf (ext:package-lock (symbol-package name)) nil))))) (when (stringp (car slot-descriptions)) (setf (dd-doc defstruct) (pop slot-descriptions))) (dolist (slot slot-descriptions) diff --git a/code/exports.lisp b/code/exports.lisp index e5253d80a..750ba0612 100644 --- a/code/exports.lisp +++ b/code/exports.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.206 2003/04/19 20:52:43 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.207 2003/05/12 16:30:41 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,7 +17,9 @@ (if (find-package "PCL") (rename-package "PCL" "PCL" 'nil) (make-package "PCL" :nicknames 'nil :use nil)) - +(if (find-package "CLOS-MOP") + (rename-package "CLOS-MOP" "CLOS-MOP" 'nil) + (make-package "CLOS-MOP" :nicknames 'nil :use nil)) (if (find-package "C-CALL") (rename-package "C-CALL" "C-CALL" 'nil) (make-package "C-CALL" :nicknames 'nil :use nil)) @@ -187,7 +189,9 @@ (:export "CADDR-T" "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN" "DADDR-T" "DEV-T" "DIRECT" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD" "F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN" + "FSFILCNT-T" "FSBLKCNT-T" "BLKCNT-T" "FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC" + "F_TEST" "F_TLOCK" "UNIX-LOCKF" "F_LOCK" "F_ULOCK" "F_OK" "GET-UNIX-ERROR-MSG" "GID-T" "INO-T" "IT-INTERVAL" "IT-VALUE" "ITIMERVAL" "UNIX-SETITIMER" "UNIX-GETITIMER" "BLKCNT-T" "FSBLKCNT-T" "FSFILCNT-T" @@ -990,6 +994,7 @@ "OBJECT-SET-EVENT-HANDLER" "OLD-TRACE" "OLD-UNTRACE" "ONCE-ONLY" "OPEN-CLX-DISPLAY" "OPTIMIZE-INTERFACE" "PACKAGE-CHILDREN" "PACKAGE-PARENT" "PARSE-TIME" + "PACKAGE-LOCK" "PACKAGE-DEFINITION-LOCK" "WITHOUT-PACKAGE-LOCKS" "PRINT-DIRECTORY" "PRINT-HERALD" "PRINT-PRETTY-KEY" "PRINT-PRETTY-KEY-EVENT" "PROCESS-ALIVE-P" "PROCESS-CLOSE" "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" diff --git a/code/macros.lisp b/code/macros.lisp index 343f15b53..9760e7dd0 100644 --- a/code/macros.lisp +++ b/code/macros.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.92 2003/04/19 20:52:43 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.93 2003/05/12 16:30:41 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -75,6 +75,23 @@ ;;; definition is done by %defmacro which we expand into. ;;; (defmacro defmacro (name lambda-list &body body) + (when cl::*enable-package-locked-errors* + (multiple-value-bind (valid block-name) + (ext:valid-function-name-p name) + (declare (ignore valid)) + (let ((package (symbol-package block-name))) + (when package + (when (ext:package-definition-lock package) + (restart-case + (error 'cl::package-locked-error + :package package + :format-control "defining macro ~A" + :format-arguments (list name)) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Disable the package's definition-lock then continue" + (setf (ext:package-definition-lock package) nil)))))))) (let ((whole (gensym "WHOLE-")) (environment (gensym "ENV-"))) (multiple-value-bind @@ -105,8 +122,7 @@ ;;; (defun c::%defmacro (name definition lambda-list doc) (assert (eval:interpreted-function-p definition)) - (setf (eval:interpreted-function-name definition) - (format nil "DEFMACRO ~S" name)) + (setf (eval:interpreted-function-name definition) name) (setf (eval:interpreted-function-arglist definition) lambda-list) (c::%%defmacro name definition doc)) ;;; @@ -188,7 +204,19 @@ "Syntax like DEFMACRO, but defines a new type." (unless (symbolp name) (simple-program-error "~S -- Type name not a symbol." name)) - + (and cl::*enable-package-locked-errors* + (symbol-package name) + (ext:package-definition-lock (symbol-package name)) + (restart-case + (error 'cl::package-locked-error + :package (symbol-package name) + :format-control "defining type ~A" + :format-arguments (list name)) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Disable package's definition-lock then continue" + (setf (ext:package-definition-lock (symbol-package name)) nil)))) (let ((whole (gensym "WHOLE-"))) (multiple-value-bind (body local-decs doc) (parse-defmacro arglist whole body name 'deftype diff --git a/code/module.lisp b/code/module.lisp index 00118dd0b..0ca540809 100644 --- a/code/module.lisp +++ b/code/module.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/module.lisp,v 1.7 2001/12/11 00:44:23 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/module.lisp,v 1.8 2003/05/12 16:30:41 emarsden Exp $") ;;; ;;; ********************************************************************** @@ -83,7 +83,8 @@ (list (module-default-pathname module-name)))) (*load-verbose* *require-verbose*)) (dolist (file files t) - (load file))))) + (ext:without-package-locks + (load file)))))) diff --git a/code/package.lisp b/code/package.lisp index b50a8cf28..b364794ef 100644 --- a/code/package.lisp +++ b/code/package.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.65 2003/05/09 14:15:55 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.66 2003/05/12 16:30:41 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -27,7 +27,8 @@ (in-package "EXTENSIONS") (export '(*keyword-package* *lisp-package* *default-package-use-list* - map-apropos package-children package-parent)) + map-apropos package-children package-parent + package-lock package-definition-lock without-package-locks)) (in-package "KERNEL") (export '(%in-package old-in-package %defpackage)) @@ -75,6 +76,15 @@ ;; List of shadowing symbols. (%shadowing-symbols () :type list) ;; + ;; Locks for this package. The PACKAGE-LOCK is a lock on the + ;; structure of the package, and controls modifications to its list + ;; of symbols and its export list. The PACKAGE-DEFINITION-LOCK + ;; protects all symbols in the package from being redefined. These + ;; are initially disabled, and are enabled by the function + ;; PACKAGE-LOCKS-INIT during after-save-initializations. + (lock nil :type boolean) + (definition-lock nil :type boolean) + ;; Documentation string for this package (doc-string nil :type (or simple-string null))) @@ -82,11 +92,15 @@ (defun %print-package (s stream d) (declare (ignore d) (stream stream)) (if (package-%name s) - (multiple-value-bind (iu it) (internal-symbol-count s) - (multiple-value-bind (eu et) (external-symbol-count s) - (print-unreadable-object (s stream) - (format stream "The ~A package, ~D/~D internal, ~D/~D external" - (package-%name s) iu it eu et)))) + (cond (*print-escape* + (multiple-value-bind (iu it) (internal-symbol-count s) + (multiple-value-bind (eu et) (external-symbol-count s) + (print-unreadable-object (s stream) + (format stream "The ~A package, ~D/~D internal, ~D/~D external" + (package-%name s) iu it eu et))))) + (t + (print-unreadable-object (s stream) + (format stream "The ~A package" (package-%name s))))) (print-unreadable-object (s stream :identity t) (format stream "deleted package")))) @@ -116,6 +130,74 @@ (defvar *keyword-package*) +(defvar *enable-package-locked-errors* nil) + + +(define-condition package-locked-error (simple-package-error) + () + (:report (lambda (condition stream) + (format stream "~&~@<Attempt to modify the locked package ~A, by ~3i~:_~?~:>" + (package-name (package-error-package condition)) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition))))) + +(defun package-locks-init () + (let ((package-names '("COMMON-LISP" "PCL" "CLOS-MOP" "EVAL" + "NEW-ASSEM" "DISASSEM" "LOOP" "ANSI-LOOP" "INSPECT" + "C" "PROFILE" "WIRE" "BIGNUM" "VM" + "FORMAT" "DFIXNUM" "PRETTY-PRINT" "C-CALL" "ALIEN" + "ALIEN-INTERNALS" "UNIX" + "CONDITIONS" "DEBUG" "DEBUG-INTERNALS" "SYSTEM" + "KERNEL" "EXTENSIONS" #+mp "MULTIPROCESSING" + "WALKER" "XREF"))) + (dolist (p package-names) + (let ((p (find-package p))) + (when p + (setf (package-definition-lock p) t) + (setf (package-lock p) t)))) + (setf *enable-package-locked-errors* t) + (push 'redefining-function ext:*setf-fdefinition-hook*)) + (values)) + +(pushnew 'package-locks-init ext:*after-save-initializations*) + + +(defmacro without-package-locks (&body body) + `(let ((*enable-package-locked-errors* nil)) + ,@body)) + + +;; trap attempts to redefine a function in a locked package, and +;; signal a continuable error. +(defun redefining-function (function replacement) + (declare (ignore replacement)) + (when *enable-package-locked-errors* + (multiple-value-bind (valid block-name) + (ext:valid-function-name-p function) + (declare (ignore valid)) + (let ((package (symbol-package block-name))) + (when package + (when (package-definition-lock package) + (when (and (consp function) + (member (first function) + '(pcl::slot-accessor + pcl::method + pcl::fast-method + pcl::effective-method + pcl::ctor))) + (return-from redefining-function nil)) + (restart-case + (error 'package-locked-error + :package package + :format-control "redefining function ~A" + :format-arguments (list function)) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Disable package's definition-lock then continue" + (setf (ext:package-definition-lock package) nil))))))))) + + ;;; This magical variable is T during initialization so Use-Package's of packages ;;; that don't yet exist quietly win. Such packages are thrown onto the list ;;; *Deferred-Use-Packages* so that this can be fixed up later. @@ -173,7 +255,7 @@ ;;; #+relative-package-names (defun package-parent (package-specifier) - "Given package-specifier, a package, symbol or string, return the + "Given PACKAGE-SPECIFIER, a package, symbol or string, return the parent package. If there is not a parent, signal an error." (declare (optimize (speed 3))) (flet ((find-last-dot (name) @@ -205,7 +287,7 @@ ;;; #+relative-package-names (defun package-children (package-specifier &key (recurse t)) - "Given package-specifier, a package, symbol or string, return all the + "Given PACKAGE-SPECIFIER, a package, symbol or string, return all the packages which are in the hierarchy 'under' the given package. If :recurse is nil, then only return the immediate children of the package." (declare (optimize (speed 3))) @@ -893,7 +975,7 @@ ',imports ',interns ',exports ',doc)))) (defun check-disjoint (&rest args) - ;; Check wether all given arguments specify disjoint sets of symbols. + ;; Check whether all given arguments specify disjoint sets of symbols. ;; Each argument is of the form (:key . set). (loop for (current-arg . rest-args) on args do @@ -950,7 +1032,7 @@ (let ((laterize (set-difference old-use-list new-use-list))) (when laterize (unuse-package laterize package) - (warn "~A used to use the following packages:~% ~S" + (warn "~A previously used the following packages:~% ~S" name laterize))))) ;; Import and Intern. @@ -1055,9 +1137,9 @@ ;;; Like Make-Package, only different. Should go away someday. ;;; (defun old-in-package (name &rest keys &key nicknames use) - "Sets *package* to package with given name, creating the package if + "Sets *PACKAGE* to package with given NAME, creating the package if it does not exist. If the package already exists then it is modified - to agree with the :Use and :Nicknames arguments. Any new nicknames + to agree with the :USE and :NICKNAMES arguments. Any new nicknames are added without removing any old ones not specified. If any package in the :Use list is not currently used, then it is added to the use list." @@ -1120,7 +1202,7 @@ ;;; Delete-Package -- Public ;;; (defun delete-package (package-or-name) - "Delete the package-or-name from the package system data structures." + "Delete the PACKAGE-OR-NAME from the package system data structures." (let ((package (if (packagep package-or-name) package-or-name (find-package package-or-name)))) @@ -1174,17 +1256,17 @@ ;;; (defun intern (name &optional package) "Returns a symbol having the specified name, creating it if necessary." - (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) - (declare (simple-string name)) - (intern* name (length name) - (if package (package-or-lose package) *package*)))) + (let ((name (if (simple-string-p name) name (coerce name 'simple-string))) + (package (if package (package-or-lose package) *package*))) + (declare (type simple-string name)) + (intern* name (length name) package))) ;;; Find-Symbol -- Public ;;; ;;; Ditto. ;;; (defun find-symbol (name &optional package) - "Returns the symbol named String in Package. If such a symbol is found + "Returns the symbol NAME in PACKAGE. If such a symbol is found then the second value is :internal, :external or :inherited to indicate how the symbol is accessible. If no symbol is found then both values are NIL." @@ -1203,14 +1285,28 @@ (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))))) + (progn + #+nil + (when *enable-package-locked-errors* + (when (ext:package-lock package) + (restart-case + (error 'package-locked-error + :package package + :format-control "interning symbol ~A" + :format-arguments (list (subseq name 0 length))) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Unlock package then continue" + (setf (ext:package-lock package) nil))))) + (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)))))) ;;; find-symbol* -- Internal ;;; @@ -1264,13 +1360,25 @@ ;;; result, otherwise just nuke the symbol. ;;; (defun unintern (symbol &optional (package *package*)) - "Makes Symbol no longer present in Package. If Symbol was present - then T is returned, otherwise NIL. If Package is Symbol's home + "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present + then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home package, then it is made uninterned." (let* ((package (package-or-lose package)) (name (symbol-name symbol)) (shadowing-symbols (package-%shadowing-symbols package))) (declare (list shadowing-symbols) (simple-string name)) + (when *enable-package-locked-errors* + (when (ext:package-lock package) + (restart-case + (error 'package-locked-error + :package package + :format-control "uninterning symbol ~A" + :format-arguments (list name)) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Disable package's lock then continue" + (setf (ext:package-lock package) nil))))) ;; ;; If a name conflict is revealed, give use a chance to shadowing-import ;; one of the accessible symbols. @@ -1350,7 +1458,7 @@ ;;; Do more stuff. ;;; (defun export (symbols &optional (package *package*)) - "Exports Symbols from Package, checking that no name conflicts result." + "Exports SYMBOLS from PACKAGE, checking that no name conflicts result." (let ((package (package-or-lose package)) (syms ())) ;; @@ -1427,9 +1535,21 @@ ;;; internal. ;;; (defun unexport (symbols &optional (package *package*)) - "Makes Symbols no longer exported from Package." + "Makes SYMBOLS no longer exported from PACKAGE." (let ((package (package-or-lose package)) (syms ())) + (when *enable-package-locked-errors* + (when (ext:package-lock package) + (restart-case + (error 'package-locked-error + :package package + :format-control "unexporting symbols ~A" + :format-arguments (list symbols)) + (continue () + :report "Ignore the lock and continue") + (unlock-package () + :report "Disable package's lock then continue" + (setf (ext:package-lock package) nil))))) (dolist (sym (symbol-listify symbols)) (multiple-value-bind (s w) (find-symbol (symbol-name sym) package) (cond ((or (not w) (not (eq s sym))) @@ -1452,7 +1572,7 @@ ;;; shadowing-import if there is. ;;; (defun import (symbols &optional (package *package*)) - "Make Symbols accessible as internal symbols in Package. If a symbol + "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 (package-or-lose package)) @@ -1495,7 +1615,7 @@ ;;; stick the symbol in. ;;; (defun shadowing-import (symbols &optional (package *package*)) - "Import Symbols into package, disregarding any name conflict. If + "Import SYMBOLS into PACKAGE, disregarding any name conflict. If a symbol of the same name is present, then it is uninterned. The symbols are added to the Package-Shadowing-Symbols." (let* ((package (package-or-lose package)) @@ -1518,9 +1638,9 @@ ;;; ;;; (defun shadow (symbols &optional (package *package*)) - "Make an internal symbol in Package with the same name as each of the - specified symbols, adding the new symbols to the Package-Shadowing-Symbols. - If a symbol with the given name is already present in Package, then + "Make an internal symbol in PACKAGE with the same name as each of the + specified SYMBOLS, adding the new symbols to the Package-Shadowing-Symbols. + If a symbol with the given name is already present in PACKAGE, then the existing symbol is placed in the shadowing symbols list if it is not already present." (let* ((package (package-or-lose package)) @@ -1543,9 +1663,9 @@ ;;; checking. ;;; (defun use-package (packages-to-use &optional (package *package*)) - "Add all the Package-To-Use to the use list for Package so that + "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that the external symbols of the used packages are accessible as internal - symbols in Package." + symbols in PACKAGE." (let ((packages (package-listify packages-to-use)) (package (package-or-lose package))) ;; @@ -1607,7 +1727,7 @@ ;;; ;;; (defun unuse-package (packages-to-unuse &optional (package *package*)) - "Remove Packages-To-Unuse from the use list for Package." + "Remove PACKAGES-TO-UNUSE from the use list for PACKAGE." (let ((package (package-or-lose package))) (dolist (p (package-listify packages-to-unuse)) (setf (package-%use-list package) @@ -1746,9 +1866,9 @@ ;;; APROPOS -- public. ;;; (defun apropos (string &optional package external-only) - "Briefly describe all symbols which contain the specified String. - If Package is supplied then only describe symbols present in - that package. If External-Only is true then only describe + "Briefly describe all symbols which contain the specified STRING. + If PACKAGE is supplied then only describe symbols present in + that package. If EXTERNAL-ONLY is non-NIL then only describe external symbols in the specified package." (map-apropos #'briefly-describe-symbol string package external-only) (values)) @@ -1756,7 +1876,7 @@ ;;; APROPOS-LIST -- public. ;;; (defun apropos-list (string &optional package external-only) - "Identical to Apropos, except that it returns a list of the symbols + "Identical to APROPOS, except that it returns a list of the symbols found instead of describing them." (collect ((result)) (map-apropos #'(lambda (symbol) diff --git a/compiler/main.lisp b/compiler/main.lisp index 0f14f093c..5cbb82013 100644 --- a/compiler/main.lisp +++ b/compiler/main.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.134 2003/04/11 14:24:22 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.135 2003/05/12 16:30:42 emarsden Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1189,7 +1189,8 @@ (let* ((*lexical-environment* (make-null-environment)) (lambda (ir1-top-level form *current-path* for-value))) (setf (leaf-name lambda) name) - (compile-top-level (list lambda) t) + (ext:without-package-locks + (compile-top-level (list lambda) t)) lambda))) ;;; COMPILE-LOAD-TIME-VALUE-LAMBDA -- internal. @@ -1269,13 +1270,15 @@ (creation-form init-form) (handler-case (if (fboundp 'lisp::make-load-form) - (locally - (declare (optimize (inhibit-warnings 3))) - (lisp::make-load-form constant (make-null-environment))) - (make-structure-load-form constant)) + (locally + (declare (optimize (inhibit-warnings 3))) + (ext:without-package-locks + (lisp::make-load-form constant (make-null-environment)))) + (ext:without-package-locks + (make-structure-load-form constant))) (error (condition) - (compiler-error "(while making load form for ~S)~%~A" - constant condition))) + (compiler-error "(while making load form for ~S)~%~A" + constant condition))) (case creation-form (:just-dump-it-normally (fasl-validate-structure constant *compile-object*) @@ -1806,7 +1809,8 @@ ;; Hack around filesystem race condition... (or (probe-file output-file-pathname) output-file-pathname) nil) - (not (null error-severity)) + (if (member error-severity '(:warning :error)) t nil) + ;; FIXME in the following we should not return t for a STYLE-WARNING (if (member error-severity '(:warning :error)) t nil)))) ;;;; COMPILE and UNCOMPILE: diff --git a/pcl/braid.lisp b/pcl/braid.lisp index f52825c8d..590205abb 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.37 2003/05/11 11:30:35 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.38 2003/05/12 16:30:42 emarsden Exp $") ;;; ;;; Bootstrapping the meta-braid. @@ -518,14 +518,15 @@ (let* ((class (kernel::find-class name)) (kernel-supers (kernel:%class-direct-superclasses class)) (supers (mapcar #'kernel:%class-name kernel-supers))) - (if slotsp - (ensure-class-using-class - existing-class name :metaclass metaclass :name name - :direct-superclasses supers - :direct-slots slots) - (ensure-class-using-class - existing-class name :metaclass metaclass :name name - :direct-superclasses supers)))) + (ext:without-package-locks + (if slotsp + (ensure-class-using-class + existing-class name :metaclass metaclass :name name + :direct-superclasses supers + :direct-slots slots) + (ensure-class-using-class + existing-class name :metaclass metaclass :name name + :direct-superclasses supers))))) (slot-initargs-from-structure-slotd (slotd) (let ((accessor (structure-slotd-accessor-symbol slotd))) `(:name ,(structure-slotd-name slotd) diff --git a/pcl/cache.lisp b/pcl/cache.lisp index f18239107..95dac9346 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.29 2003/05/04 13:11:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/cache.lisp,v 1.30 2003/05/12 16:30:42 emarsden Exp $") ;;; ;;; The basics of the PCL wrapper cache mechanism. @@ -725,7 +725,8 @@ (defun dfun-arg-symbol (arg-number) (or (nth arg-number (the list *dfun-arg-symbols*)) - (intern (format nil ".ARG~A." arg-number) *the-pcl-package*))) + (ext:without-package-locks + (intern (format nil ".ARG~A." arg-number) *the-pcl-package*)))) (defun dfun-arg-symbol-list (metatypes) (loop for i from 0 and s in metatypes @@ -735,7 +736,8 @@ (defun slot-vector-symbol (arg-number) (or (nth arg-number (the list *slot-vector-symbols*)) - (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*))) + (ext:without-package-locks + (intern (format nil ".SLOTS~A." arg-number) *the-pcl-package*)))) (defun make-dfun-lambda-list (metatypes applyp) (if applyp diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp index 7c07aae84..e95c27506 100644 --- a/pcl/ctor.lisp +++ b/pcl/ctor.lisp @@ -46,7 +46,7 @@ ;;; is called. (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.8 2003/05/04 13:11:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.9 2003/05/12 16:30:42 emarsden Exp $") (in-package "PCL") @@ -175,7 +175,8 @@ (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) (if (array-in-bounds-p ps i) (aref ps i) - (intern (format nil ".P~D." i) *the-pcl-package*)))) + (ext:without-package-locks + (intern (format nil ".P~D." i) *the-pcl-package*))))) ;; ;; Check if CLASS-NAME is a constant symbol. Give up if ;; not. @@ -220,10 +221,11 @@ ;; Return code constructing a ctor at load time, which, when ;; called, will set its funcallable instance function to an ;; optimized constructor function. - `(let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) - (declare (ignore .x.)) - (funcall (function ,function-name) ,@value-forms))))))) + `(ext:without-package-locks + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + (funcall (function ,function-name) ,@value-forms)))))))) ;;; ************************************************** @@ -493,7 +495,8 @@ (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) (aref ps i) - (intern (format nil ".D~D." i) *the-pcl-package*))))) + (ext:without-package-locks + (intern (format nil ".D~D." i) *the-pcl-package*)))))) ;; ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index fda35f639..358e0979e 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.27 2003/05/04 13:11:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.28 2003/05/12 16:30:42 emarsden Exp $") ;;; (in-package :pcl) @@ -73,7 +73,8 @@ ;;; (defmacro defclass (name direct-superclasses direct-slots &rest options &environment env) - (expand-defclass name direct-superclasses direct-slots options env)) + (ext:without-package-locks + (expand-defclass name direct-superclasses direct-slots options env))) ;;; The following functions were moved here from slots-boot.lisp ;;; because expand-defclass now depends on them to generate ftype diff --git a/pcl/low.lisp b/pcl/low.lisp index 2725ba853..c872f5080 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.26 2003/05/07 17:15:48 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.27 2003/05/12 16:30:42 emarsden Exp $") ;;; ;;; This file contains optimized low-level constructs for PCL. @@ -106,23 +106,24 @@ (declare (special *boot-state* *the-class-standard-generic-function*)) (when (valid-function-name-p function) (setq function (fdefinition function))) - (when (funcallable-instance-p function) - (if (if (eq *boot-state* 'complete) - (typep function 'generic-function) - (eq (class-of function) *the-class-standard-generic-function*)) - (setf (kernel:%funcallable-instance-info function 1) new-name) - (typecase function - (kernel:byte-closure - (set-function-name (kernel:byte-closure-function function) - new-name)) - (kernel:byte-function - (setf (kernel:byte-function-name function) new-name)) - (eval:interpreted-function - (setf (eval:interpreted-function-name function) new-name))))) + (ext:without-package-locks + (when (funcallable-instance-p function) + (if (if (eq *boot-state* 'complete) + (typep function 'generic-function) + (eq (class-of function) *the-class-standard-generic-function*)) + (setf (kernel:%funcallable-instance-info function 1) new-name) + (typecase function + (kernel:byte-closure + (set-function-name (kernel:byte-closure-function function) + new-name)) + (kernel:byte-function + (setf (kernel:byte-function-name function) new-name)) + (eval:interpreted-function + (setf (eval:interpreted-function-name function) new-name)))))) (when (memq (car-safe new-name) '(method fast-method slot-accessor)) (setf (fdefinition new-name) function)) function) - + (defun symbolicate* (pkg &rest things) (let ((*package* pkg)) (apply #'symbolicate things))) -- GitLab