rs@uunet.UU.NET (Rich Salz) (08/04/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 86
Archive-name: comobj.lisp/Part12
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of archive 12 (of 13)."
# Contents: methods.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'methods.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'methods.l'\"
else
echo shar: Extracting \"'methods.l'\" \(42046 characters\)
sed "s/^X//" >'methods.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X ;;
X;;;;;; Methods
X ;;
X
X(ndefstruct (essential-method
X (:class class)
X (:conc-name method-))
X (discriminator nil)
X (arglist ())
X (type-specifiers ())
X (function nil))
X
X(ndefstruct (combinable-method-mixin (:class class)))
X
X(ndefstruct (basic-method
X (:class class)
X (:include (essential-method))
X (:constructor make-method-1)
X (:conc-name method-))
X (function nil)
X (discriminator nil)
X (type-specifiers ())
X (arglist ())
X (options () :allocation :dynamic))
X
X(ndefstruct (method (:class class)
X (:include (combinable-method-mixin
X basic-method))))
X
X
X(ndefstruct (essential-discriminator
X (:class class)
X (:conc-name discriminator-))
X (name nil)
X (methods ())
X (discriminating-function ())
X (classical-method-table nil :allocation :dynamic)
X (cache ()))
X
X(ndefstruct (method-combination-mixin (:class class)
X (:conc-name nil))
X (method-combination-type :daemon)
X (method-combination-parameters ())
X (methods-combine-p ())
X )
X
X(ndefstruct (basic-discriminator
X (:class class)
X (:include (essential-discriminator))
X (:constructor make-discriminator-1)
X (:conc-name discriminator-))
X
X (dispatch-order :default)
X (inactive-methods () :allocation :dynamic))
X
X(ndefstruct (discriminator (:class class)
X (:include (method-combination-mixin
X basic-discriminator)))
X )
X
X;;;
X;;; This is really just for bootstrapping, of course this isn't all
X;;; worked out yet. But this SHOULD really just be for bootstrapping.
X;;;
X(defmeth method-causes-combination-p ((method basic-method))
X (ignore method)
X ())
X
X ;;
X;;;;;;
X ;;
X
X
X(defun real-expand-defmeth (name&options arglist body)
X (unless (listp name&options) (setq name&options (list name&options)))
X (keyword-parse ((discriminator-class 'discriminator)
X (method-class 'method))
X (cdr name&options)
X (dolist (x '(:discriminator-class :method-class))
X (delete x name&options :test #'(lambda (x y)
X (and (listp y) (eq (car y) x)))))
X (let ((discriminator-class-object (class-named discriminator-class t))
X (method-class-object (class-named method-class t)))
X (or discriminator-class-object ;
X (error
X "The :DISCRIMINATOR-CLASS option to defmeth was used to specify~
X that the class~%of the discriminator should be ~S;~%~
X but there is no class named ~S."
X discriminator-class
X discriminator-class))
X (or method-class-object
X (error "The :METHOD-CLASS option to defmeth was used to specify~%~
X that the class of the method should be ~S;~%~
X but there is no class named ~S."
X method-class
X method-class))
X (expand-defmeth-internal (class-prototype discriminator-class-object)
X (class-prototype method-class-object)
X name&options
X arglist
X body))))
X
X(defvar *method-being-defined*)
X
X(defmeth expand-defmeth-internal ((proto-discriminator basic-discriminator)
X (proto-method basic-method)
X name&options arglist body)
X (keyword-parse ((setf () setf-specified-p))
X (cdr name&options)
X (let* ((discriminator-class-name (class-name
X (class-of proto-discriminator)))
X (method-class-name (class-name (class-of proto-method)))
X (name (car name&options))
X (merged-arglist (cons (car arglist) (append setf (cdr arglist))))
X (merged-args (arglist-without-type-specifiers proto-discriminator
X proto-method
X merged-arglist))
X (merged-type-specifiers
X (defmethod-argument-specializers arglist))
X discriminator-name
X method-name
X (defmethod-uid (gensym))
X (load-method-1 ())
X (documentation ())
X (declarations ()))
X (if setf-specified-p
X (setq discriminator-name (make-setf-discriminator-name name)
X method-name (make-setf-method-name name
X (arglist-type-specifiers
X proto-discriminator
X proto-method
X setf)
X merged-type-specifiers))
X (setq discriminator-name name
X method-name (make-method-name name
X merged-type-specifiers)))
X (multiple-value-setq (documentation declarations body)
X (extract-declarations body))
X (setq load-method-1 `(,discriminator-class-name
X ,method-class-name
X ,discriminator-name
X ,merged-type-specifiers
X ,merged-args
X ,(cdr name&options)))
X ;;
X ;; There are 4 cases:
X ;; - evaluated
X ;; - compiled to core
X ;; - compiled to file
X ;; - loading the compiled file
X ;;
X ;; When loading a method which has a run-super in it, there is no way
X ;; to know which of two events will happen first:
X ;; 1. the load-time-eval form in the run super will be
X ;; evaluated first, or
X ;; 2. the function to install the loaded method (defmethod-uid)
X ;; will be evaluated first.
X ;; consequently, both the special function (defmethod-uid) and the
X ;; expansion of run-super must check to see if the other has already
X ;; run and set the value of defmethod-uid to the method involved.
X ;; This is what causes the boundp checks of defmethod-uid each time
X ;; before it is set.
X ;;
X `(progn
X
X (eval-when (eval load)
X
X (defun ,defmethod-uid ()
X (declare (special ,defmethod-uid))
X (unless (boundp ',defmethod-uid)
X (setq ,defmethod-uid (apply #'load-method-1
X ',load-method-1)))
X ,@(and *real-methods-exist-p*
X `((record-definition
X ',discriminator-name 'method
X ',merged-type-specifiers ',(cdr name&options))
X (setf (symbol-function ',method-name)
X #'(lambda ,merged-args
X ,@documentation
X ,@declarations
X (declare (method-function-name ,method-name))
X ,(wrap-method-body
X proto-discriminator
X (apply 'compile-method-1 load-method-1)
X discriminator-name
X defmethod-uid
X load-method-1
X body)
X ))))
X
X (setf (method-function ,defmethod-uid)
X (symbol-function ',method-name))
X
X (add-method (discriminator-named ',discriminator-name)
X ,defmethod-uid
X ()))
X
X (,defmethod-uid))
X
X (eval-when (compile load eval)
X
X ,@(and setf-specified-p
X `((record-definition
X ',name 'defsetf ',discriminator-name 'defmeth)
X (defsetf ,name
X ,(arglist-without-type-specifiers
X proto-discriminator proto-method arglist)
X ,(arglist-without-type-specifiers
X proto-discriminator proto-method setf)
X (list ',discriminator-name ,@(arglist-args
X proto-discriminator
X proto-method
X merged-args)))))
X
X ',discriminator-name)))))
X
X(defmethod wrap-method-body ((mex-generic-function discriminator)
X (mex-method method)
X generic-function-name
X method-uid
X load-method-1-args
X body)
X (let ((macroexpand-time-information (list mex-generic-function
X mex-method
X generic-function-name
X method-uid
X load-method-1-args)))
X `(macrolet ,(iterate (((name arglist params fn) in *method-body-macros*))
X (collect `(,name ,arglist
X (funcall (function ,fn)
X ',macroexpand-time-information
X ,@params))))
X (block ,generic-function-name
X . ,body))))
X
X(defun macroexpand-time-generic-function (mti) (nth 0 mti))
X
X(defun macroexpand-time-method (mti) (nth 1 mti))
X
X(defun macroexpand-time-generic-function-name (mti) (nth 2 mti))
X
X(defun macroexpand-time-method-uid (mti) (nth 3 mti))
X
X(defun macroexpand-time-load-method-1-args (mti) (nth 4 mti))
X
X
X(defun load-method-1 (discriminator-class-name
X method-class-name
X discriminator-name
X method-type-specifiers
X method-arglist
X options)
X (let* ((discriminator
X (ensure-selector-specializable
X (class-prototype (class-named discriminator-class-name))
X discriminator-name
X method-arglist))
X (method
X (or (find-method discriminator method-type-specifiers options t)
X (make method-class-name))))
X (setf (method-arglist method) method-arglist)
X (setf (method-type-specifiers method)
X (parse-type-specifiers
X discriminator method method-type-specifiers))
X (setf (method-options method) options)
X method))
X
X(defun compile-method-1 (discriminator-class-name
X method-class-name
X discriminator-name
X method-type-specifiers
X method-arglist
X options)
X (ignore discriminator-name)
X (let ((method (make method-class-name)))
X (setf (method-arglist method) method-arglist)
X (setf (method-type-specifiers method)
X (parse-type-specifiers
X (class-prototype (class-named discriminator-class-name))
X method
X method-type-specifiers))
X (setf (method-options method) options)
X method))
X
X
X
X(defmeth add-named-method ((proto-discriminator essential-discriminator)
X (proto-method essential-method)
X discriminator-name
X arglist
X type-specs
X extra
X function)
X ;; What about changing the class of the discriminator if there is
X ;; one. Whose job is that anyways. Do we need something kind of
X ;; like class-for-redefinition?
X (let* ((discriminator
X ;; Modulo bootstrapping hair, this is just:
X ;; (or (discriminator-named ..)
X ;; (make-specializable))
X (ensure-selector-specializable proto-discriminator
X discriminator-name
X arglist))
X (existing (find-method discriminator type-specs extra t))
X (method (or existing
X (make (class-of proto-method)))))
X (when existing (change-class method (class-of proto-method)))
X (setf (method-arglist method) arglist)
X (setf (method-function method) function)
X (setf (method-type-specifiers method) type-specs)
X (add-method discriminator method extra)))
X
X(defmeth add-method ((discriminator essential-discriminator)
X (method essential-method)
X extra)
X (ignore extra)
X (let ((type-specs (method-type-specifiers method))
X ;(options (method-options method))
X ;(methods (discriminator-methods discriminator))
X )
X (setf (method-discriminator method) discriminator)
X; ;; Put the new method where it belongs, either:
X; ;; - The same (EQ) method object is already on discriminator-methods
X; ;; of the discriminator so we don't need to do anything to put the
X; ;; new methods where it belongs.
X; ;; - There is an method on discriminator-methods which is equal to
X; ;; the new method (according to METHOD-EQUAL). In this case, we
X; ;; replace the existing method with the new one.
X; ;; - We just add the new method to discriminator-methods by pushing
X; ;; it onto that list.
X; (unless (memq method methods)
X; (do* ((tail (discriminator-methods discriminator) (cdr tail))
X; (existing-method (car tail) (car tail)))
X; ((cond ((null existing-method)
X; (push method (discriminator-methods discriminator)))
X; ((method-equal existing-method type-specs options)
X; (remove-method discriminator existing-method)
X; (return (add-method discriminator method))))
X;
X; (when (method-causes-combination-p method) ;NOT part of
X; (pushnew method (methods-combine-p discriminator)));standard
X; ;protocol.
X; (dolist (argument-specifier type-specs)
X; (add-method-on-argument-specifier discriminator
X; method
X; argument-specifier)))
X; ()))
X (pushnew method (discriminator-methods discriminator))
X (dolist (argument-specifier type-specs)
X (add-method-on-argument-specifier discriminator
X method
X argument-specifier)))
X (discriminator-changed discriminator method t)
X (update-pretty-arglist discriminator method) ;NOT part of
X ;standard protocol.
X ())
X
X
X(defmeth remove-named-method (discriminator-name
X argument-specifiers
X &optional extra)
X (let ((discriminator ())
X (method ()))
X (cond ((null (setq discriminator (discriminator-named
X discriminator-name)))
X (error "There is no discriminator named ~S." discriminator-name))
X ((null (setq method (find-method discriminator
X argument-specifiers
X extra
X t)))
X (error "There is no method for the discriminator ~S~%~
X which matches the argument-specifiers ~S."
X discriminator
X argument-specifiers))
X (t
X (remove-method discriminator method)))))
X
X(defmeth remove-method ((discriminator basic-discriminator) method)
X (setf (method-discriminator method) nil)
X (setf (discriminator-methods discriminator)
X (delq method (discriminator-methods discriminator)))
X (dolist (type-spec (method-type-specifiers method))
X (remove-method-on-argument-specifier discriminator method type-spec))
X (discriminator-changed discriminator method nil)
X discriminator)
X
X
X
X(defmeth add-method-on-argument-specifier
X ((discriminator essential-discriminator)
X (method essential-method)
X argument-specifier)
X (ignore method)
X (when (classp argument-specifier)
X (pushnew method
X (class-direct-methods argument-specifier))
X ;; This is a bug. This needs to be split up into a method on
X ;; essential class and a method on class or something.
X (when (methods-combine-p discriminator)
X (pushnew discriminator
X (class-discriminators-which-combine-methods
X argument-specifier)))))
X
X(defmeth remove-method-on-argument-specifier
X ((discriminator essential-discriminator)
X (method essential-method)
X argument-specifier)
X (ignore method)
X (when (classp argument-specifier)
X (setf (class-direct-methods argument-specifier)
X (delq method
X (class-direct-methods argument-specifier)))
X (when (methods-combine-p discriminator)
X (setf (class-discriminators-which-combine-methods
X argument-specifier)
X (delq discriminator
X (class-discriminators-which-combine-methods
X argument-specifier))))))
X
X
X(defun make-specializable (function-name &rest options)
X (when options (setq options (list* ':allow-other-keys t options)))
X (keyword-bind ((arglist nil arglist-specified-p)
X (discriminator-class 'discriminator)
X (dispatch nil dispatch-p))
X options
X (cond ((not (null arglist-specified-p)))
X ((fboundp 'function-arglist)
X ;; function-arglist exists, get the arglist from it.
X ;; Note: the funcall of 'function-arglist prevents
X ;; compiler warnings at least in some lisps.
X (setq arglist (funcall 'function-arglist function-name)))
X ((fboundp function-name)
X (error
X "The :arglist argument to make-specializable was not supplied~%~
X and there is no version of FUNCTION-ARGLIST defined for this~%~
X port of Portable CommonLoops.~%~
X You must either define a version of FUNCTION-ARGLIST (which~%~
X should be easy), and send it off to the Portable CommonLoops~%~
X people or you should call make-specializable again with the~%~
X function's arglist as its second argument.")))
X (setq dispatch
X (if dispatch-p
X (iterate ((disp in dispatch))
X (unless (memq disp arglist)
X (error "There is a symbol in the :dispatch argument (~S)~%~
X which isn't in the arglist."))
X (collect (position disp arglist)))
X :default))
X (let ((discriminator-class-object
X (if (classp discriminator-class)
X discriminator-class
X (class-named discriminator-class t)))
X (discriminator nil))
X (if (null discriminator-class-object)
X (error
X "The :DISCRIMINATOR-CLASS argument to make-specializable is ~S~%~
X but there is no class by that name."
X discriminator-class)
X (setq discriminator
X (apply #'make discriminator-class-object
X :name function-name
X :dispatch-order dispatch
X options)))
X; (setf (function-pretty-arglist function-name) arglist)
X (if arglist-specified-p
X (put-slot-always discriminator 'pretty-arglist arglist)
X (remove-dynamic-slot discriminator 'pretty-arglist))
X (setf (discriminator-named function-name) discriminator)
X (when (fboundp function-name)
X (add-named-method (class-prototype (class-named 'discriminator))
X (class-prototype (class-named 'method))
X function-name
X arglist
X ()
X ()
X (symbol-function function-name)))
X discriminator)))
X
X
X
X
X
X(defun update-pretty-arglist (discriminator method)
X (setf (function-pretty-arglist
X (or (discriminator-name discriminator)
X (discriminator-discriminating-function discriminator)))
X (or (get-slot-using-class (class-of discriminator) discriminator
X 'pretty-arglist t ())
X (method-arglist method))))
X
X(defmeth discriminator-pretty-arglist ((discriminator basic-discriminator))
X (or (get-slot-using-class (class-of discriminator) discriminator
X 'pretty-arglist t ())
X (let ((method (or (discriminator-default-method discriminator)
X (car (discriminator-methods discriminator)))))
X (and method (method-arglist method)))))
X
X(defmeth ensure-selector-specializable ((proto-discriminator
X essential-discriminator)
X selector arglist)
X (let ((discriminator (discriminator-named selector)))
X (cond ((not (null discriminator)) discriminator)
X ((or (not (fboundp selector))
X (eq *error-when-defining-method-on-existing-function*
X 'bootstrapping))
X (setf (discriminator-named selector)
X (make (class-of proto-discriminator) :name selector)))
X ((null *error-when-defining-method-on-existing-function*)
X (make-specializable selector
X :arglist arglist
X :discriminator-class (class-of
X proto-discriminator))
X (discriminator-named selector))
X (t
X (error "Attempt to add a method to the lisp function ~S without~%~
X first calling make-specializable. Before attempting to~
X define a method on ~S~% you should evaluate the form:~%~
X (~S '~S)"
X selector selector 'make-specializable selector)))))
X
X(defmeth find-method (discriminator type-specifiers options &optional parse)
X (iterate ((method in (discriminator-methods discriminator)))
X (when (method-equal method
X (if parse
X (parse-type-specifiers discriminator
X method
X type-specifiers)
X type-specifiers)
X options)
X (return method))))
X
X(defmeth method-equal ((method basic-method) argument-specifiers options)
X (and (equal options (method-options method))
X (equal argument-specifiers (method-type-specifiers method))))
X
X
X(defmeth discriminator-default-method ((discriminator essential-discriminator))
X (find-method discriminator () ()))
X
X(defmeth install-discriminating-function ((discriminator
X essential-discriminator)
X where
X function
X &optional inhibit-compile-p)
X (ignore discriminator)
X (check-type where symbol "a symbol other than NIL")
X (check-type function function "a funcallable object")
X
X (when (and (listp function)
X (eq (car function) 'lambda)
X (null inhibit-compile-p))
X (setq function (compile nil function)))
X
X (if where
X (setf (symbol-function where) function)
X (setf (discriminator-discriminating-function discriminator) function)))
X
X
X ;;
X;;;;;; Discriminator-Based caching.
X ;;
X;;; Methods are cached in a discriminator-based cache. The cache is an N-key
X;;; cache based on the number of specialized arguments the discriminator has.
X;;; As yet the size of the cache does not change statically or dynamically.
X;;; Because of this I allow myself the freedom of computing the mask at
X;;; compile time and not even storing it in the discriminator.
X
X(defvar *default-discriminator-cache-size* 8)
X
X(defun make-discriminator-cache (&optional
X (size *default-discriminator-cache-size*))
X (make-memory-block size))
X
X(defun make-discriminator-cache-mask (discriminator-cache
X no-of-specialized-args)
X (make-memory-block-mask (memory-block-size discriminator-cache)
X (+ no-of-specialized-args 1)))
X
X(defmeth flush-discriminator-caches ((discriminator essential-discriminator))
X (let ((cache (discriminator-cache discriminator)))
X (when cache (clear-memory-block (discriminator-cache discriminator) 0))))
X
X(defmeth initialize-discriminator-cache ((self essential-discriminator)
X no-of-specialized-args)
X (ignore no-of-specialized-args)
X (unless (discriminator-cache self)
X (setf (discriminator-cache self) (make-discriminator-cache))))
X
X(defmacro discriminator-cache-offset (mask &rest classes)
X `(logand ,mask
X ,@(iterate ((class in classes))
X (collect `(object-cache-no ,class ,mask)))))
X
X(defmacro discriminator-cache-entry (cache offset offset-from-offset)
X `(memory-block-ref ,cache (+ ,offset ,offset-from-offset)))
X
X(defmacro cache-method (cache mask method-function &rest classes)
X `(let* ((.offset. (discriminator-cache-offset ,mask ,@classes)))
X ;; Once again, we have to endure a little brain damage because we can't
X ;; count on having without-interrupts. I suppose the speed loss isn't
X ;; too significant since this is only when we get a cache miss.
X (setf (discriminator-cache-entry ,cache .offset. 0) nil)
X ,@(iterate ((class in (cdr classes)) (key-no from 1))
X (collect `(setf (discriminator-cache-entry ,cache .offset. ,key-no)
X ,class)))
X (prog1
X (setf (discriminator-cache-entry ,cache .offset. ,(length classes))
X ,method-function)
X (setf (discriminator-cache-entry ,cache .offset. 0) ,(car classes)))))
X
X(defmacro cached-method (var cache mask &rest classes)
X `(let ((.offset. (discriminator-cache-offset ,mask . ,classes)))
X (and ,@(iterate ((class in classes) (key-no from 0))
X (collect
X `(eq (discriminator-cache-entry ,cache .offset. ,key-no)
X ,class)))
X (setq ,var (discriminator-cache-entry ,cache
X .offset.
X ,(length classes)))
X t)))
X
X(defmeth make-caching-discriminating-function (discriminator lookup-function
X cache
X mask)
X (multiple-value-bind (required restp specialized-positions)
X (compute-discriminating-function-arglist-info discriminator)
X (funcall (get-templated-function-constructor
X 'caching-discriminating-function
X required
X restp
X specialized-positions
X lookup-function)
X discriminator cache mask)))
X
X(defun make-checking-discriminating-function (discriminator method-function
X type-specs
X default-function)
X (multiple-value-bind (required restp)
X (compute-discriminating-function-arglist-info discriminator)
X (let ((check-positions
X (iterate ((type-spec in type-specs)
X (pos from 0))
X (collect (and (neq type-spec 't) pos)))))
X (apply (get-templated-function-constructor
X 'checking-discriminating-function
X required
X restp
X (if default-function t nil)
X check-positions)
X discriminator method-function default-function type-specs))))
X
X
X ;;
X;;;;;;
X ;;
X
X(defvar *always-remake-discriminating-function* nil)
X
X(defmeth make-discriminating-function ((discriminator
X essential-discriminator))
X (let ((default (discriminator-default-method discriminator))
X (methods (discriminator-methods discriminator)))
X (cond ((null methods)
X (make-no-methods-discriminating-function discriminator))
X ((and default (null (cdr methods)))
X (make-default-method-only-discriminating-function discriminator))
X ((or (and default (null (cddr methods)))
X (and (null default) (null (cdr methods))))
X (make-single-method-only-discriminating-function discriminator))
X ((every #'(lambda (m)
X (classical-type-specifiers-p
X (method-type-specifiers m)))
X methods)
X (make-classical-methods-only-discriminating-function
X discriminator))
X (t
X (make-multi-method-discriminating-function discriminator)))))
X
X(defmeth make-no-methods-discriminating-function (discriminator)
X (instaar *always-remake-discriminating-function* nil)
X (discriminator-name discriminator)
X #'(lambda (&rest ignore)
X (error "There are no methods on the discriminator ~S,~%~
X so it is an error to call it."
X discriminator))))
X
X(defmeth make-default-method-only-discriminating-function
X ((self essential-discriminator))
X (install-discriminating-function
X self
X (discriminator-name self)
X (method-function (discriminator-default-method self))))
X
X(defmeth make-single-method-only-discriminating-function
X ((self essential-discriminator))
X (let* ((methods (discriminator-methods self))
X (default (discriminator-default-method self))
X (method (if (eq (car methods) default)
X (cadr methods)
X (car methods)))
X (method-type-specifiers (method-type-specifiers method))
X (method-function (method-function method)))
X (install-discriminating-function
X self
X (discriminator-name self)
X (make-checking-discriminating-function
X self
X method-function
X method-type-specifiers
X (and default (method-function default))))))
X
X(defmeth make-classical-methods-only-discriminating-function
X ((self essential-discriminator))
X (initialize-discriminator-cache self 1)
X (let ((default-method (discriminator-default-method self))
X (methods (discriminator-methods self)))
X (setf (discriminator-classical-method-table self)
X (cons (and default-method (method-function default-method))
X (iterate ((method in methods))
X (unless (eq method default-method)
X (collect (cons (car (method-type-specifiers method))
X (method-function method))))))))
X (let* ((cache (discriminator-cache self))
X (mask (make-discriminator-cache-mask cache 1)))
X (install-discriminating-function
X self
X (discriminator-name self)
X (make-caching-discriminating-function
X self 'lookup-classical-method cache mask))))
X
X(defun lookup-classical-method (discriminator class)
X ;; There really should be some sort of more sophisticated protocol going
X ;; on here. Compare type-specifiers and all that.
X (let* ((classical-method-table
X (get-slot--class discriminator 'classical-method-table)))
X (or (iterate ((super in (get-slot--class class 'class-precedence-list)))
X (let ((hit (assq super (cdr classical-method-table))))
X (when hit (return (cdr hit)))))
X (car classical-method-table))))
X
X(defmeth make-multi-method-discriminating-function
X ((self essential-discriminator))
X (multiple-value-bind (required restp specialized)
X (compute-discriminating-function-arglist-info self)
X (ignore required restp)
X (initialize-discriminator-cache self (length specialized))
X (let* ((cache (discriminator-cache self))
X (mask (make-discriminator-cache-mask cache (length specialized))))
X (install-discriminating-function
X self
X (discriminator-name self)
X (make-caching-discriminating-function
X self 'lookup-multi-method cache mask)))))
X
X(defvar *lookup-multi-method-internal*
X (make-array (min 256. call-arguments-limit)))
X
X(defun lookup-multi-method-internal (discriminator classes)
X (let* ((methods (discriminator-methods discriminator))
X (cpls *lookup-multi-method-internal*)
X (order (get-slot--class discriminator 'dispatch-order))
X (most-specific-method nil)
X (most-specific-type-specs ())
X (type-specs ()))
X ;; Put all the class-precedence-lists in a place where we can save
X ;; them as we look through all the methods.
X (without-interrupts
X (iterate ((class in classes)
X (i from 0))
X (setf (svref cpls i) (get-slot--class class 'class-precedence-list)))
X (dolist (method methods)
X (setq type-specs (get-slot--class method 'type-specifiers))
X (when (iterate ((type-spec in type-specs)
X (i from 0))
X (or (eq type-spec 't)
X (memq type-spec (svref cpls i))
X (return nil))
X (finally (return t)))
X (if (null most-specific-method)
X (setq most-specific-method method
X most-specific-type-specs type-specs)
X (case (compare-type-specifier-lists
X most-specific-type-specs type-specs nil
X () classes order)
X (2 (setq most-specific-method method
X most-specific-type-specs type-specs))
X (1))))))
X (or most-specific-method
X (discriminator-default-method discriminator))))
X
X(defun lookup-multi-method (discriminator &rest classes)
X (declare (inline lookup-multi-method-internal))
X (let ((method (lookup-multi-method-internal discriminator classes)))
X (and method (method-function method))))
X
X(defun lookup-method (discriminator &rest classes)
X (declare (inline lookup-multi-method-internal))
X (lookup-multi-method-internal discriminator classes))
X
X ;;
X;;;;;; Code for parsing arglists (in the usual case).
X ;; (when discriminator is class DISCRIMINATOR and method is class METHOD)
X;;;
X;;; arglist-type-specifiers
X;;; Given an arglist this returns its type-specifiers. Trailing T's (both
X;;; implicit and explicit) are dropped. The type specifiers are returned as
X;;; they are found in the arglist, they are not parsed into internal
X;;; type-specs.
X;;;
X(defmeth arglist-type-specifiers ((proto-disc basic-discriminator)
X (proto-meth basic-method)
X arglist)
X (let ((arg (car arglist)))
X (and arglist
X (not (memq arg '(&optional &rest &key &aux))) ;Don't allow any
X ;type-specifiers
X ;after one of these.
X (let ((tail (arglist-type-specifiers proto-disc
X proto-meth
X (cdr arglist)))
X (type-spec (and (listp arg) (cadr arg))))
X (or (and tail (cons (or type-spec 't) tail))
X (and type-spec (cons type-spec ())))))))
X
X;;; arglist-without-type-specifiers
X;;; Given an arglist remove the type specifiers.
X;;;
X(defmeth arglist-without-type-specifiers ((proto-disc basic-discriminator)
X (proto-meth basic-method)
X arglist)
X (let ((arg (car arglist)))
X (and arglist
X (if (memq arg '(&optional &rest &key &aux)) ;don't allow any
X ;type-specifiers
X ;after one of these.
X arglist
X (cons (if (listp arg) (car arg) arg)
X (arglist-without-type-specifiers proto-disc
X proto-meth
X (cdr arglist)))))))
X
X(defmeth arglist-args ((discriminator-class basic-discriminator)
X (method-class basic-method)
X arglist)
X (and arglist
X (cond ((eq (car arglist) '&aux) ())
X ((memq (car arglist) '(&optional &rest &key))
X (arglist-args discriminator-class method-class (cdr arglist)))
X (t
X ;; This plays on the fact that no type specifiers are allowed
X ;; on arguments that can have default values.
X (cons (if (listp (car arglist)) (caar arglist) (car arglist))
X (arglist-args discriminator-class
X method-class
X (cdr arglist)))))))
X
X(defmeth parse-type-specifiers ((proto-discriminator basic-discriminator)
X (proto-method basic-method)
X type-specifiers)
X (iterate ((type-specifier in type-specifiers))
X (collect (parse-type-specifier proto-discriminator
X proto-method
X type-specifier))))
X
X(defmeth parse-type-specifier ((proto-discriminator basic-discriminator)
X (proto-method basic-method)
X type-specifier)
X (ignore proto-discriminator proto-method)
X (cond ((eq type-specifier 't) 't)
X ((symbolp type-specifier)
X (or (class-named type-specifier nil)
X (error
X "~S used as a type-specifier, but is not the name of a class."
X type-specifier)))
X ((classp type-specifier) type-specifier)
X (t (error "~S is not a legal type-specifier." type-specifier))))
X
X(defmeth unparse-type-specifiers ((method essential-method))
X (iterate ((parsed-type-spec in (method-type-specifiers method)))
X (collect (unparse-type-specifier method parsed-type-spec))))
X
X(defmeth unparse-type-specifier ((method essential-method) type-spec)
X (ignore method)
X (if (classp type-spec)
X (class-name type-spec)
X type-spec))
X
X(defun classical-type-specifiers-p (typespecs)
X (or (null typespecs)
X (and (classp (car typespecs))
X (null (cdr typespecs)))))
X
X;;;
X;;; Compute various information about a discriminator's arglist by looking at
X;;; the argument lists of the methods. The hair for trying not to use &rest
X;;; arguments lives here.
X;;; The values returned are:
X;;; number-of-required-arguments
X;;; the number of required arguments to this discrimator's
X;;; discriminating function
X;;; &rest-argument-p
X;;; whether or not this discriminator's discriminating
X;;; function takes an &rest argument.
X;;; specialized-argument-positions
X;;; a list of the positions of the arguments this discriminator
X;;; specializes (e.g. for a classical discrimator this is the
X;;; list: (1)).
X;;;
X;;; As usual, it is legitimate to specialize the -internal function that is
X;;; why I put it there, since I certainly could have written this more
X;;; efficiently if I didn't want to provide that extensibility.
X;;;
X(defmeth compute-discriminating-function-arglist-info
X ((discriminator essential-discriminator)
X &optional (methods () methods-p))
X (declare (values number-of-required-arguments
X &rest-argument-p
X specialized-argument-postions))
X (unless methods-p
X (setq methods (discriminator-methods discriminator)))
X (let ((number-required nil)
X (restp nil)
X (specialized-positions ()))
X (iterate ((method in methods))
X (multiple-value-setq (number-required restp specialized-positions)
X (compute-discriminating-function-arglist-info-internal
X discriminator method number-required restp specialized-positions)))
X (values number-required restp (sort specialized-positions #'<))))
X
X(defmeth compute-discriminating-function-arglist-info-internal
X ((discriminator essential-discriminator)
X (method essential-method)
X number-of-requireds restp specialized-argument-positions)
X (ignore discriminator)
X (let ((requireds 0))
X ;; Go through this methods arguments seeing how many are required,
X ;; and whether there is an &rest argument.
X (iterate ((arg in (method-arglist method)))
X (cond ((eq arg '&aux) (return))
X ((memq arg '(&optional &rest &key))
X (return (setq restp t)))
X ((memq arg lambda-list-keywords))
X (t (incf requireds))))
X ;; Now go through this method's type specifiers to see which
X ;; argument positions are type specified. Treat T specially
X ;; in the usual sort of way. For efficiency don't bother to
X ;; keep specialized-argument-positions sorted, rather depend
X ;; on our caller to do that.
X (iterate ((type-spec in (method-type-specifiers method))
X (pos from 0))
X (unless (eq type-spec 't)
X (pushnew pos specialized-argument-positions)))
X ;; Finally merge the values for this method into the values
X ;; for the exisiting methods and return them. Note that if
X ;; num-of-requireds is NIL it means this is the first method
X ;; and we depend on that.
X (values (min (or number-of-requireds requireds) requireds)
X (or restp
X (and number-of-requireds (/= number-of-requireds requireds)))
X specialized-argument-positions)))
X
X(defun make-discriminating-function-arglist (number-required-arguments restp)
X (iterate ((i from 0 below number-required-arguments))
X (collect (intern (format nil "Discriminating Function Arg ~D" i)))
X (finally (when restp
X (collect '&rest)
X (collect (intern "Discriminating Function &rest Arg"))))))
X
X(defmeth compare-methods (discriminator method-1 method-2)
X (ignore discriminator)
X (let ((compare ()))
X (iterate ((ts-1 in (method-type-specifiers method-1))
X (ts-2 in (method-type-specifiers method-2)))
X (cond ((eq ts-1 ts-2) (setq compare '=))
X ((eq ts-1 't) (setq compare method-2))
X ((eq ts-2 't) (setq compare method-1))
X ((memq ts-1 (class-class-precedence-list ts-2))
X (setq compare method-2))
X ((memq ts-2 (class-class-precedence-list ts-1))
X (setq compare method-1))
X (t (return nil)))
X (finally (return compare)))))
X
X ;;
X;;;;;; Comparing type-specifiers, statically or wrt an object.
X ;;
X;;; compare-type-specifier-lists compares two lists of type specifiers
X;;; compare-type-specifiers compare two type specifiers
X;;; If static-p it t the comparison is done statically, otherwise it is
X;;; done with respect to object(s). The value returned is:
X;;; 1 if type-spec-1 is more specific
X;;; 2 if type-spec-2 is more specific
X;;; = if they are equal
X;;; NIL if they cannot be disambiguated
X;;;
X(defun compare-type-specifier-lists (type-spec-list-1
X type-spec-list-2
X staticp
X args
X classes
X order)
X (when (or type-spec-list-1 type-spec-list-2)
X (ecase (compare-type-specifiers (or (car type-spec-list-1) t)
X (or (car type-spec-list-2) t)
X staticp
X (car args)
X (car classes))
X (1 '1)
X (2 '2)
X (= (if (eq order :default)
X (compare-type-specifier-lists (cdr type-spec-list-1)
X (cdr type-spec-list-2)
X staticp
X (cdr args)
X (cdr classes)
X order)
X (compare-type-specifier-lists (nth (car order) type-spec-list-1)
X (nth (car order) type-spec-list-2)
X staticp
X (cdr args)
X (cdr classes)
X (cdr order))))
X
X (nil
X (unless staticp
X (error "The type specifiers ~S and ~S can not be disambiguated~
X with respect to the argument: ~S"
X (or (car type-spec-list-1) t)
X (or (car type-spec-list-2) t)
X (car args)
X (car classes)))))))
X
X(defun compare-type-specifiers (type-spec-1 type-spec-2 staticp arg class)
X (cond ((equal type-spec-1 type-spec-2) '=)
X ((eq type-spec-2 t) '1)
X ((eq type-spec-1 t) '2)
X ((and (classp type-spec-1) (classp type-spec-2))
X; (if staticp
X; (if (common-subs type-spec-1 type-spec-2)
X; nil
X; (let ((supers (common-supers type-spec-1 type-spec-2)))
X; (cond ((cdr supers) nil)
X; ((eq (car supers) type-spec-1) '2)
X; ((eq (car supers) type-spec-2) '1)
X; (t 'disjoint))))
X (iterate ((super in (class-class-precedence-list (or class (class-of arg)))))
X (cond ((eq super type-spec-1)
X (return '1))
X ((eq super type-spec-2)
X (return '2)))))
X;)
X (t
X (compare-complex-type-specifiers type-spec-1 type-spec-2 staticp arg class))))
X
X(defun compare-complex-type-specifiers (type-spec-1 type-spec-2 static-p arg class)
X (ignore type-spec-1 type-spec-2 static-p arg class)
X (error "Complex type specifiers are not yet supported."))
X
X(defmeth no-matching-method (discriminator)
X (let ((class-of-discriminator (class-of discriminator)))
X (if (eq (class-of class-of-discriminator) (class-named 'class))
X ;; The meta-class of the discriminator is class, we can get at
X ;; it's name slot without doing any method lookup.
X (let ((name (get-slot--class discriminator 'name)))
X (if (and name (symbolp name))
X (error "No matching method for: ~S." name)
X (error "No matching method for the anonymous discriminator: ~S."
X discriminator)))
X (error "No matching method for the discriminator: ~S." discriminator))))
X ;;
X;;;;;; Optimizing GET-SLOT
X ;;
X
X(defmeth method-argument-class ((method basic-method) argument)
X (let* ((arglist (method-arglist method))
X (position (position argument arglist)))
X (and position (nth position (method-type-specifiers method)))))
X
X
X(defmeth optimize-get-slot ((class basic-class)
X form)
X (declare (ignore class))
X (cons 'get-slot--class (cdr form)))
X
X(defmeth optimize-setf-of-get-slot ((class basic-class)
X form)
X (declare (ignore class))
X (cons 'put-slot--class (cdr form)))
X
END_OF_FILE
if test 42046 -ne `wc -c <'methods.l'`; then
echo shar: \"'methods.l'\" unpacked with wrong size!
fi
# end of 'methods.l'
fi
echo shar: End of archive 12 \(of 13\).
cp /dev/null ark12isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 13 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Rich $alz "Anger is an energy"
Cronus Project, BBN Labs rsalz@bbn.com
Moderator, comp.sources.unix sources@uunet.uubodys