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 (defpackage "MOP-21"
  18   (:use "CL" "SB-MOP"))
  19
  20 (in-package "MOP-21")
  21
  22 (defclass beta-generic-function (standard-generic-function)
  23   ()
  24   (:metaclass funcallable-standard-class))
  25
  26 (defclass beta-method (standard-method)
  27   ((betap :reader betap :initarg :betap :initform nil)))
  28
  29 (defmethod initialize-instance :around
  30     ((method beta-method) &rest initargs &key qualifiers)
  31   (declare (dynamic-extent initargs))
  32   (if (equal qualifiers '(:beta))
  33       (apply #'call-next-method method
  34              :qualifiers ()
  35              :betap t
  36              initargs)
  37       (call-next-method)))
  38
  39 (defun collect-runs (methods)
  40   (let ((complete-runs nil)
  41         (current-run nil))
  42     (flet ((complete-run ()
  43              (when current-run
  44                (push (nreverse current-run) complete-runs)
  45                (setf current-run nil))))
  46       (loop for method in methods with seen-beta = nil do
  47             (when (betap method)
  48               (if seen-beta
  49                   (complete-run)
  50                   (setq seen-beta t current-run nil)))
  51             (push method current-run))
  52       (complete-run))
  53     complete-runs))
  54
  55 (define-method-combination beta ()
  56   ((around (:around))
  57    (before (:before))
  58    (primary () :required t)
  59    (after (:after)))
  60   (flet ((call-methods (methods)
  61            (mapcar (lambda (method) `(call-method ,method)) methods)))
  62     (let ((form (if (or before after (rest primary))
  63                   (let ((runs (collect-runs primary)))
  64                     `(multiple-value-prog1
  65                          (progn
  66                            ,@(call-methods before)
  67                            (call-method ,(first (first runs))
  68                                         ,(rest (first runs))
  69                                         ,(rest runs)))
  70                       ,@(call-methods (reverse after))))
  71                   `(call-method ,(first primary)))))
  72       (if around
  73           `(call-method ,(first around) (,@(rest around) (make-method ,form)))
  74           form))))
  75
  76 (defmethod make-method-lambda
  77     ((gf beta-generic-function) method-prototype lambda-expression environment)
  78   (declare (ignore method-prototype environment))
  79   (let ((method-args (gensym))
  80         (next-methods (gensym))
  81         (inner-runs (gensym)))
  82     `(lambda (,method-args &optional ,next-methods ,inner-runs)
  83        (declare (ignorable ,next-methods ,inner-runs))
  84        (flet ((call-next-method (&rest args)
  85                 (declare (dynamic-extent args))
  86                 (if (null ,next-methods)
  87                     (error "There is no next method for ~S." ,gf)
  88                     (funcall (method-function (car ,next-methods))
  89                              (if args args ,method-args)
  90                              (cdr ,next-methods)
  91                              ,inner-runs)))
  92               (next-method-p () (not (null ,next-methods)))
  93               (call-inner-method (&rest args)
  94                 (declare (dynamic-extent args))
  95                 (if (null ,inner-runs)
  96                     (error "There is no inner method for ~S." ,gf)
  97                     (funcall (method-function (caar ,inner-runs))
  98                              (if args args ,method-args)
  99                              (cdar ,inner-runs)
 100                              (cdr ,inner-runs))))
 101               (inner-method-p () (not (null ,inner-runs))))
 102          (declare (ignorable #'call-next-method #'next-method-p
 103                              #'call-inner-method #'inner-method-p))
 104          (apply ,lambda-expression ,method-args)))))
 105
 106 (defmacro define-beta-function (name (&rest args) &rest options)
 107   `(defgeneric ,name ,args
 108      ,@(unless (member :generic-function-class options :key #'car)
 109          '((:generic-function-class beta-generic-function)))
 110      ,@(unless (member :method-class options :key #'car)
 111          '((:method-class beta-method)))
 112      ,@(unless (member :method-combination options :key #'car)
 113          '((:method-combination beta)))
 114      ,@options))
 115 \f
 116 (defclass top () ())
 117 (defclass middle (top) ())
 118 (defclass bottom (middle) ())
 119
 120 (define-beta-function test (object))
 121
 122 ;;; MAKE-METHOD-LAMBDA acts at (DEFMETHOD-)expand-time, which is
 123 ;;; before DEFCLASS- and DEFGENERIC-load-time.
 124 (mapcar #'eval
 125         (list
 126          '(defmethod test ((object top)) 'top)
 127          '(defmethod test :beta ((object middle))
 128            (list 'middle (call-inner-method) (call-next-method)))
 129          '(defmethod test :beta ((object bottom)) 'bottom)))
 130
 131 (assert (equal '(middle bottom top) (test (make-instance 'bottom))))
 132 (assert (equal 'top (test (make-instance 'top))))
 133 (assert (null (ignore-errors (test (make-instance 'middle)))))