Artifact b50da80015cbc132636aa5759d7d64e0955ac8793d30c2d07ef29e0963f026d3:

• File psl-1983/3-1/util/objects.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 33869) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/objects.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 33869) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Objects.SL - A simple facility for object-oriented programming.
%
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        22 July 1982
% Revised:     16 February 1983
%
% 16-Feb-83 Alan Snyder
%  Add ev-send function.  Rename declare and undeclare to declare-flavor
%  and undeclare-flavor, to avoid conflict with common lisp declare.
% 30-Dec-82 Alan Snyder
%  General clean-up; rename internal functions and variables; document
%  method lookup functions; add method lookup trace facility.
% 1-Nov-82 Alan Snyder
%  Added Object-Type function.
% 27-Sept-82 Alan Snyder
%  Removed Variable-Table (which was available only at compile-time); made
%  Variable-Names available at both compile-time and load-time; now use
%  Variable-Names to "compile" method bodies.  Result: now can compile new
%  method bodies after loading a "compiled" flavor definition.
% 27-Sept-82 Alan Snyder
%  Evaluating (or loading) a DEFFLAVOR no longer clears the method table, if it
%  had been defined previously.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(Bothtimes (imports '(common fast-vector)))
(imports '(association strings))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% NOTE: THIS FILE DEFINES MACROS.  IT MUST BE LOADED BEFORE ANY OF THESE
% FUNCTIONS ARE USED.  The recommended way to do this is to put the statement
% (BothTimes (load objects)) at the beginning of your source file.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% Summary of Public Functions:
%   
% (defflavor flavor-name (var1 var2 ...) (flav1 flav2 ...) option1 option2 ...)
% (defmethod (flavor-name message-name) (arg1 arg2 ...) form1 form2 ...)
%
% (make-instance 'flavor-name 'var1 value1 ...)
%
% (=> foo message-name arg1 arg2 ...)
%
% (send foo 'message-name arg1 arg2 ...)
% (lexpr-send foo 'message-name arg1 arg2 ... rest-arg-list)
% (lexpr-send-1 foo 'message-name arg-list)
% (ev-send foo 'message-name arg-list) {EXPR form}
%
% (send-if-handles foo 'message-name arg1 arg2 ...)
% (lexpr-send-if-handles foo 'message-name arg1 arg2 ... rest-arg-list)
% (lexpr-send-1-if-handles foo 'message-name arg-list)
%
% (instantiate-flavor 'flavor-name init-list)
%
% (object-type x)  --- returns the type of an object, or NIL if not an object
%
% (object-get-handler x message-name) -- lookup method function (see below)
% (object-get-handler-quietly x message-name)
%
% (trace-method-lookups) - start recording stats about method lookup
% (untrace-method-lookups) - stop recording stats about method lookup
% (print-method-lookup-info) - untrace and print accumulated stats
%
% (declare-flavor flavor var1 var2 ...)   NOTE: see warnings below!
% (undeclare-flavor var1 var2 ...)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Private Constants, Fluids, and Macros (mere mortals should ignore these)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(fluid '($defflavor-expansion-context
	 $object-number-of-reserved-slots
	 $object-flavor-slot
	 $object-debug-slot
	 $defflavor-option-table
	 $method-lookup-stats
	 ))

(setf $defflavor-expansion-context NIL)
(BothTimes (progn
	    (setf $object-number-of-reserved-slots 2)
	    (setf $object-flavor-slot 0)
	    (setf $object-debug-slot 1)
	    ))
(setf $defflavor-option-table
  (list
   (cons 'gettable-instance-variables '$defflavor-do-gettable-option)
   (cons 'settable-instance-variables '$defflavor-do-settable-option)
   (cons 'initable-instance-variables '$defflavor-do-initable-option)
   ))

% Note the free variable FLAVOR-NAME in this macro:
(defmacro $defflavor-error (format . arguments)
  `(ContinuableError 1000 (BldMsg ,(string-concat "DEFFLAVOR %w: " format)
			          flavor-name . ,arguments) NIL))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Public Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% DEFFLAVOR - Define a new flavor of Object
%   
% Examples:
%
% (defflavor complex-number (real-part imaginary-part) ())
%
% (defflavor complex-number (real-part imaginary-part) ()
%    gettable-instance-variables
%    initable-instance-variables
%    )
%
% (defflavor complex-number ((real-part 0.0)
%			   (imaginary-part 0.0)
%			   )
%    ()
%    gettable-instance-variables
%    (settable-instance-variables real-part)
%    )
%
% An object is represented by a vector; instance variables are allocated
% specific slots in the vector.  Do not use names like "IF" or "WHILE" for
% instance varibles: they are translated freely within method bodies (see
% DEFMETHOD).  Initial values for instance variables may be specified as
% arguments to MAKE-INSTANCE, or as initializing expressions in the variable
% list, or may be supplied by an INIT method (see MAKE-INSTANCE).
% Uninitializied instance variables are bound to *UNBOUND*.
%
% The component flavor list currently must be null.  Recognized options are:
%
%  (GETTABLE-INSTANCE-VARIABLES var1 var2 ...)
%  (SETTABLE-INSTANCE-VARIABLES var1 var2 ...) 
%  (INITABLE-INSTANCE-VARIABLES var1 var2 ...)
%  GETTABLE-INSTANCE-VARIABLES  [make all instance variables GETTABLE]
%  SETTABLE-INSTANCE-VARIABLES  [make all instance variables SETTABLE]
%  INITABLE-INSTANCE-VARIABLES  [make all instance variables INITABLE]
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro defflavor (flavor-name variable-list flavor-list . options-list)
  (prog (var-names		% List of valid instance variable names
	 init-code		% body of DEFAULT-INIT method
	 describe-code		% body of DESCRIBE method
	 defmethod-list		% list of created DEFMETHODs
	 var-options		% AList mapping var names to option list
	 initable-vars		% list of INITABLE instance variables
	 )
    (desetq (var-names init-code)
	    ($defflavor-process-varlist flavor-name variable-list)
	    )
    (setf describe-code ($defflavor-build-describe flavor-name var-names))
    (setf var-options
      ($defflavor-process-options-list flavor-name var-names options-list)
      )
    (setf defmethod-list ($defflavor-create-methods flavor-name var-options))
    (setf initable-vars ($defflavor-initable-vars flavor-name var-options))

    (put flavor-name 'variable-names var-names)
    (setf defmethod-list
      (cons `(defmethod (,flavor-name default-init) () . ,init-code)
	    defmethod-list))
    (setf defmethod-list
      (cons `(defmethod (,flavor-name describe) () . ,describe-code)
	    defmethod-list))
    (if flavor-list
      ($defflavor-error "Component Flavors not implemented")
      )

    % The previous actions happen at compile or dskin time.
    % The following actions happen at dskin or load time.

    (return `(progn
	      (if (not (get ',flavor-name 'method-table))
		(put ',flavor-name 'method-table (association-create)))
	      (put ',flavor-name 'instance-vector-size
		   ,(+ #.$object-number-of-reserved-slots (length var-names)))
	      (put ',flavor-name 'variable-names ',var-names)
	      (put ',flavor-name 'initable-variables ',initable-vars)
	      ,@defmethod-list
	      '(flavor ,flavor-name) % for documentation only
	      ))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% DEFMETHOD - Define a method on an existing flavor.
%   
% Examples:
%
% (defmethod (complex-number real-part) ()
%   real-part)
%
% (defmethod (complex-number set-real-part) (new-real-part)
%   (setf real-part new-real-part))
%
% The body of a method can freely refer to the instance variables of the flavor
% and can set them using SETF.  Each method defines a function FLAVOR$METHOD
% whose first argument is SELF, the object that is performing the method.  All
% references to instance variables (except within vectors or quoted lists) are
% translated to an invocation of the form (IGETV SELF n).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro defmethod ((flavor-name method-name) argument-list . body)
  (setf argument-list (cons 'self argument-list))
  (let ((function-name ($defflavor-function-name flavor-name method-name)))
    (put function-name 'source-code `(lambda ,argument-list . ,body))
    (let ((new-code ($create-method-source-code function-name flavor-name)))

      % The previous actions happen at compile or dskin time.
      % The following actions happen at dskin or load time.

      `(progn
        ($flavor-define-method ',flavor-name ',method-name ',function-name)
        (putd ',function-name 'expr ',new-code)
        '(method ,flavor-name ,method-name) % for documentation only
        ))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% => - Convenient form for sending a message
%   
% Examples:
%
% (=> r real-part)
%
% (=> r set-real-part 1.0)
%
% The message name is not quoted.  Arguments to the method are supplied as
% arguments to =>.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro => (object message-name . arguments)
  `(send ,object ',message-name . ,arguments))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% SEND - Send a Message (Evaluated Message Name)
%   
% Examples:
%
% (send r 'real-part)
%
% (send r 'set-real-part 1.0)
%
% Note that the message name is quoted.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro send (target-form method-form . argument-forms)

  % If the method name is known at compile time (i.e., the method-form is of
  % the form (QUOTE <id>)) and the target is either SELF (within the body of a
  % DEFMETHOD) or a variable which has been declared (using DECLARE-FLAVOR),
  % then optimize the form to a direct invocation of the method function.

  (if (and (PairP method-form)
	   (eq (car method-form) 'quote)
	   (not (null (cdr method-form)))
	   (IdP (cadr method-form))
	   )
    (let ((method-name (cadr method-form)))
      (cond ((and (eq target-form 'self) $defflavor-expansion-context)
	     ($self-send-expansion method-name argument-forms))
	    ((and (IdP target-form) (get target-form 'declared-type))
	     ($direct-send-expansion target-form method-name argument-forms))
	    (t ($normal-send-expansion target-form method-form argument-forms))
	    ))
    ($normal-send-expansion target-form method-form argument-forms)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% SEND-IF-HANDLES - Conditionally Send a Message (Evaluated Message Name)
%   
% Examples:
%
% (send-if-handles r 'real-part)
%
% (send-if-handles r 'set-real-part 1.0)
%
% SEND-IF-HANDLES is like SEND, except that if the object defines no method
% to handle the message, no error is reported and NIL is returned.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro send-if-handles (object message-name . arguments)
  `(let* ((***SELF*** ,object)
	  (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name))
	  )
     (and ***HANDLER*** (apply ***HANDLER*** (list ***SELF*** ,@arguments)))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% LEXPR-SEND - Send a Message (Explicit "Rest" Argument List)
%   
% Examples:
%
% (lexpr-send foo 'bar a b c list)
%
% The last argument to LEXPR-SEND is a list of the remaining arguments.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro lexpr-send (object message-name . arguments)
  (if arguments
    (let ((explicit-args (reverse (cdr (reverse arguments))))
	  (last-arg (LastCar arguments))
	  )
      (if explicit-args
        `(lexpr-send-1 ,object ,message-name
		       (append (list ,@explicit-args) ,last-arg))
	`(lexpr-send-1 ,object ,message-name ,last-arg)
	)
      )
    `(let ((***SELF*** ,object))
       (apply (object-get-handler ***SELF*** ,message-name)
	      (list ***SELF***)))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% LEXPR-SEND-IF-HANDLES 
%   
% This is the same as LEXPR-SEND, except that no error is reported
% if the object fails to handle the message.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro lexpr-send-if-handles (object message-name . arguments)
  (if arguments
    (let ((explicit-args (reverse (cdr (reverse arguments))))
	  (last-arg (LastCar arguments))
	  )
      (if explicit-args
        `(lexpr-send-1-if-handles ,object ,message-name
				  (append (list ,@explicit-args) ,last-arg))
	`(lexpr-send-1-if-handles ,object ,message-name ,last-arg)
	)
      )
    `(let* ((***SELF*** ,object)
	    (***HANDLER***
	     (object-get-handler-quietly ***SELF*** ,message-name))
	    )
       (and ***HANDLER*** (apply ***HANDLER*** (list ***SELF***))))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% LEXPR-SEND-1 - Send a Message (Explicit Argument List)
%   
% Examples:
%
% (lexpr-send-1 r 'real-part nil)
%
% (lexpr-send-1 r 'set-real-part (list 1.0))
%
% Note that the message name is quoted and that the argument list is passed as a
% single argument to LEXPR-SEND-1.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro lexpr-send-1 (object message-name argument-list)
  `(let ((***SELF*** ,object))
     (apply (object-get-handler ***SELF*** ,message-name)
	    (cons ***SELF*** ,argument-list))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% EV-SEND - EXPR form of LEXPR-SEND-1
%   
% EV-SEND is just like LEXPR-SEND-1, except that it is an EXPR instead of
% a MACRO.  Its sole purpose is to be used as a run-time function object,
% for example, as a function argument to a function.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de ev-send (obj msg arg-list)
  (lexpr-send-1 obj msg arg-list)
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% LEXPR-SEND-1-IF-HANDLES
%   
% This is the same as LEXPR-SEND-1, except that no error is reported if the
% object fails to handle the message.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro lexpr-send-1-if-handles (object message-name argument-list)
  `(let* ((***SELF*** ,object)
	  (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name))
	  )
     (and ***HANDLER*** (apply ***HANDLER*** (cons ***SELF*** ,argument-list)))
     ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% MAKE-INSTANCE - Create a new instance of a flavor.
%   
% Examples:
%
% (make-instance 'complex-number)
% (make-instance 'complex-number 'real-part 0.0 'imaginary-part 1.0)
%
% MAKE-INSTANCE accepts an optional initialization list, consisting of
% alternating pairs of instance variable names and corresponding initial values.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro make-instance (flavor-name . init-plist)
  `(instantiate-flavor ,flavor-name
		       (list . ,init-plist)
		       ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% 
% INSTANTIATE-FLAVOR
%   
% This is the same as MAKE-INSTANCE, except that the initialization list is
% provided as a single (required) argument.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defun instantiate-flavor (flavor-name init-plist)
  (let* ((vector-size (get flavor-name 'instance-vector-size)))
    (if vector-size
      (let* ((object (MkVect (- vector-size 1)))
	     )
	(setf (igetv object #.$object-flavor-slot) flavor-name)
	(setf (igetv object #.$object-debug-slot) NIL)
	(for (from i #.$object-number-of-reserved-slots (- vector-size 1) 1)
	     (do (iputv object i '*UNBOUND*))
	     )
	($object-perform-initialization object init-plist)
	(send-if-handles object 'default-init)
	(send-if-handles object 'init init-plist)
	object
	)
      (ContError 0 "Attempt to instantiate undefined flavor: %w"
		 flavor-name (Instantiate-Flavor flavor-name init-plist))
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Object-Type
%
% The OBJECT-TYPE function returns the type (an ID) of the specified object, or
% NIL, if the argument is not an object.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defun object-type (object)
  (if (and (VectorP object) (> (UpbV object) 1))
    (let ((flavor-name (igetv object #.$object-flavor-slot)))
      (if (IdP flavor-name) flavor-name)
      )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Method Lookup
%
% The following functions return method functions given an object and a message
% name.  The returned function can be invoked, passing the object as the first
% argument and the message arguments as the remaining arguments.  For example,
% the expression (=> foo gorp a b c) is equivalent to:
%
%   (apply (object-get-handler foo 'gorp) (list foo a b c))
%
% It can be useful for efficiency reasons to lookup a method function once and
% then apply it many times to the same object.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defun object-get-handler (object message-name)
  % Returns the method function that implements the specified message when sent
  % to the specified object.  If no such method exists, generate a continuable
  % error.

  (let ((flavor-name (object-type object)))
    (cond
     (flavor-name
      (let ((function-name ($flavor-fetch-method flavor-name message-name)))
	(or function-name
	    (ContError 1000
		       "Flavor %w has no method %w."
		       flavor-name
		       message-name
		       (object-get-handler object message-name)
		       ))))
     (t (ContError 1000
		   "Object %w cannot receive messages."
		   object
		   (object-get-handler object message-name)
		   )))))

(defun object-get-handler-quietly (object message-name)
  % Returns the method function that implements the specified message when sent
  % to the specified object, if it exists, otherwise returns NIL.

  (let ((flavor-name (object-type object)))
    (if flavor-name
      ($flavor-fetch-method flavor-name message-name))))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Method Lookup Tracing
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de trace-method-lookups ()
  % Begin accumulating information about method lookups (invocations of
  % object-get-handler).  The statistics are reset.
  (setf $method-lookup-stats (association-create))
  (copyd 'object-get-handler '$traced-object-get-handler)
  )

(de untrace-method-lookups ()
  % Stop accumulating information about method lookups.
  (copyd 'object-get-handler '$untraced-object-get-handler)
  )

(de print-method-lookup-info ()
  % Stop accumulating information about method lookups and print a summary of
  % the accumulated information about method lookups.  This summary shows which
  % methods were looked up and how many times each method was looked up.

  (untrace-method-lookups)
  (load gsort stringx)
  (setf $method-lookup-stats (gsort $method-lookup-stats '$method-info-sortfn))
  (for (in pair $method-lookup-stats)
       (do (printf "%w  %w%n"
		   (string-pad-left (bldmsg "%w" (cdr pair)) 6)
		   (car pair))))
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DECLARE-FLAVOR
%
% *** Read these warnings carefully! ***
%
% The DECLARE-FLAVOR macro allows you to declare that a specific symbol is
% bound to an object of a specific flavor.  This allows the flavors
% implementation to eliminate the run-time method lookup normally associated
% with sending a message to that variable, which can result in an appreciable
% improvement in execution speed.  This feature is motivated solely by
% efficiency considerations and should be used ONLY where the performance
% improvement is critical.
% 
% Details: if you declare the variable X to be bound to an object of flavor
% FOO, then WITHIN THE CONTEXT OF THE DECLARATION (see below), expressions of
% the form (=> X GORP ...)  or (SEND X 'GORP ...)  will be replaced by function
% invocations of the form (FOO$GORP X ...).  Note that there is no check made
% that the flavor FOO actually contains a method GORP.  If it does not, then a
% run-time error "Invocation of undefined function FOO$GORP" will be reported.
% 
% WARNING: The DECLARE-FLAVOR feature is not presently well integrated with
% the compiler.  Currently, the DECLARE-FLAVOR macro may be used only as a
% top-level form, like the PSL FLUID declaration.  It takes effect for all
% code evaluated or compiled henceforth.  Thus, if you should later compile a
% different file in the same compiler, the declaration will still be in
% effect!  THIS IS A DANGEROUS CROCK, SO BE CAREFUL!  To avoid problems, I
% recommend that DECLARE-FLAVOR be used only for uniquely-named variables.
% The effect of a DECLARE-FLAVOR can be undone by an UNDECLARE-FLAVOR, which
% also may be used only as a top-level form.  Therefore, it is good practice
% to bracket your code in the source file with a DECLARE-FLAVOR and a
% corresponding UNDECLARE-FLAVOR.
%
% Here are the syntactic details:
%
% (DECLARE-FLAVOR FLAVOR-NAME VAR1 VAR2 ...)
% (UNDECLARE-FLAVOR VAR1 VAR2 ...)
%
% *** Did you read the above warnings??? ***
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro declare-flavor (flavor-name . variable-names)
  (prog () % This macro returns NIL!
    (if (not (IdP flavor-name))
      (StdError
       (BldMsg "Flavor name in DECLARE-FLAVOR is not an ID: %p" flavor-name))
      % else
      (for (in var-name variable-names)
	   (do (if (not (IdP var-name))
	         (StdError (BldMsg
			    "Variable name in DECLARE-FLAVOR is not an ID: %p"
			    var-name))
		 % else
		 (put var-name 'declared-type flavor-name)
		 )))
      )))

(dm undeclare-flavor (form)
  (prog () % This macro returns NIL!
    (for (in var-name (cdr form))
	 (do (if (not (IdP var-name))
	       (StdError (BldMsg
			  "Variable name in UNDECLARE-FLAVOR is not an ID: %p"
			  var-name))
	       % else
	       (remprop var-name 'declared-type)
	       )))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Representation Information:
%
% (You don't need to know any of this to use this stuff.)
%
% A flavor-name is an ID.  It has the following properties:
%
% VARIABLE-NAMES	A list of the instance variables of the flavor, in
%			order of their location in the instance vector.  This
%			property exists at compile time, dskin time, and load
%			time.
%
% INITABLE-VARIABLES	A list of the instance variables that have been declared
%			to be INITABLE.  This property exists at dskin time and
%			at load time.
%
% METHOD-TABLE		An association list mapping each method name (ID)
%			defined for the flavor to the corresponding function
%			name (ID) that implements the method.  This property
%			exists at dskin time and at load time.
%
% INSTANCE-VECTOR-SIZE	An integer that specifies the number of elements in the
%			vector that represents an instance of this flavor.  This
%			property exists at dskin time and at load time.  It is
%			used by MAKE-INSTANCE.
%
% The function that implements a method has a name of the form FLAVOR$METHOD.
% Each such function ID has the following properties:
%
% SOURCE-CODE		A list of the form (LAMBDA (SELF ...) ...) which is the
%			untransformed source code for the method.  This property
%			exists at compile time and dskin time.
%
% Implementation Note:
%
% A tricky aspect of this code is making sure that the right things happen at
% the right time.  When a source file is read and evaluated (using DSKIN), then
% everything must happen at once.  However, when a source file is compiled to
% produce a FASL file, then some actions must be performed at compile-time,
% whereas other actions are supposed to occur when the FASL file is loaded.
% Actions to occur at compile time are performed by macros; actions to occur at
% load time are performed by the forms returned by macros.
%
% Another goal of the implementation is to avoid consing whenever possible
% during method invocation.  The current scheme prefers to compile into (APPLY
% HANDLER (LIST args...)), for which the PSL compiler will produce code that
% performs no consing.
% 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Internal Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defun $object-perform-initialization (object init-plist)

  % Perform the initialization of instance variables in OBJECT as specified by
  % the INIT-PLIST, which contains alternating instance variable names and
  % initializing values.

  (let* ((flavor-name (igetv object #.$object-flavor-slot))
	 (initable-vars (get flavor-name 'initable-variables))
	 (variable-names (get flavor-name 'variable-names))
	 name value
	 )
    (while init-plist
      (setf name (car init-plist))
      (setf init-plist (cdr init-plist))
      (if init-plist
	(progn (setf value (car init-plist))
	       (setf init-plist (cdr init-plist)))
	(setf value nil)
	)
      (if (memq name initable-vars)
	(iputv object
	       ($object-lookup-variable-in-list variable-names name)
	       value)
	(ContinuableError 1000
			  (BldMsg "%p not an initable instance variable of flavor %w"
				  name
				  flavor-name)
			  NIL)
	))))

(defun $object-lookup-variable-in-list (variable-names name)
  (for (in v-name variable-names)
       (for i #.$object-number-of-reserved-slots (+ i 1))
       (do (if (eq v-name name) (exit i)))
       (returns nil)
       ))

(defun $substitute-for-symbols (U var-names)
  % Substitute in U for all unquoted instances of the symbols defined in
  % Var-Names.  Also, change SETQ to SETF in forms, since only SETF can handle
  % the substituted forms.

  (cond
   ((IdP U)
    (let ((address ($object-lookup-variable-in-list var-names U)))
      (if address (list 'igetv 'self address) U)
      ))
   ((PairP U)
    (cond
     ((eq (car U) 'quote) U)
     ((eq (car U) 'setq)
      (cons 'setf ($substitute-for-symbols (cdr U) var-names)))
     (t (cons ($substitute-for-symbols (car U) var-names)
	      ($substitute-for-symbols (cdr U) var-names)))
     )
    )
   (t U)
   ))

(defun $flavor-define-method (flavor-name method-name function-name)
  (let ((method-table (get flavor-name 'method-table)))
    (association-bind method-table method-name function-name)))
(copyd 'flavor-define-method '$flavor-define-method) % for compatibility!

(defun $flavor-fetch-method (flavor-name method-name)
  % Returns NIL if the method is undefined.
  (let* ((method-table (get flavor-name 'method-table))
	 (assoc-pair (atsoc method-name method-table))
	 )
    (if assoc-pair (cdr assoc-pair) nil)))

(defun $create-method-source-code (function-name flavor-name)
  (let ((var-names (get flavor-name 'variable-names))
	(source-code (get function-name 'source-code))
        ($defflavor-expansion-context flavor-name) % FLUID variable!
	)
    ($substitute-for-symbols (MacroExpand source-code) var-names)
    ))

(defun $defflavor-process-varlist (flavor-name variable-list)

  % Process the instance variable list of a DEFFLAVOR.  Create a list of valid
  % instance variable names and a list of forms to perform default
  % initialization of instance variables.

  (prog (var-names default-init-code init-form v)
    (for (in v-entry variable-list) (do
				     (cond ((and (PairP v-entry) (IdP (car v-entry)))
					    (setf v (car v-entry))
					    (setf init-form (cdr v-entry))
					    (if init-form (setf init-form (car init-form)))
					    (setf init-form `(if (eq ,v '*UNBOUND*) (setf ,v ,init-form)))
					    (setf default-init-code (aconc default-init-code init-form))
					    )
					   ((IdP v-entry) (setf v v-entry))
					   (t ($defflavor-error "Bad item in variable list: %p" v-entry)
					      (setf v NIL)
					      )
					   )
				     (if v (setf var-names (aconc var-names v)))
				     ))
    (return (list var-names default-init-code))))

(defun $defflavor-build-describe (flavor-name var-names)
  % Return a list of forms that print a description of an instance.

  (let ((describe-code
	 `((printf ,(string-concat "An object of flavor "
				   (id2string flavor-name)
				   ", has instance variable values:%n")))))
    (for (in v var-names)
	 (do
	  (setf describe-code
	    (aconc describe-code `(printf "  %w: %p%n" ',v ,v)))
	  ))
    (aconc describe-code NIL)
    ))

(defun $defflavor-process-options-list (flavor-name var-names options-list)
  % Return an AList mapping var-names to a list of options
  (let ((var-options (association-create)))
    (for (in option options-list)
	 (do ($defflavor-process-option flavor-name var-names
					var-options option)
	     ))
    var-options
    ))

(defun $defflavor-process-option (flavor-name var-names var-options option)
  % Process the option by modifying the AList VAR-OPTIONS.
  (let (option-keyword option-arguments)
    (cond ((PairP option)
	   (setf option-keyword (car option))
	   (setf option-arguments (cdr option))
	   )
	  ((IdP option)
	   (setf option-keyword option)
	   )
	  (t ($defflavor-error "Bad item in options list: %p" option)
	     (setf option-keyword '*NONE*)
	     )
	  )
    (when (neq option-keyword '*NONE*)
      (let ((pair (atsoc option-keyword $defflavor-option-table)))
        (if (null pair)
	  ($defflavor-error "Bad option in options list: %w" option)
	  (apply (cdr pair)
		 (list flavor-name var-names var-options option-arguments))
	  )))))

(defun $defflavor-do-gettable-option (flavor-name var-names var-options args)
  ($defflavor-insert-keyword flavor-name var-names var-options args 'GETTABLE)
  )

(defun $defflavor-do-settable-option (flavor-name var-names var-options args)
  ($defflavor-insert-keyword flavor-name var-names var-options args 'SETTABLE)
  )

(defun $defflavor-do-initable-option (flavor-name var-names var-options args)
  ($defflavor-insert-keyword flavor-name var-names var-options args 'INITABLE)
  )

(defun $defflavor-insert-keyword (flavor-name var-names var-options args key)
  (if (null args) (setf args var-names)) % default: applies to all variables
  (for (in var args) % for each specified instance variable
       (do
	(if (not (memq var var-names))
	  ($defflavor-error "%p (in keyword option) not a variable." var)
	  % else
	  (let ((pair (atsoc var var-options)))
	    (when (null pair)
	      (setf pair (cons var nil))
	      (aconc var-options pair)
	      )
	    (setf (cdr pair) (adjoinq key (cdr pair)))
	    )))))

(defun $defflavor-define-access-function (flavor-name var-name)
  `(defmethod (,flavor-name ,var-name) () ,var-name))

(defun $defflavor-define-update-function (flavor-name var-name)
  (let ((method-name (intern (string-concat "SET-" (id2string var-name)))))
    `(defmethod (,flavor-name ,method-name) (new-value)
       (setf ,var-name new-value))))

(defun $defflavor-create-methods (flavor-name var-options)
  % Return a list of DEFMETHODs for GETTABLE and SETTABLE instance variables.

  (let ((defmethod-list))
    (for (in pair var-options)
	 (do
	  (let ((var-name (car pair))
		(keywords (cdr pair))
		)
	    (if (or (memq 'GETTABLE keywords) (memq 'SETTABLE keywords))
	      (setf defmethod-list
		(cons ($defflavor-define-access-function flavor-name var-name)
		      defmethod-list
		      )))
	    (if (memq 'SETTABLE keywords)
	      (setf defmethod-list
		(cons ($defflavor-define-update-function flavor-name var-name)
		      defmethod-list
		      )))
	    )))
    defmethod-list
    ))

(defun $defflavor-initable-vars (flavor-name var-options)
  % Return a list containing the names of instance variables that have been
  % declared to be INITable.
  (for (in pair var-options)
       (when (and (PairP pair)
		  (or (memq 'INITABLE (cdr pair))
		      (memq 'SETTABLE (cdr pair))
		      )))
       (collect (car pair))
       )
  )

(de $defflavor-function-name (flavor-name method-name)
  (intern (string-concat (id2string flavor-name) "$" (id2string method-name))))

(de $normal-send-expansion (target-form method-form argument-forms)
  `(let ((***SELF*** ,target-form))
     (apply (object-get-handler ***SELF*** ,method-form)
            (list ***SELF*** ,@argument-forms))))

(de $self-send-expansion (method-name argument-forms)
  (cons ($defflavor-function-name $defflavor-expansion-context method-name)
        (cons 'self argument-forms)))

(de $direct-send-expansion (target-id method-name argument-forms)
  (let ((target-type (get target-id 'declared-type)))
    (cons ($defflavor-function-name target-type method-name)
          (cons target-id argument-forms))))

(copyd '$untraced-object-get-handler 'object-get-handler)

(de $traced-object-get-handler (obj method-name)
  (let* ((result ($untraced-object-get-handler obj method-name))
	 (count (association-lookup $method-lookup-stats result))
	 )
    (association-bind $method-lookup-stats result (if count (+ count 1) 1))
    result
    ))

(de $method-info-sortfn (m1 m2)
  (numbersortfn (cdr m2) (cdr m1))
  )