Expected: #<SB-MOP:FUNCALLABLE-STANDARD-CLASS STANDARD-GENERIC-FUNCTION>
Got: #<SB-MOP:FUNCALLABLE-STANDARD-CLASS MY-GENERIC-FUNCTION>
-361: initialize-instance of standard-reader-method ignores :function argument
- (reported by Bruno Haible)
- Pass a custom :function argument to initialize-instance of a
- standard-reader-method instance, but it has no effect.
- ;; Check that it's possible to define reader methods that do typechecking.
- (progn
- (defclass typechecking-reader-method (sb-pcl:standard-reader-method)
- ())
- (defmethod initialize-instance ((method typechecking-reader-method) &rest initargs
- &key slot-definition)
- (let ((name (sb-pcl:slot-definition-name slot-definition))
- (type (sb-pcl:slot-definition-type slot-definition)))
- (apply #'call-next-method method
- :function #'(lambda (args next-methods)
- (declare (ignore next-methods))
- (apply #'(lambda (instance)
- (let ((value (slot-value instance name)))
- (unless (typep value type)
- (error "Slot ~S of ~S is not of type ~S: ~S"
- name instance type value))
- value))
- args))
- initargs)))
- (defclass typechecking-reader-class (standard-class)
- ())
- (defmethod sb-pcl:validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
- t)
- (defmethod reader-method-class ((class typechecking-reader-class) direct-slot &rest args)
- (find-class 'typechecking-reader-method))
- (defclass testclass25 ()
- ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
- (:metaclass typechecking-reader-class))
- (macrolet ((succeeds (form)
- `(not (nth-value 1 (ignore-errors ,form)))))
- (let ((p (list 'abc 'def))
- (x (make-instance 'testclass25)))
- (list (succeeds (make-instance 'testclass25 :pair '(seventeen 17)))
- (succeeds (setf (testclass25-pair x) p))
- (succeeds (setf (second p) 456))
- (succeeds (testclass25-pair x))
- (succeeds (slot-value x 'pair))))))
- Expected: (t t t nil t)
- Got: (t t t t t)
-
- (inspect (first (sb-pcl:generic-function-methods #'testclass25-pair)))
- shows that the method was created with a FAST-FUNCTION slot but with a
- FUNCTION slot of NIL.
-
362: missing error when a slot-definition is created without a name
(reported by Bruno Haible)
The MOP says about slot-definition initialization:
;;;; -*- coding: utf-8; -*-
changes in sbcl-0.9.16 relative to sbcl-0.9.15:
- * bug fix: fixed input, output and error redirection in RUN-PROGRAM
- for win32. (thanks to Mike Thomas and Yaroslav Kavenchuk)
* feature: implemented the READER-METHOD-CLASS and
WRITER-METHOD-CLASS portion of the Class Initialization Protocol
as specified by AMOP.
* fixed bug #339(c): if there are applicable methods not part of any
long-form method-combination group, call INVALID-METHOD-ERROR.
(reported by Bruno Haible)
+ * fixed bug #361: the :FUNCTION initarg in the protocol for
+ initialization of methods can now be used to override
+ internally-produced optimized functions. (reported by Bruno
+ Haible)
* bug fix: extensions of MAKE-METHOD-LAMBDA which wrap the
system-provided lambda expression no longer cause warnings about
unbound #:|pv-table| symbols.
with type-inference.
* bug fix: compiler failed to differentiate between different CONS
types in some cases.
+ * bug fix: fixed input, output and error redirection in RUN-PROGRAM
+ for win32. (thanks to Mike Thomas and Yaroslav Kavenchuk)
changes in sbcl-0.9.15 relative to sbcl-0.9.14:
* added support for the ucs-2 external format. (contributed by Ivan
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 68)
+(def!constant +fasl-file-version+ 69)
;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
;;; 38: (2003-01-05) changed names of internal SORT machinery
;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
;;; 67: (2006-07-25) Reports on #lisp about 0.9.13 fasls being invalid on
;;; 0.9.14.something
;;; 68: (2006-08-14) changed number of arguments of LOAD-DEFMETHOD
+;;; 69: (2006-08-17) changed validity of various initargs for methods
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
specializers)
(consp initargs-form)
(eq (car initargs-form) 'list*)
- (memq (cadr initargs-form) '(:function :fast-function))
+ (memq (cadr initargs-form) '(:function))
(consp (setq fn (caddr initargs-form)))
(eq (car fn) 'function)
(consp (setq fn-lambda (cadr fn)))
walked-documentation)
(parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
- (when (or next-method-p-p call-next-method-p)
- (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)
,@walked-declarations
,@walked-lambda-body))
`(,@(when plist
- `(:plist ,plist))
+ `(plist ,plist))
,@(when documentation
`(:documentation ,documentation)))))))))))
(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
+(defstruct (constant-method-call (:copier nil) (:include method-call))
+ value)
#-sb-fluid (declaim (sb-ext:freeze-type method-call))
pv-cell
next-method-call
arg-info)
+(defstruct (constant-fast-method-call
+ (:copier nil) (:include fast-method-call))
+ value)
#-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
\f
-(defvar *method-function-plist* (make-hash-table :test 'eq))
-
-(defun method-function-plist (method-function)
- (gethash method-function *method-function-plist*))
-
-(defun (setf method-function-plist) (val method-function)
- (setf (gethash method-function *method-function-plist*) val))
-
-(defun method-function-get (method-function key &optional default)
- (getf (method-function-plist method-function) key default))
-
-(defun (setf method-function-get)
- (val method-function key)
- (setf (getf (method-function-plist method-function) key) val))
-
-(defun method-function-pv-table (method-function)
- (method-function-get method-function :pv-table))
-
-(defun method-function-method (method-function)
- (method-function-get method-function :method))
-
-(defun method-function-needs-next-methods-p (method-function)
- (method-function-get method-function :needs-next-methods-p t))
+(defun method-plist-value (method key &optional default)
+ (let ((plist (if (consp method)
+ (getf (early-method-initargs method) 'plist)
+ (object-plist method))))
+ (getf plist key default)))
+
+(defun (setf method-plist-value) (new-value method key &optional default)
+ (if (consp method)
+ (setf (getf (getf (early-method-initargs method) 'plist) key default)
+ new-value)
+ (setf (getf (object-plist method) key default) new-value)))
\f
-(defmacro method-function-closure-generator (method-function)
- `(method-function-get ,method-function 'closure-generator))
-
(defun load-defmethod
(class name quals specls ll initargs source-location)
(setq initargs (copy-tree initargs))
- (let ((method-spec (or (getf initargs :method-spec)
- (make-method-spec name quals specls))))
- (setf (getf initargs :method-spec) method-spec)
- (load-defmethod-internal class name quals specls
- ll initargs source-location)))
+ (setf (getf (getf initargs 'plist) :name)
+ (make-method-spec name quals specls))
+ (load-defmethod-internal class name quals specls
+ ll initargs source-location))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
`(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
-(defun initialize-method-function (initargs &optional return-function-p method)
+(defun initialize-method-function (initargs method)
(let* ((mf (getf initargs :function))
- (method-spec (getf initargs :method-spec))
- (plist (getf initargs :plist))
- (pv-table nil)
- (mff (getf initargs :fast-function)))
- (flet ((set-mf-property (p v)
- (when mf
- (setf (method-function-get mf p) v))
- (when mff
- (setf (method-function-get mff p) v))))
- (when method-spec
- (when mf
- (setq mf (set-fun-name mf method-spec)))
- (when mff
- (let ((name `(fast-method ,@(cdr method-spec))))
- (set-fun-name mff name)
- (unless mf
- (set-mf-property :name name)))))
- (when plist
+ (mff (and (typep mf '%method-function)
+ (%method-function-fast-function mf)))
+ (plist (getf initargs 'plist))
+ (name (getf plist :name)))
+ (when name
+ (when mf
+ (setq mf (set-fun-name mf name)))
+ (when (and mff (consp name) (eq (car name) 'slow-method))
+ (let ((fast-name `(fast-method ,@(cdr name))))
+ (set-fun-name mff fast-name))))
+ (when plist
+ (let ((plist plist))
(let ((snl (getf plist :slot-name-lists))
(cl (getf plist :call-list)))
(when (or snl cl)
- (setq pv-table (intern-pv-table :slot-name-lists snl
- :call-list cl))
- (set-mf-property :pv-table pv-table)))
- (loop (when (null plist) (return nil))
- (set-mf-property (pop plist) (pop plist)))
- (when method
- (set-mf-property :method method))
- (when return-function-p
- (or mf (method-function-from-fast-function mff)))))))
+ (setf (method-plist-value method :pv-table)
+ (intern-pv-table :slot-name-lists snl :call-list cl))))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
(defvar *sm-specializers-index*
(!bootstrap-slot-index 'standard-method 'specializers))
-(defvar *sm-fast-function-index*
- (!bootstrap-slot-index 'standard-method 'fast-function))
(defvar *sm-%function-index*
(!bootstrap-slot-index 'standard-method '%function))
+(defvar *sm-qualifiers-index*
+ (!bootstrap-slot-index 'standard-method 'qualifiers))
(defvar *sm-plist-index*
(!bootstrap-slot-index 'standard-method 'plist))
;;; class and deal with it as appropriate. In fact we probably don't
;;; need it anyway because we only use this for METHOD-SPECIALIZERS on
;;; the standard reader method for METHOD-SPECIALIZERS. Probably.
-(dolist (s '(specializers fast-function %function plist))
+(dolist (s '(specializers %function plist))
(aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
(!bootstrap-slot-index 'standard-reader-method s)
(!bootstrap-slot-index 'standard-writer-method s)
(clos-slots-ref (get-slots method) *sm-specializers-index*)
(method-specializers method))))
(defun safe-method-fast-function (method)
- (let ((standard-method-classes
- (list *the-class-standard-method*
- *the-class-standard-reader-method*
- *the-class-standard-writer-method*
- *the-class-standard-boundp-method*))
- (class (class-of method)))
- (if (member class standard-method-classes)
- (clos-slots-ref (get-slots method) *sm-fast-function-index*)
- (method-fast-function method))))
+ (let ((mf (safe-method-function method)))
+ (and (typep mf '%method-function)
+ (%method-function-fast-function mf))))
(defun safe-method-function (method)
(let ((standard-method-classes
(list *the-class-standard-method*
*the-class-standard-boundp-method*))
(class (class-of method)))
(if (member class standard-method-classes)
- (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*)))
- (getf plist 'qualifiers))
+ (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
(method-qualifiers method))))
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
&key slot-name object-class method-class-function)
- (initialize-method-function initargs)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
specializers))
(setq unparsed specializers
parsed ()))
- (list :early-method ;This is an early method dammit!
-
- (getf initargs :function)
- (getf initargs :fast-function)
-
- parsed ;The parsed specializers. This is used
- ;by early-method-specializers to cache
- ;the parse. Note that this only comes
- ;into play when there is more than one
- ;early method on an early gf.
-
- (append
- (list class ;A list to which real-make-a-method
- qualifiers ;can be applied to make a real method
- arglist ;corresponding to this early one.
- unparsed
- initargs
- doc)
- (when slot-name
- (list :slot-name slot-name :object-class object-class
- :method-class-function method-class-function))))))
+ (let ((result
+ (list :early-method
+
+ (getf initargs :function)
+ (let ((mf (getf initargs :function)))
+ (aver mf)
+ (and (typep mf '%method-function)
+ (%method-function-fast-function mf)))
+
+ ;; the parsed specializers. This is used by
+ ;; EARLY-METHOD-SPECIALIZERS to cache the parse.
+ ;; Note that this only comes into play when there is
+ ;; more than one early method on an early gf.
+ parsed
+
+ ;; A list to which REAL-MAKE-A-METHOD can be applied
+ ;; to make a real method corresponding to this early
+ ;; one.
+ (append
+ (list class qualifiers arglist unparsed
+ initargs doc)
+ (when slot-name
+ (list :slot-name slot-name :object-class object-class
+ :method-class-function method-class-function))))))
+ (initialize-method-function initargs result)
+ result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
(defun early-method-lambda-list (early-method)
(third (fifth early-method)))
+(defun early-method-initargs (early-method)
+ (fifth (fifth early-method)))
+
+(defun (setf early-method-initargs) (new-value early-method)
+ (setf (fifth (fifth early-method)) new-value))
+
(defun early-add-named-method (generic-function-name
qualifiers
specializers
(unless mlist
(unless (eq class *the-class-t*)
(let* ((default-method-function #'constantly-nil)
- (default-method-initargs (list :function
- default-method-function))
+ (default-method-initargs (list :function default-method-function
+ 'plist '(:constant-value nil)))
(default-method (make-a-method
'standard-method
()
(list *the-class-t*)
default-method-initargs
"class predicate default method")))
- (setf (method-function-get default-method-function :constant-value)
- nil)
(add-method gf default-method)))
(let* ((class-method-function #'constantly-t)
- (class-method-initargs (list :function
- class-method-function))
+ (class-method-initargs (list :function class-method-function
+ 'plist '(:constant-value t)))
(class-method (make-a-method 'standard-method
()
(list 'object)
(list class)
class-method-initargs
"class predicate class method")))
- (setf (method-function-get class-method-function :constant-value) t)
(add-method gf class-method)))
gf))
(if (listp method)
(early-method-function method)
(values nil (safe-method-fast-function method)))
- (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+ (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
(if (and fmf (or (null pv-table) wrappers))
(let* ((pv-wrappers (when pv-table
(pv-wrappers-from-all-wrappers
(values mf t fmf pv-cell))
(values
(or mf (if (listp method)
- (setf (cadr method)
- (method-function-from-fast-function fmf))
+ (bug "early method with no method-function")
(method-function method)))
t nil nil)))))))
(early-method-function method)
(values nil (safe-method-fast-function method)))
(declare (ignore mf))
- (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+ (let* ((pv-table (and fmf (method-plist-value method :pv-table))))
(if (and fmf (or (null pv-table) wrappers-p))
'fast-method-call
'method-call))))
gf (car next-methods)
(list* (cdr next-methods) (cdr cm-args))
fmf-p method-alist wrappers))
- (arg-info (method-function-get fmf :arg-info)))
- (make-fast-method-call :function fmf
- :pv-cell pv-cell
- :next-method-call next
- :arg-info arg-info))
+ (arg-info (method-plist-value method :arg-info))
+ (default (cons nil nil))
+ (value (method-plist-value method :constant-value default)))
+ (if (eq value default)
+ (make-fast-method-call :function fmf :pv-cell pv-cell
+ :next-method-call next :arg-info arg-info)
+ (make-constant-fast-method-call
+ :function fmf :pv-cell pv-cell :next-method-call next
+ :arg-info arg-info :value value)))
(if real-mf-p
(flet ((frob-cm-arg (arg)
(if (if (listp arg)
:qualifiers nil ; XXX
:function (method-call-function emf)))
(fast-method-call
- (make-instance 'standard-method
- :specializers nil ; XXX
- :qualifiers nil
- :fast-function (fast-method-call-function emf)))))
+ (let* ((fmf (fast-method-call-function emf))
+ (fun (method-function-from-fast-method-call emf))
+ (mf (%make-method-function fmf nil)))
+ (set-funcallable-instance-function mf fun)
+ (make-instance 'standard-method
+ :specializers nil ; XXX
+ :qualifiers nil
+ :function mf)))))
arg))))
- (make-method-call :function mf
- ;; FIXME: this is wrong. Very wrong.
- ;; It assumes that the only place that
- ;; can have make-method calls is in
- ;; the list structure of the second
- ;; argument to CALL-METHOD, but AMOP
- ;; says that CALL-METHOD can be more
- ;; complicated if
- ;; COMPUTE-EFFECTIVE-METHOD (and
- ;; presumably MAKE-METHOD-LAMBDA) is
- ;; adjusted to match.
- ;;
- ;; On the other hand, it's a start,
- ;; because without this calls to
- ;; MAKE-METHOD in method combination
- ;; where one of the methods is of a
- ;; user-defined class don't work at
- ;; all. -- CSR, 2006-08-05
- :call-method-args (cons (mapcar #'frob-cm-arg (car cm-args))
- (cdr cm-args))))
+ (let* ((default (cons nil nil))
+ (value
+ (method-plist-value method :constant-value default))
+ ;; FIXME: this is wrong. Very wrong. It assumes
+ ;; that the only place that can have make-method
+ ;; calls is in the list structure of the second
+ ;; argument to CALL-METHOD, but AMOP says that
+ ;; CALL-METHOD can be more complicated if
+ ;; COMPUTE-EFFECTIVE-METHOD (and presumably
+ ;; MAKE-METHOD-LAMBDA) is adjusted to match.
+ ;;
+ ;; On the other hand, it's a start, because
+ ;; without this calls to MAKE-METHOD in method
+ ;; combination where one of the methods is of a
+ ;; user-defined class don't work at all. -- CSR,
+ ;; 2006-08-05
+ (args (cons (mapcar #'frob-cm-arg (car cm-args))
+ (cdr cm-args))))
+ (if (eq value default)
+ (make-method-call :function mf :call-method-args args)
+ (make-constant-method-call :function mf :value value
+ :call-method-args args))))
mf))))
(defun make-effective-method-function-simple1
(defclass method (metaobject) ())
-(defclass standard-method (definition-source-mixin plist-mixin method)
+(defclass standard-method (plist-mixin definition-source-mixin method)
((%generic-function
:initform nil
:accessor method-generic-function)
- #+nil ; implemented by PLIST
(qualifiers
:initform ()
:initarg :qualifiers
:initform ()
:initarg :lambda-list
:reader method-lambda-list)
- (%function :initform nil :initarg :function)
- (fast-function
- :initform nil
- :initarg :fast-function ;no writer
- :reader method-fast-function)
+ (%function :initform nil :initarg :function :reader method-function)
(%documentation :initform nil :initarg :documentation)))
(defclass accessor-method (standard-method)
:initarg :definition-source)))
(defclass plist-mixin (standard-object)
- ((plist :initform () :accessor object-plist)))
+ ((plist :initform () :accessor object-plist :initarg plist)))
(defclass dependent-update-mixin (plist-mixin) ())
(every (lambda (mt) (eq mt t)) metatypes)))
(defun use-caching-dfun-p (generic-function)
- (some (lambda (method)
- (let ((fmf (if (listp method)
- (third method)
- (safe-method-fast-function method))))
- (method-function-get fmf :slot-name-lists)))
+ (some (lambda (method) (method-plist-value method :slot-name-lists))
;; KLUDGE: As of sbcl-0.6.4, it's very important for
;; efficiency to know the type of the sequence argument to
;; quantifiers (SOME/NOTANY/etc.) at compile time, but
(safe-method-specializers method))
(safe-method-qualifiers method))
(return nil)))
- (let ((value (method-function-get
- (if early-p
- (or (third method) (second method))
- (or (safe-method-fast-function method)
- (safe-method-function method)))
- :constant-value default)))
+ (let ((value (method-plist-value method :constant-value default)))
(when (or (eq value default)
(and boolean-values-p
(not (member value '(t nil)))))
(let ((ocache (dfun-info-cache dfun-info)))
(dfun-miss (generic-function args wrappers invalidp emf nil nil t)
(unless invalidp
- (let* ((function
+ (let* ((value
(typecase emf
- (fast-method-call (fast-method-call-function emf))
- (method-call (method-call-function emf))))
- (value (let ((val (method-function-get
- function :constant-value '.not-found.)))
- (aver (not (eq val '.not-found.)))
- val))
+ (constant-fast-method-call
+ (constant-fast-method-call-value emf))
+ (constant-method-call (constant-method-call-value emf))
+ (t (bug "~S with non-constant EMF ~S"
+ 'constant-value-miss emf))))
(ncache (fill-cache ocache wrappers value)))
(unless (eq ncache ocache)
(dfun-update generic-function
(found-method nil))
(dolist (method (standard-slot-value/gf gf 'methods) found-method)
(let ((specializers (standard-slot-value/method method 'specializers))
- (qualifiers (plist-value method 'qualifiers)))
+ (qualifiers (standard-slot-value/method method 'qualifiers)))
(when (and (null qualifiers)
(let ((subcpl (member (ecase type
(reader (car specializers))
(dolist (meth methods)
(when (if (consp meth)
(early-method-qualifiers meth)
- (method-qualifiers meth))
+ (safe-method-qualifiers meth))
(return-from accessor-values-internal (values nil nil))))
(let* ((meth (car methods))
(early-p (not (eq *boot-state* 'complete)))
(defgeneric method-combination-type-name (standard-method-combination))
-(defgeneric method-fast-function (standard-method))
-
(defgeneric method-generic-function (standard-method))
(defgeneric object-plist (plist-mixin))
(when (valid-function-name-p fun)
(setq fun (fdefinition fun)))
(when (funcallable-instance-p fun)
- (if (if (eq *boot-state* 'complete)
- (typep fun 'generic-function)
- (eq (class-of fun) *the-class-standard-generic-function*))
- (setf (%funcallable-instance-info fun 2) new-name)
- (bug "unanticipated function type")))
+ ;; HACK
+ (case (classoid-name (classoid-of fun))
+ (%method-function (setf (%method-function-name fun) new-name))
+ (t ;; KLUDGE: probably a generic function...
+ (if (if (eq *boot-state* 'complete)
+ (typep fun 'generic-function)
+ (eq (class-of fun) *the-class-standard-generic-function*))
+ (setf (%funcallable-instance-info fun 2) new-name)
+ (bug "unanticipated function type")))))
;; Fixup name-to-function mappings in cases where the function
;; hasn't been defined by DEFUN. (FIXME: is this right? This logic
;; comes from CMUCL). -- CSR, 2004-12-31
(defun structure-slotd-init-form (slotd)
(dsd-default slotd))
-
+\f
+;;; method function stuff.
+;;;
+;;; PCL historically included a so-called method-fast-function, which
+;;; is essentially a method function but with (a) a precomputed
+;;; continuation for CALL-NEXT-METHOD and (b) a permutation vector for
+;;; slot access. [ FIXME: see if we can understand these two
+;;; optimizations before commit. ] However, the presence of the
+;;; fast-function meant that we violated AMOP and the effect of the
+;;; :FUNCTION initarg, and furthermore got to potentially confusing
+;;; situations where the function and the fast-function got out of
+;;; sync, so that calling (method-function method) with the defined
+;;; protocol would do different things from (call-method method) in
+;;; method combination.
+;;;
+;;; So we define this internal method function structure, which we use
+;;; when we create a method function ourselves. This means that we
+;;; can hang the various bits of information that we want off the
+;;; method function itself, and also that if a user overrides method
+;;; function creation there is no danger of having the system get
+;;; confused.
+(!defstruct-with-alternate-metaclass %method-function
+ :slot-names (fast-function name)
+ :boa-constructor %make-method-function
+ :superclass-name function
+ :metaclass-name random-pcl-classoid
+ :metaclass-constructor make-random-pcl-classoid
+ :dd-type funcallable-structure)
+\f
;;; WITH-PCL-LOCK is used around some forms that were previously
;;; protected by WITHOUT-INTERRUPTS, but in a threaded SBCL we don't
;;; have a useful WITHOUT-INTERRUPTS. In an unthreaded SBCL I'm not
(in-package "SB-PCL")
\f
-
;;; methods
;;;
;;; Methods themselves are simple inanimate objects. Most properties of
;;; methods are immutable, methods cannot be reinitialized. The following
;;; properties of methods can be changed:
;;; METHOD-GENERIC-FUNCTION
-;;; METHOD-FUNCTION ??
-
-(defmethod method-function ((method standard-method))
- (or (slot-value method '%function)
- (let ((fmf (slot-value method 'fast-function)))
- (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this.
- (error "~S doesn't seem to have a METHOD-FUNCTION." method))
- (setf (slot-value method '%function)
- (method-function-from-fast-function fmf)))))
-
+\f
;;; initialization
;;;
;;; Error checking is done in before methods. Because of the simplicity of
(defmethod shared-initialize :before
((method standard-method) slot-names &key
- qualifiers lambda-list specializers function fast-function documentation)
+ qualifiers lambda-list specializers function documentation)
(declare (ignore slot-names))
;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get
;; this extra paranoia and nothing else does; either everything
(check-qualifiers method qualifiers)
(check-lambda-list method lambda-list)
(check-specializers method specializers)
- (check-method-function method (or function fast-function))
+ (check-method-function method function)
(check-documentation method documentation))
(defmethod shared-initialize :before
(check-slot-name method slot-name)))
(defmethod shared-initialize :after ((method standard-method) slot-names
- &rest initargs
- &key qualifiers method-spec plist)
- (declare (ignore slot-names method-spec plist))
- (initialize-method-function initargs nil method)
- (setf (plist-value method 'qualifiers) qualifiers)
- #+ignore
- (setf (slot-value method 'closure-generator)
- (method-function-closure-generator (slot-value method '%function))))
-
-(defmethod method-qualifiers ((method standard-method))
- (plist-value method 'qualifiers))
+ &rest initargs &key)
+ (declare (ignore slot-names))
+ (initialize-method-function initargs method))
+
\f
(defvar *the-class-generic-function*
(find-class 'generic-function))
(defmethod specializer-class ((specializer eql-specializer))
(class-of (slot-value specializer 'object)))
-(defvar *in-gf-arg-info-p* nil)
-(setf (gdefinition 'arg-info-reader)
- (let ((mf (initialize-method-function
- (make-internal-reader-method-function
- 'standard-generic-function 'arg-info)
- t)))
- (lambda (&rest args) (funcall mf args nil))))
-
-
(defun error-need-at-least-n-args (function n)
(error 'simple-program-error
:format-control "~@<The function ~2I~_~S ~I~_requires ~
(defun value-for-caching (gf classes)
(let ((methods (compute-applicable-methods-using-types
gf (mapcar #'class-eq-type classes))))
- (method-function-get (or (safe-method-fast-function (car methods))
- (safe-method-function (car methods)))
- :constant-value)))
+ (method-plist-value (car methods) :constant-value)))
(defun default-secondary-dispatch-function (generic-function)
(lambda (&rest args)
(boundp (lambda (instance)
(emf-funcall sdfun class instance slotd))))
`(,name ,(class-name class) ,(slot-definition-name slotd)))))
-
-(defun make-internal-reader-method-function (class-name slot-name)
- (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
- (make-method-function
- (lambda (instance)
- (let ((wrapper (get-instance-wrapper-or-nil instance)))
- (if wrapper
- (let* ((class (wrapper-class* wrapper))
- (index (or (instance-slot-index wrapper slot-name)
- (assq slot-name
- (wrapper-class-slots wrapper)))))
- (typecase index
- (fixnum
- (let ((value (clos-slots-ref (get-slots instance)
- index)))
- (if (eq value +slot-unbound+)
- (values (slot-unbound (class-of instance)
- instance
- slot-name))
- value)))
- (cons
- (let ((value (cdr index)))
- (if (eq value +slot-unbound+)
- (values (slot-unbound (class-of instance)
- instance
- slot-name))
- value)))
- (t
- (error "~@<The wrapper for class ~S does not have ~
- the slot ~S~@:>"
- class slot-name))))
- (slot-value instance slot-name)))))))
\f
(defun make-std-reader-method-function (class-name slot-name)
(let* ((initargs (copy-tree
(instance-read-internal
.pv. instance-slots 0
(slot-value instance slot-name))))))))
- (setf (getf (getf initargs :plist) :slot-name-lists)
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
(list (list nil slot-name)))
- (list* :method-spec `(reader-method ,class-name ,slot-name)
- initargs)))
+ initargs))
(defun make-std-writer-method-function (class-name slot-name)
(let* ((initargs (copy-tree
(instance-write-internal
.pv. instance-slots 0 nv
(setf (slot-value instance slot-name) nv))))))))
- (setf (getf (getf initargs :plist) :slot-name-lists)
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
(list nil (list nil slot-name)))
- (list* :method-spec `(writer-method ,class-name ,slot-name)
- initargs)))
+ initargs))
(defun make-std-boundp-method-function (class-name slot-name)
(let* ((initargs (copy-tree
(instance-boundp-internal
.pv. instance-slots 0
(slot-boundp instance slot-name))))))))
- (setf (getf (getf initargs :plist) :slot-name-lists)
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
(list (list nil slot-name)))
- (list* :method-spec `(boundp-method ,class-name ,slot-name)
- initargs)))
+ initargs))
(incf nreq)
(push arg args))
(setq args (nreverse args))
- (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp))
+ (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp))
(make-method-initargs-form-internal1
initargs (cddr lmf) args lmf-params restp)))))
(append req-args (list rest-arg))
req-args)))
`(list*
- :fast-function
- (,(if (body-method-name body) 'named-lambda 'lambda)
- ,@(when (body-method-name body)
- ;; function name
- (list (cons 'fast-method (body-method-name body))))
- (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
- ;; body of the function
- (declare (ignorable .pv-cell. .next-method-call.)
- (disable-package-locks pv-env-environment))
- ,@outer-decls
- (symbol-macrolet ((pv-env-environment default))
- (fast-lexical-method-functions
- (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
- ,@(cdddr lmf-params))
- ,@inner-decls
- ,@body-sans-decls)))
+ :function
+ (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
+ ,@(when (body-method-name body)
+ ;; function name
+ (list (cons 'fast-method (body-method-name body))))
+ (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
+ ;; body of the function
+ (declare (ignorable .pv-cell. .next-method-call.)
+ (disable-package-locks pv-env-environment))
+ ,@outer-decls
+ (symbol-macrolet ((pv-env-environment default))
+ (fast-lexical-method-functions
+ (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body-sans-decls))))
+ (mf (%make-method-function fmf nil)))
+ (set-funcallable-instance-function
+ mf (method-function-from-fast-function fmf ',(getf initargs 'plist)))
+ mf)
',initargs))))
;;; Use arrays and hash tables and the fngen stuff to make this much
;;; returned by this will get called only when the user explicitly
;;; funcalls a result of method-function. BUT, this is needed to make
;;; early methods work.
-(defun method-function-from-fast-function (fmf)
+(defun method-function-from-fast-function (fmf plist)
(declare (type function fmf))
- (let* ((method-function nil) (pv-table nil)
- (arg-info (method-function-get fmf :arg-info))
+ (let* ((method-function nil)
+ (calls (getf plist :call-list))
+ (snl (getf plist :slot-name-lists))
+ (pv-table (when (or calls snl)
+ (intern-pv-table :call-list calls :slot-name-lists snl)))
+ (arg-info (getf plist :arg-info))
(nreq (car arg-info))
(restp (cdr arg-info)))
(setq method-function
(lambda (method-args next-methods)
- (unless pv-table
- (setq pv-table (method-function-pv-table fmf)))
(let* ((pv-cell (when pv-table
- (get-method-function-pv-cell
- method-function method-args pv-table)))
+ (get-pv-cell method-args pv-table)))
(nm (car next-methods))
(nms (cdr next-methods))
(nmc (when nm
(args (ldiff method-args rest)))
(apply fmf pv-cell nmc (nconc args (list rest))))
(apply fmf pv-cell nmc method-args)))))
- (let* ((fname (method-function-get fmf :name))
- (name (cons 'slow-method (cdr fname))))
- (set-fun-name method-function name))
- (setf (method-function-get method-function :fast-function) fmf)
+ ;; FIXME: this looks dangerous.
+ (let* ((fname (%fun-name fmf)))
+ (when (and fname (eq (car fname) 'fast-method))
+ (set-fun-name method-function (cons 'slow-method (cdr fname)))))
method-function))
-(defun get-method-function-pv-cell (method-function
- method-args
- &optional pv-table)
- (let ((pv-table (or pv-table (method-function-pv-table method-function))))
- (when pv-table
- (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
- (when pv-wrappers
- (pv-table-lookup pv-table pv-wrappers))))))
+;;; this is similar to the above, only not quite. Only called when
+;;; the MOP is heavily involved. Not quite parallel to
+;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close
+;;; over the actual PV-CELL in this case.
+(defun method-function-from-fast-method-call (fmc)
+ (let* ((fmf (fast-method-call-function fmc))
+ (pv-cell (fast-method-call-pv-cell fmc))
+ (arg-info (fast-method-call-arg-info fmc))
+ (nreq (car arg-info))
+ (restp (cdr arg-info)))
+ (lambda (method-args next-methods)
+ (let* ((nm (car next-methods))
+ (nms (cdr next-methods))
+ (nmc (when nm
+ (make-method-call
+ :function (if (std-instance-p nm)
+ (method-function nm)
+ nm)
+ :call-method-args (list nms)))))
+ (if restp
+ (let* ((rest (nthcdr nreq method-args))
+ (args (ldiff method-args rest)))
+ (apply fmf pv-cell nmc (nconc args (list rest))))
+ (apply fmf pv-cell nmc method-args))))))
+
+(defun get-pv-cell (method-args pv-table)
+ (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
+ (when pv-wrappers
+ (pv-table-lookup pv-table pv-wrappers))))
(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
(pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; Some slot-valuish things in combination with user-defined methods
+
+(defpackage "MOP-24"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-24")
+
+(defclass user-method (standard-method) (myslot))
+
+(defmacro def-user-method (name &rest rest)
+ (let* ((lambdalist-position (position-if #'listp rest))
+ (qualifiers (subseq rest 0 lambdalist-position))
+ (lambdalist (elt rest lambdalist-position))
+ (body (subseq rest (+ lambdalist-position 1)))
+ (required-part
+ (subseq lambdalist 0
+ (or (position-if #'(lambda (x)
+ (member x lambda-list-keywords))
+ lambdalist)
+ (length lambdalist))))
+ (specializers
+ (mapcar #'find-class
+ (mapcar #'(lambda (x) (if (consp x) (second x) 't))
+ required-part)))
+ (unspecialized-required-part
+ (mapcar #'(lambda (x) (if (consp x) (first x) x)) required-part))
+ (unspecialized-lambdalist
+ (append unspecialized-required-part
+ (subseq required-part (length required-part)))))
+ `(progn
+ (add-method #',name
+ (make-instance 'user-method
+ :qualifiers ',qualifiers
+ :lambda-list ',unspecialized-lambdalist
+ :specializers ',specializers
+ :function
+
+ #'(lambda (arguments next-methods-list)
+ (flet ((next-method-p () next-methods-list)
+ (call-next-method (&rest new-arguments)
+ (unless new-arguments (setq new-arguments arguments))
+ (if (null next-methods-list)
+ (error "no next method for arguments ~:s" arguments)
+ (funcall (method-function (first next-methods-list))
+ new-arguments (rest next-methods-list)))))
+ (apply #'(lambda ,unspecialized-lambdalist ,@body) arguments)))))
+ ',name)))
+
+(defclass super ()
+ ((a :initarg :a :initform 3)))
+(defclass sub (super)
+ ((b :initarg :b :initform 4)))
+(defclass subsub (sub)
+ ((b :initarg :b :initform 5)
+ (a :initarg :a :initform 6)))
+
+;;; reworking of MOP-20 tests, but with slot-valuish things.
+(progn
+ (defgeneric test-um03 (x))
+ (defmethod test-um03 ((x subsub))
+ (list* 'subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (def-user-method test-um03 ((x sub))
+ (list* 'sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um03 ((x super))
+ (list 'super (slot-value x 'a) (not (null (next-method-p)))))
+ (assert (equal (test-um03 (make-instance 'super)) '(super 3 nil)))
+ (assert (equal (test-um03 (make-instance 'sub)) '(sub 3 4 t super 3 nil)))
+ (assert (equal (test-um03 (make-instance 'subsub))
+ '(subsub 6 5 t sub 6 5 t super 6 nil))))
+
+(progn
+ (defgeneric test-um10 (x))
+ (defmethod test-um10 ((x subsub))
+ (list* 'subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 ((x sub))
+ (list* 'sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 ((x super))
+ (list 'super (slot-value x 'a) (not (null (next-method-p)))))
+ (defmethod test-um10 :after ((x super)))
+ (def-user-method test-um10 :around ((x subsub))
+ (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 :around ((x sub))
+ (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um10 :around ((x super))
+ (list* 'around-super (slot-value x 'a)
+ (not (null (next-method-p))) (call-next-method)))
+ (assert (equal (test-um10 (make-instance 'super))
+ '(around-super 3 t super 3 nil)))
+ (assert (equal (test-um10 (make-instance 'sub))
+ '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
+ (assert (equal (test-um10 (make-instance 'subsub))
+ '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
+ subsub 6 5 t sub 6 5 t super 6 nil))))
+
+(progn
+ (defgeneric test-um12 (x))
+ (defmethod test-um12 ((x subsub))
+ (list* 'subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 ((x sub))
+ (list* 'sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 ((x super))
+ (list 'super (slot-value x 'a) (not (null (next-method-p)))))
+ (defmethod test-um12 :after ((x super)))
+ (defmethod test-um12 :around ((x subsub))
+ (list* 'around-subsub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (defmethod test-um12 :around ((x sub))
+ (list* 'around-sub (slot-value x 'a) (slot-value x 'b)
+ (not (null (next-method-p))) (call-next-method)))
+ (def-user-method test-um12 :around ((x super))
+ (list* 'around-super (slot-value x 'a)
+ (not (null (next-method-p))) (call-next-method)))
+ (assert (equal (test-um12 (make-instance 'super))
+ '(around-super 3 t super 3 nil)))
+ (assert (equal (test-um12 (make-instance 'sub))
+ '(around-sub 3 4 t around-super 3 t sub 3 4 t super 3 nil)))
+ (assert (equal (test-um12 (make-instance 'subsub))
+ '(around-subsub 6 5 t around-sub 6 5 t around-super 6 t
+ subsub 6 5 t sub 6 5 t super 6 nil))))
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; be sure that the :FUNCTION initarg to initialize methods overrides
+;;; any system-provided function.
+
+(defpackage "MOP-25"
+ (:use "CL" "SB-MOP"))
+
+(in-package "MOP-25")
+
+(defclass typechecking-reader-method (standard-reader-method)
+ ())
+
+(defmethod initialize-instance
+ ((method typechecking-reader-method) &rest initargs &key slot-definition)
+ (let ((name (slot-definition-name slot-definition))
+ (type (slot-definition-type slot-definition)))
+ (apply #'call-next-method method
+ :function #'(lambda (args next-methods)
+ (declare (ignore next-methods))
+ (apply #'(lambda (instance)
+ (let ((value (slot-value instance name)))
+ (unless (typep value type)
+ (error "Slot ~S of ~S is not of type ~S: ~S"
+ name instance type value))
+ value))
+ args))
+ initargs)))
+(defclass typechecking-reader-class (standard-class)
+ ())
+
+(defmethod validate-superclass ((c1 typechecking-reader-class) (c2 standard-class))
+ t)
+
+(defmethod reader-method-class
+ ((class typechecking-reader-class) direct-slot &rest args)
+ (find-class 'typechecking-reader-method))
+
+(defclass testclass25 ()
+ ((pair :type (cons symbol (cons symbol null)) :initarg :pair :accessor testclass25-pair))
+ (:metaclass typechecking-reader-class))
+
+(assert (equal '(t t t nil t)
+ (macrolet ((succeeds (form)
+ `(not (nth-value 1 (ignore-errors ,form)))))
+ (let ((p (list 'abc 'def))
+ (x (make-instance 'testclass25)))
+ (list (succeeds (make-instance 'testclass25 :pair '(seventeen 17)))
+ (succeeds (setf (testclass25-pair x) p))
+ (succeeds (setf (second p) 456))
+ (succeeds (testclass25-pair x))
+ (succeeds (slot-value x 'pair)))))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.15.36"
+"0.9.15.37"
projects / sbcl.git / commitdiff