;;;-*-Mode:LISP; Package:(PCL LISP 1000); 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)
#|
The CommonLoops evaluator is meta-circular.
Most of the code in PCL is methods on generic functions, including most of
the code that actually implements generic functions and method lookup.
So, we have a classic bootstrapping problem. The solution to this is to
first get a cheap implementation of generic functions running, these are
called early generic functions. These early generic functions and the
corresponding early methods and early method lookup are used to get enough
of the system running that it is possible to create real generic functions
and methods and implement real method lookup. At that point (see FIXUP)
the function fix-early-generic-functions is called to convert all the early
generic functions to real generic functions.
The cheap generic functions are built using the same funcallable-instance
objects real generic-functions are made out of. This means that as PCL
is being bootstrapped, the cheap generic function objects which are being
created are the same objects which will later be fixed up to be real
generic functions. This is good because:
- we don't cons garbage structure
- we can keep pointers to the cheap generic function objects
during booting because those pointers will still point to
the right object after the generic functions are all fixed
up
This file defines the macros defmethod and defmethod-setf, and the protocol
which is used to expand them. A defmethod basically expands into a call to
load-defmethod, which basically calls add-method to add the method to the
generic-function. These expansions can be loaded either during bootstrapping
or when PCL is fully up and running.
An important effect of this structure is it means we can compile files with
defmethod forms in them in a completely running PCL, but then load those files
back in during bootstrapping. This makes development easier. It also means
there is only one set of code for processing defmethod. Bootstrapping works
by being sure to have load-method and load-defmethod-setf be careful to call
only primitives which work during bootstrapping.
|#
(proclaim '(notinline make-a-method
add-named-method
ensure-gf-internal
add-method
remove-method
expand-defmethod
expand-defmethod-setf
expand-defmethod-body
expand-defmethod-setf-body
))
(defvar *early-functions*
'((make-a-method early-make-a-method
real-make-a-method)
(add-named-method early-add-named-method
real-add-named-method)
(ensure-gf-internal early-ensure-gf-internal
real-ensure-gf-internal)))
(eval-when (load eval)
(dolist (fns *early-functions*)
(let ((name (car fns))
(early-name (cadr fns)))
(setf (symbol-function name)
`(lambda (&rest args)
(apply (symbol-function ',early-name) args))))))
;;;
;;; *generic-function-fixups* is used by fix-early-generic-functions to
;;; convert the few functions in the bootstrap which are supposed to be
;;; generic functions into generic functions.
;;;
(defvar *generic-function-fixups*
'((add-method
(generic-function method)
(generic-function method)
real-add-method)
(remove-method
(generic-function method)
(standard-generic-function method)
real-remove-method)
(expand-defmethod
(proto-method name qualifiers lambda-list body env)
(method))
(expand-defmethod-setf
(proto-method name qualifiers lambda-list setf-lambda-list body env)
(method))
(expand-defmethod-body
(mex-method generic-function-name body environment)
(method))
(expand-defmethod-setf-body
(mex-method generic-function-name body environment)
(method))))
;;;
;;;
;;;
(defmacro DEFMETHOD #-KCL (&rest args &environment env)
#+KCL (&environment env &rest args)
(declare (arglist name
{method-qualifier}*
specialized-lambda-list
&body body))
(multiple-value-bind (name qualifiers lambda-list setf-lambda-list body)
(parse-defmethod args)
(declare (ignore setf-lambda-list))
(let ((proto-method (method-prototype-for-gf name)))
(expand-defmethod
proto-method name qualifiers lambda-list body env))))
;;;
;;;
;;;
(defmacro DEFMETHOD-SETF #-KCL (&rest args &environment env)
#+KCL (&environment env &rest args)
(declare (indentation 3 1) ;This isn't really right,
;but it will do for now.
(arglist name
{method-qualifier}*
specialized-lambda-list
specialized-setf-lambda-list
&body body))
(multiple-value-bind (name qualifiers arglist setf-arglist body)
(parse-defmethod args t)
(let ((proto-method (method-prototype-for-gf `(setf ,name))))
(expand-defmethod-setf
proto-method name qualifiers arglist setf-arglist body env))))
;;;
;;; takes a spec which is either a generic function name or a list specifying
;;; a setf generic function (like: (SETF <generic-function-name>)). Returns
;;; the prototype instance of the method-class for that generic function.
;;;
;;; If there is no generic function by that 'name', this returns the default
;;; value, the prototype instance of the class STANDARD-METHOD. This default
;;; value is also returned if the spec names an ordinary function or even a
;;; macro. In effect, this leaves the signalling of the appropriate error
;;; until load time.
;;;
;;; NOTE that during bootstrapping, this function is allowed to return NIL.
;;;
(defun method-prototype-for-gf (name)
(let ((gf? (and (gboundp name)
(gdefinition name))))
(cond ((or (not (fboundp 'generic-function-p)) ;Do some add-hoc tests
(not (fboundp 'class-name)) ;to try see if we are
(not (funcallable-instance-wrapper ;bootstrapping, if so
(symbol-function 'class-name)))) ;just return NIL.
nil)
((or (null gf?)
(not (generic-function-p gf?))) ;Someone else MIGHT
;error at load time.
(class-prototype (class-named 'method)))
(t
(class-prototype (generic-function-method-class gf?))))))
;;;
;;; EXPAND-DEFMETHOD
;;; EXPAND-DEFMETHOD-SETF
;;;
;;; These generic functions are called to compute the expansion of defmethod
;;; and defmethod-setf forms. Whatever value they return will be used as the
;;; expansion of the defmethod(-setf). Before the appropriate one of these
;;; generic functions is called, the defmethod(-setf) form is parsed according
;;; to the syntax defined in the CLOS spec, so these generic functions can't
;;; be used to change the syntax of defmethod or defmethod-setf. They can be
;;; used to change the expansion for methods of a particular class. Note that
;;; for many uses, it is more appropriate to define a special method on
;;; expand-defmethod-body or expand-defmethod-setf-body.
;;;
;;; The arguments to this generic function are interpreted as follows:
;;;
;;; prototype-method
;;; the prototype instance of the class of method this defmethod
;;; form is supposed to define (see method-prototype-for-gf). This
;;; is controlled by the generic function's method-argument-class.
;;;
;;; name
;;; the name argument to the defmethod form
;;;
;;; qualifiers
;;; a list of the method qualifiers as specified in the defmethod
;;; form
;;;
;;; lambda-list
;;; the specialized lambda-list as specified in the defmethod form
;;;
;;; body
;;; the body as specified in the defmethod form.
;;;
;;; environment
;;; the lexical environment the defmethod form appeared in. This
;;; is what the defmethod macro got as its &environment argument.
;;;
;;;
;;; For a typical defmethod like:
;;;
;;; (defmethod move :before ((p position) x y)
;;; "Move the position to x,y and update the display"
;;; (setf (pos-x p) x)
;;; (setf (pos-y p) y)
;;; (update-display))
;;;
;;; The arguments would be:
;;;
;;; name: MOVE
;;; qualifiers: (:BEFORE)
;;; lambda-list: ((p position) x y)
;;; body: ((setf (pos-x p) x) (setf (pos-y p) x) (update-display))
;;; environment: <some structure or NIL>
;;;
;;; In addition, expand-defmethod-setf takes an additional argument which is
;;; the specialized setf lambda list specified in the defmethod-setf form.
;;;
;;;
;;; NOTE: These are defined as functions here, but at the end of
;;; bootstrapping, they will become generic functions.
;;; See *generic-function-fixups*.
;;;
(defun EXPAND-DEFMETHOD (proto-method name qualifiers lambda-list body env)
(multiple-value-bind (preamble fn-form specializers doc uid)
(expand-defmethod-internal
proto-method name qualifiers lambda-list body env 'nil)
(make-top-level-form `(defmethod ,name)
`(eval-when (compile load eval)
(proclaim '(special ,uid))
,(make-progn
preamble
`(load-defmethod
',(if proto-method
(class-name (class-of proto-method))
'method)
',name
',qualifiers
',specializers
',(specialized-lambda-list-lambda-list lambda-list)
',doc
',uid
,fn-form))))))
(defun EXPAND-DEFMETHOD-SETF
(proto-method name qualifiers lambda-list setf-lambda-list body env)
(let ((total-ll (make-setf-method-lambda-list lambda-list
setf-lambda-list)))
(multiple-value-bind (preamble fn-form specializers doc uid)
(expand-defmethod-internal
proto-method name qualifiers total-ll body env 't)
(make-top-level-form `(defmethod-setf ,name)
`(eval-when (compile load eval)
(proclaim '(special ,uid))
,(make-progn
preamble
`(load-defmethod-setf
',(if proto-method
(class-name (class-of proto-method))
'method)
',name
',qualifiers
',specializers
',(specialized-lambda-list-lambda-list lambda-list)
',(specialized-lambda-list-lambda-list setf-lambda-list)
',doc
',uid
,fn-form)))))))
;;;
;;; Now there is a little problem in implementing call-next-method which we
;;; have to solve, and needless to say Common Lisp doesn't exactly make it
;;; easy.
;;;
;;; Every defmethod form creates a method object. Within the defmethod body,
;;; the lexical definition of call-next-method must have a pointer to that
;;; method object.
;;;
;;; Now in any specific Lisp implementation, this would be easy enough to do.
;;; At load time we would first load the compiled-code for the function, then
;;; make the method object, use slot-value to make the method-object point at
;;; the function and use some primitive to bash the compiled code to point at
;;; the method object. But, needless to say Common Lisp doesn't provide any
;;; primitives for bashing compiled code objects, and of course that is as it
;;; should be. BUT, Common Lisp doesn't make any of the other obvious ways
;;; of implementing this work very well either.
;;;
;;; If Common Lisp had global lexicals, we could just cons up a gensym and
;;; store the method object in its value cell, the lexical definition of
;;; call-next-method could fetch it from there. But it doesn't, but we cons
;;; up a gensym and use it as if it were a global lexical anyways since that
;;; is the closest thing to a reasonable solution.
;;;
(defun expand-defmethod-internal
(method name qualifiers specialized-lambda-list body env setfp)
(declare (values preamble fn-form specializers doc uid))
(let ((*uid* (gensym))
(method-body nil)
(mex-method nil)
(documentation (extract-declarations body))
#+Symbolics
(method-spec nil))
(declare (special *uid*))
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore parameters))
(when method
(setq mex-method
(make-instance (class-of method)
;:qualifiers qualifiers ***
:options qualifiers
:arglist lambda-list
:type-specifiers (parse-specializers
specializers)
:documentation documentation)))
(setq method-body
(funcall (if setfp
#'expand-defmethod-setf-body
#'expand-defmethod-body)
mex-method name body env))
#+Symbolics
(setq method-spec (make-method-spec (if setfp `(setf ,name) name)
qualifiers
specializers))
(values
;; The first returned value, the preamble, exists solely for
;; the 3600 where the compiler doesn't bother to compile
;; random top-level forms. By using this special defun, we
;; can get method functions to compile.
#+Symbolics `(zl:defun
; (:property ,*uid* method-function)
,method-spec
,lambda-list
,@method-body)
#-Symbolics nil
;; This is a form which returns the method function. On the
;; 3600 it gets it from where the special defun above put it.
#+Symbolics
; `(get ',*uid* 'method-function)
`(si:fdefinition ',method-spec)
#-Symbolics `(function (lambda ,lambda-list ,@method-body))
specializers
documentation
*uid*))))
(defun load-defmethod (class name quals specls ll doc uid fn)
(let ((method-spec (make-method-spec name quals specls)))
(record-definition 'method method-spec)
(setq fn (set-function-name fn method-spec))
(load-defmethod-internal name quals specls ll doc fn uid class)))
(defun load-defmethod-setf (class name quals specls ll setf-ll doc uid fn)
(let* ((total-ll (make-setf-method-lambda-list ll setf-ll))
(gspec `(setf ,name))
(method-spec (make-method-spec gspec quals specls)))
(record-definition 'method method-spec)
(setq fn (set-function-name fn method-spec))
(do-defmethod-setf-defsetf name ll setf-ll)
(load-defmethod-internal gspec quals specls total-ll doc fn uid class)))
(defun load-defmethod-internal
(gf-spec qualifiers specializers lambda-list doc fn uid method-class)
(let ((method (add-named-method
gf-spec qualifiers specializers lambda-list fn
:documentation doc)))
(unless (or (eq method-class 'method)
(eq (class-named method-class t) (class-of method)))
(format *error-output*
"At the time the method with qualifiers ~:~S and~%~
specializers ~:S on the generic function ~S~%~
was compiled, the method-class for that generic function was~%~
~S. But, the method class is now ~S, this~%~
may mean that this method was compiled improperly."
qualifiers specializers gf-spec
method-class (class-name (class-of method))))
(set uid method)))
(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
`(method ,gf-spec ,@qualifiers ,unparsed-specializers))
;;; EXPAND-DEFMETHOD-BODY
;;; EXPAND-DEFMETHOD-SETF-BODY
;;;
;;; These generic functions are called by the standard methods on expand-
;;; defmethod and expand-defmethod-setf. They get an opportunity to do
;;; extra processing of the body of the method. This processing includes
;;; things like inserting special declarations, wrapping a special lexical
;;; environment around the body etc.
;;;
;;; The generic-function-name, body and environment arguments are as described
;;; in expand-defmethod and expand-defmethod-setf.
;;;
;;; The mex-method argument is a method of the class the defmethod form will
;;; define (an instance of the same class as the prototype-method argument to
;;; expand-defmethod). Unlike the prototype-method argument, the mex-method
;;; argument has some of its slots filled in. In particular the qualifiers,
;;; lambda-list, and specializers slots will be filled in. This provides a
;;; general mechanism for expand-defmethod(-setf) to communicate information
;;; about the method that will be defined to expand-defmethod(-setf)-body.
;;;
;;; NOTE: These are defined as functions here, but at the end of
;;; bootstrapping, they will become generic functions.
;;; See *generic-function-fixups*.
;;;
(defun EXPAND-DEFMETHOD-BODY (mex-method generic-function-name body env)
(expand-defmethod-body-internal mex-method generic-function-name body env))
(defun EXPAND-DEFMETHOD-SETF-BODY (mex-method generic-function-name body env)
(expand-defmethod-body-internal mex-method generic-function-name body env))
(defun expand-defmethod-body-internal
(mex-method generic-function-name body env)
(declare (special *uid*))
(let ((macroexpand-time-information (list mex-method
generic-function-name
*uid*)))
(multiple-value-bind (doc declares real-body)
(extract-declarations body env)
(declare (ignore doc)) ;We drop it on the floor
;since it gets recorded
;elsewhere.
`(,@declares
(macrolet ,(with-collection
(dolist (mbm *method-body-macros*)
(destructuring-bind (name arglist params fn) mbm
(collect `(,name ,arglist
(funcall (function ,fn)
',macroexpand-time-information
,@params))))))
(block ,generic-function-name
,@real-body))))))
(defun macroexpand-time-method (mti) (nth 0 mti))
(defun macroexpand-time-generic-function-name (mti) (nth 1 mti))
(defun macroexpand-time-method-uid (mti) (nth 2 mti))
;;;; Early generic-function support
;;;
;;;
(defvar *early-generic-functions* ())
(eval-when (eval load)
;; To try and make it possible to load PCL into an environment in which
;; it has already been loaded, be sure to get rid of any generic function
;; objects we are likely to encounter during bootstrapping.
(dolist (x *early-generic-functions*)
(cond ((and x (symbolp x))
(fmakunbound x))
((and (listp x)
(eq (car x) 'setf))
(setf (get-setf-generic-function (cadr x)) nil))
(t
(error "What the hell is ~S doing on *early-generic-functions*?"
x)))))
(defun ensure-generic-function (spec &rest keys
&key lambda-list
argument-precedence-order
declarations
documentation
method-combination
generic-function-class
method-class)
(declare (ignore lambda-list argument-precedence-order declarations
documentation method-combination method-class))
(let ((existing (and (gboundp spec)
(gdefinition spec))))
(cond ((null existing)
(let ((new (apply #'ensure-gf-internal spec keys)))
(setq new (set-function-name new spec))
(setf (gdefinition spec) new)))
((funcallable-instance-p existing) existing)
(existing
(error "~S already names an ordinary function or a macro,~%~
it can't be converted to a generic function."
spec)))))
;;;
;;; The static-slots field of the funcallable instances used as early generic
;;; functions is used to store the early methods and early discriminator code
;;; for the early generic function. The static slots field of the fins
;;; contains a list whose:
;;; CAR - a list of the early methods on this early gf
;;; CADR - the early discriminator code for this method
;;;
(defun early-ensure-gf-internal (spec &rest keys)
(declare (ignore keys))
(pushnew spec *early-generic-functions* :test #'equal)
(let ((fin (allocate-funcallable-instance-1)))
(setf (funcallable-instance-static-slots fin) (list nil nil))
fin))
(defmacro early-gf-methods (early-gf)
`(car (funcallable-instance-static-slots ,early-gf)))
(defmacro early-gf-discriminator-code (early-gf)
`(cadr (funcallable-instance-static-slots ,early-gf)))
(defun real-ensure-gf-internal (spec &key lambda-list
argument-precedence-order
declarations
documentation
(method-combination 'standard)
(generic-function-class
(class-named
'standard-generic-function))
(method-class
(class-named 'method)))
(make-instance generic-function-class
:name spec
; :argument-precedence-order argument-precedence-order
; :declarations declarations
; :documentation documentation
; :method-combination method-combination
:method-class method-class))
(defun early-make-a-method
(class qualifiers arglist specializers function doc &optional slot-name)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
;; specializers and set parsed and unparsed appropriately. If we
;; got class objects, then we can compute unparsed, but if we got
;; class names we don't try to compute parsed.
;; Note that the use of not symbolp in this every should be read
;; as 'classp' we can't use classp itself because it doesn't exist
;; yet.
(if (every #'(lambda (s) (or (eq s 't) (not (symbolp s)))) specializers)
(setq parsed specializers
unparsed (mapcar #'(lambda (s)
(if (eq s 't) 't (class-name s)))
specializers))
(setq unparsed specializers
parsed ()))
(list :early-method ;This is an early method dammit!
function ;Function is here for the benefit
;of early-lookup-method.
parsed ;The parsed specializers. This is used
;by early-method-specializers to cache
;the parse. Note that this only comes
;into play when there is more than one
;early method on an early gf.
(list class ;A list to which real-make-a-method
qualifiers ;can be applied to make a real method
arglist ;corresponding to this early one.
unparsed
function
doc
slot-name)
)))
(defun real-make-a-method
(class qualifiers arglist specializers function doc &optional slot-name)
(when (some #'(lambda (x) (and (neq x 't) (symbolp x))) specializers)
(setq specializers (parse-specializers specializers)))
;(setq specializers (parse-specializers specializers))
(make-instance class :options qualifiers
:arglist arglist
:type-specifiers specializers
:function function
:documentation doc
:slot-name slot-name
:allow-other-keys t))
;;;
;;; Fetch the specializers of an early method. This is basically just a
;;; simple accessor except that when the second argument is t, this converts
;;; the specializers from symbols into class objects. The class objects
;;; are cached the early method, this makes bootstrapping faster because
;;; the class objects only have to be computed once.
;;; NOTE:
;;; the second argument should only be passed as T by early-lookup-method.
;;; this is to implement the rule that only when there is more than one
;;; early method on a generic function are the class-objects corresponding
;;; to the early specializers. This is what lets us define methods before
;;; there are any class objects.
;;;
(defun early-method-specializers (early-method &optional objectsp)
(if (and (listp early-method)
(eq (car early-method) :early-method))
(if objectsp
(or (caddr early-method)
(setf (caddr early-method)
(mapcar #'(lambda (x) (if (eq x 't) 't (class-named x)))
(cadddr (cadddr early-method)))))
(cadddr (cadddr early-method)))
(error "~S is not an early-method." early-method)))
(defun early-add-named-method (generic-function-name
qualifiers
specializers
arglist
function
&rest options)
(declare (ignore options))
(when qualifiers
(error "Can't hack qualifiers in early methods."))
(let* ((gf (ensure-generic-function generic-function-name))
(existing (dolist (m (early-gf-methods gf))
(when (equal (early-method-specializers m) specializers)
(return m))))
(new (make-a-method 'method
()
arglist
specializers
function
())))
(when existing (remove-method gf existing))
(add-method gf new)))
;;;
;;; This is the early version of add-method. Later this will become a
;;; generic function. See fix-early-generic-functions which has special
;;; knowledge about add-method.
;;;
(defun add-method (generic-function method)
(when (not (funcallable-instance-p generic-function))
(error "Early add-method didn't get a funcallable instance."))
(when (not (and (listp method) (eq (car method) :early-method)))
(error "Early add-method didn't get an early method."))
(let ((methods (early-gf-methods generic-function)))
(setq methods
(cons method
(remove (early-method-specializers method)
methods
:key #'early-method-specializers
:test #'equal)))
(setf (early-gf-methods generic-function) methods)
(update-early-discriminator-code generic-function)))
;;;
;;; This is the early version of remove method.
;;;
(defun remove-method (generic-function method)
(when (not (funcallable-instance-p generic-function))
(error "Early remove-method didn't get a funcallable instance."))
(when (not (and (listp method) (eq (car method) :early-method)))
(error "Early remove-method didn't get an early method."))
(setf (early-gf-methods generic-function)
(remove method (early-gf-methods generic-function)))
(update-early-discriminator-code generic-function))
(defun update-early-discriminator-code (generic-function)
(let* ((methods (early-gf-methods generic-function))
(early-discriminator-code
(cond ((null methods)
#'(lambda (&rest ignore)
(declare (ignore ignore))
(error "Called an early generic-function that ~
has no methods?")))
((null (cdr methods))
;; If there is only one method, just use that method's
;; function. This corresponds to the important fact
;; that early generic-functions with only one method
;; always call that method when they are called. If
;; there is more than one method, we have to install
;; a simple little discriminator-code for this generic
;; function.
(cadr (car methods)))
(t
#'(lambda (&rest args)
(apply (early-lookup-method methods args) args))))))
(set-funcallable-instance-function generic-function
early-discriminator-code)
(setf (early-gf-discriminator-code generic-function)
early-discriminator-code)))
(defun early-lookup-method (methods args)
(let ((most-specific-method nil)
(most-specific-specs nil))
(dolist (method methods)
(let* ((method-specs (early-method-specializers method t))
;; going to POP off these variables in the loop
(args args)
(specs method-specs)
(mspecs most-specific-specs))
(when (loop
(when (null args)
;; If we are out of arguments, two things are true:
;; 1. this method matches all the arguments
;; 2. at no point were we able to be certain that
;; this method was more or less specific than
;; most-specific-method.
;; Because of the way the loop is set up, what this really
;; means is that this method is a default method, and that
;; none of the previous methods matched.
;; *** I believe this RETURN could just be (RETURN T) ***
(return (null most-specific-method)))
(let* ((arg (pop args))
(spec (or (pop specs) 't))
(mspec (or (pop mspecs) 't))
(cpl ()))
;; If this method doesn't match, return NIL, otherwise try
;; to determine whether or not it is more specific than most
;; specific method. Return T if it is more specific, NIL if
;; it isn't. If its not possible to tell, keep going.
(if (not (or (eq spec 't)
(memq spec (setq cpl
(bootstrap-get-slot
'class
(class-of arg)
'class-precedence-list)))))
(return nil)
(cond ((eq spec mspec))
((or (null most-specific-method)
(eq mspec 't)
(memq mspec (memq spec cpl)))
(return t))
((or (eq spec 't)
(memq spec (memq mspec cpl)))
(return nil))
(t (error "can't get here"))))))
(setq most-specific-method method
most-specific-specs method-specs))))
(if most-specific-method
(cadr most-specific-method)
(error "No matching early method."))))
(defun fix-early-generic-functions (&optional noisyp)
(allocate-instance (class-named 'standard-generic-function));Be sure this
;class has an
;instance.
(let* ((class (class-named 'standard-generic-function))
(wrapper (class-wrapper class))
(n-static-slots (class-no-of-instance-slots class)))
(flet ((fix-structure (gf)
(let ((static-slots
(%allocate-static-slot-storage--class n-static-slots))
(dynamic-slots
(%allocate-dynamic-slot-storage--class)))
(setf (funcallable-instance-wrapper gf) wrapper
(funcallable-instance-static-slots gf) static-slots
(funcallable-instance-dynamic-slots gf) dynamic-slots))))
(dolist (early-gf-spec *early-generic-functions*)
(when noisyp (format t "~&~S..." early-gf-spec))
(let* ((early-gf (gdefinition early-gf-spec))
(early-static-slots
(funcallable-instance-static-slots early-gf))
(early-discriminator-code nil)
(early-methods nil)
(aborted t))
(flet ((trampoline (&rest args)
(apply early-discriminator-code args)))
(if (not (listp early-static-slots))
(when noisyp (format t "already fixed?"))
(unwind-protect
(progn
(setq early-discriminator-code
(early-gf-discriminator-code early-gf))
(setq early-methods
(early-gf-methods early-gf))
(setf (gdefinition early-gf-spec) #'trampoline)
(when noisyp (format t "trampoline..."))
(fix-structure early-gf)
(when noisyp (format t "fixed..."))
(initialize early-gf ())
(dolist (early-method early-methods)
(destructuring-bind
(class quals lambda-list specs fn doc slot-name)
(cadddr early-method)
(setq specs (early-method-specializers early-method
't))
(real-add-method early-gf
(real-make-a-method class
quals
lambda-list
specs
fn
doc
slot-name))
(when noisyp (format t "m"))))
(setf (slot-value early-gf 'name) early-gf-spec)
(setq aborted nil))
(setf (gdefinition early-gf-spec) early-gf)
(when noisyp (format t "."))
(when aborted
(setf (funcallable-instance-static-slots early-gf)
early-static-slots)))))))
(dolist (fns *early-functions*)
(setf (symbol-function (car fns)) (symbol-function (caddr fns))))
(dolist (fixup *generic-function-fixups*)
(destructuring-bind (gf-spec lambda-list specializers method-fn-name)
fixup
(let* ((fn (if method-fn-name
(symbol-function method-fn-name)
(symbol-function gf-spec)))
(gf (make-instance 'standard-generic-function))
(method (make-a-method
'method () lambda-list specializers fn nil)))
(set-function-name gf gf-spec)
(real-add-method gf method)
(setf (gdefinition gf-spec) gf)))))))
;;;
;;; There is hair in here to make sure that compilers which group top-level
;;; forms into 'thunks' don't add any forms to the thunk after this form.
;;; This is important because when this is used by defclass and defmethod
;;; they don't want the forms grouped together.
;;;
(defun make-top-level-form (name form)
(declare (ignore name)) ;***
(make-progn
;#+ExCL'(eval-when (compile) (setq compiler::random-forms-count
; (1+ compiler::random-forms-max)))
#-(or Symbolics GCLisp)
'(eval-when ())
;
form ;<<< it almost got lost in the hair but here's the little form.
;
))
(defun make-progn (&rest forms)
(let ((progn-form nil))
(labels ((collect-forms (forms)
(unless (null forms)
(collect-forms (cdr forms))
(if (and (listp (car forms))
(eq (caar forms) 'progn))
(collect-forms (cdar forms))
(push (car forms) progn-form)))))
(collect-forms forms)
(cons 'progn progn-form))))
;;;
;;; parse-defmethod is used by defmethod and defmethod-setf to parse their
;;; &rest argument into the 'real' arguments. This is where the syntax of
;;; defmethod and defmethod-setf is really implemented.
;;;
(defun parse-defmethod (cdr-of-form &optional setfp)
(declare (values name qualifiers specialized-lambda-list setf-arglist body))
(let ((name (pop cdr-of-form))
(qualifiers ())
(spec-ll ())
(setf-spec-ll ()))
(loop (if (and (car cdr-of-form) (symbolp (car cdr-of-form)))
(push (pop cdr-of-form) qualifiers)
(return (setq qualifiers (nreverse qualifiers)))))
(setq spec-ll (pop cdr-of-form))
(when setfp
(setq setf-spec-ll (pop cdr-of-form))
;; No lambda-list keywords are allowed to appear in the setf
;; specialized lambda-list. Do some error checking for that
;; here.
(dolist (llk lambda-list-keywords)
(when (member llk setf-spec-ll)
(error "The lambda list keyword ~S appears in the~%~
specialized setf lambda list ~S.~%~
No lambda list keywords are allowed to appear there."
llk setf-spec-ll))))
(values name qualifiers spec-ll setf-spec-ll cdr-of-form)))
(defun parse-specializers (specializers)
(flet ((parse (spec)
(cond ((eq spec 't) 't) ;*** I HATE THIS ***
((symbolp spec)
(or (class-named spec t)
(error
"~S used as a specializer,~%~
but is not the name of a class."
spec)))
((and (listp spec)
(eq (car spec) 'quote)
(null (cddr spec)))
spec)
;((classp spec) spec)
(t (error "~S is not a legal specializer." spec)))))
(mapcar #'parse specializers)))
(defun unparse-specializers (specializers-or-method)
(if (listp specializers-or-method)
(flet ((unparse (spec)
(cond ((eq spec 't) 't) ;*** I HATE THIS ***
((classp spec)
(or (class-name spec) spec))
((and (listp spec) (eq (car spec) 'quote))
spec)
(t
(error "~S is not a legal specializer." spec)))))
(mapcar #'unparse specializers-or-method))
(unparse-specializers (method-type-specifiers specializers-or-method))))
(defun parse-method-or-spec (spec &optional (errorp t))
(declare (values generic-function method method-name))
(let (gf method name temp)
(if (method-p spec)
(setq method spec
gf (method-generic-function method)
temp (and gf (generic-function-name gf))
name (if temp
(intern-function-name
(make-method-spec temp
(method-options method)
(unparse-specializers
(method-type-specifiers method))))
(make-symbol (format nil "~S" method))))
(multiple-value-bind (gf-spec quals specls)
(parse-defmethod spec)
(and (setq gf (and (or errorp (gboundp gf-spec))
(gdefinition gf-spec)))
(setq method (get-method gf
quals
(parse-specializers specls)
errorp))
(setq name (intern-function-name (make-method-spec gf-spec
quals
specls))))))
(values gf method name)))
(defun specialized-lambda-list-parameters (specialized-lambda-list)
(multiple-value-bind (parameters ignore1 ignore2)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2))
parameters))
(defun specialized-lambda-list-lambda-list (specialized-lambda-list)
(multiple-value-bind (ignore1 lambda-list ignore2)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2))
lambda-list))
(defun specialized-lambda-list-specializers (specialized-lambda-list)
(multiple-value-bind (ignore1 ignore2 specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(declare (ignore ignore1 ignore2))
specializers))
(defun parse-specialized-lambda-list (arglist &optional post-keyword)
(declare (values parameters lambda-list specializers))
(let ((arg (car arglist)))
(cond ((null arglist) (values nil nil nil))
((eq arg '&aux)
(values nil arglist nil))
((memq arg lambda-list-keywords)
(unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
;; Warn about non-standard lambda-list-keywords, but then
;; go on to treat them like a standard lambda-list-keyword
;; what with the warning its probably ok.
(warn "Unrecognized lambda-list keyword ~S in arglist.~%~
Assuming that the symbols following it are parameters,~%~
and not allowing any parameter specializers to follow~%~
to follow it."
arg))
;; When we are at a lambda-list-keyword, the parameters don't
;; include the lambda-list-keyword; the lambda-list does include
;; the lambda-list-keyword; and no specializers are allowed to
;; follow the lambda-list-keywords (at least for now).
(multiple-value-bind (parameters lambda-list)
(parse-specialized-lambda-list (cdr arglist) t)
(values parameters
(cons arg lambda-list)
nil)))
(post-keyword
;; After a lambda-list-keyword there can be no specializers.
(multiple-value-bind (parameters lambda-list)
(parse-specialized-lambda-list (cdr arglist) t)
(values (cons (if (listp arg) (car arg) arg) parameters)
(cons arg lambda-list)
nil)))
(t
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list (cdr arglist))
(values (cons (if (listp arg) (car arg) arg) parameters)
(cons (if (listp arg) (car arg) arg) lambda-list)
(if specializers
(cons (if (listp arg) (cadr arg) 't) specializers)
(if (listp arg) (list (cadr arg)) ()))))))))