* the compiler is now aware that SYMBOL-FUNCTION returns a FUNCTION
and that READ-DELIMITED-LIST returns a LIST. (thanks to Robert
E. Brown and Tony Martinez respectively)
+ * PCL is now smarter about SLOT-VALUE, (SETF SLOT-VALUE) and
+ SLOT-BOUNDP: in particular, it is now able to optimize them much
+ better, and is now not vulnerable to having packages renamed.
+ Furthermore, a compliance bug has been fixed: SLOT-MISSING is now
+ always called when a slot is not present in an instance. (thanks
+ to Gerd Moellmann)
* fixed some bugs revealed by Paul Dietz' test suite:
** ARRAY-IN-BOUNDS-P now allows arbitrary integers as arguments,
not just nonnegative fixnums;
(defun legal-fun-name-p (name)
(or (symbolp name)
(and (consp name)
- (or (eq (car name) 'setf)
- (eq (car name) 'sb!pcl::class-predicate))
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
+ ;; (SETF FOO)
+ ;; (CLASS-PREDICATE FOO)
+ (or (and (or (eq (car name) 'setf)
+ (eq (car name) 'sb!pcl::class-predicate))
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (null (cddr name)))
+ ;; (SLOT-ACCESSOR <CLASSNAME-OR-:GLOBAL>
+ ;; <SLOT-NAME> [READER|WRITER|BOUNDP])
+ (and (eq (car name) 'sb!pcl::slot-accessor)
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (consp (cddr name))
+ (symbolp (caddr name))
+ (consp (cdddr name))
+ (member
+ (cadddr name)
+ '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp)))))))
;;; Signal an error unless NAME is a legal function name.
(defun legal-fun-name-or-type-error (name)
fun-name)
((and (consp fun-name)
(legal-fun-name-p fun-name))
- (second fun-name))
+ (case (car fun-name)
+ ((setf sb!pcl::class-predicate) (second fun-name))
+ ((sb!pcl::slot-accessor) (third fun-name))))
(t
(error "not legal as a function name: ~S" fun-name))))
(rename-package package
(package-name package)
(cons "SB-C-CALL" (package-nicknames package))))
-
-;;; KLUDGE: This is created here (instead of in package-data-list.lisp-expr)
-;;; because it doesn't have any symbols in it, so even if it's
-;;; present at cold load time, genesis thinks it's unimportant
-;;; and doesn't dump it. There's gotta be a better way, but for now
-;;; I'll just do it here. (As noted below, I'd just as soon have this
-;;; go away entirely, so I'm disinclined to fiddle with it too much.)
-;;; -- WHN 19991206
-;;;
-;;; FIXME: Why do slot accessor names need to be interned anywhere? For
-;;; low-level debugging? Perhaps this should go away, or at least
-;;; be optional, controlled by SB-SHOW or something.
-(defpackage "SB-SLOT-ACCESSOR-NAME"
- (:use))
\f
;;;; compiling and loading more of the system
thing
:debug-name (debug-namify "#'~S" thing)
:allow-debug-catch-tag t)))
- ((setf sb!pcl::class-predicate)
+ ((setf sb!pcl::class-predicate sb!pcl::slot-accessor)
(let ((var (find-lexically-apparent-fun
thing "as the argument to FUNCTION")))
(reference-leaf start cont var)))
(bug "full call to ~S" fname)))
(when (consp fname)
- (destructuring-bind (setf stem) fname
- (aver (eq setf 'setf))
- (setf (gethash stem *setf-assumed-fboundp*) t)))))
+ (destructuring-bind (setfoid &rest stem) fname
+ (aver (member setfoid
+ '(setf sb!pcl::class-predicate sb!pcl::slot-accessor)))
+ (when (eq setfoid 'setf)
+ (setf (gethash (car stem) *setf-assumed-fboundp*) t))))))
;;; If the call is in a tail recursive position and the return
;;; convention is standard, then do a tail full call. If one or fewer
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
\f
-(defvar *optimize-asv-funcall-p* nil)
-(defvar *asv-readers*)
-(defvar *asv-writers*)
-(defvar *asv-boundps*)
-
(defun expand-defmethod (name
proto-gf
proto-method
lambda-list
body
env)
- (let ((*optimize-asv-funcall-p* t)
- (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
- (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
- (add-method-declarations name qualifiers lambda-list body env)
- (multiple-value-bind (method-function-lambda initargs)
- (make-method-lambda proto-gf proto-method method-lambda env)
- (let ((initargs-form (make-method-initargs-form proto-gf
- proto-method
- method-function-lambda
- initargs
- env)))
- `(progn
- ;; Note: We could DECLAIM the ftype of the generic
- ;; function here, since ANSI specifies that we create it
- ;; if it does not exist. However, I chose not to, because
- ;; I think it's more useful to support a style of
- ;; programming where every generic function has an
- ;; explicit DEFGENERIC and any typos in DEFMETHODs are
- ;; warned about. Otherwise
- ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
- ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
- ;; compiles without raising an error and runs without
- ;; raising an error (since SIMPLE-VECTOR cases fall
- ;; through to VECTOR) but still doesn't do what was
- ;; intended. I hate that kind of bug (code which silently
- ;; gives the wrong answer), so we don't do a DECLAIM
- ;; here. -- WHN 20000229
- ,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
- `((initialize-internal-slot-gfs*
- ',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
- ,(make-defmethod-form name qualifiers specializers
- unspecialized-lambda-list
- (if proto-method
- (class-name (class-of proto-method))
- 'standard-method)
- initargs-form
- (getf (getf initargs :plist)
- :pv-table-symbol))))))))
+ (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
+ (add-method-declarations name qualifiers lambda-list body env)
+ (multiple-value-bind (method-function-lambda initargs)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (let ((initargs-form (make-method-initargs-form proto-gf
+ proto-method
+ method-function-lambda
+ initargs
+ env)))
+ `(progn
+ ;; Note: We could DECLAIM the ftype of the generic function
+ ;; here, since ANSI specifies that we create it if it does
+ ;; not exist. However, I chose not to, because I think it's
+ ;; more useful to support a style of programming where every
+ ;; generic function has an explicit DEFGENERIC and any typos
+ ;; in DEFMETHODs are warned about. Otherwise
+ ;;
+ ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;;
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall through
+ ;; to VECTOR) but still doesn't do what was intended. I hate
+ ;; that kind of bug (code which silently gives the wrong
+ ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+ ,(make-defmethod-form name qualifiers specializers
+ unspecialized-lambda-list
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form
+ (getf (getf initargs :plist)
+ :pv-table-symbol)))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
((generic-function-name-p (car form))
(optimize-generic-function-call
form required-parameters env slots calls))
- ((and (eq (car form) 'asv-funcall)
- *optimize-asv-funcall-p*)
- (case (fourth form)
- (reader (push (third form) *asv-readers*))
- (writer (push (third form) *asv-writers*))
- (boundp (push (third form) *asv-boundps*)))
- `(,(second form) ,@(cddddr form)))
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
(let* ((sym (if (atom name) name (cadr name)))
(pkg-list (cons *pcl-package*
(package-use-list *pcl-package*))))
+ ;; FIXME: given the presence of generalized function
+ ;; names, this test is broken. A little
+ ;; reverse-engineering suggests that this was intended
+ ;; to prevent precompilation of things on some
+ ;; PCL-internal automatically-constructed functions
+ ;; like the old "~A~A standard class ~A reader"
+ ;; functions. When the CADR of SB-PCL::SLOT-ACCESSOR
+ ;; generalized functions was *, this test returned T,
+ ;; not NIL, and an error was signalled in
+ ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X
+ ;; 'ASLDKJ)). Whether the right thing to do is to fix
+ ;; MAKE-ACCESSOR-TABLE so that it can work in the
+ ;; presence of slot names that have no classes, or to
+ ;; restore this test to something more obvious, I don't
+ ;; know. -- CSR, 2003-02-14
(and sym (symbolp sym)
(not (null (memq (symbol-package sym) pkg-list)))
(not (find #\space (symbol-name sym))))))))
(!bootstrap-accessor-definitions1
'slot-object
slot-name
- (list (slot-reader-symbol slot-name))
- (list (slot-writer-symbol slot-name))
- (list (slot-boundp-symbol slot-name)))))))))))
+ (list (slot-reader-name slot-name))
+ (list (slot-writer-name slot-name))
+ (list (slot-boundp-name slot-name)))))))))))
(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
*writers-for-this-defclass*)
,@(mapcar (lambda (x)
`(declaim (ftype (function (t) t)
- ,(slot-reader-symbol x)
- ,(slot-boundp-symbol x))
+ ,(slot-reader-name x)
+ ,(slot-boundp-name x))
(ftype (function (t t) t)
- ,(slot-writer-symbol x))))
+ ,(slot-writer-name x))))
*slot-names-for-this-defclass*)
(let ,(mapcar #'cdr *initfunctions-for-this-defclass*)
(load-defclass ',name
(defun accessor-miss-function (gf dfun-info)
(ecase (dfun-info-accessor-type dfun-info)
- (reader
+ ((reader boundp)
(lambda (arg)
(accessor-miss gf nil arg dfun-info)))
(writer
#-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
\f
(defun make-one-class-accessor-dfun (gf type wrapper index)
- (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
+ (let ((emit (ecase type
+ (reader 'emit-one-class-reader)
+ (boundp 'emit-one-class-boundp)
+ (writer 'emit-one-class-writer)))
(dfun-info (one-class-dfun-info type index wrapper)))
(values
(funcall (get-dfun-constructor emit (consp index))
dfun-info)))
(defun make-two-class-accessor-dfun (gf type w0 w1 index)
- (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
+ (let ((emit (ecase type
+ (reader 'emit-two-class-reader)
+ (boundp 'emit-two-class-boundp)
+ (writer 'emit-two-class-writer)))
(dfun-info (two-class-dfun-info type index w0 w1)))
(values
(funcall (get-dfun-constructor emit (consp index))
;;; std accessors same index dfun
(defun make-one-index-accessor-dfun (gf type index &optional cache)
- (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
+ (let* ((emit (ecase type
+ (reader 'emit-one-index-readers)
+ (boundp 'emit-one-index-boundps)
+ (writer 'emit-one-index-writers)))
(cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
(dfun-info (one-index-dfun-info type index cache)))
(declare (type cache cache))
(default-limit-fn nlines))
(defun make-n-n-accessor-dfun (gf type &optional cache)
- (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
+ (let* ((emit (ecase type
+ (reader 'emit-n-n-readers)
+ (boundp 'emit-n-n-boundps)
+ (writer 'emit-n-n-writers)))
(cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
(dfun-info (n-n-dfun-info type cache)))
(declare (type cache cache))
(cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
(type 'accessor)
(t 'checking)))
- (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
- (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
- ,@body))
- (invoke-emf ,nemf ,args)))
+ (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
+ (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
+ ,@body))
+ ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached
+ ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is,
+ ;; does not signal a SLOT-UNBOUND error for a boundp test.
+ ,@(if type
+ ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
+ ;; slots?)
+ `((if (and (eq ,type 'boundp) (integerp ,nemf))
+ (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
+ (invoke-emf ,nemf ,args)))
+ `((invoke-emf ,nemf ,args)))))
;;; The dynamically adaptive method lookup algorithm is implemented is
;;; implemented as a kind of state machine. The kinds of
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-get-slot class-name instance slot-name))))
+ (boundp #'(sb-kernel:instance-lambda (instance)
+ (let* ((class (class-of instance))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (not (eq +slot-unbound+
+ (!bootstrap-get-slot class-name
+ instance slot-name))))))
(writer #'(sb-kernel:instance-lambda (new-value instance)
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
'reader)
((every (lambda (method)
(if (consp method)
+ (eq *the-class-standard-boundp-method*
+ (early-method-class method))
+ (standard-boundp-method-p method)))
+ methods)
+ 'boundp)
+ ((every (lambda (method)
+ (if (consp method)
(eq *the-class-standard-writer-method*
(early-method-class method))
(standard-writer-method-p method)))
(let* ((ostate (type-of dfun-info))
(otype (dfun-info-accessor-type dfun-info))
oindex ow0 ow1 cache
- (args (ecase otype ; The congruence rules ensure
- (reader (list object)) ; that this is safe despite not
- (writer (list new object))))) ; knowing the new type yet.
+ (args (ecase otype
+ ;; The congruence rules ensure that this is safe
+ ;; despite not knowing the new type yet.
+ ((reader boundp) (list object))
+ (writer (list new object)))))
(dfun-miss (gf args wrappers invalidp nemf ntype nindex)
;; The following lexical functions change the state of the
(declare (ignore gf))
(let* ((accessor-type (gf-info-simple-accessor-type arg-info))
(accessor-class (case accessor-type
- (reader (car classes))
- (writer (cadr classes))
- (boundp (car classes)))))
+ ((reader boundp) (car classes))
+ (writer (cadr classes)))))
(accessor-values-internal accessor-type accessor-class methods)))
(defun accessor-values1 (gf accessor-type accessor-class)
(let* ((type `(class-eq ,accessor-class))
- (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
+ (types (ecase accessor-type
+ ((reader boundp) `(,type))
+ (writer `(t ,type))))
(methods (compute-applicable-methods-using-types gf types)))
(accessor-values-internal accessor-type accessor-class methods)))
(let* ((specializers (if (consp method)
(early-method-specializers method t)
(method-specializers method)))
- (specl (if (eq type 'reader)
- (car specializers)
- (cadr specializers)))
+ (specl (ecase type
+ ((reader boundp) (car specializers))
+ (writer (cadr specializers))))
(specl-cpl (if early-p
(early-class-precedence-list specl)
(and (class-finalized-p specl)
(defun emit-one-class-reader (class-slot-p)
(emit-reader/writer :reader 1 class-slot-p))
+(defun emit-one-class-boundp (class-slot-p)
+ (emit-reader/writer :boundp 1 class-slot-p))
+
(defun emit-one-class-writer (class-slot-p)
(emit-reader/writer :writer 1 class-slot-p))
(defun emit-two-class-reader (class-slot-p)
(emit-reader/writer :reader 2 class-slot-p))
+(defun emit-two-class-boundp (class-slot-p)
+ (emit-reader/writer :boundp 2 class-slot-p))
+
(defun emit-two-class-writer (class-slot-p)
(emit-reader/writer :writer 2 class-slot-p))
(defun emit-one-index-readers (class-slot-p)
(emit-one-or-n-index-reader/writer :reader nil class-slot-p))
+(defun emit-one-index-boundps (class-slot-p)
+ (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
+
(defun emit-one-index-writers (class-slot-p)
(emit-one-or-n-index-reader/writer :writer nil class-slot-p))
(defun emit-n-n-readers ()
(emit-one-or-n-index-reader/writer :reader t nil))
+(defun emit-n-n-boundp ()
+ (emit-one-or-n-index-reader/writer :boundp t nil))
+
(defun emit-n-n-writers ()
(emit-one-or-n-index-reader/writer :writer t nil))
(defvar *precompiling-lap* nil)
(defvar *emit-function-p* t)
+;;; FIXME: This variable is motivated by Gerd Moellman's observation,
+;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
+;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
+;;; order-of-magnitude slowdown. We include this variable for now,
+;;; but maybe its effect should rather be controlled by compilation
+;;; policy if there is a noticeable space difference between the
+;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
+;;; deleted. It's not clear to me how all of this works, though, so
+;;; until proper benchmarks are done it's probably safest simply to
+;;; have this pseudo-constant to hide code. -- CSR, 2003-02-14
+(defvar *optimize-cache-functions-p* t)
+
(defun emit-default-only (metatypes applyp)
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-default-only
- (emit-default-only-function metatypes applyp)))
+ (unless *optimize-cache-functions-p*
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-default-only
+ (emit-default-only-function metatypes applyp))))
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
(args (remove '&rest dlap-lambda-list))
(restl (when applyp '(.lap-rest-arg.))))
;;; FSC-INSTANCE-P returns true on funcallable structures as well as
;;; PCL fins.
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-reader/writer
- (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
+ (unless *optimize-cache-functions-p*
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-reader/writer
+ (emit-reader/writer-function
+ reader/writer 1-or-2-class class-slot-p))))
(let ((instance nil)
(arglist ())
(closure-variables ())
(field +first-wrapper-cache-number-index+)
- (readp (eq reader/writer :reader))
(read-form (emit-slot-read-form class-slot-p 'index 'slots)))
;;we need some field to do the fast obsolete check
(ecase reader/writer
- (:reader (setq instance (dfun-arg-symbol 0)
- arglist (list instance)))
+ ((:reader :boundp)
+ (setq instance (dfun-arg-symbol 0)
+ arglist (list instance)))
(:writer (setq instance (dfun-arg-symbol 1)
arglist (list (dfun-arg-symbol 0) instance))))
(ecase 1-or-2-class
`((eq wrapper wrapper-0))
`((or (eq wrapper wrapper-0)
(eq wrapper wrapper-1)))))
- ,@(if readp
- `((let ((value ,read-form))
- (unless (eq value +slot-unbound+)
- (return-from access value))))
- `((return-from access (setf ,read-form ,(car arglist))))))
+ ,@(ecase reader/writer
+ (:reader
+ `((let ((value ,read-form))
+ (unless (eq value +slot-unbound+)
+ (return-from access value)))))
+ (:boundp
+ `((let ((value ,read-form))
+ (return-from access (not (eq value +slot-unbound+))))))
+ (:writer
+ `((return-from access (setf ,read-form ,(car arglist)))))))
(funcall miss-fn ,@arglist))))))
(defun emit-slot-read-form (class-slot-p index slots)
`(cdr ,index)
`(clos-slots-ref ,slots ,index)))
-(defun emit-slot-write-form (class-slot-p index slots value)
- (if class-slot-p
- `(setf (cdr ,index) ,value)
- `(and ,slots (setf (clos-slots-ref ,slots ,index) ,value))))
-
(defun emit-boundp-check (value-form miss-fn arglist)
`(let ((value ,value-form))
(if (eq value +slot-unbound+)
(funcall ,miss-fn ,@arglist)
value)))
-(defun emit-slot-access (reader/writer
- class-slot-p
- slots
- index
- miss-fn
- arglist)
- (let ((read-form (emit-slot-read-form class-slot-p index slots))
- (write-form (emit-slot-write-form
- class-slot-p index slots (car arglist))))
+(defun emit-slot-access (reader/writer class-slot-p slots
+ index miss-fn arglist)
+ (let ((read-form (emit-slot-read-form class-slot-p index slots)))
(ecase reader/writer
(:reader (emit-boundp-check read-form miss-fn arglist))
- (:writer write-form))))
+ (:boundp `(not (eq ,read-form +slot-unbound+)))
+ (:writer `(setf ,read-form ,(car arglist))))))
(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
(let ((*emit-function-p* nil)
(defun emit-one-or-n-index-reader/writer (reader/writer
cached-index-p
class-slot-p)
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-one-or-n-index-reader/writer
- (emit-one-or-n-index-reader/writer-function
- reader/writer cached-index-p class-slot-p)))
+ (unless *optimize-cache-functions-p*
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-one-or-n-index-reader/writer
+ (emit-one-or-n-index-reader/writer-function
+ reader/writer cached-index-p class-slot-p))))
(multiple-value-bind (arglist metatypes)
(ecase reader/writer
- (:reader (values (list (dfun-arg-symbol 0))
- '(standard-instance)))
+ ((:reader :boundp)
+ (values (list (dfun-arg-symbol 0))
+ '(standard-instance)))
(:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
'(t standard-instance))))
(generating-lisp
`(funcall ,miss-fn ,@args ,@restl))))
(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-checking-or-caching
- (emit-checking-or-caching-function
- cached-emf-p return-value-p metatypes applyp)))
+ (unless *optimize-cache-functions-p*
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-checking-or-caching
+ (emit-checking-or-caching-function
+ cached-emf-p return-value-p metatypes applyp))))
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
(args (remove '&rest dlap-lambda-list))
(restl (when applyp '(.lap-rest-arg.))))
(emit-reader/writer-macro :writer 1 nil)))
(2 (if class-slot-p
(emit-reader/writer-macro :writer 2 t)
- (emit-reader/writer-macro :writer 2 nil))))))
+ (emit-reader/writer-macro :writer 2 nil)))))
+ (:boundp (ecase 1-or-2-class
+ (1 (if class-slot-p
+ (emit-reader/writer-macro :boundp 1 t)
+ (emit-reader/writer-macro :boundp 1 nil)))
+ (2 (if class-slot-p
+ (emit-reader/writer-macro :boundp 2 t)
+ (emit-reader/writer-macro :boundp 2 nil))))))
nil))
(defun emit-one-or-n-index-reader/writer-function
(emit-one-or-n-index-reader/writer-macro :writer t nil))
(if class-slot-p
(emit-one-or-n-index-reader/writer-macro :writer nil t)
- (emit-one-or-n-index-reader/writer-macro :writer nil nil)))))
+ (emit-one-or-n-index-reader/writer-macro :writer nil nil))))
+ (:boundp (if cached-index-p
+ (if class-slot-p
+ (emit-one-or-n-index-reader/writer-macro :boundp t t)
+ (emit-one-or-n-index-reader/writer-macro :boundp t nil))
+ (if class-slot-p
+ (emit-one-or-n-index-reader/writer-macro :boundp nil t)
+ (emit-one-or-n-index-reader/writer-macro :boundp nil nil)))))
nil))
(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
;;; #+SB-FLUID `(FIND-PACKAGE ,NAME))
;;; and use that to replace all three variables.)
(defvar *pcl-package* (find-package "SB-PCL"))
-(defvar *slot-accessor-name-package* (find-package "SB-SLOT-ACCESSOR-NAME"))
;;; This excludes structure types created with the :TYPE option to
;;; DEFSTRUCT. It also doesn't try to deal with types created by
(in-package "SB-PCL")
\f
-(defmacro slot-symbol (slot-name type)
- `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
- (or (get ,slot-name ',(ecase type
- (reader 'reader-symbol)
- (writer 'writer-symbol)
- (boundp 'boundp-symbol)))
- (intern (format nil "~A ~A slot ~A"
- (package-name (symbol-package ,slot-name))
- (symbol-name ,slot-name)
- ,(symbol-name type))
- *slot-accessor-name-package*))
- (progn
- (error "Non-symbol and non-interned symbol slot name accessors~
- are not yet implemented.")
- ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
- )))
+(defun slot-reader-name (slot-name)
+ (list 'slot-accessor :global slot-name 'reader))
-(defun slot-reader-symbol (slot-name)
- (slot-symbol slot-name reader))
+(defun slot-writer-name (slot-name)
+ (list 'slot-accessor :global slot-name 'writer))
-(defun slot-writer-symbol (slot-name)
- (slot-symbol slot-name writer))
-
-(defun slot-boundp-symbol (slot-name)
- (slot-symbol slot-name boundp))
+(defun slot-boundp-name (slot-name)
+ (list 'slot-accessor :global slot-name 'boundp))
(in-package "SB-PCL")
\f
-(defmacro asv-funcall (sym slot-name type &rest args)
- (declare (ignore type))
- `(if (fboundp ',sym)
- (,sym ,@args)
- (no-slot ',sym ',slot-name)))
-
-(defun no-slot (sym slot-name)
- (error "No class has a slot named ~S (~S has no function binding)."
- slot-name sym))
+(defun ensure-accessor (type fun-name slot-name)
+ (labels ((slot-missing-fun (slot-name type)
+ (let* ((method-type (ecase type
+ (slot-value 'reader-method)
+ (setf 'writer-method)
+ (slot-boundp 'boundp-method)))
+ (initargs
+ (copy-tree
+ (ecase type
+ (slot-value
+ (make-method-function
+ (lambda (obj)
+ (slot-missing (class-of obj) obj slot-name
+ 'slot-value))))
+ (slot-boundp
+ (make-method-function
+ (lambda (obj)
+ (slot-missing (class-of obj) obj slot-name
+ 'slot-boundp))))
+ (setf
+ (make-method-function
+ (lambda (val obj)
+ (declare (ignore val))
+ (slot-missing (class-of obj) obj slot-name
+ 'setf))))))))
+ (setf (getf (getf initargs :plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ (setf (getf (getf initargs :plist) :pv-table-symbol)
+ (gensym))
+ (list* :method-spec (list method-type 'slot-object slot-name)
+ initargs)))
+ (add-slot-missing-method (gf slot-name type)
+ (multiple-value-bind (class lambda-list specializers)
+ (ecase type
+ (slot-value
+ (values 'standard-reader-method
+ '(object)
+ (list *the-class-slot-object*)))
+ (slot-boundp
+ (values 'standard-boundp-method
+ '(object)
+ (list *the-class-slot-object*)))
+ (setf
+ (values 'standard-writer-method
+ '(new-value object)
+ (list *the-class-t* *the-class-slot-object*))))
+ (add-method gf (make-a-method class
+ ()
+ lambda-list
+ specializers
+ (slot-missing-fun slot-name type)
+ "generated slot-missing method"
+ slot-name)))))
+ (unless (fboundp fun-name)
+ (let ((gf (ensure-generic-function fun-name)))
+ (ecase type
+ (reader (add-slot-missing-method gf slot-name 'slot-value))
+ (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
+ (writer (add-slot-missing-method gf slot-name 'setf)))
+ (setf (plist-value gf 'slot-missing-method) t))
+ t)))
(defmacro accessor-slot-value (object slot-name)
- (unless (constantp slot-name)
- (error "~S requires its slot-name argument to be a constant"
- 'accessor-slot-value))
+ (aver (constantp slot-name))
(let* ((slot-name (eval slot-name))
- (sym (slot-reader-symbol slot-name)))
- `(asv-funcall ,sym ,slot-name reader ,object)))
+ (reader-name (slot-reader-name slot-name)))
+ `(let ((.ignore. (load-time-value
+ (ensure-accessor 'reader ',reader-name ',slot-name))))
+ (declare (ignore .ignore.))
+ (funcall #',reader-name ,object))))
(defmacro accessor-set-slot-value (object slot-name new-value &environment env)
- (unless (constantp slot-name)
- (error "~S requires its slot-name argument to be a constant"
- 'accessor-set-slot-value))
+ (aver (constantp slot-name))
(setq object (macroexpand object env))
(setq slot-name (macroexpand slot-name env))
(let* ((slot-name (eval slot-name))
(let ((object-var (gensym)))
(prog1 `((,object-var ,object))
(setq object object-var)))))
- (sym (slot-writer-symbol slot-name))
- (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
+ (writer-name (slot-writer-name slot-name))
+ (form
+ `(let ((.ignore.
+ (load-time-value
+ (ensure-accessor 'writer ',writer-name ',slot-name))))
+ (declare (ignore .ignore.))
+ (funcall #',writer-name ,new-value ,object))))
(if bindings
`(let ,bindings ,form)
form)))
(defmacro accessor-slot-boundp (object slot-name)
- (unless (constantp slot-name)
- (error "~S requires its slot-name argument to be a constant"
- 'accessor-slot-boundp))
- (let ((slot-name (eval slot-name)))
- `(slot-boundp-normal ,object ',slot-name)))
+ (aver (constantp slot-name))
+ (let* ((slot-name (eval slot-name))
+ (boundp-name (slot-boundp-name slot-name)))
+ `(let ((.ignore. (load-time-value
+ (ensure-accessor 'boundp ',boundp-name ',slot-name))))
+ (declare (ignore .ignore.))
+ (funcall #',boundp-name ,object))))
(defun make-structure-slot-boundp-function (slotd)
- (lambda (object) (declare (ignore object)) t))
+ (declare (ignore slotd))
+ (lambda (object)
+ (declare (ignore object))
+ t))
(defun get-optimized-std-accessor-method-function (class slotd name)
(if (structure-class-p class)
initargs)))
(defun initialize-internal-slot-gfs (slot-name &optional type)
- (when (or (null type) (eq type 'reader))
- (let* ((name (slot-reader-symbol slot-name))
- (gf (ensure-generic-function name)))
- (unless (generic-function-methods gf)
- (add-reader-method *the-class-slot-object* gf slot-name))))
- (when (or (null type) (eq type 'writer))
- (let* ((name (slot-writer-symbol slot-name))
- (gf (ensure-generic-function name)))
- (unless (generic-function-methods gf)
- (add-writer-method *the-class-slot-object* gf slot-name))))
- nil)
-
-(defun initialize-internal-slot-gfs* (readers writers boundps)
- (dolist (reader readers)
- (initialize-internal-slot-gfs reader 'reader))
- (dolist (writer writers)
- (initialize-internal-slot-gfs writer 'writer))
- (dolist (boundp boundps)
- (initialize-internal-slot-gfs boundp 'boundp)))
+ (macrolet ((frob (type name-fun add-fun)
+ `(when (or (null type) (eq type ',type))
+ (let* ((name (,name-fun slot-name))
+ (gf (ensure-generic-function name))
+ (methods (generic-function-methods gf)))
+ (when (or (null methods)
+ (plist-value gf 'slot-missing-method))
+ (setf (plist-value gf 'slot-missing-method) nil)
+ (,add-fun *the-class-slot-object* gf slot-name))))))
+ (frob reader slot-reader-name add-reader-method)
+ (frob writer slot-writer-name add-writer-method)
+ (frob boundp slot-boundp-name add-boundp-method)))
+slot-unbound+))
direct-slots)))
(reader-names (mapcar (lambda (slotd)
- (intern (format nil
- "~A~A reader"
- conc-name
- (slot-definition-name
- slotd))))
+ (list 'slot-accessor name
+ (slot-definition-name slotd)
+ 'reader))
direct-slots))
(writer-names (mapcar (lambda (slotd)
- (intern (format nil
- "~A~A writer"
- conc-name
- (slot-definition-name
- slotd))))
+ (list 'slot-accessor name
+ (slot-definition-name slotd)
+ 'writer))
direct-slots))
(readers-init
(mapcar (lambda (slotd reader-name)
(pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
(defun pv-wrappers-from-pv-args (&rest args)
- (let* ((nkeys (length args))
- (pv-wrappers (make-list nkeys))
- w
- (w-t pv-wrappers))
- (dolist (arg args)
- (setq w (wrapper-of arg))
- (when (invalid-wrapper-p w)
- (setq w (check-wrapper-validity arg)))
- (setf (car w-t) w))
- (setq w-t (cdr w-t))
- (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
- pv-wrappers))
+ (let (wrappers)
+ (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers)))
+ (let ((wrapper (wrapper-of arg)))
+ (push (if (invalid-wrapper-p wrapper)
+ (check-wrapper-validity wrapper)
+ wrapper)
+ wrappers)))))
(defun pv-wrappers-from-all-args (pv-table args)
- (let ((nkeys 0)
- (slot-name-lists (pv-table-slot-name-lists pv-table)))
- (dolist (sn slot-name-lists)
- (when sn (incf nkeys)))
- (let* ((pv-wrappers (make-list nkeys))
- (pv-w-t pv-wrappers))
- (dolist (sn slot-name-lists)
- (when sn
- (let* ((arg (car args))
- (w (wrapper-of arg)))
- (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
- (error "error in PV-WRAPPERS-FROM-ALL-ARGS"))
- (setf (car pv-w-t) w)
- (setq pv-w-t (cdr pv-w-t))))
- (setq args (cdr args)))
- (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
- pv-wrappers)))
+ (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
+ when snl
+ collect (wrapper-of arg) into wrappers
+ finally (return (if (cdr wrappers) wrappers (car wrappers)))))
+;;; Return the subset of WRAPPERS which is used in the cache
+;;; of PV-TABLE.
(defun pv-wrappers-from-all-wrappers (pv-table wrappers)
- (let ((nkeys 0)
- (slot-name-lists (pv-table-slot-name-lists pv-table)))
- (dolist (sn slot-name-lists)
- (when sn (incf nkeys)))
- (let* ((pv-wrappers (make-list nkeys))
- (pv-w-t pv-wrappers))
- (dolist (sn slot-name-lists)
- (when sn
- (let ((w (car wrappers)))
- (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
- (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS"))
- (setf (car pv-w-t) w)
- (setq pv-w-t (cdr pv-w-t))))
- (setq wrappers (cdr wrappers)))
- (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
- pv-wrappers)))
+ (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers
+ when snl
+ collect w into result
+ finally (return (if (cdr result) result (car result)))))
(set
(walk-form-internal form :set env))
((lambda call)
- (cond ((or (symbolp form)
- (and (listp form)
- (= (length form) 2)
- (eq (car form) 'setf)))
+ (cond ((legal-fun-name-p form)
form)
(t (walk-form-internal form context env)))))
(case (car template)
;;; we should be able to make classes with uninterned names:
(defclass #:class-with-uninterned-name () ())
\f
+;;; SLOT-MISSING should be called when there are missing slots.
+(defclass class-with-all-slots-missing () ())
+(defmethod slot-missing (class (o class-with-all-slots-missing)
+ slot-name op
+ &optional new-value)
+ op)
+(assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo)
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (slot-value x 'bar))
+ (make-instance 'class-with-all-slots-missing))
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
+ (make-instance 'class-with-all-slots-missing))
+ 'setf))
+\f
;;;; success
(sb-ext:quit :unix-status 104)
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.12.37"
+"0.7.12.38"
projects / sbcl.git / commitdiff