LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032809. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "BOOT" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388028. :AUTHOR "REL3" :LENGTH-IN-BYTES 21491. :LENGTH-IN-BLOCKS 21. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;;-*-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 ofthe code that actually implements generic functions and method lookup.So, we have a classic bootstrapping problem.   The solution to this is tofirst get a cheap implementation of generic functions running, these arecalled early generic functions.  These early generic functions and thecorresponding early methods and early method lookup are used to get enoughof the system running that it is possible to create real generic functionsand methods and implement real method lookup.  At that point (see FIXUP)the function fix-early-generic-functions is called to convert all the earlygeneric functions to real generic functions.The cheap generic functions are built using the same funcallable-instanceobjects real generic-functions are made out of.  This means that as PCLis being bootstrapped, the cheap generic function objects which are beingcreated are the same objects which will later be fixed up to be realgeneric 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    upThis file defines the macro defmethod and its expansion.  Basically, defmethodexpands into a call to defmethod-1.  defmethod-1 has 4 support functions thatit calls.  During bootstrapping, we use one version of those functions, oncethe system is bootstrapped, the real version of those functions is installed.An important effect of this structure is it means we can compile files withdefmethod forms in them in a completely running PCL, but then load those filesback in during bootstrapping.  This makes development easier.|#(proclaim '(notinline load-method-1      compile-method-1      install-method-function-1      add-named-method      add-method))(defmacro defmethod (&rest args)  (declare (arglist name    {method-qualifier}*    specialized-lambda-list    &body body))  (multiple-value-bind (name qualifiers arglist setf-arglist body)      (parse-defmethod args)    (declare (ignore setf-arglist))    (expand-defmethod name qualifiers arglist body)))(defmacro defmethod-setf (&rest args)  (declare (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)      ;;    ;; For methods on the setf generic function, the combined lambda-list    ;; is just the new-value arguments followed by the access arguments.    ;; For:    ;;    (defmethod-setf foo ((c class) (m method)) ((nv number))    ;;       ...)    ;; The specialized lambda-list of the setf generic-function is:    ;;    ((nv number) (c class) (m method))    ;;    (let ((setf-name (make-setf-generic-function-name name))  (combined-arglist (append setf-arglist arglist ())))      `(progn (record-definition ',name 'defsetf ',setf-name 'defmethod-setf)        (defsetf ,name ,(specialized-lambda-list-lambda-list arglist),(specialized-lambda-list-lambda-list setf-arglist)   (list ',setf-name ,@(specialized-lambda-list-parameters combined-arglist))) ,(expand-defmethod setf-name qualifiers combined-arglist body)))))(defun parse-defmethod (cdr-of-form &optional setfp)  (declare (values name qualifiers arglist setf-arglist body))  (let ((name (pop cdr-of-form))(qualifiers ())(arglist ())(setf-arglist ()))    (loop (if (and (car cdr-of-form) (listp (car cdr-of-form)))      (return (setq qualifiers (nreverse qualifiers)))      (push (pop cdr-of-form) qualifiers)))    (setq arglist (pop cdr-of-form))    (when setfp      (setq setf-arglist (pop cdr-of-form))      ;; For the time being, no lambda-list keywords are allowed to appear      ;; in the setf-arglist.  This condition could be relaxed, it would      ;; require providing some documented function for combining the setf      ;; arglist with the access arglist.      (dolist (llk lambda-list-keywords)(when (memq llk setf-arglist)  (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-arglist))))    (values name qualifiers arglist setf-arglist cdr-of-form)))(defun make-setf-generic-function-name (name)  (intern (string-append "setf generic-function for " name)  (symbol-package name)))(defun expand-defmethod (name qualifiers arglist body)  (let ((defmethod-uid (gensym))(load-method-1 ()))    (multiple-value-bind (parameters lambda-list specializers)(parse-specialized-lambda-list arglist)      ;; Get the documentation string and the declarations all in order.      ;; First we have to extract whatever documentation and declarations      ;; the user put in the defmethod form, then we add in the special      ;; declarations defmethod adds.      ;; Note that both documentation and declarations will be inserted      ;; in the method-function lambda with ,. this allows them not to      ;; take up any space (particularly documentation) when they are      ;; nil, but it means they have to be lists of the real values if      ;; they are not nil.      (multiple-value-bind (documentation declarations real-body)  (extract-declarations body)(when documentation (setq documentation (list documentation)))(setq load-method-1 `(,name      ,specializers      ,lambda-list      ,qualifiers      ',(car documentation)));;;; There are 4 cases:;;   - evaluated;;   - compiled to core;;   - compiled to file;;   - loading the compiled file;;;; When loading a method which has a call-next-method in it,;; there is no way to know which of two events will happen;; first:;;   1. the load-time-eval form in the call-next-method will;;      be evaluated first, or;;   2. the top-level-form which loads the method function will;;      will be evaluated first.;; consequently, both the top-level-form and the expansion of;; call-next-method must check to see if the other has already;; run and set the value of defmethod-uid to the method involved.;; This is what causes the boundp checks of defmethod-uid each time;; before it is set.;;(make-top-level-form  `(defmethod-1 ',name ',specializers ',lambda-list ',qualifiers',(car documentation)',defmethod-uid(function (lambda ,lambda-list    ,@documentation    ,@declarations    ,(wrap-method-body       ();*** FIX       (apply #-KCL #'compile-method-1      #+KCL 'compile-method-1      load-method-1)       name       defmethod-uid       load-method-1       real-body)))))))))(defun make-top-level-form (form)  #-Symbolics form  #+Symbolics (let ((dummy-name (gensym)))`(progn (defun ,dummy-name () ,form)(eval-when (load eval) (,dummy-name)))))(defun defmethod-1 (gf-name specializers arglist qualifiers documentation uid fn)  (record-definition gf-name 'method specializers qualifiers)  (let ((method  (or (and (boundp uid) (symbol-value uid))      (set uid (LOAD-METHOD-1 gf-name      specializers      arglist      qualifiers      documentation)))))    (INSTALL-METHOD-FUNCTION-1 gf-name method fn)    (ADD-METHOD (symbol-function gf-name) method nil)    method))(defun wrap-method-body (mex-generic-function mex-method generic-function-name method-uid load-method-1-args body)  (let ((macroexpand-time-information (list mex-generic-function    mex-method    generic-function-name    method-uid    load-method-1-args)))    `(macrolet ,(iterate (((name arglist params fn) in *method-body-macros*))  (collect `(,name ,arglist       (funcall (function ,fn)',macroexpand-time-information,@params))))       (block ,generic-function-name . ,body))))(defun macroexpand-time-generic-function (mti) (nth 0 mti))(defun macroexpand-time-method (mti) (nth 1 mti))(defun macroexpand-time-generic-function-name (mti) (nth 2 mti))(defun macroexpand-time-method-uid (mti) (nth 3 mti))(defun macroexpand-time-load-method-1-args (mti) (nth 4 mti))(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)) ()))))))))  ;;   ;;;;;; 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*) (fmakunbound x)))(defun load-method-1 (generic-function-name      method-type-specifiers      method-arglist      options      documentation)  (pushnew generic-function-name *early-generic-functions*)  (if (fboundp generic-function-name)      (let ((fin (symbol-function generic-function-name)))(unless (funcallable-instance-p fin)  (error "Can't add an early method to ordinary lisp function."))(unless (listp (funcallable-instance-static-slots fin))  ;; This means the fin has already been 'fixed', change it  ;; back to being an early generic function before going on.  ;; This is needed despite making the eval-when above because  ;; of KCL's *eval-when-compile* misfeature.  (setf (funcallable-instance-static-slots fin) (list nil nil))))      (let ((fin (make-funcallable-instance-1)))(setf (funcallable-instance-static-slots fin) (list nil nil))(setf (symbol-function generic-function-name) fin)))  (compile-method-1 generic-function-name    method-type-specifiers    method-arglist    options    documentation))(defun compile-method-1 (&rest args)  (list :early-method()                  ;install-method-function-1 is going    ;to put the method function here.(copy-list args)))(defun early-method-specializers (early-method)  (if (and (listp early-method)   (eq (car early-method) :early-method))      (cadr (caddr early-method))      (error "~S is not an early-method." early-method)))(defun install-method-function-1 (generic-function-name method function)  (and (fboundp 'set-function-name)       (set-function-name function  (list 'methodgeneric-function-name(early-method-specializers method))))  (if (and (listp method) (eq (car method) :early-method))      (setf (cadr method) function)      (error "Early load-method-1 didn't get an early method.")));;;;;; 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;;;    (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)));;;;;; 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 ignore)  (declare (ignore ignore))  (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)    (let ((early-discriminator-code    ;; If there is only one method, just use that method's function.    ;; This corresponds to the 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.    (if (null (cdr methods))(cadr method)#'(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        (mapcar #'(lambda (spec)   (if (eq spec 't) 't (class-named spec)))       (early-method-specializers method)))     ;; 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 methodmost-specific-specs method-specs))))    (if most-specific-method(cadr most-specific-method)(error "No matching early method."))))(defun add-named-method (generic-function-name arglist type-specs function)  (let ((method (load-method-1 generic-function-name       type-specs       arglist       ()       ())))    (install-method-function-1 nil method function)    (add-method (symbol-function generic-function-name) method nil)))(defun fix-early-generic-functions (&optional noisyp)  (make-instance (class-named 'standard-generic-function));Be sure this class          ;has instances!  (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-name *early-generic-functions*)(when noisyp (format t "~&~S..." early-gf-name))(let* ((early-gf (symbol-function early-gf-name))       (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 (symbol-function early-gf-name) #'trampoline)      (when noisyp (format t "trampoline..."))      (fix-structure early-gf)      (when noisyp (format t "fixed..."))      (initialize early-gf ())      (dolist (early-method early-methods)(let* ((function (cadr early-method))       (load-method-1 (caddr early-method))       (method (apply #'real-load-method-1      early-gf      (cdr load-method-1))))  (real-install-method-function-1 early-gf-name  method  function)  (real-add-method early-gf method ())  (when noisyp (format t "m"))))      (setq aborted nil))  (setf (symbol-function early-gf-name) early-gf)  (when noisyp (format t "."))  (when aborted    (setf (funcallable-instance-static-slots early-gf)  early-static-slots)))))))        (dolist (fns '((load-method-1 . real-load-method-1)     (compile-method-1 . real-compile-method-1)     (install-method-function-1 . real-install-method-function-1)     (add-named-method . real-add-named-method)))(setf (symbol-function (car fns)) (symbol-function (cdr fns))))      (fmakunbound 'add-method)      (real-add-named-method 'add-method     '(generic-function method extra)     '(generic-function method)     #'real-add-method))))ase) (GET hea