255 lines
9.6 KiB
Common Lisp
255 lines
9.6 KiB
Common Lisp
;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
|
||
;;;
|
||
;;; *************************************************************************
|
||
;;; Copyright (c) 1991 Venue
|
||
;;; All rights reserved.
|
||
;;; *************************************************************************
|
||
;;;
|
||
|
||
(in-package 'clos)
|
||
|
||
(defun make-effective-method-function (generic-function form)
|
||
(flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
|
||
(if (and (listp form)
|
||
(eq (car form) 'call-method)
|
||
(method-p (cadr form))
|
||
(every #'method-p (caddr form)))
|
||
;;
|
||
;; The effective method is just a call to call-method. This opens up
|
||
;; the possibility of just using the method function of the method as
|
||
;; as the effective method function.
|
||
;;
|
||
;; But we have to be careful. If that method function will ask for
|
||
;; the next methods we have to provide them. We do not look to see
|
||
;; if there are next methods, we look at whether the method function
|
||
;; asks about them. If it does, we must tell it whether there are
|
||
;; or aren't to prevent the leaky next methods bug.
|
||
;;
|
||
(let* ((method-function (method-function (cadr form)))
|
||
(arg-info (gf-arg-info generic-function))
|
||
(metatypes (arg-info-metatypes arg-info))
|
||
(applyp (arg-info-applyp arg-info)))
|
||
(if (not (method-function-needs-next-methods-p method-function))
|
||
method-function
|
||
(let ((next-method-functions (mapcar #'method-function (caddr form))))
|
||
(name-function
|
||
(get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
|
||
(let ((*next-methods* .next-method-functions.))
|
||
,(make-dfun-call metatypes applyp '.method-function.)))
|
||
#'default-test-converter ;This could be optimized by making
|
||
;the interface from here to the
|
||
;walker more clear so that the
|
||
;form wouldn't get walked at all.
|
||
#'(lambda (form)
|
||
(if (memq form '(.next-method-functions. .method-function.))
|
||
(values form (list form))
|
||
form))
|
||
#'(lambda (form)
|
||
(cond ((eq form '.next-method-functions.)
|
||
(list next-method-functions))
|
||
((eq form '.method-function.)
|
||
(list method-function)))))))))
|
||
;;
|
||
;; We have some sort of `real' effective method. Go off and get a
|
||
;; compiled function for it. Most of the real hair here is done by
|
||
;; the GET-FUNCTION mechanism.
|
||
;;
|
||
(name-function (make-effective-method-function-internal generic-function form)))))
|
||
|
||
(defvar *global-effective-method-gensyms* ())
|
||
(defvar *rebound-effective-method-gensyms*)
|
||
|
||
(defun get-effective-method-gensym ()
|
||
(or (pop *rebound-effective-method-gensyms*)
|
||
(let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
|
||
(push new *global-effective-method-gensyms*)
|
||
new)))
|
||
|
||
(eval-when (load)
|
||
(let ((*rebound-effective-method-gensyms* ()))
|
||
(dotimes (i 10) (get-effective-method-gensym))))
|
||
|
||
(defun make-effective-method-function-internal (generic-function effective-method)
|
||
(let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
|
||
(arg-info (gf-arg-info generic-function))
|
||
(metatypes (arg-info-metatypes arg-info))
|
||
(applyp (arg-info-applyp arg-info)))
|
||
(labels ((test-converter (form)
|
||
(if (and (consp form) (eq (car form) 'call-method))
|
||
'.call-method.
|
||
(default-test-converter form)))
|
||
(code-converter (form)
|
||
(if (and (consp form) (eq (car form) 'call-method))
|
||
;;
|
||
;; We have a `call' to CALL-METHOD. There may or may not be next methods
|
||
;; and the two cases are a little different. It controls how many gensyms
|
||
;; we will generate.
|
||
;;
|
||
(let ((gensyms
|
||
(if (cddr form)
|
||
(list (get-effective-method-gensym)
|
||
(get-effective-method-gensym))
|
||
(list (get-effective-method-gensym)
|
||
()))))
|
||
(values `(let ((*next-methods* ,(cadr gensyms)))
|
||
,(make-dfun-call metatypes applyp (car gensyms)))
|
||
gensyms))
|
||
(default-code-converter form)))
|
||
(constant-converter (form)
|
||
(if (and (consp form) (eq (car form) 'call-method))
|
||
(if (cddr form)
|
||
(list (check-for-make-method (cadr form))
|
||
(mapcar #'check-for-make-method (caddr form)))
|
||
(list (check-for-make-method (cadr form))
|
||
()))
|
||
(default-constant-converter form)))
|
||
(check-for-make-method (effective-method)
|
||
(cond ((method-p effective-method)
|
||
(method-function effective-method))
|
||
((and (listp effective-method)
|
||
(eq (car effective-method) 'make-method))
|
||
(make-effective-method-function generic-function
|
||
(make-progn (cadr effective-method))))
|
||
(t
|
||
(error "Effective-method form is malformed.")))))
|
||
(get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
|
||
#'test-converter
|
||
#'code-converter
|
||
#'constant-converter))))
|
||
|
||
|
||
|
||
(defvar *invalid-method-error*
|
||
#'(lambda (&rest args)
|
||
(declare (ignore args))
|
||
(error
|
||
"INVALID-METHOD-ERROR was called outside the dynamic scope~%~
|
||
of a method combination function (inside the body of~%~
|
||
DEFINE-METHOD-COMBINATION or a method on the generic~%~
|
||
function COMPUTE-EFFECTIVE-METHOD).")))
|
||
|
||
(defvar *method-combination-error*
|
||
#'(lambda (&rest args)
|
||
(declare (ignore args))
|
||
(error
|
||
"METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
|
||
of a method combination function (inside the body of~%~
|
||
DEFINE-METHOD-COMBINATION or a method on the generic~%~
|
||
function COMPUTE-EFFECTIVE-METHOD).")))
|
||
|
||
;(defmethod compute-effective-method :around ;issue with magic
|
||
; ((generic-function generic-function) ;generic functions
|
||
; (method-combination method-combination)
|
||
; applicable-methods)
|
||
; (declare (ignore applicable-methods))
|
||
; (flet ((real-invalid-method-error (method format-string &rest args)
|
||
; (declare (ignore method))
|
||
; (apply #'error format-string args))
|
||
; (real-method-combination-error (format-string &rest args)
|
||
; (apply #'error format-string args)))
|
||
; (let ((*invalid-method-error* #'real-invalid-method-error)
|
||
; (*method-combination-error* #'real-method-combination-error))
|
||
; (call-next-method))))
|
||
|
||
(defun invalid-method-error (&rest args)
|
||
(declare (arglist method format-string &rest format-arguments))
|
||
(apply *invalid-method-error* args))
|
||
|
||
(defun method-combination-error (&rest args)
|
||
(declare (arglist format-string &rest format-arguments))
|
||
(apply *method-combination-error* args))
|
||
|
||
|
||
|
||
;;;
|
||
;;; The STANDARD method combination type. This is coded by hand (rather than
|
||
;;; with define-method-combination) for bootstrapping and efficiency reasons.
|
||
;;; Note that the definition of the find-method-combination-method appears in
|
||
;;; the file defcombin.lisp, this is because EQL methods can't appear in the
|
||
;;; bootstrap.
|
||
;;;
|
||
;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
|
||
;;; classes has to appear here for this reason. This code must conform to
|
||
;;; the code in the file defcombin, look there for more details.
|
||
;;;
|
||
|
||
(defclass method-combination () ())
|
||
|
||
(define-gf-predicate method-combination-p method-combination)
|
||
|
||
(defclass standard-method-combination
|
||
(definition-source-mixin method-combination)
|
||
((type :reader method-combination-type
|
||
:initarg :type)
|
||
(documentation :reader method-combination-documentation
|
||
:initarg :documentation)
|
||
(options :reader method-combination-options
|
||
:initarg :options)))
|
||
|
||
(defmethod print-object ((mc method-combination) stream)
|
||
(printing-random-thing (mc stream)
|
||
(format stream
|
||
"Method-Combination ~S ~S"
|
||
(method-combination-type mc)
|
||
(method-combination-options mc))))
|
||
|
||
(eval-when (load eval)
|
||
(setq *standard-method-combination*
|
||
(make-instance 'standard-method-combination
|
||
:type 'standard
|
||
:documentation "The standard method combination."
|
||
:options ())))
|
||
|
||
;This definition appears in defcombin.lisp.
|
||
;
|
||
;(defmethod find-method-combination ((generic-function generic-function)
|
||
; (type (eql 'standard))
|
||
; options)
|
||
; (when options
|
||
; (method-combination-error
|
||
; "The method combination type STANDARD accepts no options."))
|
||
; *standard-method-combination*)
|
||
|
||
(defun make-call-methods (methods)
|
||
(mapcar #'(lambda (method) `(call-method ,method ())) methods))
|
||
|
||
(defmethod compute-effective-method ((generic-function generic-function)
|
||
(combin standard-method-combination)
|
||
applicable-methods)
|
||
(let ((before ())
|
||
(primary ())
|
||
(after ())
|
||
(around ()))
|
||
(dolist (m applicable-methods)
|
||
(let ((qualifiers (method-qualifiers m)))
|
||
(cond ((member ':before qualifiers) (push m before))
|
||
((member ':after qualifiers) (push m after))
|
||
((member ':around qualifiers) (push m around))
|
||
(t
|
||
(push m primary)))))
|
||
(setq before (reverse before)
|
||
after (reverse after)
|
||
primary (reverse primary)
|
||
around (reverse around))
|
||
(cond ((null primary)
|
||
`(error "No primary method for the generic function ~S." ',generic-function))
|
||
((and (null before) (null after) (null around))
|
||
;;
|
||
;; By returning a single call-method `form' here we enable an important
|
||
;; implementation-specific optimization.
|
||
;;
|
||
`(call-method ,(first primary) ,(rest primary)))
|
||
(t
|
||
(let ((main-effective-method
|
||
(if (or before after (rest primary))
|
||
`(multiple-value-prog1
|
||
(progn ,@(make-call-methods before)
|
||
(call-method ,(first primary) ,(rest primary)))
|
||
,@(make-call-methods (reverse after)))
|
||
`(call-method ,(first primary) ()))))
|
||
(if around
|
||
`(call-method ,(first around)
|
||
(,@(rest around) (make-method ,main-effective-method)))
|
||
main-effective-method))))))
|
||
|