home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part12 / methods.l
Encoding:
Text File  |  1987-08-23  |  41.1 KB  |  1,119 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26.  
  27. (in-package 'pcl)
  28.  
  29.   ;;   
  30. ;;;;;; Methods
  31.   ;;   
  32.  
  33. (ndefstruct (essential-method
  34.           (:class class)
  35.           (:conc-name method-))
  36.   (discriminator nil)
  37.   (arglist ())
  38.   (type-specifiers ())
  39.   (function nil))
  40.  
  41. (ndefstruct (combinable-method-mixin (:class class)))
  42.  
  43. (ndefstruct (basic-method
  44.           (:class class)
  45.           (:include (essential-method))
  46.           (:constructor make-method-1)
  47.           (:conc-name method-))
  48.   (function nil)
  49.   (discriminator nil)
  50.   (type-specifiers ())
  51.   (arglist ())
  52.   (options () :allocation :dynamic))
  53.  
  54. (ndefstruct (method (:class class)
  55.             (:include (combinable-method-mixin
  56.                    basic-method))))
  57.  
  58.  
  59. (ndefstruct (essential-discriminator
  60.           (:class class)
  61.           (:conc-name discriminator-))
  62.   (name nil)
  63.   (methods ())
  64.   (discriminating-function ())
  65.   (classical-method-table nil :allocation :dynamic)
  66.   (cache ()))
  67.  
  68. (ndefstruct (method-combination-mixin (:class class)
  69.                       (:conc-name nil))
  70.   (method-combination-type :daemon)
  71.   (method-combination-parameters ())
  72.   (methods-combine-p ())
  73.   )
  74.  
  75. (ndefstruct (basic-discriminator
  76.           (:class class)
  77.           (:include (essential-discriminator))
  78.           (:constructor make-discriminator-1)
  79.           (:conc-name discriminator-))
  80.  
  81.   (dispatch-order :default)  
  82.   (inactive-methods () :allocation :dynamic))
  83.  
  84. (ndefstruct (discriminator (:class class)
  85.                (:include (method-combination-mixin
  86.                       basic-discriminator)))
  87.   )
  88.  
  89. ;;;
  90. ;;; This is really just for bootstrapping, of course this isn't all
  91. ;;; worked out yet.  But this SHOULD really just be for bootstrapping.
  92. ;;; 
  93. (defmeth method-causes-combination-p ((method basic-method))
  94.   (ignore method)
  95.   ())
  96.  
  97.   ;;   
  98. ;;;;;; 
  99.   ;;   
  100.  
  101.  
  102. (defun real-expand-defmeth (name&options arglist body)
  103.   (unless (listp name&options) (setq name&options (list name&options)))
  104.   (keyword-parse ((discriminator-class 'discriminator)
  105.                   (method-class 'method))
  106.                  (cdr name&options)
  107.     (dolist (x '(:discriminator-class :method-class))
  108.       (delete x name&options :test #'(lambda (x y)
  109.                        (and (listp y) (eq (car y) x)))))
  110.     (let ((discriminator-class-object (class-named discriminator-class t))
  111.           (method-class-object (class-named method-class t)))
  112.       (or discriminator-class-object        ;
  113.           (error
  114.         "The :DISCRIMINATOR-CLASS option to defmeth was used to specify~
  115.              that the class~%of the discriminator should be ~S;~%~
  116.              but there is no class named ~S."
  117.         discriminator-class
  118.         discriminator-class))
  119.       (or method-class-object
  120.           (error "The :METHOD-CLASS option to defmeth was used to specify~%~
  121.                   that the class of the method should be ~S;~%~
  122.                   but there is no class named ~S."
  123.                  method-class
  124.                  method-class))
  125.       (expand-defmeth-internal (class-prototype discriminator-class-object)
  126.                    (class-prototype method-class-object)
  127.                    name&options
  128.                    arglist
  129.                    body))))
  130.  
  131. (defvar *method-being-defined*)
  132.  
  133. (defmeth expand-defmeth-internal ((proto-discriminator basic-discriminator)
  134.                   (proto-method basic-method)
  135.                   name&options arglist body)
  136.   (keyword-parse ((setf () setf-specified-p))
  137.                  (cdr name&options)
  138.     (let* ((discriminator-class-name (class-name
  139.                        (class-of proto-discriminator)))
  140.            (method-class-name (class-name (class-of proto-method)))
  141.            (name (car name&options))
  142.            (merged-arglist (cons (car arglist) (append setf (cdr arglist))))
  143.            (merged-args (arglist-without-type-specifiers proto-discriminator
  144.                                                          proto-method
  145.                                                          merged-arglist))
  146.            (merged-type-specifiers
  147.          (defmethod-argument-specializers arglist))
  148.            discriminator-name
  149.            method-name
  150.        (defmethod-uid (gensym))
  151.        (load-method-1 ())
  152.        (documentation ())
  153.        (declarations ()))
  154.       (if setf-specified-p
  155.       (setq discriminator-name (make-setf-discriminator-name name)
  156.         method-name (make-setf-method-name name
  157.                            (arglist-type-specifiers
  158.                              proto-discriminator
  159.                              proto-method
  160.                              setf)
  161.                            merged-type-specifiers))
  162.       (setq discriminator-name name
  163.         method-name (make-method-name name
  164.                           merged-type-specifiers)))
  165.       (multiple-value-setq (documentation declarations body)
  166.     (extract-declarations body))
  167.       (setq load-method-1 `(,discriminator-class-name
  168.                 ,method-class-name
  169.                 ,discriminator-name
  170.                 ,merged-type-specifiers
  171.                 ,merged-args
  172.                 ,(cdr name&options)))
  173.       ;;
  174.       ;; There are 4 cases:
  175.       ;;   - evaluated
  176.       ;;   - compiled to core
  177.       ;;   - compiled to file
  178.       ;;   - loading the compiled file
  179.       ;;
  180.       ;; When loading a method which has a run-super in it, there is no way
  181.       ;; to know which of two events will happen first:
  182.       ;;   1. the load-time-eval form in the run super will be
  183.       ;;      evaluated first, or
  184.       ;;   2. the function to install the loaded method (defmethod-uid)
  185.       ;;      will be evaluated first.
  186.       ;; consequently, both the special function (defmethod-uid) and the
  187.       ;; expansion of run-super must check to see if the other has already
  188.       ;; run and set the value of defmethod-uid to the method involved.
  189.       ;; This is what causes the boundp checks of defmethod-uid each time
  190.       ;; before it is set.
  191.       ;; 
  192.       `(progn
  193.      
  194.      (eval-when (eval load)
  195.        
  196.        (defun ,defmethod-uid ()
  197.          (declare (special ,defmethod-uid))
  198.          (unless (boundp ',defmethod-uid)
  199.            (setq ,defmethod-uid (apply #'load-method-1
  200.                        ',load-method-1)))
  201.          ,@(and *real-methods-exist-p*
  202.             `((record-definition
  203.             ',discriminator-name 'method
  204.             ',merged-type-specifiers ',(cdr name&options))
  205.               (setf (symbol-function ',method-name)
  206.                 #'(lambda ,merged-args
  207.                 ,@documentation
  208.                 ,@declarations
  209.                 (declare (method-function-name ,method-name))
  210.                 ,(wrap-method-body
  211.                    proto-discriminator
  212.                    (apply 'compile-method-1 load-method-1)
  213.                    discriminator-name
  214.                    defmethod-uid
  215.                    load-method-1
  216.                    body)
  217.                 ))))
  218.          
  219.          (setf (method-function ,defmethod-uid)
  220.            (symbol-function ',method-name))
  221.          
  222.          (add-method (discriminator-named ',discriminator-name)
  223.              ,defmethod-uid
  224.              ()))
  225.        
  226.        (,defmethod-uid))
  227.      
  228.      (eval-when (compile load eval)
  229.        
  230.        ,@(and setf-specified-p
  231.           `((record-definition
  232.               ',name 'defsetf ',discriminator-name 'defmeth)
  233.             (defsetf ,name
  234.                  ,(arglist-without-type-specifiers
  235.                 proto-discriminator proto-method arglist)
  236.                  ,(arglist-without-type-specifiers
  237.                 proto-discriminator proto-method setf)
  238.               (list ',discriminator-name ,@(arglist-args
  239.                              proto-discriminator
  240.                              proto-method
  241.                              merged-args)))))
  242.        
  243.        ',discriminator-name)))))
  244.  
  245. (defmethod wrap-method-body ((mex-generic-function discriminator)
  246.                  (mex-method method)
  247.                  generic-function-name
  248.                  method-uid
  249.                  load-method-1-args
  250.                  body)
  251.   (let ((macroexpand-time-information (list mex-generic-function
  252.                         mex-method
  253.                         generic-function-name
  254.                         method-uid
  255.                         load-method-1-args)))
  256.     `(macrolet ,(iterate (((name arglist params fn) in *method-body-macros*))
  257.           (collect `(,name ,arglist
  258.                    (funcall (function ,fn)
  259.                     ',macroexpand-time-information
  260.                     ,@params))))
  261.        (block ,generic-function-name
  262.      . ,body))))
  263.  
  264. (defun macroexpand-time-generic-function (mti) (nth 0 mti))
  265.  
  266. (defun macroexpand-time-method (mti) (nth 1 mti))
  267.  
  268. (defun macroexpand-time-generic-function-name (mti) (nth 2 mti))
  269.  
  270. (defun macroexpand-time-method-uid (mti) (nth 3 mti))
  271.  
  272. (defun macroexpand-time-load-method-1-args (mti) (nth 4 mti))
  273.  
  274.  
  275. (defun load-method-1 (discriminator-class-name
  276.                method-class-name
  277.                discriminator-name
  278.                method-type-specifiers
  279.               method-arglist
  280.               options)
  281.   (let* ((discriminator
  282.        (ensure-selector-specializable
  283.          (class-prototype (class-named discriminator-class-name))
  284.          discriminator-name
  285.          method-arglist))
  286.      (method
  287.        (or (find-method discriminator method-type-specifiers options t)
  288.            (make method-class-name))))
  289.     (setf (method-arglist method) method-arglist)
  290.     (setf (method-type-specifiers method)
  291.       (parse-type-specifiers
  292.         discriminator method method-type-specifiers))
  293.     (setf (method-options method) options)
  294.     method))
  295.  
  296. (defun compile-method-1 (discriminator-class-name
  297.              method-class-name
  298.              discriminator-name
  299.              method-type-specifiers
  300.              method-arglist
  301.              options)
  302.   (ignore discriminator-name)
  303.   (let ((method (make method-class-name)))
  304.     (setf (method-arglist method) method-arglist)
  305.     (setf (method-type-specifiers method)
  306.           (parse-type-specifiers
  307.         (class-prototype (class-named discriminator-class-name))
  308.         method
  309.         method-type-specifiers))
  310.     (setf (method-options method) options)
  311.     method))
  312.  
  313.  
  314.  
  315. (defmeth add-named-method ((proto-discriminator essential-discriminator)
  316.                (proto-method essential-method)
  317.                discriminator-name
  318.                arglist
  319.                type-specs
  320.                extra
  321.                function)
  322.   ;; What about changing the class of the discriminator if there is
  323.   ;; one.  Whose job is that anyways.  Do we need something kind of
  324.   ;; like class-for-redefinition?
  325.   (let* ((discriminator
  326.        ;; Modulo bootstrapping hair, this is just:
  327.        ;;   (or (discriminator-named ..)
  328.        ;;       (make-specializable))
  329.        (ensure-selector-specializable proto-discriminator
  330.                       discriminator-name
  331.                       arglist))
  332.      (existing (find-method discriminator type-specs extra t))
  333.      (method (or existing
  334.              (make (class-of proto-method)))))
  335.     (when existing (change-class method (class-of proto-method)))
  336.     (setf (method-arglist method) arglist)
  337.     (setf (method-function method) function)
  338.     (setf (method-type-specifiers method) type-specs)
  339.     (add-method discriminator method extra)))
  340.  
  341. (defmeth add-method ((discriminator essential-discriminator)
  342.              (method essential-method)
  343.              extra)
  344.   (ignore extra)
  345.   (let ((type-specs (method-type-specifiers method))
  346.        ;(options (method-options method))
  347.        ;(methods (discriminator-methods discriminator))
  348.     )
  349.     (setf (method-discriminator method) discriminator)
  350. ;    ;; Put the new method where it belongs, either:
  351. ;    ;;  - The same (EQ) method object is already on discriminator-methods
  352. ;    ;;    of the discriminator so we don't need to do anything to put the
  353. ;    ;;    new methods where it belongs.
  354. ;    ;;  - There is an method on discriminator-methods which is equal to
  355. ;    ;;    the new method (according to METHOD-EQUAL).  In this case, we
  356. ;    ;;    replace the existing method with the new one.
  357. ;    ;;  - We just add the new method to discriminator-methods by pushing
  358. ;    ;;    it onto that list.
  359. ;    (unless (memq method methods)
  360. ;      (do* ((tail (discriminator-methods discriminator) (cdr tail))
  361. ;        (existing-method (car tail) (car tail)))
  362. ;       ((cond ((null existing-method)         
  363. ;           (push method (discriminator-methods discriminator)))
  364. ;          ((method-equal existing-method type-specs options)
  365. ;           (remove-method discriminator existing-method)
  366. ;           (return (add-method discriminator method))))
  367. ;        
  368. ;        (when (method-causes-combination-p method)             ;NOT part of
  369. ;          (pushnew method (methods-combine-p discriminator)));standard
  370. ;                                         ;protocol.
  371. ;        (dolist (argument-specifier type-specs)
  372. ;          (add-method-on-argument-specifier discriminator
  373. ;                        method
  374. ;                        argument-specifier)))
  375. ;    ()))
  376.     (pushnew method (discriminator-methods discriminator))
  377.     (dolist (argument-specifier type-specs)
  378.       (add-method-on-argument-specifier discriminator
  379.                     method
  380.                     argument-specifier)))
  381.     (discriminator-changed discriminator method t)
  382.     (update-pretty-arglist discriminator method)    ;NOT part of
  383.                                 ;standard protocol.
  384.     ())
  385.  
  386.  
  387. (defmeth remove-named-method (discriminator-name
  388.                   argument-specifiers
  389.                   &optional extra)
  390.   (let ((discriminator ())
  391.     (method ()))
  392.     (cond ((null (setq discriminator (discriminator-named
  393.                        discriminator-name)))
  394.        (error "There is no discriminator named ~S." discriminator-name))
  395.       ((null (setq method (find-method discriminator
  396.                        argument-specifiers 
  397.                        extra
  398.                        t)))
  399.        (error "There is no method for the discriminator ~S~%~
  400.                    which matches the argument-specifiers ~S."
  401.           discriminator
  402.           argument-specifiers))
  403.       (t
  404.        (remove-method discriminator method)))))
  405.  
  406. (defmeth remove-method ((discriminator basic-discriminator) method)
  407.   (setf (method-discriminator method) nil)
  408.   (setf (discriminator-methods discriminator)
  409.     (delq method (discriminator-methods discriminator)))
  410.   (dolist (type-spec (method-type-specifiers method))
  411.     (remove-method-on-argument-specifier discriminator method type-spec))
  412.   (discriminator-changed discriminator method nil)
  413.   discriminator)
  414.  
  415.  
  416.  
  417. (defmeth add-method-on-argument-specifier
  418.      ((discriminator essential-discriminator)
  419.       (method essential-method)
  420.       argument-specifier)
  421.   (ignore method)
  422.   (when (classp argument-specifier)
  423.     (pushnew method
  424.          (class-direct-methods argument-specifier))
  425.     ;; This is a bug.  This needs to be split up into a method on
  426.     ;; essential class and a method on class or something.
  427.     (when (methods-combine-p discriminator)
  428.       (pushnew discriminator
  429.            (class-discriminators-which-combine-methods
  430.          argument-specifier)))))
  431.  
  432. (defmeth remove-method-on-argument-specifier
  433.      ((discriminator essential-discriminator)
  434.       (method essential-method)
  435.       argument-specifier)
  436.   (ignore method)
  437.   (when (classp argument-specifier)
  438.     (setf (class-direct-methods argument-specifier)
  439.       (delq method
  440.         (class-direct-methods argument-specifier)))
  441.     (when (methods-combine-p discriminator)
  442.       (setf (class-discriminators-which-combine-methods
  443.           argument-specifier)
  444.         (delq discriminator
  445.           (class-discriminators-which-combine-methods
  446.             argument-specifier))))))
  447.  
  448.  
  449. (defun make-specializable (function-name &rest options)
  450.   (when options (setq options (list* ':allow-other-keys t options)))
  451.   (keyword-bind ((arglist nil arglist-specified-p)
  452.          (discriminator-class 'discriminator)
  453.          (dispatch nil dispatch-p))
  454.         options
  455.     (cond ((not (null arglist-specified-p)))
  456.       ((fboundp 'function-arglist)
  457.        ;; function-arglist exists, get the arglist from it.
  458.        ;; Note: the funcall of 'function-arglist prevents
  459.        ;;       compiler warnings at least in some lisps.
  460.        (setq arglist (funcall 'function-arglist function-name)))
  461.       ((fboundp function-name)
  462.        (error
  463.          "The :arglist argument to make-specializable was not supplied~%~
  464.               and there is no version of FUNCTION-ARGLIST defined for this~%~
  465.               port of Portable CommonLoops.~%~
  466.               You must either define a version of FUNCTION-ARGLIST (which~%~
  467.               should be easy), and send it off to the Portable CommonLoops~%~
  468.               people or you should call make-specializable again with the~%~
  469.               function's arglist as its second argument.")))
  470.     (setq dispatch
  471.       (if dispatch-p
  472.           (iterate ((disp in dispatch))
  473.         (unless (memq disp arglist)
  474.           (error "There is a symbol in the :dispatch argument (~S)~%~
  475.                           which isn't in the arglist."))
  476.         (collect (position disp arglist)))
  477.           :default))
  478.     (let ((discriminator-class-object
  479.         (if (classp discriminator-class)
  480.         discriminator-class
  481.         (class-named discriminator-class t)))
  482.       (discriminator nil))
  483.       (if (null discriminator-class-object)
  484.       (error
  485.         "The :DISCRIMINATOR-CLASS argument to make-specializable is ~S~%~
  486.              but there is no class by that name."
  487.         discriminator-class)
  488.       (setq discriminator             
  489.         (apply #'make discriminator-class-object
  490.                :name function-name
  491.                :dispatch-order dispatch
  492.                options)))
  493. ;     (setf (function-pretty-arglist function-name) arglist)
  494.       (if arglist-specified-p
  495.       (put-slot-always discriminator 'pretty-arglist arglist)
  496.       (remove-dynamic-slot discriminator 'pretty-arglist))
  497.       (setf (discriminator-named function-name) discriminator)
  498.       (when (fboundp function-name)
  499.     (add-named-method (class-prototype (class-named 'discriminator))
  500.               (class-prototype (class-named 'method))
  501.               function-name
  502.               arglist
  503.               ()
  504.               ()
  505.               (symbol-function function-name)))
  506.       discriminator)))
  507.  
  508.  
  509.  
  510.  
  511.  
  512. (defun update-pretty-arglist (discriminator method)
  513.   (setf (function-pretty-arglist
  514.       (or (discriminator-name discriminator)
  515.           (discriminator-discriminating-function discriminator)))
  516.     (or (get-slot-using-class (class-of discriminator) discriminator
  517.                   'pretty-arglist t ())
  518.         (method-arglist method))))
  519.  
  520. (defmeth discriminator-pretty-arglist ((discriminator basic-discriminator))
  521.   (or (get-slot-using-class (class-of discriminator) discriminator
  522.                 'pretty-arglist t ())
  523.       (let ((method (or (discriminator-default-method discriminator)
  524.             (car (discriminator-methods discriminator)))))
  525.     (and method (method-arglist method)))))
  526.  
  527. (defmeth ensure-selector-specializable ((proto-discriminator
  528.                        essential-discriminator)
  529.                      selector arglist)
  530.   (let ((discriminator (discriminator-named selector)))
  531.     (cond ((not (null discriminator)) discriminator)
  532.           ((or (not (fboundp selector))
  533.                (eq *error-when-defining-method-on-existing-function*
  534.            'bootstrapping))
  535.            (setf (discriminator-named selector)
  536.                  (make (class-of proto-discriminator) :name selector)))
  537.           ((null *error-when-defining-method-on-existing-function*)
  538.            (make-specializable selector
  539.                    :arglist arglist
  540.                    :discriminator-class (class-of
  541.                               proto-discriminator))
  542.            (discriminator-named selector))
  543.           (t
  544.            (error "Attempt to add a method to the lisp function ~S without~%~
  545.                    first calling make-specializable.  Before attempting to~
  546.                    define a method on ~S~% you should evaluate the form:~%~
  547.                    (~S '~S)"
  548.                   selector selector 'make-specializable selector)))))
  549.  
  550. (defmeth find-method (discriminator type-specifiers options &optional parse)
  551.   (iterate ((method in (discriminator-methods discriminator)))
  552.     (when (method-equal method
  553.             (if parse
  554.                 (parse-type-specifiers discriminator
  555.                            method
  556.                            type-specifiers)
  557.                 type-specifiers)
  558.             options)
  559.       (return method))))
  560.  
  561. (defmeth method-equal ((method basic-method) argument-specifiers options)
  562.   (and (equal options (method-options method))
  563.        (equal argument-specifiers (method-type-specifiers method))))
  564.  
  565.  
  566. (defmeth discriminator-default-method ((discriminator essential-discriminator))
  567.   (find-method discriminator () ()))
  568.  
  569. (defmeth install-discriminating-function ((discriminator
  570.                         essential-discriminator)
  571.                       where
  572.                       function
  573.                       &optional inhibit-compile-p)
  574.   (ignore discriminator)
  575.   (check-type where symbol "a symbol other than NIL")
  576.   (check-type function function "a funcallable object")
  577.   
  578.   (when (and (listp function)
  579.          (eq (car function) 'lambda)
  580.          (null inhibit-compile-p))
  581.     (setq function (compile nil function)))
  582.  
  583.   (if where
  584.       (setf (symbol-function where) function)
  585.       (setf (discriminator-discriminating-function discriminator) function)))
  586.  
  587.  
  588.   ;;   
  589. ;;;;;; Discriminator-Based caching.
  590.   ;;
  591. ;;; Methods are cached in a discriminator-based cache.  The cache is an N-key
  592. ;;; cache based on the number of specialized arguments the discriminator has.
  593. ;;; As yet the size of the cache does not change statically or dynamically.
  594. ;;; Because of this I allow myself the freedom of computing the mask at
  595. ;;; compile time and not even storing it in the discriminator.
  596.  
  597. (defvar *default-discriminator-cache-size* 8)
  598.  
  599. (defun make-discriminator-cache (&optional
  600.                   (size *default-discriminator-cache-size*))
  601.   (make-memory-block size))
  602.  
  603. (defun make-discriminator-cache-mask (discriminator-cache
  604.                       no-of-specialized-args)
  605.   (make-memory-block-mask (memory-block-size discriminator-cache)
  606.                           (+ no-of-specialized-args 1)))
  607.  
  608. (defmeth flush-discriminator-caches ((discriminator essential-discriminator))
  609.   (let ((cache (discriminator-cache discriminator)))
  610.     (when cache (clear-memory-block (discriminator-cache discriminator) 0))))
  611.  
  612. (defmeth initialize-discriminator-cache ((self essential-discriminator)
  613.                                             no-of-specialized-args)
  614.   (ignore no-of-specialized-args)
  615.   (unless (discriminator-cache self)
  616.     (setf (discriminator-cache self) (make-discriminator-cache))))
  617.  
  618. (defmacro discriminator-cache-offset (mask &rest classes)
  619.   `(logand ,mask
  620.            ,@(iterate ((class in classes))
  621.            (collect `(object-cache-no ,class ,mask)))))
  622.  
  623. (defmacro discriminator-cache-entry (cache offset offset-from-offset)
  624.   `(memory-block-ref ,cache (+ ,offset ,offset-from-offset)))
  625.  
  626. (defmacro cache-method (cache mask method-function &rest classes)
  627.   `(let* ((.offset. (discriminator-cache-offset ,mask ,@classes)))
  628.      ;; Once again, we have to endure a little brain damage because we can't
  629.      ;; count on having without-interrupts.  I suppose the speed loss isn't
  630.      ;; too significant since this is only when we get a cache miss.
  631.      (setf (discriminator-cache-entry ,cache .offset. 0) nil)
  632.      ,@(iterate ((class in (cdr classes)) (key-no from 1))
  633.          (collect `(setf (discriminator-cache-entry ,cache .offset. ,key-no)
  634.              ,class)))
  635.      (prog1
  636.        (setf (discriminator-cache-entry ,cache .offset. ,(length classes))
  637.          ,method-function)
  638.        (setf (discriminator-cache-entry ,cache .offset. 0) ,(car classes)))))
  639.  
  640. (defmacro cached-method (var cache mask &rest classes)
  641.   `(let ((.offset. (discriminator-cache-offset ,mask . ,classes)))
  642.      (and ,@(iterate ((class in classes) (key-no from 0))
  643.               (collect
  644.                 `(eq (discriminator-cache-entry ,cache .offset. ,key-no)
  645.              ,class)))
  646.           (setq ,var (discriminator-cache-entry ,cache
  647.                         .offset.
  648.                         ,(length classes)))
  649.           t)))
  650.  
  651. (defmeth make-caching-discriminating-function (discriminator lookup-function
  652.                                   cache
  653.                                   mask)
  654.   (multiple-value-bind (required restp specialized-positions)
  655.       (compute-discriminating-function-arglist-info discriminator)
  656.     (funcall (get-templated-function-constructor
  657.            'caching-discriminating-function
  658.            required
  659.            restp
  660.            specialized-positions
  661.            lookup-function)
  662.              discriminator cache mask)))
  663.  
  664. (defun make-checking-discriminating-function (discriminator method-function
  665.                                                             type-specs
  666.                                 default-function)
  667.   (multiple-value-bind (required restp)
  668.       (compute-discriminating-function-arglist-info discriminator)
  669.     (let ((check-positions
  670.         (iterate ((type-spec in type-specs)
  671.               (pos from 0))
  672.           (collect (and (neq type-spec 't) pos)))))
  673.       (apply (get-templated-function-constructor
  674.            'checking-discriminating-function
  675.            required
  676.            restp
  677.            (if default-function t nil)
  678.            check-positions)
  679.              discriminator method-function default-function type-specs))))
  680.  
  681.  
  682.   ;;   
  683. ;;;;;; 
  684.   ;;   
  685.  
  686. (defvar *always-remake-discriminating-function* nil)
  687.  
  688. (defmeth make-discriminating-function ((discriminator
  689.                      essential-discriminator))
  690.   (let ((default (discriminator-default-method discriminator))
  691.         (methods (discriminator-methods discriminator)))
  692.     (cond ((null methods)
  693.        (make-no-methods-discriminating-function discriminator))
  694.       ((and default (null (cdr methods)))
  695.            (make-default-method-only-discriminating-function discriminator))
  696.           ((or (and default (null (cddr methods)))
  697.            (and (null default) (null (cdr methods))))
  698.            (make-single-method-only-discriminating-function discriminator))
  699.           ((every #'(lambda (m)
  700.                       (classical-type-specifiers-p
  701.             (method-type-specifiers m)))
  702.                   methods)
  703.            (make-classical-methods-only-discriminating-function
  704.          discriminator))
  705.           (t
  706.            (make-multi-method-discriminating-function discriminator)))))
  707.  
  708. (defmeth make-no-methods-discriminating-function (discriminator)
  709.   (instaar *always-remake-discriminating-function* nil)
  710.  (discriminator-name discriminator)
  711.     #'(lambda (&rest ignore)
  712.     (error "There are no methods on the discriminator ~S,~%~
  713.                 so it is an error to call it."
  714.            discriminator))))
  715.  
  716. (defmeth make-default-method-only-discriminating-function
  717.      ((self essential-discriminator))
  718.   (install-discriminating-function
  719.     self
  720.     (discriminator-name self)
  721.     (method-function (discriminator-default-method self))))
  722.  
  723. (defmeth make-single-method-only-discriminating-function
  724.       ((self essential-discriminator))
  725.   (let* ((methods (discriminator-methods self))
  726.      (default (discriminator-default-method self))
  727.      (method (if (eq (car methods) default)
  728.              (cadr methods)
  729.              (car methods)))
  730.          (method-type-specifiers (method-type-specifiers method))
  731.          (method-function (method-function method)))
  732.     (install-discriminating-function
  733.       self
  734.       (discriminator-name self)
  735.       (make-checking-discriminating-function
  736.     self
  737.     method-function
  738.     method-type-specifiers
  739.     (and default (method-function default))))))
  740.  
  741. (defmeth make-classical-methods-only-discriminating-function
  742.       ((self essential-discriminator))
  743.   (initialize-discriminator-cache self 1)
  744.   (let ((default-method (discriminator-default-method self))
  745.     (methods (discriminator-methods self)))
  746.     (setf (discriminator-classical-method-table self)
  747.       (cons (and default-method (method-function default-method))
  748.         (iterate ((method in methods))
  749.           (unless (eq method default-method)
  750.             (collect (cons (car (method-type-specifiers method))
  751.                    (method-function method))))))))
  752.   (let* ((cache (discriminator-cache self))
  753.      (mask (make-discriminator-cache-mask cache 1)))
  754.     (install-discriminating-function
  755.       self
  756.       (discriminator-name self)
  757.       (make-caching-discriminating-function
  758.     self 'lookup-classical-method cache mask))))
  759.  
  760. (defun lookup-classical-method (discriminator class)
  761.   ;; There really should be some sort of more sophisticated protocol going
  762.   ;; on here.  Compare type-specifiers and all that.
  763.   (let* ((classical-method-table
  764.        (get-slot--class discriminator 'classical-method-table)))
  765.     (or (iterate ((super in (get-slot--class class 'class-precedence-list)))
  766.           (let ((hit (assq super (cdr classical-method-table))))
  767.             (when hit (return (cdr hit)))))
  768.     (car classical-method-table))))
  769.  
  770. (defmeth make-multi-method-discriminating-function
  771.       ((self essential-discriminator))
  772.   (multiple-value-bind (required restp specialized)
  773.       (compute-discriminating-function-arglist-info self)
  774.     (ignore required restp)
  775.     (initialize-discriminator-cache self (length specialized))
  776.     (let* ((cache (discriminator-cache self))
  777.        (mask (make-discriminator-cache-mask cache (length specialized))))
  778.       (install-discriminating-function
  779.     self
  780.     (discriminator-name self)
  781.     (make-caching-discriminating-function
  782.       self 'lookup-multi-method cache mask)))))
  783.  
  784. (defvar *lookup-multi-method-internal*
  785.     (make-array (min 256. call-arguments-limit)))
  786.  
  787. (defun lookup-multi-method-internal (discriminator classes)
  788.   (let* ((methods (discriminator-methods discriminator))
  789.      (cpls *lookup-multi-method-internal*)
  790.      (order (get-slot--class discriminator 'dispatch-order))
  791.          (most-specific-method nil)
  792.          (most-specific-type-specs ())
  793.      (type-specs ()))
  794.     ;; Put all the class-precedence-lists in a place where we can save
  795.     ;; them as we look through all the methods.
  796.     (without-interrupts
  797.       (iterate ((class in classes)
  798.         (i from 0))
  799.     (setf (svref cpls i) (get-slot--class class 'class-precedence-list)))
  800.       (dolist (method methods)
  801.     (setq type-specs (get-slot--class method 'type-specifiers))
  802.     (when (iterate ((type-spec in  type-specs)
  803.             (i from 0))
  804.         (or (eq type-spec 't)
  805.             (memq type-spec (svref cpls i))
  806.             (return nil))
  807.         (finally (return t)))
  808.       (if (null most-specific-method)
  809.           (setq most-specific-method method
  810.             most-specific-type-specs type-specs)
  811.           (case (compare-type-specifier-lists
  812.               most-specific-type-specs type-specs nil
  813.               () classes order)
  814.         (2 (setq most-specific-method method
  815.              most-specific-type-specs type-specs))
  816.         (1))))))
  817.     (or most-specific-method
  818.     (discriminator-default-method discriminator))))
  819.  
  820. (defun lookup-multi-method (discriminator &rest classes)
  821.   (declare (inline lookup-multi-method-internal))
  822.   (let ((method (lookup-multi-method-internal discriminator classes)))
  823.     (and method (method-function method))))
  824.  
  825. (defun lookup-method (discriminator &rest classes)
  826.   (declare (inline lookup-multi-method-internal))
  827.   (lookup-multi-method-internal discriminator classes))
  828.  
  829.   ;;   
  830. ;;;;;; Code for parsing arglists (in the usual case).
  831.   ;;   (when discriminator is class DISCRIMINATOR and method is class METHOD)
  832. ;;;
  833. ;;; arglist-type-specifiers
  834. ;;; Given an arglist this returns its type-specifiers.  Trailing T's (both
  835. ;;; implicit and explicit) are dropped.  The type specifiers are returned as
  836. ;;; they are found in the arglist, they are not parsed into internal
  837. ;;; type-specs.
  838. ;;;
  839. (defmeth arglist-type-specifiers ((proto-disc basic-discriminator)
  840.                   (proto-meth basic-method)
  841.                   arglist)
  842.   (let ((arg (car arglist)))
  843.     (and arglist
  844.          (not (memq arg '(&optional &rest &key &aux)))  ;Don't allow any
  845.                                                         ;type-specifiers
  846.                                                     ;after one of these.
  847.          (let ((tail (arglist-type-specifiers proto-disc
  848.                           proto-meth
  849.                           (cdr arglist)))
  850.                (type-spec (and (listp arg) (cadr arg))))
  851.            (or (and tail (cons (or type-spec 't) tail))
  852.                (and type-spec (cons type-spec ())))))))
  853.  
  854. ;;; arglist-without-type-specifiers
  855. ;;; Given an arglist remove the type specifiers.
  856. ;;; 
  857. (defmeth arglist-without-type-specifiers ((proto-disc basic-discriminator)
  858.                       (proto-meth basic-method)
  859.                       arglist)
  860.   (let ((arg (car arglist)))
  861.     (and arglist
  862.          (if (memq arg '(&optional &rest &key &aux))    ;don't allow any
  863.                                                         ;type-specifiers
  864.                                                         ;after one of these.
  865.              arglist
  866.              (cons (if (listp arg) (car arg) arg)
  867.                    (arglist-without-type-specifiers proto-disc
  868.                             proto-meth
  869.                             (cdr arglist)))))))
  870.  
  871. (defmeth arglist-args ((discriminator-class basic-discriminator)
  872.                (method-class basic-method)
  873.                arglist)
  874.   (and arglist
  875.        (cond ((eq (car arglist) '&aux) ())
  876.              ((memq (car arglist) '(&optional &rest &key))
  877.               (arglist-args discriminator-class method-class (cdr arglist)))
  878.              (t
  879.               ;; This plays on the fact that no type specifiers are allowed
  880.           ;; on arguments that can have default values.
  881.               (cons (if (listp (car arglist)) (caar arglist) (car arglist))
  882.                     (arglist-args discriminator-class
  883.                   method-class
  884.                   (cdr arglist)))))))
  885.  
  886. (defmeth parse-type-specifiers ((proto-discriminator basic-discriminator)
  887.                 (proto-method basic-method)
  888.                 type-specifiers)
  889.   (iterate ((type-specifier in type-specifiers))
  890.     (collect (parse-type-specifier proto-discriminator
  891.                    proto-method
  892.                    type-specifier))))
  893.  
  894. (defmeth parse-type-specifier ((proto-discriminator basic-discriminator)
  895.                                 (proto-method basic-method)
  896.                                 type-specifier)
  897.   (ignore proto-discriminator proto-method)
  898.   (cond ((eq type-specifier 't) 't)
  899.         ((symbolp type-specifier)
  900.          (or (class-named type-specifier nil)
  901.              (error
  902.            "~S used as a type-specifier, but is not the name of a class."
  903.            type-specifier)))
  904.         ((classp type-specifier) type-specifier)
  905.         (t (error "~S is not a legal type-specifier." type-specifier))))
  906.  
  907. (defmeth unparse-type-specifiers ((method essential-method))
  908.   (iterate ((parsed-type-spec in (method-type-specifiers method)))
  909.     (collect (unparse-type-specifier method parsed-type-spec))))
  910.  
  911. (defmeth unparse-type-specifier ((method essential-method) type-spec)
  912.   (ignore method)
  913.   (if (classp type-spec)
  914.       (class-name type-spec)
  915.       type-spec))
  916.  
  917. (defun classical-type-specifiers-p (typespecs)
  918.   (or (null typespecs)
  919.       (and (classp (car typespecs))
  920.            (null (cdr typespecs)))))
  921.  
  922. ;;;
  923. ;;; Compute various information about a discriminator's arglist by looking at
  924. ;;; the argument lists of the methods.  The hair for trying not to use &rest
  925. ;;; arguments lives here.
  926. ;;;  The values returned are:
  927. ;;;    number-of-required-arguments
  928. ;;;       the number of required arguments to this discrimator's
  929. ;;;       discriminating function
  930. ;;;    &rest-argument-p
  931. ;;;       whether or not this discriminator's discriminating
  932. ;;;       function takes an &rest argument.
  933. ;;;    specialized-argument-positions
  934. ;;;       a list of the positions of the arguments this discriminator
  935. ;;;       specializes (e.g. for a classical discrimator this is the
  936. ;;;       list: (1)).
  937. ;;;
  938. ;;; As usual, it is legitimate to specialize the -internal function that is
  939. ;;; why I put it there, since I certainly could have written this more
  940. ;;; efficiently if I didn't want to provide that extensibility.
  941. ;;; 
  942. (defmeth compute-discriminating-function-arglist-info
  943.      ((discriminator essential-discriminator)
  944.       &optional (methods () methods-p))
  945.   (declare (values number-of-required-arguments
  946.                    &rest-argument-p
  947.                    specialized-argument-postions))
  948.   (unless methods-p
  949.     (setq methods (discriminator-methods discriminator)))
  950.   (let ((number-required nil)
  951.         (restp nil)
  952.         (specialized-positions ()))
  953.     (iterate ((method in methods))
  954.       (multiple-value-setq (number-required restp specialized-positions)
  955.         (compute-discriminating-function-arglist-info-internal
  956.       discriminator method number-required restp specialized-positions)))
  957.     (values number-required restp (sort specialized-positions #'<))))
  958.  
  959. (defmeth compute-discriminating-function-arglist-info-internal
  960.      ((discriminator essential-discriminator)
  961.       (method essential-method)
  962.       number-of-requireds restp specialized-argument-positions)
  963.   (ignore discriminator)
  964.   (let ((requireds 0))
  965.     ;; Go through this methods arguments seeing how many are required,
  966.     ;; and whether there is an &rest argument.
  967.     (iterate ((arg in (method-arglist method)))
  968.       (cond ((eq arg '&aux) (return))
  969.             ((memq arg '(&optional &rest &key))
  970.              (return (setq restp t)))
  971.         ((memq arg lambda-list-keywords))
  972.             (t (incf requireds))))
  973.     ;; Now go through this method's type specifiers to see which
  974.     ;; argument positions are type specified.  Treat T specially
  975.     ;; in the usual sort of way.  For efficiency don't bother to
  976.     ;; keep specialized-argument-positions sorted, rather depend
  977.     ;; on our caller to do that.
  978.     (iterate ((type-spec in (method-type-specifiers method))
  979.               (pos from 0))
  980.       (unless (eq type-spec 't)
  981.     (pushnew pos specialized-argument-positions)))
  982.     ;; Finally merge the values for this method into the values
  983.     ;; for the exisiting methods and return them.  Note that if
  984.     ;; num-of-requireds is NIL it means this is the first method
  985.     ;; and we depend on that.
  986.     (values (min (or number-of-requireds requireds) requireds)
  987.             (or restp
  988.         (and number-of-requireds (/= number-of-requireds requireds)))
  989.             specialized-argument-positions)))
  990.  
  991. (defun make-discriminating-function-arglist (number-required-arguments restp)
  992.   (iterate ((i from 0 below number-required-arguments))
  993.     (collect (intern (format nil "Discriminating Function Arg ~D" i)))
  994.     (finally (when restp
  995.                (collect '&rest)
  996.                (collect (intern "Discriminating Function &rest Arg"))))))
  997.  
  998. (defmeth compare-methods (discriminator method-1 method-2)
  999.   (ignore discriminator)
  1000.   (let ((compare ()))
  1001.     (iterate ((ts-1 in (method-type-specifiers method-1))
  1002.           (ts-2 in (method-type-specifiers method-2)))
  1003.       (cond ((eq ts-1 ts-2) (setq compare '=))
  1004.         ((eq ts-1 't)   (setq compare method-2))
  1005.         ((eq ts-2 't)   (setq compare method-1))        
  1006.         ((memq ts-1 (class-class-precedence-list ts-2))
  1007.          (setq compare method-2))
  1008.         ((memq ts-2 (class-class-precedence-list ts-1))
  1009.          (setq compare method-1))
  1010.         (t (return nil)))
  1011.       (finally (return compare)))))
  1012.  
  1013.   ;;   
  1014. ;;;;;; Comparing type-specifiers, statically or wrt an object.
  1015.   ;;
  1016. ;;; compare-type-specifier-lists compares two lists of type specifiers
  1017. ;;; compare-type-specifiers compare two type specifiers
  1018. ;;; If static-p it t the comparison is done statically, otherwise it is
  1019. ;;; done with respect to object(s).  The value returned is:
  1020. ;;;    1    if type-spec-1 is more specific
  1021. ;;;    2    if type-spec-2 is more specific
  1022. ;;;    =    if they are equal
  1023. ;;;    NIL  if they cannot be disambiguated
  1024. ;;;
  1025. (defun compare-type-specifier-lists (type-spec-list-1
  1026.                      type-spec-list-2
  1027.                      staticp
  1028.                      args
  1029.                      classes
  1030.                      order)
  1031.   (when (or type-spec-list-1 type-spec-list-2)
  1032.     (ecase (compare-type-specifiers (or (car type-spec-list-1) t)
  1033.                                     (or (car type-spec-list-2) t)
  1034.                                     staticp
  1035.                                     (car args)
  1036.                                     (car classes))
  1037.       (1 '1)
  1038.       (2 '2)
  1039.       (= (if (eq order :default)
  1040.          (compare-type-specifier-lists (cdr type-spec-list-1)
  1041.                        (cdr type-spec-list-2)
  1042.                        staticp
  1043.                        (cdr args)
  1044.                        (cdr classes)
  1045.                        order)
  1046.          (compare-type-specifier-lists (nth (car order) type-spec-list-1)
  1047.                        (nth (car order) type-spec-list-2)
  1048.                        staticp
  1049.                        (cdr args)
  1050.                        (cdr classes)
  1051.                        (cdr order))))
  1052.         
  1053.       (nil
  1054.         (unless staticp
  1055.           (error "The type specifiers ~S and ~S can not be disambiguated~
  1056.                   with respect to the argument: ~S"
  1057.                  (or (car type-spec-list-1) t)
  1058.                  (or (car type-spec-list-2) t)
  1059.                  (car args)
  1060.                  (car classes)))))))
  1061.  
  1062. (defun compare-type-specifiers (type-spec-1 type-spec-2 staticp arg class)
  1063.   (cond ((equal type-spec-1 type-spec-2) '=)
  1064.         ((eq type-spec-2 t) '1)
  1065.         ((eq type-spec-1 t) '2)
  1066.         ((and (classp type-spec-1) (classp type-spec-2))
  1067. ;        (if staticp
  1068. ;            (if (common-subs type-spec-1 type-spec-2)
  1069. ;                nil
  1070. ;                (let ((supers (common-supers type-spec-1 type-spec-2)))
  1071. ;                  (cond ((cdr supers) nil)
  1072. ;                        ((eq (car supers) type-spec-1) '2)
  1073. ;                        ((eq (car supers) type-spec-2) '1)
  1074. ;                        (t 'disjoint))))
  1075.              (iterate ((super in (class-class-precedence-list (or class (class-of arg)))))
  1076.                (cond ((eq super type-spec-1)
  1077.                       (return '1))
  1078.                      ((eq super type-spec-2)
  1079.                       (return '2)))))
  1080. ;)
  1081.         (t
  1082.          (compare-complex-type-specifiers type-spec-1 type-spec-2 staticp arg class))))
  1083.  
  1084. (defun compare-complex-type-specifiers (type-spec-1 type-spec-2 static-p arg class)
  1085.   (ignore type-spec-1 type-spec-2 static-p arg class)
  1086.   (error "Complex type specifiers are not yet supported."))
  1087.  
  1088. (defmeth no-matching-method (discriminator)
  1089.   (let ((class-of-discriminator (class-of discriminator)))
  1090.     (if (eq (class-of class-of-discriminator) (class-named 'class))
  1091.         ;; The meta-class of the discriminator is class, we can get at
  1092.         ;; it's name slot without doing any method lookup.
  1093.         (let ((name (get-slot--class discriminator 'name)))
  1094.           (if (and name (symbolp name))
  1095.               (error "No matching method for: ~S." name)
  1096.               (error "No matching method for the anonymous discriminator: ~S."
  1097.                      discriminator)))
  1098.         (error "No matching method for the discriminator: ~S." discriminator))))
  1099.   ;;   
  1100. ;;;;;; Optimizing GET-SLOT
  1101.   ;;   
  1102.  
  1103. (defmeth method-argument-class ((method basic-method) argument)
  1104.   (let* ((arglist (method-arglist method))
  1105.          (position (position argument arglist)))
  1106.     (and position (nth position (method-type-specifiers method)))))
  1107.  
  1108.  
  1109. (defmeth optimize-get-slot ((class basic-class)
  1110.                 form)
  1111.   (declare (ignore class))
  1112.   (cons 'get-slot--class (cdr form)))
  1113.  
  1114. (defmeth optimize-setf-of-get-slot ((class basic-class)
  1115.                     form)
  1116.   (declare (ignore class))
  1117.   (cons 'put-slot--class (cdr form)))
  1118.  
  1119.