;;;; -*- coding: utf-8; -*-
changes in sbcl-0.9.7 relative to sbcl-0.9.6:
+ * bug fix: it is now possible to have more than one subclass of
+ STANDARD-GENERIC-FUNCTION without causing stack overflow.
+ (reported by Bruno Haible, Pascal Costanza and others)
* bug fix: *COMPILE-FILE-PATHNAME* now contains the user's pathname
merged with *DEFAULT-PATHNAME-DEFAULTS*.
* optimization: performance improvements to IO on file streams of
(when lambda-list-p
(proclaim (defgeneric-declaration fun-name lambda-list)))))
\f
+;;; FIXME: this function took on a slightly greater role than it
+;;; previously had around 2005-11-02, when CSR fixed the bug whereby
+;;; having more than one subclass of standard-generic-function caused
+;;; the whole system to die horribly through a metacircle in
+;;; GF-ARG-INFO. The fix is to be slightly more disciplined about
+;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when
+;;; computing discriminating functions, so we need to be careful about
+;;; having a base case for the recursion, and we provide that with the
+;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet)
+;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to
+;;; that stage, where all potentially dangerous cases are enumerated
+;;; and stopped. -- CSR, 2005-11-02.
(defun get-generic-fun-info (gf)
;; values nreq applyp metatypes nkeys arg-info
(multiple-value-bind (applyp metatypes arg-info)
(let* ((arg-info (if (early-gf-p gf)
(early-gf-arg-info gf)
- (gf-arg-info gf)))
+ (if (eq (class-of gf) *the-class-standard-generic-function*)
+ (clos-slots-ref (fsc-instance-slots gf) *sgf-arg-info-index*)
+ (gf-arg-info gf))))
(metatypes (arg-info-metatypes arg-info)))
(values (arg-info-applyp arg-info)
metatypes
(defun make-final-checking-dfun (generic-function function
classes-list new-class)
- (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-fun-info generic-function)
+ (declare (ignore nreq applyp nkeys))
(if (every (lambda (mt) (eq mt t)) metatypes)
(values (lambda (&rest args)
(invoke-emf function args))
(defparameter *secondary-dfun-call-cost* 1)
(defun caching-dfun-cost (gf)
- (let* ((arg-info (gf-arg-info gf))
- (nreq (length (arg-info-metatypes arg-info))))
+ (let ((nreq (get-generic-fun-info gf)))
(+ *cache-lookup-cost*
(* *wrapper-of-cost* nreq)
(if (methods-contain-eql-specializer-p
(t
(make-final-caching-dfun gf classes-list new-class)))))
+(defvar *accessor-miss-history* nil)
+
(defun accessor-miss (gf new object dfun-info)
- (let* ((ostate (type-of dfun-info))
- (otype (dfun-info-accessor-type dfun-info))
- oindex ow0 ow1 cache
- (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
- ;; dfun to that which is their name. They accept arguments
- ;; which are the parameters of the new state, and get other
- ;; information from the lexical variables bound above.
- (flet ((two-class (index w0 w1)
+ (let ((wrapper (wrapper-of object))
+ (previous-miss (assq gf *accessor-miss-history*)))
+ (when (eq wrapper (cdr previous-miss))
+ (error "~@<Vicious metacircle: The computation of a ~
+ dfun of ~s for argument ~s uses the dfun being ~
+ computed.~@:>"
+ gf object))
+ (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*))
+ (ostate (type-of dfun-info))
+ (otype (dfun-info-accessor-type dfun-info))
+ oindex ow0 ow1 cache
+ (args (ecase otype
+ ((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
+ ;; dfun to that which is their name. They accept arguments
+ ;; which are the parameters of the new state, and get other
+ ;; information from the lexical variables bound above.
+ (flet ((two-class (index w0 w1)
(when (zerop (random 2)) (psetf w0 w1 w1 w0))
(dfun-update gf
#'make-two-class-accessor-dfun
(setq cache (dfun-info-cache dfun-info))
(if (consp nindex)
(caching)
- (do-fill #'n-n))))))))))
+ (do-fill #'n-n)))))))))))
(defun checking-miss (generic-function args dfun-info)
(let ((oemf (dfun-info-function dfun-info))
(let ((definite-p t) (possibly-applicable-methods nil))
(dolist (method (if (early-gf-p generic-function)
(early-gf-methods generic-function)
- (generic-function-methods generic-function)))
+ (if (eq (class-of generic-function)
+ *the-class-standard-generic-function*)
+ ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO
+ (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*)
+ (generic-function-methods generic-function))))
(let ((specls (if (consp method)
(early-method-specializers method t)
(method-specializers method)))
(when possibly-applicable-p
(unless applicable-p (setq definite-p nil))
(push method possibly-applicable-methods))))
- (let ((precedence (arg-info-precedence (if (early-gf-p generic-function)
- (early-gf-arg-info
- generic-function)
- (gf-arg-info
- generic-function)))))
- (values (sort-applicable-methods precedence
- (nreverse possibly-applicable-methods)
- types)
- definite-p))))
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-fun-info generic-function)
+ (declare (ignore nreq applyp metatypes nkeys))
+ (let* ((precedence (arg-info-precedence arg-info)))
+ (values (sort-applicable-methods precedence
+ (nreverse possibly-applicable-methods)
+ types)
+ definite-p)))))
(defun sort-applicable-methods (precedence methods types)
(sort-methods methods
(return t)))))
\f
(defun update-dfun (generic-function &optional dfun cache info)
- (let* ((early-p (early-gf-p generic-function))
- (gf-name (if early-p
- (!early-gf-name generic-function)
- (generic-function-name generic-function))))
+ (let* ((early-p (early-gf-p generic-function)))
(set-dfun generic-function dfun cache info)
(let ((dfun (if early-p
(or dfun (make-initial-dfun generic-function))
(compute-discriminating-function generic-function))))
(set-funcallable-instance-function generic-function dfun)
- (set-fun-name generic-function gf-name)
- dfun)))
+ (let ((gf-name (if early-p
+ (!early-gf-name generic-function)
+ (generic-function-name generic-function))))
+ (set-fun-name generic-function gf-name)
+ dfun))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
;;;; more information.
;;; This file contains two tests for COMPUTE-APPLICABLE-METHODS on
-;;; subclasses of generic functions. However, at present it is
-;;; impossible to have both of these in the same image, because of a
-;;; vicious metacircle. Once the vicious metacircle is dealt with,
-;;; uncomment the second test case.
+;;; subclasses of generic functions.
;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
(assert (equalp (list (testgf07 5.0) (testgf07 17))
'((number real) #(number real integer))))
-#|
(defclass nonumber-generic-function (standard-generic-function)
()
(:metaclass funcallable-standard-class))
(assert (equalp (list (testgf08 5.0) (testgf08 17))
'((real) #(integer real))))
-|#
;;;; more information.
;;; This file contains tests for COMPUTE-DISCRIMINATING-FUNCTION on
-;;; subclasses of generic functions. However, at present it is
-;;; impossible to have more than one of these in the same image,
-;;; because of a vicious metacircle. Once the vicious metacircle is
-;;; dealt with, uncomment the test cases.
+;;; subclasses of generic functions.
(defpackage "MOP-4"
(:use "CL" "SB-MOP"))
(assert (= (foo 5) 11))
-#|
-
;;; from PCL sources
-(defmethod compute-discriminating-function ((gf my-generic-function))
+(defclass my-generic-function-pcl1 (standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+
+(defmethod compute-discriminating-function ((gf my-generic-function-pcl1))
(let ((std (call-next-method)))
(lambda (arg)
(print (list 'call-to-gf gf arg))
(funcall std arg))))
-and
+(defgeneric pcl1 (x)
+ (:generic-function-class my-generic-function-pcl1))
-(defmethod compute-discriminating-function ((gf my-generic-function))
+(defmethod pcl1 ((x integer)) (1+ x))
+
+(let ((output (with-output-to-string (*standard-output*)
+ (pcl1 3))))
+ (assert (search "(CALL-TO-GF #<MY-GENERIC-FUNCTION-PCL1 PCL1 (1)> 3)" output)))
+
+#|
+(defclass my-generic-function-pcl2 (standard-generic-function) ()
+ (:metaclass funcallable-standard-class))
+(defmethod compute-discriminating-function ((gf my-generic-function-pcl2))
(lambda (arg)
(cond (<some condition>
<store some info in the generic function>
(funcall gf arg))
(t
<call-a-method-of-gf>))))
-
|#
-#|
-
;;; from clisp's test suite
(progn
(defclass traced-generic-function (standard-generic-function)
()
- (:metaclass clos:funcallable-standard-class))
+ (:metaclass funcallable-standard-class))
(defvar *last-traced-arguments* nil)
(defvar *last-traced-values* nil)
- (defmethod clos:compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method))
- (name (clos:generic-function-name gf)))
+ (defmethod compute-discriminating-function ((gf traced-generic-function)) (let ((orig-df (call-next-method))
+ (name (generic-function-name gf)))
#'(lambda (&rest arguments)
- (declare (compile))
(format *trace-output* "~%=> ~S arguments: ~:S" name arguments)
(setq *last-traced-arguments* arguments)
(let ((values (multiple-value-list (apply orig-df arguments))))
(defgeneric testgf15 (x) (:generic-function-class traced-generic-function)
(:method ((x number)) (values x (- x) (* x x) (/ x))))
(testgf15 5)
- (list *last-traced-arguments* *last-traced-values*))
+ (assert (equal (list *last-traced-arguments* *last-traced-values*)
+ '((5) (5 -5 25 1/5)))))
;;; also we might be in a position to run the "application example"
;;; from mop.tst in clisp's test suite
-
-|#
--- /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.
+
+;;; This file contains the simplest test that the multiple subclasses
+;;; of generic function metacircle is gone.
+
+(defpackage "MOP-7"
+ (:use "CL" "SB-MOP" "TEST-UTIL"))
+
+(in-package "MOP-7")
+
+(defclass g1 (standard-generic-function)
+ ()
+ (:metaclass funcallable-standard-class))
+(defclass g2 (standard-generic-function)
+ ()
+ (:metaclass funcallable-standard-class))
+
+(defgeneric f1 ()
+ (:generic-function-class g1))
+(defgeneric f2 ()
+ (:generic-function-class g2))
+
+(print #'f1)
+(print #'f2)
;;; 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.6.10"
+"0.9.6.11"
projects / sbcl.git / commitdiff