rs@uunet.UU.NET (Rich Salz) (07/31/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 78
Archive-name: comobj.lisp/Part04
#! /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 4 (of 13)."
# Contents: class-slots.l defclass.l fsc-low.l regress.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'class-slots.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'class-slots.l'\"
else
echo shar: Extracting \"'class-slots.l'\" \(14319 characters\)
sed "s/^X//" >'class-slots.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X ;;
X;;;;;; Slot access for the class class.
X ;; get-slot-using-class and friends
X;;; At last the meta-braid is up. The method class-instance-slots exists and there
X;;; is peace in the land. Now we can finish get-slot, put-slot and friends.
X
X(defmacro get-slot-using-class--class (class object slot-name
X dont-call-slot-missing-p default)
X (once-only (slot-name)
X `(let* ((.wrapper.
X (iwmc-class-class-wrapper ,object))
X (.get-slot-offset.
X (class-wrapper-get-slot-offset .wrapper. ,slot-name)))
X (if (eq (class-wrapper-cached-key .wrapper. .get-slot-offset.)
X ,slot-name)
X (get-static-slot--class
X ,object (class-wrapper-cached-val .wrapper. .get-slot-offset.))
X (get-slot-using-class--class-internal
X ,class ,object ,slot-name ,dont-call-slot-missing-p ,default)))))
X
X
X(defmacro put-slot-using-class--class (class object slot-name new-value
X dont-call-slot-missing-p)
X (once-only (slot-name)
X `(let* ((.wrapper. (iwmc-class-class-wrapper ,object))
X (.get-slot-offset. (class-wrapper-get-slot-offset .wrapper. ,slot-name)))
X (if (eq (class-wrapper-cached-key .wrapper. .get-slot-offset.) ,slot-name)
X (setf (get-static-slot--class
X ,object (class-wrapper-cached-val .wrapper. .get-slot-offset.))
X ,new-value)
X (put-slot-using-class--class-internal
X ,class ,object ,slot-name ,new-value ,dont-call-slot-missing-p)))))
X
X(defmacro get-slot--class (object slot-name)
X (once-only (object)
X `(get-slot-using-class--class
X (class-of--class ,object) ,object ,slot-name () ())))
X
X(defmacro put-slot--class (object slot-name new-value)
X (once-only (object)
X `(put-slot-using-class--class
X (class-of--class ,object) ,object ,slot-name ,new-value ())))
X
X(defmeth get-slot-using-class ((class basic-class) object slot-name
X &optional dont-call-slot-missing-p default)
X (get-slot-using-class--class
X class object slot-name dont-call-slot-missing-p default))
X
X(defmeth put-slot-using-class ((class basic-class) object slot-name new-value
X &optional dont-call-slot-missing-p)
X (put-slot-using-class--class
X class object slot-name new-value dont-call-slot-missing-p))
X
X(defmeth remove-dynamic-slot-using-class ((class basic-class)
X object slot-name)
X (ignore class)
X (remove-dynamic-slot--class object slot-name))
X
X;;;
X;;; with-slot-internal--class is macro which makes code which accesses the
X;;; slots of instances with meta-class class more readable. The macro itself
X;;; is kind of dense though. In the following call:
X;;; (WITH-SLOT-INTERNAL--CLASS (CLASS OBJECT SLOT-NAME T)
X;;; (:INSTANCE (INDEX) . instance-case-code)
X;;; (:DYNAMIC (LOC NEWP) . dynamic-case-code)
X;;; (:CLASS (SLOTD) . class-case-code)
X;;; (NIL () . nil-case-code))
X;;; If the slot is found and has allocation:
X;;; :instance instance-case-code is evaluated with INDEX bound to the
X;;; index of the slot.
X;;; :dynamic dynamic-case-code is evaluated with LOC bound to the cons
X;;; whose car holds the value of this dynamic slot, and NEWP
X;;; bound to t if the slot was just created and nil otherwise.
X;;; :class class-case-code is evaluated with slotd bound to the slotd
X;;; of the slot.
X;;; If the slot is not found.
X;;; If createp is t it is created and things proceed as in the allocation
X;;; :dynamic case.
X;;; Otherwise, and if the allocation is nil the nil-case code is evaluated.
X;;;
X(defmacro with-slot-internal--class ((class object slot-name createp)
X &body cases)
X (let ((temp1 (gensym))
X (temp2 (gensym))
X (createp-var (gensym))
X (instance-case (cdr (assq :instance cases)))
X (dynamic-case (cdr (assq :dynamic cases)))
X (class-case (cdr (assq :class cases)))
X (nil-case (cdr (assq nil cases))))
X `(prog (,temp1 ;The Horror! Its a PROG,
X ,temp2 ;but its in a macro so..
X (,createp-var ,createp))
X (cond
X ((setq ,temp1 (slotd-position ,slot-name
X (class-instance-slots ,class)))
X ;; We have the slots position in the instance slots. Convert
X ;; that to the slots index and then cache the index and return
X ;; the result of evaluating the instance-case.
X (setq ,temp1 (%convert-slotd-position-to-slot-index ,temp1))
X (let ((wrapper (validate-class-wrapper ,object)))
X (class-wrapper-cache-cache-entry
X wrapper
X (class-wrapper-get-slot-offset wrapper ,slot-name)
X ,slot-name
X ,temp1))
X (return (let ,(and (car instance-case)
X `((,(caar instance-case) ,temp1)))
X . ,(cdr instance-case))))
X ((setq ,temp1 (slotd-assoc ,slot-name
X (class-non-instance-slots ,class)))
X ;; We have a slotd -- this is some sort of declared slot.
X (ecase (slotd-allocation ,temp1)
X (:class (return
X (let ,(and (car class-case)
X `((,(caar class-case) ,temp1)))
X . ,(cdr class-case))))
X ((:none nil) (go nil-case))
X (:dynamic (setq ,createp-var :dynamic
X ,temp2 (slotd-default ,temp1))))))
X ;; When we get here, either:
X ;; - we didn't find a slot-description for this slot, so try to
X ;; find it in the dynamic slots creating it if createp-var is
X ;; non-null.
X ;; - we found a :dynamic slot-description, createp-var got set
X ;; to :dynamic and we dropped through to here where we try
X ;; to find the slot. If we find it we return the loc. If
X ;; not we create it and initialize it to its default value.
X (multiple-value-setq (,temp1 ,createp-var)
X (dynamic-slot-loc--class ,object ,slot-name ,createp-var))
X (when ,temp1
X (when (and ,createp-var ,temp2)
X (setf (car ,temp1) (eval ,temp2)))
X (let
X (,@(and (caar dynamic-case) `((,(caar dynamic-case) ,temp1)))
X ,@(and (cadar dynamic-case) `((,(cadar dynamic-case)
X ,createp-var))))
X (return . ,(cdr dynamic-case))))
X nil-case
X ;; This slot is either explicitly declared :allocation nil (we
X ;; jumped here by (GO NIL-CASE) or there is no declaration for
X ;; this slot and we didn't find it in the dynamic-slots, we fell
X ;; through from the dynamic lookup above.
X (let ,(and (car nil-case) `((,(caar nil-case) ,temp1)))
X . ,(cdr nil-case)))))
X
X(defun dynamic-slot-loc--class (object slot-name createp)
X (let ((plist (iwmc-class-dynamic-slots object)))
X (or (iterate ((prop on plist by cddr))
X (when (eq (car prop) slot-name) (return (cdr prop))))
X (and createp
X (values (cdr (setf (iwmc-class-dynamic-slots object)
X (list* slot-name () plist)))
X createp)))))
X
X(defun get-slot-using-class--class-internal (class object slot-name
X dont-call-slot-missing-p
X default)
X (with-slot-internal--class (class object slot-name nil)
X (:instance (index) (get-static-slot--class object index))
X (:dynamic (loc newp) (if (eq newp t) (setf (car loc) default) (car loc)))
X (:class (slotd) (slotd-default slotd))
X (nil () (unless dont-call-slot-missing-p
X (slot-missing object slot-name)))))
X
X(defun put-slot-using-class--class-internal (class object slot-name new-value
X dont-call-slot-missing-p)
X (with-slot-internal--class
X (class object slot-name dont-call-slot-missing-p)
X (:instance (index) (setf (get-static-slot--class object index)
X new-value))
X (:dynamic (loc) (setf (car loc) new-value))
X (:class (slotd) (setf (slotd-default slotd) new-value))
X (nil () (unless dont-call-slot-missing-p
X (slot-missing object slot-name)))))
X
X(defun all-slots (object)
X (all-slots-using-class (class-of object) object))
X
X(defmeth all-slots-using-class ((class basic-class) object)
X (append (iterate ((slotd in (class-instance-slots class)))
X (collect (slotd-name slotd))
X (collect (get-slot--class object (slotd-name slotd))))
X (iwmc-class-dynamic-slots object)))
X
X(defmeth remove-dynamic-slot-using-class ((class basic-class) object
X slot-name)
X (ignore class)
X (remove-dynamic-slot--class object slot-name))
X
X(defun slot-allocation (object slot-name)
X (slot-allocation-using-class (class-of object) object slot-name))
X
X(defmeth slot-allocation-using-class ((class basic-class) object slot-name)
X (with-slot-internal--class (class object slot-name nil)
X (:instance () :instance)
X (:dynamic () :dynamic)
X (:class () :class)
X (nil () nil)))
X
X(defun slot-exists-p (object slot-name)
X (let* ((flag "")
X (val
X (get-slot-using-class (class-of object) object slot-name t flag)))
X (neq val flag)))
X
X(defmeth slot-missing (object slot-name)
X (error "The slot: ~S is missing from the object: ~S" slot-name object))
X
X(defmacro typep--class (iwmc-class type)
X `(not (null (memq (class-named ,type ())
X (class-class-precedence-list
X (class-wrapper-class
X (iwmc-class-class-wrapper ,iwmc-class)))))))
X
X(defmacro type-of--class (iwmc-class)
X `(class-name
X (class-wrapper-wrapped-class (iwmc-class-class-wrapper ,iwmc-class))))
X
X(defun subclassp (class1 class2)
X (or (classp class1) (setq class1 (class-named class1)))
X (or (classp class2) (setq class2 (class-named class2)))
X (memq class2 (class-class-precedence-list class1)))
X
X(defun sub-class-p (x class)
X (if (symbolp class) (setq class (class-named class)))
X (not (null (memq class (class-class-precedence-list (class-of x))))))
X
X
X(defmeth class-has-instances-p ((class basic-class))
X (class-wrapper class))
X
X(defmeth make-instance ((class basic-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 (let ((instance (%allocate-instance--class
X (class-no-of-instance-slots class))))
X (setf (iwmc-class-class-wrapper instance) class-wrapper)
X instance)
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(defun make (class &rest init-plist)
X (when (symbolp class) (setq class (class-named class)))
X (let ((object (make-instance class)))
X (initialize object init-plist)
X object))
X
X(defmeth initialize ((object object) init-plist)
X (initialize-from-defaults object)
X (initialize-from-init-plist object init-plist))
X
X(defmeth initialize-from-defaults ((self object))
X (iterate ((slotd in (class-instance-slots (class-of self))))
X (setf (get-slot self (slotd-name slotd)) (eval (slotd-default slotd)))))
X
X(defmeth initialize-from-init-plist ((self object) init-plist)
X (when init-plist
X (let* ((class (class-of self))
X (instance-slots (class-instance-slots class))
X (non-instance-slots (class-non-instance-slots class)))
X (flet ((find-slotd (keyword)
X (flet ((find-internal (slotds)
X (dolist (slotd slotds)
X (when (eq (slotd-keyword slotd) keyword)
X (return slotd)))))
X (or (find-internal instance-slots)
X (find-internal non-instance-slots)))))
X (do* ((keyword-loc init-plist (cdr value-loc))
X (value-loc (cdr keyword-loc) (cdr keyword-loc))
X (slotd () ())
X (allow-other-keys-p () allow-other-keys-p))
X (())
X (flet ((allow-other-keywords-p ()
X (when (null allow-other-keys-p)
X (setq allow-other-keys-p
X (do ((loc keyword-loc (cddr loc)))
X ((null loc) 0)
X (when (eq (car loc) ':allow-other-keys)
X (if (cadr loc) 1 0)))))
X (if (= allow-other-keys-p 1) t nil)))
X (cond ((null keyword-loc) (return nil))
X ((eq (car keyword-loc) :allow-other-keys)
X (setq allow-other-keys-p
X (if (cadr keyword-loc) 1 0)))
X ((null value-loc)
X (error "No value supplied for the init-keyword ~S."
X (car keyword-loc)))
X ((null (setq slotd (find-slotd (car keyword-loc))))
X (unless (allow-other-keywords-p)
X (error "~S is not a valid keyword in the init-plist."
X (car keyword-loc))))
X (t
X (setf (get-slot self (slotd-name slotd))
X (car value-loc))))))))))
X
X
X
X(defmeth class-default-includes ((class basic-class))
X (ignore class)
X (list 'object))
X
END_OF_FILE
if test 14319 -ne `wc -c <'class-slots.l'`; then
echo shar: \"'class-slots.l'\" unpacked with wrong size!
fi
# end of 'class-slots.l'
fi
if test -f 'defclass.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'defclass.l'\"
else
echo shar: Extracting \"'defclass.l'\" \(13381 characters\)
sed "s/^X//" >'defclass.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X
X(in-package 'pcl)
X
X
X ;;
X;;;;;; New New Minglewood Blues
X ;; the new "legendary macro itself"
X;;;
X(defmacro ndefstruct (name-and-options &rest slot-descriptions)
X ;;
X ;; The defstruct macro does some pre-processing on name-and-options and
X ;; slot-descriptions before it passes them on to expand-defstruct. It
X ;; also pulls out the documentation string (if there is one) and passes
X ;; it to expand defstruct as a separate argument.
X ;;
X ;; The main reason for doing this is that it imposes more uniformity in
X ;; the syntax of defstructs for different metaclasses, and it puts some
X ;; useful error checking for that syntax in one central place.
X ;;
X (let ((documentation (and (stringp (car slot-descriptions))
X (pop slot-descriptions))))
X (or (listp name-and-options) (setq name-and-options (list name-and-options)))
X (setq slot-descriptions
X (iterate ((sd in slot-descriptions))
X (collect
X (cond ((not (listp sd)) (list sd nil))
X (t (unless (evenp (length sd))
X (error "While parsing the defstruct ~S, the slot-description: ~S~%~
X has an odd number of elements."
X (car name-and-options) sd))
X sd)))))
X (keyword-parse ((class 'structure))
X (cdr name-and-options)
X (let ((class-object (class-named class t)))
X (if class-object
X (expand-defstruct
X (class-prototype class-object) name-and-options documentation slot-descriptions)
X (error "The argument to defstruct's :class option was ~S;~%~
X but there is no class named ~S."
X class class))))))
X
X(defmacro defclass (name includes slots &rest options)
X (keyword-parse ((metaclass 'class)) options
X (let ((metaclass-object (class-named metaclass t)))
X (or metaclass-object
X (error "The class option to defclass was ~S,~%~
X but there is no class with that name."
X metaclass))
X (or (subclassp metaclass-object 'class)
X (error
X "The class specified in the :metaclass option to defclass, ~S,~%~
X is not a subclass of the class class."
X metaclass))
X (expand-defclass metaclass-object name includes slots options))))
X
X(defmethod expand-defclass ((metaclass class) name includes slots options)
X (keyword-parse ((accessor-prefix nil accessor-prefix-p)) options
X (when (and accessor-prefix-p
X (not (or (null accessor-prefix)
X (symbolp accessor-prefix))))
X (error "The :accessor-prefix option, when specified must have either~%~
X have an argument which is a symbol, or no argument at all."))
X (setq slots (iterate ((slot in slots))
X (collect
X (cond ((and (listp slot)
X (cddr slot))
X (let ((initform
X (if (memq :initform (cdr slot))
X (cadr (memq :initform (cdr slot)))
X *slotd-unsupplied*)))
X (list* (car slot) initform (cdr slot))))
X ((listp slot) slot)
X (t (list slot *slotd-unsupplied*))))))
X `(ndefstruct (,name (:class ,(class-name metaclass))
X (:include ,includes)
X ,@(and accessor-prefix-p
X `((:conc-name ,accessor-prefix)))
X (:generate-accessors ,(and accessor-prefix-p
X 'method))
X ,@options)
X ,@slots)))
X
X(defmeth expand-defstruct ((class basic-class) name-and-options documentation slot-descriptions)
X (ignore documentation)
X (let* ((name (car name-and-options))
X (ds-options (parse-defstruct-options class name (cdr name-and-options)))
X (slotds (parse-slot-descriptions class ds-options slot-descriptions)))
X `(progn
X (eval-when (load eval)
X (record-definition ',name 'ndefstruct))
X ;; Start by calling add-named-class which will actually define the new
X ;; class, updating the class lattice obsoleting old instances etc.
X (eval-when (compile load eval)
X (add-named-class
X (class-prototype (class-named ',(class-name (class-of class))))
X ',name
X ',(or (ds-options-includes ds-options)
X (class-default-includes class))
X ',slotds
X ',ds-options))
X ,@(expand-defstruct-make-definitions class name ds-options slotds)
X ',name)))
X
X(defmeth expand-defstruct-make-definitions ((class basic-class)
X name ds-options slotds)
X (append (make-accessor-definitions class name ds-options slotds)
X (make-constructor-definitions class name ds-options slotds)
X (make-copier-definitions class name ds-options slotds)
X (make-predicate-definitions class name ds-options slotds)
X (make-print-function-definitions class name ds-options slotds)))
X
X(define-function-template iwmc-class-accessor () '(slot-name)
X `(function (lambda (iwmc-class) (get-slot--class iwmc-class slot-name))))
X
X(eval-when (load)
X (pre-make-templated-function-constructor iwmc-class-accessor))
X
X(define-function-template iwmc-class-accessor-setf (read-only-p) '(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--class iwmc-class slot-name new-value)))))
X
X
X(eval-when (load)
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 class) slotd)
X (funcall (get-templated-function-constructor 'iwmc-class-accessor)
X (slotd-name slotd)))
X
X(defmethod make-iwmc-class-accessor-setf ((ignore class) slotd)
X (funcall
X (get-templated-function-constructor 'iwmc-class-accessor-setf
X (slotd-read-only slotd))
X (slotd-name slotd)))
X
X(defun add-named-method-early (discriminator-name
X arglist
X argument-specifiers
X function)
X (if (null *real-methods-exist-p*)
X (unless (memq discriminator-name *protected-early-selectors*)
X (setf (symbol-function discriminator-name) function))
X (add-named-method (class-prototype (class-named 'discriminator))
X (class-prototype (class-named 'method))
X discriminator-name
X arglist
X argument-specifiers
X ()
X function)))
X
X(defmeth make-accessor-definitions
X ((class basic-class) name ds-options slotds)
X (ignore class ds-options)
X (cons `(do-accessor-definitions ',name ',slotds)
X (iterate ((slotd in slotds))
X (let ((accessor (slotd-accessor slotd))
X setf-discriminator-name)
X (when accessor
X (setq setf-discriminator-name
X (make-setf-discriminator-name accessor))
X (compile-time-define 'defun accessor)
X (compile-time-define 'defun setf-discriminator-name)
X (compile-time-define 'defsetf accessor setf-discriminator-name)
X (collect `(defsetf ,accessor ,setf-discriminator-name)))))))
X
X(defun do-accessor-definitions (name slotds)
X (let ((class (class-named name))
X (accessor nil)
X (setf-discriminator-name nil))
X (dolist (slotd slotds)
X (when (setq accessor (slotd-accessor slotd))
X (setq setf-discriminator-name
X (make-setf-discriminator-name accessor))
X (unless *real-methods-exist-p*
X (record-early-discriminator accessor)
X (record-early-discriminator setf-discriminator-name))
X (add-named-method-early accessor
X `(,name)
X `(,class)
X (or (slotd-get-function slotd)
X (make-iwmc-class-accessor class slotd)))
X (add-named-method-early setf-discriminator-name
X `(,name new-value)
X `(,class)
X (or (slotd-put-function slotd)
X (make-iwmc-class-accessor-setf class
X slotd)))))
X (unless *real-methods-exist-p*
X (record-early-method-fixup
X `(let ((*real-methods-exist-p* t))
X (do-accessor-definitions ',name ',slotds))))))
X
X(defmeth make-constructor-definitions ((class basic-class) name ds-options slotds)
X (ignore class slotds)
X (let ((constructors (ds-options-constructors ds-options)))
X (iterate ((constructor in constructors))
X (when (car constructor)
X (collect
X (if (cdr constructor)
X `(defun ,(car constructor) ,(cadr constructor)
X (make ',name ,@(iterate ((slot-name in (cadr constructor)))
X (unless (memq slot-name
X '(&optional &rest &aux))
X (collect `',(make-keyword slot-name))
X (collect slot-name)))))
X `(defun ,(car constructor) (&rest init-plist)
X (apply #'make ',name init-plist))))))))
X
X(define-function-template copier--class () ()
X `(function
X (lambda (iwmc-class)
X (let* ((class (class-of iwmc-class))
X (to (make-instance (class-of iwmc-class)))
X (from-static (iwmc-class-static-slots iwmc-class))
X (to-static (iwmc-class-static-slots to))
X (static-slots (class-instance-slots class)))
X (do ((i 0 (+ i 1))
X (index nil index)
X (x static-slots (cdr x)))
X ((null x))
X (setq index (%convert-slotd-position-to-slot-index i))
X (setf (%static-slot-storage-get-slot--class to-static index)
X (%static-slot-storage-get-slot--class from-static index)))
X (setf (iwmc-class-dynamic-slots to)
X (copy-list (iwmc-class-dynamic-slots iwmc-class)))
X to))))
X
X(eval-when (load)
X (pre-make-templated-function-constructor copier--class))
X
X(defmeth make-copier-definitions ((class basic-class) name ds-options slotds)
X (ignore class slotds)
X (let ((copier (ds-options-copier ds-options)))
X (when copier
X (compile-time-define 'defun copier)
X `((do-copier-definition ',name ',copier)))))
X
X(defun do-copier-definition (class-name copier-name)
X (unless *real-methods-exist-p*
X (record-early-discriminator copier-name)
X (record-early-method-fixup
X `(let ((*real-methods-exist-p* t))
X (do-copier-definition ',class-name ',copier-name))))
X (add-named-method-early copier-name
X `(,class-name)
X `(,(class-named class-name))
X (funcall
X (get-templated-function-constructor
X 'copier--class))))
X
X(define-function-template iwmc-class-predicate () '(class-name)
X `(function (lambda (x)
X (and (iwmc-class-p x)
X (typep--class x class-name)))))
X
X(eval-when (load)
X (pre-make-templated-function-constructor iwmc-class-predicate))
X
X(defmeth make-predicate-definitions ((class basic-class)
X name ds-options slotds)
X (ignore class slotds)
X (let ((predicate (or (ds-options-predicate ds-options)
X (make-symbol (string-append name " Predicate")))))
X (compile-time-define 'defun predicate)
X `((do-predicate-definition ',name ',predicate)
X (deftype ,name () '(satisfies ,predicate)))))
X
X(defun do-predicate-definition (class-name predicate-name)
X (setf (symbol-function predicate-name)
X (funcall (get-templated-function-constructor 'iwmc-class-predicate)
X class-name)))
X
X(defun make-print-function-definitions
X (class name ds-options slotds)
X (ignore class slotds)
X (let* ((print-function (ds-options-print-function ds-options))
X (arglist ())
X (defun ())
X (defun-name ()))
X (when print-function
X (cond ((symbolp print-function)
X (setq arglist '(object stream depth)))
X ((and (listp print-function) (eq (car print-function) 'lambda))
X (setq arglist (cadr print-function)
X defun-name (intern
X (string-append (symbol-name name)
X " Print Function"))
X defun `(defun ,defun-name ,arglist
X ,@(cddr print-function))
X print-function defun-name))
X (t
X (error "Internal error, make-print-function-definitions can't~%~
X understand the contents of the print-function slot of~%~
X the ds-options.")))
X `(,defun
X (do-print-function-definitions ',name ',arglist ',print-function)))))
X
X(defun do-print-function-definitions (name arglist print-function)
X (unless *real-methods-exist-p*
X (record-early-method-fixup
X `(let ((*real-methods-exist-p* t))
X (do-print-function-definitions ',name ',arglist ',print-function))))
X (add-named-method-early 'print-instance
X arglist
X (list (class-named name))
X print-function))
X
END_OF_FILE
if test 13381 -ne `wc -c <'defclass.l'`; then
echo shar: \"'defclass.l'\" unpacked with wrong size!
fi
# end of 'defclass.l'
fi
if test -f 'fsc-low.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'fsc-low.l'\"
else
echo shar: Extracting \"'fsc-low.l'\" \(13302 characters\)
sed "s/^X//" >'fsc-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
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
XIn other words, it is too slow 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(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
END_OF_FILE
if test 13302 -ne `wc -c <'fsc-low.l'`; then
echo shar: \"'fsc-low.l'\" unpacked with wrong size!
fi
# end of 'fsc-low.l'
fi
if test -f 'regress.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'regress.l'\"
else
echo shar: Extracting \"'regress.l'\" \(17554 characters\)
sed "s/^X//" >'regress.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: regress.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: Regression Tests for COOL.
X; Author: James Kempf, HP/DCC
X; Created: 24-Feb-87
X; Modified: 25-Feb-87 08:45:24 (James Kempf)
X; Language: Lisp
X; Package: TEST
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X
X(provide "co-regress")
X
X(in-package 'test)
X
X(require "co")
X
X(require "co-test")
X
X(use-package 'co)
X
X
X
X;;Need the test macro from PCL
X
X(import
X '(
X pcl:do-test
X )
X)
X
X;;This is needed to be sure the Lisp functions are
X;; correctly redefined
X
X(import-specialized-functions)
X
X(do-test ("define-type" :return-value T)
X (
X (define-type car
X (:var name :gettable)
X (:var top-speed :settable)
X (:var turbo-p :initable)
X :all-initable
X )
X car
X )
X ( (instancep 'car) NIL)
X ( (typep 'car 'instance) NIL)
X)
X
X(do-test "make-instance"
X (instancep (setq c (make-instance 'car :name 'porsche)))
X (=> c :typep 'car)
X)
X
X(do-test ("make-instance error cases" :should-error T)
X (make-instance NIL)
X (make-instance (gensym))
X (make-instance 'not-a-type)
X (make-instance 'float)
X (make-instance 'car :not-initkw 314159)
X)
X
X(do-test ("make-instance syntax" :should-error T)
X (make-instance)
X (make-instance '(a b))
X (make-instance 'car :boink)
X (make-instance 'car :name)
X (make-instance 'car 'truck 'van)
X)
X
X
X
X(do-test ("the right methods there?" :return-value T)
X ((supports-operation-p c :name) T)
X ((supports-operation-p c :set-name) NIL)
X ((supports-operation-p c :set-top-speed) T)
X ((supports-operation-p c :top-speed) T)
X ((supports-operation-p c :turbo-p) NIL)
X ((supports-operation-p c :set-turbo-p) NIL)
X ((supports-operation-p c :not-a-method) NIL)
X ((supports-operation-p c 'describe) NIL)
X ((supports-operation-p c 'init) NIL)
X ((supports-operation-p c 'channelprin) NIL)
X ((supports-operation-p c 'init) NIL)
X ((supports-operation-p c :describe) T)
X ((supports-operation-p c :print) T)
X ((supports-operation-p c :initialize) T)
X ((supports-operation-p c :initialize-variables) T)
X ((supports-operation-p c :init) T)
X ((supports-operation-p c :eql) T)
X ((supports-operation-p c :equal) T)
X ((supports-operation-p c :equalp) T)
X ((supports-operation-p c :typep) T)
X ((supports-operation-p c :copy) T)
X ((supports-operation-p c :copy-state) T)
X ((supports-operation-p c :copy-instance) T)
X)
X
X
X(do-test ("typep" :return-value T)
X ((typep c 'car) T)
X ((typep c 'instance) T)
X ((typep c t) T)
X ((typep c 'integer) NIL)
X ((typep '(frog) 'car) NIL)
X ((type-of c) car)
X)
X
X(do-test ("rename-type" :return-value T)
X ((rename-type 'car 'auto) auto)
X ((typep c 'car) NIL)
X ((typep c 'auto) T)
X ((type-of c) auto)
X ((undefine-type 'car) NIL)
X ((typep c 'auto) T)
X ((typep c 'auto) T)
X)
X
X(do-test ("rename-type error cases" :should-error T)
X (rename-type 'float 'pneuname)
X (rename-type 'auto 'auto)
X (rename-type 'car 'auto)
X)
X
X(do-test ("define-method error case" :should-error T)
X (eval '(define-method (car :flat) ()))
X)
X
X(do-test ("now that type car is renamed" :return-value T)
X ((=> c :name) porsche)
X ((=> c :set-top-speed 157) 157)
X ((=> c :top-speed) 157)
X ((define-method (auto :sportscar-p) () (> top-speed 130)) (auto :sportscar-p))
X ((=> c :sportscar-p) T)
X)
X
X
X(do-test ("define a new type car" :return-value T)
X ((define-type car (:var railroad) (:var type) :all-settable) car)
X)
X
X(do-test ("now that we have a new type car" :return-value T)
X ((=> c :name) porsche)
X ((=> c :set-top-speed 157) 157)
X ((=> c :top-speed) 157)
X ((define-method (auto :sportscar-p) () (> top-speed 130)) (auto :sportscar-p))
X ((=> c :sportscar-p) T)
X ((undefine-type 'car) T)
X)
X
X
X(do-test ("type for rename-type and undefine-type" :return-value T)
X ((define-type other) other)
X)
X
X(do-test ("rename-type syntax" :should-error T)
X (rename-type 'auto NIL)
X (rename-type 'other 'auto)
X (rename-type NIL 'auto)
X (rename-type '(a) 'other)
X (rename-type 'other '(a b))
X (rename-type)
X (rename-type 'auto)
X)
X
X
X(do-test ("undefine-type" :return-value T)
X ((undefine-type 'auto) T)
X ((null (type-of c)) NIL)
X ((eq (type-of c) T) NIL)
X ((member (type-of c) '(auto car)) NIL)
X ((symbolp (type-of c)) T)
X ((undefine-type 'auto) NIL)
X ((undefine-type 'other) T)
X ((undefine-type 'float) NIL)
X)
X
X
X(do-test ("let's use those undefined types" :should-error T)
X (make-instance 'auto)
X (eval '(define-method (auto :burp) () T))
X (=> c :name)
X)
X
X(do-test ("send? to object with undefined type" :return-value T)
X
X ((send? c :name) NIL)
X
X)
X
X
X(do-test ("undefine-type syntax" :should-error T)
X (undefine-type '(a big dog))
X)
X
X(do-test ("define-type syntax" :should-error T)
X (eval '(define-type))
X (eval '(define-type (a list)))
X (eval '(define-type actress ann-margret))
X (eval '(define-type actress (ann-margret)))
X (eval '(define-type actress (:var)))
X (eval '(define-type actress (:var :var)))
X (eval '(define-type actress (:var :a-keyword)))
X (eval '(define-type actress (:var twin) (:var not-twin) (:var twin)))
X (eval '(define-type actress (:var ann-margret ())))
X (eval '(define-type actress (:var ann-margret dyan-cannon)))
X (eval '(define-type actress (:var ann-margret (:not-option lips))))
X (eval '(define-type actress (:var ann-margret (:init))))
X (eval '(define-type actress (:var ann-margret (:init 'one 'two))))
X (eval '(define-type actress (:var ann-margret :not-an-option)))
X (eval '(define-type actress (:var ann-margret (:gettable))))
X)
X
X(do-test ("various define-types that should work" :return-value T)
X ((undefine-type 'actress) NIL)
X ((undefine-type 'self) NIL)
X)
X
X(do-test ("define an actress" :return-value T)
X ((define-type actress (:var actress)) actress)
X)
X
X(do-test ("check self" :return-value T)
X ((eval '(define-type self (:var me :settable (:init 'hit)))) self)
X ((let ((self (make-instance 'self))) (=> self :me)) hit)
X
X)
X
X(do-test "get rid of self"
X (undefine-type 'self)
X)
X
X(do-test ("initial funny business setup" :return-value T)
X ((define-type oedipus-rex) oedipus-rex)
X ((define-type laius (:inherit-from oedipus-rex)) laius)
X ((define-type jocasta (:inherit-from laius)) jocasta)
X)
X
X(do-test ("check for inheritence funny business" :should-error T)
X (eval '(define-type oedipus-rex (:inherit-from oedipus-rex)))
X (eval '(define-type oedipus-rex (:inherit-from laius)))
X (eval '(define-type oedipus-rex (:inherit-from jocasta)))
X)
X
X(do-test ("clean up after funny business check" :return-value T)
X ((undefine-type 'jocasta) T)
X ((undefine-type 'laius) T)
X ((undefine-type 'oedipus-rex) T)
X)
X
X(do-test ("get rid of it" :return-value T)
X ((undefine-type 'animal) NIL)
X)
X
X(do-test ("general animal test" :return-value T)
X ((list (makunbound 'name)
X (makunbound 'num-legs)
X (makunbound 'color)
X (makunbound 'lives-where)) (name num-legs color lives-where))
X ((define-type animal
X (:var name :gettable)
X (:var num-legs :gettable)
X (:var color (:init 'brown))
X (:var lives-where (:init 'on-ground) :settable)
X :all-initable
X ) animal)
X ((instancep (setq an-animal (make-instance 'animal :name 'horse :num-legs 4))) T)
X ((type-of an-animal) animal)
X ((typep an-animal 'animal) T)
X ((supports-operation-p an-animal :name) T)
X ((supports-operation-p an-animal :set-name) NIL)
X ((supports-operation-p an-animal :num-legs) T)
X ((supports-operation-p an-animal :set-num-legs) NIL)
X ((supports-operation-p an-animal :color) NIL)
X ((supports-operation-p an-animal :set-color) NIL)
X ((supports-operation-p an-animal :lives-where) T)
X ((supports-operation-p an-animal :set-lives-where) T)
X ((=> an-animal :num-legs) 4)
X ((=> an-animal :name) horse)
X ((=> an-animal :lives-where) on-ground)
X ((=> an-animal :set-lives-where 'ocean) ocean)
X ((=> an-animal :lives-where) ocean)
X)
X
X(do-test ("=> error case to animal" :should-error T)
X (setq no-animal (make-instance 'animal :rocky 'bullwinkle))
X name
X (=> an-animal :set-name 'new-name)
X name
X num-legs
X (=> an-animal :set-num-legs)
X (=> an-animal :set-num-legs 8)
X (=> an-animal :color)
X color
X (=> an-animal :set-color 'red)
X lives-where
X (=> an-animal :not-a-method)
X (=> an-animal :set-lives-where)
X)
X
X
X(do-test ("=> syntax error check" :should-error T)
X (eval '(=>))
X (eval '(=> an-animal))
X (=> animal :lives-where)
X (=> an-animal NIL)
X (=> NIL :lives-where)
X (=> an-animal :lives-where 'extra-parm)
X)
X
X
X
X(do-test ("supports-operation-p syntax" :should-error T)
X (supports-operation-p animal :lives-where)
X)
X
X(do-test ("supports-operation-p syntax" :return-value T)
X ((supports-operation-p an-animal NIL) NIL)
X ((supports-operation-p NIL :lives-where) NIL)
X)
X
X
X(do-test ("instancep syntax" :return-value T)
X ((instancep 'float) NIL)
X ((instancep an-animal) T)
X)
X
X
X
X(do-test ("send? to animal" :return-value T)
X ((send? an-animal :name) horse)
X ((send? an-animal :set-name 'new-name) NIL)
X ((send? an-animal :num-legs) 4)
X ((send? an-animal :set-num-legs) NIL)
X ((send? an-animal :set-num-legs 8) NIL)
X ((send? an-animal :color) NIL)
X ((send? an-animal :set-color 'red) NIL)
X ((send? an-animal :lives-where) ocean)
X ((send? an-animal :not-a-method) NIL)
X ((send? an-animal :set-lives-where 'mars) mars)
X ((send? an-animal :lives-where) mars)
X ((send? an-animal NIL) NIL)
X ((send? NIL :lives-where) NIL)
X)
X
X
X(do-test ("send? syntax and error case" :should-error T)
X (send? an-animal :set-lives-where)
X (eval '(send?))
X (eval '(send? an-animal))
X (send? animal :lives-where)
X (send? an-animal :lives-where 'extra-parm)
X)
X
X
X
X(do-test ("define-method in general" :return-value T)
X ((define-method (animal :num-legs) ()
X num-legs) (animal :num-legs))
X ((define-method (animal :num-legs) ()
X num-legs) (animal :num-legs))
X ((define-method (animal :set-num-legs) (new-num-legs)
X (setq num-legs new-num-legs))
X (animal :set-num-legs))
X ((=> an-animal :num-legs) 4)
X ((=> an-animal :num-legs) 4)
X ((=> an-animal :set-num-legs 2) 2)
X ((=> an-animal :num-legs) 2)
X ((define-method (animal :doc) () "doctari" "veterinarian") (animal :doc))
X ((define-method (animal :quote-two) 'train (list quote train)) (animal :quote-two))
X)
X
X
X(do-test ("define-method syntax" :should-error T)
X (eval '(define-method (float :nines) () ))
X (=> an-animal :set-num-legs)
X (=> an-animal :set-num-legs 1 'and 'a 2)
X (eval '(define-method))
X (eval '(define-method 'frog))
X (eval '(define-method (corn mash)))
X (eval '(define-method (animal mash) bleach))
X)
X
X
X(do-test ("undefine-method" :return-value T)
X ((=> (make-instance 'animal) :doc) "veterinarian")
X ((undefine-method 'animal 'not-a-method) NIL)
X ((undefine-method 'animal '(a)) NIL)
X ((undefine-method 'animal :quote-two) T)
X ((undefine-method 'animal :quote-two) NIL)
X ((=> an-animal :doc) "veterinarian")
X ((undefine-method 'animal :doc) T)
X)
X
X(do-test ("undefine-method error cases" :should-error T)
X (=> an-animal :doc)
X (undefine-method '(a) :quote-two)
X (eval '(undefine-method))
X (undefine-method 'not-a-type :quote-two)
X (undefine-method 'integer :quote-two)
X)
X
X
X(do-test ("undefine bird" :return-value T)
X ((undefine-type 'bird) NIL)
X)
X
X(do-test ("define bird type" :return-value T)
X ((define-type bird
X (:inherit-from animal
X :init-keywords
X (:methods :name :num-legs :set-num-legs
X :lives-where :set-lives-where
X )
X )
X (:var aquatic-p (:init NIL))
X :all-initable
X :all-settable
X ) bird)
X)
X
X
X(do-test ("make bird instances" :return-value T)
X ((instancep (setf ibis
X (make-instance 'bird :name 'ibis :num-legs 2 :aquatic-p T))) T)
X ((=> ibis :name) ibis)
X ((=> ibis :num-legs) 2)
X ((=> ibis :aquatic-p) T)
X ((=> ibis :lives-where) on-ground)
X)
X
X
X(do-test ("make-instance error cases" :should-error T)
X (make-instance 'bird :num-legs)
X (make-instance 'bird :not-init-keyword 89)
X (=> ibis :color)
X)
X
X
X(do-test ("undefine horse" :return-value T)
X ((undefine-type 'horse) NIL)
X)
X
X(do-test ("define horse type" :return-value T)
X
X ((define-type horse
X (:inherit-from animal
X :init-keywords
X (:methods :except :num-legs :set-num-legs
X )
X )
X (:var races-won (:init NIL) :settable)
X ) horse)
X)
X
X
X(do-test ("make horse instances" :return-value T)
X ((instancep (setf wildfire
X (make-instance 'horse :name 'wildfire))) T)
X ((=> wildfire :name) wildfire)
X ((=> wildfire :lives-where) on-ground)
X)
X
X(do-test ("make horse instance error cases" :should-error T)
X (=> wildfire :num-legs)
X (=> wildfire :color)
X (=> wildfire :aquatic-p)
X (make-instance 'horse :not-init-keyword 89)
X (make-instance 'horse :name)
X)
X
X
X(do-test ("call method on horse" :return-value T)
X ((define-method (horse horses-name) () (call-method (animal :name)))
X (horse horses-name))
X ((=> wildfire 'horses-name) wildfire)
X ((define-method (horse :num-legs) () (call-method (animal :num-legs)))
X (horse :num-legs))
X ((define-method (horse :set-num-legs) (new-num-legs) (call-method (animal :set-num-legs) new-num-legs))
X (horse :set-num-legs))
X ((=> wildfire :set-num-legs 6) 6)
X ((=> wildfire :num-legs) 6)
X)
X
X
X(do-test ("apply method on horse" :return-value T)
X ((define-method (horse horses-name) () (apply-method (animal :name) ()))
X (horse horses-name))
X ((=> wildfire 'horses-name) wildfire)
X ((define-method (horse :num-legs) () (apply-method (animal :num-legs) ()))
X (horse :num-legs))
X
X ((define-method (horse :set-num-legs) (new-num-legs) (apply-method (animal :set-num-legs) (list new-num-legs)))
X (horse :set-num-legs))
X ((=> wildfire :set-num-legs 6) 6)
X ((=> wildfire :num-legs) 6)
X)
X
X(do-test ("call-method syntax error cases" :should-error T)
X (eval '(call-method (wildfire :name)))
X (eval '(apply-method (horse :name)))
X (eval '(apply-method (horse :name) 'not-a-list))
X (eval '(define-method (horse horses-name) () (apply-method (horse)) ))
X (eval '(define-method (horse horses-name) () (apply-method (horse :name)) ))
X (eval '(define-method (horse horses-name) () (apply-method (horse :name) 'not-a-list) ))
X (eval '(define-method (horse horses-name) () (apply-method (horse :name 'should-not-be-here)) ))
X)
X
X(do-test ("undefine-method part II" :return-value T)
X ((undefine-method 'horse 'unknown-method) NIL)
X ((undefine-method 'horse 'horses-name) T)
X ((undefine-method 'horse 'horses-name) NIL)
X)
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X
END_OF_FILE
if test 17554 -ne `wc -c <'regress.l'`; then
echo shar: \"'regress.l'\" unpacked with wrong size!
fi
# end of 'regress.l'
fi
echo shar: End of archive 4 \(of 13\).
cp /dev/null ark4isdone
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.-whan i