X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=src%2Fpcl-patch.lisp;fp=src%2Fpcl-patch.lisp;h=dbb4add6852b622153d6750cd218700242ece967;hp=0000000000000000000000000000000000000000;hb=149a7b3d9c1eceaeddad8404137383545ac044e8;hpb=9dd8f1378407cae8ec7b6b05a8b3c152bc4a5f9b diff --git a/src/pcl-patch.lisp b/src/pcl-patch.lisp new file mode 100644 index 0000000..dbb4add --- /dev/null +++ b/src/pcl-patch.lisp @@ -0,0 +1,161 @@ +;;;; pcl-patch.lisp --- Hot-patch for SBCL's PCL variant. +;;;; +;;;; Copyright (C) 2014 Jan Moringen +;;;; +;;;; Author: Jan Moringen + +(cl:in-package #:sb-pcl) + +;;; `make-method-lambda-using-specializers' + +(export '(make-method-lambda-using-specializers)) + +(defgeneric make-method-lambda-using-specializers (gf method qualifiers specializers method-lambda env) + (:method ((gf standard-generic-function) (method standard-method) qualifiers specializers method-lambda env) + (declare (type (cons (eql lambda) (cons list)) method-lambda)) + ;; Default behavior: delegate to MAKE-METHOD-LAMBDA. + (let* ((lambda-list (second method-lambda)) + (*method-lambda-list* (append + (mapcar #'list (subseq lambda-list 0 (length specializers)) specializers) + (subseq lambda-list (length specializers))))) + (make-method-lambda gf method method-lambda env))) + (:documentation + "TODO +return three values: +1. the method lambda +2. initargs for the method instance +3. a (possibly modified) method lambda-list or nil")) + +(defun expand-defmethod (name + proto-gf + proto-method + qualifiers + lambda-list + body + env) + (multiple-value-bind (parameters unspecialized-lambda-list specializers) + (parse-specialized-lambda-list lambda-list) + (declare (ignore parameters)) + (let ((*method-name* `(,name ,@qualifiers ,specializers)) + (method-lambda `(lambda ,unspecialized-lambda-list ,@body))) + (multiple-value-bind (method-function-lambda initargs new-lambda-list) + (make-method-lambda-using-specializers + proto-gf proto-method qualifiers specializers method-lambda env) + (let ((initargs-form (make-method-initargs-form + proto-gf proto-method method-function-lambda + initargs env)) + (specializers-form (make-method-specializers-form + proto-gf proto-method specializers env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH (X)) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers-form + (or new-lambda-list unspecialized-lambda-list) + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form))))))) + +;;; `make-specializer-form-using-class' +;;; +;;; To free every new custom generic function class from having to +;;; implement iteration over specializers in +;;; `make-method-specializers-form', we provide a default method +;;; +;;; make-method-specializers-form standard-g-f standard-method +;;; +;;; which performs this iteration and calls the new generic function +;;; +;;; make-specializer-form-using-class proto-g-f proto-m specializer-names env +;;; +;;; on which custom generic function classes can install methods to +;;; handle their custom specializers. The generic function uses OR +;;; method combination to allow the following idiom: +;;; +;;; (defmethod make-specializer-form-using-class or +;;; (proto-generic-function MY-GENERIC-FUNCTION) +;;; (proto-method standard-method) +;;; (specializer-name cons) +;;; (environment t)) +;;; (when (typep specializer-name '(cons (eql MY-SPECIALIZER))) +;;; MY-SPECIALIZER-FORM)) +;;; +;;; The OR method combination lets everything but (my-specializer …) +;;; fall through to the next methods which will, at some point, handle +;;; class and eql specializers and eventually reach an error signaling +;;; method for invalid specializers. + +;; TODO same approach for parse-specializer-using-class? +(defgeneric make-specializer-form-using-class (proto-generic-function proto-method specializer-name environment) + (:method-combination or) + #+sb-doc + (:documentation + "Return a form which, when evaluated in lexical environment + ENVIRONMENT, parses the specializer SPECIALIZER-NAME and returns + the appropriate specializer object. + + Both PROTO-GENERIC-FUNCTION and PROTO-METHOD may be + uninitialized. However their types and prototype can be + inspected.")) + +;; Default behavior is signaling an error for not otherwise handled +;; specializers. +(defmethod make-specializer-form-using-class or + ((proto-generic-function standard-generic-function) + (proto-method standard-method) + (specializer-name t) + (environment t)) + (error 'simple-reference-error + :format-control + "~@<~S is not a valid parameter specializer name.~@:>" + :format-arguments (list specializer-name) + :references (list '(:ansi-cl :macro defmethod) + '(:ansi-cl :glossary "parameter specializer name")))) + +(defmethod make-specializer-form-using-class or + ((proto-generic-function standard-generic-function) + (proto-method standard-method) + (specializer-name symbol) + (environment t)) + `(find-class ',specializer-name)) + +(defmethod make-specializer-form-using-class or + ((proto-generic-function standard-generic-function) + (proto-method standard-method) + (specializer-name cons) + (environment t)) + ;; In case of unknown specializer or known specializer with syntax + ;; error, TYPECASE may fall through to default method with error + ;; signaling. + (typecase specializer-name + ((cons (eql eql) (cons t null)) + `(intern-eql-specializer ,(second specializer-name))) + ((cons (eql class-eq) (cons t null)) + `(class-eq-specializer (find-class ',(second specializer-name)))))) + +(defmethod make-method-specializers-form + ((proto-generic-function standard-generic-function) + (proto-method standard-method) + (specializer-names t) + (environment t)) + (flet ((make-parse-form (name) + (make-specializer-form-using-class + proto-generic-function proto-method name environment))) + `(list ,@(mapcar #'make-parse-form specializer-names))))