home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume11 / comobj.pch < prev    next >
Lisp/Scheme  |  1987-09-14  |  56KB  |  1,516 lines
  1. Subject:  v11i044:  Patch for Common objects sources
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rs@uunet.UU.NET
  5.  
  6. Submitted-by:          hplabs!hplabsz!kempf@rutgers.edu
  7. Posting-number: Volume 11, Issue 44
  8. Archive-name: comobj.pch
  9.  
  10. [  New versions of two files that were mostly mangled last time.  --r$  ]
  11. -----CUT-----HERE---
  12. # This is a shell archive.  Remove anything before this line,
  13. # then unpack it by saving it in a file and typing "sh file".
  14. # This archive contains:
  15. #    fixup.l    
  16. #    methods.l    
  17. # Error checking via wc(1) will be performed.
  18.  
  19. LANG=""; export LANG
  20.  
  21. echo x - fixup.l
  22. cat >fixup.l <<'@EOF'
  23. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
  24. ;;;
  25. ;;; *************************************************************************
  26. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  27. ;;;
  28. ;;; Use and copying of this software and preparation of derivative works
  29. ;;; based upon this software are permitted.  Any distribution of this
  30. ;;; software or derivative works must comply with all applicable United
  31. ;;; States export control laws.
  32. ;;; 
  33. ;;; This software is made available AS IS, and Xerox Corporation makes no
  34. ;;; warranty about the software, its performance or its conformity to any
  35. ;;; specification.
  36. ;;; 
  37. ;;; Any person obtaining a copy of this software is requested to send their
  38. ;;; name and post office or electronic mail address to:
  39. ;;;   CommonLoops Coordinator
  40. ;;;   Xerox Artifical Intelligence Systems
  41. ;;;   2400 Hanover St.
  42. ;;;   Palo Alto, CA 94303
  43. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  44. ;;;
  45. ;;; Suggestions, comments and requests for improvements are also welcome.
  46. ;;; *************************************************************************
  47. ;;;
  48.  
  49. (in-package 'pcl)
  50.  
  51. (eval-when (compile load eval)
  52.   (setq *real-methods-exist-p* nil)
  53.   (setf (symbol-function 'expand-defmeth)
  54.     (symbol-function 'real-expand-defmeth)))
  55.  
  56. (eval-when (load)
  57.   (clrhash *discriminator-name-hash-table*)
  58.   (fix-early-defmeths)
  59.  ;; This now happens at the end of loading HIGH to make it
  60.  ;; possible to compile and load pcl in the same environment.
  61.  ;(setq *error-when-defining-method-on-existing-function* t)
  62.   )
  63.  
  64. (eval-when (compile load eval)
  65.   (setq *real-methods-exist-p* t))
  66.  
  67.   ;;   
  68. ;;;;;; Pending defmeths which I couldn't do before.
  69.   ;;
  70.  
  71.  
  72. (eval-when (load eval)
  73.   (setf (discriminator-named 'print-instance) ())
  74.   (make-specializable 'print-instance :arglist '(instance stream depth)))
  75.  
  76. (defmeth print-instance ((instance object) stream depth)
  77.   (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
  78.     (format stream "#S(~S" (class-name (class-of instance)))
  79.     (iterate ((slot-or-value in (all-slots instance))
  80.           (slotp = t (not slotp)))
  81.       (when (numberp length)
  82.     (cond ((<= length 0) (format stream " ...") (return ()))
  83.           (t (decf length))))
  84.       (princ " " stream)
  85.       (let ((*print-level* (cond ((null *print-level*) ())
  86.                  (slotp 1)
  87.                  (t (- *print-level* depth)))))
  88.     (if (and *print-level* (<= *print-level* 0))
  89.         (princ "#" stream)
  90.         (prin1 slot-or-value stream))))
  91.     (princ ")" stream)))
  92.  
  93. (defmeth print-instance ((class essential-class) stream depth)
  94.   (named-object-print-function class stream depth))
  95.  
  96.  
  97. (defmethod print-instance ((method essential-method) stream depth)
  98.   (ignore depth)
  99.   (printing-random-thing (method stream)
  100.     (let ((discriminator (method-discriminator method))
  101.       (class-name (capitalize-words (class-name (class-of method)))))
  102.       (format stream "~A ~S ~:S"
  103.           class-name
  104.           (and discriminator (discriminator-name discriminator))
  105.           (method-type-specifiers method)))))
  106.  
  107. (defmethod print-instance ((method basic-method) stream depth)
  108.   (ignore depth)
  109.   (printing-random-thing (method stream)
  110.     (let ((discriminator (method-discriminator method))
  111.       (class-name (capitalize-words (class-name (class-of method)))))
  112.       (format stream "~A ~S ~:S"
  113.           class-name
  114.           (and discriminator (discriminator-name discriminator))
  115.           (unparse-type-specifiers method)))))
  116.  
  117. (defmethod print-instance ((discriminator essential-discriminator) stream depth)
  118.   (named-object-print-function discriminator stream depth))
  119.  
  120. (defmethod print-instance ((discriminator basic-discriminator) stream depth)
  121.   (named-object-print-function
  122.     discriminator stream depth (list (method-combination-type discriminator))))
  123.  
  124. (eval-when (load)
  125.  
  126. (define-meta-class essential-class (lambda (x) (%instance-ref x 0)))
  127.  
  128. (defmeth class-slots ((class essential-class))
  129.   (ignore class)
  130.   ())
  131.  
  132. (defmeth make-instance ((class essential-class))
  133.   (let ((primitive-instance
  134.       (%make-instance (class-named 'essential-class)
  135.               (1+ (length (class-slots class))))))
  136.     (setf (%instance-ref primitive-instance 0) class)
  137.     primitive-instance))
  138.  
  139. (defmeth get-slot-using-class ((class essential-class) object slot-name)
  140.   (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
  141.     (if pos
  142.     (%instance-ref object (1+ pos))
  143.     (slot-missing ;class
  144.       object slot-name))))
  145.  
  146. (defmeth put-slot-using-class ((class essential-class)
  147.                    object
  148.                    slot-name
  149.                    new-value)
  150.   (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
  151.     (if pos
  152.     (setf (%instance-ref object (1+ pos)) new-value)
  153.     (slot-missing ;class
  154.               object slot-name))))
  155.  
  156. (defmeth optimize-get-slot (class form)
  157.   (declare (ignore class))
  158.   form)
  159.  
  160. (defmeth optimize-setf-of-get-slot (class form)
  161.   (declare (ignore class))
  162.   form)
  163.  
  164. (defmeth make-slotd ((class essential-class) &rest keywords-and-options)
  165.   (ignore class)
  166.   (apply #'make-slotd--essential-class keywords-and-options))
  167.  
  168. (defmeth add-named-class ((proto-class essential-class) name
  169.               local-supers
  170.               local-slot-slotds
  171.               extra)
  172.   ;; First find out if there is already a class with this name.
  173.   ;; If there is, call class-for-redefinition to get the class
  174.   ;; object to use for the new definition.  If there is no exisiting
  175.   ;; class we just make a new instance.
  176.   (let* ((existing (class-named name t))
  177.      (class (if existing
  178.             (class-for-redefinition existing proto-class name 
  179.                         local-supers local-slot-slotds
  180.                         extra)
  181.             (make (class-of proto-class)))))
  182.  
  183.     (setq local-supers
  184.       (mapcar
  185.         #'(lambda (ls)
  186.         (or (class-named ls t)
  187.             (error "~S was specified as the name of a local-super~%~
  188.                             for the class named ~S.  But there is no class~%~
  189.                             class named ~S." ls name ls)))
  190.         local-supers))
  191.     
  192.     (setf (class-name class) name)
  193. ;   (setf (class-ds-options class) extra)    ;This is NOT part of the
  194. ;                        ;standard protocol.
  195.    
  196.     (add-class class local-supers local-slot-slotds extra)
  197.     
  198.     (setf (class-named name) class)
  199.     name))
  200.  
  201. (defmeth supers-changed ((class essential-class)
  202.              old-local-supers
  203.              old-local-slots
  204.              extra
  205.              top-p)
  206.   (ignore old-local-supers old-local-slots top-p)
  207.   (let ((cpl (compute-class-precedence-list class)))
  208.     (setf (class-class-precedence-list class) cpl)
  209. ;   (update-slots--class class cpl)                 ;This is NOT part of
  210. ;                                 ;the essential-class
  211. ;                                 ;protocol.
  212.     (dolist (sub-class (class-direct-subclasses class))
  213.       (supers-changed sub-class
  214.               (class-local-supers sub-class)
  215.               (class-local-slots sub-class)
  216.               extra
  217.               nil))
  218. ;   (when top-p                                          ;This is NOT part of
  219. ;     (update-method-inheritance class old-local-supers));the essential-class
  220. ;                                      ;protocol.
  221.     ))
  222.  
  223. (defmeth slots-changed ((class essential-class)
  224.             old-local-slots
  225.             extra
  226.             top-p)
  227.   (ignore top-p old-local-slots)
  228.   ;; When this is called, class should have its local-supers and
  229.   ;; local-slots slots filled in properly.
  230. ; (update-slots--class class (class-class-precedence-list class))
  231.   (dolist (sub-class (class-direct-subclasses class))
  232.     (slots-changed sub-class (class-local-slots sub-class) extra nil)))
  233.  
  234. (defmeth method-equal (method argument-specifiers options)
  235.   (ignore options)
  236.   (equal argument-specifiers (method-type-specifiers method)))
  237.  
  238. (defmeth methods-combine-p ((d essential-discriminator))
  239.   (ignore d)
  240.   nil)
  241.  
  242. )
  243.  
  244.   ;;   
  245. ;;;;;; 
  246.   ;;
  247.  
  248. (define-method-body-macro call-next-method ()
  249.   :global :error
  250.   :method (expand-call-next-method
  251.         (macroexpand-time-method macroexpand-time-environment)
  252.         nil
  253.         macroexpand-time-environment))
  254.  
  255. (defmethod expand-call-next-method ((mex-method method) args mti)
  256.   (ignore args)
  257.   (let* ((arglist (and mex-method (method-arglist mex-method)))
  258.      (uid (macroexpand-time-method-uid mti))
  259.      (load-method-1-args (macroexpand-time-load-method-1-args mti))
  260.      (load-time-eval-form `(load-time-eval
  261.                  (if (boundp ',uid)
  262.                      ,uid
  263.                      (setq ,uid
  264.                        (apply #'load-method-1
  265.                           ',load-method-1-args)))))
  266.      (applyp nil))
  267.     (multiple-value-setq (arglist applyp) (make-call-arguments arglist))
  268.     (cond ((null (method-type-specifiers mex-method))
  269.        (warn "Using call-next-method in a default method.~%~
  270.                   At run time this will generate an error.")
  271.        '(error "Using call-next-method in a default method."))
  272.       (applyp
  273.        `(apply
  274.           #'call-next-method-internal ,load-time-eval-form . ,arglist))
  275.       (t
  276.        `(call-next-method-internal ,load-time-eval-form . ,arglist)))))
  277.  
  278. (defun call-next-method-internal (current-method &rest args)
  279.   (let* ((discriminator (method-discriminator current-method))
  280.      (type-specifiers (method-type-specifiers current-method))
  281.      (most-specific nil)
  282.      (most-specific-type-specifiers ())
  283.      (dispatch-order (get-slot--class discriminator 'dispatch-order)))
  284.     (iterate ((method in (discriminator-methods discriminator)))
  285.       (let ((method-type-specifiers (method-type-specifiers method))
  286.             (temp ()))
  287.         (and (every #'(lambda (arg type-spec)
  288.             (or (eq type-spec 't)
  289.                 (memq type-spec
  290.                   (get-slot--class
  291.                     (class-of arg) 'class-precedence-list))))
  292.                     args method-type-specifiers)
  293.              (eql 1 (setq temp (compare-type-specifier-lists
  294.                  type-specifiers
  295.                  method-type-specifiers
  296.                  ()
  297.                  args
  298.                  ()
  299.                  dispatch-order)))
  300.              (or (null most-specific)
  301.                  (eql 1 (setq temp (compare-type-specifier-lists
  302.                                      method-type-specifiers
  303.                                      most-specific-type-specifiers
  304.                                      ()
  305.                                      args
  306.                                      ()
  307.                      dispatch-order))))
  308.              (setq most-specific method
  309.                    most-specific-type-specifiers method-type-specifiers))))
  310.     (if (or most-specific
  311.             (setq most-specific (discriminator-default-method
  312.                   discriminator)))
  313.         (apply (method-function most-specific) args)
  314.         (error "no super method found"))))
  315.  
  316. ;;;
  317. ;;; This is kind of bozoid because it always copies the lambda-list even
  318. ;;; when it doesn't need to.  It also doesn't remember things it could
  319. ;;; remember, causing it to call memq more than it should.  Fix this one
  320. ;;; day when there is nothing else to do.
  321. ;;; 
  322. (defun make-call-arguments (lambda-list &aux applyp)
  323.   (setq lambda-list (reverse lambda-list))
  324.   (when (memq '&aux lambda-list)
  325.     (setq lambda-list (cdr (memq '&aux lambda-list))))
  326.   (setq lambda-list (nreverse lambda-list))
  327.   (let ((optional (memq '&optional lambda-list)))
  328.     (when optional
  329.       ;; The &optional keyword appears in the lambda list.
  330.       ;; Get rid of it, by moving the rest of the lambda list
  331.       ;; up, then go through the optional arguments, replacing
  332.       ;; them with the real symbol.
  333.       (setf (car optional) (cadr optional)
  334.         (cdr optional) (cddr optional))
  335.       (iterate ((loc on optional))
  336.     (when (memq (car loc) lambda-list-keywords)
  337.       (unless (memq (car loc) '(&rest &key &allow-other-keys))
  338.         (error
  339.           "The non-standard lambda list keyword ~S appeared in the~%~
  340.                lambda list of a method in which CALL-NEXT-METHOD is used.~%~
  341.                PCL can only deal with standard lambda list keywords."))
  342.       (when (listp (car loc)) (setf (car loc) (caar loc)))))))
  343.   (let ((rest (memq '&rest lambda-list)))
  344.     (cond ((not (null rest))
  345.        ;; &rest appears in the lambda list. This means we
  346.        ;; have to do an apply. We ignore the rest of the
  347.        ;; lambda list, just grab the &rest var and set applyp.
  348.        (setf (car rest) (if (listp (cadr rest))
  349.                 (caadr rest)
  350.                 (cadr rest))
  351.          (cdr rest) ())
  352.        (setq applyp t))
  353.       (t
  354.        (let ((key (memq '&key lambda-list)))
  355.          (when key
  356.            ;; &key appears in the lambda list.  Remove &key from the
  357.            ;; lambda list then replace all the keywords with pairs of
  358.            ;; the actual keyword followed by the value variable.
  359.            ;; Have to parse the hairy triple case of &key.
  360.            (let ((key-args
  361.                (iterate ((arg in (cdr key)))
  362.              (until (eq arg '&allow-other-keys))
  363.              (cond ((symbolp arg)
  364.                 (collect (make-keyword arg))
  365.                 (collect arg))
  366.                    ((cddr arg)
  367.                 (collect (caddr arg))
  368.                 (collect (car arg)))
  369.                    (t
  370.                 (collect (make-keyword (car arg)))
  371.                 (collect (car arg)))))))
  372.          (if key-args
  373.              (setf (car key) (car key-args)
  374.                (cdr key) (cdr key-args))
  375.              (setf (cdr key) nil
  376.                lambda-list (remove '&key lambda-list)))))))))
  377.   (values lambda-list applyp))
  378. @EOF
  379. if test "`wc -lwc <fixup.l`" != '    355   1302  12760'
  380. then
  381.  echo ERROR: wc results of fixup.l are `wc -lwc <fixup.l` should be 355   1302  12760
  382. fi
  383. chmod 666 fixup.l
  384.  
  385. LANG=""; export LANG
  386.  
  387. echo x - methods.l
  388. cat >methods.l <<'@EOF'
  389. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  390. ;;;
  391. ;;; *************************************************************************
  392. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  393. ;;;
  394. ;;; Use and copying of this software and preparation of derivative works
  395. ;;; based upon this software are permitted.  Any distribution of this
  396. ;;; software or derivative works must comply with all applicable United
  397. ;;; States export control laws.
  398. ;;; 
  399. ;;; This software is made available AS IS, and Xerox Corporation makes no
  400. ;;; warranty about the software, its performance or its conformity to any
  401. ;;; specification.
  402. ;;; 
  403. ;;; Any person obtaining a copy of this software is requested to send their
  404. ;;; name and post office or electronic mail address to:
  405. ;;;   CommonLoops Coordinator
  406. ;;;   Xerox Artifical Intelligence Systems
  407. ;;;   2400 Hanover St.
  408. ;;;   Palo Alto, CA 94303
  409. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  410. ;;;
  411. ;;; Suggestions, comments and requests for improvements are also welcome.
  412. ;;; *************************************************************************
  413. ;;;
  414.  
  415. (in-package 'pcl)
  416.  
  417.   ;;   
  418. ;;;;;; Methods
  419.   ;;   
  420.  
  421. (ndefstruct (essential-method
  422.           (:class class)
  423.           (:conc-name method-))
  424.   (discriminator nil)
  425.   (arglist ())
  426.   (type-specifiers ())
  427.   (function nil))
  428.  
  429. (ndefstruct (combinable-method-mixin (:class class)))
  430.  
  431. (ndefstruct (basic-method
  432.           (:class class)
  433.           (:include (essential-method))
  434.           (:constructor make-method-1)
  435.           (:conc-name method-))
  436.   (function nil)
  437.   (discriminator nil)
  438.   (type-specifiers ())
  439.   (arglist ())
  440.   (options () :allocation :dynamic))
  441.  
  442. (ndefstruct (method (:class class)
  443.             (:include (combinable-method-mixin
  444.                    basic-method))))
  445.  
  446.  
  447. (ndefstruct (essential-discriminator
  448.           (:class class)
  449.           (:conc-name discriminator-))
  450.   (name nil)
  451.   (methods ())
  452.   (discriminating-function ())
  453.   (classical-method-table nil :allocation :dynamic)
  454.   (cache ()))
  455.  
  456. (ndefstruct (method-combination-mixin (:class class)
  457.                       (:conc-name nil))
  458.   (method-combination-type :daemon)
  459.   (method-combination-parameters ())
  460.   (methods-combine-p ())
  461.   )
  462.  
  463. (ndefstruct (basic-discriminator
  464.           (:class class)
  465.           (:include (essential-discriminator))
  466.           (:constructor make-discriminator-1)
  467.           (:conc-name discriminator-))
  468.  
  469.   (dispatch-order :default)  
  470.   (inactive-methods () :allocation :dynamic))
  471.  
  472. (ndefstruct (discriminator (:class class)
  473.                (:include (method-combination-mixin
  474.                       basic-discriminator)))
  475.   )
  476.  
  477. ;;;
  478. ;;; This is really just for bootstrapping, of course this isn't all
  479. ;;; worked out yet.  But this SHOULD really just be for bootstrapping.
  480. ;;; 
  481. (defmeth method-causes-combination-p ((method basic-method))
  482.   (ignore method)
  483.   ())
  484.  
  485.   ;;   
  486. ;;;;;; 
  487.   ;;   
  488.  
  489.  
  490. (defun real-expand-defmeth (name&options arglist body)
  491.   (unless (listp name&options) (setq name&options (list name&options)))
  492.   (keyword-parse ((discriminator-class 'discriminator)
  493.                   (method-class 'method))
  494.                  (cdr name&options)
  495.     (dolist (x '(:discriminator-class :method-class))
  496.       (delete x name&options :test #'(lambda (x y)
  497.                        (and (listp y) (eq (car y) x)))))
  498.     (let ((discriminator-class-object (class-named discriminator-class t))
  499.           (method-class-object (class-named method-class t)))
  500.       (or discriminator-class-object        ;
  501.           (error
  502.         "The :DISCRIMINATOR-CLASS option to defmeth was used to specify~
  503.              that the class~%of the discriminator should be ~S;~%~
  504.              but there is no class named ~S."
  505.         discriminator-class
  506.         discriminator-class))
  507.       (or method-class-object
  508.           (error "The :METHOD-CLASS option to defmeth was used to specify~%~
  509.                   that the class of the method should be ~S;~%~
  510.                   but there is no class named ~S."
  511.                  method-class
  512.                  method-class))
  513.       (expand-defmeth-internal (class-prototype discriminator-class-object)
  514.                    (class-prototype method-class-object)
  515.                    name&options
  516.                    arglist
  517.                    body))))
  518.  
  519. (defvar *method-being-defined*)
  520.  
  521. (defmeth expand-defmeth-internal ((proto-discriminator basic-discriminator)
  522.                   (proto-method basic-method)
  523.                   name&options arglist body)
  524.   (keyword-parse ((setf () setf-specified-p))
  525.                  (cdr name&options)
  526.     (let* ((discriminator-class-name (class-name
  527.                        (class-of proto-discriminator)))
  528.            (method-class-name (class-name (class-of proto-method)))
  529.            (name (car name&options))
  530.            (merged-arglist (cons (car arglist) (append setf (cdr arglist))))
  531.            (merged-args (arglist-without-type-specifiers proto-discriminator
  532.                                                          proto-method
  533.                                                          merged-arglist))
  534.            (merged-type-specifiers
  535.          (defmethod-argument-specializers arglist))
  536.            discriminator-name
  537.            method-name
  538.        (defmethod-uid (gensym))
  539.        (load-method-1 ())
  540.        (documentation ())
  541.        (declarations ()))
  542.       (if setf-specified-p
  543.       (setq discriminator-name (make-setf-discriminator-name name)
  544.         method-name (make-setf-method-name name
  545.                            (arglist-type-specifiers
  546.                              proto-discriminator
  547.                              proto-method
  548.                              setf)
  549.                            merged-type-specifiers))
  550.       (setq discriminator-name name
  551.         method-name (make-method-name name
  552.                           merged-type-specifiers)))
  553.       (multiple-value-setq (documentation declarations body)
  554.     (extract-declarations body))
  555.       (setq load-method-1 `(,discriminator-class-name
  556.                 ,method-class-name
  557.                 ,discriminator-name
  558.                 ,merged-type-specifiers
  559.                 ,merged-args
  560.                 ,(cdr name&options)))
  561.       ;;
  562.       ;; There are 4 cases:
  563.       ;;   - evaluated
  564.       ;;   - compiled to core
  565.       ;;   - compiled to file
  566.       ;;   - loading the compiled file
  567.       ;;
  568.       ;; When loading a method which has a run-super in it, there is no way
  569.       ;; to know which of two events will happen first:
  570.       ;;   1. the load-time-eval form in the run super will be
  571.       ;;      evaluated first, or
  572.       ;;   2. the function to install the loaded method (defmethod-uid)
  573.       ;;      will be evaluated first.
  574.       ;; consequently, both the special function (defmethod-uid) and the
  575.       ;; expansion of run-super must check to see if the other has already
  576.       ;; run and set the value of defmethod-uid to the method involved.
  577.       ;; This is what causes the boundp checks of defmethod-uid each time
  578.       ;; before it is set.
  579.       ;; 
  580.       `(progn
  581.      
  582.      (eval-when (eval load)
  583.        
  584.        (defun ,defmethod-uid ()
  585.          (declare (special ,defmethod-uid))
  586.          (unless (boundp ',defmethod-uid)
  587.            (setq ,defmethod-uid (apply #'load-method-1
  588.                        ',load-method-1)))
  589.          ,@(and *real-methods-exist-p*
  590.             `((record-definition
  591.             ',discriminator-name 'method
  592.             ',merged-type-specifiers ',(cdr name&options))
  593.               (setf (symbol-function ',method-name)
  594.                 #'(lambda ,merged-args
  595.                 ,@documentation
  596.                 ,@declarations
  597.                 (declare (method-function-name ,method-name))
  598.                 ,(wrap-method-body
  599.                    proto-discriminator
  600.                    (apply 'compile-method-1 load-method-1)
  601.                    discriminator-name
  602.                    defmethod-uid
  603.                    load-method-1
  604.                    body)
  605.                 ))))
  606.          
  607.          (setf (method-function ,defmethod-uid)
  608.            (symbol-function ',method-name))
  609.          
  610.          (add-method (discriminator-named ',discriminator-name)
  611.              ,defmethod-uid
  612.              ()))
  613.        
  614.        (,defmethod-uid))
  615.      
  616.      (eval-when (compile load eval)
  617.        
  618.        ,@(and setf-specified-p
  619.           `((record-definition
  620.               ',name 'defsetf ',discriminator-name 'defmeth)
  621.             (defsetf ,name
  622.                  ,(arglist-without-type-specifiers
  623.                 proto-discriminator proto-method arglist)
  624.                  ,(arglist-without-type-specifiers
  625.                 proto-discriminator proto-method setf)
  626.               (list ',discriminator-name ,@(arglist-args
  627.                              proto-discriminator
  628.                              proto-method
  629.                              merged-args)))))
  630.        
  631.        ',discriminator-name)))))
  632.  
  633. (defmethod wrap-method-body ((mex-generic-function discriminator)
  634.                  (mex-method method)
  635.                  generic-function-name
  636.                  method-uid
  637.                  load-method-1-args
  638.                  body)
  639.   (let ((macroexpand-time-information (list mex-generic-function
  640.                         mex-method
  641.                         generic-function-name
  642.                         method-uid
  643.                         load-method-1-args)))
  644.     `(macrolet ,(iterate (((name arglist params fn) in *method-body-macros*))
  645.           (collect `(,name ,arglist
  646.                    (funcall (function ,fn)
  647.                     ',macroexpand-time-information
  648.                     ,@params))))
  649.        (block ,generic-function-name
  650.      . ,body))))
  651.  
  652. (defun macroexpand-time-generic-function (mti) (nth 0 mti))
  653.  
  654. (defun macroexpand-time-method (mti) (nth 1 mti))
  655.  
  656. (defun macroexpand-time-generic-function-name (mti) (nth 2 mti))
  657.  
  658. (defun macroexpand-time-method-uid (mti) (nth 3 mti))
  659.  
  660. (defun macroexpand-time-load-method-1-args (mti) (nth 4 mti))
  661.  
  662.  
  663. (defun load-method-1 (discriminator-class-name
  664.                method-class-name
  665.                discriminator-name
  666.                method-type-specifiers
  667.               method-arglist
  668.               options)
  669.   (let* ((discriminator
  670.        (ensure-selector-specializable
  671.          (class-prototype (class-named discriminator-class-name))
  672.          discriminator-name
  673.          method-arglist))
  674.      (method
  675.        (or (find-method discriminator method-type-specifiers options t)
  676.            (make method-class-name))))
  677.     (setf (method-arglist method) method-arglist)
  678.     (setf (method-type-specifiers method)
  679.       (parse-type-specifiers
  680.         discriminator method method-type-specifiers))
  681.     (setf (method-options method) options)
  682.     method))
  683.  
  684. (defun compile-method-1 (discriminator-class-name
  685.              method-class-name
  686.              discriminator-name
  687.              method-type-specifiers
  688.              method-arglist
  689.              options)
  690.   (ignore discriminator-name)
  691.   (let ((method (make method-class-name)))
  692.     (setf (method-arglist method) method-arglist)
  693.     (setf (method-type-specifiers method)
  694.           (parse-type-specifiers
  695.         (class-prototype (class-named discriminator-class-name))
  696.         method
  697.         method-type-specifiers))
  698.     (setf (method-options method) options)
  699.     method))
  700.  
  701.  
  702.  
  703. (defmeth add-named-method ((proto-discriminator essential-discriminator)
  704.                (proto-method essential-method)
  705.                discriminator-name
  706.                arglist
  707.                type-specs
  708.                extra
  709.                function)
  710.   ;; What about changing the class of the discriminator if there is
  711.   ;; one.  Whose job is that anyways.  Do we need something kind of
  712.   ;; like class-for-redefinition?
  713.   (let* ((discriminator
  714.        ;; Modulo bootstrapping hair, this is just:
  715.        ;;   (or (discriminator-named ..)
  716.        ;;       (make-specializable))
  717.        (ensure-selector-specializable proto-discriminator
  718.                       discriminator-name
  719.                       arglist))
  720.      (existing (find-method discriminator type-specs extra t))
  721.      (method (or existing
  722.              (make (class-of proto-method)))))
  723.     (when existing (change-class method (class-of proto-method)))
  724.     (setf (method-arglist method) arglist)
  725.     (setf (method-function method) function)
  726.     (setf (method-type-specifiers method) type-specs)
  727.     (add-method discriminator method extra)))
  728.  
  729. (defmeth add-method ((discriminator essential-discriminator)
  730.              (method essential-method)
  731.              extra)
  732.   (ignore extra)
  733.   (let ((type-specs (method-type-specifiers method))
  734.        ;(options (method-options method))
  735.        ;(methods (discriminator-methods discriminator))
  736.     )
  737.     (setf (method-discriminator method) discriminator)
  738. ;    ;; Put the new method where it belongs, either:
  739. ;    ;;  - The same (EQ) method object is already on discriminator-methods
  740. ;    ;;    of the discriminator so we don't need to do anything to put the
  741. ;    ;;    new methods where it belongs.
  742. ;    ;;  - There is an method on discriminator-methods which is equal to
  743. ;    ;;    the new method (according to METHOD-EQUAL).  In this case, we
  744. ;    ;;    replace the existing method with the new one.
  745. ;    ;;  - We just add the new method to discriminator-methods by pushing
  746. ;    ;;    it onto that list.
  747. ;    (unless (memq method methods)
  748. ;      (do* ((tail (discriminator-methods discriminator) (cdr tail))
  749. ;        (existing-method (car tail) (car tail)))
  750. ;       ((cond ((null existing-method)         
  751. ;           (push method (discriminator-methods discriminator)))
  752. ;          ((method-equal existing-method type-specs options)
  753. ;           (remove-method discriminator existing-method)
  754. ;           (return (add-method discriminator method))))
  755. ;        
  756. ;        (when (method-causes-combination-p method)             ;NOT part of
  757. ;          (pushnew method (methods-combine-p discriminator)));standard
  758. ;                                         ;protocol.
  759. ;        (dolist (argument-specifier type-specs)
  760. ;          (add-method-on-argument-specifier discriminator
  761. ;                        method
  762. ;                        argument-specifier)))
  763. ;    ()))
  764.     (pushnew method (discriminator-methods discriminator))
  765.     (dolist (argument-specifier type-specs)
  766.       (add-method-on-argument-specifier discriminator
  767.                     method
  768.                     argument-specifier)))
  769.     (discriminator-changed discriminator method t)
  770.     (update-pretty-arglist discriminator method)    ;NOT part of
  771.                                 ;standard protocol.
  772.     ())
  773.  
  774.  
  775. (defmeth remove-named-method (discriminator-name
  776.                   argument-specifiers
  777.                   &optional extra)
  778.   (let ((discriminator ())
  779.     (method ()))
  780.     (cond ((null (setq discriminator (discriminator-named
  781.                        discriminator-name)))
  782.        (error "There is no discriminator named ~S." discriminator-name))
  783.       ((null (setq method (find-method discriminator
  784.                        argument-specifiers 
  785.                        extra
  786.                        t)))
  787.        (error "There is no method for the discriminator ~S~%~
  788.                    which matches the argument-specifiers ~S."
  789.           discriminator
  790.           argument-specifiers))
  791.       (t
  792.        (remove-method discriminator method)))))
  793.  
  794. (defmeth remove-method ((discriminator basic-discriminator) method)
  795.   (setf (method-discriminator method) nil)
  796.   (setf (discriminator-methods discriminator)
  797.     (delq method (discriminator-methods discriminator)))
  798.   (dolist (type-spec (method-type-specifiers method))
  799.     (remove-method-on-argument-specifier discriminator method type-spec))
  800.   (discriminator-changed discriminator method nil)
  801.   discriminator)
  802.  
  803.  
  804.  
  805. (defmeth add-method-on-argument-specifier
  806.      ((discriminator essential-discriminator)
  807.       (method essential-method)
  808.       argument-specifier)
  809.   (ignore method)
  810.   (when (classp argument-specifier)
  811.     (pushnew method
  812.          (class-direct-methods argument-specifier))
  813.     ;; This is a bug.  This needs to be split up into a method on
  814.     ;; essential class and a method on class or something.
  815.     (when (methods-combine-p discriminator)
  816.       (pushnew discriminator
  817.            (class-discriminators-which-combine-methods
  818.          argument-specifier)))))
  819.  
  820. (defmeth remove-method-on-argument-specifier
  821.      ((discriminator essential-discriminator)
  822.       (method essential-method)
  823.       argument-specifier)
  824.   (ignore method)
  825.   (when (classp argument-specifier)
  826.     (setf (class-direct-methods argument-specifier)
  827.       (delq method
  828.         (class-direct-methods argument-specifier)))
  829.     (when (methods-combine-p discriminator)
  830.       (setf (class-discriminators-which-combine-methods
  831.           argument-specifier)
  832.         (delq discriminator
  833.           (class-discriminators-which-combine-methods
  834.             argument-specifier))))))
  835.  
  836.  
  837. (defun make-specializable (function-name &rest options)
  838.   (when options (setq options (list* ':allow-other-keys t options)))
  839.   (keyword-bind ((arglist nil arglist-specified-p)
  840.          (discriminator-class 'discriminator)
  841.          (dispatch nil dispatch-p))
  842.         options
  843.     (cond ((not (null arglist-specified-p)))
  844.       ((fboundp 'function-arglist)
  845.        ;; function-arglist exists, get the arglist from it.
  846.        ;; Note: the funcall of 'function-arglist prevents
  847.        ;;       compiler warnings at least in some lisps.
  848.        (setq arglist (funcall 'function-arglist function-name)))
  849.       ((fboundp function-name)
  850.        (error
  851.          "The :arglist argument to make-specializable was not supplied~%~
  852.               and there is no version of FUNCTION-ARGLIST defined for this~%~
  853.               port of Portable CommonLoops.~%~
  854.               You must either define a version of FUNCTION-ARGLIST (which~%~
  855.               should be easy), and send it off to the Portable CommonLoops~%~
  856.               people or you should call make-specializable again with the~%~
  857.               function's arglist as its second argument.")))
  858.     (setq dispatch
  859.       (if dispatch-p
  860.           (iterate ((disp in dispatch))
  861.         (unless (memq disp arglist)
  862.           (error "There is a symbol in the :dispatch argument (~S)~%~
  863.                           which isn't in the arglist."))
  864.         (collect (position disp arglist)))
  865.           :default))
  866.     (let ((discriminator-class-object
  867.         (if (classp discriminator-class)
  868.         discriminator-class
  869.         (class-named discriminator-class t)))
  870.       (discriminator nil))
  871.       (if (null discriminator-class-object)
  872.       (error
  873.         "The :DISCRIMINATOR-CLASS argument to make-specializable is ~S~%~
  874.              but there is no class by that name."
  875.         discriminator-class)
  876.       (setq discriminator             
  877.         (apply #'make discriminator-class-object
  878.                :name function-name
  879.                :dispatch-order dispatch
  880.                options)))
  881. ;     (setf (function-pretty-arglist function-name) arglist)
  882.       (if arglist-specified-p
  883.       (put-slot-always discriminator 'pretty-arglist arglist)
  884.       (remove-dynamic-slot discriminator 'pretty-arglist))
  885.       (setf (discriminator-named function-name) discriminator)
  886.       (when (fboundp function-name)
  887.     (add-named-method (class-prototype (class-named 'discriminator))
  888.               (class-prototype (class-named 'method))
  889.               function-name
  890.               arglist
  891.               ()
  892.               ()
  893.               (symbol-function function-name)))
  894.       discriminator)))
  895.  
  896.  
  897.  
  898.  
  899.  
  900. (defun update-pretty-arglist (discriminator method)
  901.   (setf (function-pretty-arglist
  902.       (or (discriminator-name discriminator)
  903.           (discriminator-discriminating-function discriminator)))
  904.     (or (get-slot-using-class (class-of discriminator) discriminator
  905.                   'pretty-arglist t ())
  906.         (method-arglist method))))
  907.  
  908. (defmeth discriminator-pretty-arglist ((discriminator basic-discriminator))
  909.   (or (get-slot-using-class (class-of discriminator) discriminator
  910.                 'pretty-arglist t ())
  911.       (let ((method (or (discriminator-default-method discriminator)
  912.             (car (discriminator-methods discriminator)))))
  913.     (and method (method-arglist method)))))
  914.  
  915. (defmeth ensure-selector-specializable ((proto-discriminator
  916.                        essential-discriminator)
  917.                      selector arglist)
  918.   (let ((discriminator (discriminator-named selector)))
  919.     (cond ((not (null discriminator)) discriminator)
  920.           ((or (not (fboundp selector))
  921.                (eq *error-when-defining-method-on-existing-function*
  922.            'bootstrapping))
  923.            (setf (discriminator-named selector)
  924.                  (make (class-of proto-discriminator) :name selector)))
  925.           ((null *error-when-defining-method-on-existing-function*)
  926.            (make-specializable selector
  927.                    :arglist arglist
  928.                    :discriminator-class (class-of
  929.                               proto-discriminator))
  930.            (discriminator-named selector))
  931.           (t
  932.            (error "Attempt to add a method to the lisp function ~S without~%~
  933.                    first calling make-specializable.  Before attempting to~
  934.                    define a method on ~S~% you should evaluate the form:~%~
  935.                    (~S '~S)"
  936.                   selector selector 'make-specializable selector)))))
  937.  
  938. (defmeth find-method (discriminator type-specifiers options &optional parse)
  939.   (iterate ((method in (discriminator-methods discriminator)))
  940.     (when (method-equal method
  941.             (if parse
  942.                 (parse-type-specifiers discriminator
  943.                            method
  944.                            type-specifiers)
  945.                 type-specifiers)
  946.             options)
  947.       (return method))))
  948.  
  949. (defmeth method-equal ((method basic-method) argument-specifiers options)
  950.   (and (equal options (method-options method))
  951.        (equal argument-specifiers (method-type-specifiers method))))
  952.  
  953.  
  954. (defmeth discriminator-default-method ((discriminator essential-discriminator))
  955.   (find-method discriminator () ()))
  956.  
  957. (defmeth install-discriminating-function ((discriminator
  958.                         essential-discriminator)
  959.                       where
  960.                       function
  961.                       &optional inhibit-compile-p)
  962.   (ignore discriminator)
  963.   (check-type where symbol "a symbol other than NIL")
  964.   (check-type function function "a funcallable object")
  965.   
  966.   (when (and (listp function)
  967.          (eq (car function) 'lambda)
  968.          (null inhibit-compile-p))
  969.     (setq function (compile nil function)))
  970.  
  971.   (if where
  972.       (setf (symbol-function where) function)
  973.       (setf (discriminator-discriminating-function discriminator) function)))
  974.  
  975.  
  976.   ;;   
  977. ;;;;;; Discriminator-Based caching.
  978.   ;;
  979. ;;; Methods are cached in a discriminator-based cache.  The cache is an N-key
  980. ;;; cache based on the number of specialized arguments the discriminator has.
  981. ;;; As yet the size of the cache does not change statically or dynamically.
  982. ;;; Because of this I allow myself the freedom of computing the mask at
  983. ;;; compile time and not even storing it in the discriminator.
  984.  
  985. (defvar *default-discriminator-cache-size* 8)
  986.  
  987. (defun make-discriminator-cache (&optional
  988.                   (size *default-discriminator-cache-size*))
  989.   (make-memory-block size))
  990.  
  991. (defun make-discriminator-cache-mask (discriminator-cache
  992.                       no-of-specialized-args)
  993.   (make-memory-block-mask (memory-block-size discriminator-cache)
  994.                           (+ no-of-specialized-args 1)))
  995.  
  996. (defmeth flush-discriminator-caches ((discriminator essential-discriminator))
  997.   (let ((cache (discriminator-cache discriminator)))
  998.     (when cache (clear-memory-block (discriminator-cache discriminator) 0))))
  999.  
  1000. (defmeth initialize-discriminator-cache ((self essential-discriminator)
  1001.                                             no-of-specialized-args)
  1002.   (ignore no-of-specialized-args)
  1003.   (unless (discriminator-cache self)
  1004.     (setf (discriminator-cache self) (make-discriminator-cache))))
  1005.  
  1006. (defmacro discriminator-cache-offset (mask &rest classes)
  1007.   `(logand ,mask
  1008.            ,@(iterate ((class in classes))
  1009.            (collect `(object-cache-no ,class ,mask)))))
  1010.  
  1011. (defmacro discriminator-cache-entry (cache offset offset-from-offset)
  1012.   `(memory-block-ref ,cache (+ ,offset ,offset-from-offset)))
  1013.  
  1014. (defmacro cache-method (cache mask method-function &rest classes)
  1015.   `(let* ((.offset. (discriminator-cache-offset ,mask ,@classes)))
  1016.      ;; Once again, we have to endure a little brain damage because we can't
  1017.      ;; count on having without-interrupts.  I suppose the speed loss isn't
  1018.      ;; too significant since this is only when we get a cache miss.
  1019.      (setf (discriminator-cache-entry ,cache .offset. 0) nil)
  1020.      ,@(iterate ((class in (cdr classes)) (key-no from 1))
  1021.          (collect `(setf (discriminator-cache-entry ,cache .offset. ,key-no)
  1022.              ,class)))
  1023.      (prog1
  1024.        (setf (discriminator-cache-entry ,cache .offset. ,(length classes))
  1025.          ,method-function)
  1026.        (setf (discriminator-cache-entry ,cache .offset. 0) ,(car classes)))))
  1027.  
  1028. (defmacro cached-method (var cache mask &rest classes)
  1029.   `(let ((.offset. (discriminator-cache-offset ,mask . ,classes)))
  1030.      (and ,@(iterate ((class in classes) (key-no from 0))
  1031.               (collect
  1032.                 `(eq (discriminator-cache-entry ,cache .offset. ,key-no)
  1033.              ,class)))
  1034.           (setq ,var (discriminator-cache-entry ,cache
  1035.                         .offset.
  1036.                         ,(length classes)))
  1037.           t)))
  1038.  
  1039. (defmeth make-caching-discriminating-function (discriminator lookup-function
  1040.                                   cache
  1041.                                   mask)
  1042.   (multiple-value-bind (required restp specialized-positions)
  1043.       (compute-discriminating-function-arglist-info discriminator)
  1044.     (funcall (get-templated-function-constructor
  1045.            'caching-discriminating-function
  1046.            required
  1047.            restp
  1048.            specialized-positions
  1049.            lookup-function)
  1050.              discriminator cache mask)))
  1051.  
  1052. (defun make-checking-discriminating-function (discriminator method-function
  1053.                                                             type-specs
  1054.                                 default-function)
  1055.   (multiple-value-bind (required restp)
  1056.       (compute-discriminating-function-arglist-info discriminator)
  1057.     (let ((check-positions
  1058.         (iterate ((type-spec in type-specs)
  1059.               (pos from 0))
  1060.           (collect (and (neq type-spec 't) pos)))))
  1061.       (apply (get-templated-function-constructor
  1062.            'checking-discriminating-function
  1063.            required
  1064.            restp
  1065.            (if default-function t nil)
  1066.            check-positions)
  1067.              discriminator method-function default-function type-specs))))
  1068.  
  1069.  
  1070.   ;;   
  1071. ;;;;;; 
  1072.   ;;   
  1073.  
  1074. (defvar *always-remake-discriminating-function* nil)
  1075.  
  1076. (defmeth make-discriminating-function ((discriminator
  1077.                      essential-discriminator))
  1078.   (let ((default (discriminator-default-method discriminator))
  1079.         (methods (discriminator-methods discriminator)))
  1080.     (cond ((null methods)
  1081.        (make-no-methods-discriminating-function discriminator))
  1082.       ((and default (null (cdr methods)))
  1083.            (make-default-method-only-discriminating-function discriminator))
  1084.           ((or (and default (null (cddr methods)))
  1085.            (and (null default) (null (cdr methods))))
  1086.            (make-single-method-only-discriminating-function discriminator))
  1087.           ((every #'(lambda (m)
  1088.                       (classical-type-specifiers-p
  1089.             (method-type-specifiers m)))
  1090.                   methods)
  1091.            (make-classical-methods-only-discriminating-function
  1092.          discriminator))
  1093.           (t
  1094.            (make-multi-method-discriminating-function discriminator)))))
  1095.  
  1096. (defmeth make-no-methods-discriminating-function (discriminator)
  1097.   (install-discriminating-function
  1098.     discriminator
  1099.     (discriminator-name discriminator)
  1100.     #'(lambda (&rest ignore)
  1101.     (error "There are no methods on the discriminator ~S,~%~
  1102.                 so it is an error to call it."
  1103.            discriminator))))
  1104.  
  1105. (defmeth make-default-method-only-discriminating-function
  1106.      ((self essential-discriminator))
  1107.   (install-discriminating-function
  1108.     self
  1109.     (discriminator-name self)
  1110.     (method-function (discriminator-default-method self))))
  1111.  
  1112. (defmeth make-single-method-only-discriminating-function
  1113.       ((self essential-discriminator))
  1114.   (let* ((methods (discriminator-methods self))
  1115.      (default (discriminator-default-method self))
  1116.      (method (if (eq (car methods) default)
  1117.              (cadr methods)
  1118.              (car methods)))
  1119.          (method-type-specifiers (method-type-specifiers method))
  1120.          (method-function (method-function method)))
  1121.     (install-discriminating-function
  1122.       self
  1123.       (discriminator-name self)
  1124.       (make-checking-discriminating-function
  1125.     self
  1126.     method-function
  1127.     method-type-specifiers
  1128.     (and default (method-function default))))))
  1129.  
  1130. (defmeth make-classical-methods-only-discriminating-function
  1131.       ((self essential-discriminator))
  1132.   (initialize-discriminator-cache self 1)
  1133.   (let ((default-method (discriminator-default-method self))
  1134.     (methods (discriminator-methods self)))
  1135.     (setf (discriminator-classical-method-table self)
  1136.       (cons (and default-method (method-function default-method))
  1137.         (iterate ((method in methods))
  1138.           (unless (eq method default-method)
  1139.             (collect (cons (car (method-type-specifiers method))
  1140.                    (method-function method))))))))
  1141.   (let* ((cache (discriminator-cache self))
  1142.      (mask (make-discriminator-cache-mask cache 1)))
  1143.     (install-discriminating-function
  1144.       self
  1145.       (discriminator-name self)
  1146.       (make-caching-discriminating-function
  1147.     self 'lookup-classical-method cache mask))))
  1148.  
  1149. (defun lookup-classical-method (discriminator class)
  1150.   ;; There really should be some sort of more sophisticated protocol going
  1151.   ;; on here.  Compare type-specifiers and all that.
  1152.   (let* ((classical-method-table
  1153.        (get-slot--class discriminator 'classical-method-table)))
  1154.     (or (iterate ((super in (get-slot--class class 'class-precedence-list)))
  1155.           (let ((hit (assq super (cdr classical-method-table))))
  1156.             (when hit (return (cdr hit)))))
  1157.     (car classical-method-table))))
  1158.  
  1159. (defmeth make-multi-method-discriminating-function
  1160.       ((self essential-discriminator))
  1161.   (multiple-value-bind (required restp specialized)
  1162.       (compute-discriminating-function-arglist-info self)
  1163.     (ignore required restp)
  1164.     (initialize-discriminator-cache self (length specialized))
  1165.     (let* ((cache (discriminator-cache self))
  1166.        (mask (make-discriminator-cache-mask cache (length specialized))))
  1167.       (install-discriminating-function
  1168.     self
  1169.     (discriminator-name self)
  1170.     (make-caching-discriminating-function
  1171.       self 'lookup-multi-method cache mask)))))
  1172.  
  1173. (defvar *lookup-multi-method-internal*
  1174.     (make-array (min 256. call-arguments-limit)))
  1175.  
  1176. (defun lookup-multi-method-internal (discriminator classes)
  1177.   (let* ((methods (discriminator-methods discriminator))
  1178.      (cpls *lookup-multi-method-internal*)
  1179.      (order (get-slot--class discriminator 'dispatch-order))
  1180.          (most-specific-method nil)
  1181.          (most-specific-type-specs ())
  1182.      (type-specs ()))
  1183.     ;; Put all the class-precedence-lists in a place where we can save
  1184.     ;; them as we look through all the methods.
  1185.     (without-interrupts
  1186.       (iterate ((class in classes)
  1187.         (i from 0))
  1188.     (setf (svref cpls i) (get-slot--class class 'class-precedence-list)))
  1189.       (dolist (method methods)
  1190.     (setq type-specs (get-slot--class method 'type-specifiers))
  1191.     (when (iterate ((type-spec in  type-specs)
  1192.             (i from 0))
  1193.         (or (eq type-spec 't)
  1194.             (memq type-spec (svref cpls i))
  1195.             (return nil))
  1196.         (finally (return t)))
  1197.       (if (null most-specific-method)
  1198.           (setq most-specific-method method
  1199.             most-specific-type-specs type-specs)
  1200.           (case (compare-type-specifier-lists
  1201.               most-specific-type-specs type-specs nil
  1202.               () classes order)
  1203.         (2 (setq most-specific-method method
  1204.              most-specific-type-specs type-specs))
  1205.         (1))))))
  1206.     (or most-specific-method
  1207.     (discriminator-default-method discriminator))))
  1208.  
  1209. (defun lookup-multi-method (discriminator &rest classes)
  1210.   (declare (inline lookup-multi-method-internal))
  1211.   (let ((method (lookup-multi-method-internal discriminator classes)))
  1212.     (and method (method-function method))))
  1213.  
  1214. (defun lookup-method (discriminator &rest classes)
  1215.   (declare (inline lookup-multi-method-internal))
  1216.   (lookup-multi-method-internal discriminator classes))
  1217.  
  1218.   ;;   
  1219. ;;;;;; Code for parsing arglists (in the usual case).
  1220.   ;;   (when discriminator is class DISCRIMINATOR and method is class METHOD)
  1221. ;;;
  1222. ;;; arglist-type-specifiers
  1223. ;;; Given an arglist this returns its type-specifiers.  Trailing T's (both
  1224. ;;; implicit and explicit) are dropped.  The type specifiers are returned as
  1225. ;;; they are found in the arglist, they are not parsed into internal
  1226. ;;; type-specs.
  1227. ;;;
  1228. (defmeth arglist-type-specifiers ((proto-disc basic-discriminator)
  1229.                   (proto-meth basic-method)
  1230.                   arglist)
  1231.   (let ((arg (car arglist)))
  1232.     (and arglist
  1233.          (not (memq arg '(&optional &rest &key &aux)))  ;Don't allow any
  1234.                                                         ;type-specifiers
  1235.                                                     ;after one of these.
  1236.          (let ((tail (arglist-type-specifiers proto-disc
  1237.                           proto-meth
  1238.                           (cdr arglist)))
  1239.                (type-spec (and (listp arg) (cadr arg))))
  1240.            (or (and tail (cons (or type-spec 't) tail))
  1241.                (and type-spec (cons type-spec ())))))))
  1242.  
  1243. ;;; arglist-without-type-specifiers
  1244. ;;; Given an arglist remove the type specifiers.
  1245. ;;; 
  1246. (defmeth arglist-without-type-specifiers ((proto-disc basic-discriminator)
  1247.                       (proto-meth basic-method)
  1248.                       arglist)
  1249.   (let ((arg (car arglist)))
  1250.     (and arglist
  1251.          (if (memq arg '(&optional &rest &key &aux))    ;don't allow any
  1252.                                                         ;type-specifiers
  1253.                                                         ;after one of these.
  1254.              arglist
  1255.              (cons (if (listp arg) (car arg) arg)
  1256.                    (arglist-without-type-specifiers proto-disc
  1257.                             proto-meth
  1258.                             (cdr arglist)))))))
  1259.  
  1260. (defmeth arglist-args ((discriminator-class basic-discriminator)
  1261.                (method-class basic-method)
  1262.                arglist)
  1263.   (and arglist
  1264.        (cond ((eq (car arglist) '&aux) ())
  1265.              ((memq (car arglist) '(&optional &rest &key))
  1266.               (arglist-args discriminator-class method-class (cdr arglist)))
  1267.              (t
  1268.               ;; This plays on the fact that no type specifiers are allowed
  1269.           ;; on arguments that can have default values.
  1270.               (cons (if (listp (car arglist)) (caar arglist) (car arglist))
  1271.                     (arglist-args discriminator-class
  1272.                   method-class
  1273.                   (cdr arglist)))))))
  1274.  
  1275. (defmeth parse-type-specifiers ((proto-discriminator basic-discriminator)
  1276.                 (proto-method basic-method)
  1277.                 type-specifiers)
  1278.   (iterate ((type-specifier in type-specifiers))
  1279.     (collect (parse-type-specifier proto-discriminator
  1280.                    proto-method
  1281.                    type-specifier))))
  1282.  
  1283. (defmeth parse-type-specifier ((proto-discriminator basic-discriminator)
  1284.                                 (proto-method basic-method)
  1285.                                 type-specifier)
  1286.   (ignore proto-discriminator proto-method)
  1287.   (cond ((eq type-specifier 't) 't)
  1288.         ((symbolp type-specifier)
  1289.          (or (class-named type-specifier nil)
  1290.              (error
  1291.            "~S used as a type-specifier, but is not the name of a class."
  1292.            type-specifier)))
  1293.         ((classp type-specifier) type-specifier)
  1294.         (t (error "~S is not a legal type-specifier." type-specifier))))
  1295.  
  1296. (defmeth unparse-type-specifiers ((method essential-method))
  1297.   (iterate ((parsed-type-spec in (method-type-specifiers method)))
  1298.     (collect (unparse-type-specifier method parsed-type-spec))))
  1299.  
  1300. (defmeth unparse-type-specifier ((method essential-method) type-spec)
  1301.   (ignore method)
  1302.   (if (classp type-spec)
  1303.       (class-name type-spec)
  1304.       type-spec))
  1305.  
  1306. (defun classical-type-specifiers-p (typespecs)
  1307.   (or (null typespecs)
  1308.       (and (classp (car typespecs))
  1309.            (null (cdr typespecs)))))
  1310.  
  1311. ;;;
  1312. ;;; Compute various information about a discriminator's arglist by looking at
  1313. ;;; the argument lists of the methods.  The hair for trying not to use &rest
  1314. ;;; arguments lives here.
  1315. ;;;  The values returned are:
  1316. ;;;    number-of-required-arguments
  1317. ;;;       the number of required arguments to this discrimator's
  1318. ;;;       discriminating function
  1319. ;;;    &rest-argument-p
  1320. ;;;       whether or not this discriminator's discriminating
  1321. ;;;       function takes an &rest argument.
  1322. ;;;    specialized-argument-positions
  1323. ;;;       a list of the positions of the arguments this discriminator
  1324. ;;;       specializes (e.g. for a classical discrimator this is the
  1325. ;;;       list: (1)).
  1326. ;;;
  1327. ;;; As usual, it is legitimate to specialize the -internal function that is
  1328. ;;; why I put it there, since I certainly could have written this more
  1329. ;;; efficiently if I didn't want to provide that extensibility.
  1330. ;;; 
  1331. (defmeth compute-discriminating-function-arglist-info
  1332.      ((discriminator essential-discriminator)
  1333.       &optional (methods () methods-p))
  1334.   (declare (values number-of-required-arguments
  1335.                    &rest-argument-p
  1336.                    specialized-argument-postions))
  1337.   (unless methods-p
  1338.     (setq methods (discriminator-methods discriminator)))
  1339.   (let ((number-required nil)
  1340.         (restp nil)
  1341.         (specialized-positions ()))
  1342.     (iterate ((method in methods))
  1343.       (multiple-value-setq (number-required restp specialized-positions)
  1344.         (compute-discriminating-function-arglist-info-internal
  1345.       discriminator method number-required restp specialized-positions)))
  1346.     (values number-required restp (sort specialized-positions #'<))))
  1347.  
  1348. (defmeth compute-discriminating-function-arglist-info-internal
  1349.      ((discriminator essential-discriminator)
  1350.       (method essential-method)
  1351.       number-of-requireds restp specialized-argument-positions)
  1352.   (ignore discriminator)
  1353.   (let ((requireds 0))
  1354.     ;; Go through this methods arguments seeing how many are required,
  1355.     ;; and whether there is an &rest argument.
  1356.     (iterate ((arg in (method-arglist method)))
  1357.       (cond ((eq arg '&aux) (return))
  1358.             ((memq arg '(&optional &rest &key))
  1359.              (return (setq restp t)))
  1360.         ((memq arg lambda-list-keywords))
  1361.             (t (incf requireds))))
  1362.     ;; Now go through this method's type specifiers to see which
  1363.     ;; argument positions are type specified.  Treat T specially
  1364.     ;; in the usual sort of way.  For efficiency don't bother to
  1365.     ;; keep specialized-argument-positions sorted, rather depend
  1366.     ;; on our caller to do that.
  1367.     (iterate ((type-spec in (method-type-specifiers method))
  1368.               (pos from 0))
  1369.       (unless (eq type-spec 't)
  1370.     (pushnew pos specialized-argument-positions)))
  1371.     ;; Finally merge the values for this method into the values
  1372.     ;; for the exisiting methods and return them.  Note that if
  1373.     ;; num-of-requireds is NIL it means this is the first method
  1374.     ;; and we depend on that.
  1375.     (values (min (or number-of-requireds requireds) requireds)
  1376.             (or restp
  1377.         (and number-of-requireds (/= number-of-requireds requireds)))
  1378.             specialized-argument-positions)))
  1379.  
  1380. (defun make-discriminating-function-arglist (number-required-arguments restp)
  1381.   (iterate ((i from 0 below number-required-arguments))
  1382.     (collect (intern (format nil "Discriminating Function Arg ~D" i)))
  1383.     (finally (when restp
  1384.                (collect '&rest)
  1385.                (collect (intern "Discriminating Function &rest Arg"))))))
  1386.  
  1387. (defmeth compare-methods (discriminator method-1 method-2)
  1388.   (ignore discriminator)
  1389.   (let ((compare ()))
  1390.     (iterate ((ts-1 in (method-type-specifiers method-1))
  1391.           (ts-2 in (method-type-specifiers method-2)))
  1392.       (cond ((eq ts-1 ts-2) (setq compare '=))
  1393.         ((eq ts-1 't)   (setq compare method-2))
  1394.         ((eq ts-2 't)   (setq compare method-1))        
  1395.         ((memq ts-1 (class-class-precedence-list ts-2))
  1396.          (setq compare method-2))
  1397.         ((memq ts-2 (class-class-precedence-list ts-1))
  1398.          (setq compare method-1))
  1399.         (t (return nil)))
  1400.       (finally (return compare)))))
  1401.  
  1402.   ;;   
  1403. ;;;;;; Comparing type-specifiers, statically or wrt an object.
  1404.   ;;
  1405. ;;; compare-type-specifier-lists compares two lists of type specifiers
  1406. ;;; compare-type-specifiers compare two type specifiers
  1407. ;;; If static-p it t the comparison is done statically, otherwise it is
  1408. ;;; done with respect to object(s).  The value returned is:
  1409. ;;;    1    if type-spec-1 is more specific
  1410. ;;;    2    if type-spec-2 is more specific
  1411. ;;;    =    if they are equal
  1412. ;;;    NIL  if they cannot be disambiguated
  1413. ;;;
  1414. (defun compare-type-specifier-lists (type-spec-list-1
  1415.                      type-spec-list-2
  1416.                      staticp
  1417.                      args
  1418.                      classes
  1419.                      order)
  1420.   (when (or type-spec-list-1 type-spec-list-2)
  1421.     (ecase (compare-type-specifiers (or (car type-spec-list-1) t)
  1422.                                     (or (car type-spec-list-2) t)
  1423.                                     staticp
  1424.                                     (car args)
  1425.                                     (car classes))
  1426.       (1 '1)
  1427.       (2 '2)
  1428.       (= (if (eq order :default)
  1429.          (compare-type-specifier-lists (cdr type-spec-list-1)
  1430.                        (cdr type-spec-list-2)
  1431.                        staticp
  1432.                        (cdr args)
  1433.                        (cdr classes)
  1434.                        order)
  1435.          (compare-type-specifier-lists (nth (car order) type-spec-list-1)
  1436.                        (nth (car order) type-spec-list-2)
  1437.                        staticp
  1438.                        (cdr args)
  1439.                        (cdr classes)
  1440.                        (cdr order))))
  1441.         
  1442.       (nil
  1443.         (unless staticp
  1444.           (error "The type specifiers ~S and ~S can not be disambiguated~
  1445.                   with respect to the argument: ~S"
  1446.                  (or (car type-spec-list-1) t)
  1447.                  (or (car type-spec-list-2) t)
  1448.                  (car args)
  1449.                  (car classes)))))))
  1450.  
  1451. (defun compare-type-specifiers (type-spec-1 type-spec-2 staticp arg class)
  1452.   (cond ((equal type-spec-1 type-spec-2) '=)
  1453.         ((eq type-spec-2 t) '1)
  1454.         ((eq type-spec-1 t) '2)
  1455.         ((and (classp type-spec-1) (classp type-spec-2))
  1456. ;        (if staticp
  1457. ;            (if (common-subs type-spec-1 type-spec-2)
  1458. ;                nil
  1459. ;                (let ((supers (common-supers type-spec-1 type-spec-2)))
  1460. ;                  (cond ((cdr supers) nil)
  1461. ;                        ((eq (car supers) type-spec-1) '2)
  1462. ;                        ((eq (car supers) type-spec-2) '1)
  1463. ;                        (t 'disjoint))))
  1464.              (iterate ((super in (class-class-precedence-list (or class (class-of arg)))))
  1465.                (cond ((eq super type-spec-1)
  1466.                       (return '1))
  1467.                      ((eq super type-spec-2)
  1468.                       (return '2)))))
  1469. ;)
  1470.         (t
  1471.          (compare-complex-type-specifiers type-spec-1 type-spec-2 staticp arg class))))
  1472.  
  1473. (defun compare-complex-type-specifiers (type-spec-1 type-spec-2 static-p arg class)
  1474.   (ignore type-spec-1 type-spec-2 static-p arg class)
  1475.   (error "Complex type specifiers are not yet supported."))
  1476.  
  1477. (defmeth no-matching-method (discriminator)
  1478.   (let ((class-of-discriminator (class-of discriminator)))
  1479.     (if (eq (class-of class-of-discriminator) (class-named 'class))
  1480.         ;; The meta-class of the discriminator is class, we can get at
  1481.         ;; it's name slot without doing any method lookup.
  1482.         (let ((name (get-slot--class discriminator 'name)))
  1483.           (if (and name (symbolp name))
  1484.               (error "No matching method for: ~S." name)
  1485.               (error "No matching method for the anonymous discriminator: ~S."
  1486.                      discriminator)))
  1487.         (error "No matching method for the discriminator: ~S." discriminator))))
  1488.   ;;   
  1489. ;;;;;; Optimizing GET-SLOT
  1490.   ;;   
  1491.  
  1492. (defmeth method-argument-class ((method basic-method) argument)
  1493.   (let* ((arglist (method-arglist method))
  1494.          (position (position argument arglist)))
  1495.     (and position (nth position (method-type-specifiers method)))))
  1496.  
  1497.  
  1498. (defmeth optimize-get-slot ((class basic-class)
  1499.                 form)
  1500.   (declare (ignore class))
  1501.   (cons 'get-slot--class (cdr form)))
  1502.  
  1503. (defmeth optimize-setf-of-get-slot ((class basic-class)
  1504.                     form)
  1505.   (declare (ignore class))
  1506.   (cons 'put-slot--class (cdr form)))
  1507. @EOF
  1508. if test "`wc -lwc <methods.l`" != '   1118   3675  42045'
  1509. then
  1510.     echo ERROR: wc results of methods.l are `wc -lwc <methods.l` should be 1118   3675  42045
  1511. fi
  1512.  
  1513. chmod 755 methods.l
  1514.  
  1515. exit 0
  1516.