hacking MNA "pcl cleanups" megapatch, phase IV..
The SB-PCL package now USE-PACKAGEs SB-INT and SB-EXT.
SB-INT no longer exports unused E.
SB-INT:ITERATE is now called SB-INT:NAMED-LET, to avoid
collision with SB-PCL::ITERATE.
The SB-ITERATE and SB-WALKER packages now use SB-INT
and SB-EXT too.
Now lotso SB-INT: prefixes in src/pcl/*.lisp can go away.
;; ..and macros..
"COLLECT"
"DO-ANONYMOUS" "DOHASH" "DOVECTOR"
- "ITERATE"
+ "NAMED-LET"
"LETF" "LETF*"
"ONCE-ONLY"
"DEFENUM"
;; FIXME: maybe belongs in %KERNEL with other typesystem stuff?
"CONSTANT-ARGUMENT"
- ;; FIXME: Maybe this isn't used any more? And if it is,
- ;; it probably needs a better name, since SPECIAL things
- ;; are such a nice source of sneaky bugs.
- "E"
-
;; various internal defaults
"*DEFAULT-PACKAGE-USE-LIST*"
"DEFAULT-INIT-CHAR"
#s(sb-cold:package-data
:name "SB!ITERATE"
- :doc "private: implementation of an iteration facility used by PCL"
- :use ("CL" "SB!WALKER")
+ :doc "private: an iteration facility used to implement PCL"
+ :use ("CL" "SB!WALKER" "SB!INT" "SB!EXT")
:export ("ITERATE" "ITERATE*" "GATHERING" "GATHER"
"WITH-GATHERING" "INTERVAL" "ELEMENTS"
"LIST-ELEMENTS" "LIST-TAILS" "PLIST-ELEMENTS"
extensions, but even they are not guaranteed to be present in
later versions of SBCL, and the other stuff in here is
definitely not guaranteed to be present in later versions of SBCL."
- :use ("CL" "SB!ITERATE" "SB!WALKER")
+ ;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL
+ ;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends
+ ;; up using a thundering herd of explicit prefixes to get to
+ ;; SB-KERNEL symbols. However, it'll probably be too messy to do
+ ;; this until the duplicate SB-PCL:CLASS/CL:CLASS hierarchy kludge
+ ;; is unscrewed, since until it is there are too many things which
+ ;; conflict between the two packages.
+ :use ("CL" "SB!ITERATE" "SB!WALKER" "SB!INT" "SB!EXT")
:import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "FUNCTION-DOC"
"PACKAGE-DOC-STRING"
"PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
- "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"
- "SB!INT" "SB!EXT")
- ("SB!INT" "MEMQ" "ASSQ" "DELQ" "POSQ" "NEQ"))
+ "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS"))
:reexport ("ADD-METHOD" "ALLOCATE-INSTANCE"
"COMPUTE-APPLICABLE-METHODS"
"ENSURE-GENERIC-FUNCTION"
#s(sb-cold:package-data
:name "SB!WALKER"
:doc "internal: a code walker used by PCL"
- :use ("CL")
+ :use ("CL" "SB!INT" "SB!EXT")
:export ("DEFINE-WALKER-TEMPLATE" "WALK-FORM"
"*WALK-FORM-EXPAND-MACROS-P*"
"VARIABLE-LEXICAL-P" "VARIABLE-SPECIAL-P"
macros))))
`(macrolet ,macros (let* ,(nreverse binds) ,@body))))
\f
+;;; This function can be used as the default value for keyword
+;;; arguments that must be always be supplied. Since it is known by
+;;; the compiler to never return, it will avoid any compile-time type
+;;; warnings that would result from a default value inconsistent with
+;;; the declared type. When this function is called, it signals an
+;;; error indicating that a required keyword argument was not
+;;; supplied. This function is also useful for DEFSTRUCT slot defaults
+;;; corresponding to required arguments.
(declaim (ftype (function () nil) required-argument))
(defun required-argument ()
#!+sb-doc
- "This function can be used as the default value for keyword arguments that
- must be always be supplied. Since it is known by the compiler to never
- return, it will avoid any compile-time type warnings that would result from a
- default value inconsistent with the declared type. When this function is
- called, it signals an error indicating that a required keyword argument was
- not supplied. This function is also useful for DEFSTRUCT slot defaults
- corresponding to required arguments."
(/show0 "entering REQUIRED-ARGUMENT")
(error "A required keyword argument was not supplied."))
\f
-;;; "the ultimate iteration macro"
+;;; "the ultimate iteration macro"
;;;
;;; note for Schemers: This seems to be identical to Scheme's "named LET".
-(defmacro iterate (name binds &body body)
+(defmacro named-let (name binds &body body)
#!+sb-doc
- "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
- This is syntactic sugar for Labels. It creates a local function Name with
- the specified Vars as its arguments and the Declarations and Forms as its
- body. This function is then called with the Initial-Values, and the result
- of the call is returned from the macro."
(dolist (x binds)
(unless (proper-list-of-length-p x 2)
(error "Malformed ITERATE variable spec: ~S." x)))
`(labels ((,name ,(mapcar #'first binds) ,@body))
(,name ,@(mapcar #'second binds))))
-\f
+
;;; ONCE-ONLY is a utility useful in writing source transforms and
;;; macros. It provides a concise way to wrap a LET around some code
;;; to ensure that some forms are only evaluated once.
;;; result of the evaluation of BODY. Within the body, each VAR is
;;; bound to the corresponding temporary variable.
(defmacro once-only (specs &body body)
- (iterate frob
- ((specs specs)
- (body body))
+ (named-let frob ((specs specs)
+ (body body))
(if (null specs)
`(progn ,@body)
(let ((spec (first specs)))
;;; implement suitable code as jump tables.
(defmacro expand-into-inlines ()
#+nil (declare (optimize (inhibit-warnings 3)))
- (iterate build-dispatch
- ((bit 4)
- (base 0))
+ (named-let build-dispatch ((bit 4)
+ (base 0))
(if (minusp bit)
(let ((info (svref *inline-functions* base)))
(if info
(closure-vars (make-array num-closure-vars)))
(declare (type index num-closure-vars)
(type simple-vector closure-vars))
- (iterate frob ((index (1- num-closure-vars)))
+ (named-let frob ((index (1- num-closure-vars)))
(unless (minusp index)
(setf (svref closure-vars index) (pop-eval-stack))
(frob (1- index))))
(type stack-pointer old-sp old-fp)
(type (or null simple-vector) closure-vars))
(when closure-vars
- (iterate more ((index (1- (length closure-vars))))
+ (named-let more ((index (1- (length closure-vars))))
(unless (minusp index)
(push-eval-stack (svref closure-vars index))
(more (1- index)))))
(a (make-array (length types) :fill-pointer 0)))
(dolist (%type types (coerce a 'list))
;; Merge TYPE into RESULT.
- (iterate again ((type %type))
+ (named-let again ((type %type))
(dotimes (i (length a) (vector-push-extend type a))
(let ((ai (aref a i)))
(multiple-value-bind (simplified win?)
(setf (initarg car-option)
`',(cdr option))))
((:documentation :generic-function-class :method-class)
- (unless (sb-int:proper-list-of-length-p option 2)
+ (unless (proper-list-of-length-p option 2)
(error "bad list length for ~S" option))
(if (initarg car-option)
(duplicate-option car-option)
(defun compile-or-load-defgeneric (function-name)
(sb-kernel:proclaim-as-function-name function-name)
(sb-kernel:note-name-defined function-name :function)
- (unless (eq (sb-int:info :function :where-from function-name) :declared)
- (setf (sb-int:info :function :where-from function-name) :defined)
- (setf (sb-int:info :function :type function-name)
+ (unless (eq (info :function :where-from function-name) :declared)
+ (setf (info :function :where-from function-name) :defined)
+ (setf (info :function :type function-name)
(sb-kernel:specifier-type 'function))))
(defun load-defgeneric (function-name lambda-list &rest initargs)
initargs-form &optional pv-table-symbol)
(let (fn
fn-lambda)
- (if (and (interned-symbol-p (sb-int:function-name-block-name name))
+ (if (and (interned-symbol-p (function-name-block-name name))
(every #'interned-symbol-p qualifiers)
(every #'(lambda (s)
(if (consp s)
;; force symbols to be printed
;; with explicit package
;; prefixes.)
- (*package* sb-int:*keyword-package*))
+ (*package* *keyword-package*))
(format nil "~S" mname)))))
`(progn
(defun ,mname-sym ,(cadr fn-lambda)
(declare (ignorable ,@required-parameters))
,class-declarations
,@declarations
- (block ,(sb-int:function-name-block-name
+ (block ,(function-name-block-name
generic-function-name)
,@real-body)))
(constant-value-p (and (null (cdr real-body))
,(cadr var)))))))
(rest `((,var ,args-tail)))
(key (cond ((not (consp var))
- `((,var (get-key-arg ,(sb-int:keywordicate var)
+ `((,var (get-key-arg ,(keywordicate var)
,args-tail))))
((null (cddr var))
(multiple-value-bind (keyword variable)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (sb-int:keywordicate (car var))
+ (values (keywordicate (car var))
(car var)))
`((,key (get-key-arg1 ',keyword ,args-tail))
(,variable (if (consp ,key)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (sb-int:keywordicate (car var))
+ (values (keywordicate (car var))
(car var)))
`((,key (get-key-arg1 ',keyword ,args-tail))
(,(caddr var) ,key)
next-method-p-p)))))
(defun generic-function-name-p (name)
- (and (sb-int:legal-function-name-p name)
+ (and (legal-function-name-p name)
(gboundp name)
(if (eq *boot-state* 'complete)
(standard-generic-function-p (gdefinition name))
(if (listp arg)
(if (listp (car arg))
(caar arg)
- (sb-int:keywordicate (car arg)))
- (sb-int:keywordicate arg))))
+ (keywordicate (car arg)))
+ (keywordicate arg))))
(let ((nrequired 0)
(noptional 0)
(keysp nil)
(defun keyword-spec-name (x)
(let ((key (if (atom x) x (car x))))
(if (atom key)
- (intern (symbol-name key) sb-int:*keyword-package*)
+ (keywordicate key)
(car key))))
(defun ftype-declaration-from-lambda-list (lambda-list name)
keywords keyword-parameters)
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
- (let* ((old (sb-int:info :function :type name)) ;FIXME:FDOCUMENTATION instead?
+ (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
(old-ftype (if (sb-kernel:function-type-p old) old nil))
(old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype)))
(old-keys (and old-ftype
;;; CAR - a list of the early methods on this early gf
;;; CADR - the early discriminator code for this method
(defun ensure-generic-function-using-class (existing spec &rest keys
- &key (lambda-list nil lambda-list-p)
+ &key (lambda-list nil
+ lambda-list-p)
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
(real-get-method generic-function qualifiers specializers errorp)))
(defun !fix-early-generic-functions ()
- (sb-int:/show "entering !FIX-EARLY-GENERIC-FUNCTIONS")
(let ((accessors nil))
;; Rearrange *!EARLY-GENERIC-FUNCTIONS* to speed up
;; FIX-EARLY-GENERIC-FUNCTIONS.
(dolist (early-gf-spec *!early-generic-functions*)
- (sb-int:/show early-gf-spec)
(when (every #'early-method-standard-accessor-p
(early-gf-methods (gdefinition early-gf-spec)))
(push early-gf-spec accessors)))
standard-class-p
funcallable-standard-class-p
specializerp)))
- (sb-int:/show spec)
+ (/show spec)
(setq *!early-generic-functions*
(cons spec
(delete spec *!early-generic-functions* :test #'equal))))
(dolist (early-gf-spec *!early-generic-functions*)
- (sb-int:/show early-gf-spec)
+ (/show early-gf-spec)
(let* ((gf (gdefinition early-gf-spec))
(methods (mapcar #'(lambda (early-method)
(let ((args (copy-list (fifth
(set-methods gf methods)))
(dolist (fn *!early-functions*)
- (sb-int:/show fn)
+ (/show fn)
(setf (gdefinition (car fn)) (fdefinition (caddr fn))))
(dolist (fixup *!generic-function-fixups*)
- (sb-int:/show fixup)
+ (/show fixup)
(let* ((fspec (car fixup))
(gf (gdefinition fspec))
(methods (mapcar #'(lambda (method)
(setf (generic-function-method-combination gf)
*standard-method-combination*)
(set-methods gf methods))))
- (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
+ (/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS"))
\f
;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument
;;; into the 'real' arguments. This is where the syntax of DEFMETHOD
(i 0 (1+ i)))
((>= i no-of-slots)) ;endp rem-slots))
(declare (list rem-slots)
- (type sb-int:index i))
+ (type index i))
(setf (aref slots i) (first rem-slots)))
slots))
(t
(!bootstrap-class-predicates nil)
(!bootstrap-built-in-classes)
- (sb-int:dohash (name x *find-class*)
+ (dohash (name x *find-class*)
(let* ((class (find-class-from-cell name x))
(layout (class-wrapper class))
(lclass (sb-kernel:layout-class layout))
(in-package "SB-PCL")
\f
-;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL
-;;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends
-;;; up using a thundering herd of explicit prefixes to get to
-;;; SB-KERNEL symbols. Using the SB-INT and SB-EXT packages as well
-;;; would help reduce prefixing and make it more natural to reuse
-;;; things (ONCE-ONLY, *KEYWORD-PACKAGE*..) used in the main body of
-;;; the system. However, that would cause a conflict between the
-;;; SB-ITERATE:ITERATE macro and the SB-INT:ITERATE macro. (This could
-;;; be resolved by renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or
-;;; with more gruntwork by punting the SB-ITERATE package and
-;;; replacing calls to SB-ITERATE:ITERATE with calls to CL:LOOP.
-;;; So perhaps:
-;;; * Do some sort of automated check for overlap of symbols to make
-;;; sure there wouldn't be any other clashes.
-;;; * Rename SB-INT:ITERATE to SB-INT:NAMED-LET.
-;;; * Make SB-PCL use SB-INT and SB-EXT.
-;;; * Grep for SB-INT: and SB-EXT: prefixes in the pcl/ directory
-;;; and delete them.
-
;;; The caching algorithm implemented:
;;;
;;; << put a paper here >>
;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
;;; SB-PCL:*BUILT-IN-CLASSES*.
-(sb-int:/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
+(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (sb-int:/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
(if (typep class 'cl:built-in-class)
(sb-kernel:built-in-class-direct-superclasses class)
(let ((inherits (sb-kernel:layout-inherits
(sb-kernel:class-layout class))))
- (sb-int:/show inherits)
+ (/show inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (sb-int:/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
- (sb-int:collect ((res))
+ (/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (collect ((res))
(let ((subs (sb-kernel:class-subclasses class)))
- (sb-int:/show subs)
+ (/show subs)
(when subs
- (sb-int:dohash (sub v subs)
+ (dohash (sub v subs)
(declare (ignore v))
- (sb-int:/show sub)
+ (/show sub)
(when (member class (direct-supers sub))
(res sub)))))
(res)))
;; relevant cases.
42))))
(mapcar (lambda (kernel-bic-entry)
- (sb-int:/show "setting up" kernel-bic-entry)
+ (/show "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
(class (cl:find-class name)))
- (sb-int:/show name class)
+ (/show name class)
`(,name
,(mapcar #'cl:class-name (direct-supers class))
,(mapcar #'cl:class-name (direct-subs class))
sb-kernel:funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
-(sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
;; FIXME: could test harder to see whether it's a SETF function name,
;; then call WARN
(when (eq (first x) 'setf) ; Give up if not a setf function name.
- (or (values (sb-int:info :setf :documentation (second x)))
+ (or (values (info :setf :documentation (second x)))
;; Try the pcl function documentation.
(and (fboundp x) (documentation (fdefinition x) t)))))
(defmethod documentation ((x symbol) (doc-type (eql 'function)))
- (or (values (sb-int:info :function :documentation x))
+ (or (values (info :function :documentation x))
;; Try the pcl function documentation.
(and (fboundp x) (documentation (fdefinition x) t))))
(defmethod documentation ((x symbol) (doc-type (eql 'setf)))
- (values (sb-int:info :setf :documentation x)))
+ (values (info :setf :documentation x)))
(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
- (setf (sb-int:info :setf :documentation (cadr x)) new-value))
+ (setf (info :setf :documentation (cadr x)) new-value))
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql 'function)))
- (setf (sb-int:info :function :documentation x) new-value))
+ (setf (info :function :documentation x) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
- (setf (sb-int:info :setf :documentation x) new-value))
+ (setf (info :setf :documentation x) new-value))
;;; packages
(defmethod documentation ((x package) (doc-type (eql 't)))
;;; types, classes, and structure names
(defmethod documentation ((x cl:structure-class) (doc-type (eql 't)))
- (values (sb-int:info :type :documentation (cl:class-name x))))
+ (values (info :type :documentation (cl:class-name x))))
(defmethod documentation ((x structure-class) (doc-type (eql 't)))
- (values (sb-int:info :type :documentation (class-name x))))
+ (values (info :type :documentation (class-name x))))
(defmethod documentation ((x cl:standard-class) (doc-type (eql 't)))
- (or (values (sb-int:info :type :documentation (cl:class-name x)))
+ (or (values (info :type :documentation (cl:class-name x)))
(let ((pcl-class (sb-kernel:class-pcl-class x)))
(and pcl-class (plist-value pcl-class 'documentation)))))
(defmethod documentation ((x cl:structure-class) (doc-type (eql 'type)))
- (values (sb-int:info :type :documentation (cl:class-name x))))
+ (values (info :type :documentation (cl:class-name x))))
(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
- (values (sb-int:info :type :documentation (class-name x))))
+ (values (info :type :documentation (class-name x))))
(defmethod documentation ((x cl:standard-class) (doc-type (eql 'type)))
- (or (values (sb-int:info :type :documentation (cl:class-name x)))
+ (or (values (info :type :documentation (cl:class-name x)))
(let ((pcl-class (sb-kernel:class-pcl-class x)))
(and pcl-class (plist-value pcl-class 'documentation)))))
(defmethod documentation ((x symbol) (doc-type (eql 'type)))
- (or (values (sb-int:info :type :documentation x))
+ (or (values (info :type :documentation x))
(let ((class (find-class x nil)))
(when class
(plist-value class 'documentation)))))
(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
- (when (eq (sb-int:info :type :kind x) :instance)
- (values (sb-int:info :type :documentation x))))
+ (when (eq (info :type :kind x) :instance)
+ (values (info :type :documentation x))))
(defmethod (setf documentation) (new-value
(x cl:structure-class)
(doc-type (eql 't)))
- (setf (sb-int:info :type :documentation (cl:class-name x)) new-value))
+ (setf (info :type :documentation (cl:class-name x)) new-value))
(defmethod (setf documentation) (new-value
(x structure-class)
(doc-type (eql 't)))
- (setf (sb-int:info :type :documentation (class-name x)) new-value))
+ (setf (info :type :documentation (class-name x)) new-value))
(defmethod (setf documentation) (new-value
(x cl:structure-class)
(doc-type (eql 'type)))
- (setf (sb-int:info :type :documentation (cl:class-name x)) new-value))
+ (setf (info :type :documentation (cl:class-name x)) new-value))
(defmethod (setf documentation) (new-value
(x structure-class)
(doc-type (eql 'type)))
- (setf (sb-int:info :type :documentation (class-name x)) new-value))
+ (setf (info :type :documentation (class-name x)) new-value))
(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
(if (structure-type-p x) ; Catch structures first.
- (setf (sb-int:info :type :documentation x) new-value)
+ (setf (info :type :documentation x) new-value)
(let ((class (find-class x nil)))
(if class
(setf (plist-value class 'documentation) new-value)
- (setf (sb-int:info :type :documentation x) new-value)))))
+ (setf (info :type :documentation x) new-value)))))
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql 'structure)))
- (unless (eq (sb-int:info :type :kind x) :instance)
+ (unless (eq (info :type :kind x) :instance)
(error "~S is not the name of a structure type." x))
- (setf (sb-int:info :type :documentation x) new-value))
+ (setf (info :type :documentation x) new-value))
;;; variables
(defmethod documentation ((x symbol) (doc-type (eql 'variable)))
- (values (sb-int:info :variable :documentation x)))
+ (values (info :variable :documentation x)))
(defmethod (setf documentation) (new-value
(x symbol)
(doc-type (eql 'variable)))
- (setf (sb-int:info :variable :documentation x) new-value))
+ (setf (info :variable :documentation x) new-value))
;;; miscellaneous documentation. Compiler-macro documentation is stored
;;; as random-documentation and handled here.
(defmethod documentation ((x symbol) (doc-type symbol))
(cdr (assoc doc-type
- (values (sb-int:info :random-documentation :stuff x)))))
+ (values (info :random-documentation :stuff x)))))
(defmethod (setf documentation) (new-value (x symbol) (doc-type symbol))
- (let ((pair (assoc doc-type (sb-int:info :random-documentation :stuff x))))
+ (let ((pair (assoc doc-type (info :random-documentation :stuff x))))
(if pair
(setf (cdr pair) new-value)
(push (cons doc-type new-value)
- (sb-int:info :random-documentation :stuff x))))
+ (info :random-documentation :stuff x))))
new-value)
;;; FIXME: The ((X SYMBOL) (DOC-TYPE SYMBOL)) method and its setf method should
(defmacro built-in-or-structure-wrapper (x) `(sb-kernel:layout-of ,x))
(defmacro get-wrapper (inst)
- (sb-int:once-only ((wrapper `(wrapper-of ,inst)))
+ (once-only ((wrapper `(wrapper-of ,inst)))
`(progn
(assert (typep ,wrapper 'wrapper) () "What kind of instance is this?")
,wrapper)))
;;; FIXME: could be an inline function (like many other things around
;;; here)
(defmacro get-instance-wrapper-or-nil (inst)
- (sb-int:once-only ((wrapper `(wrapper-of ,inst)))
+ (once-only ((wrapper `(wrapper-of ,inst)))
`(if (typep ,wrapper 'wrapper)
,wrapper
nil)))
(defmacro get-slots-or-nil (inst)
- (sb-int:once-only ((n-inst inst))
+ (once-only ((n-inst inst))
`(when (pcl-instance-p ,n-inst)
(if (std-instance-p ,n-inst)
(std-instance-slots ,n-inst)
\f
;;;; the PRINT-OBJECT generic function
-;;; Blow away the old non-generic function placeholder which was used by the
-;;; printer doing bootstrapping, and immediately replace it with some new
-;;; printing logic, so that the Lisp printer stays crippled only for the
-;;; shortest necessary time.
+;;; Blow away the old non-generic function placeholder which was used
+;;; by the printer doing bootstrapping, and immediately replace it
+;;; with some new printing logic, so that the Lisp printer stays
+;;; crippled only for the shortest necessary time.
(let (;; (If we don't suppress /SHOW printing while the printer is
;; crippled here, it becomes really easy to crash the bootstrap
;; sequence by adding /SHOW statements e.g. to the compiler,
;; which kinda defeats the purpose of /SHOW being a harmless
;; tracing-style statement.)
- #+sb-show (sb-int:*/show* nil))
+ #+sb-show (*/show* nil))
(fmakunbound 'print-object)
(defgeneric print-object (object stream))
(defmethod print-object ((x t) stream)
(variable-globally-special-p var)))
(defun variable-globally-special-p (symbol)
- (eq (sb-int:info :variable :kind symbol) :special))
+ (eq (info :variable :kind symbol) :special))
\f
;;;; handling of special forms
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.10.22"
+"0.6.10.23"
projects / sbcl.git / commitdiff