src/pcl-patch.lisp

   1 ;;;; pcl-patch.lisp --- Hot-patch for SBCL's PCL variant.
   2 ;;;;
   3 ;;;; Copyright (C) 2014 Jan Moringen
   4 ;;;;
   5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
   6
   7 (cl:in-package #:sb-pcl)
   8
   9 ;;; `make-method-lambda-using-specializers'
  10
  11 (export '(make-method-lambda-using-specializers))
  12
  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)))
  22   (:documentation
  23    "TODO
  24 return three values:
  25 1. the method lambda
  26 2. initargs for the method instance
  27 3. a (possibly modified) method lambda-list or nil"))
  28
  29 (defun expand-defmethod (name
  30                          proto-gf
  31                          proto-method
  32                          qualifiers
  33                          lambda-list
  34                          body
  35                          env)
  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
  46                               initargs env))
  47               (specializers-form (make-method-specializers-form
  48                                   proto-gf proto-method specializers env)))
  49           `(progn
  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
  56              ;;
  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)) ..)
  63              ;;
  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)
  71                                    (if proto-method
  72                                        (class-name (class-of proto-method))
  73                                        'standard-method)
  74                                    initargs-form)))))))
  75
  76 ;;; `make-specializer-form-using-class'
  77 ;;;
  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
  81 ;;;
  82 ;;;   make-method-specializers-form standard-g-f standard-method
  83 ;;;
  84 ;;; which performs this iteration and calls the new generic function
  85 ;;;
  86 ;;;   make-specializer-form-using-class proto-g-f proto-m specializer-names env
  87 ;;;
  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:
  91 ;;;
  92 ;;;   (defmethod make-specializer-form-using-class or
  93 ;;;       (proto-generic-function MY-GENERIC-FUNCTION)
  94 ;;;       (proto-method standard-method)
  95 ;;;       (specializer-name cons)
  96 ;;;       (environment t))
  97 ;;;     (when (typep specializer-name '(cons (eql MY-SPECIALIZER)))
  98 ;;;       MY-SPECIALIZER-FORM))
  99 ;;;
 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.
 104
 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)
 108   #+sb-doc
 109   (:documentation
 110    "Return a form which, when evaluated in lexical environment
 111     ENVIRONMENT, parses the specializer SPECIALIZER-NAME and returns
 112     the appropriate specializer object.
 113
 114     Both PROTO-GENERIC-FUNCTION and PROTO-METHOD may be
 115     uninitialized. However their types and prototype can be
 116     inspected."))
 117
 118 ;; Default behavior is signaling an error for not otherwise handled
 119 ;; specializers.
 120 (defmethod make-specializer-form-using-class or
 121     ((proto-generic-function standard-generic-function)
 122      (proto-method standard-method)
 123      (specializer-name t)
 124      (environment t))
 125   (error 'simple-reference-error
 126          :format-control
 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"))))
 131
 132 (defmethod make-specializer-form-using-class or
 133     ((proto-generic-function standard-generic-function)
 134      (proto-method standard-method)
 135      (specializer-name symbol)
 136      (environment t))
 137   `(find-class ',specializer-name))
 138
 139 (defmethod make-specializer-form-using-class or
 140     ((proto-generic-function standard-generic-function)
 141      (proto-method standard-method)
 142      (specializer-name cons)
 143      (environment t))
 144   ;; In case of unknown specializer or known specializer with syntax
 145   ;; error, TYPECASE may fall through to default method with error
 146   ;; signaling.
 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))))))
 152
 153 (defmethod make-method-specializers-form
 154     ((proto-generic-function standard-generic-function)
 155      (proto-method standard-method)
 156      (specializer-names t)
 157      (environment 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))))