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   #+sb-doc
  23   (:documentation
  24    "TODO
  25 return three values:
  26 1. the method lambda
  27 2. initargs for the method instance
  28 3. a (possibly modified) method lambda-list or nil"))
  29
  30 (defun expand-defmethod (name
  31                          proto-gf
  32                          proto-method
  33                          qualifiers
  34                          lambda-list
  35                          body
  36                          env)
  37   (multiple-value-bind (parameters unspecialized-lambda-list specializers)
  38       (parse-specialized-lambda-list lambda-list)
  39     (declare (ignore parameters))
  40     (let ((*method-name* `(,name ,@qualifiers ,specializers))
  41           (method-lambda `(lambda ,unspecialized-lambda-list ,@body)))
  42       (multiple-value-bind (method-function-lambda initargs new-lambda-list)
  43           (make-method-lambda-using-specializers
  44            proto-gf proto-method qualifiers specializers method-lambda env)
  45         (let ((initargs-form (make-method-initargs-form
  46                               proto-gf proto-method method-function-lambda
  47                               initargs env))
  48               (specializers-form (make-method-specializers-form
  49                                   proto-gf proto-method specializers env)))
  50           `(progn
  51              ;; Note: We could DECLAIM the ftype of the generic function
  52              ;; here, since ANSI specifies that we create it if it does
  53              ;; not exist. However, I chose not to, because I think it's
  54              ;; more useful to support a style of programming where every
  55              ;; generic function has an explicit DEFGENERIC and any typos
  56              ;; in DEFMETHODs are warned about. Otherwise
  57              ;;
  58              ;;   (DEFGENERIC FOO-BAR-BLETCH (X))
  59              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
  60              ;;   (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
  61              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
  62              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
  63              ;;   (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
  64              ;;
  65              ;; compiles without raising an error and runs without
  66              ;; raising an error (since SIMPLE-VECTOR cases fall through
  67              ;; to VECTOR) but still doesn't do what was intended. I hate
  68              ;; that kind of bug (code which silently gives the wrong
  69              ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
  70              ,(make-defmethod-form name qualifiers specializers-form
  71                                    (or new-lambda-list unspecialized-lambda-list)
  72                                    (if proto-method
  73                                        (class-name (class-of proto-method))
  74                                        'standard-method)
  75                                    initargs-form)))))))