From 832f3b5652ae1b4a8888829cd4a1b391a8ca9952 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 17 Aug 2006 15:12:46 +0000 Subject: [PATCH] 0.9.15.17: Implement the :FUNCTION initarg for method initialization ... half of the battle here was altering the propagation of information about methods around the system. Prior to this checkin, information was kept in a (non-weak) hash table holding plists for method functions and method fast functions. Instead, we associate the plist with the method itself. ... implement method-qualifiers as a proper slot reader, rather than through the plist; ... method-function-get-DIE-DIE-DIE ... constant-method-call and constant-fast-method-call structures for the special case of constant-value (e.g. predicate) generic functions ... remove :METHOD-SPEC initarg, since it's useless ... rely more on interning instead of METHOD-FUNCTION-PV-TABLE ... remove dead code (e.g. METHOD-FUNCTION-CLOSURE-GENERATOR, MAKE-INTERNAL-READER-METHOD-FUNCTION) ... define a %METHOD-FUNCTION funcallable structure, to bind function and fast-function closely together. ... remove the :FAST-FUNCTION initarg. Now, if the system wants a fast-function, it creates a %method-function structure with the fast-function in the fast-function slot (and an ordinary method-function as the funcallable-instance-function) ... some test cases. (This fixes bug #361 among others, and we have no current failures against the Closer mop-feature-tests) --- BUGS | 48 ----------- NEWS | 8 +- src/code/early-fasl.lisp | 3 +- src/pcl/boot.lisp | 175 +++++++++++++++++----------------------- src/pcl/braid.lisp | 11 +-- src/pcl/combin.lisp | 75 +++++++++-------- src/pcl/defs.lisp | 11 +-- src/pcl/dfun.lisp | 30 +++---- src/pcl/generic-functions.lisp | 2 - src/pcl/low.lisp | 44 ++++++++-- src/pcl/methods.lisp | 44 ++-------- src/pcl/slots-boot.lisp | 47 ++--------- src/pcl/vector.lisp | 98 +++++++++++++--------- tests/mop-24.impure.lisp | 140 ++++++++++++++++++++++++++++++++ tests/mop-25.impure.lisp | 63 +++++++++++++++ version.lisp-expr | 2 +- 16 files changed, 461 insertions(+), 340 deletions(-) create mode 100644 tests/mop-24.impure.lisp create mode 100644 tests/mop-25.impure.lisp diff --git a/BUGS b/BUGS index be6f906..0e990ce 100644 --- a/BUGS +++ b/BUGS @@ -1407,54 +1407,6 @@ WORKAROUND: Expected: # Got: # -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: diff --git a/NEWS b/NEWS index 3f10968..45cf33e 100644 --- a/NEWS +++ b/NEWS @@ -1,7 +1,5 @@ ;;;; -*- 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. @@ -22,6 +20,10 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: * 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. @@ -50,6 +52,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: 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 diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 09c3333..3a4f6e0 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -76,7 +76,7 @@ ;;; 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 @@ -139,6 +139,7 @@ ;;; 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*)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 456c037..be9bfbd 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -413,7 +413,7 @@ bootstrapping. 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))) @@ -752,8 +752,6 @@ bootstrapping. 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) @@ -797,7 +795,7 @@ bootstrapping. ,@walked-declarations ,@walked-lambda-body)) `(,@(when plist - `(:plist ,plist)) + `(plist ,plist)) ,@(when documentation `(:documentation ,documentation))))))))))) @@ -876,6 +874,8 @@ bootstrapping. (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)) @@ -899,6 +899,9 @@ bootstrapping. 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)) @@ -1359,41 +1362,25 @@ bootstrapping. (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) -(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))) -(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 @@ -1430,38 +1417,25 @@ bootstrapping. (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)))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? @@ -1739,10 +1713,10 @@ bootstrapping. (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)) @@ -1750,7 +1724,7 @@ bootstrapping. ;;; 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) @@ -1767,15 +1741,9 @@ bootstrapping. (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* @@ -1794,8 +1762,7 @@ bootstrapping. *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) @@ -2108,7 +2075,6 @@ bootstrapping. (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 @@ -2126,27 +2092,32 @@ bootstrapping. 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 @@ -2218,6 +2189,12 @@ bootstrapping. (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 diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 5a808ae..00b4adc 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -597,8 +597,8 @@ (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 () @@ -606,19 +606,16 @@ (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)) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 68f4100..b2743d3 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -31,7 +31,7 @@ (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 @@ -41,8 +41,7 @@ (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))))))) @@ -83,7 +82,7 @@ (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)))) @@ -129,11 +128,15 @@ 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) @@ -150,31 +153,37 @@ :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 diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index e94c009..68e53b6 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -365,11 +365,10 @@ (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 @@ -382,11 +381,7 @@ :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) @@ -684,7 +679,7 @@ :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) ()) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3117264..3765007 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -489,11 +489,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -584,12 +580,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))))) @@ -1077,14 +1068,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -1229,7 +1219,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)) @@ -1261,7 +1251,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 36195fa..af9bc26 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -104,8 +104,6 @@ (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)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 525f3cc..aa65f9e 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -179,11 +179,15 @@ (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 @@ -335,7 +339,35 @@ (defun structure-slotd-init-form (slotd) (dsd-default slotd)) - + +;;; 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) + ;;; 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 diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 92e94b8..76a784f 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -23,23 +23,13 @@ (in-package "SB-PCL") - ;;; 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))))) - + ;;; initialization ;;; ;;; Error checking is done in before methods. Because of the simplicity of @@ -139,7 +129,7 @@ (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 @@ -151,7 +141,7 @@ (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 @@ -162,17 +152,10 @@ (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)) + (defvar *the-class-generic-function* (find-class 'generic-function)) @@ -666,15 +649,6 @@ (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 "~@" - class slot-name)))) - (slot-value instance slot-name))))))) (defun make-std-reader-method-function (class-name slot-name) (let* ((initargs (copy-tree @@ -446,10 +414,9 @@ (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 @@ -461,10 +428,9 @@ (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 @@ -476,7 +442,6 @@ (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)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index c2590ec..4750fac 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -1051,7 +1051,7 @@ (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))))) @@ -1066,22 +1066,26 @@ (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 @@ -1089,19 +1093,20 @@ ;;; 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 @@ -1115,20 +1120,41 @@ (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))) diff --git a/tests/mop-24.impure.lisp b/tests/mop-24.impure.lisp new file mode 100644 index 0000000..c6f8999 --- /dev/null +++ b/tests/mop-24.impure.lisp @@ -0,0 +1,140 @@ +;;;; 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)))) diff --git a/tests/mop-25.impure.lisp b/tests/mop-25.impure.lisp new file mode 100644 index 0000000..9836e47 --- /dev/null +++ b/tests/mop-25.impure.lisp @@ -0,0 +1,63 @@ +;;;; 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))))))) diff --git a/version.lisp-expr b/version.lisp-expr index 0f8def5..6e45527 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4