src/code/early-defmethod.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!PCL")
  11
  12 ;;;; Rudimentary DEFMETHOD
  13
  14 (sb!xc:defmacro defmethod (name lambda-list &rest body &aux qualifier)
  15   (when (keywordp lambda-list)
  16     ;; Allow an :AFTER method in 'condition.lisp'.
  17     ;; It's ignored during cold-init, but eventually takes effect.
  18     (assert (eq lambda-list :after))
  19     (setq qualifier lambda-list lambda-list (pop body)))
  20   (ecase name
  21     (make-load-form
  22      ;; Expect one mandatory class-name and the optional environment.
  23      (assert (typep lambda-list
  24                     '(cons (cons symbol (cons symbol null))
  25                            (cons (eql &optional) (cons symbol null))))))
  26     (print-object
  27      ;; Expect one unqualified mandatory arg and one unqualified.
  28      (assert (typep lambda-list '(cons (cons symbol (cons symbol null))
  29                                        (cons symbol null))))))
  30   (binding* ((specializer (cadar lambda-list)) ; only one allowd
  31              (unspecialized-ll `(,(caar lambda-list) ,@(cdr lambda-list)))
  32              ((forms decls) (parse-body body nil))) ; Note: disallowing docstring
  33     `(!trivial-defmethod
  34       ',name ',specializer ,qualifier ',unspecialized-ll
  35       ;; OAOO problem: compute the same lambda name as real DEFMETHOD would
  36       (named-lambda (fast-method ,name
  37                      (,specializer ,@(if (eq name 'print-object) '(t))))
  38           (.pv. .next-method-call. .arg0. ,@(cdr unspecialized-ll)
  39                 ;; Rebind specialized arg with unchecked type assertion.
  40                 &aux (,(car unspecialized-ll) (truly-the ,specializer .arg0.)))
  41         (declare (ignore .pv. .next-method-call.)
  42                  (ignorable ,(car unspecialized-ll)))
  43         ,@decls
  44         ;; Fail at compile-time if any transformational magic needs to happen.
  45         (macrolet ,(mapcar (lambda (f)
  46                              `(,f (&rest args)
  47                                   (declare (ignore args))
  48                                   (error "can't use ~A in trivial method" ',f)))
  49                            '(slot-boundp slot-value %set-slot-value call-next-method))
  50           (flet (((setf slot-value) (&rest args) `(%set-slot-value ,@args)))
  51             (declare (inline (setf slot-value)))
  52             ,@forms)))
  53       ;; Why is SOURCE-LOC needed? Lambdas should know their location.
  54       (sb!c::source-location))))
  55
  56 (defvar *!trivial-methods* '())
  57 (defun !trivial-defmethod (name specializer qualifier lambda-list lambda source-loc)
  58   (let ((gf (assoc name *!trivial-methods*)))
  59     ;; Append the method but don't bother finding a predicate for it.
  60     ;; Methods occurring in early warm load (notably from SB-FASTEVAL)
  61     ;; wil be properly installed when 'pcl/print-object.lisp' is loaded.
  62     (rplacd gf (concatenate 'vector (cdr gf)
  63                             (list (list nil lambda specializer qualifier
  64                                         lambda-list source-loc))))))
  65
  66 ;;; Slow-but-correct logic for single-dispatch sans method combination,
  67 ;;; allowing exactly one primary method. Methods are sorted most-specific-first,
  68 ;;; so we can stop looking as soon as a match is found.
  69 (defun !call-a-method (gf-name specialized-arg &rest rest)
  70   (let* ((methods (the simple-vector
  71                     (cdr (or (assoc gf-name *!trivial-methods*)
  72                              (error "No methods on ~S" gf-name)))))
  73          (applicable-method
  74           (find specialized-arg methods
  75                 :test (lambda (arg method &aux (guard (car method)))
  76                         (and (or (functionp guard) (fboundp guard))
  77                              (funcall guard arg))))))
  78     (assert applicable-method)
  79     ;; The "method" is a list: (GUARD LAMBDA . OTHER-STUFF)
  80     ;; Call using no permutation-vector / no precomputed next method.
  81     (apply (cadr applicable-method) nil nil specialized-arg rest)))
  82
  83 (defun make-load-form (object &optional environment)
  84   (!call-a-method 'make-load-form object environment))
  85 (defun print-object (object stream)
  86   (!call-a-method 'print-object object stream))
  87
  88 ;;; FIXME: this no longer holds methods, but it seems to have an effect
  89 ;;; on the caching of a discriminating function for PRINT-OBJECT
  90 (defvar *!delayed-defmethod-args* nil)