;;; We define a keyword "BOA" constructor so that we can reference the
;;; slot names in init forms.
(def!macro def-alien-type-class ((name &key include include-args) &rest slots)
- (let ((defstruct-name
- (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
+ (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
(multiple-value-bind (include include-defstruct overrides)
(etypecase include
(null
(symbol
(values
include
- (intern (concatenate 'string
- "ALIEN-" (symbol-name include) "-TYPE"))
+ (symbolicate "ALIEN-" include "-TYPE")
nil))
(list
(values
(car include)
- (intern (concatenate 'string
- "ALIEN-" (symbol-name (car include)) "-TYPE"))
+ (symbolicate "ALIEN-" (car include) "-TYPE")
(cdr include))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(:class ',name)
,@overrides)
(:constructor
- ,(intern (concatenate 'string "MAKE-"
- (string defstruct-name)))
+ ,(symbolicate "MAKE-" defstruct-name)
(&key class bits alignment
,@(mapcar #'(lambda (x)
(if (atom x) x (car x)))
,@slots)))))
(def!macro def-alien-type-method ((class method) lambda-list &rest body)
- (let ((defun-name (intern (concatenate 'string
- (symbol-name class)
- "-"
- (symbol-name method)
- "-METHOD"))))
+ (let ((defun-name (symbolicate class "-" method "-METHOD")))
`(progn
(defun ,defun-name ,lambda-list
,@body)
`(progn
(defun ,defun-name (,directive ,directives)
,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
+ `((let ,(mapcar (lambda (var)
+ `(,var
+ (,(symbolicate "FORMAT-DIRECTIVE-" var)
+ ,directive)))
(butlast lambda-list))
,@body))
`((declare (ignore ,directive ,directives))
(posn 0 :type posn))
(defmacro enqueue (stream type &rest args)
- (let ((constructor (intern (concatenate 'string
- "MAKE-"
- (symbol-name type)))))
+ (let ((constructor (symbolicate "MAKE-" type)))
(once-only ((stream stream)
(entry `(,constructor :posn
(index-posn
(defun ,defun-name (stream ,directive ,directives orig-args args)
(declare (ignorable stream orig-args args))
,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
+ `((let ,(mapcar (lambda (var)
+ `(,var
+ (,(symbolicate "FORMAT-DIRECTIVE-" var)
+ ,directive)))
(butlast lambda-list))
(values (progn ,@body) args)))
`((declare (ignore ,directive ,directives))
(early-name (cadr fns)))
(setf (gdefinition name)
(set-function-name
- #'(lambda (&rest args)
- (apply (the function (name-get-fdefinition early-name)) args))
+ (lambda (&rest args)
+ (apply (fdefinition early-name) args))
name))))
) ; EVAL-WHEN
;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30
,@(remove nil
(mapcar (lambda (a s) (and (symbolp s)
- (neq s 't)
+ (neq s t)
`(%class ,a ,s)))
parameters
specializers))
(extract-declarations (cddr walked-lambda))
(declare (ignore ignore))
(when (or next-method-p-p call-next-method-p)
- (setq plist (list* :needs-next-methods-p 't plist)))
+ (setq plist (list* :needs-next-methods-p t plist)))
(when (some #'cdr slots)
(multiple-value-bind (slot-name-lists call-list)
(slot-name-lists-from-slots slots calls)
;; like :LOAD-TOPLEVEL.
((not (listp form)) form)
((eq (car form) 'call-next-method)
- (setq call-next-method-p 't)
+ (setq call-next-method-p t)
form)
((eq (car form) 'next-method-p)
- (setq next-method-p-p 't)
+ (setq next-method-p-p t)
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
- (setq call-next-method-p 't)
+ (setq call-next-method-p t)
(setq closurep t)
form)
((eq (cadr form) 'next-method-p)
- (setq next-method-p-p 't)
+ (setq next-method-p-p t)
(setq closurep t)
form)
(t nil))))
pv-table-symbol))
(when (and (eq *boot-state* 'complete)
(fboundp gf-spec))
- (let* ((gf (name-get-fdefinition gf-spec))
+ (let* ((gf (fdefinition gf-spec))
(method (and (generic-function-p gf)
(find-method gf
qualifiers
(if (memq x lambda-list-keywords)
(case x
(&optional (setq state 'optional))
- (&key (setq keysp 't
+ (&key (setq keysp t
state 'key))
- (&allow-other-keys (setq allow-other-keys-p 't))
- (&rest (setq restp 't
+ (&allow-other-keys (setq allow-other-keys-p t))
+ (&rest (setq restp t
state 'rest))
(&aux (return t))
(otherwise
- (error "encountered the non-standard lambda list keyword ~S" x)))
+ (error "encountered the non-standard lambda list keyword ~S"
+ x)))
(ecase state
(required (incf nrequired))
(optional (incf noptional))
(old-restp (and old-ftype (sb-kernel:function-type-rest old-ftype)))
(old-keys (and old-ftype
(mapcar #'sb-kernel:key-info-name
- (sb-kernel:function-type-keywords old-ftype))))
+ (sb-kernel:function-type-keywords
+ old-ftype))))
(old-keysp (and old-ftype (sb-kernel:function-type-keyp old-ftype)))
- (old-allowp (and old-ftype (sb-kernel:function-type-allowp old-ftype)))
+ (old-allowp (and old-ftype
+ (sb-kernel:function-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
- `(function ,(append (make-list nrequired :initial-element 't)
+ `(function ,(append (make-list nrequired :initial-element t)
(when (plusp noptional)
(append '(&optional)
- (make-list noptional :initial-element 't)))
+ (make-list noptional :initial-element t)))
(when (or restp old-restp)
'(&rest t))
(when (or keysp old-keysp)
(length (arg-info-metatypes arg-info)))
(defun arg-info-nkeys (arg-info)
- (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
+ (count-if #'(lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
;;; Keep pages clean by not setting if the value is already the same.
(defmacro esetf (pos val)
metatypes
arg-info))
(values (length metatypes) applyp metatypes
- (count-if #'(lambda (x) (neq x 't)) metatypes)
+ (count-if #'(lambda (x) (neq x t)) metatypes)
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
(if (every #'(lambda (s) (not (symbolp s))) specializers)
(setq parsed specializers
unparsed (mapcar #'(lambda (s)
- (if (eq s 't) 't (class-name s)))
+ (if (eq s t) t (class-name s)))
specializers))
(setq unparsed specializers
parsed ()))
(defun early-method-specializers (early-method &optional objectsp)
(if (and (listp early-method)
(eq (car early-method) :early-method))
- (cond ((eq objectsp 't)
+ (cond ((eq objectsp t)
(or (fourth early-method)
(setf (fourth early-method)
(mapcar #'find-class (cadddr (fifth early-method))))))
(or (dolist (m (early-gf-methods generic-function))
(when (and (or (equal (early-method-specializers m nil)
specializers)
- (equal (early-method-specializers m 't)
+ (equal (early-method-specializers m t)
specializers))
(equal (early-method-qualifiers m) qualifiers))
(return m)))
(dolist (fn *!early-functions*)
(sb-int:/show fn)
- (setf (gdefinition (car fn)) (name-get-fdefinition (caddr fn))))
+ (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
(dolist (fixup *!generic-function-fixups*)
(sb-int:/show fixup)
(specializers (second method))
(method-fn-name (third method))
(fn-name (or method-fn-name fspec))
- (fn (name-get-fdefinition fn-name))
+ (fn (fdefinition fn-name))
(initargs
(list :function
(set-function-name
(parse-specialized-lambda-list (cdr arglist))
(values (cons (if (listp arg) (car arg) arg) parameters)
(cons (if (listp arg) (car arg) arg) lambda-list)
- (cons (if (listp arg) (cadr arg) 't) specializers)
+ (cons (if (listp arg) (cadr arg) t) specializers)
(cons (if (listp arg) (car arg) arg) required)))))))
\f
(eval-when (:load-toplevel :execute)
(t
(boot-make-wrapper (length slots) name))))
(proto nil))
- (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
+ (when (eq name t) (setq *the-wrapper-of-t* wrapper))
(set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
*pcl-package*)
class)
(!bootstrap-set-slot metaclass-name class slot-name value)))
(set-slot 'name name)
(set-slot 'source source)
- (set-slot 'type (if (eq class (find-class 't))
+ (set-slot 'type (if (eq class (find-class t))
t
;; FIXME: Could this just be CLASS instead
;; of `(CLASS ,CLASS)? If not, why not?
(writer (values 'standard-writer-method
#'make-std-writer-method-function
(list 'new-value class-name)
- (list 't class-name)
+ (list t class-name)
"automatically generated writer method"))
(boundp (values 'standard-boundp-method
#'make-std-boundp-method-function
;; other sorts of brainos.
(dolist (e *built-in-classes*)
(dolist (super (cadr e))
- (unless (or (eq super 't)
+ (unless (or (eq super t)
(assq super *built-in-classes*))
(error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
but ~S is not itself a class in *BUILT-IN-CLASSES*."
invalid))))
(defun (setf wrapper-state) (new-value wrapper)
(setf (sb-kernel:layout-invalid wrapper)
- (if (eq new-value 't)
+ (if (eq new-value t)
nil
new-value)))
;;; FIXME: could become inline function
(defmacro invalid-wrapper-p (wrapper)
- `(neq (wrapper-state ,wrapper) 't))
+ `(neq (wrapper-state ,wrapper) t))
(defvar *previous-nwrappers* (make-hash-table))
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
(state (wrapper-state owrapper)))
- (if (eq state 't)
+ (if (eq state t)
owrapper
(let ((nwrapper
(ecase (car state)
(wrapper nil)
,@(when wrappers
`((class *the-class-t*)
- (type 't))))
- (unless (eq mt 't)
+ (type t))))
+ (unless (eq mt t)
(setq wrapper (wrapper-of arg))
(when (invalid-wrapper-p wrapper)
(setq ,invalid-wrapper-p t)
(eq (car method) ':early-method)
(method-p method))
(if method-alist-p
- 't
+ t
(multiple-value-bind (mf fmf)
(if (listp method)
(early-method-function method)
method-alist-p wrappers-p)))
(cdr form))
'fast-method-call
- 't)
+ t)
(fast-method-call
'.fast-call-method-list.)
(t
method-alist-p wrappers-p)))
(cdr form))
'fast-method-call
- 't)))
+ t)))
(values `(dolist (emf ,gensym nil)
,(make-emf-call metatypes applyp 'emf type))
(list gensym))))
(std-obj (specifier-type 'sb-pcl::std-object)))
(cond
;; Flush tests whose result is known at compile time.
- ((csubtypep otype std-obj) 't)
- ((not (types-intersect otype std-obj)) 'nil)
+ ((csubtypep otype std-obj) t)
+ ((not (types-intersect otype std-obj)) nil)
(t
`(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
(funcall fn constructor))
(dolist (subclass (class-direct-subclasses class))
(recurse subclass))))
- (recurse (find-class 't))
+ (recurse (find-class t))
(values nclasses nconstructors))))
(defun reset-constructors ()
(when (eq flag ':unsupplied) (setq flag ':constants)))
(t
(push (cons name +slot-unbound+) constants)
- (setq flag 't)))))
+ (setq flag t)))))
(let* ((constants-alist (sort constants #'(lambda (x y)
(memq (car y)
(memq (car x) layout)))))
(defun make-initfunction (initform)
(declare (special *initfunctions*))
- (cond ((or (eq initform 't)
+ (cond ((or (eq initform t)
(equal initform ''t))
'(function constantly-t))
- ((or (eq initform 'nil)
+ ((or (eq initform nil)
(equal initform ''nil))
'(function constantly-nil))
- ((or (eql initform '0)
+ ((or (eql initform 0)
(equal initform ''0))
'(function constantly-0))
(t
(defun parse-qualifier-pattern (name pattern)
(cond ((eq pattern '()) `(null .qualifiers.))
- ((eq pattern '*) 't)
+ ((eq pattern '*) t)
((symbolp pattern) `(,pattern .qualifiers.))
((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
(t (error "In the method group specifier ~S,~%~
;;; unadvised, traced etc. definition. This lets me get at the generic
;;; function object even when it is traced.
(defun unencapsulated-fdefinition (symbol)
- (name-get-fdefinition symbol))
+ (fdefinition symbol))
;;; If symbol names a function which is traced or advised, redefine
;;; the `real' definition without affecting the advise.
(sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
- (name-set-fdefinition name new-definition))
+ (setf (fdefinition name) new-definition))
(defun gboundp (spec)
(parse-gspec spec
;;; interface
(defun type-from-specializer (specl)
- (cond ((eq specl 't)
- 't)
+ (cond ((eq specl t)
+ t)
((consp specl)
(unless (member (car specl) '(class prototype class-eq eql))
(error "~S is not a legal specializer type." specl))
(declare (special *the-class-t*))
(setq type (type-from-specializer type))
(if (atom type)
- (if (eq type 't)
+ (if (eq type t)
*the-class-t*
(error "bad argument to type-class"))
(case (car type)
(member generator '(emit-checking emit-caching
emit-in-checking-cache-p emit-constant-value)))
(setq args (cons (mapcar #'(lambda (mt)
- (if (eq mt 't)
+ (if (eq mt t)
mt
'class))
(car args))
(let* ((generator-entry (assq generator *dfun-constructors*))
(args-entry (assoc args (cdr generator-entry) :test #'equal)))
(if (null *enable-dfun-constructor-caching*)
- (apply (name-get-fdefinition generator) args)
+ (apply (fdefinition generator) args)
(or (cadr args-entry)
(multiple-value-bind (new not-best-p)
(apply (symbol-function generator) args)
',(car generator-entry)
',(car args-entry)
',system
- ,(apply (name-get-fdefinition (car generator-entry))
+ ,(apply (fdefinition (car generator-entry))
(car args-entry)))))))))))
\f
;;; When all the methods of a generic function are automatically generated
(multiple-value-bind (nreq applyp metatypes nkeys)
(get-generic-function-info generic-function)
(declare (ignore nreq))
- (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+ (if (every #'(lambda (mt) (eq mt t)) metatypes)
(let ((dfun-info (default-method-only-dfun-info)))
(values
(funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
(defun make-final-checking-dfun (generic-function function
classes-list new-class)
(let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
- (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+ (if (every #'(lambda (mt) (eq mt t)) metatypes)
(values #'(lambda (&rest args)
(invoke-emf function args))
nil (default-method-only-dfun-info))
(multiple-value-bind (nreq applyp metatypes nkeys)
(get-generic-function-info generic-function)
(declare (ignore nreq applyp nkeys))
- (every #'(lambda (mt) (eq mt 't)) metatypes)))
+ (every #'(lambda (mt) (eq mt t)) metatypes)))
(defun use-caching-dfun-p (generic-function)
(some (lambda (method)
(when (and metatypes
(not (null (car metatypes)))
(dolist (mt metatypes nil)
- (unless (eq mt 't) (return t))))
+ (unless (eq mt t) (return t))))
(get-dfun-constructor 'emit-caching metatypes applyp))))
(defun use-constant-value-dfun-p (gf &optional boolean-values-p)
(method-function method)))
:constant-value default)))
(if boolean-values-p
- (not (or (eq value 't) (eq value nil)))
+ (not (or (eq value t) (eq value nil)))
(eq value default)))))
methods)))))
(dolist (sclass (if early-p
(early-class-precedence-list class)
(class-precedence-list class))
- (error "This can't happen"))
+ (error "This can't happen."))
(let ((a (assq sclass specl+slotd-list)))
(when a
(let* ((slotd (cdr a))
(defun specializer-applicable-using-type-p (specl type)
(setq specl (type-from-specializer specl))
- (when (eq specl 't)
+ (when (eq specl t)
(return-from specializer-applicable-using-type-p (values t t)))
;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
;; and has only what they need.
- (if (or (atom type) (eq (car type) 't))
+ (if (or (atom type) (eq (car type) t))
(values nil t)
(case (car type)
(and (saut-and specl type))
'specializer-applicable-using-type-p
type)))))
-(defun map-all-classes (function &optional (root 't))
+(defun map-all-classes (function &optional (root t))
(let ((braid-p (or (eq *boot-state* 'braid)
(eq *boot-state* 'complete))))
(labels ((do-class (class)
(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
(let* ((index -1)
(wrapper-bindings (mapcan #'(lambda (arg mt)
- (unless (eq mt 't)
+ (unless (eq mt t)
(incf index)
`((,(intern (format nil
"WRAPPER-~D"
(when (eq (first x) 'setf) ; Give up if not a setf function name.
(or (values (sb-int:info :setf :documentation (second x)))
;; Try the pcl function documentation.
- (and (fboundp x) (documentation (fdefinition x) 't)))))
+ (and (fboundp x) (documentation (fdefinition x) t)))))
(defmethod documentation ((x symbol) (doc-type (eql 'function)))
(or (values (sb-int:info :function :documentation x))
;; Try the pcl function documentation.
- (and (fboundp x) (documentation (fdefinition x) 't))))
+ (and (fboundp x) (documentation (fdefinition x) t))))
(defmethod documentation ((x symbol) (doc-type (eql 'setf)))
(values (sb-int:info :setf :documentation x)))
(defun trace-method-internal (ofunction name options)
(eval `(untrace ,name))
- (name-set-fdefinition name ofunction)
+ (setf (fdefinition name) ofunction)
(eval `(trace ,name ,@options))
- (name-get-fdefinition name))
+ (fdefinition name))
|#
\f
;;;; MAKE-LOAD-FORM
(dolist (a alist)
(reset-class-initialize-info-1 (cdr a))))))
-(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
+(defun initialize-info (class
+ initargs
+ &optional
+ (plist-p t)
+ allow-other-keys-arg)
(let ((info nil))
(if (and (eq *initialize-info-cache-class* class)
(eq *initialize-info-cache-initargs* initargs))
((initargs-form-list new-keys)
(multiple-value-bind (initargs-form-list new-keys)
(make-default-initargs-form-list class keys)
- (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
+ (setf (initialize-info-cached-initargs-form-list info)
+ initargs-form-list)
(setf (initialize-info-cached-new-keys info) new-keys)))
((default-initargs-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info)))
(unless (and (null (cdr make-instance-methods))
(eq (car make-instance-methods) std-mi-meth)
(null (cdr default-initargs-methods))
- (eq (car (method-specializers (car default-initargs-methods)))
+ (eq (car (method-specializers
+ (car default-initargs-methods)))
*the-class-slot-class*)
(flet ((check-meth (meth)
(let ((quals (method-qualifiers meth)))
(get-secondary-dispatch-function
#'shared-initialize shared-initialize-methods
`((class-eq ,class) t t)
- `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
+ `((,(find-standard-ii-method shared-initialize-methods
+ 'slot-object)
,#'(lambda (instance init-type &rest initargs)
(declare (ignore init-type))
(call-initialize-function initialize-function
(get-secondary-dispatch-function
#'initialize-instance initialize-instance-methods
`((class-eq ,class) t)
- `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
+ `((,(find-standard-ii-method initialize-instance-methods
+ 'slot-object)
,#'(lambda (instance &rest initargs)
(invoke-effective-method-function
shared-initialize t instance t initargs))))
initialize-instance t instance initargs)
instance))))))
-(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
+(defun get-simple-initialization-function (class
+ keys
+ &optional allow-other-keys-arg)
(let ((info (initialize-info class keys nil allow-other-keys-arg)))
(values (initialize-info-combined-initialize-function info)
(initialize-info-constants info))))
-(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
- separate-p)
+(defun get-complex-initialization-functions (class
+ keys
+ &optional
+ allow-other-keys-arg
+ separate-p)
(let* ((info (initialize-info class keys nil allow-other-keys-arg))
- (default-initargs-function (initialize-info-default-initargs-function info)))
+ (default-initargs-function (initialize-info-default-initargs-function
+ info)))
(if separate-p
(values default-initargs-function
(initialize-info-shared-initialize-t-function info))
(let* ((slot (car slot+index))
(name (slot-definition-name slot)))
(when (and (eql (cdr slot+index) most-positive-fixnum)
- (or (eq si-slot-names 't)
+ (or (eq si-slot-names t)
(member name si-slot-names)))
(let* ((initform (slot-definition-initform slot))
(initfunction (slot-definition-initfunction slot))
((constantp initform)
(let ((value (funcall initfunction)))
(if (and simple-p (integerp location))
- (progn (setf (nth location constants) value)
+ (progn (setf (nth location constants)
+ value)
nil)
`((const ,value)
(instance-set ,pv-offset ,slot)))))
initargs))
(list pv-cell (coerce cvector cvector-type)))))
\f
-;;; The effect of this is to cause almost all of the overhead of MAKE-INSTANCE
-;;; to happen at load time (or maybe at precompile time, as explained in a
-;;; previous message) rather than the first time that MAKE-INSTANCE is called
-;;; with a given class-name and sequence of keywords.
+;;; The effect of this is to cause almost all of the overhead of
+;;; MAKE-INSTANCE to happen at load time (or maybe at precompile time,
+;;; as explained in a previous message) rather than the first time
+;;; that MAKE-INSTANCE is called with a given class-name and sequence
+;;; of keywords.
-;;; This optimization applies only when the first argument and all the even
-;;; numbered arguments are constants evaluating to interned symbols.
+;;; This optimization applies only when the first argument and all the
+;;; even numbered arguments are constants evaluating to interned
+;;; symbols.
(declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
(let* ((*make-instance-function-keys* nil)
(expanded-form (expand-make-instance-form form)))
(if expanded-form
- `(funcall (name-get-fdefinition
- ;; The symbol is guaranteed to be fbound.
+ `(funcall (fdefinition
+ ;; The name is guaranteed to be fbound.
;; Is there a way to declare this?
(load-time-value
(get-make-instance-function-symbol
(defmethod shared-initialize
((instance slot-object) slot-names &rest initargs)
- (when (eq slot-names 't)
+ (when (eq slot-names t)
(return-from shared-initialize
(call-initialize-function
(initialize-info-shared-initialize-t-function
(initialize-info (class-of instance) initargs))
instance initargs)))
- (when (eq slot-names 'nil)
+ (when (eq slot-names nil)
(return-from shared-initialize
(call-initialize-function
(initialize-info-shared-initialize-nil-function
instance
slotd)
val)
- (return 't))))
+ (return t))))
;; Try to initialize the slot from its initform.
(if (and slot-names
- (or (eq slot-names 't)
+ (or (eq slot-names t)
(memq slot-name slot-names))
- (or (and (not std-p) (eq slot-names 't))
+ (or (and (not std-p) (eq slot-names t))
(not (slot-boundp-using-class class instance slotd))))
(let ((initfunction (slot-definition-initfunction slotd)))
(when initfunction
(intern (let ((*package* *pcl-package*)
(*print-case* :upcase)
(*print-pretty* nil)
- (*print-gensym* 't))
+ (*print-gensym* t))
(format nil "~S" name))
*pcl-package*))))
\f
;; information around, I'm not sure. -- WHN 2000-12-30
%variable-rebinding))
-(defmacro name-get-fdefinition (name)
- (sb-int:once-only ((name name))
- `(if (symbolp ,name) ; take care of "setf <fun>"'s
- (symbol-function ,name)
- (fdefinition ,name))))
-
-(defmacro name-set-fdefinition (name new-definition)
- (sb-int:once-only ((name name))
- `(if (symbolp ,name) ; take care of "setf <fun>"'s
- (setf (symbol-function ,name) ,new-definition)
- (setf (fdefinition ,name) ,new-definition))))
-
;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
(macrolet ((def-constantly-fun (name constant-expr)
`(setf (symbol-function ',name)
(loop (cond ((not (listp form))
(return-from outer nil))
((eq (car form) 'declare)
- (return-from inner 't))
+ (return-from inner t))
(t
(multiple-value-bind (newform macrop)
(macroexpand-1 form environment)
(eq *boot-state* 'braid))
(when (and new-value (class-wrapper new-value))
(setf (find-class-cell-predicate cell)
- (name-get-fdefinition (class-predicate-name new-value))))
+ (fdefinition (class-predicate-name new-value))))
(when (and new-value (not (forward-referenced-class-p new-value)))
- (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
+ (dolist (keys+aok (find-class-cell-make-instance-function-keys
+ cell))
(update-initialize-info-internal
(initialize-info new-value (car keys+aok) nil (cdr keys+aok))
'make-instance-function))))
value)))
#'(lambda () result))))
-;;; These are augmented definitions of list-elements and list-tails from
-;;; iterate.lisp. These versions provide the extra :by keyword which can
+;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from
+;;; iterate.lisp. These versions provide the extra :BY keyword which can
;;; be used to specify the step function through the list.
(defmacro *list-elements (list &key (by #'cdr))
`(let ((tail ,list))
(cond ((or (null (fboundp generic-function-name))
(not (generic-function-p
(setq generic-function
- (name-get-fdefinition generic-function-name)))))
+ (fdefinition generic-function-name)))))
(error "~S does not name a generic function."
generic-function-name))
((null (setq method (get-method generic-function
lambda-list
&rest other-initargs)
(unless (and (fboundp generic-function-name)
- (typep (name-get-fdefinition generic-function-name)
- 'generic-function))
+ (typep (fdefinition generic-function-name) 'generic-function))
(sb-kernel::style-warn "implicitly creating new generic function ~S"
generic-function-name))
;; XXX What about changing the class of the generic function if
(defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
(let* ((w wrappers) (w-tail w) (mt-tail metatypes))
(dolist (class (if (listp classes) classes (list classes)))
- (unless (eq 't (car mt-tail))
+ (unless (eq t (car mt-tail))
(let ((c-w (class-wrapper class)))
(unless c-w (return-from get-wrappers-from-classes nil))
(if (eql nkeys 1)
(defmacro class-test (arg class)
(cond ((eq class *the-class-t*)
- 't)
+ t)
((eq class *the-class-slot-object*)
`(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class)))
((eq class *the-class-std-object*)
#'identity)))
(defun class-from-type (type)
- (if (or (atom type) (eq (car type) 't))
+ (if (or (atom type) (eq (car type) t))
*the-class-t*
(case (car type)
(and (dolist (type (cdr type) *the-class-t*)
;;; We know that known-type implies neither new-type nor `(not ,new-type).
(defun augment-type (new-type known-type)
- (if (or (eq known-type 't)
+ (if (or (eq known-type t)
(eq (car new-type) 'eql))
new-type
(let ((so-far (if (and (consp known-type) (eq (car known-type) 'and))
(if p-tail
(let* ((position (car p-tail))
(known-type (or (nth position types) t)))
- (if (eq (nth position metatypes) 't)
+ (if (eq (nth position metatypes) t)
(do-column (cdr p-tail) contenders
(cons (cons position known-type)
known-types))
(defvar *case-table-limit* 10)
(defun compute-mcase-parameters (case-list)
- (unless (eq 't (caar (last case-list)))
+ (unless (eq t (caar (last case-list)))
(error "The key for the last case arg to mcase was not T"))
(let* ((eq-p (dolist (case case-list t)
- (unless (or (eq (car case) 't)
+ (unless (or (eq (car case) t)
(symbolp (caar case)))
(return nil))))
(len (1- (length case-list)))
(list eq-p type)))
(defmacro mlookup (key info default &optional eq-p type)
- (unless (or (eq eq-p 't) (null eq-p))
+ (unless (or (eq eq-p t) (null eq-p))
(error "Invalid eq-p argument"))
(ecase type
(:simple
(state 'required)
(arglist (method-lambda-list method)))
(dolist (arg arglist)
- (cond ((eq arg '&optional) (setq state 'optional))
- ((eq arg '&rest) (setq state 'rest))
- ((eq arg '&key) (setq state 'key))
- ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
- ((memq arg lambda-list-keywords))
+ (cond ((eq arg '&optional) (setq state 'optional))
+ ((eq arg '&rest) (setq state 'rest))
+ ((eq arg '&key) (setq state 'key))
+ ((eq arg '&allow-other-keys) (setq allow-other-keys t))
+ ((memq arg lambda-list-keywords))
(t
(ecase state
(required (push arg required))
(defmethod specializer-method-table ((specializer class-eq-specializer))
*class-eq-specializer-methods*)
-(defmethod add-direct-method ((specializer specializer-with-object) (method method))
+(defmethod add-direct-method ((specializer specializer-with-object)
+ (method method))
(let* ((object (specializer-object specializer))
(table (specializer-method-table specializer))
(entry (gethash object table)))
(cdr entry) ())
method))
-(defmethod remove-direct-method ((specializer specializer-with-object) (method method))
+(defmethod remove-direct-method ((specializer specializer-with-object)
+ (method method))
(let* ((object (specializer-object specializer))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(car (gethash (specializer-object specializer)
(specializer-method-table specializer))))
-(defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
+(defmethod specializer-direct-generic-functions ((specializer
+ specializer-with-object))
(let* ((object (specializer-object specializer))
(entry (gethash object (specializer-method-table specializer))))
(when entry
(defun map-all-generic-functions (function)
(let ((all-generic-functions (make-hash-table :test 'eq)))
(map-specializers #'(lambda (specl)
- (dolist (gf (specializer-direct-generic-functions specl))
+ (dolist (gf (specializer-direct-generic-functions
+ specl))
(unless (gethash gf all-generic-functions)
(setf (gethash gf all-generic-functions) t)
(funcall function gf))))))
nil)
-(defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
+(defmethod shared-initialize :after ((specl class-eq-specializer)
+ slot-names
+ &key)
(declare (ignore slot-names))
(setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
(setq direct-slots
(if direct-slots-p
(setf (slot-value class 'direct-slots)
- (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
+ (mapcar (lambda (pl) (make-direct-slotd class pl))
+ direct-slots))
(slot-value class 'direct-slots)))
(if direct-default-initargs-p
- (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
- (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
+ (setf (plist-value class 'direct-default-initargs)
+ direct-default-initargs)
+ (setq direct-default-initargs
+ (plist-value class 'direct-default-initargs)))
(setf (plist-value class 'class-slot-cells)
(gathering1 (collecting)
(dolist (dslotd direct-slots)
(car predicate-name))
(or (slot-value class 'predicate-name)
(setf (slot-value class 'predicate-name)
- (make-class-predicate-name (class-name class))))))
+ (make-class-predicate-name (class-name
+ class))))))
(add-direct-subclasses class direct-superclasses)
(update-class class nil)
(make-class-predicate class predicate-name)
(mapcar #'(lambda (pl)
(when defstruct-p
(let* ((slot-name (getf pl :name))
- (acc-name (format nil "~S structure class ~A"
- name slot-name))
+ (acc-name
+ (format nil
+ "~S structure class ~A"
+ name slot-name))
(accessor (intern acc-name)))
- (setq pl (list* :defstruct-accessor-symbol accessor
- pl))))
+ (setq pl (list* :defstruct-accessor-symbol
+ accessor pl))))
(make-direct-slotd class pl))
direct-slots)))
(setq direct-slots (slot-value class 'direct-slots)))
(car predicate-name))
(or (slot-value class 'predicate-name)
(setf (slot-value class 'predicate-name)
- (make-class-predicate-name (class-name class))))))
+ (make-class-predicate-name
+ (class-name class))))))
(make-class-predicate class predicate-name)
(add-slot-accessors class direct-slots))
;; If there is a change in the shape of the instances then the
;; old class is now obsolete.
(let* ((nlayout (mapcar #'slot-definition-name
- (sort instance-slots #'< :key #'slot-definition-location)))
+ (sort instance-slots #'<
+ :key #'slot-definition-location)))
(nslots (length nlayout))
(nwrapper-class-slots (compute-class-slots class-slots))
(owrapper (class-wrapper class))
(when (and (class-finalized-p class)
(let ((cpl (class-precedence-list class)))
(or (member *the-class-slot-class* cpl)
- (member *the-class-standard-effective-slot-definition* cpl))))
+ (member *the-class-standard-effective-slot-definition*
+ cpl))))
(let ((gf-table (make-hash-table :test 'eq)))
(labels ((collect-gfs (class)
(dolist (gf (specializer-direct-generic-functions class))
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
(let ((slotd-type (slot-definition-type slotd)))
- (setq type (cond ((eq type 't) slotd-type)
+ (setq type (cond ((eq type t) slotd-type)
((*subtypep type slotd-type) type)
(t `(and ,type ,slotd-type)))))))
(list :name name
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
(let ((slotd (car direct-slotds)))
- (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
- :internal-reader-function (slot-definition-internal-reader-function slotd)
- :internal-writer-function (slot-definition-internal-writer-function slotd)
+ (list* :defstruct-accessor-symbol
+ (slot-definition-defstruct-accessor-symbol slotd)
+ :internal-reader-function
+ (slot-definition-internal-reader-function slotd)
+ :internal-writer-function
+ (slot-definition-internal-writer-function slotd)
(call-next-method))))
\f
-;;; NOTE: For bootstrapping considerations, these can't use make-instance
+;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE
;;; to make the method object. They have to use make-a-method which
;;; is a specially bootstrapped mechanism for making standard methods.
(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
;;;; inform-type-system-about-class
;;;; make-type-predicate
;;;
-;;; These are NOT part of the standard protocol. They are internal mechanism
-;;; which PCL uses to *try* and tell the type system about class definitions.
-;;; In a more fully integrated implementation of CLOS, the type system would
-;;; know about class objects and class names in a more fundamental way and
-;;; the mechanism used to inform the type system about new classes would be
-;;; different.
+;;; These are NOT part of the standard protocol. They are internal
+;;; mechanism which PCL uses to *try* and tell the type system about
+;;; class definitions. In a more fully integrated implementation of
+;;; CLOS, the type system would know about class objects and class
+;;; names in a more fundamental way and the mechanism used to inform
+;;; the type system about new classes would be different.
(defmethod inform-type-system-about-class ((class std-class) name)
(inform-type-system-about-std-class name))
\f
;; will already be doing what we want. In particular, we must be
;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
;; means do what FLUSH does and then some.
- (when (eq state 't) ; FIXME: should be done through INVALID-WRAPPER-P
+ (when (eq state t) ; FIXME: should be done through INVALID-WRAPPER-P
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
;;; - when the instance is involved in method lookup
;;; - when attempting to access a slot of an instance
;;;
-;;; It is not called by class-of, wrapper-of, or any of the low-level instance
-;;; access macros.
+;;; It is not called by class-of, wrapper-of, or any of the low-level
+;;; instance access macros.
;;;
-;;; Of course these times when it is called are an internal implementation
-;;; detail of PCL and are not part of the documented description of when the
-;;; obsolete instance update happens. The documented description is as it
-;;; appears in 88-002R.
+;;; Of course these times when it is called are an internal
+;;; implementation detail of PCL and are not part of the documented
+;;; description of when the obsolete instance update happens. The
+;;; documented description is as it appears in 88-002R.
;;;
-;;; This has to return the new wrapper, so it counts on all the methods on
-;;; obsolete-instance-trap-internal to return the new wrapper. It also does
-;;; a little internal error checking to make sure that the traps are only
-;;; happening when they should, and that the trap methods are computing
-;;; appropriate new wrappers.
+;;; This has to return the new wrapper, so it counts on all the
+;;; methods on obsolete-instance-trap-internal to return the new
+;;; wrapper. It also does a little internal error checking to make
+;;; sure that the traps are only happening when they should, and that
+;;; the trap methods are computing appropriate new wrappers.
;;; obsolete-instance-trap might be called on structure instances
;;; after a structure is redefined. In most cases, obsolete-instance-trap
\f
(defmethod validate-superclass ((c slot-class)
(f forward-referenced-class))
- 't)
+ t)
\f
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
(pushnew dependent (plist-value metaobject 'dependents)))
(if defstruct-constructor
(make-instance class)
(let* ((proto (%allocate-instance--class *empty-vector*)))
- (shared-initialize proto T :check-initargs-legality-p NIL)
+ (shared-initialize proto t :check-initargs-legality-p nil)
(setf (std-instance-wrapper proto) wrapper)
proto))))
(unless acc-sym-p
(setf initargs
(list* :defstruct-accessor-symbol
- (intern (concatenate 'simple-string conc-name (symbol-name name))
+ (intern (concatenate 'simple-string
+ conc-name
+ (symbol-name name))
(symbol-package (class-name class)))
initargs)))
- (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
+ (apply #'make-instance
+ (direct-slot-definition-class class initargs)
+ initargs)))
(defun slot-definition-defstruct-slot-description (slot)
(let ((type (slot-definition-type slot)))
(slot-value class 'direct-slots)))
(when from-defclass-p
(do-defstruct-from-defclass
- class direct-superclasses direct-slots conc-name pred-name constructor))
+ class direct-superclasses
+ direct-slots
+ conc-name pred-name
+ constructor))
(compile-structure-class-internals
class direct-slots conc-name pred-name constructor)
(setf (slot-value class 'predicate-name) pred-name)
(unless (extract-required-parameters (second constructor))
(setf (slot-value class 'defstruct-constructor) (car constructor)))
(when (and defstruct-predicate (not from-defclass-p))
- (name-set-fdefinition pred-name (symbol-function defstruct-predicate)))
+ (fdefinition pred-name (symbol-function defstruct-predicate)))
(unless (or from-defclass-p (slot-value class 'documentation))
(setf (slot-value class 'documentation)
(format nil "~S structure class made from Defstruct" name)))
(defun update-structure-class (class direct-superclasses direct-slots)
(add-direct-subclasses class direct-superclasses)
- (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class))
+ (setf (slot-value class 'class-precedence-list)
+ (compute-class-precedence-list class))
(let* ((eslotds (compute-slots class))
(internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
(setf (slot-value class 'slots) eslotds)
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
(let ((slotd (car direct-slotds)))
- (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
- :internal-reader-function (slot-definition-internal-reader-function slotd)
- :internal-writer-function (slot-definition-internal-writer-function slotd)
+ (list* :defstruct-accessor-symbol
+ (slot-definition-defstruct-accessor-symbol slotd)
+ :internal-reader-function
+ (slot-definition-internal-reader-function slotd)
+ :internal-writer-function
+ (slot-definition-internal-writer-function slotd)
(call-next-method))))
(defmethod make-optimized-reader-method-function ((class structure-class)
(when (or (not (eq *boot-state* 'complete))
(and class (not (class-finalized-p class))))
(setq class nil))
- (when (and class-name (not (eq class-name 't)))
+ (when (and class-name (not (eq class-name t)))
(when (or (null type)
(not (and class
(memq *the-class-structure-object*
(when parameter-or-nil
(let* ((class-name (caddr (variable-declaration
'class parameter-or-nil env))))
- (when (and class-name (not (eq class-name 't)))
+ (when (and class-name (not (eq class-name t)))
(position parameter-or-nil slots :key #'car))))))
(if (constantp form)
(let ((form (eval form)))
(w-t pv-wrappers))
(dolist (arg args)
(setq w (wrapper-of arg))
- (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
+ (unless (eq t (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
(setq w (check-wrapper-validity arg)))
(setf (car w-t) w))
(setq w-t (cdr w-t))
(relist-internal x args nil)))
(defun relist* (x &rest args)
- (relist-internal x args 't))
+ (relist-internal x args t))
(defun relist-internal (x args *p)
(if (null (cdr args))
(not (symbolp (caddr arg)))
(note-lexical-binding (caddr arg) env))))
(t
- (error "Can't understand something in the arglist ~S" arglist))))
+ (error "can't understand something in the arglist ~S" arglist))))
(defun walk-let (form context env)
(walk-let/let* form context env nil))
(walker-environment-bind (new-env old-env)
(let* ((possible-block-name (second form))
(blocked-prog (and (symbolp possible-block-name)
- (not (eq possible-block-name 'nil)))))
+ (not (eq possible-block-name nil)))))
(multiple-value-bind (let/let* block-name bindings body)
(if blocked-prog
(values (car form) (cadr form) (caddr form) (cdddr form))
;;; 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.20"
+"0.6.10.21"
projects / sbcl.git / commitdiff