rs@uunet.UU.NET (Rich Salz) (08/03/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 82
Archive-name: comobj.lisp/Part08
#! /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 8 (of 13)."
# Contents: class-prot.l low.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'class-prot.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'class-prot.l'\"
else
echo shar: Extracting \"'class-prot.l'\" \(26632 characters\)
sed "s/^X//" >'class-prot.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL Lisp 1000); 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;;; ADD-NAMED-CLASS proto-class name local-supers local-slot-slotds extra
X;;; protocol: class-definition
X;;;
X;;; Creates or updates the definition of a class with a named class. If
X;;; there is already a class named name, calls class-for-redefinition to
X;;; find out which class to use for the redefinition. Once it has a class
X;;; object to use it stores the relevant information from the ds-options in
X;;; the class and calls add-class to add the class to the class
X;;; lattice.
X;;;
X(defmeth add-named-class ((proto-class basic-class) name
X local-supers
X local-slot-slotds
X extra)
X ;; First find out if there is already a class with this name.
X ;; If there is, call class-for-redefinition to get the class
X ;; object to use for the new definition. If there is no exisiting
X ;; class we just make a new instance.
X (let* ((existing (class-named name t))
X (class (if existing
X (class-for-redefinition existing proto-class name
X local-supers local-slot-slotds
X extra)
X (make (class-of proto-class)))))
X
X (setq local-supers
X (mapcar
X #'(lambda (ls)
X (or (class-named ls t)
X (error "~S was specified as the name of a local-super~%~
X for the class named ~S. But there is no class~%~
X class named ~S." ls name ls)))
X local-supers))
X
X (setf (class-name class) name)
X (setf (class-ds-options class) extra) ;This is NOT part of the
X ;standard protocol.
X
X (add-class class local-supers local-slot-slotds extra)
X
X (setf (class-named name) class)
X name))
X
X(defmeth add-class
X ((class essential-class) new-local-supers new-local-slots extra)
X (ignore extra)
X (let ((old-local-supers (class-local-supers class))
X (old-local-slots (class-local-slots class)))
X
X (setf (class-local-supers class) new-local-supers)
X (setf (class-local-slots class) new-local-slots)
X
X (if (and old-local-supers ;*** YUCH!! There is a bug
X new-local-supers ;*** when old and new are ()
X (equal old-local-supers new-local-supers))
X (if (and old-local-slots
X new-local-slots
X (equal old-local-slots new-local-slots))
X ;; If the supers haven't changed, and the slots haven't changed
X ;; then not much has changed and we don't have to do anything.
X ()
X ;; If only the slots have changed call slots-changed.
X (slots-changed class old-local-slots extra t))
X ;; If the supers have changed, first update local-supers and
X ;; direct-subclasses of all the people involved. Then call
X ;; supers-changed.
X (progn
X (dolist (nls new-local-supers)
X (unless (memq nls old-local-supers)
X (check-super-metaclass-compatibility class nls)
X (push class (class-direct-subclasses nls))))
X (dolist (ols old-local-supers)
X (unless (memq ols new-local-supers)
X (setf (class-direct-subclasses ols)
X (delq class (class-direct-subclasses ols)))))
X (supers-changed class old-local-supers old-local-slots extra t)))))
X
X
X(defmeth supers-changed ((class basic-class)
X old-local-supers
X old-local-slots
X extra
X top-p)
X (ignore old-local-slots)
X (let ((cpl (compute-class-precedence-list class)))
X (setf (class-class-precedence-list class) cpl)
X (update-slots--class class cpl) ;This is NOT part of
X ;the essential-class
X ;protocol.
X (dolist (sub-class (class-direct-subclasses class))
X (supers-changed sub-class
X (class-local-supers sub-class)
X (class-local-slots sub-class)
X extra
X nil))
X (when top-p ;This is NOT part of
X (update-method-inheritance class old-local-supers));the essential-class
X ;protocol.
X ))
X
X(defmeth slots-changed ((class basic-class)
X old-local-slots
X extra
X top-p)
X (ignore top-p old-local-slots)
X ;; When this is called, class should have its local-supers and
X ;; local-slots slots filled in properly.
X (update-slots--class class (class-class-precedence-list class))
X (dolist (sub-class (class-direct-subclasses class))
X (slots-changed sub-class (class-local-slots sub-class) extra nil)))
X
X(defun update-slots--class (class cpl)
X (let ((obsolete-class nil))
X (multiple-value-bind (instance-slots non-instance-slots)
X (collect-slotds class (class-local-slots class) cpl)
X ;; If there is a change in the shape of the instances then the
X ;; old class is now obsolete. Make a copy of it, then fill
X ;; ourselves in properly and obsolete it.
X (when (and (class-has-instances-p class)
X (not (same-shape-slots-p (class-instance-slots class)
X instance-slots)))
X (setq obsolete-class (copy-class class)))
X (setf (class-no-of-instance-slots class) (length instance-slots))
X (setf (class-instance-slots class) instance-slots)
X (setf (class-non-instance-slots class) non-instance-slots)
X (when obsolete-class
X (flush-class-caches class)
X (make-class-obsolete class (copy-class class))))))
X
X;;;
X;;; CLASS-FOR-REDEFINITION old-class proto-class name ds-options slotds
X;;; protocol: class definition
X;;;
X;;; When a class is being defined, and a class with that name already exists
X;;; a decision must be made as to what to use for the new class object, and
X;;; whether to update the old class object. For this, class-for-redefinition
X;;; is called with the old class object, the prototype of the new class, and
X;;; the name ds-options and slotds corresponding to the new definition.
X;;; It should return the class object to use as the new definition. It is
X;;; OK for this to be old-class if that is appropriate.
X;;;
X(defmeth class-for-redefinition ((old-class essential-class)
X proto-class
X name
X local-supers
X local-slot-slotds
X extra)
X (ignore local-supers local-slot-slotds extra)
X (cond ((not (compatible-meta-class-change-p old-class proto-class))
X (error "The class ~A already exists; its class is ~A.~%~
X The :class argument in the defstruct is ~A.
X This is an incompatible meta-class change.~%"
X name
X (class-name (class-of old-class))
X (class-name (class-of proto-class))))
X (t (values old-class (copy-class old-class)))))
X
X(defmeth update-method-inheritance ((class basic-class) old-local-supers)
X ;; In the absence of method combination, we have to flush all the
X ;; discriminators which we used to inherit and all the discriminators
X ;; which we now inherit.
X (let ((old-mil
X (compute-method-inheritance-list class old-local-supers))
X (new-mil
X (compute-method-inheritance-list class
X (class-local-supers class)))
X (discriminators ())
X (combined-discriminators ()))
X (dolist (old-donor old-mil)
X (when (setq discriminators (class-direct-discriminators old-donor))
X (dolist (old-discriminator discriminators)
X (flush-discriminator-caches old-discriminator)
X (when (methods-combine-p old-discriminator)
X (pushnew old-discriminator combined-discriminators)))))
X (dolist (new-donor new-mil)
X (when (setq discriminators (class-direct-discriminators new-donor))
X (unless (memq new-donor old-mil)
X (dolist (new-discriminator discriminators)
X (when (methods-combine-p new-discriminator)
X (pushnew new-discriminator combined-discriminators))
X (flush-discriminator-caches new-discriminator)))))
X (when (fboundp 'combine-methods) ;***
X (COMBINE-METHODS CLASS COMBINED-DISCRIMINATORS)))) ;***
X
X
X(defmeth discriminator-changed ((discriminator essential-discriminator)
X method
X added-p)
X (ignore method added-p)
X (make-discriminating-function discriminator)
X (flush-discriminator-caches discriminator))
X
X
X(defun make-class-obsolete (class obsolete-class)
X (setf (class-wrapper-class (class-wrapper obsolete-class)) obsolete-class)
X (setf (class-wrapper class) nil)
X (setf (class-local-supers obsolete-class) (list class))
X (setf (class-class-precedence-list obsolete-class)
X (cons obsolete-class (class-class-precedence-list class)))
X (setf (class-name obsolete-class)
X (symbol-append "obsolete-" (class-name class)))
X (setf (iwmc-class-class-wrapper obsolete-class)
X (wrapper-of (class-named 'obsolete-class)))
X obsolete-class)
X
X(defun copy-class (class)
X (let* ((no-of-instance-slots (class-no-of-instance-slots (class-of class)))
X (new-class (%allocate-instance--class no-of-instance-slots)))
X (setf (iwmc-class-class-wrapper new-class)
X (iwmc-class-class-wrapper class))
X (iterate ((i from 0 below no-of-instance-slots))
X (let ((index (%convert-slotd-position-to-slot-index i)))
X (setf (get-static-slot--class new-class index)
X (get-static-slot--class class index))))
X (setf (iwmc-class-dynamic-slots new-class)
X (copy-list (iwmc-class-dynamic-slots class)))
X new-class))
X
X(defun wrapper-of (class)
X (or (class-wrapper class)
X (setf (class-wrapper class) (make-class-wrapper class))))
X
X(defmeth collect-slotds ((class basic-class) local-slots cpl)
X (let ((slots ()))
X (flet ((add-slotd (slotd)
X (let ((entry
X (or (assq (slotd-name slotd) slots)
X (progn (push (list (slotd-name slotd)) slots)
X (car slots)))))
X (push slotd (cdr entry)))))
X (dolist (super (reverse (cdr cpl))) ;fix this consing later
X (dolist (super-slotd (class-local-slots super))
X (add-slotd super-slotd)))
X
X (dolist (local-slotd local-slots)
X (add-slotd local-slotd)))
X
X ;; Now use compute-effective-slotd to condense all the
X ;; inherited slotds into the one effective slotd.
X (dolist (slot slots)
X (setf (car slot)
X (compute-effective-slotd class (cdr slot))))
X ;; Now we need to separate it back out into instance and non-instance
X ;; slots.
X (let ((instance ())
X (non-instance ()))
X (dolist (slot slots)
X (setq slot (car slot))
X (if (eq (slotd-allocation slot) ':instance)
X (push slot instance)
X (push slot non-instance)))
X (values instance non-instance slots))))
X
X(defmethod compute-effective-slotd ((class class) slotds)
X (ignore class)
X (let ((slotd (if (null (cdr slotds))
X (car slotds)
X (copy-slotd (car slotds)))))
X (flet ((merge-values (default type read-only accessor allocation)
X (macrolet ((merge-value (name value)
X `(when (eq (,name slotd) *slotd-unsupplied*)
X (setf (,name slotd) ,value))))
X (merge-value slotd-default default)
X (merge-value slotd-type type)
X (merge-value slotd-read-only read-only)
X (merge-value slotd-accessor accessor)
X (merge-value slotd-allocation allocation))))
X (dolist (s (cdr slotds))
X (merge-values (slotd-default s)
X (slotd-type s)
X (slotd-read-only s)
X (slotd-accessor s)
X (slotd-allocation s)))
X (merge-values 'nil ;default value -- for now
X 't ;type
X 'nil ;read-only
X 'nil ;accessor
X :instance)) ;allocation
X slotd))
X
X(defmethod compute-class-precedence-list ((root class))
X #+Lucid (declare (optimize (speed 0) (safety 3)))
X (let ((*cpl* ())
X (*root* root)
X (*must-precede-alist* ()))
X (declare (special *cpl* *root* *must-precede-alist*))
X ;; We start by computing two values.
X ;; CPL
X ;; The depth-first left-to-right up to joins walk of the supers tree.
X ;; This is equivalent to breadth-first left-to-right walk of the
X ;; tree with all but the last occurence of a class removed from
X ;; the resulting list. This is in fact how the walk is implemented.
X ;;
X ;; MUST-PRECEDE-ALIST
X ;; An alist of the must-precede relations. The car of each element
X ;; of the must-precede-alist is a class, the cdr is all the classes
X ;; which either:
X ;; have this class as a local super
X ;; or
X ;; appear before this class in some other class's local-supers.
X ;;
X ;; Thus, the must-precede-alist reflects the two constraints that:
X ;; 1. A class must appear in the CPL before its local supers.
X ;; 2. Order of local supers is preserved in the CPL.
X ;;
X (labels
X ;(flet
X (
X; (walk-supers (class &optional precedence)
X; (let ((elem (assq class must-precede-alist)))
X; (if elem
X; (setf (cdr elem) (union (cdr elem) precedence))
X; (push (cons class precedence) must-precede-alist)))
X; (let ((rsupers (reverse (cons class (class-local-supers class)))))
X; (iterate ((sup in rsupers)
X; (pre on (cdr rsupers))
X; (temp = nil))
X; ;; Make sure this element of supers is OK.
X; ;; Actually, there is an important design decision hidden in
X; ;; here. Namely, at what time should symbols in a class's
X; ;; local-supers be changed to the class objects they are
X; ;; forward referencing.
X; ;; 1. At first make-instance (compute-class-precedence-list)?
X; ;; 2. When the forward referenced class is first defined?
X; ;; This code does #1.
X; (cond ((classp sup))
X; ((and (symbolp sup)
X; (setq temp (class-named sup t)))
X; ;; This is a forward reference to a class which is
X; ;; now defined. Replace the symbol in the local
X; ;; supers with the actual class object, and set sup.
X; (nsubst temp sup (class-local-supers class))
X; (setq sup temp))
X; ((symbolp sup)
X; (error "While computing the class-precedence-list for ~
X; the class ~S.~%~
X; The class ~S (from the local supers of ~S) ~
X; is undefined."
X; (class-name root) sup (class-name class)))
X; (t
X; (error "INTERNAL ERROR --~%~
X; While computing the class-precedence-list for ~
X; the class ~S,~%~
X; ~S appeared in the local supers of ~S."
X; root sup class)))
X; (walk-supers sup pre))
X; (unless (memq class cpl) (push class cpl))))
X (must-move-p (element list &aux move)
X (dolist (must-precede (cdr (assq element *must-precede-alist*)))
X (when (setq move (memq must-precede (cdr list)))
X (return move))))
X (find-farthest-move (element move)
X (let ((closure (compute-must-precedes-closure element)))
X (dolist (must-precede closure)
X (setq move (or (memq must-precede move) move)))
X move))
X (compute-must-precedes-closure (class)
X (let ((closure ()))
X (labels ((walk (element path)
X (when (memq element path)
X (class-ordering-error
X *root* element path *must-precede-alist*))
X (dolist (precede
X (cdr (assq element
X *must-precede-alist*)))
X (unless (memq precede closure)
X (pushnew precede closure)
X (walk precede (cons element path))))))
X (walk class nil)
X closure))))
X
X (walk-supers *root*) ;Do the walk
X ;; For each class in the cpl, make sure that there are no classes after
X ;; it which should be before it. We do this by cdring down the list,
X ;; making sure that for each element of the list, none of its
X ;; must-precedes come after it in the list. If we find one, we use the
X ;; transitive closure of the must-precedes (call find-farthest-move) to
X ;; see where the class must really be moved. We use a hand-coded loop
X ;; so that we can splice things in and out of the CPL as we go.
X (let ((tail *cpl*)
X (element nil)
X (move nil))
X (loop (when (null tail) (return))
X (setq element (car tail)
X move (must-move-p element tail))
X (cond (move
X (setq move (find-farthest-move element move))
X (setf (cdr move) (cons element (cdr move)))
X (setf (car tail) (cadr tail)) ;Interlisp delete is OK
X (setf (cdr tail) (cddr tail)) ;since it will never be
X ;last element of list.
X )
X (t
X (setq tail (cdr tail)))))
X (copy-list *cpl*)))))
X
X(defun walk-supers (class &optional precedence)
X (declare (special *cpl* *root* *must-precede-alist*))
X (let ((elem (assq class *must-precede-alist*)))
X (if elem
X (setf (cdr elem) (union (cdr elem) precedence))
X (push (cons class precedence) *must-precede-alist*)))
X (let ((rsupers (reverse (cons class (class-local-supers class)))))
X (iterate ((sup in rsupers)
X (pre on (cdr rsupers))
X (temp = nil))
X ;; Make sure this element of supers is OK.
X ;; Actually, there is an important design decision hidden in
X ;; here. Namely, at what time should symbols in a class's
X ;; local-supers be changed to the class objects they are
X ;; forward referencing.
X ;; 1. At first make-instance (compute-class-precedence-list)?
X ;; 2. When the forward referenced class is first defined?
X ;; This code does #1.
X (cond ((classp sup))
X ((and (symbolp sup)
X (setq temp (class-named sup t)))
X ;; This is a forward reference to a class which is
X ;; now defined. Replace the symbol in the local
X ;; supers with the actual class object, and set sup.
X (nsubst temp sup (class-local-supers class))
X (setq sup temp))
X ((symbolp sup)
X (error "While computing the class-precedence-list for ~
X the class ~S.~%~
X The class ~S (from the local supers of ~S) ~
X is undefined."
X (class-name *root*) sup (class-name class)))
X (t
X (error "INTERNAL ERROR --~%~
X While computing the class-precedence-list for ~
X the class ~S,~%~
X ~S appeared in the local supers of ~S."
X *root* sup class)))
X (walk-supers sup pre))
X (unless (memq class *cpl*) (push class *cpl*))))
X
X(defun class-ordering-error (root element path must-precede-alist)
X (ignore root)
X (setq path (cons element (reverse (memq element (reverse path)))))
X (flet ((pretty (class) (or (class-name class) class)))
X (let ((explanations ()))
X (do ((tail path (cdr tail)))
X ((null (cdr tail)))
X (let ((after (cadr tail))
X (before (car tail)))
X (if (memq after (class-local-supers before))
X (push (format nil
X "~% ~A must precede ~A -- ~
X ~A is in the local supers of ~A."
X (pretty before) (pretty after)
X (pretty after) (pretty before))
X explanations)
X (dolist (common-precede
X (intersection
X (cdr (assq after must-precede-alist))
X (cdr (assq before must-precede-alist))))
X (when (memq after (memq before
X (class-local-supers common-precede)))
X (push (format nil
X "~% ~A must precede ~A -- ~
X ~A has local supers ~S."
X (pretty before) (pretty after)
X (pretty common-precede)
X (mapcar #'pretty
X (class-local-supers common-precede)))
X explanations))))))
X (error "While computing the class-precedence-list for the class ~A:~%~
X There is a circular constraint through the classes:~{ ~A~}.~%~
X This arises because:~{~A~}"
X (pretty root)
X (mapcar #'pretty path)
X (reverse explanations)))))
X
X(defmeth compute-method-inheritance-list ((class essential-class)
X local-supers)
X (compute-class-precedence-list class))
X
X(defmeth compatible-meta-class-change-p (class proto-new-class)
X (eq (class-of class) (class-of proto-new-class)))
X
X(defmeth check-super-metaclass-compatibility (class new-super)
X (unless (eq (class-of class) (class-of new-super))
X (error "The class ~S was specified as a~%super-class of the class ~S;~%~
X but the meta-classes ~S and~%~S are incompatible."
X new-super class (class-of new-super) (class-of class))))
X
X(defun classp (x)
X (and (iwmc-class-p x) (typep--class x 'essential-class)))
X
X
X
X(defmeth class-standard-constructor ((class basic-class))
X (dolist (constructor (ds-options-constructors (class-ds-options class)))
X (when (null (cdr constructor)) (return (car constructor)))))
X
X
X(defmeth flush-class-caches ((class basic-class))
X (let ((wrapper (class-wrapper class)))
X (and wrapper (flush-class-wrapper-cache wrapper))
X (iterate ((subclass in (class-direct-subclasses class)))
X (flush-class-caches subclass))))
X
X
X ;;
X;;;;;; CHANGE-CLASS
X ;;
X
X(defun change-class (object new-class)
X (or (classp new-class)
X (setq new-class (class-named new-class)))
X (let ((new-object (make new-class)))
X ;; Call change-class-internal so that a user-defined method
X ;; (or the default method) can copy the information from the
X ;; old instance to the dummy instance of the new class.
X (change-class-internal object new-object)
X ;; Now that the dummy new-object has the right information,
X ;; move all that stuff into the old-instance.
X (setf (iwmc-class-class-wrapper object)
X (wrapper-of new-class))
X (setf (iwmc-class-static-slots object)
X (iwmc-class-static-slots new-object))
X (setf (iwmc-class-dynamic-slots object)
X (iwmc-class-dynamic-slots new-object))
X object))
X
X(defmeth change-class-internal ((old object) (new object))
X (let ((all-slots (all-slots old)))
X (iterate ((name in all-slots by cddr)
X (value in (cdr all-slots) by cddr))
X (put-slot-always new name value))))
X
X ;;
X;;;;;; WITH-SLOTS
X ;;
X
X(define-method-body-macro with-slots (instance-forms-and-options
X &body body
X &environment env)
X :global (expand-with-slots nil nil instance-forms-and-options env body)
X :method (expand-with-slots (macroexpand-time-generic-function
X macroexpand-time-environment)
X (macroexpand-time-method
X macroexpand-time-environment)
X instance-forms-and-options
X env
X body))
X
X(defun expand-with-slots (proto-discriminator proto-method first-arg env body)
X (ignore proto-discriminator)
X (setq first-arg (iterate ((arg in first-arg))
X (collect (if (listp arg) arg (list arg)))))
X (let ((entries (expand-with-make-entries proto-method first-arg))
X (gensyms ()))
X (dolist (arg first-arg)
X (push (list (if (listp arg) (car arg) arg)
X (gensym))
X gensyms))
X `(let ,(mapcar #'reverse gensyms)
X ,(walk-form (cons 'progn body)
X :environment env
X :walk-function
X #'(lambda (form context &aux temp)
X (cond ((and (symbolp form)
X (eq context ':eval)
X (null (variable-lexical-p form))
X (null (variable-special-p form))
X (setq temp (assq form entries)))
X (if (car (cddddr temp)) ;use slot-value?
X (let ((get-slot
X `(get-slot ,(cadr (assq (cadr temp) gensyms))
X ',(slotd-name (cadddr temp)))))
X (optimize-get-slot (caddr temp)
X get-slot))
X `(,(slotd-accessor (cadddr temp))
X ,(cadr (assq (cadr temp) gensyms)))))
X ((and (listp form)
X (or (eq (car form) 'setq)
X (eq (car form) 'setf)))
X (cond ((cdddr form)
X (cons 'progn
X (iterate ((pair on (cdr form) by cddr))
X (collect (list (car form)
X (car pair)
X (cadr pair))))))
X ((setq temp (assq (cadr form) entries))
X (if (car (cddddr temp))
X (let ((get-slot
X `(setf-of-get-slot
X ,(cadr (assq (cadr temp) gensyms))
X ',(slotd-name (cadddr temp))
X ,(caddr form))))
X (optimize-setf-of-get-slot (caddr temp)
X get-slot))
X `(setf (,(slotd-accessor (cadddr temp))
X ,(cadr (assq (cadr temp) gensyms)))
X ,(caddr form))))
X (t form)))
X (t form)))))))
X
X;;; Returns an alist of the form:
X;;;
X;;; (<prefix+slot-name> <instance-form> <class> <slotd> <use-slot-value-p>)
X;;;
X(defmeth expand-with-make-entries (method first-arg)
X (let* ((entries ())
X (method-arguments
X (when (method-p method)
X (iterate ((arg in (method-arglist method))
X (spec in (method-type-specifiers method)))
X (when (classp spec) (collect (cons arg spec)))))))
X (iterate ((instance-and-keys in first-arg))
X (keyword-bind ((use-slot-value nil)
X (class nil class-specified-p)
X (prefix nil prefix-specified-p))
X (cdr instance-and-keys)
X (let ((instance (car instance-and-keys)))
X (setq class
X (or (and class-specified-p
X (or (class-named class t)
X (error "In WITH-SLOTS the class specified for ~
X ~S, ~S ~%~
X is not the name of a defined class."
X instance class)))
X (cdr (assq instance method-arguments))
X (error "The class of (the value of) ~S was not given in ~
X in the call to with-slots and could not be ~
X inferred automatically."
X instance)))
X (iterate ((slotd in (class-slots class)))
X (push (list (if (null prefix-specified-p)
X (slotd-name slotd)
X (intern (string-append prefix
X (slotd-name slotd))
X (symbol-package
X (if (symbolp prefix)
X prefix
X (slotd-name slotd)))))
X instance
X class
X slotd
X use-slot-value)
X entries)))))
X entries))
X
X
X(defun named-object-print-function (instance stream depth
X &optional (extra nil extra-p))
X (ignore depth)
X (printing-random-thing (instance stream)
X ;; I know I don't have to do this this way. I know I
X ;; could use ~[~;~], but how many Common Lisps do you
X ;; think have that completely debugged?
X (if extra-p
X (format stream "~A ~S ~:S"
X (capitalize-words (class-name (class-of instance)))
X (get-slot instance 'name)
X extra)
X (format stream "~A ~S"
X (capitalize-words (class-name (class-of instance)))
X (get-slot instance 'name)))))
X
END_OF_FILE
if test 26632 -ne `wc -c <'class-prot.l'`; then
echo shar: \"'class-prot.l'\" unpacked with wrong size!
fi
# end of 'class-prot.l'
fi
if test -f 'low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'low.l'\"
else
echo shar: Extracting \"'low.l'\" \(27849 characters\)
sed "s/^X//" >'low.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER) 1000); 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;;; This file contains portable versions of low-level functions and macros
X;;; which are ripe for implementation specific customization. None of the
X;;; code in this file *has* to be customized for a particular Common Lisp
X;;; implementation. Moreover, in some implementations it may not make any
X;;; sense to customize some of this code.
X;;;
X;;; But, experience suggests that MOST Common Lisp implementors will want
X;;; to customize some of the code in this file to make PCL run better in
X;;; their implementation. The code in this file has been separated and
X;;; heavily commented to make that easier.
X;;;
X;;; Implementation-specific version of this file already exist for:
X;;;
X;;; Symbolics 3600 family 3600-low.lisp
X;;; Lucid Lisp lucid-low.lisp
X;;; Xerox 1100 family 1100-low.lisp
X;;; Ti Explorer ti-low.lisp
X;;; Vaxlisp vaxl-low.lisp
X;;; Spice Lisp spice-low.lisp
X;;; Kyoto Common Lisp kcl-low.lisp
X;;; ExCL (Franz) excl-low.lisp
X;;; H.P. Common Lisp hp-low.lisp
X;;;
X;;;
X;;; These implementation-specific files are loaded after this file. Because
X;;; none of the macros defined by this file are used in functions defined by
X;;; this file the implementation-specific files can just contain the parts of
X;;; this file they want to change. They don't have to copy this whole file
X;;; and then change the parts they want.
X;;;
X;;; If you make changes or improvements to these files, or if you need some
X;;; low-level part of PCL re-modularized to make it more portable to your
X;;; system please send mail to CommonLoops.pa@Xerox.com.
X;;;
X;;; Thanks.
X;;;
X
X(in-package 'pcl)
X
X ;;
X;;;;;; without-interrupts
X ;;
X;;; OK, Common Lisp doesn't have this and for good reason. But For all of
X;;; the Common Lisp's that PCL runs on today, there is a meaningful way to
X;;; implement this. WHAT I MEAN IS:
X;;;
X;;; I want the body to be evaluated in such a way that no other code that is
X;;; running PCL can be run during that evaluation. I agree that the body
X;;; won't take *long* to evaluate. That is to say that I will only use
X;;; without interrupts around small computations.
X;;;
X;;; OK?
X;;;
X(defmacro without-interrupts (&body body)
X `(progn ,.body))
X
X ;;
X;;;;;; Load Time Eval
X ;;
X;;;
X;;; #, is woefully inadequate. You can't use it inside of a macro and have
X;;; the expansion of part of the macro be evaluated at load-time.
X;;;
X;;; load-time-eval is used to provide an interface to implementation
X;;; dependent implementation of load time evaluation.
X;;;
X;;; A compiled call to load-time-eval:
X;;; should evaluated the form at load time,
X;;; but if it is being compiled-to-core evaluate it at compile time
X;;; Interpreted calls to load-time-eval:
X;;; should just evaluate form at run-time.
X;;;
X;;; The portable implementation just evaluates it every time, and PCL knows
X;;; this. PCL is careful to only use load-time-eval in places where (except
X;;; for performance penalty) it is OK to evaluate the form every time.
X;;;
X(defmacro load-time-eval (form)
X `(progn ,form))
X
X ;;
X;;;;;; Memory Blocks (array-like blocks of memory)
X ;;
X;;; The portable implementation of memory-blocks is as arrays.
X;;;
X;;; The area argument to make-memory-block is based on the area feature of
X;;; LispM's. As it is used in PCL that argument will always be an unquoted
X;;; symbol. So a call to make-memory-block will look like:
X;;; (make-memory-block 100 class-wrapper-area)
X;;; This allows any particular implementation of make-memory-block to look at
X;;; the symbol at compile time (macroexpand time) and know where the memory-
X;;; block should be consed. Currently the only values ever used as the area
X;;; argument are:
X;;;
X;;; CLASS-WRAPPER-AREA used when making a class-wrapper
X;;;
X;;; NOTE:
X;;; It is perfectly legitimate for an implementation of make-memory-block
X;;; to ignore the area argument. It only exists to try to improve paging
X;;; performance in systems which do allow control over where memory is
X;;; allocated.
X;;;
X(defmacro make-memory-block (size &optional area)
X (ignore area)
X `(make-array ,size :initial-element nil))
X
X(defmacro memory-block-size (block)
X `(array-dimension ,block 0))
X
X(defmacro memory-block-ref (block offset)
X `(svref ,block ,offset))
X
X(eval-when (compile load eval)
X
X(defun make-memory-block-mask (size &optional (words-per-entry 2))
X (logxor (1- (expt 2 (floor (log size 2))))
X (1- (expt 2 (ceiling (log words-per-entry 2))))))
X
X)
X
X;;;
X;;; clear-memory-block sets all the slots of a memory block to nil starting
X;;; at start. This really shouldn't be a macro, it should be a function.
X;;; It has to be a macro because otherwise its call to memory-block-ref will
X;;; get compiled before people get a chance to change memory-block-ref.
X;;; This argues one of:
X;;; - this should be a function in another file. No, it belongs here.
X;;; - Common Lisp should have defsubst. Probably
X;;; - Implementors should take (proclaim '(inline xxx)) more seriously.
X;;;
X(defmacro clear-memory-block (block start &optional times)
X (once-only (block)
X `(do ((end ,(if times `(+ ,start ,times) `(length ,block)))
X (index ,start (+ index 1)))
X ((= index end))
X (setf (memory-block-ref ,block index) nil))))
X
X ;;
X;;;;;; CLASS-OF
X ;;
X;;;
X;;; *class-of* is the lisp code for the definition of class-of.
X;;;
X;;; This version uses type-of to determine the class of an object. Because
X;;; of the underspecification of type-of, this does not always produce the
X;;; "most specific class of which x is an instance". But it is the best I
X;;; can do portably.
X;;;
X;;; Specific ports of PCL should feel free to redefine *class-of* to provide
X;;; a more accurate definition. At some point in any definition of class-of
X;;; there should be a test to determine if the argument is a %instance, and
X;;; if so the %instance-class-of macro should be used to determine the class
X;;; of the instance.
X;;;
X;;; Whenever a new meta-class is defined, the portable code will take care of
X;;; modifying the definition of %instance-class-of and recompiling class-of.
X;;;
X(defvar *class-of*
X '(lambda (x)
X (or (and (%instancep x)
X (%instance-class-of x))
X ;(%funcallable-instance-p x)
X (class-named (type-of x) t)
X (error "Can't determine class of ~S" x))))
X
X(defvar *meta-classes* ())
X
X(defmacro %instance-class-of (arg)
X `(cond ,@(iterate ((mc in *meta-classes*))
X (collect
X `((eq (%instance-meta-class ,arg)
X ;; %^&$%& KCL has to have this stupid call to
X ;; load-time-eval here because their compiler
X ;; always creates a file and compiles that file.
X #-KCL',(class-named (car mc))
X #+KCL (load-time-eval (class-named ',(car mc))))
X (funcall (function ,(cdr mc)) ,arg))))
X (t
X (error
X "Internal error in %INSTANCE-CLASS-OF. The argument to~%~
X %instance-class-of is a %instance, but its meta-class is~%~
X not one of the meta-classes defined with define-meta-class."
X (%instance-meta-class ,arg)))))
X
X(defmacro define-meta-class (name class-of-function &rest options)
X (check-type name symbol "a symbol which is the name of a meta-class")
X (check-type class-of-function function "a function")
X `(load-define-meta-class ',name ',class-of-function))
X
X(defun load-define-meta-class (name class-of-function)
X (or (eq name 'class)
X (class-named name t)
X (error "In define-meta-class, there is no class named ~S.~%~
X The class ~S must be defined before evaluating this~%~
X define-meta-class form."))
X (let ((existing (assq name *meta-classes*)))
X (if existing
X (setf (cdr existing) class-of-function)
X (setq *meta-classes* (nconc *meta-classes*
X (list (cons name class-of-function)))))
X (recompile-class-of)))
X
X(defun recompile-class-of ()
X ;; Change the definition of class-of so that the next time it is
X ;; called it will recompile itself.
X ;; NOTE: This does not have to be written this way. If we impose
X ;; the constraint that any define-meta-class must be loaded
X ;; in the same environment as it was compiled then there is
X ;; no need for a compiler at run or load time.
X ;; By same environment I mean with the same define-meta-class
X ;; forms already in force, and this certainly seems like a
X ;; reasonable constraint to me.
X (setf (symbol-function 'class-of)
X #'(lambda (x)
X (declare (notinline class-of))
X ;; Now recompile class-of so that the new definition
X ;; of %instance-class-of will take effect.
X (compile 'class-of *class-of*)
X (class-of x))))
X
X ;;
X;;;;;; TYPEP and TYPE-OF support.
X ;;
X;;; Portable CommonLoops makes no changes to typep or type-of. In order for
X;;; those functions to work with CommonLoops objects each implementation will
X;;; have to fix its typep and type-of. It shouldn't be hard though, and
X;;; these macros should help.
X
X(defmacro %instance-typep (x type)
X `(not (null (memq (class-named ,type ())
X (class-class-precedence-list (class-of ,x))))))
X
X(defmacro %instance-type-of (x)
X `(class-name (class-of ,x)))
X
X ;;
X;;;;;; The primitive instances.
X ;;
X;;;
X;;; Conceptually, a %instance is an array-like datatype whose first element
X;;; points to the meta-class of the %instance and whose remaining elements
X;;; are used by the meta-class for whatever purpose it wants.
X;;;
X;;; What would like to do is use defstruct to define a new type with a
X;;; variable number of slots. Unfortunately, Common Lisp itself does not
X;;; let us do that. So we have to define a new type %instance, and have
X;;; it point to an array which is the extra slots.
X;;;
X;;; Most any port of PCL should re-implement this datatype. Implementing it
X;;; as a variable length type so that %instance are only one vector in memory
X;;; (the "extra slots" are in-line with the meta-class) will have significant
X;;; impact on the speed of many CommonLoops programs. As an example of how
X;;; to do this re-implementation of %instance, please see the file 3600-low.
X;;;
X
X(defstruct (%instance (:print-function print-instance)
X (:constructor %make-instance-1 (meta-class storage))
X (:predicate %instancep))
X meta-class
X storage)
X
X(defmacro %make-instance (meta-class size)
X `(%make-instance-1 ,meta-class (make-array ,size)))
X
X(defmacro %instance-ref (instance index)
X `(aref (%instance-storage ,instance) ,index))
X
X(defun print-instance (instance stream depth) ;This is a temporary definition
X (ignore depth) ;used mostly for debugging the
X (printing-random-thing (instance stream) ;bootstrapping code.
X (format stream "instance ??")))
X
X ;;
X;;;;;; Very Low-Level representation of instances with meta-class class.
X ;;
X;;; As shown below, an instance with meta-class class (iwmc-class) is a three
X;;; *slot* structure.
X;;;
X;;;
X;;; /------["Class"]
X;;; /-------["Class Wrapper" / <slot-and-method-cache>]
X;;; /
X;;; Instance--> [ / , \ , \ ]
X;;; \ \
X;;; \ \---[Instance Slot Storage Block]
X;;; \
X;;; \-------[Dynamic Slot plist]
X;;;
X;;; Instances with meta-class class point to their class indirectly through
X;;; the class's class wrapper (each class has one class wrapper, not each
X;;; instance). This is done so that all the extant instances of a class can
X;;; have the class they point to changed quickly. See change-class.
X;;;
X;;; Static-slots are a 1-d-array-like structure.
X;;; The default PCL implementation is as a memory block as described above.
X;;; Particular ports are free to change this to a lower-level block of memory
X;;; type structure. Once again, the accessor for static-slots storage doesn't
X;;; need to do bounds checking, and static-slots structures don't need to be
X;;; able to change size. This is because new slots are added using the
X;;; dynamic slot mechanism, and if the class changes or the class of the
X;;; instance changes a new static-slot structure is allocated (if needed).
X;;
X;;; Dynamic-slots are a plist-like structure.
X;;; The default PCL implementation is as a plist.
X;;;
X;;; *** Put a real discussion here of where things should be consed.
X;;; - if all the class wrappers in the world are on the same page that
X;;; would be good because during method lookup we only use the wrappers
X;;; not the classes and once a slot is cached, we only use the wrappers
X;;; too. So a page of just wrappers would stay around all the time and
X;;; you would never have to page in the classes at least in "tight" loops.
X;;;
X
X(defmacro iwmc-class-p (x)
X `(and (%instancep ,x)
X (eq (%instance-meta-class ,x)
X (load-time-eval (class-named 'class)))))
X
X;(defmacro %allocate-iwmc-class ()
X; `(%make-instance (load-time-eval (class-named 'class)) 3))
X
X(defmacro iwmc-class-class-wrapper (iwmc-class)
X `(%instance-ref ,iwmc-class 0))
X
X(defmacro iwmc-class-static-slots (iwmc-class)
X `(%instance-ref ,iwmc-class 1))
X
X(defmacro iwmc-class-dynamic-slots (iwmc-class)
X `(%instance-ref ,iwmc-class 2))
X
X
X(defmacro %allocate-instance--class (no-of-slots &optional class-class)
X `(let ((iwmc-class
X (%make-instance ,(or class-class
X '(load-time-eval (class-named 'class)))
X 3)))
X (%allocate-instance--class-1 ,no-of-slots iwmc-class)
X iwmc-class))
X
X(defmacro %allocate-instance--class-1 (no-of-slots instance)
X (once-only (instance)
X `(progn
X (setf (iwmc-class-static-slots ,instance)
X (%allocate-static-slot-storage--class ,no-of-slots))
X (setf (iwmc-class-dynamic-slots ,instance)
X (%allocate-dynamic-slot-storage--class)))))
X
X
X(defmacro %allocate-class-class (no-of-slots) ;This is used to allocate the
X `(let ((i (%make-instance nil 3))) ;class class. It bootstraps
X (setf (%instance-meta-class i) i) ;the call to class-named in
X (setf (class-named 'class) i) ;%allocate-instance--class.
X (%allocate-instance--class-1 ,no-of-slots i)
X i))
X
X(defmacro %convert-slotd-position-to-slot-index (slotd-position)
X slotd-position)
X
X
X(defmacro %allocate-static-slot-storage--class (no-of-slots)
X `(make-memory-block ,no-of-slots))
X
X(defmacro %static-slot-storage-get-slot--class (static-slot-storage
X slot-index)
X `(memory-block-ref ,static-slot-storage ,slot-index))
X
X(defmacro %allocate-dynamic-slot-storage--class ()
X ())
X
X(defmacro %dynamic-slot-storage-get-slot--class (dynamic-slot-storage
X name
X default)
X `(getf ,dynamic-slot-storage ,name ,default))
X
X(defmacro %dynamic-slot-storage-remove-slot--class (dynamic-slot-storage
X name)
X `(remf ,dynamic-slot-storage ,name))
X
X
X
X(defmacro class-of--class (iwmc-class)
X `(class-wrapper-class (iwmc-class-class-wrapper ,iwmc-class)))
X
X(define-meta-class class (lambda (x) (class-of--class x)))
X
X
X ;;
X;;;;;; Class Wrappers (the Watercourse Way algorithm)
X ;;
X;;; Well, we had this really cool scheme for keeping multiple different
X;;; caches tables in the same block of memory. Unfortunately, we only
X;;; cache one thing in class wrappers these days, and soon class wrappers
X;;; will go away entirely so its kind of lost generality. I am leaving
X;;; the old comment here cause the hack is worth remembering.
X;;;
X;;; * Old Comment
X;;; * The key point are:
X;;; *
X;;; * - No value in the cache can be a key for anything else stored
X;;; * in the cache.
X;;; *
X;;; * - When we invalidate a wrapper cache, we flush it so that when
X;;; * it is next touched it will get a miss.
X;;; *
X;;; * A class wrapper is a block of memory whose first two slots have a
X;;; * deadicated (I just can't help myself) purpose and whose remaining
X;;; * slots are the shared cache table. A class wrapper looks like:
X;;; *
X;;; * slot 0: <pointer to class>
X;;; * slot 1: T if wrapper is valid, NIL otherwise.
X;;; * .
X;;; * . shared cache
X;;; * .
X;;;
X
X(eval-when (compile load eval)
X
X(defconstant class-wrapper-cache-size 32
X "The size of class-wrapper caches.")
X
X(defconstant class-wrapper-leader 2
X "The number of slots at the beginning of a class wrapper which have a
X special purpose. These are the slots that are not part of the cache.")
X
X; due to a compiler bug, the extra "2" default argument has been added
X; to the following function invocation, for HP Lisp. rds 3/6/87
X(defconstant class-wrapper-cache-mask
X (make-memory-block-mask class-wrapper-cache-size 2))
X
X)
X
X(defmacro make-class-wrapper (class)
X `(let ((wrapper (make-memory-block ,(+ class-wrapper-cache-size
X class-wrapper-leader)
X class-wrapper-area)))
X (setf (class-wrapper-class wrapper) ,class)
X (setf (class-wrapper-valid-p wrapper) t)
X wrapper))
X
X(defmacro class-wrapper-class (class-wrapper)
X `(memory-block-ref ,class-wrapper 0))
X
X(defmacro class-wrapper-valid-p (class-wrapper)
X `(memory-block-ref ,class-wrapper 1))
X
X(defmacro class-wrapper-cached-key (class-wrapper offset)
X `(memory-block-ref ,class-wrapper ,offset))
X
X(defmacro class-wrapper-cached-val (class-wrapper offset)
X `(memory-block-ref ,class-wrapper (+ ,offset 1)))
X
X(defmacro class-wrapper-get-slot-offset (class-wrapper slot-name)
X (ignore class-wrapper)
X `(+ class-wrapper-leader
X 0
X (symbol-cache-no ,slot-name ,class-wrapper-cache-mask)))
X
X
X(defmacro flush-class-wrapper-cache (class-wrapper)
X `(clear-memory-block ,class-wrapper
X ,class-wrapper-leader
X ,class-wrapper-cache-size))
X
X(defmacro class-wrapper-cache-cache-entry (wrapper offset key val)
X (once-only (wrapper offset key val)
X `(without-interrupts
X (setf (class-wrapper-cached-key ,wrapper ,offset) ,key) ;store key
X (setf (class-wrapper-cached-val ,wrapper ,offset) ,val))));store value
X
X(defmacro class-wrapper-cache-cached-entry (wrapper offset key)
X (once-only (wrapper offset)
X `(and (eq (class-wrapper-cached-key ,wrapper ,offset) ,key)
X (class-wrapper-cached-val ,wrapper ,offset))))
X
X(defmacro invalidate-class-wrapper (wrapper)
X (once-only (wrapper)
X `(progn (flush-class-wrapper-cache ,wrapper)
X (setf (class-wrapper-valid-p ,wrapper) nil))))
X
X(defmacro validate-class-wrapper (iwmc-class) ;HAS to be a macro!
X `(let ((wrapper (iwmc-class-class-wrapper ,iwmc-class)));So that xxx-low
X (if (class-wrapper-valid-p wrapper) ;can redefine the
X wrapper ;macros we use.
X (progn (setf (iwmc-class-class-wrapper ,iwmc-class)
X (class-wrapper (class-wrapper-class wrapper)))
X (setf (class-wrapper-valid-p wrapper) t)))))
X
X ;;
X;;;;;; Generating CACHE numbers
X ;;
X;;; These macros should produce a CACHE number for their first argument
X;;; masked to fit in their second argument. A useful cache number is just
X;;; the symbol or object's memory address. The memory address can either
X;;; be masked to fit the mask or folded down with xor to fit in the mask.
X;;; See some of the other low files for examples of how to implement these
X;;; macros. Except for their illustrative value, the portable versions of
X;;; these macros are nearly worthless. Any port of CommonLoops really
X;;; should redefine these to be faster and produce more useful numbers.
X
X(defvar *warned-about-symbol-cache-no* nil)
X(defvar *warned-about-object-cache-no* nil)
X
X(defmacro symbol-cache-no (symbol mask)
X (unless *warned-about-symbol-cache-no*
X (setq *warned-about-symbol-cache-no* t)
X (warn
X "Compiling PCL without having defined an implementation-specific~%~
X version of SYMBOL-CACHE-NO. This is likely to have a significant~%~
X effect on slot-access performance.~%~
X See the definition of symbol-cache-no in the file low to get an~%~
X idea of how to implement symbol-cache-no."))
X `(logand (sxhash ,symbol) ,mask))
X
X(defmacro object-cache-no (object mask)
X (ignore object)
X (unless *warned-about-object-cache-no*
X (setq *warned-about-object-cache-no* t)
X (warn
X "Compiling PCL without having defined an implementation-specific~%~
X version of OBJECT-CACHE-NO. This effectively disables method.~%~
X lookup caching. See the definition of object-cache-no in the file~%~
X low to get an idea of how to implement object-cache-no."))
X `(logand 0 ,mask))
X
X
X ;;
X;;;;;; FUNCTION-ARGLIST
X ;;
X;;; Given something which is functionp, function-arglist should return the
X;;; argument list for it. PCL does not count on having this available, but
X;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of
X;;; function-arglist for each specific port of pcl should be put in the
X;;; appropriate xxx-low file. This is what it should look like:
X;(defun function-arglist (function)
X; (<system-dependent-arglist-function> function))
X
X(defun function-pretty-arglist (function)
X (ignore function)
X ())
X
X(defsetf function-pretty-arglist set-function-pretty-arglist)
X
X(defun set-function-pretty-arglist (function new-value)
X (ignore function)
X new-value)
X
X
X
X ;;
X;;;;;; Templated functions
X ;;
X;;; In CommonLoops there are many program-generated functions which
X;;; differ from other, similar program-generated functions only in the
X;;; values of certain in-line constants.
X;;;
X;;; A prototypical example is the family of discriminating functions used by
X;;; classical discriminators. For all classical discriminators which have
X;;; the same number of required arguments and no &rest argument, the
X;;; discriminating function is the same, except for the value of the
X;;; "in-line" constants (the cache and discriminator).
X;;;
X;;; Naively, whenever we want one of these functions we have to produce and
X;;; compile separate lambda. But this is very expensive, instead what we
X;;; would like to do is copy the existing compiled code and replace the
X;;; values of the inline constants with the right new values.
X;;;
X;;; Templated functions provide a nice interface to this abstraction of
X;;; copying an existing compiled function and replacing certain constants
X;;; with others. Templated functions are based on the assumption that for
X;;; any given CommonLisp one of the following is true:
X;;; Either:
X;;; Funcalling a lexical closure is fast, and lexical variable access
X;;; is as fast (or about as fast) in-line constant access. In this
X;;; case we implement templated functions as lexical closures closed
X;;; over the constants we want to change from one instance of the
X;;; templated function to another.
X;;; Or:
X;;; Code can be written to take a compiled code object, copy it and
X;;; replace references to certain in-line constants with references
X;;; to other in-line constants.
X;;;
X;;; Actually, I believe that for most Lisp both of the above assumptions are
X;;; true. For certain lisps the explicit copy and replace scheme *may be*
X;;; more efficient but the lexical closure scheme is completely portable and
X;;; is likely to be more efficient since the lexical closure it returns are
X;;; likely to share compiled code objects and only have separate lexical
X;;; environments.
X;;;
X;;; Another thing to notice about templated functions is that they provide
X;;; the modularity to support special objects which a particular
X;;; implementation's low-level function-calling code might know about. As
X;;; an example, when a classical discriminating function is created, the
X;;; code says "make a classical discriminating function with 1 required
X;;; arguments". It then uses whatever comes back from the templated function
X;;; code as the the discriminating function So, a particular port can easily
X;;; make this return any sort of special data structure instead of one of
X;;; the lexical closures the portable implementation returns.
X;;;
X(defvar *templated-function-types* ())
X(defmacro define-function-template (name
X template-parameters
X instance-parameters
X &body body)
X `(progn
X (pushnew ',name *templated-function-types*)
X ;; Get rid of all the cached constructors.
X (setf (get ',name 'templated-fn-constructors) ())
X ;; Now define the constructor constructor.
X (setf (get ',name 'templated-fn-params)
X (list* ',template-parameters ',instance-parameters ',body))
X (setf (get ',name 'templated-fn-constructor-constructor)
X ,(make-templated-function-constructor-constructor
X template-parameters instance-parameters body))))
X
X(defun reset-templated-function-types ()
X (dolist (type *templated-function-types*)
X (setf (get type 'templated-fn-constructors) ())))
X
X(defun get-templated-function-constructor (name &rest template-parameters)
X (setq template-parameters (copy-list template-parameters)) ;Groan.
X (let ((existing (assoc template-parameters
X (get name 'templated-fn-constructors)
X :test #'equal)))
X (if existing
X (progn (setf (nth 3 existing) t) ;Mark this constructor as
X ;having been used.
X (cadr existing)) ;And return the actual
X ;constructor.
X (let ((new-constructor
X (apply (get name 'templated-fn-constructor-constructor)
X template-parameters)))
X (push (list template-parameters new-constructor 'made-on-the-fly t)
X (get name 'templated-fn-constructors))
X new-constructor))))
X
X(defmacro pre-make-templated-function-constructor (name
X &rest template-parameters)
X (setq template-parameters (copy-list template-parameters)) ;Groan.
X (let* ((params (get name 'templated-fn-params))
X (template-params (car params))
X (instance-params (cadr params))
X (body (cddr params))
X (dummy-fn-name (gensym))) ;For the 3600, which doesn't bother to
X ;compile top-level forms, we do the
X ;top-level form compilation by hand.
X (progv template-params
X template-parameters
X `(progn
X (defun ,dummy-fn-name ()
X (let ((entry
X (or (assoc ',template-parameters
X (get ',name 'templated-fn-constructors)
X :test #'equal)
X (let ((new-entry
X (list ',template-parameters () () ())))
X (push new-entry
X (get ',name 'templated-fn-constructors))
X new-entry))))
X (setf (caddr entry) 'pre-made)
X (setf (cadr entry)
X (function (lambda ,(eval instance-params)
X ,(eval (cons 'progn body)))))))
X (,dummy-fn-name)))))
X
X(defun make-templated-function-constructor-constructor (template-params
X instance-params
X body)
X `(function
X (lambda ,template-params
X (compile () (list 'lambda ,instance-params ,@body)))))
X
X ;;
X;;;;;;
X ;;
X
X(defun record-definition (name type &rest args)
X (ignore name type args)
X ())
X
X(defun compile-time-define (&rest ignore)
X (ignore ignore))
X
END_OF_FILE
if test 27849 -ne `wc -c <'low.l'`; then
echo shar: \"'low.l'\" unpacked with wrong size!
fi
# end of 'low.l'
fi
echo shar: End of archive 8 \(of 13\).
cp /dev/null ark8isdone
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.uu.net