("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")
(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*))
(if (zerop *break-level*) ; restart added by SBCL
(repl :continuable continuable)
- (let ((level *break-level*))
+ (let ((level *break-level*))
(with-simple-restart
(abort "~@<Reduce debugger level (to break level ~W).~@:>"
level)
(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
(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"))
-
(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))
(: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
(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
(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)
(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))
\f
(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)
(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%")))
(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~%")
;; 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)
(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
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-*
# 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
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
--- /dev/null
+@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}.
--- /dev/null
+@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
* Efficiency::
* Beyond The ANSI Standard::
* The Foreign Function Interface::
+* Package Locks::
* Contributed Modules::
* Concept Index::
* Function Index::
@include efficiency.texinfo
@include beyond-ansi.texinfo
@include ffi.texinfo
+@include package-locks.texi-temp
@include contrib-modules.texinfo
@include backmatter.texinfo
(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
"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"
"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"
;; 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).
(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
(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)
(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
\f
;;;; various other (not specified by ANSI) CONDITIONs
;;;;
#!+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))
(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
;; 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)
nil))
(defmacro defpackage (package &rest options)
- #!+sb-doc
- "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
- following:
- (:NICKNAMES {package-name}*)
- (:SIZE <integer>)
- (:SHADOW {symbol-name}*)
- (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
- (:USE {package-name}*)
- (:IMPORT-FROM <package-name> {symbol-name}*)
- (:INTERN {symbol-name}*)
- (:EXPORT {symbol-name}*)
- (:DOCUMENTATION doc-string)
- All options except :SIZE and :DOCUMENTATION can be used multiple times."
+ #!+sb-doc
+ #.(format nil
+ "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
+ following: ~{~&~4T~A~}
+ All options except ~{~A, ~}and :DOCUMENTATION can be used multiple
+ times."
+ '((:nicknames "{package-name}*")
+ (:size "<integer>")
+ (:shadow "{symbol-name}*")
+ (:shadowing-import-from "<package-name> {symbol-name}*")
+ (:use "{package-name}*")
+ (:import-from "<package-name> {symbol-name}*")
+ (:intern "{symbol-name}*")
+ (:export "{symbol-name}*")
+ #!+sb-package-locks (:implement "{package-name}*")
+ #!+sb-package-locks (:lock "boolean")
+ (:documentation "doc-string"))
+ '(:size #!+sb-package-locks :lock))
(let ((nicknames nil)
(size nil)
(shadows nil)
(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
(: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
`(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)
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)
(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))
(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))
(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
(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
(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
"the default for the :VERBOSE argument to LOAD")
(defvar *load-code-verbose* nil)
-
--- /dev/null
+;;;; 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)
(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)))))
(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 ~
(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
;; 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
((macrolet)
(destructuring-bind (definitions &rest body)
(rest exp)
- (let ((lexenv
+ (let ((lexenv
(let ((sb!c:*lexenv* lexenv))
(sb!c::funcall-in-macrolet-lexenv
definitions
: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
(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))
#!+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)))))))
\f
;;;; FBOUNDP and FMAKUNBOUND
(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))
(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
(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)
;; 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))
\f
;;;; iteration macros
(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
(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
;;; 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*)
(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)
(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
(setf res (%make-package-hashtable table hash size)))
res)))
\f
+;;;; package locking operations, built conditionally on :sb-package-locks
+
+#!+sb-package-locks
+(progn
+(defun package-locked-p (package)
+ #!+sb-doc
+ "Returns T when PACKAGE is locked, NIL otherwise. Signals an error
+if PACKAGE doesn't designate a valid package."
+ (package-lock (find-undeleted-package-or-lose package)))
+
+(defun lock-package (package)
+ #!+sb-doc
+ "Locks PACKAGE and returns T. Has no effect if PACKAGE was already
+locked. Signals an error if PACKAGE is not a valid package designator"
+ (setf (package-lock (find-undeleted-package-or-lose package)) t))
+
+(defun unlock-package (package)
+ #!+sb-doc
+ "Unlocks PACKAGE and returns T. Has no effect if PACKAGE was already
+unlocked. Signals an error if PACKAGE is not a valid package designator."
+ (setf (package-lock (find-undeleted-package-or-lose package)) nil)
+ t)
+
+(defun package-implemented-by-list (package)
+ #!+sb-doc
+ "Returns a list containing the implementation packages of
+PACKAGE. Signals an error if PACKAGE is not a valid package designator."
+ (package-%implementation-packages (find-undeleted-package-or-lose package)))
+
+(defun package-implements-list (package)
+ #!+sb-doc
+ "Returns the packages that PACKAGE is an implementation package
+of. Signals an error if PACKAGE is not a valid package designator."
+ (let ((package (find-undeleted-package-or-lose package)))
+ (loop for x in (list-all-packages)
+ when (member package (package-%implementation-packages x))
+ collect x)))
+
+(defun add-implementation-package (packages-to-add
+ &optional (package *package*))
+ #!+sb-doc
+ "Adds PACKAGES-TO-ADD as implementation packages of PACKAGE. Signals
+an error if PACKAGE or any of the PACKAGES-TO-ADD is not a valid
+package designator."
+ (let ((package (find-undeleted-package-or-lose package))
+ (packages-to-add (package-listify packages-to-add)))
+ (setf (package-%implementation-packages package)
+ (union (package-%implementation-packages package)
+ (mapcar #'find-undeleted-package-or-lose packages-to-add)))))
+
+(defun remove-implementation-package (packages-to-remove
+ &optional (package *package*))
+ #!+sb-doc
+ "Removes PACKAGES-TO-REMOVE from the implementation packages of
+PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-REMOVE
+is not a valid package designator."
+ (let ((package (find-undeleted-package-or-lose package))
+ (packages-to-remove (package-listify packages-to-remove)))
+ (setf (package-%implementation-packages package)
+ (nset-difference
+ (package-%implementation-packages package)
+ (mapcar #'find-undeleted-package-or-lose packages-to-remove)))))
+
+(defmacro with-unlocked-packages ((&rest packages) &body forms)
+ #!+sb-doc
+ "Unlocks PACKAGES for the dynamic scope of the body. Signals an
+error if any of PACKAGES is not a valid package designator."
+ (with-unique-names (unlocked-packages)
+ `(let (,unlocked-packages)
+ (unwind-protect
+ (progn
+ (dolist (p ',packages)
+ (when (package-locked-p p)
+ (push p ,unlocked-packages)
+ (unlock-package p)))
+ ,@forms)
+ (dolist (p ,unlocked-packages)
+ (when (find-package p)
+ (lock-package p)))))))
+
+(defun package-lock-violation (package &key (symbol nil symbol-p)
+ format-control format-arguments)
+ (let ((restart :continue)
+ (cl-violation-p (eq package (find-package :common-lisp))))
+ (flet ((error-arguments ()
+ (append (list (if symbol-p
+ 'symbol-package-locked-error
+ 'package-locked-error)
+ :package package
+ :format-control format-control
+ :format-arguments format-arguments)
+ (when symbol-p (list :symbol symbol))
+ (list :references
+ (append '((:sbcl :node "Package Locks"))
+ (when cl-violation-p
+ '((:ansi-cl :section (11 1 2 1 2)))))))))
+ (restart-case
+ (apply #'cerror "Ignore the package lock." (error-arguments))
+ (:ignore-all ()
+ :report "Ignore all package locks in the context of this operation."
+ (setf restart :ignore-all))
+ (:unlock-package ()
+ :report "Unlock the package."
+ (setf restart :unlock-package)))
+ (ecase restart
+ (:continue
+ (pushnew package *ignored-package-locks*))
+ (:ignore-all
+ (setf *ignored-package-locks* t))
+ (:unlock-package
+ (unlock-package package))))))
+
+(defun package-lock-violation-p (package &optional (symbol nil symbolp))
+ ;; KLUDGE: (package-lock package) needs to be before
+ ;; comparison to *package*, since during cold init this gets
+ ;; called before *package* is bound -- but no package should
+ ;; be locked at that point.
+ (and package
+ (package-lock package)
+ ;; In package or implementation package
+ (not (or (eq package *package*)
+ (member *package* (package-%implementation-packages package))))
+ ;; Runtime disabling
+ (not (eq t *ignored-package-locks*))
+ (or (eq :invalid *ignored-package-locks*)
+ (not (member package *ignored-package-locks*)))
+ ;; declarations for symbols
+ (not (and symbolp (member symbol (disabled-package-locks))))))
+
+(defun disabled-package-locks ()
+ (if (boundp 'sb!c::*lexenv*)
+ (sb!c::lexenv-disabled-package-locks sb!c::*lexenv*)
+ sb!c::*disabled-package-locks*))
+
+) ; progn
+
+;;;; more package-locking these are NOPs unless :sb-package-locks is
+;;;; in target features. Cross-compiler NOPs for these are in cross-misc.
+
+;;; The right way to establish a package lock context is
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR, defined in early-package.lisp
+;;;
+;;; Must be used inside the dynamic contour established by
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR
+(defun assert-package-unlocked (package &optional format-control
+ &rest format-arguments)
+ #!-sb-package-locks
+ (declare (ignore format-control format-arguments))
+ #!+sb-package-locks
+ (when (package-lock-violation-p package)
+ (package-lock-violation package
+ :format-control format-control
+ :format-arguments format-arguments))
+ package)
+
+;;; Must be used inside the dynamic contour established by
+;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR.
+;;;
+;;; FIXME: Maybe we should establish such contours for he toplevel
+;;; and others, so that %set-fdefinition and others could just use
+;;; this.
+(defun assert-symbol-home-package-unlocked (name format)
+ #!-sb-package-locks
+ (declare (ignore format))
+ #!+sb-package-locks
+ (let* ((symbol (etypecase name
+ (symbol name)
+ (list (if (eq 'setf (first name))
+ (second name)
+ ;; Skip (class-predicate foo), etc.
+ ;; FIXME: MOP and package-lock
+ ;; interaction needs to be thought about.
+ (return-from
+ assert-symbol-home-package-unlocked
+ name)))))
+ (package (symbol-package symbol)))
+ (when (package-lock-violation-p package symbol)
+ (package-lock-violation package
+ :symbol symbol
+ :format-control format
+ :format-arguments (list name))))
+ name)
+
+\f
;;;; miscellaneous PACKAGE operations
(def!method print-object ((package package) stream)
"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)
((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
;; 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
(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
(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))))))
\f
;;; Take a symbol-or-list-of-symbols and return a list, checking types.
(defun symbol-listify (thing)
(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
(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))
\f
;;; Check that all symbols are accessible, then move from external to internal.
(defun unexport (symbols &optional (package (sane-package)))
: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))
\f
;;; Check for name conflict caused by the import and let the user
"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)
(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))))
\f
;;; If a conflicting symbol is present, unintern it, otherwise just
;;; stick the symbol in.
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)))
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)
\f
;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
(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)
(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.
\f
;;;; 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)))
+
\f
;;;; package hacking
"public: the default package for user code and data")
#+sb-doc (setf (documentation (find-package "KEYWORD") t)
"public: home of keywords")
+\f
+
,@(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
(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
,@(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)
(/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*
(defvar *current-component*)
(defvar *delayed-ir1-transforms*)
(defvar *handled-conditions*)
+(defvar *disabled-package-locks*)
(defvar *policy*)
(defvar *dynamic-counts-tn*)
(defvar *elsewhere*)
(values)
())
(defknown style-warn (string &rest t) null ())
+
(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))
\f
;;;; a subset of DOCUMENTATION functionality for bootstrapping
(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
(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))
(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)
(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)
((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))))))
(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
(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)
(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
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
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)))))))
+
\f
;;;; the THE special operator, and friends
(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)
(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)
(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)))
(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
(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))
(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)))
(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
nil
nil
(lexenv-handled-conditions lexenv)
+ (lexenv-disabled-package-locks lexenv)
(lexenv-policy lexenv))))
\f
;;;; flow/DFO/component hackery
(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 . <function>) (a
(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))
(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)))))
;; 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,
(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)))
((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))
((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
(*policy* *policy*)
(*handled-conditions* *handled-conditions*)
+ (*disabled-package-locks* *disabled-package-locks*)
(*lexenv* (make-null-lexenv))
(*block-compile* *block-compile-arg*)
(*source-info* info)
(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).
(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).
(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
(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)
(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)
(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
(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)
(*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
(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))
`(list ,@(mapcar (lambda (specializer)
(if (consp specializer)
``(,',(car specializer)
- ,,(cadr specializer))
+ ,,(cadr specializer))
`',specializer))
specializers))
unspecialized-lambda-list
;; 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)))))
(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
(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
(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."
(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:
;;
(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)))
(*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.
;;; 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)))
\f
;;; ***********************************************
(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.
;; 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))))))))
\f
;;; **************************************************
(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
(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)
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
(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
,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)
\f
(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))))
\f
;;;; standard method combination
(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)))
\f
(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))
(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))))
(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)))))
+
\f
;;; FIXME: probably no longer needed after init
(defmacro precompile-random-code-segments (&optional system)
(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")
(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")))))
\f
(defmethod generic-function-argument-precedence-order
((gf standard-generic-function))
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)
(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)
(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))))
(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))
(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)))))))
\f
(defun add-direct-subclasses (class supers)
(dolist (super supers)
;; 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)
`(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
(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))
/*
- $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.
-/* $Header$ */
-
#ifdef LANGUAGE_ASSEMBLY
#define REG(num) $ ## num
#else
;;; 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).
\f
;;; 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))
\f
;;; 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)
--- /dev/null
+;;;; 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)
;;;; 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
(read-char s)))))
\f
;;; success
-(quit :unix-status 104)
+(sb-ext:quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff