1 ;;;; pcl-patch.lisp --- Hot-patch for SBCL's PCL variant.
3 ;;;; Copyright (C) 2014 Jan Moringen
5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
7 (cl:in-package #:sb-pcl)
9 ;;; `make-method-lambda-using-specializers'
11 (export '(make-method-lambda-using-specializers))
13 (defgeneric make-method-lambda-using-specializers (gf method qualifiers specializers method-lambda env)
14 (:method ((gf standard-generic-function) (method standard-method) qualifiers specializers method-lambda env)
15 (declare (type (cons (eql lambda) (cons list)) method-lambda))
16 ;; Default behavior: delegate to MAKE-METHOD-LAMBDA.
17 (let* ((lambda-list (second method-lambda))
18 (*method-lambda-list* (append
19 (mapcar #'list (subseq lambda-list 0 (length specializers)) specializers)
20 (subseq lambda-list (length specializers)))))
21 (make-method-lambda gf method method-lambda env)))
26 2. initargs for the method instance
27 3. a (possibly modified) method lambda-list or nil"))
29 (defun expand-defmethod (name
36 (multiple-value-bind (parameters unspecialized-lambda-list specializers)
37 (parse-specialized-lambda-list lambda-list)
38 (declare (ignore parameters))
39 (let ((*method-name* `(,name ,@qualifiers ,specializers))
40 (method-lambda `(lambda ,unspecialized-lambda-list ,@body)))
41 (multiple-value-bind (method-function-lambda initargs new-lambda-list)
42 (make-method-lambda-using-specializers
43 proto-gf proto-method qualifiers specializers method-lambda env)
44 (let ((initargs-form (make-method-initargs-form
45 proto-gf proto-method method-function-lambda
47 (specializers-form (make-method-specializers-form
48 proto-gf proto-method specializers env)))
50 ;; Note: We could DECLAIM the ftype of the generic function
51 ;; here, since ANSI specifies that we create it if it does
52 ;; not exist. However, I chose not to, because I think it's
53 ;; more useful to support a style of programming where every
54 ;; generic function has an explicit DEFGENERIC and any typos
55 ;; in DEFMETHODs are warned about. Otherwise
57 ;; (DEFGENERIC FOO-BAR-BLETCH (X))
58 ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
59 ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
60 ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
61 ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
62 ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
64 ;; compiles without raising an error and runs without
65 ;; raising an error (since SIMPLE-VECTOR cases fall through
66 ;; to VECTOR) but still doesn't do what was intended. I hate
67 ;; that kind of bug (code which silently gives the wrong
68 ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
69 ,(make-defmethod-form name qualifiers specializers-form
70 (or new-lambda-list unspecialized-lambda-list)
72 (class-name (class-of proto-method))
76 ;;; `make-specializer-form-using-class'
78 ;;; To free every new custom generic function class from having to
79 ;;; implement iteration over specializers in
80 ;;; `make-method-specializers-form', we provide a default method
82 ;;; make-method-specializers-form standard-g-f standard-method
84 ;;; which performs this iteration and calls the new generic function
86 ;;; make-specializer-form-using-class proto-g-f proto-m specializer-names env
88 ;;; on which custom generic function classes can install methods to
89 ;;; handle their custom specializers. The generic function uses OR
90 ;;; method combination to allow the following idiom:
92 ;;; (defmethod make-specializer-form-using-class or
93 ;;; (proto-generic-function MY-GENERIC-FUNCTION)
94 ;;; (proto-method standard-method)
95 ;;; (specializer-name cons)
97 ;;; (when (typep specializer-name '(cons (eql MY-SPECIALIZER)))
98 ;;; MY-SPECIALIZER-FORM))
100 ;;; The OR method combination lets everything but (my-specializer …)
101 ;;; fall through to the next methods which will, at some point, handle
102 ;;; class and eql specializers and eventually reach an error signaling
103 ;;; method for invalid specializers.
105 ;; TODO same approach for parse-specializer-using-class?
106 (defgeneric make-specializer-form-using-class (proto-generic-function proto-method specializer-name environment)
107 (:method-combination or)
110 "Return a form which, when evaluated in lexical environment
111 ENVIRONMENT, parses the specializer SPECIALIZER-NAME and returns
112 the appropriate specializer object.
114 Both PROTO-GENERIC-FUNCTION and PROTO-METHOD may be
115 uninitialized. However their types and prototype can be
118 ;; Default behavior is signaling an error for not otherwise handled
120 (defmethod make-specializer-form-using-class or
121 ((proto-generic-function standard-generic-function)
122 (proto-method standard-method)
125 (error 'simple-reference-error
127 "~@<~S is not a valid parameter specializer name.~@:>"
128 :format-arguments (list specializer-name)
129 :references (list '(:ansi-cl :macro defmethod)
130 '(:ansi-cl :glossary "parameter specializer name"))))
132 (defmethod make-specializer-form-using-class or
133 ((proto-generic-function standard-generic-function)
134 (proto-method standard-method)
135 (specializer-name symbol)
137 `(find-class ',specializer-name))
139 (defmethod make-specializer-form-using-class or
140 ((proto-generic-function standard-generic-function)
141 (proto-method standard-method)
142 (specializer-name cons)
144 ;; In case of unknown specializer or known specializer with syntax
145 ;; error, TYPECASE may fall through to default method with error
147 (typecase specializer-name
148 ((cons (eql eql) (cons t null))
149 `(intern-eql-specializer ,(second specializer-name)))
150 ((cons (eql class-eq) (cons t null))
151 `(class-eq-specializer (find-class ',(second specializer-name))))))
153 (defmethod make-method-specializers-form
154 ((proto-generic-function standard-generic-function)
155 (proto-method standard-method)
156 (specializer-names t)
158 (flet ((make-parse-form (name)
159 (make-specializer-form-using-class
160 proto-generic-function proto-method name environment)))
161 `(list ,@(mapcar #'make-parse-form specializer-names))))