rs@uunet.UU.NET (Rich Salz) (08/03/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 80
Archive-name: comobj.lisp/Part06
#! /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 6 (of 13)."
# Contents: gfun-low.l test.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'gfun-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'gfun-low.l'\"
else
echo shar: Extracting \"'gfun-low.l'\" \(20567 characters\)
sed "s/^X//" >'gfun-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
X#| To do:
X
Xfigure out bootstrapping issues
X
Xfix problems caused by make-iwmc-class-accessor
X
Xpolish up the low levels of iwmc-class,
X
Xpolish up low levels of this and implement it for the 3600 then Lucid.
X
Xfix use of get-slot-using-class--class-internal
X
X|#
X ;;
X;;;;;; FUNCALLABLE INSTANCES
X ;;
X
X#|
X
XIn CommonLoops, generic functions are instances whose meta class is
Xfuncallable-standard-class. Instances with this meta class behave
Xsomething like lexical closures in that they have slots, just like
Xinstances with meta class standard-class, and are also funcallable.
XWhen an instance with meta class funcallable-standard-class is
Xfuncalled, the value of its function slot is called.
X
XIt is possible to implement funcallable instances in pure Common Lisp.
XA simple implementation which uses lexical closures as the instances and
Xa hash table to record that the lexical closures are funcallable
Xinstances is easy to write. Unfortunately, this implementation adds
Xsuch significant overhead:
X
X to generic-function-invocation (1 function call)
X to slot-access (1 function call)
X to class-of a generic-function (1 hash-table lookup)
X
Xthat it is too slo to be practical.
X
XInstead, PCL uses a specially tailored implementation for each common
XLisp and makes no attempt to provide a purely portable implementation.
XThe specially tailored implementations are based on each the lexical
Xclosure's provided by that implementation and tend to be fairly easy to
Xwrite.
X
X|#
X
X(in-package 'pcl)
X
X;;;
X;;; The first part of the file contains the implementation dependent code
X;;; to implement the low-level funcallable instances. Each implementation
X;;; must provide the following functions and macros:
X;;;
X;;; MAKE-FUNCALLABLE-INSTANCE-1 ()
X;;; should create and return a new funcallable instance
X;;;
X;;; FUNCALLABLE-INSTANCE-P (x)
X;;; the obvious predicate
X;;;
X;;; SET-FUNCALLABLE-INSTANCE-FUNCTION-1 (fin new-value)
X;;; change the fin so that when it is funcalled, the new-value
X;;; function is called. Note that it is legal for new-value
X;;; to be copied before it is installed in the fin (the Lucid
X;;; implementation in particular does this).
X;;;
X;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
X;;; should return the value of the data named data-name in the fin
X;;; data-name is one of the symbols in the list which is the value
X;;; of funcallable-instance-data. Since data-name is almost always
X;;; a quoted symbol and funcallable-instance-data is a constant, it
X;;; is possible (and worthwhile) to optimize the computation of
X;;; data-name's offset in the data part of the fin.
X;;;
X
X(defconstant funcallable-instance-data
X '(class wrapper static-slots dynamic-slots)
X "These are the 'data-slots' which funcallable instances have so that
X the meta-class funcallable-standard-class can store class, and static
X and dynamic slots in them.")
X
X#+Lucid
X(progn
X
X(defconstant funcallable-instance-procedure-size 50)
X(defconstant funcallable-instance-flag-bit #B1000000000000000)
X(defvar *funcallable-instance-trampolines* ()
X "This is a list of all the procedure sizes which were too big to be stored
X directly in a funcallable instance. For each of these procedures, a
X trampoline procedure had to be used. This is for metering information
X only.")
X
X(defun make-funcallable-instance-1 ()
X (let ((new-fin (lucid::new-procedure funcallable-instance-procedure-size)))
X ;; Have to set the procedure function to something for two reasons.
X ;; 1. someone might try to funcall it.
X ;; 2. the flag bit that says the procedure is a funcallable
X ;; instance is set by set-funcallable-instance-function.
X (set-funcallable-instance-function
X new-fin
X #'(lambda (&rest ignore)
X (declare (ignore ignore))
X (error "Attempt to funcall a funcallable-instance without first~%~
X setting its funcallable-instance-function.")))
X new-fin))
X
X(defmacro funcallable-instance-p (x)
X (once-only (x)
X `(and (lucid::procedurep ,x)
X (logand (lucid::procedure-ref ,x lucid::procedure-flags)
X funcallable-instance-flag-bit))))
X
X(defun set-funcallable-instance-function-1 (fin new-value)
X (unless (funcallable-instance-p fin)
X (error "~S is not a funcallable-instance"))
X (cond ((not (functionp new-value))
X (error "~S is not a function."))
X ((not (lucid::procedurep new-value))
X ;; new-value is an interpreted function. Install a
X ;; trampoline to call the interpreted function.
X (set-funcallable-instance-function fin
X (make-trampoline new-value)))
X (t
X (let ((new-procedure-size (lucid::procedure-length new-value))
X (max-procedure-size (- funcallable-instance-procedure-size
X (length funcallable-instance-data))))
X (if (< new-procedure-size max-procedure-size)
X ;; The new procedure fits in the funcallable-instance.
X ;; Just copy the new procedure into the fin procedure,
X ;; also be sure to update the procedure-flags of the
X ;; fin to keep it a fin.
X (progn
X (dotimes (i max-procedure-size)
X (setf (lucid::procedure-ref fin i)
X (lucid::procedure-ref new-value i)))
X (setf (lucid::procedure-ref fin lucid::procedure-flags)
X (logand funcallable-instance-flag-bit
X (lucid::procedure-ref
X fin lucid::procedure-flags)))
X new-value)
X ;; The new procedure doesn't fit in the funcallable instance
X ;; Instead, install a trampoline procedure which will call
X ;; the new procecdure. First make note of the fact that we
X ;; had to trampoline so that we can see if its worth upping
X ;; the value of funcallable-instance-procedure-size.
X (progn
X (push new-procedure-size *funcallable-instance-trampolines*)
X (set-funcallable-instance-function
X fin
X (make-trampoline new-value))))))))
X
X
X(defmacro funcallable-instance-data-1 (instance data)
X `(lucid::procedure-ref ,instance
X (- funcallable-instance-procedure-size
X (position ,data funcallable-instance-data))))
X
X);dicuL+#
X
X;;;
X;;; All of these Lisps (Xerox Symbolics ExCL KCL and VAXLisp) have the
X;;; following in Common:
X;;;
X;;; - they represent their compiled closures as a pair of
X;;; environment and compiled function
X;;; - they represent the environment using a list or a vector
X;;; - I don't (YET) know how to add a bit to the damn things to
X;;; say that they are funcallable-instances and so I have to
X;;; use the last entry in the closure environment to do that.
X;;; This is a lose because that is much slower, I have to CDR
X;;; down to the last element of the environment.
X;;;
X#+(OR Xerox Symbolics ExCL KCL (and DEC VAX))
X(progn
X
X(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))
X
X(defconstant funcallable-instance-closure-size 15)
X
X(defmacro lexical-closure-p (lc)
X #+Xerox `(typep ,lc 'il:compiled-closure)
X #+Symbolics `(si:lexical-closure-p ,lc)
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) (once-only (lc)
X `(and (listp ,lc)
X (eq (car ,lc) 'system::%compiled-closure%))))
X
X(defmacro lexical-closure-env (lc)
X #+Xerox `()
X #+Symbolics `(si:lexical-closure-environment ,lc)
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) `(caadr ,lc))
X
X(defmacro lexical-closure-env-size (env)
X #+Xerox `()
X #+Symbolics `(length ,env)
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) `(array-dimension ,env 0))
X
X(defmacro lexical-closure-env-ref (env index check) check
X #+Xerox `()
X #+Symbolics `(let ((env ,env))
X (dotimes (i ,index)
X (setq env (cdr env)))
X (car env))
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) (once-only (env)
X `(and ,(or checkp
X `(= (array-dimension ,env 0)
X funcallable-instance-closure-size))
X (svref ,env 0))))
X
X(defmacro lexical-closure-env-set (env index new checkp) checkp
X #+Xerox `()
X #+Symbolics `(let ((env ,env))
X (dotimes (i ,index)
X (setq env (cdr env)))
X (setf (car env) ,new))
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) (once-only (env)
X `(and ,(or checkp
X `(= (array-dimension ,env 0)
X funcallable-instance-closure-size))
X (setf (svref ,env ,index) ,new))))
X
X(defmacro lexical-closure-code (lc)
X #+Xerox `()
X #+Symbolics `(si:lexical-closure-function ,lc)
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) `(caddr ,lc))
X
X(defmacro compiled-function-code (cf)
X #+Xerox `()
X #+Symbolics cf
X #+ExCL `()
X #+KCL `()
X #+(and DEC VAX) `())
X
X(eval-when (load eval)
X (let ((dummies ()))
X (dotimes (i funcallable-instance-closure-size)
X (push (gentemp "Dummy Closure Variable ") dummies))
X (compile 'make-funcallable-instance-1 ;For the time being, this use
X `(lambda () ;of compile at load time is
X (let (new-fin ,@dummies) ;simpler than using #.
X (setq new-fin #'(lambda ()
X ,@(mapcar #'(lambda (d)
X `(setq ,d (dummy-fn ,d)))
X dummies)))
X (lexical-closure-env-set
X (lexical-closure-env new-fin)
X (1- funcallable-instance-closure-size)
X *funcallable-instance-marker*
X t)
X new-fin)))))
X
X(defmacro funcallable-instance-p (x)
X (once-only (x)
X `(and (lexical-closure-p ,x)
X (let ((env (lexical-closure-env ,x)))
X (and (eq (lexical-closure-env-ref
X env (1- funcallable-instance-closure-size) t)
X *funcallable-instance-marker*))))))
X
X(defun set-funcallable-instance-function-1 (fin new-value)
X (cond ((lexical-closure-p new-value)
X (let* ((fin-env (lexical-closure-env fin))
X (new-env (lexical-closure-env new-value))
X (new-env-size (lexical-closure-env-size new-env))
X (fin-env-size (- funcallable-instance-closure-size
X (length funcallable-instance-data))))
X (cond ((<= new-env-size fin-env-size)
X (dotimes (i new-env-size)
X (lexical-closure-env-set
X fin-env i (lexical-closure-env-ref new-env i nil) nil))
X (setf (lexical-closure-code fin)
X (lexical-closure-code new-value)))
X (t
X (set-funcallable-instance-function-1
X fin (make-trampoline new-value))))))
X (t
X #+Symbolics
X (set-funcallable-instance-function-1 fin
X (make-trampoline new-value))
X #-Symbolics
X (setf (lexical-closure-code fin)
X (compiled-function-code new-value)))))
X
X(defmacro funcallable-instance-data-1 (fin data)
X `(lexical-closure-env-ref
X (lexical-closure-env ,fin)
X (- funcallable-instance-closure-size
X (position ,data funcallable-instance-data)
X 2)
X nil))
X
X(defsetf funcallable-instance-data-1 (fin data) (new-value)
X `(lexical-closure-env-set
X (lexical-closure-env ,fin)
X (- funcallable-instance-closure-size
X (position ,data funcallable-instance-data)
X 2)
X ,new-value
X nil))
X
X);
X
X
X(defun make-trampoline (function)
X #'(lambda (&rest args)
X (apply function args)))
X
X(defun set-funcallable-instance-function (fin new-value)
X (cond ((not (funcallable-instance-p fin))
X (error "~S is not a funcallable-instance"))
X ((not (functionp new-value))
X (error "~S is not a function."))
X ((compiled-function-p new-value)
X (set-funcallable-instance-function-1 fin new-value))
X (t
X (set-funcallable-instance-function-1 fin
X (make-trampoline new-value)))))
X
X
X(eval-when (eval load)
X (setq *class-of*
X '(lambda (x)
X (or (and (%instancep x)
X (%instance-class-of x))
X (and (funcallable-instance-p x)
X (funcallable-instance-class x))
X (class-named (type-of x) t))))
X
X (recompile-class-of))
X
X
X(defmacro funcallable-instance-class (fin)
X `(funcallable-instance-data-1 ,fin 'class))
X
X(defmacro funcallable-instance-wrapper (fin)
X `(funcallable-instance-data-1 ,fin 'wrapper))
X
X(defmacro funcallable-instance-static-slots (fin)
X `(funcallable-instance-data-1 ,fin 'static-slots))
X
X(defmacro funcallable-instance-dynamic-slots (fin)
X `(funcallable-instance-data-1 ,fin 'dynamic-slots))
X
X(defun make-funcallable-instance (class wrapper number-of-static-slots)
X (let ((fin (make-funcallable-instance-1))
X (static-slots (make-memory-block number-of-static-slots))
X (dynamic-slots ()))
X (setf (funcallable-instance-class fin) class
X (funcallable-instance-wrapper fin) wrapper
X (funcallable-instance-static-slots fin) static-slots
X (funcallable-instance-dynamic-slots fin) dynamic-slots)
X fin))
X
X
X;;; By macroleting the definitions of:
X;;; IWMC-CLASS-CLASS-WRAPPER
X;;; IWMC-CLASS-STATIC-SLOTS
X;;; IWMC-CLASS-DYNAMIC-SLOTS
X;;; get-slot-using-class--class-internal ;These are kind of a
X;;; put-slot-using-class--class-internal ;hack, solidfy this.
X;;;
X;;; we can use all the existing code for metaclass class.
X;;;
X(defmacro with-funcallable-class-as-class ((instance checkp)
X &body body)
X (once-only (instance)
X `(let ((.class. (funcallable-instance-p ,instance)))
X ,(and checkp
X `(or .class.
X (error "~S is not an instance with meta-class ~
X funcallable-class." ,instance)))
X (macrolet ((iwmc-class-class-wrapper (instance)
X `(funcallable-instance-wrapper ,instance))
X (iwmc-class-static-slots (instance)
X `(funcallable-instance-static-slots ,instance))
X (iwmc-class-dynamic-slots (instance)
X `(funcallable-instance-dynamic-slots ,instance))
X (get-slot-using-class--class-internal
X (class object slot-name
X dont-call-slot-missing-p default)
X `(with-slot-internal--class (,class ,object
X ,slot-name nil)
X (:instance (index)
X (get-static-slot--class ,object index))
X (:dynamic (loc newp) (if (eq newp t)
X (setf (car loc) ,default)
X (car loc)))
X (:class (slotd) (slotd-default slotd))
X (nil () (unless ,dont-call-slot-missing-p
X (slot-missing ,object ,slot-name)))))
X (put-slot-using-class--class-internal
X (class object slot-name new-value
X dont-call-slot-missing-p)
X `(with-slot-internal--class (,class ,object
X ,slot-name
X ,dont-call-slot-missing-p)
X (:instance (index)
X (setf (get-static-slot--class ,object
X index)
X ,new-value))
X (:dynamic (loc) (setf (car loc) ,new-value))
X (:class (slotd) (setf (slotd-default slotd)
X ,new-value))
X (nil () (unless ,dont-call-slot-missing-p
X (slot-missing ,object ,slot-name))))))
X ,@body))))
X
X ;;
X;;;;;;
X ;;
X
X
X(defmacro get-slot--funcallable-class (fnc-instance slot-name)
X (once-only (fnc-instance slot-name)
X `(with-funcallable-class-as-class (,fnc-instance t)
X (get-slot--class ,fnc-instance ,slot-name))))
X
X(defmacro put-slot--funcallable-class (fnc-instance slot-name new-value)
X (once-only (fnc-instance slot-name)
X `(with-funcallable-class-as-class (,fnc-instance t)
X ;; Cheat a little bit here, its worth it.
X ,(if (constantp slot-name)
X (if (eq (eval slot-name) 'function)
X `(progn (set-funcallable-instance-function ,fnc-instance
X ,new-value)
X (put-slot--class ,fnc-instance ,slot-name ,new-value))
X `(put-slot--class ,fnc-instance ,slot-name ,new-value))
X `(if (eq ,slot-name 'function)
X (progn (set-funcallable-instance-function ,fnc-instance
X ,new-value)
X (put-slot--class ,fnc-instance ,slot-name ,new-value))
X (put-slot--class ,fnc-instance ,slot-name ,new-value))))))
X
X ;;
X;;;;;;
X ;;
X
X(defclass funcallable-class (class)
X ())
X
X(defmeth check-super-metaclass-compatibility ((fnc-class funcallable-class)
X (class class))
X (ignore fnc-class)
X (null (class-slots class)))
X
X
X(defmeth get-slot-using-class ((ignore funcallable-class)
X instance
X slot-name)
X (get-slot--funcallable-class instance slot-name))
X
X(defmeth put-slot-using-class ((ignore funcallable-class)
X instance
X slot-name
X new-value)
X (put-slot--funcallable-class instance slot-name new-value))
X
X(defmeth make-instance ((class funcallable-class))
X (let ((class-wrapper (class-wrapper class)))
X (if class-wrapper ;Are there any instances?
X ;; If there are instances, the class is OK, just go ahead and
X ;; make the instance.
X (make-funcallable-instance class
X class-wrapper
X (class-no-of-instance-slots class))
X ;; Do first make-instance-time error-checking, build the class
X ;; wrapper and call ourselves again to really build the instance.
X (progn
X ;; no first time error checking yet.
X (setf (class-wrapper class) (make-class-wrapper class))
X (make-instance class)))))
X
X(eval-when (compile load eval)
X
X(define-function-template iwmc-funcallable-class-accessor () '(slot-name)
X `(function (lambda (iwmc-class)
X (get-slot--funcallable-class iwmc-class slot-name))))
X
X(define-function-template iwmc-funcallable-class-accessor-setf (read-only-p)
X '(slot-name)
X (if read-only-p
X `(function
X (lambda (iwmc-class new-value)
X (error "~S is a read only slot." slot-name)))
X `(function
X (lambda (iwmc-class new-value)
X (put-slot--funcallable-class iwmc-class slot-name new-value)))))
X)
X
X(eval-when (load)
X (pre-make-templated-function-constructor iwmc-class-accessor)
X (pre-make-templated-function-constructor iwmc-class-accessor-setf nil)
X (pre-make-templated-function-constructor iwmc-class-accessor-setf t))
X
X(defmethod make-iwmc-class-accessor ((ignore funcallable-class) slotd)
X (funcall
X (get-templated-function-constructor 'iwmc-funcallable-class-accessor)
X (slotd-name slotd)))
X
X(defmethod make-iwmc-class-accessor-setf ((ignore funcallable-class) slotd)
X (funcall
X (get-templated-function-constructor 'iwmc-funcallable-class-accessor-setf
X (slotd-read-only slotd))
X (slotd-name slotd)))
X
X
X ;;
X;;;;;;
X ;;
X
X#|
X
X(defclass generic-function (discriminator)
X ((function #'(lambda (&rest ignore) ignore (error "foo")))
X (name ())
X (methods ())
X (discriminating-function ())
X (cache ())
X (dispatch-order ())
X (method-combination-type ())
X (method-combination-parameters ())
X (methods-combine-p ()))
X (:metaclass funcallable-class))
X
X(defmeth install-discriminating-function ((gfun generic-function)
X where
X function
X &optional inhibit-compile-p)
X (check-type where symbol "a symbol other than NIL")
X (check-type function function "a funcallable object")
X
X (when (and (listp function)
X (eq (car function) 'lambda)
X (null inhibit-compile-p))
X (setq function (compile nil function)))
X
X (setf (get-slot gfun 'function) function))
X
X(defun convert-to-generic-functions ()
X (let ((discriminators ()))
X (do-symbols (s (find-package 'pcl))
X (when (discriminator-named s) (push s discriminators)))
X
X
X ))
X
X(defun convert-generic-function (name)
X (let ((discriminator (discriminator-named name))
X (gfun (make 'generic-function)))
X (setf (funcallable-instance-static-slots gfun)
X (iwmc-class-static-slots discriminator))
X (setf (funcallable-instance-dynamic-slots gfun)
X (iwmc-class-dynamic-slots discriminator))
X (install-discriminating-function gfun
X ()
X (symbol-function name))
X (set name gfun)))
X
X
X(defclass bar ()
X ((function nil)
X (a 1)
X (b 2))
X (:metaclass funcallable-class))
X
X(defclass foo ()
X ((a nil)
X (b nil)
X (c nil))
X (:metaclass funcallable-class))
X
X|#
X
END_OF_FILE
if test 20567 -ne `wc -c <'gfun-low.l'`; then
echo shar: \"'gfun-low.l'\" unpacked with wrong size!
fi
# end of 'gfun-low.l'
fi
if test -f 'test.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'test.l'\"
else
echo shar: Extracting \"'test.l'\" \(21892 characters\)
sed "s/^X//" >'test.l' <<'END_OF_FILE'
X;;;-*- Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; Testing code.
X;;;
X
X(in-package 'pcl)
X
X;;; Because CommonLoops runs in itself so much, the notion of a test file for
X;;; it is kind of weird.
X;;;
X;;; If all of PCL loads then many of the tests in this file (particularly
X;;; those at the beginning) are sure to work. Those tests exists primarily
X;;; to help debug things when low-level changes are made to PCL, or when a
X;;; particular port customizes low-level code.
X;;;
X;;; Some of the other tests are "real" in the sense that they test things
X;;; that PCL itself does not use, so might be broken.
X;;;
X;;; NOTE:
X;;; The tests in this file do not appear in random order! They
X;;; depend on state which has already been set up in order to run.
X;;;
X;;; As a convention foo, bar and baz are used for classes and
X;;; discriminators which are just for the current test. By
X;;; default, do-test resets those names before running the current
X;;; test. Other names like x, y, z, method-1... are used to name
X;;; classes and discriminators which last the life of the file.
X;;;
X
X(defvar *without-errors*
X (or #+Symbolics #'(lambda (form)
X `(multiple-value-bind (.values. .errorp.)
X (si::errset ,form nil)
X (declare (ignore .values.))
X .errorp.))
X #+Xerox #'(lambda (form)
X `(xcl:condition-case (progn ,form nil)
X (error () t)))
X
X nil))
X
X(defmacro without-errors (&body body)
X (if *without-errors*
X (funcall *without-errors* `(progn ,@body))
X (error "Calling WITHOUT-ERRORS when *without-errors* is nil.")))
X
X#-HP (defmacro do-test (name&options &body body)
X (let ((name (if (listp name&options) (car name&options) name&options))
X (options (if (listp name&options) (cdr name&options) ())))
X (keyword-bind ((clear t)
X (should-error nil))
X options
X (cond ((and should-error (null *without-errors*))
X `(format t
X "~&Skipping testing ~A,~%~
X because can't ignore errors in this Common Lisp."
X ',name))
X (t
X `(progn
X (format t "~&Testing ")
X (format t ,name)
X (format t "... ")
X ,(when clear
X '(progn (dolist (x '(foo bar baz))
X (setf (discriminator-named x) nil)
X (fmakunbound x)
X (setf (class-named x) nil))))
X (if ,(if should-error
X `(without-errors (progn ,@body))
X `(progn ,@body))
X (format t "OK")
X (progn (format t "FAILED")
X (error "Test Failed: ~A" ',name)))))))))
X
X#+HP (defmacro do-test (name&options &body body)
X (let ((name (if (listp name&options) (car name&options) name&options))
X (options (if (listp name&options) (cdr name&options) ())))
X (keyword-bind ((clear t)
X (should-error nil))
X options
X (cond ((and should-error (null *without-errors*))
X `(format t
X "~&Skipping testing ~A,~%~
X because can't ignore errors in this Common Lisp."
X ',name))
X (t
X `(progn
X (format t "~&Testing ~A..." ,name)
X ,(when clear
X '(progn (dolist (x '(foo bar baz))
X (setf (discriminator-named x) nil)
X (fmakunbound x)
X (setf (class-named x) nil))))
X
X ,@(butlast body)
X (if ,(if should-error
X `(without-errors (progn ,@body))
X `(progn ,@(last body)))
X (format t "OK")
X (progn (format t "FAILED")
X (error "Test Failed: ~A" ',name)))))))))
X
X(defun permutations (elements length)
X (if (= length 1)
X (iterate ((x in elements)) (collect (list x)))
X (let ((sub-permutations (permutations elements (- length 1))))
X (iterate ((x in elements))
X (join (iterate ((y in sub-permutations))
X (collect (cons x y))))))))
X
X ;;
X;;;;;;
X ;;
X
X
X(eval-when (load eval)
X (format t "~&~%~%Testing Extremely low-level stuff..."))
X
X(do-test ("Memory Block Primitives" :clear nil)
X (let ((block (make-memory-block 10))
X (tests (iterate ((i from 0 below 10)) (collect (make-list 1)))))
X (and (numberp (memory-block-size block))
X (= (memory-block-size block) 10)
X (progn (iterate ((i from 0) (test in tests))
X (setf (memory-block-ref block i) test))
X (iterate ((i from 0) (test in tests))
X (unless (eq (memory-block-ref block i) test) (return nil))
X (finally (return t)))))))
X
X(do-test ("Class Wrapper Caching" :clear nil)
X (let* ((wrapper (make-class-wrapper 'test))
X (offset (class-wrapper-get-slot-offset wrapper 'foo))
X (value (list ())))
X
X (and (eq 'foo (setf (class-wrapper-cached-key wrapper offset) 'foo))
X (eq value (setf (class-wrapper-cached-val wrapper offset) value))
X (eq 'foo (class-wrapper-cached-key wrapper offset))
X (eq value (class-wrapper-cached-val wrapper offset)))))
X
X(do-test ("Flushing Class-Wrapper caches" :clear nil)
X (let* ((wrapper (make-class-wrapper 'test))
X (offset (class-wrapper-get-slot-offset wrapper 'foo)))
X (setf (class-wrapper-cached-key wrapper offset) 'foo)
X (flush-class-wrapper-cache wrapper)
X (neq 'foo (class-wrapper-cached-key wrapper offset))))
X
X(do-test "Class Wrapper Caching"
X (let ((slots '(;; Some random important slots.
X name class-wrapper class-precedence-list
X direct-supers direct-subclasses direct-methods
X no-of-instance-slots instance-slots
X local-supers
X non-instance-slots local-slots prototype))
X (wrapper (make-class-wrapper 'test))
X (hits 0))
X (iterate ((slot in slots))
X (let ((offset (class-wrapper-get-slot-offset wrapper slot)))
X (setf (class-wrapper-cached-key wrapper offset) slot)))
X (iterate ((slot in slots))
X (let ((offset (class-wrapper-get-slot-offset wrapper slot)))
X (and (eq (class-wrapper-cached-key wrapper offset) slot)
X (incf hits))))
X (format t
X " (~D% hit) "
X (* 100.0 (/ hits (float (length slots)))))
X t))
X
X;(do-test "static slot-storage"
X; (let ((static-slots (%allocate-static-slot-storage--class 5)))
X; (iterate ((i from 0))
X; (when (= i 5) (return t))
X; (let ((cons (list ()))
X; (index (%convert-slotd-position-to-slot-index i)))
X; (setf (%static-slot-storage-get-slot--class static-slots index) cons)
X; (or (eq cons
X; (%static-slot-storage-get-slot--class static-slots index))
X; (return nil))))))
X
X
X(eval-when (load eval) (format t "~&~%~%Testing High-Level stuff..."))
X
X
X
X(defvar *built-in-classes*
X '((T T)
X (NUMBER 1)
X (RATIO 1/2 1/2)
X (COMPLEX)
X (INTEGER 1)
X (RATIO)
X (FIXNUM most-positive-fixnum most-positive-fixnum)
X (BIGNUM (+ most-positive-fixnum 1) (+ most-positive-fixnum 1))
X SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT
X (FLOAT 1.1)
X (NULL () ())
X (STANDARD-CHAR #\a)
X (STRING-CHAR #\a)
X (CHARACTER #\a #\a)
X BIT-VECTOR
X (STRING (make-string 1) (make-string 1))
X (ARRAY (make-array 1))
X SIMPLE-ARRAY SIMPLE-VECTOR SIMPLE-STRING SIMPLE-BIT-VECTOR
X (VECTOR (make-string 1))
X (VECTOR (make-array 1))
X (LIST '(1 2 3))
X (SEQUENCE (make-string 1))
X (SEQUENCE (make-array 1))
X (SEQUENCE (make-list 1))
X (HASH-TABLE (make-hash-table :size 1) (make-hash-table :size 1))
X (READTABLE *readtable* *readtable*)
X (PACKAGE *package* *package*)
X (PATHNAME (make-pathname :name "foo") (make-pathname :name "foo"))
X (STREAM *terminal-io* *terminal-io*)
X (RANDOM-STATE (make-random-state) (make-random-state))
X (CONS (cons 1 2) (cons 1 2))
X (SYMBOL 'foo 'foo)
X COMMON))
X
X(do-test "existence of built-in classes"
X (not (dolist (entry *built-in-classes*)
X (let ((type (if (listp entry) (car entry) entry)))
X (or (class-named type t)
X (progn (format t "Missing the built-in class named: ~S" type)
X (return t)))))))
X
X;;; See how CLASS-OF works.
X;(eval-when (load eval)
X; (format t "~%Check to see how well portable CLASS-OF works... ")
X; (let ((lost ()))
X; (dolist (entry *built-in-classes*)
X; (or (not (listp entry))
X; (null (cddr entry))
X; (let* ((thing (eval (caddr entry)))
X; (class (class-of thing)))
X; (and class (eq (class-name class) (car entry))))
X; (progn (setq lost t)
X; (format t
X; "~&WARNING: Can't define methods on: ~S."
X; (car entry)))))
X; (when lost (terpri) (terpri))
X; (format t "OK")))
X
X(do-test "existence of discriminators for accessors of early classes"
X ;; Because accessors are done with add-method, and this has to be done
X ;; specially for early classes it is worth testing to make sure that
X ;; the discriminators got created for the accessor of early classes.
X (not
X (dolist (class '(t object essential-class class discriminator method))
X (setq class (class-named class))
X (or (not (dolist (slotd (class-instance-slots class))
X (and (slotd-accessor slotd)
X (or (discriminator-named (slotd-accessor slotd))
X (return nil)))))
X (not (dolist (slotd (class-non-instance-slots class))
X (and (slotd-accessor slotd)
X (or (discriminator-named (slotd-accessor slotd))
X (return nil)))))))))
X
X(do-test "a simple defstruct"
X (ndefstruct (x (:class class))
X (a 1)
X (b 2))
X
X (and (fboundp 'make-x)
X (fboundp 'x-p)
X (fboundp 'copy-x)
X (fboundp 'x-a)
X (fboundp 'x-b)
X (typep--class (make-x) 'x)
X (x-p (make-x))
X (equal (x-a (make-x)) 1)
X (equal (x-a (make-x :a 3)) 3)
X (x-p (copy-x (make-x)))
X ))
X
X(do-test "obsolete-class stuff"
X (and (class-named 'obsolete-class)
X (let ((old-x-class (class-named 'x))
X (old-x-instance (make-x)))
X
X (ndefstruct (x (:class class))
X (a 3))
X (and (neq (class-of old-x-instance) (class-named 'x))
X (= (x-a old-x-instance) 1)))))
X
X(do-test "multiple constructors"
X (ndefstruct (x (:class class)
X (:constructor make-x)
X (:constructor make-x-1 (a b)))
X a
X b)
X (and (fboundp 'make-x)
X (fboundp 'make-x-1)
X (equal (get-slot (make-x :a 1 :b 2) 'a) 1)
X (equal (get-slot (make-x :a 1 :b 2) 'b) 2)
X (equal (get-slot (make-x-1 2 1) 'a) 2)
X (equal (get-slot (make-x-1 2 1) 'b) 1)))
X
X(do-test "the :print-function defstruct-option"
X
X (ndefstruct (x (:class class)
X (:print-function x-print-function))
X a
X b)
X
X (defun x-print-function (object stream level)
X (when (and (x-p object)
X (streamp stream) ;Don't be breaking my test file
X (numberp level)) ;because of your problems.
X (throw 'x 'x)))
X
X (eq (catch 'x (prin1 (make 'x))) 'x))
X
X;;; ** need more tests in here,
X;;; test the basic iwmc-class structure
X;;; test class-wrappers some more
X;;;
X
X;;; OK, now we know that simple defstruct works and that obsolete classes work.
X;;; Now we set up some real simple classes that we can use for the rest of the
X;;; file.
X;;;
X(ndefstruct (i (:class class))) ;(i ..)
X(ndefstruct (j (:class class))) ;(j ..)
X(ndefstruct (k (:class class))) ;(k ..)
X
X(ndefstruct (l (:class class) (:include (i)))) ;(l i ..)
X(ndefstruct (m (:class class) (:include (i j)))) ;(m i j ..)
X(ndefstruct (n (:class class) (:include (k)))) ;(n k ..)
X
X(ndefstruct (q (:class class) (:include (i)))) ;(q i ..)
X(ndefstruct (r (:class class) (:include (m)))) ;(r m i j ..)
X(ndefstruct (s (:class class) (:include (n i k)))) ;(s n i k ..)
X
X(do-test "classical methods"
X
X (defmeth foo ((x i)) x 'i)
X (defmeth foo ((x n)) x 'n)
X (defmeth foo ((x s)) x 's)
X
X (and (eq (foo (make-i)) 'i)
X (eq (foo (make-n)) 'n)
X (eq (foo (make-s)) 's)))
X
X(do-test "run-super"
X
X (defmeth foo (o) o ())
X
X (defmeth foo ((o i)) o (cons 'i (run-super)))
X (defmeth foo ((o m)) o (cons 'm (run-super)))
X (defmeth foo ((o n)) o (cons 'n (run-super)))
X (defmeth foo ((o q)) o (cons 'q (run-super)))
X (defmeth foo ((o r)) o (cons 'r (run-super)))
X (defmeth foo ((o s)) o (cons 's (run-super)))
X
X (let ((i (make-i)) (m (make-m)) (q (make-q)) (r (make-r)) (s (make-s)))
X (and (equal (foo i) '(i))
X (equal (foo m) '(m i))
X (equal (foo q) '(q i))
X (equal (foo r) '(r m i))
X (equal (foo s) '(s n i)))))
X
X(do-test "multi-methods when first 3 args are discriminated on"
X (let ((permutations (permutations '(i n r) 3)))
X (mapcar #'(lambda (p)
X (EVAL `(defmeth foo ,(mapcar 'list '(x y z) p) x y z ',p)))
X permutations)
X (every #'(lambda (p)
X (equal (apply 'foo (mapcar 'make p)) p))
X permutations)))
X
X(do-test "multi-methods when assorted args are discriminated on"
X (let ((permutations (permutations '(i n r nil) 3)))
X (mapc #'(lambda (p)
X (EVAL `(defmeth foo
X ,(mapcar #'(lambda (arg type-spec)
X (if type-spec
X (list arg type-spec) arg))
X '(arg1 arg2 arg3)
X p)
X arg1 arg2 arg3 ',p)))
X permutations)
X (every #'(lambda (p)
X (equal (apply 'foo
X (mapcar #'(lambda (x) (and x (make x))) p)) p))
X permutations)))
X
X
X
X;(do-test "anonymous discriminators"
X;
X; (let ((foo (make 'discriminator))
X; (proto-method (class-prototype (class-named 'method))))
X; (add-method-internal foo proto-method '(thing) (list (class-named 'x)) '(lambda (thing) thing 'x))
X; (add-method foo '(thing) (list (class-named 'y)) '(lambda (thing) thing 'y))
X; (add-method foo '(thing) (list (class-named 'z)) '(lambda (thing) thing 'z))
X;
X; (let ((function (discriminator-discriminating-function foo)))
X; (and (eq (funcall function (make 'x)) 'x)
X; (eq (funcall function (make 'y)) 'y)
X; (eq (funcall function (make 'z)) 'z)))))
X
X
X
X(do-test "Simple with test -- does not really exercise the walker."
X
X (ndefstruct (foo (:class class))
X (x 0)
X (y 0))
X
X (defmeth foo ((obj foo))
X (with (obj)
X (list x y)))
X
X (defmeth bar ((obj foo))
X (with ((obj obj-))
X (setq obj-x 1
X obj-y 2)))
X
X (and (equal '(0 0) (foo (make-foo)))
X (equal '(1 2) (foo (make-foo :x 1 :y 2)))
X (let ((foo (make-foo)))
X (bar foo)
X (and (equal (get-slot foo 'x) 1)
X (equal (get-slot foo 'y) 2)))))
X
X(do-test "Simple with* test -- does not really exercise the walker."
X
X (ndefstruct (foo (:class class))
X (x 0)
X (y 0))
X
X (defmeth foo ((obj foo))
X (with* (obj)
X (list x y)))
X
X (defmeth bar ((obj foo))
X (with* ((obj obj-))
X (setq obj-x 1
X obj-y 2)))
X
X (and (equal '(0 0) (foo (make-foo)))
X (equal '(1 2) (foo (make-foo :x 1 :y 2)))
X (let ((foo (make-foo)))
X (bar foo)
X (and (equal (get-slot foo 'x) 1)
X (equal (get-slot foo 'y) 2)))))
X
X'(
X
X;;; setup for :daemon combination test
X;;;
X
X(do-test "setting up for :daemon method combination test"
X
X (ndefstruct (foo (:class class)))
X (ndefstruct (bar (:class class) (:include (foo))))
X (ndefstruct (baz (:class class) (:include (bar)))))
X
X(defvar *foo*)
X
X(defmeth foo ((x foo)) (push 'foo *foo*) 'foo)
X(defmeth (foo :before) ((x foo)) (push '(:before foo) *foo*))
X(defmeth (foo :after) ((x foo)) (push '(:after foo) *foo*))
X
X(do-test (":before primary and :after all on same class." :clear nil)
X
X (let ((*foo* ()))
X (and (eq (foo (make 'foo)) 'foo)
X (equal *foo* '((:after foo) foo (:before foo))))))
X
X(defmeth foo ((x bar)) (push 'bar *foo*) 'bar)
X
X(do-test (":before and :after inherited, primary from this class" :clear nil)
X
X (let ((*foo* ()))
X (and (eq (foo (make 'bar)) 'bar)
X (equal *foo* '((:after foo) bar (:before foo))))))
X
X(do-test ("make sure shadowing primary in sub-class has no effect here"
X :clear nil)
X (let ((*foo* ()))
X (and (eq (foo (make 'foo)) 'foo)
X (equal *foo* '((:after foo) foo (:before foo))))))
X
X(defmeth (foo :before) ((x bar)) (push '(:before bar) *foo*))
X(defmeth (foo :after) ((x bar)) (push '(:after bar) *foo*))
X
X(do-test (":before both here and inherited~%~
X :after both here and inherited~%~
X primary from here"
X :clear nil)
X (let ((*foo* ()))
X (and (eq (foo (make 'bar)) 'bar)
X (equal (reverse *foo*)
X '((:before bar) (:before foo) bar (:after foo) (:after bar))))))
X
X(defmeth foo ((x baz)) (push 'baz *foo*) 'baz)
X
X(do-test ("2 :before and 2 :after inherited, primary from here" :clear nil)
X (let ((*foo* ()))
X (and (eq (foo (make 'baz)) 'baz)
X (equal (reverse *foo*)
X '((:before bar) (:before foo) baz (:after foo) (:after bar))))))
X
X
X(do-test "setting up for :list method combination test"
X (make-specializable 'foo :arglist '(x) :method-combination-type :list)
X
X (ndefstruct (foo (:class class)))
X (ndefstruct (bar (:class class) (:include (foo))))
X (ndefstruct (baz (:class class) (:include (bar)))))
X
X(defmeth foo ((x foo)) 'foo)
X
X(do-test ("single method, :list combined, from here" :clear nil)
X (equal (foo (make 'foo)) '(foo)))
X
X(defmeth foo ((x bar)) 'bar)
X(do-test ("method from here and one inherited, :list combined" :clear nil)
X (equal (foo (make 'bar)) '(foo bar)))
X
X(defmeth foo ((x baz)) 'baz)
X
X(do-test ("method from here, two inherited, :list combined" :clear nil)
X (equal (foo (make 'baz)) '(foo bar baz)))
X
X(do-test ("make sure that more specific methods aren't in my combined method"
X :clear nil)
X (and (equal (foo (make 'foo)) '(foo))
X (equal (foo (make 'bar)) '(foo bar))
X (equal (foo (make 'baz)) '(foo bar baz))))
X
X)
X
X ;;
X;;;;;; things that bug fixes prompted.
X ;;
X
X
X(do-test "with inside of lexical closures"
X ;; 6/20/86
X ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant. It
X ;; didn't walk inside there. Its sort of surprising this didn't get
X ;; caught sooner.
X
X (ndefstruct (foo (:class class))
X (x 0)
X (y 0))
X
X (defun foo (fn foos)
X (and foos (cons (funcall fn (car foos)) (foo fn (cdr foos)))))
X
X (defun bar ()
X (let ((the-foo (make 'foo :x 0 :y 3)))
X (with ((the-foo () foo))
X (foo #'(lambda (foo) (incf x) (decf y))
X (make-list 3)))))
X
X (equal (bar) '(2 1 0)))
X
X(do-test "redefinition of default method has proper effect"
X ;; 5/26/86
X ;; This was caused because the hair for trying to avoid making a
X ;; new discriminating function didn't know that changing the default
X ;; method was a reason to make a new discriminating function. Fixed
X ;; by always making a new discriminating function when a method is
X ;; added or removed. The template stuff should keep this from being
X ;; expensive.
X
X (defmeth foo ((x class)) 'class)
X (defmeth foo (x) 'default)
X (defmeth foo (x) 'new-default)
X
X (eq (foo nil) 'new-default))
X
X
X(do-test ("extra keywords in init-plist cause an error" :should-error t)
X ;; 5/26/86
X ;; Remember that Common-Lisp defstruct signals errors if there are
X ;; extra keywords in the &rest argument to make-foo.
X
X (ndefstruct (foo (:class class)) a b c)
X
X (make 'foo :d 3))
X
X(do-test "run-super with T specifier for first arg"
X ;; 5/29/86
X ;; This was caused because run-super-internal didn't know about the
X ;; type-specifier T being special. This is yet another reason to
X ;; flush that nonsense about keeping T special.
X
X (defmeth foo (x y) '((t t)))
X
X (defmeth foo (x (y k)) '((t k)))
X
X (defmeth foo (x (y n)) (cons '(t n) (run-super)))
X
X (defmeth foo ((x i) (y k)) '((i k)))
X
X (defmeth foo ((x l) (y n)) (cons '(l n) (run-super)))
X
X
X (and (equal (foo (make 'l) (make 'n)) '((l n) (i k)))
X (equal (foo (make 'i) (make 'k)) '((i k)))
X (equal (foo () (make 'k)) '((t k)))
X (equal (foo () (make 'n)) '((t n) (t k)))))
X
X(do-test "with inside of with scopes correctly"
X ;; 7/07/86
X
X (ndefstruct (foo (:class class)
X (:conc-name nil))
X (foo 1))
X
X (ndefstruct (bar (:class class)
X (:conc-name nil))
X (foo 1))
X
X
X (defmeth foo ((bar bar)) bar ())
X
X (defun bar (x)
X (with* ((x "" foo))
X (list foo (with ((x "" bar)) foo))))
X
X (defun baz (x)
X (with ((x "" bar))
X (list foo (with* ((x "" foo)) foo))))
X
X (and (equal (bar (make 'bar)) '(1 nil))
X (equal (baz (make 'bar)) '(nil 1))
X
X (equal (bar (make 'foo)) '(1 1))
X (equal (baz (make 'foo)) '(1 1))))
X
END_OF_FILE
if test 21892 -ne `wc -c <'test.l'`; then
echo shar: \"'test.l'\" unpacked with wrong size!
fi
# end of 'test.l'
fi
echo shar: End of archive 6 \(of 13\).
cp /dev/null ark6isdone
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