tests/mop-21.impure-cload.lisp

   1 ;;;; miscellaneous side-effectful tests of the MOP
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; Pascal Costanza's implementation of beta methods, lightly
  15 ;;; modified.  Contains a specialization of MAKE-METHOD-LAMBDA.
  16
  17 (defclass beta-generic-function (standard-generic-function)
  18   ()
  19   (:metaclass sb-mop:funcallable-standard-class))
  20
  21 (defclass beta-method (standard-method)
  22   ((betap :reader betap :initarg :betap :initform nil)))
  23
  24 (defmethod initialize-instance :around
  25     ((method beta-method) &rest initargs &key qualifiers)
  26   (declare (dynamic-extent initargs))
  27   (if (equal qualifiers '(:beta))
  28       (apply #'call-next-method method
  29              :qualifiers ()
  30              :betap t
  31              initargs)
  32       (call-next-method)))
  33
  34 (defun collect-runs (methods)
  35   (let ((complete-runs nil)
  36         (current-run nil))
  37     (flet ((complete-run ()
  38              (when current-run
  39                (push (nreverse current-run) complete-runs)
  40                (setf current-run nil))))
  41       (loop for method in methods with seen-beta = nil do
  42             (when (betap method)
  43               (if seen-beta
  44                   (complete-run)
  45                   (setq seen-beta t current-run nil)))
  46             (push method current-run))
  47       (complete-run))
  48     complete-runs))
  49
  50 (define-method-combination beta ()
  51   ((around (:around))
  52    (before (:before))
  53    (primary () :required t)
  54    (after (:after)))
  55   (flet ((call-methods (methods)
  56            (mapcar (lambda (method) `(call-method ,method)) methods)))
  57     (let ((form (if (or before after (rest primary))
  58                   (let ((runs (collect-runs primary)))
  59                     `(multiple-value-prog1
  60                          (progn
  61                            ,@(call-methods before)
  62                            (call-method ,(first (first runs))
  63                                         ,(rest (first runs))
  64                                         ,(rest runs)))
  65                       ,@(call-methods (reverse after))))
  66                   `(call-method ,(first primary)))))
  67       (if around
  68           `(call-method ,(first around) (,@(rest around) (make-method ,form)))
  69           form))))
  70
  71 (defmethod sb-mop:make-method-lambda
  72     ((gf beta-generic-function) method-prototype lambda-expression environment)
  73   (declare (ignore method-prototype environment))
  74   (let ((method-args (gensym))
  75         (next-methods (gensym))
  76         (inner-runs (gensym)))
  77     `(lambda (,method-args &optional ,next-methods ,inner-runs)
  78        (declare (ignorable ,next-methods ,inner-runs))
  79        (flet ((call-next-method (&rest args)
  80                 (declare (dynamic-extent args))
  81                 (if (null ,next-methods)
  82                     (error "There is no next method for ~S." ,gf)
  83                     (funcall (sb-mop:method-function (car ,next-methods))
  84                              (if args args ,method-args)
  85                              (cdr ,next-methods)
  86                              ,inner-runs)))
  87               (next-method-p () (not (null ,next-methods)))
  88               (call-inner-method (&rest args)
  89                 (declare (dynamic-extent args))
  90                 (if (null ,inner-runs)
  91                     (error "There is no inner method for ~S." ,gf)
  92                     (funcall (sb-mop:method-function (caar ,inner-runs))
  93                              (if args args ,method-args)
  94                              (cdar ,inner-runs)
  95                              (cdr ,inner-runs))))
  96               (inner-method-p () (not (null ,inner-runs))))
  97          (declare (ignorable #'call-next-method #'next-method-p
  98                              #'call-inner-method #'inner-method-p))
  99          (apply ,lambda-expression ,method-args)))))
 100
 101 (defmacro define-beta-function (name (&rest args) &rest options)
 102   `(defgeneric ,name ,args
 103      ,@(unless (member :generic-function-class options :key #'car)
 104          '((:generic-function-class beta-generic-function)))
 105      ,@(unless (member :method-class options :key #'car)
 106          '((:method-class beta-method)))
 107      ,@(unless (member :method-combination options :key #'car)
 108          '((:method-combination beta)))
 109      ,@options))
 110 \f
 111 (defclass top () ())
 112 (defclass middle (top) ())
 113 (defclass bottom (middle) ())
 114
 115 (define-beta-function test (object))
 116
 117 ;;; MAKE-METHOD-LAMBDA acts at (DEFMETHOD-)expand-time, which is
 118 ;;; before DEFCLASS- and DEFGENERIC-load-time.
 119 (mapcar #'eval
 120         (list
 121          '(defmethod test ((object top))
 122            (declare (ignore object))
 123            'top)
 124          '(defmethod test :beta ((object middle))
 125            (declare (ignore object))
 126            (list 'middle (call-inner-method) (call-next-method)))
 127          '(defmethod test :beta ((object bottom))
 128            (declare (ignore object))
 129            'bottom)))
 130
 131 (with-test (:name (:mop-21))
 132   (assert (equal '(middle bottom top) (test (make-instance 'bottom))))
 133   (assert (equal 'top (test (make-instance 'top))))
 134   (assert (null (ignore-errors (test (make-instance 'middle))))))