rs@uunet.UU.NET (Rich Salz) (08/03/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 81
Archive-name: comobj.lisp/Part07
#! /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 7 (of 13)."
# Contents: co-dmeth.l macros.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-dmeth.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-dmeth.l'\"
else
echo shar: Extracting \"'co-dmeth.l'\" \(22335 characters\)
sed "s/^X//" >'co-dmeth.l' <<'END_OF_FILE'
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-dmeth.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Defining CommonObjects methods
X; Author: James Kempf
X; Created: March 10, 1987
X; Modified: 12-Mar-87 09:21:38 (James Kempf)
X; Language: Lisp
X; Package: COMMON-OBJECTS
X; Status: Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); 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(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; nued) Support for Using Keywords as Method Names
X;
X; These macros and functions translate keyword method names into
X; names in a package. Some Common Lisps do allow keyword symbols
X; to have an associated function, others don't. Rather than
X; differentiating, a single package, KEYWORD-STANDIN, is used
X; for method symbols which are keywords.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(defun keyword-standin (keyword)
X
X ;;An example of a special method is :print which gets
X ;; translated into the symbol pcl:print-instance
X
X (if (special-keyword-p keyword)
X (keyword-standin-special keyword)
X (intern (symbol-name keyword) *keyword-standin-package*)
X )
X
X) ;end keyword-standin
X
X;;unkeyword-standin-Return the keyword for a standin symbol
X
X(defun unkeyword-standin (symbol)
X
X (if (special-method-p symbol)
X (unkeyword-standin-special symbol)
X (if (eq (symbol-package symbol) *keyword-standin-package*)
X (setf symbol (intern (symbol-name symbol) (find-package :keyword)))
X symbol
X
X ) ;if
X
X ) ;if
X
X) ;end unkeyword-standin
X
X;;Set up the universal method selector list, for fast messaging
X
X(eval-when (load eval)
X (dolist (l *universal-methods*)
X (push (keyword-standin l) *universal-method-selectors*)
X )
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Runtime Interface to the Slots
X;
X; The extra slots are used for the pointer to self and for parents. Each
X; ancestor is actually a fully fledged object of the ancestor type, except its
X; pointer to self slot points back to the original object piece.
X; Slot indicies can be calculated directly at compile time, since they do
X; not change after the object is created.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;self-from-inner-self-Return the pointer to the original object
X
X(defmacro self-from-inner-self ()
X `(%instance-ref .inner-self. ,$SELF-INDEX)
X
X) ;end self-from-inner-self
X
X;;parent-from-inner-self-Given the parent's name, return a pointer
X;; to the object piece in which the instance variables are stored.
X
X(defmacro parent-from-inner-self (parent-class-name)
X `(get-slot .inner-self. ',(local-super-slot-name parent-class-name))
X
X) ;end parent-from-inner-self
X
X;;local-super-slot-name-Generate a slot name for the parent's instance
X;; variable
X
X(defun local-super-slot-name (local-super-name)
X (intern (concatenate 'string
X "Slot For "
X (symbol-name local-super-name)))
X
X) ;end local-super-slot-name
X
X;;calculate-slot-index-Return the index of the slot in the vector
X
X(defun calculate-slot-index (slotname parents slots)
X
X (let
X (
X (parloc (position slotname parents))
X (sloc (position slotname slots))
X )
X
X (if parloc
X (+ $START-OF-PARENTS parloc)
X (+ $START-OF-PARENTS (length parents) sloc)
X )
X
X )
X
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; New Method Class For CommonObjects
X;
X; CommonObjects methods need to keep track of their method symbol, so
X; that the symbol can be looked up and inserted into a CALL-METHOD
X; or APPLY-METHOD when a method including one of these forms is loaded.
X; The new method keeps track of a method symbol as an instance variable,
X; and maintains the symbol's function cell with an accurate pointer to
X; the current function implementing the method. The function is called
X; through this symbol during run-time processing of a CALL-METHOD.
X; Note that, since the method object gets created when the method
X; is loaded (or, alternatively, looked up, if a CALL-METHOD was
X; processed before the method was defined), the symbol will be GENSYM'ed
X; in the load time environment. Fully qualified symbols are needed for
X; the method names because they are not exported from the PCL package.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;common-objects-method-Add an additional slot for the function symbol name
X
X(ndefstruct
X (common-objects-method (:class class)
X (:include pcl::method)
X (:conc-name method-)
X )
X (function-symbol NIL) ;;name of the method function
X ;; used for call-method
X
X) ;end common-objects-method
X
X;;method-function-Need this to have the SETF
X;; method work correctly
X
X(defmeth method-function ((method common-objects-method))
X
X ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X ;; new code.
X
X (call-next-method)
X
X
X) ;end method-function
X
X;;method-function-Even though we may not yet be able to
X;; determine what the function symbol is, the SETF method
X;; must reset the symbol's function, in the event the
X;; method object is recycled.
X
X(defmeth (method-function (:setf (nv))) ((method common-objects-method))
X
X
X ;;If the method function symbol for the CALL-METHOD optimization
X ;; has not yet been set, do it.
X
X (when (method-function-symbol method)
X (setf (symbol-function (method-function-symbol method))
X nv
X )
X
X )
X
X
X ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X ;; new code.
X
X (call-next-method)
X
X) ;end method-function :setf
X
X;;method-discriminator-Need this to have the SETF
X;; method work correctly
X
X(defmeth method-discriminator ((method common-objects-method))
X
X ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X ;; new code.
X
X (call-next-method)
X
X
X) ;end method-discriminator
X
X;;method-discriminator-By the time the method's discriminator is
X;; set, the method has enough information to generate the
X;; symbol for CALL-METHOD optimization.
X
X(defmeth (method-discriminator (:setf (nv))) ((method common-objects-method))
X
X
X ;;If the method function symbol for the CALL-METHOD optimization
X ;; has not yet been set, do it.
X
X (when (not (method-function-symbol method))
X (setf (method-function-symbol method)
X (generate-method-function-symbol
X (class-name (car (method-type-specifiers method)))
X (discriminator-name nv)
X )
X )
X (setf (symbol-function (method-function-symbol method))
X (method-function method)
X )
X
X )
X
X
X ;;This was RUN-SUPER-INTERNAL, but now changed to accomodate
X ;; new code.
X
X (call-next-method)
X
X) ;end method-discriminator :setf
X
X;;generate-method-function-symbol-Generate a method function
X;; symbol for the method. Used in the CALL-METHOD optimization.
X
X(defun generate-method-function-symbol (class-name message)
X
X ;;Generate a symbol for the function to be called.
X ;; This is in the same package as the method name
X ;; symbol, and its name as the form:
X ;; <class package name>;;<class name> <message package name>;;<message>
X ;; Note that this will avoid collisions for two methods with
X ;; the same name and different packages, because the symbol
X ;; names (as well as the packages) are different.
X ;; We hope that this should avoid collision.
X
X (intern
X (concatenate 'simple-string
X (package-name (symbol-package class-name))
X ";;"
X (symbol-name class-name)
X " "
X (package-name
X (if (keywordp message)
X (find-package 'keyword-standin)
X (symbol-package message)
X )
X )
X ";;"
X (symbol-name message)
X )
X (if (keywordp message)
X (find-package 'keyword-standin)
X (symbol-package message)
X )
X )
X
X) ;generate-method-function-symbol
X
X;;expand-with-make-entries-Returns an alist of the form:
X;;
X;; (<prefix+slot-name> <instance-form> <class> <slotd> <use-slot-value-p>)
X;;
X
X(defmeth expand-with-make-entries ((method common-objects-method) first-arg)
X (declare (ignore first-arg)) ; rds 3/8
X (let*
X (
X (entries ())
X (method-argument (first (method-arglist method)))
X (method-type-spec (first (method-type-specifiers method)))
X )
X
X ;;CommonObjects methods only discriminate on the first
X ;; argument. Also, we always want to use the slot value,
X ;; since there is no slotd-accessor.
X
X (dolist (slotd (class-slots method-type-spec))
X (push
X (list
X (slotd-name slotd) ;;the slot name
X method-argument ;;the instance arg name
X method-type-spec ;;the class
X slotd ;;the slot descriptor
X T ;;use the slot value directly
X )
X entries
X )
X ) ;dolist
X
X entries
X
X ) ;let*
X
X) ;expand-with-make-entries
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Messaging Macros and Functions
X;
X; Message sending becomes funcalling the message.
X; We convert all message sends to a funcall of the message. Because
X; CommonObjects encourages messages to be keywords and keywords are
X; not funcallable, we have to have a special package in which keywords
X; are interned before their use as messages.
X;
X; As an example of all this, take the expansion of a sample =>:
X;
X; (=> object :message arg-1 arg-2) expands into:
X;
X; (funcall 'keyword-standin::message object arg-1 arg-2)
X;
X; This means that all CommonObjects discriminators will be classical.
X; That is they will discriminator only on the class of their first
X; argument.
X;
X; The first argument to any method will always be the inner self, that is
X; an instance of the same class as the method was defined on. This is
X; bound to the symbol .INNER-SELF., special macros SELF-FROM-INNER-SELF
X; and PARENT-FROM-INNER-SELF are used to access outer-self and parent
X; instances.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;make-set-message-Construct a :SET-xxx message for SETF
X
X(defmacro make-set-message (message)
X
X `(intern
X (concatenate 'simple-string
X "SET-"
X (symbol-name ,message)
X )
X (symbol-package ,message)
X
X )
X
X) ;make-set-message
X
X;;=>-Convert to PCL messaging. Note that no error or type checking occurs.
X
X(defmacro => (object message &rest args)
X
X `(funcall
X ,(if (keywordp message)
X `',(keyword-standin message)
X message
X )
X ,object
X ,@args
X )
X
X) ;end =>
X
X;;send?-Messaging macro which returns NIL if something is wrong.
X
X(defmacro send? (object message &rest args)
X
X `(send?-internal
X ,object
X ,(if (keywordp message)
X `',(keyword-standin message)
X message
X )
X ,@args
X )
X
X) ;end send?
X
X;;Setf definitions for messaging macros.
X
X(defsetf => (obj message) (new-value)
X
X `(progn
X (=> ,obj
X ,(if (keywordp message)
X (make-set-message message)
X `(make-set-message ,message)
X )
X ,new-value
X )
X )
X) ;end defsetf for =>
X
X(defsetf send? (obj message) (new-value)
X `(progn
X (send? ,obj
X ,(if (keywordp message)
X (make-set-message message)
X `(make-set-message ,message)
X )
X ,new-value
X )
X )
X) ;end defsetf for send?
X
X;;send?-internal-Process the message invocation into correct code for
X;; SEND?
X
X(defun send?-internal (object message &rest args)
X
X (if object
X (let*
X (
X (class (class-of object))
X (class-name (class-name class))
X (metaclass-name (class-name (class-of class)))
X
X )
X
X ;;Check if OBJECT is an instance and class is still defined
X ;; and operation is supported.
X
X (if (and
X (eq metaclass-name 'common-objects-class)
X (not (eq class-name $UNDEFINED-TYPE-NAME))
X (fast-supports-operation-p class message)
X )
X
X (apply message object args)
X
X NIL
X
X ) ;if
X
X ) ;let*
X
X ) ;if
X
X) ;send?-internal
X
X;;fast-supports-operation-p-Does no checking on CLASS
X
X(defun fast-supports-operation-p (class message)
X
X;;Check first if its a universal method
X
X (if (member (unkeyword-standin message) *universal-methods*)
X
X T
X
X ;;Otherwise, check in the class object if it's got them
X
X (dolist (methobj (pcl::class-direct-methods class))
X
X (when (eq (method-name methobj) message)
X (return-from fast-supports-operation-p T)
X )
X
X ) ;dolist
X ) ;if
X
X) ;fast-supports-operation-p
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Method Definition
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;defcommon-objects-meth-Create method and discriminator objects and
X;; call EXPAND-DEFMETH-INTERNAL. The method object is of class
X;; common-objects-method. Note that this macro gets expanded at the
X;; time this file is compiled.
X
X(defmacro defcommon-objects-meth (message arglist body)
X
X
X `(let
X (
X (discriminator-class-object (class-named 'pcl::discriminator t))
X (method-class-object (class-named 'common-objects-method t))
X )
X
X (pcl::expand-defmeth-internal (class-prototype discriminator-class-object)
X (class-prototype method-class-object)
X (if (listp ,message) ,message (list ,message))
X ,arglist
X (list ,body)
X )
X
X ) ;let
X
X) ;end defcommon-objects-meth
X
X;;define-method-Top level programmer interface to method
X;; definition
X
X(defmacro define-method (spec arglist &body body)
X
X ;;Syntax check the call first
X
X (co-parse-method-macro-call spec arglist body)
X
X (let*
X (
X (class-name (car spec))
X (message (if (keywordp (cadr spec))
X (keyword-standin (cadr spec))
X (cadr spec)))
X )
X
X
X ;;Check first to be sure that class is a CommonObjects class
X
X (if (not
X (eq (class-name (class-of (class-named class-name T))) 'common-objects-class)
X )
X (error "DEFINE-METHOD: `~S' is not a CommonObjects type." class-name)
X )
X
X ;;The compiler-let of *CURRENT-METHOD-CLASS-NAME* is to support
X ;; CALL-METHOD.
X ;; Also, bind SELF around the body to outer self.
X ;; Note that this allows someone to rebind SELF in the body, but
X ;; that rebinding will not affect CALL-METHOD, APPLY-METHOD or IV
X ;; access since they don't really use SELF.
X ;; Also, use WITH to allow lexical access to the instance
X ;; variables.
X
X (setq body `(compiler-let
X (
X (*current-method-class-name* ',class-name)
X )
X
X (let ((self (self-from-inner-self)))
X (with*
X (
X (.inner-self. "" ,class-name)
X )
X
X self
X (progn . ,body))
X )
X
X ) ;compiler-let
X )
X
X
X `(progn
X
X ,(defcommon-objects-meth message
X `((.inner-self. ,class-name) ,@arglist)
X
X body
X
X )
X
X (list ',class-name ',(cadr spec))
X
X ) ;progn
X
X ) ;let*
X
X) ;end define-method
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Call-Method and Optimizations
X;
X; Because of pf the ambiguous nature of the definition of #, in CLtL,
X; the implementation of #, may not work correctly on a particular system
X; when used within the backquote macro in compiled code.
X; The kind of behavior which is needed is as follows (with reference
X; to 5.3.3, pg. 70)
X;
X; 1) If the situation is EVAL, then execute the function
X; LOAD-TIME-GET-CALL-METHOD-FUNCTION-SYMBOL and cache the
X; method symbol in line when the code is macroexpanded.
X;
X; 2) If the situation is compile, then arrange for the function
X; LOAD-TIME-GET-CALL-METHOD-FUNCTION-SYMBOL to be executed
X; and the result cached only when the file gets loaded.
X;
X; What I want to say is:
X;
X; `(,caller
X; #,(load-time-get-call-method-function ',class-name ',method-name
X; ',arglist
X; )
X; <rest of form>
X; )
X;
X; and have it work correctly. Well, it doesn't always.
X;
X; Alternatively, I would like to generate a closure at compile time
X; which will get fasled into the output file and will cache the
X; method symbol the first time it is called. But that doesn't
X; always work either.
X;
X; So, instead, I tried using an elaborate scheme which creates vectors
X; at compile time and uses a top level (EVAL-WHEN (LOAD) ...) to
X; depost the method symbol at load time. The special variable
X; *LIST-OF-CALL-METHOD-FIXUPS* gets bound to NIL before every
X; DEFINE-METHOD invocation. The CALL-METHOD macro creates
X; instances of the DEFSTRUCT CALL-METHOD-RECORD and pushes them
X; on *LIST-OF-CALL-METHOD-FIXUPS* recording CALL-METHODs and
X; vectors for caching the method symbol. The CALL-METHOD macro
X; can do this because the PCL method EXPAND-DEFMETH-INTERNAL
X; is replaced in the patches file. This new method walks
X; them method code body during the execution of EXPAND-DEFMETH-INTERNAL
X; rather than at the top level, as in the stock PCL system.
X; If this change is NOT made, then the method body must
X; be prewalked before code generation, because the code
X; walk (during which CALL-METHOD gets expanded) doesn't
X; occur until after DEFINE-METHOD returns to the top level.
X;
X; As the last part of the DEFINE-METHOD code generation,
X; a top level (EVAL-WHEN (LOAD EVAL) ...) is generated to get
X; the method symbol at load time and deposit it in the
X; vector. The SVREF gets the symbol at the time the CALL-METHOD
X; is invoked. So, in effect, I'm generating my own
X; closure.
X;
X; Well, that doesn't work either. Why? Because once the
X; vector is deposited into the code, there is no guarantee
X; that it will be EQ to the one in the list. And, in any
X; event, this scheme won't work in traditional interpreters
X; which expand macros as they are encountered, since the
X; top level (EVAL-WHEN (LOAD EVAL) ... ) gets done before
X; the CALL-METHOD macro is fully expanded.
X;
X; Sigh. The only choice is to GENSYM a symbol at compile
X; time and pray that it doesn't trash something at load time.
X; But maybe that's OK.
X;
X; Note that the general behavior which is desired here is loadtime
X; execution within generated code, rather than at the top level.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;call-method-Top level macro for CALL-METHOD.
X
X(defmacro call-method (spec &rest args)
X (call-method-internal 'call-method spec args)
X
X) ;end call-method
X
X;;apply-method-Top level macro for APPLY-METHOD.
X
X(defmacro apply-method (spec &rest args)
X (call-method-internal 'apply-method spec args)
X
X) ;end apply-method
X
X;;call-method-internal-Process a CALL-METHOD invocation.
X
X(defun call-method-internal (for spec args)
X (declare (special *current-method-class-name*))
X (if (null (boundp '*current-method-class-name*))
X (error "Attempt to use ~S other than inside a method.~%" for)
X (let* ((caller (ecase for
X (call-method 'funcall)
X (apply-method 'apply)))
X (class-name (if (listp spec)
X (car spec)
X *current-method-class-name*))
X (message (if (listp spec) (cadr spec) spec))
X
X (fsym (generate-method-function-symbol class-name message))
X
X )
X
X
X ;;Check the syntax
X
X (co-parse-call-to-method (list for spec args)
X (symbol-name for)
X *current-method-class-name*
X )
X
X
X ;;Generate code. Note there is no need to check
X ;; whether or not the method function symbol
X ;; is bound or to do any fixing up at all.
X ;; If it is not, then its an error, because
X ;; the method hasn't yet been defined. The
X ;; function cell will be bound when the
X ;; method gets defined.
X
X `(,caller (symbol-function ',fsym)
X
X ,(if (listp spec)
X `(parent-from-inner-self ,class-name)
X '.inner-self.)
X ,@args)
X ) ;let
X ) ;if
X
X) ;end call-method-internal
X
X
X;;legal-parent-p-Is parent-name a legal parent of class-name?
X
X(defun legal-parent-p (class-name parent-name)
X
X (member parent-name
X (class-local-super-names (class-named class-name T))
X :test #'eq
X
X )
X) ;legal-parent-p
X
X
END_OF_FILE
if test 22335 -ne `wc -c <'co-dmeth.l'`; then
echo shar: \"'co-dmeth.l'\" unpacked with wrong size!
fi
# end of 'co-dmeth.l'
fi
if test -f 'macros.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'macros.l'\"
else
echo shar: Extracting \"'macros.l'\" \(25561 characters\)
sed "s/^X//" >'macros.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); 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;;; Macros global variable definitions, and other random support stuff used
X;;; by the rest of the system.
X;;;
X;;; For simplicity (not having to use eval-when a lot), this file must be
X;;; loaded before it can be compiled.
X;;;
X
X(in-package 'pcl :nicknames '(portable-commonloops) :use '(lisp walker))
X
X(export '(defclass
X defmethod
X print-object
X
X print-instance
X ndefstruct
X defmeth
X run-super
X make
X initialize
X get-slot
X with
X with*
X class-of
X class-named
X discriminator-named
X class-prototype
X class
X object
X
X
X
X essential-class
X
X class-name
X class-precedence-list
X class-local-supers
X class-local-slots
X class-direct-subclasses
X class-direct-methods
X class-slots
X
X
X essential-discriminator
X
X discriminator-name
X discriminator-methods
X discriminator-discriminating-function
X
X essential-method
X
X method-discriminator
X method-arglist
X method-argument-specifiers
X method-function
X
X method-equal
X
X discriminator-methods
X
X slotd-name
X slot-missing
X
X define-meta-class
X %make-instance
X %instance-ref
X %instancep
X %instance-meta-class
X
X make-instance
X get-slot
X put-slot
X get-slot-using-class
X optimize-slot-access
X define-class-of-clause
X add-named-class
X class-for-redefinition
X add-class
X supers-changed
X slots-changed
X check-super-meta-class-compatibility
X check-meta-class-change-compatibility
X make-slotd
X compute-class-precedence-list
X walk-method-body
X walk-method-body-form
X optimize-get-slot
X optimize-set-of-get-slot
X variable-lexical-p
X add-named-method
X add-method
X remove-named-method
X remove-method
X find-method
X find-method-internal
X make-discriminating-function
X install-discriminating-function
X no-matching-method
X class-class-precedence-list
X class-local-supers
X class-direct-subclasses
X class-name
X
X )
X (find-package 'pcl))
X
X(proclaim '(declaration values ;I use this so that Zwei can
X ;remind me what values a
X ;function returns.
X
X method-function-name ;This is used so that some
X ;systems can print the name
X ;of the method when I am in
X ;the debugger.
X ))
X
X;;; Age old functions which CommonLisp cleaned-up away. They probably exist
X;;; in other packages in all CommonLisp implementations, but I will leave it
X;;; to the compiler to optimize into calls to them.
X;;;
X;;; Common Lisp BUG:
X;;; Some Common Lisps define these in the Lisp package which causes
X;;; all sorts of lossage. Common Lisp should explictly specify which
X;;; symbols appear in the Lisp package.
X;;;
X(defmacro memq (item list) `(member ,item ,list :test #'eq))
X(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
X(defmacro rassq (item list) `(rassoc ,item ,list :test #'eq))
X(defmacro delq (item list) `(delete ,item ,list :test #'eq))
X(defmacro neq (x y) `(not (eq ,x ,y)))
X
X(defun make-caxr (n form)
X (if (< n 4)
X `(,(nth n '(car cadr caddr cadddr)) ,form)
X (make-caxr (- n 4) `(cddddr ,form))))
X
X(defun make-cdxr (n form)
X (cond ((zerop n) form)
X ((< n 5) `(,(nth n '(identity cdr cddr cdddr cddddr)) ,form))
X (t (make-cdxr (- n 4) `(cddddr ,form)))))
X
X(defmacro ignore (&rest vars)
X #+Symbolics `(progn ,.(remove 'ignore vars))
X #-Symbolics `(progn ,@vars))
X
X(defun true (&rest ignore) (ignore ignore) t)
X(defun false (&rest ignore) (ignore ignore) nil)
X
X;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just
X;;; lifted it from there but I am honest. Not only that but this one is
X;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more
X;;; like rebuilding Rome.
X(defmacro once-only (vars &body body)
X (let ((gensym-var (gensym))
X (run-time-vars (gensym))
X (run-time-vals (gensym))
X (expand-time-val-forms ()))
X (dolist (var vars)
X (push `(if (or (symbolp ,var)
X (numberp ,var)
X (and (listp ,var)
X (member (car ,var) '(quote function))))
X ,var
X (let ((,gensym-var (gensym)))
X (push ,gensym-var ,run-time-vars)
X (push ,var ,run-time-vals)
X ,gensym-var))
X expand-time-val-forms))
X `(let* (,run-time-vars
X ,run-time-vals
X (wrapped-body
X ((lambda ,vars . ,body) . ,(reverse expand-time-val-forms))))
X `((lambda ,(nreverse ,run-time-vars) ,wrapped-body)
X . ,(nreverse ,run-time-vals)))))
X
X(defun extract-declarations (body &optional environment)
X (declare (values documentation declares body))
X (let (documentation declares form temp)
X (when (stringp (car body)) (setq documentation (pop body)))
X (loop
X (when (null body) (return))
X (setq form (car body))
X (cond ((and (listp form) (eq (car form) 'declare))
X (push (pop body) declares))
X; ((and (neq (setq temp (macroexpand form environment)) form)
X; (listp temp)
X; (eq (car temp) 'declare))
X; (pop body)
X; (push temp declares))
X (t (return))))
X (values documentation declares body)))
X
X ;;
X;;;;;; FAST-NCONC Lists
X ;;
X;;; These are based on Interlisp's TCONC function. They are slighlty
X;;; generalized to take either the item to nconc onto the end of the list or
X;;; a cons to add to the end of a list. In addition there is a constructor to
X;;; make fast-nconc-lists and an accessor to get at a fast-nconc-list's real
X;;; list.
X(defmacro make-fast-nconc-list ()
X `(let ((fast-nconc-list (cons () (list ()))))
X (rplaca fast-nconc-list (cdr fast-nconc-list))
X fast-nconc-list))
X
X(defmacro fast-nconc-list-real-list (fast-nconc-list)
X `(cddr ,fast-nconc-list))
X
X(defmacro fast-nconc-cons (fast-nconc-list cons)
X (once-only (fast-nconc-list)
X `(progn (rplacd (car ,fast-nconc-list) ,cons)
X (rplaca ,fast-nconc-list (cdar ,fast-nconc-list)))))
X
X(defmacro fast-nconc-item (fast-nconc-list item)
X `(fast-nconc-cons ,fast-nconc-list (cons ,item nil)))
X
X#+Lucid
X(eval-when (compile load eval)
X (eval `(defstruct ,(intern "FASLESCAPE" (find-package 'lucid)))))
X
X; rds 3/8 added -HP and +HP for make-keyword:
X#-HP
X(defun make-keyword (symbol)
X (intern (symbol-name symbol) '#,(find-package 'keyword)))
X
X#+HP
X(defun make-keyword (symbol)
X (intern (symbol-name symbol) (find-package 'keyword)))
X
X(defun string-append (&rest strings)
X (setq strings (copy-list strings)) ;The explorer can't even
X ;rplaca an &rest arg?
X (do ((string-loc strings (cdr string-loc)))
X ((null string-loc)
X (apply #'concatenate 'string strings))
X (rplaca string-loc (string (car string-loc)))))
X
X(defun symbol-append (sym1 sym2 &optional (package *package*))
X (intern (string-append sym1 sym2) package))
X
X(defmacro check-member (place list &key (test #'eql) (pretty-name place))
X (once-only (place list)
X `(or (member ,place ,list :test ,test)
X (error "The value of ~A, ~S is not one of ~S."
X ',pretty-name ,place ,list))))
X
X
X
X;;; A simple version of destructuring-bind.
X
X;;; This does no more error checking than CAR and CDR themselves do. Some
X;;; attempt is made to be smart about preserving intermediate values. It
X;;; could be better, although the only remaining case should be easy for
X;;; the compiler to spot since it compiles to PUSH POP.
X;;;
X;;; Common Lisp BUG:
X;;; Common Lisp should have destructuring-bind.
X;;;
X(defmacro destructuring-bind (pattern form &body body)
X (multiple-value-bind (ignore declares body)
X (extract-declarations body)
X (multiple-value-bind (setqs binds)
X (destructure pattern form)
X `(let ,binds
X ,@declares
X ,@setqs
X . ,body))))
X
X(defun destructure (pattern form)
X (declare (values setqs binds))
X (let ((*destructure-vars* ())
X (setqs ()))
X (declare (special *destructure-vars*))
X (when (not (symbolp form))
X (setq *destructure-vars* '(.destructure-form.)
X setqs (list `(setq .destructure-form. ,form)))
X (setq form '.destructure-form.))
X (values (nconc setqs (nreverse (destructure-internal pattern form)))
X (delete nil *destructure-vars*))))
X
X(defun destructure-internal (pattern form)
X ;; When we are called, pattern must be a list. Form should be a symbol
X ;; which we are free to setq containing the value to be destructured.
X ;; Optimizations are performed for the last element of pattern cases.
X ;; we assume that the compiler is smart about gensyms which are bound
X ;; but only for a short period of time.
X (declare (special *destructure-vars*))
X (let ((gensym (gensym))
X (pending-pops 0)
X (var nil)
X (setqs ()))
X (labels
X ((make-pop (var form pop-into)
X (prog1
X (cond ((zerop pending-pops)
X `(progn ,(and var `(setq ,var (car ,form)))
X ,(and pop-into `(setq ,pop-into (cdr ,form)))))
X ((null pop-into)
X (and var `(setq ,var ,(make-caxr pending-pops form))))
X (t
X `(progn (setq ,pop-into ,(make-cdxr pending-pops form))
X ,(and var `(setq ,var (pop ,pop-into))))))
X (setq pending-pops 0))))
X (do ((pat pattern (cdr pat)))
X ((null pat) ())
X (if (symbolp (setq var (car pat)))
X (progn
X (push var *destructure-vars*)
X (cond ((null (cdr pat))
X (push (make-pop var form ()) setqs))
X ((symbolp (cdr pat))
X (push (make-pop var form (cdr pat)) setqs)
X (push (cdr pat) *destructure-vars*)
X (return ()))
X ((memq var '(nil ignore)) (incf pending-pops))
X ((memq (cadr pat) '(nil ignore))
X (push (make-pop var form ()) setqs)
X (incf pending-pops 1))
X (t
X (push (make-pop var form form) setqs))))
X (progn
X (push `(let ((,gensym ()))
X ,(make-pop gensym form (if (symbolp (cdr pat)) (cdr pat) form))
X ,@(nreverse
X (destructure-internal (if (consp pat) (car pat) pat)
X gensym)))
X setqs)
X (when (symbolp (cdr pat))
X (push (cdr pat) *destructure-vars*)
X (return)))))
X setqs)))
X
X;;; Iterate is a simple iteration macro. If CommonLisp had a standard Loop
X;;; macro I wouldn't need this wretched crock. But what the hell, it seems
X;;; to do most of what I need. It looks like:
X;;; (iterate (<control-clause-1> <control-clause-2> ...)
X;;; . <body>)
X;;;
X;;; a control clause can be one of:
X;;; (<var> in <list-form>) | (<var> in <list-form> by <function>)
X;;; (<var> on <list-form>) | (<var> on <list-form> by <function>)
X;;; (<var> from <initial> to <final>)
X;;; (<var> from <initial> below <final>)
X;;; (<var> from <initial> to <final> by <function> | <increment>)
X;;; (<var> from <initial> below <final> by <function> | <increment>)
X;;; (<var> = <form>) <form> is evaluated each time through
X;;; (<var> = <initial> <subsequent>)
X;;;
X;;; inside <body> you are allowed to use:
X;;; collect
X;;; join
X;;; sum
X
X(defvar *iterate-result-types* ())
X
X(defmacro define-iterate-result-type (name arglist &body body)
X (let ((fn-name
X (if (and (null (cdr body)) (symbolp (car body)))
X (car body)
X (make-symbol (string-append (symbol-name name) " iterate result type")))))
X `(progn
X (let ((existing (assq ',name *iterate-result-types*)))
X (if existing
X (rplacd existing ',fn-name)
X (push ',(cons name fn-name) *iterate-result-types*)))
X ,(and (not (and (null (cdr body)) (symbolp (car body))))
X `(defun ,fn-name ,arglist . ,body)))))
X
X(defmacro iterate (controls &body body)
X #+Xerox (setq body (copy-tree body))
X (let (binds var-init-steps
X pre-end-tests post-end-tests
X pre-bodies post-bodies
X (result-type ()))
X (mapc #'(lambda (control)
X (let ((var (car control))
X (type (cadr control))
X (initial (caddr control))
X (args (cdddr control)))
X (ecase type
X ((in on)
X (let* ((gensym (if (or (eq type 'in) (consp var)) (gensym) var))
X (step `(,(if args (cadr args) 'cdr) ,gensym)))
X (push `(,gensym ,initial ,step) var-init-steps)
X (push `(null ,gensym) pre-end-tests)
X (cond ((listp var)
X (multiple-value-bind (setqs dbinds)
X (destructure var (if (eq type 'in) `(car ,gensym) gensym))
X (setq binds (nconc dbinds binds))
X (setq pre-bodies (nconc pre-bodies (nreverse setqs)))))
X ((eq type 'in)
X (push var binds)
X (push `(setq ,var (car ,gensym)) pre-bodies)))))
X (from
X (let ((gensym (gensym))
X (final
X (and (memq (car args) '(to below))
X (if (eq (car args) 'to)
X (cadr args)
X `(- ,(cadr args) 1))))
X (step
X (progn (setq args (member 'by args))
X (cond ((null args)
X `(1+ ,var))
X ((numberp (cadr args))
X `(+ ,var ,(cadr args)))
X (t (cadr args))))))
X (push `(,var ,initial ,step) var-init-steps)
X (and final (push `(,gensym ,final) binds))
X (and final (push `(> , var ,gensym) pre-end-tests))))
X (=
X (push `(,var ,initial ,(or (car args) initial))
X var-init-steps))
X )))
X controls)
X (setq body
X (walk-form (cons 'progn body)
X :walk-function
X #'(lambda (form context &aux aux)
X (ignore context)
X (or (and (listp form)
X (setq aux (assq (car form) *iterate-result-types*))
X (setq result-type
X (if (null result-type)
X (funcall (cdr aux)
X form nil 'create-result-type)
X (funcall (cdr aux)
X form result-type 'check-result-type)))
X (funcall (cdr aux) form result-type 'macroexpand))
X form))))
X (let* ((initially (cons 'progn
X (dolist (tlf body)
X (when (and (consp tlf) (eq (car tlf) 'initially))
X (return (prog1 (cdr tlf)
X (setf (car tlf) 'progn
X (cdr tlf) ())))))))
X (finally (cons 'progn
X (dolist (tlf body)
X (when (and (consp tlf) (eq (car tlf) 'finally))
X (return (prog1 (cdr tlf)
X (setf (car tlf) 'progn
X (cdr tlf) ()))))))))
X `(let (,@binds . ,(caddr result-type))
X (iterate-macrolets
X (prog ,(mapcar #'(lambda (x) (list (car x) (cadr x)))
X var-init-steps)
X ,initially
X restart
X (and (or . ,(reverse pre-end-tests))
X (go .iterate_return.))
X (progn . ,(reverse pre-bodies))
X ,body
X (progn . ,(reverse post-bodies))
X (or ,@post-end-tests
X (progn ,@(mapcar #'(lambda (x)
X (and (cddr x)
X `(setq ,(car x)
X ,(caddr x))))
X var-init-steps)
X (go restart)))
X .iterate_return.
X ,finally
X (return ,(cadddr result-type))))))))
X
X(define-iterate-result-type collect (form result-type op)
X iterate-collect-join)
X
X(define-iterate-result-type join (form result-type op)
X iterate-collect-join)
X
X(defun iterate-collect-join (form result-type op)
X (ecase op
X (create-result-type
X (let ((gensym (gensym)))
X `(,(car form) ,gensym ((,gensym ())) (nreverse ,gensym))))
X (check-result-type
X (if (memq (car result-type) '(collect join))
X result-type
X (error "Using ~S inside an iterate in which you already used ~S."
X (car form) (car result-type))))
X (macroexpand
X (if (eq (car form) 'collect)
X `(push ,(cadr form) ,(cadr result-type))
X `(setq ,(cadr result-type)
X (append (reverse ,(cadr form)) ,(cadr result-type)))))))
X
X(define-iterate-result-type sum (form result-type op)
X (ecase op
X (create-result-type
X (let ((gensym (gensym)))
X `(,(car form) ,gensym ((,gensym 0)) ,gensym)))
X (check-result-type
X (eq (car result-type) 'sum))
X (macroexpand
X `(incf ,(cadr result-type) ,(cadr form)))))
X
X(defmacro iterate-macrolets (&body body)
X `(macrolet
X ((until (test)
X `(when ,test (go .iterate_return.)))
X (while (test)
X `(until (not ,test)))
X (initially (&body body)
X (error
X "It is an error for FINALLY to appear other than at top-level~%~
X inside an iterate."))
X (finally (&body ignore)
X (error
X "It is an error for INITIALLY to appear other than at top-level~%~
X inside an iterate."))
X )
X . ,body))
X
X;;;
X;;; Two macros useful for parsing defstructs.
X;;; The first parses slot-description (or lambda-list) style keyword-value
X;;; pairs. The second, more complicated one, parses defstruct option style
X;;; keyword-value pairs.
X;;;
X(defmacro keyword-bind (keywords form &body body)
X `(apply (function (lambda (&key . ,keywords) . ,body)) ,form))
X
X;;;
X;;; (keyword-parse (<keyword-spec-1> <keyword-spec-2> ..)
X;;; form
X;;; . body)
X;;;
X;;; Where form is a form which will be evaluated and should return the list
X;;; of keywords and values which keyword-parse will parse. Body will be
X;;; evaluated with the variables specified by the keyword-specs bound.
X;;; Keyword specs look like:
X;;; <var>
X;;; (<var> <default>)
X;;; (<var> <default> <suppliedp var>)
X;;; (<var> <default> <suppliedp var> <option-1> <val-1> ...)
X;;;
X;;; The options can be:
X;;; :allowed --- :required :multiple
X;;; :return-cdr --- t nil
X;;;
X(defmacro keyword-parse (keywords form &body body)
X ;; This makes an effort to resemble keyword-bind in that the vars are bound
X ;; one at a time so that a default value form can look at the value of a
X ;; previous argument. This is probably more hair than its worth, but what
X ;; the hell, programming is fun.
X (let* ((lambda-list ())
X (supplied-p-gensyms ())
X (value-forms ())
X (entry-var (gensym)))
X (dolist (kw keywords)
X (unless (listp kw) (setq kw (list kw)))
X (destructuring-bind (var default supplied-p-var . options) kw
X (keyword-bind (presence (allowed ':required) return-cdr) options
X (push var lambda-list)
X (when supplied-p-var
X (push supplied-p-var lambda-list)
X (push (gensym) supplied-p-gensyms))
X (push `(let ((,entry-var (keyword-parse-assq ',(make-keyword var)
X ,form
X ',allowed)))
X (if (null ,entry-var)
X ,default
X ;; Insert appropriate error-checking based on the
X ;; allowed argument.
X (progn
X ,(when (null allowed)
X `(unless (nlistp (car ,entry-var))
X (error "The ~S keyword was supplied with an ~
X argument, it is not allowed to have one."
X ',(make-keyword var))))
X ,(when (eq allowed ':required)
X `(unless (listp (car ,entry-var))
X (error
X "The ~S keyword was supplied without an ~
X argument~%when present, this keyword must ~
X have an argument."
X ',(make-keyword var))))
X (cond ((listp (car ,entry-var))
X ,(and supplied-p-var
X `(setq ,(car supplied-p-gensyms) 't))
X ,(if return-cdr
X (if (eq allowed ':multiple)
X `(mapcar #'cdr ,entry-var)
X `(cdar ,entry-var))
X (if (eq allowed ':multiple)
X `(mapcar #'cadr ,entry-var)
X `(cadar ,entry-var))))
X (t
X ,(and supplied-p-var
X `(setq ,(car supplied-p-gensyms)
X ':presence))
X ,presence)))))
X value-forms)
X (when supplied-p-var
X (push (car supplied-p-gensyms) value-forms)))))
X `(let ,supplied-p-gensyms
X ((lambda ,(reverse lambda-list) . ,body) . ,(reverse value-forms)))))
X
X
X(defun keyword-parse-assq (symbol list allowed)
X (do ((result nil result)
X (tail list (cdr tail)))
X ((null tail) (nreverse result))
X (if (eq (if (symbolp (car tail)) (car tail) (caar tail)) symbol)
X (if (neq allowed ':multiple)
X (return tail)
X (push (car tail) result)))))
X
X ;;
X;;;;;; printing-random-thing
X ;;
X;;; Similar to printing-random-object in the lisp machine but much simpler
X;;; and machine independent.
X(defmacro printing-random-thing ((thing stream) &body body)
X (once-only (stream)
X `(let ((*print-level* (and (numberp *print-level*) (- *print-level* 1))))
X (progn (princ "#<" ,stream)
X ,@body
X (princ " " ,stream)
X (printing-random-thing-internal ,thing ,stream)
X (princ ">" ,stream)))))
X
X(defun printing-random-thing-internal (thing stream)
X (ignore thing stream)
X nil)
X
X ;;
X;;;;;;
X ;;
X
X(defun capitalize-words (string)
X (let ((string (copy-seq (string string))))
X (declare (string string))
X (do* ((flag t flag)
X (length (length string) length)
X (char nil char)
X (i 0 (+ i 1)))
X ((= i length) string)
X (setq char (elt string i))
X (cond ((both-case-p char)
X (if flag
X (and (setq flag (lower-case-p char))
X (setf (elt string i) (char-upcase char)))
X (and (not flag) (setf (elt string i) (char-downcase char))))
X (setq flag nil))
X ((char-equal char #\-)
X (setq flag t))
X (t (setq flag nil))))))
X
X ;;
X;;;;;; CLASS-NAMED naming classes.
X ;;
X;;;
X;;; (CLASS-NAMED <name>) returns the class named <name>. setf can be used
X;;; with class-named to set the class named <name>. These are "extrinsic"
X;;; names. Neither class-named nor setf of class-named do anything with the
X;;; name slot of the class, they only lookup and change the association from
X;;; name to class.
X;;;
X
X(defvar *class-name-hash-table* (make-hash-table :test #'eq))
X
X(defun class-named (name &optional no-error-p)
X (or (gethash name *class-name-hash-table*)
X (if no-error-p () (error "No class named: ~S." name))))
X
X(defsetf class-named (name &optional ignore-damnit) (class)
X `(setf (gethash ,name *class-name-hash-table*) ,class))
X
X
X(defvar *discriminator-name-hash-table* (make-hash-table :test #'eq
X :size 1000))
X
X(defun discriminator-named (name) ;This a function for
X (gethash name *discriminator-name-hash-table*)) ;the benefit of
X ;compile-time-define?
X
X(defun set-discriminator-named (name new-value)
X (setf (gethash name *discriminator-name-hash-table*) new-value))
X
X(defsetf discriminator-named set-discriminator-named)
X
X;;;
X;;; To define a macro which is only applicable in the body of a defmethod,
X;;; use define-method-body-macro. This macro takes two arguments the name
X;;; of the macro that should be defined in the body of the method and the
X;;; function which should be called to expand calls to that macro.
X;;;
X;;; Expander-function will be called with 3 arguments:
X;;;
X;;; the entire macro form (gotten with &whole)
X;;; the macroexpand-time-information
X;;; the environment
X;;;
X
X(defvar *method-body-macros* ())
X
X(defmacro define-method-body-macro (name arglist &key global method)
X (when (eq global :error)
X (setq global
X `(progn (warn "~S used outside the body of a method." ',name)
X '(error "~S used outside the body of a method." ',name))))
X (or method
X (error "Have to provide a value for the method-body definition of~%~
X a macro defined with define-method-body-macro."))
X #+KCL (when (memq '&environment arglist)
X ;; In KCL, move &environment to the beginning of the
X ;; arglist since they require that it be there.
X (unless (eq (car arglist) '&environment)
X (do ((loc arglist (cdr loc)))
X ((eq (cadr loc) '&environment)
X (setq arglist (list* (cadr loc) (caddr loc) arglist))
X (setf (cdr loc) (cdddr loc))))))
X (let ((body-expander-function (gensym))
X (parameters (remove lambda-list-keywords arglist
X :test #'(lambda (x y) (member y x)))))
X `(eval-when (compile load eval)
X ,(and global `(defmacro ,name ,arglist ,global))
X (defun ,body-expander-function
X (macroexpand-time-environment ,@parameters)
X ,method)
X
X (let ((entry (or (assq ',name *method-body-macros*)
X (progn (push (list ',name) *method-body-macros*)
X (car *method-body-macros*)))))
X (setf (cdr entry) (list ',arglist
X ',parameters
X ',body-expander-function))))))
X
X ;;
X;;;;;; Special variable definitions.
X ;;
X;;; Gets set to its right value once early-defmeths are fixed.
X;;;
X(defvar *error-when-defining-method-on-existing-function* 'bootstrapping
X "If this variable is non-null (the default) defmethod signals an error when
X a method is defined on an existing lisp-function without first calling
X make-specializable on that function.")
X
END_OF_FILE
if test 25561 -ne `wc -c <'macros.l'`; then
echo shar: \"'macros.l'\" unpacked with wrong size!
fi
# end of 'macros.l'
fi
echo shar: End of archive 7 \(of 13\).
cp /dev/null ark7isdone
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.uco-dmk