From ff92598854bf7cae8d57fe49cef4d9a98e1ab345 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 29 Jun 2004 08:50:51 +0000 Subject: [PATCH] 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). --- build-order.lisp-expr | 3 + contrib/sb-aclrepl/debug.lisp | 8 +- contrib/sb-aclrepl/inspect.lisp | 3 +- contrib/sb-grovel/defpackage.lisp | 7 +- contrib/sb-grovel/foreign-glue.lisp | 6 +- contrib/sb-simple-streams/package.lisp | 3 + contrib/sb-sprof/sb-sprof.lisp | 40 +- doc/manual/Makefile | 1 + doc/manual/make-tempfiles.sh | 17 +- doc/manual/package-locks-basic.texinfo | 7 + doc/manual/package-locks-extended.texinfo | 333 +++++++++++++ doc/manual/sbcl.texinfo | 2 + make-target-2.sh | 6 + package-data-list.lisp-expr | 22 + src/code/cold-init.lisp | 1 + src/code/condition.lisp | 212 +++++--- src/code/cross-misc.lisp | 31 ++ src/code/debug-int.lisp | 37 +- src/code/defboot.lisp | 2 +- src/code/defpackage.lisp | 64 ++- src/code/defstruct.lisp | 23 +- src/code/early-fasl.lisp | 4 +- src/code/early-package.lisp | 66 +++ src/code/early-pprint.lisp | 22 +- src/code/early-setf.lisp | 2 + src/code/eval.lisp | 17 +- src/code/fdefinition.lisp | 55 +- src/code/fop.lisp | 7 +- src/code/macros.lisp | 2 + src/code/package.lisp | 7 +- src/code/profile.lisp | 11 +- src/code/symbol.lisp | 15 +- src/code/target-package.lisp | 775 +++++++++++++++++++---------- src/cold/shared.lisp | 8 + src/cold/warm.lisp | 4 +- src/compiler/assem.lisp | 47 +- src/compiler/compiler-deftype.lisp | 2 + src/compiler/early-c.lisp | 1 + src/compiler/fndb.lisp | 1 + src/compiler/info-functions.lisp | 6 +- src/compiler/ir1-translators.lisp | 103 ++-- src/compiler/ir1tran.lisp | 13 + src/compiler/ir1util.lisp | 6 +- src/compiler/lexenv.lisp | 4 +- src/compiler/main.lisp | 17 +- src/compiler/policy.lisp | 5 +- src/compiler/proclaim.lisp | 22 + src/compiler/target-main.lisp | 2 + src/pcl/boot.lisp | 28 +- src/pcl/braid.lisp | 7 +- src/pcl/cache.lisp | 4 +- src/pcl/combin.lisp | 7 +- src/pcl/ctor.lisp | 72 +-- src/pcl/defclass.lisp | 48 +- src/pcl/defcombin.lisp | 11 +- src/pcl/defs.lisp | 10 +- src/pcl/dlisp.lisp | 7 +- src/pcl/early-low.lisp | 11 + src/pcl/low.lisp | 12 +- src/pcl/macros.lisp | 30 +- src/pcl/methods.lisp | 7 +- src/pcl/std-class.lisp | 173 ++++--- src/pcl/vector.lisp | 47 +- src/runtime/mips-arch.c | 2 - src/runtime/mips-lispregs.h | 2 - tests/clos.impure-cload.lisp | 2 +- tests/compiler.impure-cload.lisp | 4 +- tests/compiler.impure.lisp | 7 +- tests/package-locks.impure.lisp | 439 ++++++++++++++++ tests/seq.impure.lisp | 10 +- version.lisp-expr | 2 +- 71 files changed, 2214 insertions(+), 780 deletions(-) create mode 100644 doc/manual/package-locks-basic.texinfo create mode 100644 doc/manual/package-locks-extended.texinfo create mode 100644 src/code/early-package.lisp create mode 100644 tests/package-locks.impure.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 1c85be4..7a25279 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -133,6 +133,9 @@ ("src/code/target-extensions" :not-host) + ;; Needed before the first use of WITH-SINGLE-PACKAGE-LOCKED-ERROR. + ("src/code/early-package" :not-host) + ("src/code/early-defstructs" :not-host) ; gotta-be-first DEFSTRUCTs ("src/code/defbangstruct") diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp index 2b8787a..76eef97 100644 --- a/contrib/sb-aclrepl/debug.lisp +++ b/contrib/sb-aclrepl/debug.lisp @@ -6,9 +6,11 @@ (cl:in-package :sb-aclrepl) - +;;; FIXME: These declaims violate package locks. Are they needed at +;;; all? Seems not. +#+ignore (declaim (special - sb-debug::*debug-command-level sb-debug::*debug-command-level* + sb-debug::*debug-command-level* sb-debug::*real-stack-top* sb-debug::*stack-top* sb-debug::*stack-top-hint* sb-debug::*current-frame* sb-debug::*flush-debug-errors*)) @@ -45,7 +47,7 @@ (if (zerop *break-level*) ; restart added by SBCL (repl :continuable continuable) - (let ((level *break-level*)) + (let ((level *break-level*)) (with-simple-restart (abort "~@" level) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index b09fc59..f807776 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -12,7 +12,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +default-inspect-length+ 20)) -(defstruct inspect +(defstruct (%inspect (:constructor make-inspect) + (:conc-name inspect-)) ;; stack of parents of inspected object object-stack ;; a stack of indices of parent object components diff --git a/contrib/sb-grovel/defpackage.lisp b/contrib/sb-grovel/defpackage.lisp index ffeb518..5f161b1 100644 --- a/contrib/sb-grovel/defpackage.lisp +++ b/contrib/sb-grovel/defpackage.lisp @@ -1,4 +1,9 @@ (defpackage "SB-GROVEL" (:export "GROVEL-CONSTANTS-FILE") + (:shadow "TYPE" "UNION") + ;; FIXME: This is a really quick and dirty package lock compliance + ;; fix, that should be redone. Specifically, this is needed to address the + ;; nasty things done with SB-ALIEN:STRUCT. + #+sb-package-locks + (:implement "SB-ALIEN") (:use "COMMON-LISP" "SB-ALIEN" "ASDF" "SB-EXT")) - diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index c15509f..e07bb59 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -303,14 +303,14 @@ deeply nested structures." (labels ((accessor (root rpath) (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root)))))) `((defun ,(intern accessor-name) (struct) - (declare (type (alien ,struct-name) struct) + (declare (cl:type (alien ,struct-name) struct) (optimize (speed 3))) (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel)) :getter) ,(accessor root rpath) ,(size root))) (defun (setf ,(intern accessor-name)) (new-val struct) - (declare (type (alien ,struct-name) struct) - (type ,(lisp-type-for (type root) (size root)) new-val) + (declare (cl:type (alien ,struct-name) struct) + (cl:type ,(lisp-type-for (type root) (size root)) new-val) (optimize (speed 3))) ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root) (find-package :sb-grovel)) diff --git a/contrib/sb-simple-streams/package.lisp b/contrib/sb-simple-streams/package.lisp index 622fb5c..8e80524 100644 --- a/contrib/sb-simple-streams/package.lisp +++ b/contrib/sb-simple-streams/package.lisp @@ -11,6 +11,9 @@ (:use #:common-lisp) (:import-from #:sb-kernel #:ansi-stream #:charpos #:line-length) (:import-from #:sb-gray #:fundamental-stream) + #+sb-package-locks + ;; FIXME: Using deffoo! or equivalent might be nicer. + (:implement #:common-lisp #:sb-kernel #:sb-int) (:export ;; Stream classes #:STREAM #:SIMPLE-STREAM diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index fdeba62..eb0640e 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -202,14 +202,14 @@ (defun topological-sort (dag) (let ((sorted ()) (dfn -1)) - (labels ((sort (v) + (labels ((rec-sort (v) (setf (vertex-visited v) t) (setf (vertex-dfn v) (incf dfn)) (dolist (e (vertex-edges v)) (unless (vertex-visited (edge-vertex e)) - (sort (edge-vertex e)))) + (rec-sort (edge-vertex e)))) (push v sorted))) - (map-vertices #'sort dag) + (map-vertices #'rec-sort dag) (nreverse sorted)))) ;;; Reduce graph G to a dag by coalescing strongly connected components @@ -382,7 +382,7 @@ (rotatef (aref vec i) (aref vec j)))) (key (i) (aref vec (+ i key-offset))) - (sort (from to) + (rec-sort (from to) (when (> to from) (let* ((mid (* element-size (round (+ (/ from element-size) @@ -403,9 +403,9 @@ (when (< j i) (return)) (rotate i j)) (rotate from j) - (sort from (- j element-size)) - (sort i to))))) - (sort from to) + (rec-sort from (- j element-size)) + (rec-sort i to))))) + (rec-sort from to) vec)) @@ -1013,7 +1013,7 @@ (format t "~& Count % Parts~%") (do-vertices (node call-graph) (when (cycle-p node) - (flet ((print (indent index count percent name) + (flet ((print-info (indent index count percent name) (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" count percent indent name index))) (print-separator) @@ -1022,9 +1022,9 @@ (samples-percent call-graph (cycle-count node)) (node-name node)) (dolist (v (vertex-scc-vertices node)) - (print 4 (node-index v) (node-count v) - (samples-percent call-graph (node-count v)) - (node-name v)))))) + (print-info 4 (node-index v) (node-count v) + (samples-percent call-graph (node-count v)) + (node-name v)))))) (print-separator) (format t "~2%"))) @@ -1036,7 +1036,7 @@ (print-cycles call-graph) (flet ((find-call (from to) (find to (node-edges from) :key #'call-vertex)) - (print (indent index count percent name) + (print-info (indent index count percent name) (format t "~&~6d ~5,1f ~11@t ~V@t ~s [~d]~%" count percent indent name index))) (format t "~& Callers~%") @@ -1048,10 +1048,10 @@ ;; Print caller information. (dolist (caller (node-callers node)) (let ((call (find-call caller node))) - (print 4 (node-index caller) - (call-count call) - (samples-percent call-graph (call-count call)) - (node-name caller)))) + (print-info 4 (node-index caller) + (call-count call) + (samples-percent call-graph (call-count call)) + (node-name caller)))) ;; Print the node itself. (format t "~&~6d ~5,1f ~6d ~5,1f ~s [~d]~%" (node-count node) @@ -1062,10 +1062,10 @@ (node-index node)) ;; Print callees. (do-edges (call called node) - (print 4 (node-index called) - (call-count call) - (samples-percent call-graph (call-count call)) - (node-name called)))) + (print-info 4 (node-index called) + (call-count call) + (samples-percent call-graph (call-count call)) + (node-name called)))) (print-separator) (format t "~2%") (print-flat call-graph :stream stream :max max diff --git a/doc/manual/Makefile b/doc/manual/Makefile index bbb8fa3..c9b03dd 100644 --- a/doc/manual/Makefile +++ b/doc/manual/Makefile @@ -91,6 +91,7 @@ clean: rm -f *~ *.bak *.orig \#*\# .\#* texput.log *.fasl rm -rf $(HTMLDIR) $(DOCSTRINGDIR) rm -f contrib-docs.texi-temp + rm -f package-locks.texi-temp rm -f $(PSFILE) $(PDFFILE) $(DVIFILE) html-stamp tempfiles-stamp rm -f $(TMPFILES) contrib-doc-list.texi-temp rm -f sbcl.info sbcl.info-* diff --git a/doc/manual/make-tempfiles.sh b/doc/manual/make-tempfiles.sh index 629e68c..777d03c 100644 --- a/doc/manual/make-tempfiles.sh +++ b/doc/manual/make-tempfiles.sh @@ -15,12 +15,13 @@ # We create the documentation from the in-tree sbcl if it is found, # else an installed sbcl is used. sbclsystem=`pwd`/../../src/runtime/sbcl -if [ -e $sbclsystem ] +sbclcore=`pwd`/../../output/sbcl.core +if [ -e $sbclsystem ] && [ -e $sbclcore ] then -SBCL="${1:-$sbclsystem --core `pwd`/../../output/sbcl.core}" -export SBCL_HOME=`pwd`/../../contrib + SBCL="${1:-$sbclsystem --core $sbclcore}" + export SBCL_HOME=`pwd`/../../contrib else -SBCL="${1:-`which sbcl`}" + SBCL="${1:-`which sbcl`}" fi # Output directory. This has to end with a slash (it's interpreted by @@ -41,3 +42,11 @@ echo "(progn (load \"docstrings.lisp\") (dolist (module (quote ($MODULES))) (req echo /creating contrib-docs.texi-temp echo "(load \"create-contrib-doc-list.lisp\")" | $SBCL --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger + +echo /creating package-locks.texi-temp +if $SBCL --noinform --sysinit /dev/null --userinit /dev/null --noprint --disable-debugger --eval '(quit :unix-status #+sb-package-locks 0 #-sb-package-locks 1)' +then + cp package-locks-extended.texinfo package-locks.texi-temp +else + cp package-locks-basic.texinfo package-locks.texi-temp +fi diff --git a/doc/manual/package-locks-basic.texinfo b/doc/manual/package-locks-basic.texinfo new file mode 100644 index 0000000..d5fa812 --- /dev/null +++ b/doc/manual/package-locks-basic.texinfo @@ -0,0 +1,7 @@ +@node Package Locks +@chapter Package Locks + +SBCL does not currently include package locking support by default. To +build SBCL with package locking enabled add @code{:sb-package-locks} +to target @code{*features*} as per instructions in the file +@file{INSTALL}. diff --git a/doc/manual/package-locks-extended.texinfo b/doc/manual/package-locks-extended.texinfo new file mode 100644 index 0000000..8a1435d --- /dev/null +++ b/doc/manual/package-locks-extended.texinfo @@ -0,0 +1,333 @@ +@include package-locks-basic.texinfo + +None of the following sections apply to SBCL built +without package locks. + +The interface described here is experimental: incompatible changes +in future SBCL releases are possible, even expected. + +@menu +* Package Locking Overview:: +* Implementation Packages:: +* Package Locked Errors:: +* Package Locks in Compiled Code:: +* Package Lock Violations:: +* Package Lock Dictionary:: +@end menu + +@node Package Locking Overview +@section Package Locking Overview +Package locks protect against unintentional modifications of a +package: they provide similar protection to user packages as is +mandated to @code{common-lisp} package by the ANSI specification. They +are not, and should not be used as a security measure. + +Newly created packages are by default unlocked (see the @code{:lock} +option to @code{defpackage}). + +The package @code{common-lisp} and SBCL internal implementation +packages are locked by default, including @code{sb-ext}. + +It may be beneficial to lock @code{common-lisp-user} as well, to +ensure that various libraries don't pollute it without asking, +but this is not currently done by default. + +@node Implementation Packages +@section Implementation Packages + +Each package has a list of associated implementation packages. A +locked package, and the symbols whose home package it is, can be +modified without violating package locks only when @code{*package*} is +bound to one of the implementation packages of the locked package. + +Unless explicitly altered by @code{defpackage}, +@code{sb-ext:add-implementation-package}, or +@code{sb-ext:remove-implementation-package} each package is its own +(only) implementation package. + +@node Package Locked Errors +@section Package Locked Errors + +If an operation violates a package lock, a continuable error that is +of a subtype of @code{sb-ext:package-lock-violation} (subtype of +@code{package-error}) is signalled when the operation is attempted. + +Additional restarts may be established for continuable package lock +violations for interactive use. + +The actual type of the error depends on circumstances that caused the +violation: operations on packages signal errors of type +@code{sb-ext:package-locked-error}, and operations on symbols signal +errors of type @code{sb-ext:symbol-package-locked-error}. + +@node Package Locks in Compiled Code +@section Package Locks in Compiled Code + +@subsection Lexical bindings and declarations + +Compiling lexical binding constructs or lexical declarations that +violate package locks package cause a compile-time package-lock +violation. A complete listing of operators affect by this is: +@code{let}, @code{let*}, @code{flet}, @code{labels}, @code{macrolet}, +and @code{symbol-macrolet}, @code{declare}. + +Package locks affecting both lexical bindings and declarations can be +disabled at compile-time with @code{sb-ext:disable-package-locks} +declaration, and re-enabled with @code{sb-ext:enable-package-locks} +declaration. Constructs compiled with package locks thusly disabled +are guaranteed not to signal package lock violation errors at runtime. + +Example: + +@lisp +(in-package :locked) + +(defun foo () ...) + +(defmacro with-foo (&body body) + `(locally (declare (disable-package-locks locked:foo)) + (flet ((foo () ...)) + (declare (enable-package-locks locked:foo)) ; re-enable for body + ,@@body))) +@end lisp + +@subsection Interned symbols + +If compiled code contains interned symbols, then loading that code +into an image without the said symbols will not cause a package lock +violation even if the packages in question are locked. + +@subsection Other limitations on compiled code + +With the exception of the aforementioned contructs, and interned +symbols, behaviour is unspecified if package locks affecting compiled +code are not the same during loading of the code or execution. + +Specifically, code compiled with packages unlocked may or may not fail +to signal package-lock-violations even if the packages are locked at +runtime, and code compiled with packages locked may or may not signal +spurious package-lock-violations at runtime even if the packages are +unlocked. + +In practise all this means that package-locks have a neglible +performance penalty in compiled code as long as they are not violated. + +@node Package Lock Violations +@section Package Lock Violations + +@heading Operations on Packages + +Following actions cause a package lock violation if the package +operated on is locked, and @code{*package*} is not an implementation +package of that package, and the action would cause a change in the +state of the package (eg. exporting already external symbols is +allowed). Package lock violations caused by these operations signal +errors of type @code{sb-ext:package-locked-error}. + +@enumerate +@item +Shadowing a symbol in a package. + +@item +Importing a symbol to a package. + +@item +Uninterning a symbol from a package. + +@item +Exporting a symbol from a package. + +@item +Unexporting a symbol from a package. + +@item +Changing the packages used by a package. + +@item +Renaming a package. + +@item +Deleting a package. + +@end enumerate + +@heading Operations on Symbols + +Following actions cause a package lock violation if the home package +of the symbol operated on is locked, and @code{*package*} is not an +implementation package of that package. Package lock violations caused +by these action signal errors of type +@code{sb-ext:symbol-package-locked-error}. + +These actions cause only one package lock violation per lexically +apparent violated package. + +Example: + +@lisp +;; Packages FOO and BAR are locked. +;; +;; Two lexically apparent violated packages: exactly two +;; package-locked-errors will be signalled. + +(defclass foo:point () + ((x :accessor bar:x) + (y :accessor bar:y))) +@end lisp + +@enumerate +@item +Binding or altering its value lexically or dynamically, or +establishing it as a symbol-macro. + +Exceptions: + +@itemize @minus +@item +If the symbol is not defined as a constant, global symbol-macro or a +global dynamic variable, it may be lexically bound or established as a +local symbol macro. + +@item +If the symbol is defined as a global dynamic variable, it may be +assigned or bound. + +@end itemize + +@item +Defining, undefining, or binding it, or its setf name as a function. + +Exceptions: + +@itemize @minus +@item +If the symbol is not defined as a function, macro, or special operator +it and its setf name may be lexically bound as a function. + +@end itemize + +@item +Defining, undefining, or binding it as a macro or compiler macro. + +Exceptions: + +@itemize @minus +@item +If the symbol is not defined as a function, macro, or special operator +it may be lexically bound as a macro. + +@end itemize + +@item +Defining it as a type specifier or structure. + +@item +Defining it as a declaration with a declaration proclamation. + +@item +Declaring or proclaiming it special. + +@item +Declaring or proclaiming its type or ftype. + +Exceptions: + +@itemize @minus +@item +If the symbol may be lexically bound, the type of that binding may be +declared. + +@item +If the symbol may be lexically bound as a function, the ftype of that +binding may be declared. + +@end itemize + +@item +Defining a setf expander for it. + +@item +Defining it as a method combination type. + +@item +Using it as the class-name argument to setf of find-class. + +@end enumerate + +@node Package Lock Dictionary +@section Package Lock Dictionary + +@deftp {Declaration} sb-ext:disable-package-locks + +Syntax: @code{(sb-ext:disable-package-locks symbol*)} + +Disables package locks affecting the named symbols during compilation +in the lexical scope of the declaration. Disabling locks on symbols +whose home package is unlocked, or disabling an already disabled lock, +has no effect. +@end deftp + +@deftp {Declaration} sb-ext:enable-package-locks + +Syntax: @code{(sb-ext:enable-package-locks symbol*)} + +Re-enables package locks affecting the named symbols during +compilation in the lexical scope of the declaration. Enabling locks +that were not first disabled with @code{sb-ext:disable-package-locks} +declararion, or enabling locks that are already enabled has no effect. +@end deftp + +@include condition-sb-ext-package-lock-violation.texinfo +@include condition-sb-ext-package-locked-error.texinfo +@include condition-sb-ext-symbol-package-locked-error.texinfo + +@defun sb-ext:package-locked-error-symbol @var{symbol-package-locked-error} + +Returns the symbol that caused the @code{symbol-package-locked-error} +condition. +@end defun + +@include fun-sb-ext-package-locked-p.texinfo +@include fun-sb-ext-lock-package.texinfo +@include fun-sb-ext-unlock-package.texinfo +@include fun-sb-ext-package-implemented-by-list.texinfo +@include fun-sb-ext-package-implements-list.texinfo +@include fun-sb-ext-add-implementation-package.texinfo +@include fun-sb-ext-remove-implementation-package.texinfo +@include macro-sb-ext-without-package-locks.texinfo +@include macro-sb-ext-with-unlocked-packages.texinfo + +@defmac defpackage name [[@var{option}]]* @result{} package + +Options are extended to include the following: + +@itemize +@item +@code{:lock} @var{boolean} + +If the argument to @code{:lock} is @code{t}, the package is initially +locked. If @code{:lock} is not provided it defaults to @code{nil}. + +@item +@code{:implement} @var{package-designator}* + +The package is added as an implementation package to the packages +named. If @code{:implement} is not provided, it defaults to the +package itself. +@end itemize + +Example: + +@lisp +(defpackage "FOO" (:export "BAR") (:lock t) (:implement)) +(defpackage "FOO-INT" (:use "FOO") (:implement "FOO" "FOO-INT")) + +;;; is equivalent to + +(defpackage "FOO") (:export "BAR")) +(lock-package "FOO") +(remove-implementation-package "FOO" "FOO") +(defpackage "FOO-INT" (:use "BAR")) +(add-implementation-package "FOO-INT" "FOO") +@end lisp +@end defmac diff --git a/doc/manual/sbcl.texinfo b/doc/manual/sbcl.texinfo index f2146e5..bcc05cd 100644 --- a/doc/manual/sbcl.texinfo +++ b/doc/manual/sbcl.texinfo @@ -62,6 +62,7 @@ provided with absolutely no warranty. See the @file{COPYING} and * Efficiency:: * Beyond The ANSI Standard:: * The Foreign Function Interface:: +* Package Locks:: * Contributed Modules:: * Concept Index:: * Function Index:: @@ -78,6 +79,7 @@ provided with absolutely no warranty. See the @file{COPYING} and @include efficiency.texinfo @include beyond-ansi.texinfo @include ffi.texinfo +@include package-locks.texi-temp @include contrib-modules.texinfo @include backmatter.texinfo diff --git a/make-target-2.sh b/make-target-2.sh index fb1c8c1..6b3cd21 100644 --- a/make-target-2.sh +++ b/make-target-2.sh @@ -78,6 +78,12 @@ echo //doing warm init (space 1) (speed 1))) + ;; Lock internal packages + #+sb-package-locks + (dolist (p (list-all-packages)) + (unless (member p (mapcar #'find-package '(:keyword :cl-user))) + (lock-package p))) + (sb-int:/show "done with warm.lisp, about to SAVE-LISP-AND-DIE") ;; Even if /SHOW output was wanted during build, it's probably ;; not wanted by default after build is complete. (And if it's diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8d46924..f0ab524 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -560,6 +560,23 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME" "DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE" + ;; package-locking stuff + #!+sb-package-locks "PACKAGE-LOCKED-P" + #!+sb-package-locks "LOCK-PACKAGE" + #!+sb-package-locks "UNLOCK-PACKAGE" + #!+sb-package-locks "PACKAGE-IMPLEMENTED-BY-LIST" + #!+sb-package-locks "PACKAGE-IMPLEMENTS-LIST" + #!+sb-package-locks "ADD-IMPLEMENTATION-PACKAGE" + #!+sb-package-locks "REMOVE-IMPLEMENTATION-PACKAGE" + #!+sb-package-locks "WITH-UNLOCKED-PACKAGES" + #!+sb-package-locks "PACKAGE-LOCK-VIOLATION" + #!+sb-package-locks "PACKAGE-LOCKED-ERROR" + #!+sb-package-locks "SYMBOL-PACKAGE-LOCKED-ERROR" + #!+sb-package-locks "PACKAGE-LOCKED-ERROR-SYMBOL" + "WITHOUT-PACKAGE-LOCKS" + "DISABLE-PACKAGE-LOCKS" + "ENABLE-PACKAGE-LOCKS" + ;; error signalled when attempt to load an invalid fasl ;; is made, so that user code can try to recompile, etc. "INVALID-FASL" @@ -1062,6 +1079,11 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "ALIEN-TYPE-TYPE" "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" "ALLOCATE-VECTOR" + "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" + "DISABLED-PACKAGE-LOCKS" + "WITH-SINGLE-PACKAGE-LOCKED-ERROR" + "PACKAGE-ERROR-FORMAT-ARGUMENTS" + "PACKAGE-ERROR-FORMAT-CONTROL" "ALWAYS-SUBTYPEP" "ARGS-TYPE" "ARGS-TYPE-ALLOWP" "ARGS-TYPE-KEYP" "ARGS-TYPE-KEYWORDS" "ARGS-TYPE-OPTIONAL" "ARGS-TYPE-P" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 9711add..9757734 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -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). diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 5345544..6b971ec 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -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 ;;;; diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 868d3f6..2b2a6c5 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -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)) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index bd9e7a0..eb0a395 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -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 diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index a9cfbf7..964639f 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -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) diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index efb100e..cb83743 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -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 ) - (:SHADOW {symbol-name}*) - (:SHADOWING-IMPORT-FROM {symbol-name}*) - (:USE {package-name}*) - (:IMPORT-FROM {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 "") + (:shadow "{symbol-name}*") + (:shadowing-import-from " {symbol-name}*") + (:use "{package-name}*") + (:import-from " {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)) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 6d70ebe..b0f374b 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -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 diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 5115bcb..4f80e72 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -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) - diff --git a/src/code/early-package.lisp b/src/code/early-package.lisp new file mode 100644 index 0000000..1084cdf --- /dev/null +++ b/src/code/early-package.lisp @@ -0,0 +1,66 @@ +;;;; 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) diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 4b61727..0fd0895 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -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))))) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 7f6dce7..2185a96 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -337,6 +337,8 @@ GET-SETF-EXPANSION directly." (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 ~ diff --git a/src/code/eval.lisp b/src/code/eval.lisp index d77f90f..9a3cdf1 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -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)) diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 943eb2e..59ca173 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -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)) diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 20f7ad7..758e8b4 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -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 diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 5c64df2..0843787 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -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) diff --git a/src/code/package.lisp b/src/code/package.lisp index 8e14a5e..59f2f24 100644 --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -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 diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 729be4f..30bd69d 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -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 @@ Lisp process." ;;; 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*) diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index e24c33e..557141b 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -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 diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index ab640e9..074e43d 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -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))) - - (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))))) + (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)))))) ;;; 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)))))) - - ;; 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)) + (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)) + + ;; 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)))))) - - (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))))) + (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)))) + + (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) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 95f125a..f523aa8 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -23,6 +23,14 @@ (in-package "SB-COLD") +;;; FIXME: This is embarassing -- SBCL violates SBCL style-package locks +;;; on the host lisp. Rather then find and fix all cases right now, +;;; let's just remain self-hosting. The problems at least involve +;;; a few defvars and local macros with names in the CL package. +#+(and sbcl sb-package-locks) +(dolist (p (list-all-packages)) + (sb-ext:unlock-package p)) + ;;; prefixes for filename stems when cross-compiling. These are quite arbitrary ;;; (although of course they shouldn't collide with anything we don't want to ;;; write over). In particular, they can be either relative path names (e.g. diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index f6892a9..bd355bf 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -13,13 +13,13 @@ ;;;; general warm init compilation policy - (proclaim '(optimize (compilation-speed 1) (debug #+sb-show 2 #-sb-show 1) (inhibit-warnings 2) (safety 2) (space 1) (speed 2))) + ;;;; package hacking @@ -226,3 +226,5 @@ "public: the default package for user code and data") #+sb-doc (setf (documentation (find-package "KEYWORD") t) "public: home of keywords") + + diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index ba5c68e..3a9e453 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1163,16 +1163,24 @@ ,@(mapcar (lambda (name) `(,name (gen-label))) new-labels)) - (declare (ignorable ,vop-var ,seg-var)) + (declare (ignorable ,vop-var ,seg-var) + ;; Must be done so that contribs and user code doing + ;; low-level stuff don't need to worry about this. + (disable-package-locks %%current-segment%% %%current-vop%%)) (macrolet ((%%current-segment%% () '**current-segment**) (%%current-vop%% () '**current-vop**)) - (symbol-macrolet (,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar (lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body))))))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host. + ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%% %%current-vop%%)) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) + `((..inherited-labels.. ,nested-labels)))) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) + body))))))) #+sb-xc-host (sb!xc:defmacro assemble ((&optional segment vop &key labels) &body body @@ -1209,13 +1217,13 @@ (declare (ignorable ,vop-var ,seg-var)) (macrolet ((%%current-segment%% () '**current-segment**) (%%current-vop%% () '**current-vop**)) - (symbol-macrolet (,@(when (or inherited-labels nested-labels) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar (lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body))))))) + (symbol-macrolet (,@(when (or inherited-labels nested-labels) + `((..inherited-labels.. ,nested-labels)))) + ,@(mapcar (lambda (form) + (if (label-name-p form) + `(emit-label ,form) + form)) + body))))))) (defmacro inst (&whole whole instruction &rest args &environment env) #!+sb-doc @@ -1636,10 +1644,19 @@ ,@(when decls `((declare ,@decls))) (let ((,postits (segment-postits ,segment-name))) + ;; Must be done so that contribs and user code doing + ;; low-level stuff don't need to worry about this. + (declare (disable-package-locks %%current-segment%%)) (setf (segment-postits ,segment-name) nil) (macrolet ((%%current-segment%% () (error "You can't use INST without an ~ ASSEMBLE inside emitters."))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host + ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%% + ;; declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%%)) ,@emitter)) (values)) (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/src/compiler/compiler-deftype.lisp b/src/compiler/compiler-deftype.lisp index 2a1ddce..322b06b 100644 --- a/src/compiler/compiler-deftype.lisp +++ b/src/compiler/compiler-deftype.lisp @@ -14,6 +14,8 @@ (/show0 "compiler-deftype.lisp 14") (defun %compiler-deftype (name expander &optional doc) + (with-single-package-locked-error + (:symbol name "defining ~A as a type specifier")) (ecase (info :type :kind name) (:primitive (when *type-system-initialized* diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index d308bdd..43d22da 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -102,6 +102,7 @@ (defvar *current-component*) (defvar *delayed-ir1-transforms*) (defvar *handled-conditions*) +(defvar *disabled-package-locks*) (defvar *policy*) (defvar *dynamic-counts-tn*) (defvar *elsewhere*) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index d0f3312..77430a4 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1482,3 +1482,4 @@ (values) ()) (defknown style-warn (string &rest t) null ()) + diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index a2dccfd..5188227 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -209,8 +209,10 @@ (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) (when (eq (info :function :kind name) :special-form) (error "~S names a special form." name)) - (setf (info :function :compiler-macro-function name) function) - function) + (with-single-package-locked-error + (:symbol name "setting the compiler-macro-function of ~A") + (setf (info :function :compiler-macro-function name) function) + function)) ;;;; a subset of DOCUMENTATION functionality for bootstrapping diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 3c65f27..fc91bee 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -255,6 +255,8 @@ (compiler-style-warn "duplicate definitions in ~S" definitions)) (let* ((processed-definitions (mapcar definitionize-fun definitions)) (*lexenv* (make-lexenv definitionize-keyword processed-definitions))) + ;; I wonder how much of an compiler performance penalty this + ;; non-constant keyword is. (funcall fun definitionize-keyword processed-definitions))) ;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then @@ -278,6 +280,9 @@ (destructuring-bind (name arglist &body body) definition (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) + (when (fboundp name) + (with-single-package-locked-error + (:symbol name "binding ~A as a local macro"))) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -326,10 +331,14 @@ (destructuring-bind (name expansion) definition (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) + (when (or (boundp name) (eq (info :variable :kind name) :macro)) + (with-single-package-locked-error + (:symbol name "binding ~A as a local symbol-macro"))) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" kind name))) + ;; A magical cons that MACROEXPAND-1 understands. `(,name . (MACRO . ,expansion)))))) (defun funcall-in-symbol-macrolet-lexenv (definitions fun context) @@ -523,7 +532,10 @@ (vars var) (names name) (vals (second spec))))))) - + (dolist (name (names)) + (when (eq (info :variable :kind name) :macro) + (with-single-package-locked-error + (:symbol name "lexically binding symbol-macro ~A")))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -542,9 +554,10 @@ ((next result) (processing-decls (decls vars nil next result) (let ((fun (ir1-convert-lambda-body - forms vars - :debug-name (debug-namify "LET " - bindings)))) + forms + vars + :debug-name (debug-namify "LET S" + bindings)))) (reference-leaf start ctran fun-lvar fun)) (values next result)))) (ir1-convert-combination-args fun-lvar ctran next result values)))))) @@ -559,7 +572,12 @@ (parse-body body :doc-string-allowed nil) (multiple-value-bind (vars values) (extract-let-vars bindings 'let*) (processing-decls (decls vars nil start next) - (ir1-convert-aux-bindings start next result forms vars values))))) + (ir1-convert-aux-bindings start + next + result + forms + vars + values))))) ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET @@ -601,6 +619,9 @@ (let ((name (first def))) (check-fun-name name) + (when (fboundp name) + (with-single-package-locked-error + (:symbol name "binding ~A as a local function"))) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) @@ -619,7 +640,7 @@ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'flet) + (extract-flet-vars definitions 'flet) (let ((fvars (mapcar (lambda (n d) (ir1-convert-lambda d :source-name n @@ -629,7 +650,10 @@ names defs))) (processing-decls (decls nil fvars next result) (let ((*lexenv* (make-lexenv :funs (pairlis names fvars)))) - (ir1-convert-progn-body start next result forms))))))) + (ir1-convert-progn-body start + next + result + forms))))))) (def-ir1-translator labels ((definitions &body body) start next result) #!+sb-doc @@ -639,46 +663,50 @@ each other." (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) (multiple-value-bind (names defs) - (extract-flet-vars definitions 'labels) - (let* ( ;; dummy LABELS functions, to be used as placeholders + (extract-flet-vars definitions 'labels) + (let* (;; dummy LABELS functions, to be used as placeholders ;; during construction of real LABELS functions - (placeholder-funs (mapcar (lambda (name) - (make-functional - :%source-name name - :%debug-name (debug-namify - "LABELS placeholder " - name))) - names)) - ;; (like PAIRLIS but guaranteed to preserve ordering:) - (placeholder-fenv (mapcar #'cons names placeholder-funs)) + (placeholder-funs (mapcar (lambda (name) + (make-functional + :%source-name name + :%debug-name (debug-namify + "LABELS placeholder " + name))) + names)) + ;; (like PAIRLIS but guaranteed to preserve ordering:) + (placeholder-fenv (mapcar #'cons names placeholder-funs)) ;; the real LABELS functions, compiled in a LEXENV which ;; includes the dummy LABELS functions - (real-funs - (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) - (mapcar (lambda (name def) - (ir1-convert-lambda def - :source-name name - :debug-name (debug-namify - "LABELS " name) - :allow-debug-catch-tag t)) - names defs)))) - + (real-funs + (let ((*lexenv* (make-lexenv :funs placeholder-fenv))) + (mapcar (lambda (name def) + (ir1-convert-lambda def + :source-name name + :debug-name (debug-namify + "LABELS " name) + :allow-debug-catch-tag t)) + names defs)))) + ;; Modify all the references to the dummy function leaves so ;; that they point to the real function leaves. - (loop for real-fun in real-funs and - placeholder-cons in placeholder-fenv do - (substitute-leaf real-fun (cdr placeholder-cons)) - (setf (cdr placeholder-cons) real-fun)) - + (loop for real-fun in real-funs and + placeholder-cons in placeholder-fenv do + (substitute-leaf real-fun (cdr placeholder-cons)) + (setf (cdr placeholder-cons) real-fun)) + ;; Voila. - (processing-decls (decls nil real-funs next result) + (processing-decls (decls nil real-funs next result) (let ((*lexenv* (make-lexenv ;; Use a proper FENV here (not the ;; placeholder used earlier) so that if the ;; lexical environment is used for inline ;; expansion we'll get the right functions. :funs (pairlis names real-funs)))) - (ir1-convert-progn-body start next result forms))))))) + (ir1-convert-progn-body start + next + result + forms))))))) + ;;;; the THE special operator, and friends @@ -860,9 +888,8 @@ (with-unique-names (exit-block) `(block ,exit-block (%within-cleanup - :catch - (%catch (%escape-fun ,exit-block) ,tag) - ,@body))))) + :catch (%catch (%escape-fun ,exit-block) ,tag) + ,@body))))) (def-ir1-translator unwind-protect ((protected &body cleanup) start next result) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 37ddb42..22654d1 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -922,6 +922,9 @@ (collect ((restr nil cons) (new-vars nil cons)) (dolist (var-name (rest decl)) + (when (boundp var-name) + (with-single-package-locked-error + (:symbol var-name "declaring the type of ~A"))) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) @@ -982,6 +985,9 @@ (let ((type (compiler-specifier-type spec))) (collect ((res nil cons)) (dolist (name names) + (when (fboundp name) + (with-single-package-locked-error + (:symbol name "declaring the ftype of ~A"))) (let ((found (find name fvars :key #'leaf-source-name :test #'equal))) @@ -1006,6 +1012,8 @@ (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) + (with-single-package-locked-error + (:symbol name "declaring ~A special")) (let ((var (find-in-bindings vars name))) (etypecase var (cons @@ -1202,6 +1210,11 @@ (dynamic-extent (process-dx-decl (cdr spec) vars) res) + ((disable-package-locks enable-package-locks) + (make-lexenv + :default res + :disabled-package-locks (process-package-lock-decl + spec (lexenv-disabled-package-locks res)))) (t (unless (info :declaration :recognized (first spec)) (compiler-warn "unrecognized declaration ~S" raw-spec)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 1f7cb2e..7600eeb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -539,6 +539,8 @@ (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (handled-conditions (lexenv-handled-conditions default)) + (disabled-package-locks + (lexenv-disabled-package-locks default)) (policy (lexenv-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) @@ -551,7 +553,8 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup handled-conditions policy))) + lambda cleanup handled-conditions + disabled-package-locks policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -581,6 +584,7 @@ nil nil (lexenv-handled-conditions lexenv) + (lexenv-disabled-package-locks lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index f89df35..d9d57f2 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -27,7 +27,7 @@ (funs vars blocks tags type-restrictions lambda cleanup handled-conditions - policy))) + disabled-package-locks policy))) ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a ;; local function), a DEFINED-FUN, representing an ;; INLINE/NOTINLINE declaration, or a list (MACRO . ) (a @@ -64,6 +64,8 @@ (cleanup nil) ;; condition types we handle with a handler around the compiler (handled-conditions *handled-conditions*) + ;; lexically disabled package locks (list of symbols) + (disabled-package-locks *disabled-package-locks*) ;; the current OPTIMIZE policy (policy *policy* :type policy)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 47b4c92..ff1bcce 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -806,7 +806,8 @@ (defun convert-and-maybe-compile (form path) (declare (list path)) (let* ((*lexenv* (make-lexenv :policy *policy* - :handled-conditions *handled-conditions*)) + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (tll (ir1-toplevel form path nil))) (cond ((eq *block-compile* t) (push tll *toplevel-lambdas*)) (t (compile-toplevel (list tll) nil))))) @@ -853,7 +854,9 @@ ;; issue a warning instead of silently screwing up. (*policy* (lexenv-policy *lexenv*)) ;; This is probably also a hack - (*handled-conditions* (lexenv-handled-conditions *lexenv*))) + (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*))) (process-toplevel-progn forms path compile-time-too)))) ;;; Parse an EVAL-WHEN situations list, returning three flags, @@ -952,7 +955,8 @@ (when name (legal-fun-name-or-type-error name)) (let* ((*lexenv* (make-lexenv :policy *policy* - :handled-conditions *handled-conditions*)) + :handled-conditions *handled-conditions* + :disabled-package-locks *disabled-package-locks*)) (fun (make-functional-from-toplevel-lambda lambda-expression :name name :path path))) @@ -1175,8 +1179,9 @@ ((macrolet) (funcall-in-macrolet-lexenv magic - (lambda (&key funs) + (lambda (&key funs prepend) (declare (ignore funs)) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too)) @@ -1184,7 +1189,8 @@ ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic - (lambda (&key vars) + (lambda (&key vars prepend) + (aver (null prepend)) (process-toplevel-locally body path compile-time-too @@ -1392,6 +1398,7 @@ (*policy* *policy*) (*handled-conditions* *handled-conditions*) + (*disabled-package-locks* *disabled-package-locks*) (*lexenv* (make-null-lexenv)) (*block-compile* *block-compile-arg*) (*source-info* info) diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp index 47becfd..d3bfe86 100644 --- a/src/compiler/policy.lisp +++ b/src/compiler/policy.lisp @@ -73,8 +73,9 @@ (cons name 1)) *policy-qualities*)) ;; not actually POLICY, but very similar - (setf *handled-conditions* nil)) - + (setf *handled-conditions* nil + *disabled-package-locks* nil)) + ;;; On the cross-compilation host, we initialize immediately (not ;;; waiting for "cold init", since cold init doesn't exist on ;;; cross-compilation host). diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index d189c90..a26b2a4 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -119,6 +119,17 @@ (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec))) list)) +(declaim (ftype (function (list list) list) + process-package-lock-decl)) +(defun process-package-lock-decl (spec old) + (let ((decl (car spec)) + (list (cdr spec))) + (ecase decl + (disable-package-locks + (union old list :test #'equal)) + (enable-package-locks + (set-difference old list :test #'equal))))) + ;;; ANSI defines the declaration (FOO X Y) to be equivalent to ;;; (TYPE FOO X Y) when FOO is a type specifier. This function ;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). @@ -157,6 +168,8 @@ (error "can't declare a non-symbol as SPECIAL: ~S" name)) (when (constantp name) (error "can't declare a constant as SPECIAL: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaraing ~A special")) (clear-info :variable :constant-value name) (setf (info :variable :kind name) :special))) (type @@ -165,6 +178,8 @@ (dolist (name (rest args)) (unless (symbolp name) (error "can't declare TYPE of a non-symbol: ~S" name)) + (with-single-package-locked-error + (:symbol name "globally declaring the type of ~A")) (when (eq (info :variable :where-from name) :declared) (let ((old-type (info :variable :type name))) (when (type/= type old-type) @@ -181,6 +196,8 @@ (unless (csubtypep ctype (specifier-type 'function)) (error "not a function type: ~S" (first args))) (dolist (name (rest args)) + (with-single-package-locked-error + (:symbol name "globally declaring the ftype of ~A")) (when (eq (info :function :where-from name) :declared) (let ((old-type (info :function :type name))) (when (type/= ctype old-type) @@ -222,6 +239,9 @@ (unmuffle-conditions (setq *handled-conditions* (process-unmuffle-conditions-decl form *handled-conditions*))) + ((disable-package-locks enable-package-locks) + (setq *disabled-package-locks* + (process-package-lock-decl form *disabled-package-locks*))) ((inline notinline maybe-inline) (dolist (name args) (proclaim-as-fun-name name) ; since implicitly it is a function @@ -236,6 +256,8 @@ (error "In~% ~S~%the declaration to be recognized is not a ~ symbol:~% ~S" form decl)) + (with-single-package-locked-error + (:symbol decl "globally declaring ~A as a declaration proclamation")) (setf (info :declaration :recognized decl) t))) (t (unless (info :declaration :recognized kind) diff --git a/src/compiler/target-main.lisp b/src/compiler/target-main.lisp index b031250..8a1cffb 100644 --- a/src/compiler/target-main.lisp +++ b/src/compiler/target-main.lisp @@ -72,6 +72,8 @@ (*policy* (lexenv-policy *lexenv*)) ;; see above (*handled-conditions* (lexenv-handled-conditions *lexenv*)) + ;; ditto + (*disabled-package-locks* (lexenv-disabled-package-locks *lexenv*)) ;; FIXME: ANSI doesn't say anything about CL:COMPILE ;; interacting with these variables, so we shouldn't. As ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e88a9de..e89443f 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -437,14 +437,14 @@ bootstrapping. (mname `(,(if (eq (cadr initargs-form) :function) 'method 'fast-method) ,name ,@qualifiers ,specls)) - (mname-sym (intern (let ((*print-pretty* nil) - ;; (We bind *PACKAGE* to - ;; KEYWORD here as a way to - ;; force symbols to be printed - ;; with explicit package - ;; prefixes.) - (*package* *keyword-package*)) - (format nil "~S" mname))))) + (mname-sym (let ((*print-pretty* nil) + ;; (We bind *PACKAGE* to KEYWORD here + ;; as a way to force symbols to be + ;; printed with explicit package + ;; prefixes.) + (target *package*) + (*package* *keyword-package*)) + (format-symbol target "~S" mname)))) `(progn (defun ,mname-sym ,(cadr fn-lambda) ,@(cddr fn-lambda)) @@ -460,7 +460,7 @@ bootstrapping. `(list ,@(mapcar (lambda (specializer) (if (consp specializer) ``(,',(car specializer) - ,,(cadr specializer)) + ,,(cadr specializer)) `',specializer)) specializers)) unspecialized-lambda-list @@ -1428,10 +1428,10 @@ bootstrapping. ;; failing that, to use a special ;; symbol prefix denoting privateness. ;; -- WHN 19991201 - (intern (format nil "FAST-~A" - (car method-spec)) - *pcl-package*))) - ,@(cdr method-spec)))) + (format-symbol *pcl-package* + "FAST-~A" + (car method-spec)))) + ,@(cdr method-spec)))) (set-fun-name mff name) (unless mf (set-mf-property :name name))))) @@ -1939,7 +1939,7 @@ bootstrapping. (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (find-class method-class t ,env)))))) (defun real-ensure-gf-using-class--generic-function (existing diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 9e65da9..9aec60e 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -97,8 +97,7 @@ (defmacro !initial-classes-and-wrappers (&rest classes) `(progn ,@(mapcar (lambda (class) - (let ((wr (intern (format nil "~A-WRAPPER" class) - *pcl-package*))) + (let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class))) `(setf ,wr ,(if (eq class 'standard-generic-function) '*sgf-wrapper* `(boot-make-wrapper @@ -189,9 +188,7 @@ (boot-make-wrapper (length slots) name)))) (proto nil)) (when (eq name t) (setq *the-wrapper-of-t* wrapper)) - (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) - *pcl-package*) - class) + (set (make-class-symbol name) class) (dolist (slot slots) (unless (eq (getf slot :allocation :instance) :instance) (error "Slot allocation ~S is not supported in bootstrap." diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 766e7e7..b3e44d3 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -651,13 +651,13 @@ (defun dfun-arg-symbol (arg-number) (or (nth arg-number (the list *dfun-arg-symbols*)) - (intern (format nil ".ARG~A." arg-number) *pcl-package*))) + (format-symbol *pcl-package* ".ARG~A." arg-number))) (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) (or (nth arg-number (the list *slot-vector-symbols*)) - (intern (format nil ".SLOTS~A." arg-number) *pcl-package*))) + (format-symbol *pcl-package* ".SLOTS~A." arg-number))) ;; FIXME: There ought to be a good way to factor out the idiom: ;; diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 31141b4..a4d72a4 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -157,10 +157,9 @@ (defun get-effective-method-gensym () (or (pop *rebound-effective-method-gensyms*) - (let ((new (intern (format nil - "EFFECTIVE-METHOD-GENSYM-~D" - (length *global-effective-method-gensyms*)) - *pcl-package*))) + (let ((new (format-symbol *pcl-package* + "EFFECTIVE-METHOD-GENSYM-~D" + (length *global-effective-method-gensyms*)))) (setq *global-effective-method-gensyms* (append *global-effective-method-gensyms* (list new))) new))) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index ca88083..5a3dd01 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -130,12 +130,11 @@ (*print-case* :upcase) (*print-pretty* nil) (*print-gensym* t)) - (intern (format nil "CTOR ~S::~S ~S ~S" - (package-name (symbol-package class-name)) - (symbol-name class-name) - (plist-keys initargs) - (plist-values initargs :test #'constantp)) - *pcl-package*))) + (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S" + (package-name (symbol-package class-name)) + (symbol-name class-name) + (plist-keys initargs) + (plist-values initargs :test #'constantp)))) ;;; ;;; Keep this a separate function for testing. @@ -148,11 +147,12 @@ ;;; Keep this a separate function for testing. ;;; (defun make-ctor (function-name class-name initargs) - (let ((ctor (%make-ctor function-name class-name nil initargs))) - (push ctor *all-ctors*) - (setf (symbol-function function-name) ctor) - (install-initial-constructor ctor :force-p t) - ctor)) + (without-package-locks ; for (setf symbol-function) + (let ((ctor (%make-ctor function-name class-name nil initargs))) + (push ctor *all-ctors*) + (setf (symbol-function function-name) ctor) + (install-initial-constructor ctor :force-p t) + ctor))) ;;; *********************************************** @@ -174,7 +174,7 @@ (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) (if (array-in-bounds-p ps i) (aref ps i) - (intern (format nil ".P~D." i) *pcl-package*)))) + (format-symbol *pcl-package* ".P~D." i)))) ;; ;; Check if CLASS-NAME is a constant symbol. Give up if ;; not. @@ -220,17 +220,19 @@ ;; 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.)) - ;;; ??? check if this is worth it. - (declare - (ftype (or (function ,(make-list (length value-forms) - :initial-element t) - t) - (function (&rest t) t)) - ,function-name)) - (,function-name ,@value-forms))))))) + `(locally + (declare (disable-package-locks ,function-name)) + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + ;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (,function-name ,@value-forms)))))))) ;;; ************************************************** @@ -456,7 +458,7 @@ (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) (aref ps i) - (intern (format nil ".D~D." i) *pcl-package*))))) + (format-symbol *pcl-package* ".D~D." i))))) ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr @@ -470,24 +472,26 @@ (if (consp location) (class-init location 'param value) (instance-init location 'param value))))) + ;; ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied ;; initargs are treated as if they were appended to supplied ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. + ;; (loop for (key initfn initform) in default-initargs and i from 0 unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) - (when (eq type 'var) - (let ((init-var (default-init-var-name i))) - (setq init init-var) - (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (let* ((type (if (constantp initform) 'constant 'var)) + (init (if (eq type 'var) initfn initform))) + (when (eq type 'var) + (let ((init-var (default-init-var-name i))) + (setq init init-var) + (push (cons init-var initfn) default-inits))) + (dolist (location (initarg-locations key)) + (if (consp location) + (class-init location type init) + (instance-init location type init))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 87b2c1e..f525d4a 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -98,20 +98,22 @@ mclass *the-class-structure-class*)))))) (let ((defclass-form - `(progn - (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) - (%compiler-defclass ',name - ',*readers-for-this-defclass* - ',*writers-for-this-defclass* - ',*slot-names-for-this-defclass*) - (load-defclass ',name - ',metaclass - ',supers - (list ,@canonical-slots) - (list ,@(apply #'append - (when defstruct-p - '(:from-defclass-p t)) - other-initargs))))))) + `(progn + (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (with-single-package-locked-error + (:symbol ',name "defining ~A as a class") + (%compiler-defclass ',name + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-for-this-defclass*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs)))))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -131,7 +133,8 @@ (and (not (eq name 'structure-object)) *the-class-structure-object*))) (defstruct-form (make-structure-class-defstruct-form - name (class-direct-slots (find-class name)) include))) + name (class-direct-slots (find-class name)) + include))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) ,defstruct-form) ; really compile the defstruct-form @@ -157,13 +160,14 @@ ,defclass-form))))))))) (defun %compiler-defclass (name readers writers slot-names) - (preinform-compiler-about-class-type name) - (proclaim `(ftype (function (t) t) - ,@readers - ,@(mapcar #'slot-reader-name slot-names) - ,@(mapcar #'slot-boundp-name slot-names))) - (proclaim `(ftype (function (t t) t) - ,@writers ,@(mapcar #'slot-writer-name slot-names)))) + (with-single-package-locked-error (:symbol name "defining ~A as a class") + (preinform-compiler-about-class-type name) + (proclaim `(ftype (function (t) t) + ,@readers + ,@(mapcar #'slot-reader-name slot-names) + ,@(mapcar #'slot-boundp-name slot-names))) + (proclaim `(ftype (function (t t) t) + ,@writers ,@(mapcar #'slot-writer-name slot-names))))) (defun make-initfunction (initform) (cond ((or (eq initform t) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 8b71ed4..060f4a0 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -25,10 +25,13 @@ (defmacro define-method-combination (&whole form &rest args) (declare (ignore args)) - (if (and (cddr form) - (listp (caddr form))) - (expand-long-defcombin form) - (expand-short-defcombin form))) + `(progn + (with-single-package-locked-error + (:symbol ',(second form) "defining ~A as a method combination")) + ,(if (and (cddr form) + (listp (caddr form))) + (expand-long-defcombin form) + (expand-short-defcombin form)))) ;;;; standard method combination diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index c0bff27..f247747 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -216,19 +216,13 @@ (defun get-built-in-class-symbol (class-name) (or (cadr (assq class-name *built-in-class-symbols*)) - (let ((symbol (intern (format nil - "*THE-CLASS-~A*" - (symbol-name class-name)) - *pcl-package*))) + (let ((symbol (make-class-symbol class-name))) (push (list class-name symbol) *built-in-class-symbols*) symbol))) (defun get-built-in-wrapper-symbol (class-name) (or (cadr (assq class-name *built-in-wrapper-symbols*)) - (let ((symbol (intern (format nil - "*THE-WRAPPER-OF-~A*" - (symbol-name class-name)) - *pcl-package*))) + (let ((symbol (make-wrapper-symbol class-name))) (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index e6de19f..6b388e4 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -296,10 +296,9 @@ (wrapper-bindings (mapcan (lambda (arg mt) (unless (eq mt t) (incf index) - `((,(intern (format nil - "WRAPPER-~D" - index) - *pcl-package*) + `((,(format-symbol *pcl-package* + "WRAPPER-~D" + index) ,(emit-fetch-wrapper mt arg 'miss (pop slot-regs)))))) args metatypes)) diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index 5db39e8..cfad90f 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -60,6 +60,17 @@ (classoid-layout classoid)) 'defstruct-description))))) +;;; Symbol contruction utilities +(defun format-symbol (package format-string &rest format-arguments) + (without-package-locks + (intern (apply #'format nil format-string format-arguments) package))) + +(defun make-class-symbol (class-name) + (format-symbol *pcl-package* "*THE-CLASS-~A*" (symbol-name class-name))) + +(defun make-wrapper-symbol (class-name) + (format-symbol *pcl-package* "*THE-WRAPPER-~A*" (symbol-name class-name))) + (defun condition-type-p (type) (and (symbolp type) (condition-classoid-p (find-classoid type nil)))) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 1f9a12c..ea468f4 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -219,12 +219,12 @@ (defun intern-fun-name (name) (cond ((symbolp name) name) ((listp name) - (intern (let ((*package* *pcl-package*) - (*print-case* :upcase) - (*print-pretty* nil) - (*print-gensym* t)) - (format nil "~S" name)) - *pcl-package*)))) + (let ((*package* *pcl-package*) + (*print-case* :upcase) + (*print-pretty* nil) + (*print-gensym* t)) + (format-symbol *pcl-package* "~S" name))))) + ;;; FIXME: probably no longer needed after init (defmacro precompile-random-code-segments (&optional system) diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 44c4127..156d1e4 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -164,19 +164,23 @@ (defun (setf find-class) (new-value name &optional errorp environment) (declare (ignore errorp environment)) - (if (legal-class-name-p name) - (let ((cell (find-class-cell name))) - (setf (find-class-cell-class cell) new-value) - (when (and (eq *boot-state* 'complete) (null new-value)) - (setf (find-classoid name) nil)) - (when (or (eq *boot-state* 'complete) - (eq *boot-state* 'braid)) - (when (and new-value (class-wrapper new-value)) - (setf (find-class-cell-predicate cell) - (fdefinition (class-predicate-name new-value)))) - (update-ctors 'setf-find-class :class new-value :name name)) - new-value) - (error "~S is not a legal class name." name))) + (cond ((legal-class-name-p name) + (with-single-package-locked-error + (:symbol name "using ~A as the class-name argument in ~ + (SETF FIND-CLASS)")) + (let ((cell (find-class-cell name))) + (setf (find-class-cell-class cell) new-value) + (when (and (eq *boot-state* 'complete) (null new-value)) + (setf (find-classoid name) nil)) + (when (or (eq *boot-state* 'complete) + (eq *boot-state* 'braid)) + (when (and new-value (class-wrapper new-value)) + (setf (find-class-cell-predicate cell) + (fdefinition (class-predicate-name new-value)))) + (update-ctors 'setf-find-class :class new-value :name name)) + new-value)) + (t + (error "~S is not a legal class name." name)))) (/show "pcl/macros.lisp 230") diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index c15b6c8..20158c0 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -405,11 +405,14 @@ (defun make-discriminating-function-arglist (number-required-arguments restp) (nconc (let ((args nil)) (dotimes (i number-required-arguments) - (push (intern (format nil "Discriminating Function Arg ~D" i)) + (push (format-symbol *package* ;; ! is this right? + "Discriminating Function Arg ~D" + i) args)) (nreverse args)) (when restp - `(&rest ,(intern "Discriminating Function &rest Arg"))))) + `(&rest ,(format-symbol *package* + "Discriminating Function &rest Arg"))))) (defmethod generic-function-argument-precedence-order ((gf standard-generic-function)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index ca020b4..46cdf63 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -302,23 +302,25 @@ args)) (defmethod ensure-class-using-class ((class null) name &rest args &key) - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (set-class-type-translation (class-prototype meta) name) - (setf class (apply #'make-instance meta :name name initargs) - (find-class name) class) - (set-class-type-translation class name) - class)) + (without-package-locks + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (set-class-type-translation (class-prototype meta) name) + (setf class (apply #'make-instance meta :name name initargs) + (find-class name) class) + (set-class-type-translation class name) + class))) (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (unless (eq (class-of class) meta) - (apply #'change-class class meta initargs)) - (apply #'reinitialize-instance class initargs) - (setf (find-class name) class) - (set-class-type-translation class name) - class)) + (without-package-locks + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (unless (eq (class-of class) meta) + (apply #'change-class class meta initargs)) + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class) + (set-class-type-translation class name) + class))) (defmethod class-predicate-name ((class t)) 'constantly-nil) @@ -523,32 +525,33 @@ (flet ((compute-preliminary-cpl (root) (let ((*allow-forward-referenced-classes-in-cpl-p* t)) (compute-class-precedence-list root)))) - (unless (class-finalized-p class) - (let ((name (class-name class))) - (setf (find-class name) class) - ;; KLUDGE: This is fairly horrible. We need to make a - ;; full-fledged CLASSOID here, not just tell the compiler that - ;; some class is forthcoming, because there are legitimate - ;; questions one can ask of the type system, implemented in - ;; terms of CLASSOIDs, involving forward-referenced classes. So. - (when (and (eq *boot-state* 'complete) - (null (find-classoid name nil))) - (setf (find-classoid name) - (make-standard-classoid :name name))) - (set-class-type-translation class name) - (let ((layout (make-wrapper 0 class)) - (classoid (find-classoid name))) - (setf (layout-classoid layout) classoid) - (setf (classoid-pcl-class classoid) class) - (setf (slot-value class 'wrapper) layout) - (let ((cpl (compute-preliminary-cpl class))) - (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest cpl)))))) - (register-layout layout :invalidate t) - (setf (classoid-layout classoid) layout) - (mapc #'make-preliminary-layout (class-direct-subclasses class))))))) + (without-package-locks + (unless (class-finalized-p class) + (let ((name (class-name class))) + (setf (find-class name) class) + ;; KLUDGE: This is fairly horrible. We need to make a + ;; full-fledged CLASSOID here, not just tell the compiler that + ;; some class is forthcoming, because there are legitimate + ;; questions one can ask of the type system, implemented in + ;; terms of CLASSOIDs, involving forward-referenced classes. So. + (when (and (eq *boot-state* 'complete) + (null (find-classoid name nil))) + (setf (find-classoid name) + (make-standard-classoid :name name))) + (set-class-type-translation class name) + (let ((layout (make-wrapper 0 class)) + (classoid (find-classoid name))) + (setf (layout-classoid layout) classoid) + (setf (classoid-pcl-class classoid) class) + (setf (slot-value class 'wrapper) layout) + (let ((cpl (compute-preliminary-cpl class))) + (setf (layout-inherits layout) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest cpl)))))) + (register-layout layout :invalidate t) + (setf (classoid-layout classoid) layout) + (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))) (defmethod shared-initialize :before ((class class) slot-names &key name) @@ -653,8 +656,8 @@ (error "Structure slots must have :INSTANCE allocation."))) (defun make-structure-class-defstruct-form (name direct-slots include) - (let* ((conc-name (intern (format nil "~S structure class " name))) - (constructor (intern (format nil "~Aconstructor" conc-name))) + (let* ((conc-name (format-symbol *package* "~S structure class " name)) + (constructor (format-symbol *package* "~Aconstructor" conc-name)) (defstruct `(defstruct (,name ,@(when include `((:include ,(class-name include)))) @@ -738,11 +741,10 @@ (mapcar (lambda (pl) (when defstruct-p (let* ((slot-name (getf pl :name)) - (acc-name - (format nil - "~S structure class ~A" - name slot-name)) - (accessor (intern acc-name))) + (accessor + (format-symbol *package* + "~S structure class ~A" + name slot-name))) (setq pl (list* :defstruct-accessor-symbol accessor pl)))) (make-direct-slotd class pl)) @@ -799,22 +801,28 @@ (fix-slot-accessors class dslotds 'remove)) (defun fix-slot-accessors (class dslotds add/remove) - (flet ((fix (gfspec name r/w) - (let* ((ll (case r/w (r '(object)) (w '(new-value object)))) - (gf (if (fboundp gfspec) - (ensure-generic-function gfspec) - (ensure-generic-function gfspec :lambda-list ll)))) - (case r/w - (r (if (eq add/remove 'add) - (add-reader-method class gf name) - (remove-reader-method class gf))) - (w (if (eq add/remove 'add) - (add-writer-method class gf name) - (remove-writer-method class gf))))))) - (dolist (dslotd dslotds) - (let ((slot-name (slot-definition-name dslotd))) - (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) - (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) + ;; We disable package locks here, since defining a class can trigger + ;; the update of the accessors of another class -- which might lead + ;; to package lock violations if we didn't. + (without-package-locks + (flet ((fix (gfspec name r/w) + (let* ((ll (case r/w (r '(object)) (w '(new-value object)))) + (gf (if (fboundp gfspec) + (ensure-generic-function gfspec) + (ensure-generic-function gfspec :lambda-list ll)))) + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name) + (remove-writer-method class gf))))))) + (dolist (dslotd dslotds) + (let ((slot-name (slot-definition-name dslotd))) + (dolist (r (slot-definition-readers dslotd)) + (fix r slot-name 'r)) + (dolist (w (slot-definition-writers dslotd)) + (fix w slot-name 'w))))))) (defun add-direct-subclasses (class supers) (dolist (super supers) @@ -853,26 +861,27 @@ ;; Note that we can't simply delay the finalization when CLASS has ;; no forward referenced superclasses because that causes bootstrap ;; problems. - (when (and (not finalizep) - (not (class-finalized-p class)) + (without-package-locks + (when (and (not finalizep) + (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (return-from update-class)) + (when (or finalizep (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) - (finalize-inheritance class) - (return-from update-class)) - (when (or finalizep (class-finalized-p class) - (not (class-has-a-forward-referenced-superclass-p class))) - (setf (find-class (class-name class)) class) - (update-cpl class (compute-class-precedence-list class)) - ;; This invocation of UPDATE-SLOTS, in practice, finalizes the - ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE + (setf (find-class (class-name class)) class) + (update-cpl class (compute-class-precedence-list class)) + ;; This invocation of UPDATE-SLOTS, in practice, finalizes the + ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE ;; is called at finalization, so that MOP programmers can hook - ;; into the system as described in "Class Finalization Protocol" - ;; (section 5.5.2 of AMOP). - (update-slots class (compute-slots class)) - (update-gfs-of-class class) - (update-initargs class (compute-default-initargs class)) - (update-ctors 'finalize-inheritance :class class)) - (unless finalizep - (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) + ;; into the system as described in "Class Finalization Protocol" + ;; (section 5.5.2 of AMOP). + (update-slots class (compute-slots class)) + (update-gfs-of-class class) + (update-initargs class (compute-default-initargs class)) + (update-ctors 'finalize-inheritance :class class)) + (unless finalizep + (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))) (defun update-cpl (class cpl) (if (class-finalized-p class) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index f75acf6..995fa6f 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -1091,27 +1091,30 @@ `(list* :fast-function (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) - (list (body-method-name body))) ; function name - (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args - ;; body of the function - (declare (ignorable .pv-cell. .next-method-call.)) - ,@outer-decls - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol - pv-parameters)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body-sans-decls))) + ,@(when (body-method-name body) + (list (body-method-name body))) ; function name + (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args + ;; body of the function + (declare (ignorable .pv-cell. .next-method-call.)) + ,@outer-decls + (declare (disable-package-locks pv-env)) + (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) + &rest forms) + (declare (ignore pv-table-symbol + pv-parameters)) + (declare (enable-package-locks pv-env)) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) + (declare (enable-package-locks pv-env)) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body-sans-decls))) ',initargs)))) ;;; Use arrays and hash tables and the fngen stuff to make this much @@ -1150,7 +1153,7 @@ (setf (get (car fname) 'method-sym) (let ((str (symbol-name (car fname)))) (if (string= "FAST-" str :end2 5) - (intern (subseq str 5) *pcl-package*) + (format-symbol *pcl-package* (subseq str 5)) (car fname))))) ,@(cdr fname)))) (set-fun-name method-function name)) diff --git a/src/runtime/mips-arch.c b/src/runtime/mips-arch.c index 7b68e65..b2c927e 100644 --- a/src/runtime/mips-arch.c +++ b/src/runtime/mips-arch.c @@ -1,7 +1,5 @@ /* - $Header$ - This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. diff --git a/src/runtime/mips-lispregs.h b/src/runtime/mips-lispregs.h index ff9b78a..47f9a5a 100644 --- a/src/runtime/mips-lispregs.h +++ b/src/runtime/mips-lispregs.h @@ -1,5 +1,3 @@ -/* $Header$ */ - #ifdef LANGUAGE_ASSEMBLY #define REG(num) $ ## num #else diff --git a/tests/clos.impure-cload.lisp b/tests/clos.impure-cload.lisp index 67032c5..e9e09b5 100644 --- a/tests/clos.impure-cload.lisp +++ b/tests/clos.impure-cload.lisp @@ -73,7 +73,7 @@ ;;; in a similar vein, we should be able to define methods on classes ;;; that are effectively unknown to the type system: (sb-mop:ensure-class 'unknown-type) -(defmethod method ((x unknown-type)) x) +(defmethod method-on-unknown ((x unknown-type)) x) ;;; (we can't call it without defining methods on allocate-instance ;;; etc., but we should be able to define it). diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 956c43c..bdd3550 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -377,7 +377,9 @@ ;;; bug 313: source transforms were "lisp-1" (defun srctran-lisp1-1 (cadr) (if (functionp cadr) (funcall cadr 1) nil)) (assert (eql (funcall (eval #'srctran-lisp1-1) #'identity) 1)) -(defvar caar) +(without-package-locks + ;; this be a nasal demon, but test anyways + (defvar caar)) (defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar) 1)) (assert (eql (funcall (eval #'srctran-lisp1-2) #'identity) 1)) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index f94e582..e8f86a0 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -308,12 +308,17 @@ ;;; BUG 48a. and b. (symbol-macrolet handling), fixed by Eric Marsden ;;; and Raymond Toy for CMUCL, fix ported for sbcl-0.7.6.18. (multiple-value-bind (function warnings-p failure-p) - (compile nil '(lambda () (symbol-macrolet ((t nil)) t))) + (compile nil '(lambda () + ;; not interested in the package lock violation here + (declare (sb-ext:disable-package-locks t)) + (symbol-macrolet ((t nil)) t))) (assert failure-p) (assert (raises-error? (funcall function) program-error))) (multiple-value-bind (function warnings-p failure-p) (compile nil '(lambda () + ;; not interested in the package lock violation here + (declare (sb-ext:disable-package-locks *standard-input*)) (symbol-macrolet ((*standard-input* nil)) *standard-input*))) (assert failure-p) diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp new file mode 100644 index 0000000..de47170 --- /dev/null +++ b/tests/package-locks.impure.lisp @@ -0,0 +1,439 @@ +;;;; package lock tests with side effects + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +(load "assertoid.lisp") +(use-package "ASSERTOID") + +#-sb-package-locks +(sb-ext:quit :unix-status 104) + +;;;; Our little labrats and a few utilities + +(defpackage :test-used) + +(defpackage :test-unused) + +(defpackage :test-aux (:export #:noslot)) + +(defpackage :test + (:use :test-used) + (:shadow #:shadowed) + (:export + #:*special* + #:car + #:cdr + #:class + #:constant + #:external + #:function + #:macro + #:noclass + #:noclass-slot + #:nocondition + #:nocondition-slot + #:nospecial + #:nostruct + #:nostruct2 + #:nostruct-slot + #:nosymbol-macro + #:notype + #:num + #:numfun + #:shadowed + #:symbol-macro + #:unused + )) + +(defvar *uninterned* "UNINTERNED") +(defvar *interned* "INTERNED") + +(defun maybe-unintern (name package) + (let ((s (find-symbol name package))) + (when s + (unintern s package)))) + +(defun set-test-locks (lock-p) + (dolist (p '(:test :test-aux :test-delete)) + (when (find-package p) + (if lock-p + (sb-ext:lock-package p) + (sb-ext:unlock-package p))))) + +(defun reset-test () + "Reset TEST package to a known state, ensure that TEST-DELETE exists." + (unless (find-package :test-delete) + (make-package :test-delete)) + (sb-ext:with-unlocked-packages (:test :test-aux) + (dolist (s '(test:nosymbol-macro + test:noclass test:nostruct test:nostruct2 test:nocondition)) + (makunbound s) + (unintern s) + (intern (symbol-name s) :test)) + (rename-package (find-package :test) :test) + (unexport (intern "INTERNAL" :test) :test) + (intern *interned* :test) + (use-package :test-used :test) + (export 'test::external :test) + (unuse-package :test-unused :test) + (defclass test:class () ()) + (defun test:function () 'test:function) + (defmacro test:macro () ''test:macro) + (defparameter test:*special* 'test:*special*) + (defconstant test:constant 'test:constant) + (intern "UNUSED" :test) + (dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot + test-aux:noslot)) + (fmakunbound s)) + (ignore-errors (progn + (fmakunbound 'test:unused) + (makunbound 'test:unused))) + (maybe-unintern *uninterned* :test) + (maybe-unintern "NOT-FROM-TEST" :test) + (defconstant test:num 0) + (define-symbol-macro test:symbol-macro "SYMBOL-MACRO") + (defun test:numfun (n) n) + (defun test:car (cons) (cl:car cons)) + (defun (setf test:cdr) (obj cons) (setf (cl:cdr cons) obj)) + (assert (not (find-symbol *uninterned* :test))))) + +(defun tmp-fmakunbound (x) + "FMAKUNDBOUND x, then restore the original binding." + (let ((f (fdefinition x))) + (fmakunbound x) + (ignore-errors (setf (fdefinition x) f)))) + +(defmacro with-error-info ((string &rest args) &body forms) + `(handler-bind ((error (lambda (e) + (format t ,string ,@args) + (finish-output)))) + (progn ,@forms))) + +;;;; Test cases + +;;; A collection of forms that are legal both with and without package +;;; locks. +(defvar *legal-forms* + '(;; package alterations that don't actually mutate the package + (intern *interned* :test) + (import 'test:unused :test) + (shadowing-import 'test:shadowed :test) + (export 'test:unused :test) + (unexport 'test::internal :test) + (let ((p (find-package :test))) + (rename-package p :test)) + (use-package :test-used :test) + (unuse-package :test-unused :test) + (shadow "SHADOWED" :test) + (let ((s (with-unlocked-packages (:test) + (let ((s (intern *uninterned* :test))) + (unintern s :test) + s)))) + (unintern s :test)) + + ;; binding and altering value + (let ((test:function 123)) + (assert (eql test:function 123))) + (let ((test:*special* :foo)) + (assert (eql test:*special* :foo))) + (progn + (setf test:*special* :quux) + (assert (eql test:*special* :quux))) + (let ((test:unused :zot)) + (assert (eql test:unused :zot))) + + ;; symbol-macrolet + (symbol-macrolet ((test:function :sym-ok)) + (assert (eql test:function :sym-ok))) + (symbol-macrolet ((test:unused :sym-ok2)) + (assert (eql test:unused :sym-ok2))) + + ;; binding as a function + (flet ((test:*special* () :yes)) + (assert (eql (test:*special*) :yes))) + (flet ((test:unused () :yes!)) + (assert (eql (test:unused) :yes!))) + (labels ((test:*special* () :yes)) + (assert (eql (test:*special*) :yes))) + (labels ((test:unused () :yes!)) + (assert (eql (test:unused) :yes!))) + + ;; binding as a macro + (macrolet ((test:*special* () :ok)) + (assert (eql (test:*special*) :ok))) + )) + +;;; A collection of forms that cause runtime package lock violations +;;; on TEST, and will also signal an error on LOAD even if first +;;; compiled with COMPILE-FILE with TEST unlocked. +(defvar *illegal-runtime-forms* + '(;; package alterations + (intern *uninterned* :test) + (import 'not-from-test :test) + (export 'test::internal :test) + (unexport 'test:external :test) + (shadowing-import 'not-from-test :test) + (let ((p (find-package :test))) + (rename-package p :test '(:test-nick))) + (use-package :test-unused :test) + (unuse-package :test-used :test) + (shadow 'not-from-test :test) + (unintern (or (find-symbol *interned* :test) (error "bugo")) :test) + (delete-package :test-delete) + + ;; defining or undefining as a function + (defun test:unused () 'foo) + (setf (fdefinition 'test:unused) (lambda () 'bar)) + (setf (symbol-function 'test:unused) (lambda () 'quux)) + (tmp-fmakunbound 'test:function) + + ;; defining or undefining as a macro or compiler macro + (defmacro test:unused () ''foo) + (setf (macro-function 'test:unused) (constantly 'foo)) + (define-compiler-macro test:unused (&whole form arg) + form) + (setf (compiler-macro-function 'test:unused) (constantly 'foo)) + + ;; type-specifier or structure + (progn + (defstruct test:nostruct test:nostruct-slot) + ;; test creation as well, since the structure-class won't be + ;; finalized before that + (make-nostruct :nostruct-slot :foo)) + (defclass test:noclass () + ((slot :initform nil :accessor test:noclass-slot))) + (deftype test:notype () 'string) + (define-condition test:nocondition (error) + ((slot :initform nil :accessor test:nocondition-slot))) + + ;; symbol-macro + (define-symbol-macro test:nosymbol-macro 'foo) + + ;; declaration proclamation + (proclaim '(declaration test:unused)) + + ;; declare special + (declaim (special test:nospecial)) + (proclaim '(special test:nospecial)) + + ;; declare type + (declaim (type fixnum test:num)) + (proclaim '(type fixnum test:num)) + + ;; declare ftype + (declaim (ftype (function (fixnum) fixnum) test:numfun)) + (proclaim '(ftype (function (fixnum) fixnum) test:numfun)) + + ;; setf expanders + (defsetf test:car rplaca) ; strictly speaking wrong, but ok as a test + (defsetf test:car (cons) (new-car) + `(setf (car ,cons) ,new-car)) + (define-setf-expander test:car (place) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place) + (let ((store (gensym))) + (values dummies + vals + `(,store) + `(progn (rplaca ,getter ,store) ,store) + `(car ,getter))))) + + ;; setf function names + (defun (setf test:function) (obj) + obj) + (tmp-fmakunbound '(setf test:cdr)) + + ;; define-method-combination + (define-method-combination test:unused) + + ;; setf find-class + (setf (find-class 'test:class) (find-class 'standard-class)) + )) + +;;; Forms that cause violations on two distinct packages. +(defvar *illegal-double-forms* + '((defclass test:noclass () ((x :accessor test-aux:noslot))) + (define-condition test:nocondition (error) + ((x :accessor test-aux:noslot))))) + +;;; A collection of forms that cause compile-time package lock +;;; violations on TEST, and will not signal an error on LOAD if first +;;; compiled by COMPILE-FILE with test unlocked. CAR is the affected +;;; symbol, CDR the form affecting it. +(defvar *illegal-compile-time-forms-alist* + '(;; binding + + ;; binding as a function + (test:function . (flet ((test:function () :shite)) + (test:function))) + (test:function . (labels ((test:function () :shite)) + (test:function))) + (test:macro . (flet ((test:macro () :shite)) + (test:macro))) + (test:macro . (labels ((test:macro () :shite)) + (test:macro))) + + ;; macrolet + (test:function . (macrolet ((test:function () :yuk)) + (test:function))) + (test:macro . (macrolet ((test:macro () :yuk)) + (test:macro))) + + ;; setf name + (test:function . (flet (((setf test:function) (obj) + obj)) + (setf (test:function) 1))) + + ;; ftype + (test:function . (locally + (declare (ftype function test:function)) + (cons t t))) + + ;; type + (test:num . (locally + (declare (type fixnum test:num)) + (cons t t))) + + ;; special + (test:nospecial . (locally + (declare (special test:nospecial)) + (cons t t))) + + ;; declare ftype + (test:numfun . (locally + (declare (ftype (function (fixnum) fixnum) test:numfun)) + (cons t t))))) + +(defvar *illegal-compile-time-forms* (mapcar #'cdr *illegal-compile-time-forms-alist*)) + +(defvar *illegal-forms* (append *illegal-runtime-forms* + *illegal-compile-time-forms* + *illegal-double-forms*)) + +;;;; Running the tests + +;;; Unlocked. No errors nowhere. +(reset-test) +(set-test-locks nil) +(dolist (form (append *legal-forms* *illegal-forms*)) + (with-error-info ("~Unlocked form: ~S~%" form) + (eval form))) + +;;; Locked. Errors for all illegal forms, none for legal. +(reset-test) +(set-test-locks t) +(dolist (form *legal-forms*) + (with-error-info ("locked legal form: ~S~%" form) + (eval form))) +(reset-test) +(set-test-locks t) +(dolist (form (append *illegal-runtime-forms* *illegal-double-forms*)) + (with-error-info ("locked illegal runtime form: ~S~%" form) + (let ((fun (compile nil `(lambda () ,form)))) + (assert (raises-error? (funcall fun) sb-ext:package-lock-violation))))) +(dolist (pair *illegal-compile-time-forms-alist*) + (let ((form (cdr pair))) + (with-error-info ("locked illegal compile-time form: ~S~%" form) + (assert (raises-error? (compile nil `(lambda () ,form)) sb-ext:package-lock-violation))))) + +;;; Locked, WITHOUT-PACKAGE-LOCKS for runtime errors. +(reset-test) +(set-test-locks t) +(dolist (form *illegal-runtime-forms*) + (with-error-info ("without-package-locks illegal runtime form: ~S~%" form) + (funcall (compile nil `(lambda () (without-package-locks ,form)))))) + +;;; Locked, WITHOUT-PACKAGE-LOCKS & DISABLE-PACKAGE-LOCKS for compile-time errors. +(reset-test) +(set-test-locks t) +(dolist (pair *illegal-compile-time-forms-alist*) + (destructuring-bind (sym . form) pair + (with-error-info ("without-package-locks illegal compile-time form: ~S~%" form) + (let ((fun (without-package-locks (compile nil `(lambda () ,form))))) + (funcall fun))))) +(reset-test) +(set-test-locks t) +(dolist (pair *illegal-compile-time-forms-alist*) + (destructuring-bind (sym . form) pair + (with-error-info ("disable-package-locks illegal compile-time form: ~S~%" form) + (funcall (compile nil `(lambda () + (declare (disable-package-locks ,sym)) + ,form)))))) + +;;; Locked, one error per "lexically apparent violated package", also +;;; test restarts. +(reset-test) +(set-test-locks t) +(dolist (form (append *illegal-runtime-forms* *illegal-compile-time-forms*)) + (with-error-info ("one error per form: ~S~%") + (let ((errorp nil)) + (handler-bind ((package-lock-violation (lambda (e) + (when errorp + (error "multiple errors")) + (setf errorp t) + (continue e)))) + (eval form))))) +(dolist (form *illegal-double-forms*) + (with-error-info ("two errors per form: ~S~%" form) + (let ((error-count 0)) + ;; check that we don't get multiple errors from a single form + (handler-bind ((package-lock-violation (lambda (x) + (declare (ignore x)) + (incf error-count) + (continue x)))) + (eval form) + (unless (= 2 error-count) + (error "expected 2 errors per form, got ~A for ~A" + error-count form)))))) + +;;; COMPILE-FILE when unlocked, LOAD locked -- *illegal-runtime-forms* only +(let* ((tmp "package-locks.tmp.lisp") + (fasl (compile-file-pathname tmp)) + (n 0)) + (dolist (form *illegal-runtime-forms*) + (unwind-protect + (with-simple-restart (next "~S failed, continue with next test" form) + (reset-test) + (set-test-locks nil) + (with-open-file (f tmp :direction :output) + (prin1 form f)) + (multiple-value-bind (file warnings failure-p) (compile-file tmp) + (set-test-locks t) + (assert (raises-error? (load fasl) sb-ext:package-lock-violation)))) + (when (probe-file tmp) + (delete-file tmp)) + (when (probe-file fasl) + (delete-file fasl))))) + +;;;; Tests for enable-package-locks declarations +(reset-test) +(set-test-locks t) +(dolist (pair *illegal-compile-time-forms-alist*) + (destructuring-bind (sym . form) pair + (assert (raises-error? + (compile nil `(lambda () + (declare (disable-package-locks ,sym)) + ,form + (locally (declare (enable-package-locks ,sym)) + ,form))) + package-lock-violation)) + (assert (raises-error? + (eval `(locally (declare (disable-package-locks ,sym)) + ,form + (locally (declare (enable-package-locks ,sym)) + ,form))) + package-lock-violation)))) + +;;; WOOT! Done. +(sb-ext:quit :unix-status 104) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index e41d17d..91d3231 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -13,10 +13,12 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(in-package :cl-user) - (load "assertoid.lisp") -(use-package "ASSERTOID") + +(defpackage :seq-test + (:use :cl :assertoid)) + +(in-package :seq-test) ;;; helper functions for exercising SEQUENCE code on data of many ;;; specialized types, and in many different optimization scenarios @@ -874,4 +876,4 @@ (read-char s))))) ;;; success -(quit :unix-status 104) +(sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index f593c3a..d8c812c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.12.6" +"0.8.12.7" -- 1.7.10.4