;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation. All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted. Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;; CommonLoops Coordinator
;;; Xerox Artifical Intelligence Systems
;;; 2400 Hanover St.
;;; Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
(in-package 'pcl)
#|
get rid of load-method-1 and friends, replace it with calls to add-method etc.
rename make-method
replace options with qualifiers everywhere
replace specifiers with specializers everywhere
method-class option of gf
hack-method-body option
expand-defmethod and expand-defmethod-setf
(have to make make-specializable'd too!!)
would like to be able to construct lexical environments as part of expand-defmethod-body and expand-defmethod-setf-body.
make-method --->> make-std-method
|#
;;
;;;;;; Methods
;;
(eval-when (compile load eval)
(mapcar #'eval *methods-defclass-forms*))
(defun method-p (x) (typep x 'method))
(defmethod-setf method-function ((method basic-method)) (nv)
(setf (slot-value method 'function) nv)
(let ((gf (method-generic-function method)))
(when gf
(generic-function-changed gf method t))))
;;;
;;; This method has to be defined by hand! Don't try to define it using
;;; :accessor or :reader. It can't be an automatically generated reader
;;; method because that would break the way the special discriminator
;;; code which uses this feature works.
;;;
(defmethod reader/writer-method-slot-name ((m standard-reader/writer-method))
(slot-value--class m 'slot-name))
(defmethod print-object ((method essential-method) stream depth)
(declare (ignore depth))
(printing-random-thing (method stream)
(let ((generic-function (method-generic-function method))
(class-name (capitalize-words (class-name (class-of method)))))
(format stream "~A ~S ~:S"
class-name
(and generic-function (generic-function-name generic-function))
(unparse-specializers method)))))
(defmethod print-object ((generic-function generic-function) stream depth)
(named-object-print-function generic-function stream depth))
(defmethod print-object ((generic-function standard-generic-function)
stream
depth)
(named-object-print-function
generic-function
stream
depth
(list ;(method-combination-type generic-function)
(length (generic-function-methods generic-function)))))
(defun generic-function-p (x) (typep x 'generic-function))
;;;
;;; This is really just for bootstrapping, of course this isn't all
;;; worked out yet. But this SHOULD really just be for bootstrapping.
;;;
(defmethod method-causes-combination-p ((method basic-method))
(declare (ignore method))
())
(defmethod remove-named-method (generic-function-name argument-specifiers
&optional extra)
(let ((generic-function ())
(method ()))
(cond ((or (null (fboundp generic-function-name))
(not (generic-function-p
(setq generic-function
(symbol-function generic-function-name)))))
(error "~S does not name a generic-function."
generic-function-name))
((null (setq method (get-method generic-function
extra
(parse-specializers
argument-specifiers)
nil)))
(error "There is no method for the generic-function ~S~%~
which matches the argument-specifiers ~S."
generic-function
argument-specifiers))
(t
(remove-method generic-function method)))))
(defmethod ADD-METHOD-ON-SPECIALIZER ((method method) specializer)
(specializer-methods specializer
(adjoin method (specializer-methods specializer))))
(defmethod REMOVE-METHOD-ON-SPECIALIZER ((method method) specializer)
(specializer-methods specializer
(delete method (specializer-methods specializer))))
(defvar *individual-specializer-methods* (make-hash-table :test #'eql))
(defun specializer-methods (specializer &optional (new () new-p))
(cond ((classp specializer)
(if new-p
(setf (class-direct-methods specializer) new)
(class-direct-methods specializer)))
((eq specializer 't) ;*** I HATE THIS ***
(if new-p
(specializer-methods (class-named 't) new)
(specializer-methods (class-named 't))))
((and (listp specializer)
(eq (car specializer) 'quote)
(null (cddr specializer)))
(let ((ind (cadr specializer)))
(if new-p
(setf (gethash ind *individual-specializer-methods*) new)
(gethash ind *individual-specializer-methods* ()))))
(t
(error "Internal Error -- don't understand ~S as a specializer."
specializer))))
(defun make-specializable (function-name &key (arglist nil arglistp))
(cond ((not (null arglistp)))
((not (fboundp function-name)))
((fboundp 'function-arglist)
;; function-arglist exists, get the arglist from it.
(setq arglist (function-arglist function-name)))
(t
(error
"The :arglist argument to make-specializable was not supplied~%~
and there is no version of FUNCTION-ARGLIST defined for this~%~
port of Portable CommonLoops.~%~
You must either define a version of FUNCTION-ARGLIST (which~%~
should be easy), and send it off to the Portable CommonLoops~%~
people or you should call make-specializable again with the~%~
:arglist keyword to specify the arglist.")))
(let ((original (and (fboundp function-name)
(symbol-function function-name)))
(generic-function (make-instance 'standard-generic-function
:name function-name)))
(setf (symbol-function function-name) generic-function)
(when arglistp
(setf (generic-function-pretty-arglist generic-function) arglist))
(when original
(add-named-method function-name
()
()
arglist
original))
generic-function))
(defun update-pretty-arglist (generic-function method)
(setf (function-pretty-arglist
(or (generic-function-name generic-function)
(generic-function-discriminating-function generic-function)))
(or (slot-value-using-class (class-of generic-function)
generic-function
'pretty-arglist
t
())
(method-arglist method))))
(defmethod generic-function-pretty-arglist
((generic-function standard-generic-function))
(or (slot-value-using-class (class-of generic-function)
generic-function
'pretty-arglist
t
())
(let ((method (or (generic-function-default-method generic-function)
(car (generic-function-methods generic-function)))))
(and method (method-arglist method)))))
(defmethod get-method (generic-function qualifiers specializers
&optional (errorp t))
(let ((hit (dolist (method (generic-function-methods generic-function))
(when (method-equal method qualifiers specializers)
(return method)))))
(cond (hit hit)
((null errorp) nil)
(t
(error "No method on ~S with qualifiers ~:S and specializers ~:S."
generic-function qualifiers specializers)))))
(defmethod method-equal ((method basic-method) qualifiers specializers)
(and (equal qualifiers (method-options method))
(equal specializers (method-type-specifiers method))))
(defmethod generic-function-default-method
((generic-function generic-function))
(get-method generic-function () () nil))
;;
;;;;;; Generic-Function-Based caching.
;;
;;; Methods are cached in a generic-function-based cache. The cache is an
;;; N-key cache based on the number of specialized arguments the generic
;;; function has. The size of the cache does not change statically or
;;; dynamically. This makes it possible to compute the mask at compile
;;; time and not even store it in the generic-function.
(defconstant generic-function-cache-size 32)
(defun make-generic-function-cache ()
(make-memory-block generic-function-cache-size))
(defun make-generic-function-cache-mask (no-of-specialized-args)
(make-memory-block-mask generic-function-cache-size
(+ no-of-specialized-args 1)))
(defmethod flush-generic-function-caches ((generic-function generic-function))
(let ((cache (generic-function-cache generic-function)))
(when cache (clear-memory-block cache 0))))
(defmethod initialize-generic-function-cache
((generic-function generic-function) no-of-specialized-args)
(declare (ignore no-of-specialized-args))
(unless (generic-function-cache generic-function)
(setf (generic-function-cache generic-function)
(make-generic-function-cache))))
(defmethod make-caching-discriminating-function (generic-function
lookup-function
cache
mask)
(multiple-value-bind (required restp specialized-positions)
(compute-discriminating-function-arglist-info generic-function)
(funcall (get-templated-function-constructor
'caching-discriminating-function
required
restp
specialized-positions
lookup-function
mask)
generic-function cache)))
(defun make-checking-discriminating-function (generic-function
method-function
type-specs
default-function)
(multiple-value-bind (required restp)
(compute-discriminating-function-arglist-info generic-function)
(let ((check-positions
(iterate ((type-spec in type-specs)
(pos from 0))
(collect (and (neq type-spec 't) pos)))))
(apply (get-templated-function-constructor
'checking-discriminating-function
required
restp
(if default-function t nil)
check-positions)
generic-function method-function default-function type-specs))))
;;
;;;;;;
;;
(defmethod update-discriminator-code ((generic-function generic-function))
(install-discriminating-function
generic-function (compute-discriminator-code generic-function)))
(defmethod install-discriminating-function
((generic-function generic-function) function)
(when (and (listp function)
(eq (car function) 'lambda))
(setq function (compile nil function)))
(set-funcallable-instance-function generic-function function))
(defmethod compute-discriminator-code ((generic-function generic-function))
(let ((default (generic-function-default-method generic-function))
(methods (generic-function-methods generic-function))
(std-class (class-named 'class))
(r/w nil))
(cond ((null methods)
(make-no-methods-dcode generic-function))
((and default (null (cdr methods)))
(make-default-method-only-dcode generic-function))
((not (dolist (m methods)
(let ((spec (car (method-type-specifiers m))))
(cond ((or (symbolp spec) ;Bootstrapping!
(listp spec)
(not (eq (class-of spec) std-class)))
(return t))
((and (memq r/w '(nil r))
(typep m 'standard-reader-method))
(setq r/w 'r))
((and (memq r/w '(nil w))
(typep m 'standard-writer-method))
(setq r/w 'w))
(t
(return t))))))
(if (eq r/w 'r)
(make-all-std-class-readers-dcode generic-function)
(make-all-std-class-writers-dcode generic-function)))
((or (and default (null (cddr methods)))
(and (null default) (null (cdr methods))))
(make-single-method-only-discriminating-function generic-function))
((every #'(lambda (m)
(classical-type-specifiers-p
(method-type-specifiers m)))
methods)
(make-classical-methods-only-discriminating-function
generic-function))
(t
(make-multi-method-discriminating-function generic-function)))))
(defmethod make-no-methods-dcode (generic-function)
#'(lambda (&rest ignore)
(declare (ignore ignore))
(error "There are no methods on the generic-function ~S,~%~
so it is an error to call it."
generic-function)))
(defmethod make-default-method-only-dcode (generic-function)
(method-function (generic-function-default-method generic-function)))
(defmethod make-single-method-only-discriminating-function
((self generic-function))
(let* ((methods (generic-function-methods self))
(default (generic-function-default-method self))
(method (if (eq (car methods) default)
(cadr methods)
(car methods)))
(method-type-specifiers (method-type-specifiers method))
(method-function (method-function method)))
(make-checking-discriminating-function
self
method-function
method-type-specifiers
(and default (method-function default)))))
(defmethod make-classical-methods-only-discriminating-function
((self generic-function))
(initialize-generic-function-cache self 1)
(let ((default-method (generic-function-default-method self))
(methods (generic-function-methods self)))
(setf (generic-function-classical-method-table self)
(cons (and default-method (method-function default-method))
(iterate ((method in methods))
(unless (eq method default-method)
(collect (cons (car (method-type-specifiers method))
(method-function method))))))))
(let* ((cache (generic-function-cache self))
(mask (make-generic-function-cache-mask 1)))
(make-caching-discriminating-function
self 'lookup-classical-method cache mask)))
(defun lookup-classical-method (generic-function class)
;; There really should be some sort of more sophisticated protocol going
;; on here. Compare type-specifiers and all that.
(let* ((classical-method-table
(slot-value--funcallable-standard-class (class-of generic-function)
generic-function
'classical-method-table
nil
nil)))
(or (iterate ((super in (slot-value--class class 'class-precedence-list)))
(let ((hit (assq super (cdr classical-method-table))))
(when hit (return (cdr hit)))))
(car classical-method-table))))
(defmethod make-multi-method-discriminating-function
((self generic-function))
(multiple-value-bind (required restp specialized)
(compute-discriminating-function-arglist-info self)
(declare (ignore required restp))
(initialize-generic-function-cache self (length specialized))
(let* ((cache (generic-function-cache self))
(mask (make-generic-function-cache-mask (length specialized))))
(make-caching-discriminating-function
self 'lookup-multi-method cache mask))))
(defvar *lookup-multi-method-internal*
(make-array (min 256. call-arguments-limit)))
(defun lookup-multi-method-internal (generic-function classes)
(let* ((methods (generic-function-methods generic-function))
(cpls *lookup-multi-method-internal*)
(order (slot-value--funcallable-standard-class
(class-of generic-function)
generic-function
'dispatch-order
()
()))
(most-specific-method nil)
(most-specific-type-specs ())
(type-specs ()))
;; Put all the class-precedence-lists in a place where we can save
;; them as we look through all the methods.
(without-interrupts
(iterate ((class in classes)
(i from 0))
(setf (svref cpls i)
(and class ;NIL when caller knows this
;argument is not specialized.
(slot-value--class class 'class-precedence-list))))
(dolist (method methods)
(setq type-specs (slot-value--class method 'type-specifiers))
(when (iterate ((type-spec in type-specs)
(i from 0))
(or (eq type-spec 't)
(memq type-spec (svref cpls i))
(return nil))
(finally (return t)))
(if (null most-specific-method)
(setq most-specific-method method
most-specific-type-specs type-specs)
(case (compare-type-specifier-lists
most-specific-type-specs type-specs nil
() classes order)
(2 (setq most-specific-method method
most-specific-type-specs type-specs))
(1))))))
(or most-specific-method
(generic-function-default-method generic-function))))
(defun lookup-multi-method (generic-function &rest classes)
(declare (inline lookup-multi-method-internal))
(let ((method (lookup-multi-method-internal generic-function classes)))
(and method (method-function method))))
(defun lookup-method (generic-function &rest classes)
(declare (inline lookup-multi-method-internal))
(lookup-multi-method-internal generic-function classes))
;;
;;;;;; Code for parsing arglists (in the usual case).
;; (when generic-function is class generic-function and method is class METHOD)
;;;
;;; arglist-type-specifiers
;;; Given an arglist this returns its type-specifiers. Trailing T's (both
;;; implicit and explicit) are dropped. The type specifiers are returned as
;;; they are found in the arglist, they are not parsed into internal
;;; type-specs.
;;;
;;; *** does anyone call this ?
;(defmethod arglist-type-specifiers ((proto-disc basic-discriminator)
; (proto-meth basic-method)
; arglist)
; (let ((arg (car arglist)))
; (and arglist
; (not (memq arg '(&optional &rest &key &aux))) ;Don't allow any
; ;type-specifiers
; ;after one of these.
; (let ((tail (arglist-type-specifiers proto-disc
; proto-meth
; (cdr arglist)))
; (type-spec (and (listp arg) (cadr arg))))
; (or (and tail (cons (or type-spec 't) tail))
; (and type-spec (cons type-spec ())))))))
;;; arglist-without-type-specifiers
;;; Given an arglist remove the type specifiers.
;;;
;(defmethod arglist-without-type-specifiers ((proto-disc basic-discriminator)
; (proto-meth basic-method)
; arglist)
; (let ((arg (car arglist)))
; (and arglist
; (if (memq arg '(&optional &rest &key &aux)) ;don't allow any
; ;type-specifiers
; ;after one of these.
; arglist
; (cons (if (listp arg) (car arg) arg)
; (arglist-without-type-specifiers proto-disc
; proto-meth
; (cdr arglist)))))))
;(defmethod arglist-args ((discriminator-class basic-discriminator)
; (method-class basic-method)
; arglist)
; (and arglist
; (cond ((eq (car arglist) '&aux) ())
; ((memq (car arglist) '(&optional &rest &key))
; (arglist-args discriminator-class method-class (cdr arglist)))
; (t
; ;; This plays on the fact that no type specifiers are allowed
; ;; on arguments that can have default values.
; (cons (if (listp (car arglist)) (caar arglist) (car arglist))
; (arglist-args discriminator-class
; method-class
; (cdr arglist)))))))
(defun classical-type-specifiers-p (typespecs)
(or (null typespecs)
(and (classp (car typespecs))
(null (cdr typespecs)))))
;;;
;;; Compute various information about a generic-function's arglist by looking
;;; at the argument lists of the methods. The hair for trying not to use
;;; &rest arguments lives here.
;;; The values returned are:
;;; number-of-required-arguments
;;; the number of required arguments to this generic-function's
;;; discriminating function
;;; &rest-argument-p
;;; whether or not this generic-function's discriminating
;;; function takes an &rest argument.
;;; specialized-argument-positions
;;; a list of the positions of the arguments this generic-function
;;; specializes (e.g. for a classical generic-function this is the
;;; list: (1)).
;;;
;;; As usual, it is legitimate to specialize the -internal function that is
;;; why I put it there, since I certainly could have written this more
;;; efficiently if I didn't want to provide that extensibility.
;;;
(defmethod compute-discriminating-function-arglist-info
((generic-function generic-function))
(declare (values number-of-required-arguments
&rest-argument-p
specialized-argument-postions))
(let ((number-required nil)
(restp nil)
(specialized-positions ())
(methods (generic-function-methods generic-function)))
(iterate ((method in methods))
(multiple-value-setq (number-required restp specialized-positions)
(compute-discriminating-function-arglist-info-internal
generic-function method number-required restp specialized-positions)))
(values number-required restp (sort specialized-positions #'<))))
(defmethod compute-discriminating-function-arglist-info-internal
((generic-function generic-function)
(method essential-method)
number-of-requireds restp specialized-argument-positions)
(declare (ignore generic-function))
(let ((requireds 0))
;; Go through this methods arguments seeing how many are required,
;; and whether there is an &rest argument.
(iterate ((arg in (method-arglist method)))
(cond ((eq arg '&aux) (return))
((memq arg '(&optional &rest &key))
(return (setq restp t)))
((memq arg lambda-list-keywords))
(t (incf requireds))))
;; Now go through this method's type specifiers to see which
;; argument positions are type specified. Treat T specially
;; in the usual sort of way. For efficiency don't bother to
;; keep specialized-argument-positions sorted, rather depend
;; on our caller to do that.
(iterate ((type-spec in (method-type-specifiers method))
(pos from 0))
(unless (eq type-spec 't)
(pushnew pos specialized-argument-positions)))
;; Finally merge the values for this method into the values
;; for the exisiting methods and return them. Note that if
;; num-of-requireds is NIL it means this is the first method
;; and we depend on that.
(values (min (or number-of-requireds requireds) requireds)
(or restp
(and number-of-requireds (/= number-of-requireds requireds)))
specialized-argument-positions)))
(defun make-discriminating-function-arglist (number-required-arguments restp)
(iterate ((i from 0 below number-required-arguments))
(collect (intern (format nil "Discriminating Function Arg ~D" i)))
(finally (when restp
(collect '&rest)
(collect (intern "Discriminating Function &rest Arg"))))))
(defmethod compare-methods (generic-function method-1 method-2)
(declare (ignore generic-function))
(let ((compare ()))
(iterate ((ts-1 in (method-type-specifiers method-1))
(ts-2 in (method-type-specifiers method-2)))
(cond ((eq ts-1 ts-2) (setq compare '=))
((eq ts-1 't) (setq compare method-2))
((eq ts-2 't) (setq compare method-1))
((memq ts-1 (class-class-precedence-list ts-2))
(setq compare method-2))
((memq ts-2 (class-class-precedence-list ts-1))
(setq compare method-1))
(t (return nil)))
(finally (return compare)))))
;;
;;;;;; Comparing type-specifiers, statically or wrt an object.
;;
;;; compare-type-specifier-lists compares two lists of type specifiers
;;; compare-type-specifiers compare two type specifiers
;;; If static-p it t the comparison is done statically, otherwise it is
;;; done with respect to object(s). The value returned is:
;;; 1 if type-spec-1 is more specific
;;; 2 if type-spec-2 is more specific
;;; = if they are equal
;;; NIL if they cannot be disambiguated
;;;
(defun compare-type-specifier-lists (type-spec-list-1
type-spec-list-2
staticp
args
classes
order)
(when (or type-spec-list-1 type-spec-list-2)
(ecase (compare-type-specifiers (or (car type-spec-list-1) t)
(or (car type-spec-list-2) t)
staticp
(car args)
(car classes))
(1 '1)
(2 '2)
(= (if (eq order :default)
(compare-type-specifier-lists (cdr type-spec-list-1)
(cdr type-spec-list-2)
staticp
(cdr args)
(cdr classes)
order)
(compare-type-specifier-lists (nth (car order) type-spec-list-1)
(nth (car order) type-spec-list-2)
staticp
(cdr args)
(cdr classes)
(cdr order))))
(nil
(unless staticp
(error "The type specifiers ~S and ~S can not be disambiguated~
with respect to the argument: ~S"
(or (car type-spec-list-1) t)
(or (car type-spec-list-2) t)
(car args)
(car classes)))))))
(defun compare-type-specifiers (type-spec-1 type-spec-2 staticp arg class)
(cond ((equal type-spec-1 type-spec-2) '=)
((eq type-spec-2 t) '1)
((eq type-spec-1 t) '2)
((and (not (listp type-spec-1))
(not (listp type-spec-2)))
; (if staticp
; (if (common-subs type-spec-1 type-spec-2)
; nil
; (let ((supers (common-supers type-spec-1 type-spec-2)))
; (cond ((cdr supers) nil)
; ((eq (car supers) type-spec-1) '2)
; ((eq (car supers) type-spec-2) '1)
; (t 'disjoint))))
(dolist (super (slot-value--class (or class (class-of arg))
'class-precedence-list))
(cond ((eq super type-spec-1)
(return '1))
((eq super type-spec-2)
(return '2)))))
(t
(compare-complex-type-specifiers
type-spec-1 type-spec-2 staticp arg class))))
(defun compare-complex-type-specifiers (type-spec-1 type-spec-2 static-p arg class)
(declare (ignore type-spec-1 type-spec-2 static-p arg class))
(error "Complex type specifiers are not yet supported."))
(defmethod no-matching-method (generic-function)
(error "No matching method for the generic-function: ~S." generic-function))
;;;
;;;
;;;
(defun real-remove-method (generic-function method)
(setf (method-generic-function method) nil)
(setf (generic-function-methods generic-function)
(delq method (generic-function-methods generic-function)))
(dolist (specializers (method-type-specifiers method))
(remove-method-on-specializer method specializers))
(generic-function-changed generic-function method nil)
generic-function)
(defun real-add-named-method (generic-function-name
qualifiers
specializers
lambda-list
function
&rest other-initargs)
;; What about changing the class of the generic-function if there is
;; one. Whose job is that anyways. Do we need something kind of
;; like class-for-redefinition?
(let* ((generic-function
(ensure-generic-function generic-function-name
:lambda-list lambda-list))
(specs (parse-specializers specializers))
(existing (get-method generic-function qualifiers specs nil))
(proto (method-prototype-for-gf generic-function-name))
(new (apply #'make-instance (class-of proto)
:options qualifiers
:type-specifiers specs
:arglist lambda-list
:function function
other-initargs)))
(when existing (remove-method generic-function existing))
(add-method generic-function new)))
(defun real-add-method (generic-function method)
(let ((type-specs (method-type-specifiers method))
;(options (method-options method))
;(methods (discriminator-methods discriminator))
)
(setf (method-generic-function method) generic-function)
(pushnew method (generic-function-methods generic-function))
(dolist (specializer type-specs)
(add-method-on-specializer method specializer))
(generic-function-changed generic-function method t)
(update-pretty-arglist generic-function method) ;NOT part of
;standard protocol.
method))