File: mop-21.impure-cload.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (133 lines) | stat: -rw-r--r-- 5,202 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
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)))))