0.9.3.14:

[sbcl.git] / tests / mop-3.impure-cload.lisp

diff --git a/tests/mop-3.impure-cload.lisp b/tests/mop-3.impure-cload.lisp
new file mode 100644 (file)
index 0000000..173ba20
--- /dev/null
+++ b/tests/mop-3.impure-cload.lisp
@@ -0,0 +1,94 @@
+;;;; 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 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.
+
+;;; tests from Bruno Haible (sbcl-devel 2004-08-02)
+
+(defpackage "MOP-3"
+  (:use "CL" "SB-MOP"))
+
+(in-package "MOP-3")
+
+(defclass msl-generic-function (standard-generic-function)
+  ()
+  (:metaclass funcallable-standard-class))
+
+(defun reverse-method-list (methods)
+  (let ((result '()))
+    (dolist (method methods)
+      (if (and (consp result)
+               (equal (method-qualifiers method) 
+                      (method-qualifiers (caar result))))
+          (push method (car result))
+          (push (list method) result)))
+    (reduce #'append result)))
+
+(defmethod compute-applicable-methods ((gf msl-generic-function) arguments)
+  (reverse-method-list (call-next-method)))
+(defmethod compute-applicable-methods-using-classes 
+    ((gf msl-generic-function) classes)
+  (reverse-method-list (call-next-method)))
+
+(defgeneric testgf07 (x) 
+  (:generic-function-class msl-generic-function)
+  (:method ((x integer)) 
+    (cons 'integer (if (next-method-p) (call-next-method))))
+  (:method ((x real)) 
+    (cons 'real (if (next-method-p) (call-next-method))))
+  (:method ((x number)) 
+    (cons 'number (if (next-method-p) (call-next-method))))
+  (:method :around ((x integer)) 
+    (coerce (call-next-method) 'vector)))
+
+(assert (equalp (list (testgf07 5.0) (testgf07 17))
+                '((number real) #(number real integer))))
+
+#|
+(defclass nonumber-generic-function (standard-generic-function)
+  ()
+  (:metaclass funcallable-standard-class))
+
+(defun nonumber-method-list (methods)
+  (remove-if #'(lambda (method)
+                 (member (find-class 'number)
+                         (sb-pcl:method-specializers method)))
+             methods))
+
+(defmethod compute-applicable-methods 
+    ((gf nonumber-generic-function) arguments)
+  (nonumber-method-list (call-next-method)))
+(defmethod compute-applicable-methods-using-classes 
+    ((gf nonumber-generic-function) classes)
+  (nonumber-method-list (call-next-method)))
+
+(defgeneric testgf08 (x) 
+  (:generic-function-class nonumber-generic-function)
+  (:method ((x integer)) 
+    (cons 'integer (if (next-method-p) (call-next-method))))
+  (:method ((x real)) 
+    (cons 'real (if (next-method-p) (call-next-method))))
+  (:method ((x number)) 
+    (cons 'number (if (next-method-p) (call-next-method))))
+  (:method :around ((x integer)) 
+    (coerce (call-next-method) 'vector)))
+
+(assert (equalp (list (testgf08 5.0) (testgf08 17))
+                '((real) #(integer real))))
+|#
+
+(sb-ext:quit :unix-status 104)