From 258637fa16b01f57f3015955abf32976b618513f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 9 Aug 2006 15:07:32 +0000 Subject: [PATCH] 0.9.15.18: Add a (lightly-modified) version of Pascal Costanza's implementation of mixed beta/standard method combination (which happens to have a specialized make-method-lambda). --- tests/mop-21.impure-cload.lisp | 133 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 2 files changed, 134 insertions(+), 1 deletion(-) create mode 100644 tests/mop-21.impure-cload.lisp diff --git a/tests/mop-21.impure-cload.lisp b/tests/mop-21.impure-cload.lisp new file mode 100644 index 0000000..16b16a3 --- /dev/null +++ b/tests/mop-21.impure-cload.lisp @@ -0,0 +1,133 @@ +;;;; 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. + +;;; Pascal Costanza's implementation of beta methods, lightly +;;; modified. Contains a specialization of MAKE-METHOD-LAMBDA. + +(defpackage "MOP-21" + (:use "CL" "SB-MOP")) + +(in-package "MOP-21") + +(defclass beta-generic-function (standard-generic-function) + () + (:metaclass funcallable-standard-class)) + +(defclass beta-method (standard-method) + ((betap :reader betap :initarg :betap :initform nil))) + +(defmethod initialize-instance :around + ((method beta-method) &rest initargs &key qualifiers) + (declare (dynamic-extent initargs)) + (if (equal qualifiers '(:beta)) + (apply #'call-next-method method + :qualifiers () + :betap t + initargs) + (call-next-method))) + +(defun collect-runs (methods) + (let ((complete-runs nil) + (current-run nil)) + (flet ((complete-run () + (when current-run + (push (nreverse current-run) complete-runs) + (setf current-run nil)))) + (loop for method in methods with seen-beta = nil do + (when (betap method) + (if seen-beta + (complete-run) + (setq seen-beta t current-run nil))) + (push method current-run)) + (complete-run)) + complete-runs)) + +(define-method-combination beta () + ((around (:around)) + (before (:before)) + (primary () :required t) + (after (:after))) + (flet ((call-methods (methods) + (mapcar (lambda (method) `(call-method ,method)) methods))) + (let ((form (if (or before after (rest primary)) + (let ((runs (collect-runs primary))) + `(multiple-value-prog1 + (progn + ,@(call-methods before) + (call-method ,(first (first runs)) + ,(rest (first runs)) + ,(rest runs))) + ,@(call-methods (reverse after)))) + `(call-method ,(first primary))))) + (if around + `(call-method ,(first around) (,@(rest around) (make-method ,form))) + form)))) + +(defmethod make-method-lambda + ((gf beta-generic-function) method-prototype lambda-expression environment) + (declare (ignore method-prototype environment)) + (let ((method-args (gensym)) + (next-methods (gensym)) + (inner-runs (gensym))) + `(lambda (,method-args &optional ,next-methods ,inner-runs) + (declare (ignorable ,next-methods ,inner-runs)) + (flet ((call-next-method (&rest args) + (declare (dynamic-extent args)) + (if (null ,next-methods) + (error "There is no next method for ~S." ,gf) + (funcall (method-function (car ,next-methods)) + (if args args ,method-args) + (cdr ,next-methods) + ,inner-runs))) + (next-method-p () (not (null ,next-methods))) + (call-inner-method (&rest args) + (declare (dynamic-extent args)) + (if (null ,inner-runs) + (error "There is no inner method for ~S." ,gf) + (funcall (method-function (caar ,inner-runs)) + (if args args ,method-args) + (cdar ,inner-runs) + (cdr ,inner-runs)))) + (inner-method-p () (not (null ,inner-runs)))) + (declare (ignorable #'call-next-method #'next-method-p + #'call-inner-method #'inner-method-p)) + (apply ,lambda-expression ,method-args))))) + +(defmacro define-beta-function (name (&rest args) &rest options) + `(defgeneric ,name ,args + ,@(unless (member :generic-function-class options :key #'car) + '((:generic-function-class beta-generic-function))) + ,@(unless (member :method-class options :key #'car) + '((:method-class beta-method))) + ,@(unless (member :method-combination options :key #'car) + '((:method-combination beta))) + ,@options)) + +(defclass top () ()) +(defclass middle (top) ()) +(defclass bottom (middle) ()) + +(define-beta-function test (object)) + +;;; MAKE-METHOD-LAMBDA acts at (DEFMETHOD-)expand-time, which is +;;; before DEFCLASS- and DEFGENERIC-load-time. +(mapcar #'eval + (list + '(defmethod test ((object top)) 'top) + '(defmethod test :beta ((object middle)) + (list 'middle (call-inner-method) (call-next-method))) + '(defmethod test :beta ((object bottom)) 'bottom))) + +(assert (equal '(middle bottom top) (test (make-instance 'bottom)))) +(assert (equal 'top (test (make-instance 'top)))) +(assert (null (ignore-errors (test (make-instance 'middle))))) diff --git a/version.lisp-expr b/version.lisp-expr index 5309947..1fb05ee 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.17" +"0.9.15.18" -- 1.7.10.4