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)
  15   (ecase name
  16     (make-load-form
  17      ;; Expect one mandatory class-name and the optional environment.
  18      (assert (typep lambda-list
  19                     '(cons (cons symbol (cons symbol null))
  20                            (cons (eql &optional) (cons symbol null))))))
  21     (print-object
  22      ;; Expect one unqualified mandatory arg and one unqualified.
  23      (assert (typep lambda-list '(cons (cons symbol (cons symbol null))
  24                                        (cons symbol null))))))
  25   (binding* ((specializer (cadar lambda-list)) ; only one allowd
  26              (unspecialized-ll `(,(caar lambda-list) ,@(cdr lambda-list)))
  27              ((forms decls) (parse-body body nil))) ; Note: disallowing docstring
  28     `(!trivial-defmethod
  29       ',name ',specializer ',unspecialized-ll
  30       (named-lambda (fast-method ,name (,specializer))
  31           (.pv. .next-method-call. .arg0. ,@(cdr unspecialized-ll)
  32                 ;; Rebind specialized arg with unchecked type assertion.
  33                 &aux (,(car unspecialized-ll) (truly-the ,specializer .arg0.)))
  34         (declare (ignore .pv. .next-method-call.)
  35                  (ignorable ,(car unspecialized-ll)))
  36         ,@decls
  37         ;; Fail at compile-time if any transformational magic needs to happen.
  38         (macrolet ,(mapcar (lambda (f)
  39                              `(,f (&rest args)
  40                                   (declare (ignore args))
  41                                   (error "can't use ~A in trivial method" ',f)))
  42                            '(slot-boundp slot-value %set-slot-value call-next-method))
  43           (flet (((setf slot-value) (&rest args) `(%set-slot-value ,@args)))
  44             (declare (inline (setf slot-value)))
  45             ,@forms)))
  46       ;; Why is SOURCE-LOC needed? Lambdas should know their location.
  47       (sb!c::source-location))))
  48
  49 (defvar *!trivial-methods* '())
  50 (defun !trivial-defmethod (name specializer lambda-list lambda source-loc)
  51   (let ((gf (assoc name *!trivial-methods*)))
  52     (unless gf
  53       (setq gf (cons name #()))
  54       (push gf *!trivial-methods*))
  55     (let ((entry (list specializer lambda-list lambda source-loc)))
  56       (setf (cdr gf)
  57             (merge '(simple-array t (*)) ; SIMPLE-VECTOR not DEFTYPEd yet!
  58                    (list entry) (cdr gf) #'>
  59                    ;; We only use hierarchical objects in self-build,
  60                    ;; so sorting by LAYOUT-DEPTHOID is an accurate indicator
  61                    ;; of what precedes what in the precedence list.
  62                    :key (lambda (x) (layout-depthoid (find-layout (car x))))))
  63       entry)))
  64
  65 ;;; Slow-but-correct logic for single-dispatch sans method combination,
  66 ;;; allowing exactly one primary method. Methods are sorted most-specific-first,
  67 ;;; so we can stop looking as soon as a match is found.
  68 (defun !call-a-method (gf-name specialized-arg &rest rest)
  69   (let* ((methods (the simple-vector
  70                     (cdr (or (assoc gf-name *!trivial-methods*)
  71                              (error "No methods on ~S" gf-name)))))
  72          (applicable-method
  73           ;; First try matching the type name exactly. Failing that, use TYPEP.
  74           (or (find (type-of specialized-arg) methods :key #'car :test #'eq)
  75               (find-if (lambda (x) (typep specialized-arg (car x))) methods))))
  76     (assert applicable-method)
  77     ;; no permutation-vector / no precomputed next method
  78     (apply (third applicable-method) nil nil specialized-arg rest)))
  79
  80 (defun make-load-form (object &optional environment)
  81   (!call-a-method 'make-load-form object environment))
  82 (defun print-object (object stream)
  83   (!call-a-method 'print-object object stream))
  84
  85 ;;; This method gets removed by force-delayed-methods
  86 (defmethod print-object ((self t) stream)
  87   (print-unreadable-object (self stream :type t :identity t)))
  88
  89 ;;;; Complete DEFMETHOD, not usable until CLOS works.
  90
  91 (defvar *!delayed-defmethod-args* nil)
  92 ;;; By our convention, "DEF!METHOD" would imply behavior in both the
  93 ;;; host and target, but this is only for the target, so ...
  94 (defmacro def*method (&rest args)
  95   `(push (cons (sb!c:source-location) ',args) *!delayed-defmethod-args*))