rs@uunet.UU.NET (Rich Salz) (08/04/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 85
Archive-name: comobj.lisp/Part11
#! /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 11 (of 13)."
# Contents: co-dtype.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'co-dtype.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'co-dtype.l'\"
else
echo shar: Extracting \"'co-dtype.l'\" \(36944 characters\)
sed "s/^X//" >'co-dtype.l' <<'END_OF_FILE'
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; File: co-dtype.l
X; RCS: $Revision: 1.1 $
X; SCCS: %A% %G% %U%
X; Description: CommonObjects types.
X; Author: James Kempf
X; Created: March 10, 1987
X; Modified: 12-Mar-87 09:58:43 (James Kempf)
X; Language: Lisp
X; Package: COMMON-OBJECTS
X; Status: Distribution
X;
X; (c) Copyright 1987, HP Labs, all rights reserved.
X;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;
X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved.
X;
X; Use and copying of this software and preparation of derivative works based
X; upon this software are permitted. Any distribution of this software or
X; derivative works must comply with all applicable United States export
X; control laws.
X;
X; This software is made available AS IS, and Hewlett-Packard Corporation makes
X; no warranty about the software, its performance or its conformity to any
X; specification.
X;
X; Suggestions, comments and requests for improvement may be mailed to
X; aiws@hplabs.HP.COM
X
X;;;-*-Mode:LISP; Package:(CO (PCL LISP)); Base:10; Syntax: Common-lisp-*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X
X(in-package 'common-objects :nicknames '(co) :use '(lisp pcl walker))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Define-Type
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;define-type-Define a CommonObjects type
X
X(defmacro define-type (&rest body)
X
X (internal-define-type body)
X
X) ;end define-type
X
X;;internal-define-type-Parse a CommonObjects type definition and
X;; generate code for creating the type.
X
X(defun internal-define-type (body)
X
X (let
X (
X (doc-string NIL) ;;documentation string, if any
X (name NIL) ;;type name
X (parents NIL) ;;list of parents
X (slots NIL) ;;list of instance variables
X (options NIL) ;;options list
X (phonytiv NIL) ;;phony type info vector. Used to
X ;; hold type definition during
X ;; parsing.
X (assignments NIL);;variable initializations
X (settables NIL) ;;settable method names
X (gettables NIL) ;;gettable method names
X (inherited NIL) ;;inherited methods w. parents
X (keywords NIL) ;;keywords for initialization
X (init-key-check ;;T if a check should occur
X NIL
X )
X (dont-define NIL) ;;methods to not define
X )
X
X
X ;;Get name and options
X
X (multiple-value-setq
X (name doc-string options)
X (co-parse-define-type-call (cons 'define-type body)
X name doc-string options
X )
X )
X
X ;;Make a phony type info for use with options parsing code
X
X (setf phonytiv (build-phony-type-info name))
X
X ;;Get variable names, assignments, and other options
X
X (multiple-value-setq
X (slots assignments options)
X (co-process-var-options phonytiv options slots assignments)
X )
X
X ;;Fill in phony type info with option information
X
X (co-parse-options phonytiv slots options)
X
X (setf parents (svref phonytiv $PARENT-TYPES-SLOT))
X
X (setf gettables (svref phonytiv $GETTABLE-VARIABLES-SLOT))
X (setf settables (svref phonytiv $SETTABLE-VARIABLES-SLOT))
X (setf inherited (svref phonytiv $METHODS-TO-INHERIT-SLOT))
X (setf init-key-check
X (not (svref phonytiv $NO-INIT-KEYWORD-CHECK-SLOT))
X )
X (setf dont-define
X (svref phonytiv $METHODS-TO-NOT-DEFINE-SLOT)
X )
X
X ;;Make keywords out of initiable variables and merge with
X ;; keywords
X
X (setf keywords
X (append
X (svref phonytiv $INIT-KEYWORDS-SLOT)
X (mapcar
X #'(lambda (x)
X (intern (symbol-name x) (find-package 'keyword))
X )
X (svref phonytiv $INITABLE-VARIABLES-SLOT)
X )
X )
X
X ) ;setf
X
X ;;All compile-time checking must be done BEFORE the compile-time
X ;; class definition is done, so that errors don't leave
X ;; around a bogus class.
X
X ;;Merge duplicate method names and check for inheritance
X ;; funny business
X
X (merge-duplicates name gettables settables inherited dont-define)
X
X ;;Fully define the class at compile-time, so that
X ;; method definition works. Note that this means that
X ;; any pre-existing definition will be clobbered.
X ;; Compile time definition is needed for
X ;; any other methods which are defined in the same
X ;; file as a type definition. This is necessary because
X ;; the metaobject protocol doesn't distinguish between
X ;; a partially defined type and a fully defined one.
X ;; Compile-time definition is no longer needed for
X ;; definition of inherited, universal, and get/set
X ;; methods, since the metaobject protocol is gone
X ;; around for these, except for the :INITIALIZE-VARIABLES
X ;; method, which is still generated in full.
X
X (fully-define-type name slots parents keywords init-key-check)
X
X ;;Generate code for the class definition. This code
X ;; defines the class at load time and the universal
X ;; methods.
X
X `(progn
X
X ;;This only needs to get done at load time, since
X ;; class definition at compile time (to take
X ;; care of :INITIALIZE-VARIABLES method generation
X ;; and others in the file) is done during the macro
X ;; expansion. Also, it need not get done if the
X ;; definition is being evaluated, since the macro
X ;; has already done in.
X
X (eval-when (load)
X (fully-define-type ',name
X ',slots
X ',parents
X ',keywords
X ',init-key-check
X )
X )
X
X ;;Define the initialization, get/set, and inherited methods.
X
X ;;Variable initialization is handled by generating an
X ;; initialization method. The :INITIALIZE-VARIABLES method
X ;; is the only universal one generated on a type by type basis.
X ;; Since the user can insert anything into the initialization
X ;; forms, the code must go through the full processing
X ;; for method definition, including code walking of
X ;; WITH-SLOTS. This requires that the PCL class be
X ;; defined at compile time.
X
X ,(if (not (member ':initialize-variables dont-define))
X (build-init-vars-method
X name
X (svref phonytiv $INITABLE-VARIABLES-SLOT)
X assignments
X )
X )
X
X ;;Universal methods are no longer defined on a per type
X ;; basis, but rather default methods are defined
X ;; for all CommonObjects types. The user can define
X ;; their own methods which override the default ones,
X ;; but the defaults can't be undefined or renamed.
X ;; Using defaults saves time during type definition.
X
X ;;Inherited methods must be defined
X ;; at compile time, otherwise the CLASS-DIRECT-METHODS
X ;; call in METHOD-ALIST won't find the gettable and
X ;; settable methods during compilation. This is
X ;; also true for gettable and settable methods.
X ;; Note, however, that other methods defined in
X ;; the same file will NOT get inherited, because
X ;; they are not fully defined at compile time.
X ;; This means that users should avoid defining
X ;; parent and child types in the same file.
X ;; In particular, the ADD-METHOD call generated
X ;; by the PCL method generation code only gets
X ;; done at load time, and hence seperately defined
X ;; methods are only returned by CLASS-DIRECT-METHODS
X ;; after loading. The code below will cause the
X ;; (EVAL-WHEN (LOAD) ...) top level forms returned
X ;; by the PCL method code generation to be overridden.
X
X
X ;;Inherited methods
X
X ,@(build-inherited-methods name inherited dont-define parents slots)
X
X ;;Gettables and settables
X
X ,@(build-gs-methods name gettables settables dont-define parents slots)
X
X ',name
X
X ) ;progn
X
X
X ) ;end let
X) ;end internal-define-type
X
X;;fully-define-type-Fully define the CommonObjects type
X
X(defun fully-define-type (name slots parents keywords init-key-check)
X
X (let
X (
X (classprot (class-prototype (class-named 'common-objects-class)))
X )
X
X ;;Check for redefinition incompatibility, if any.
X
X (check-for-redefinition-incompatibility name parents slots)
X
X (add-named-class classprot
X name
X parents
X slots
X NIL
X )
X
X
X ;;Now set the slots for the initialization keywords and
X ;; the check flag
X
X (setf classprot (class-named name))
X (setf (class-init-keywords classprot) keywords)
X (setf (class-init-keywords-check classprot) init-key-check)
X
X ) ;let
X
X) ;end fully-define-type
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Auxillary Type Definition Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;build-phony-type-info-Make a phony type info vector, to hold the
X;; information while the DEFINE-TYPE call is being parsed.
X
X(defun build-phony-type-info (name)
X
X;;Check if the name is OK first
X
X (unless (co-legal-type-or-method-name name)
X (co-deftype-error "legal type names must be symbols and NOT the symbol NIL."
X name
X )
X )
X
X ;;Set the name and origin slots and return
X
X (let
X (
X (phonytiv
X (make-array
X $INFO-NUMBER-OF-SLOTS
X :initial-element NIL
X )
X )
X )
X
X (setf (svref phonytiv $TYPE-NAME-SLOT) name)
X
X phonytiv
X
X ;;Note that we don't check for predefined type info's here
X ;; because that should (eventually!) be handled by
X ;; the CommonLoops kernel
X
X ) ;end let
X
X) ;end build-phony-type-info
X
X;;check-for-redefinition-incompatibility-Check to see if redefining
X;; will cause an incompatible change
X
X(defun check-for-redefinition-incompatibility (name newparents newslots)
X
X (let*
X (
X (oldclass (class-named name T))
X )
X
X
X ;;If no class object, then this is new
X
X (when oldclass
X
X ;;Check instance variable incompatibility
X
X (if (not (slots-compatible-p newslots (class-user-visible-slots oldclass)))
X (co-deftype-error
X "please rename, since changing instance variables is incompatible.~%"
X name
X )
X )
X
X ;;Check for parent incompatibility
X
X (if (not
X (slots-compatible-p
X newparents
X (class-local-super-names oldclass)
X )
X )
X (co-deftype-error
X "please rename, since changing parents is incompatible.~%"
X name
X )
X )
X
X ) ;when
X
X ) ;let
X
X) ;end check-for-redefinition-incompatibility
X
X;;slots-compatible-p-Check if the number and ordering
X;; of the slots in the old and new lists is the same
X
X(defun slots-compatible-p (newslots oldslots)
X
X ;;Check that number of slots is the same
X
X (when (not (= (length oldslots) (length newslots)))
X (return-from slots-compatible-p NIL)
X )
X
X ;;Check slot names
X
X (do
X (
X (ns newslots (cdr ns))
X (os oldslots (cdr os))
X )
X ( (or (null ns) (null os)) )
X
X (if (not (eq (car ns) (car os)))
X (return-from slots-compatible-p NIL)
X ) ;if
X ) ;do
X
X T
X) ;end slots-compatible-p
X
X;;merge-duplicates-Merge duplicates and check for conflicts
X;; in parents.
X
X(defun merge-duplicates (name gettables settables parents dont-define)
X
X ;;Destructively modify gettables and settables
X ;;to get rid of duplicates
X
X (merge-methods gettables settables)
X
X ;;Check for funny business in inheritance
X
X (check-for-funny-inheritance name parents)
X
X ;;Check if any conflicts with parents and among parents
X
X (check-for-method-conflicts name gettables parents dont-define)
X
X NIL
X) ;end merge-duplicates
X
X;;merge-methods-Put settables on gettable list
X
X(defun merge-methods (gettables settables)
X
X (dolist (meth settables)
X
X (when (not (member meth gettables :test #'equal))
X (setf (cdr (last gettables)) (list meth ) )
X )
X ) ;dolist
X
X) ;end merge-methods
X
X;;check-for-funny-inheritance-Check for attempts to inherit
X;; from yourself
X
X(defun check-for-funny-inheritance (name parents)
X
X ;;Check me
X
X (dolist (p parents)
X
X ;; Check me
X
X (if (eq name (class-name (car p)))
X (co-deftype-error"this type has itself as an ancestor.~%" name)
X )
X
X ;;Check parent
X
X (check-for-funny-inheritance name (mapcar #'list (class-local-supers (car p))))
X )
X
X) ;end check-for-funny-inheritance
X
X;;check-for-method-conflicts-Merge gettable and parent lists and
X;; check for conflicts.
X
X(defun check-for-method-conflicts (name gettables parents dont-define)
X
X (let
X (
X (kwp (find-package 'keyword))
X (meths NIL)
X )
X
X ;;Intern the gettable names in the keyword package
X
X (dolist (g gettables)
X (setf meths (cons (intern (symbol-name g) kwp) meths))
X ) ;dolist
X
X ;;Concatenate the parent methods onto the end
X
X (dolist (p parents)
X
X (setf meths
X (concatenate
X 'list
X meths
X (cdr p)
X )
X )
X
X ) ;dolist
X
X ;;Now check for duplicates
X
X (check-for-conflicts name meths dont-define)
X
X ) ;let
X
X) ;end check-for-method-conflicts
X
X;;check-for-conflicts-Check if any generated methods
X;; conflict
X
X(defun check-for-conflicts (name list dont-define)
X
X (setf list (sort list #'(lambda (x y) (string-lessp (symbol-name x) (symbol-name y)))))
X
X (do*
X (
X (item (car list) (car clist))
X (clist (cdr list) (cdr clist))
X )
X ((eq clist NIL))
X
X ;;Check if a method already exists and isn't on the don't define
X ;; list
X
X (if (and (equal item (car clist)) (not (member item dont-define)))
X (co-deftype-error
X "two methods ~S exist during method generation.~%~
X Please undefine one or the other.~%"
X name item
X )
X )
X ) ;do
X
X) ;end check-for-conflicts
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Top Level Method Building Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;build-inherited-methods-Build the list of inherited methods by using
X;; apply-method
X
X(defun build-inherited-methods (name parents dont-define parent-names slots)
X
X (let
X (
X (methcode NIL)
X )
X
X ;;Do all the parents
X
X (dolist (p parents)
X
X ;;Do this parent's list
X
X (dolist (m (cdr p))
X
X ;;Check first to be sure it should be defined
X
X (if (not (member m dont-define))
X
X (push
X (build-inherited-method
X name
X m
X (class-name (car p))
X parent-names
X slots
X )
X methcode
X )
X
X )
X
X ) ;dolist
X ) ;dolist
X
X methcode
X
X ) ;let
X
X) ;build-inherited-methods
X
X;;build-gs-methods-Build gettable and settable methods
X
X(defun build-gs-methods (typename gettables settables dont-define parents slots)
X
X (let
X (
X (methcode NIL)
X (kwp (find-package 'keyword))
X (meth NIL)
X )
X
X ;;First do gettables
X
X (dolist (g gettables)
X
X (setf meth (intern (symbol-name g) kwp))
X
X ;;Check first to be sure it must be defined
X
X (if (not (member meth dont-define))
X
X (push
X (build-get-method typename
X meth
X g
X parents
X slots
X )
X methcode
X )
X )
X
X
X ) ;dolist
X
X ;;Now do settables
X
X (dolist (s settables)
X
X (setf meth
X (intern (concatenate 'simple-string "SET-" (symbol-name s)) kwp)
X )
X
X ;;Check first to be sure it must be defined
X
X (if (not (member s dont-define))
X (push
X (build-set-method
X typename
X meth
X s
X parents
X slots
X )
X methcode
X )
X )
X
X ) ;dolist
X
X methcode
X
X ) ;let
X) ;end build-gs-methods
X
X;;build-init-vars-method-Return code for the :INITIALIZE-VARIABLES
X;; method. Note that this must be a fully-blown CommonObjects
X;; method, because the users can put anthing they want into
X;; the initialization code, including CALL-METHOD.
X
X(defun build-init-vars-method
X (name initable-slots assignments)
X
X (let
X (
X (form NIL)
X (kwpak (find-package 'keyword))
X (code NIL)
X )
X
X
X ;;This code is stolen from DEFINE-METHOD and is
X ;; inserted in line here so that, when it
X ;; gets returned to the top level, PCL::EXPAND-DEFMETH-INTERNAL
X ;; gets invoked while the DEFINE-TYPE macro is executing,
X ;; rather than at the top level, when the macro has
X ;; finished executing.
X
X (setf code
X `(compiler-let
X (
X (*current-method-class-name* ',name)
X )
X
X
X (let ((self (self-from-inner-self)))
X (declare (optimize (speed 3) (safety 0)))
X
X (with*
X (
X (.inner-self. "" ,name)
X )
X
X ,(if initable-slots
X
X `(do*
X (
X (unprocessed-keys keylist (cddr unprocessed-keys))
X (keyword (car unprocessed-keys) (car unprocessed-keys))
X (value (cadr unprocessed-keys) (cadr unprocessed-keys))
X )
X ( (null unprocessed-keys) )
X (case keyword
X ,@(dolist (var initable-slots form)
X (push
X `(
X (,(intern (symbol-name var) kwpak) )
X (setf ,var value)
X )
X form
X )
X )
X )
X )
X
X ) ;if
X
X ,@assignments
X
X ) ;with*
X
X ) ;let
X ) ;compiler-let
X ) ;setf
X
X ;;Now define as a full blown CommonObjects method, with code
X ;; walking and everything. Add in CALL-METHOD processing.
X
X `(progn
X
X ,(defcommon-objects-meth
X 'keyword-standin::initialize-variables
X `((.inner-self. ,name) &rest keylist)
X code
X )
X
X ) ;progn
X
X ) ;end let
X
X) ;end build-init-vars-method
X
X;;build-pcl-method-def-Build a PCL method definition without
X;; all the overhead of code walking and method object creation
X;; at compile time
X
X(defun build-pcl-method-def (type method func-args code)
X
X (setf method
X (if (keywordp method)
X (keyword-standin method)
X method
X )
X )
X
X (let*
X (
X (type-spec (list type))
X (method-function-name (pcl::make-method-name method type-spec))
X )
X
X ;;The extra list is so the forms get inserted at the
X ;; top level OK
X
X `(
X (eval-when (compile load eval)
X (pcl::record-definition
X ',method 'pcl::method ',type-spec NIL
X )
X (defun ,method-function-name ,func-args
X (declare (optimize (speed 3) (safety 0)))
X ,code
X )
X )
X
X ;;Note that this must be done at compile time
X ;; as well, since inherited methods must
X ;; be there for other types in the file
X
X (eval-when (compile load eval)
X (let
X (
X (method
X (pcl::load-method-1
X 'pcl::discriminator
X 'common-objects-method
X ',method
X ',type-spec
X ',func-args
X NIL
X )
X
X )
X
X )
X
X (setf (method-function method)
X (symbol-function ',method-function-name)
X )
X
X (add-method (discriminator-named ',method) method NIL)
X )
X
X )
X
X )
X
X ) ;let*
X
X) ;build-pcl-method-def
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Get/Set and Inherited Method Building Functions
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;build-get-method-Build a gettable method
X
X(defun build-get-method (name methname var parents slots)
X
X `(progn
X ,@(build-pcl-method-def
X name
X methname
X '(.inner-self.)
X `(%instance-ref .inner-self. ,(calculate-slot-index var parents slots))
X )
X )
X
X) ;end build-get-method
X
X;;build-set-method-Build a settable method
X
X(defun build-set-method (name methname var parents slots)
X
X `(progn
X ,@(build-pcl-method-def
X name
X methname
X '(.inner-self. .new-value.)
X `(setf
X (%instance-ref .inner-self. ,(calculate-slot-index var parents slots))
X .new-value.
X )
X )
X )
X
X) ;end build-set-method
X
X;;build-inherited-method-Return code for an inherited method.
X
X(defun build-inherited-method (name m p parents slots)
X
X ;;Now generate code
X
X `(progn
X ,@(build-pcl-method-def
X name
X m
X '(.inner-self. &rest .arg-list.)
X `(apply
X (symbol-function
X ',(generate-method-function-symbol
X p m
X )
X )
X (%instance-ref
X .inner-self.
X ,(calculate-slot-index
X p
X parents
X slots
X )
X )
X .arg-list.
X
X )
X )
X
X )
X
X) ;end build-inherited-method
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Default Universal Methods
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;define-universal-method-Macro to define universal methods. Note that
X;; DEFCOMMON-OBJECTS-METH could probably be used directly, but this
X;; tells what we're doing. We need a CommonObjects method here because
X;; we may need a symbol for CALL-METHOD
X
X(defmacro define-universal-method (name arglist &body body)
X
X ;;Check for undefined type in body
X
X (setf body
X `(progn
X (if (eq (class-name (class-of ,(first (first arglist))))
X $UNDEFINED-TYPE-NAME
X )
X (no-matching-method (discriminator-named ',name))
X )
X ,@body
X )
X )
X
X (defcommon-objects-meth name arglist body)
X
X ) ;define-universal-method
X
X;;keyword-standin::init-Default :INIT method does nothing
X
X(define-universal-method keyword-standin::init
X ((self common-objects-class) &rest keylist)
X
X
X) ;keyword-standin::init
X
X;;keyword-standin::initialize-Default :INITIALIZE initializes
X;; parents, then variables
X
X(define-universal-method keyword-standin::initialize
X ((self common-objects-class) &rest keylist)
X
X (let
X (
X (class (class-of self))
X )
X
X (dolist (l (class-local-super-slot-names class))
X
X ;;GET-SLOT is inserted in-line here
X
X (apply 'keyword-standin::initialize
X (%instance-ref self (slot-index class l))
X keylist
X )
X )
X
X ;;Now initialize variables
X
X (apply 'keyword-standin::initialize-variables self (car keylist))
X (apply 'keyword-standin::init self (car keylist))
X
X ) ;let
X
X) ;keyword-standin::initialize
X
X;;print-instance-Print the instance
X
X(define-universal-method print-instance
X ((self common-objects-class) output-stream integer)
X
X (if (or (not integer)
X (not *print-level*)
X (< integer *print-level*)
X )
X
X (pcl::printing-random-thing (self output-stream)
X (format output-stream "~A" (class-name (class-of self)))
X )
X
X )
X
X) ;print-instance
X
X;;keyword-standin::describe-Default :DESCRIBE method
X
X(define-universal-method keyword-standin::describe
X ((self common-objects-class) &optional describe-inner-loop)
X
X (let
X (
X (class (class-of self))
X )
X
X (when (equal
X (class-name (class-of class))
X 'common-objects-class
X )
X
X ;;Give name of this guy
X
X (if (not describe-inner-loop)
X (format T
X "This object of type ~A has variables:~%"
X (class-name (class-of self))
X )
X (format T
X "For parent ~A:~%"
X (class-name (class-of self))
X )
X ) ;if
X
X ;;Now print instance variables
X
X (dolist (slot (class-user-visible-slots class))
X (format T " ~A: ~S~%" slot (get-slot-using-class class self slot))
X )
X
X ;;Now print for parents
X
X (dolist (lss (class-local-super-slot-names class))
X (keyword-standin::describe (get-slot-using-class class self lss) T)
X )
X
X ) ;when
X
X ) ;let
X
X) ;keyword-standin::describe
X
X;;keyword-standin::eql-Default :EQL predicate method
X
X(define-universal-method keyword-standin::eql
X ((self common-objects-class) .any.)
X
X (eq self .any.)
X
X) ;keyword-standin::eql
X
X;;keyword-standin::equal-Default :EQUAL predicate method
X
X(define-universal-method keyword-standin::equal
X ((self common-objects-class) .any.)
X
X (keyword-standin::eql self .any.)
X
X) ;keyword-standin::equal
X
X;;keyword-standin::equalp-Default :EQUALP predicate method
X
X(define-universal-method keyword-standin::equalp
X ((self common-objects-class) .any.)
X
X (keyword-standin::equal self .any.)
X
X) ;keyword-standin::equalp
X
X;;keyword-standin::typep-Default :TYPEP predicate method
X
X(define-universal-method keyword-standin::typep
X ((self common-objects-class) .any.)
X
X (or (equal (class-name (class-of self)) .any.)
X (eq .any. 'instance)
X (eq .any. 't)
X )
X
X) ;keyword-standin::typep
X
X;;keyword-standin::copy-Default :COPY method
X
X(define-universal-method keyword-standin::copy
X ((self common-objects-class))
X
X self
X
X) ;keyword-standin::copy
X
X;;keyword-standin::copy-instance-Default :COPY-INSTANCE method
X
X(define-universal-method keyword-standin::copy-instance
X ((self common-objects-class))
X
X (let
X (
X (class (class-of self))
X (inst NIL)
X )
X
X (when (equal
X (class-name (class-of class))
X 'common-objects-class
X )
X
X (setf inst (make-instance (class-name class)))
X
X ;Copy state from inner-self to instance
X
X (co::set-slot-values self inst class)
X
X inst
X ) ;when
X
X ) ;let
X
X) ;keyword-standin::copy-instance
X
X;;keyword-standin::copy-state-Default :COPY-STATE method
X
X(define-universal-method keyword-standin::copy-state
X ((self common-objects-class))
X
X self
X
X) ;keyword-standin::copy-state
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Support Methods and Functions for Universal Methods
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;set-slot-values-Set the slot values in OBJECT to those in .INNER-SELF.
X
X(defmeth set-slot-values (.inner-self. object class)
X
X ;;Set in this guy
X
X (dolist (slot (class-user-visible-slots class))
X (setf (get-slot object slot) (get-slot .inner-self. slot))
X )
X
X ;;Now set in parents
X
X (dolist (lss (class-local-super-slot-names class))
X (set-slot-values
X (get-slot .inner-self. lss)
X (get-slot object lss)
X (class-of (get-slot .inner-self. lss))
X )
X )
X
X) ;end set-slot-values
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Renaming and Undefining Types and Methods
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;rename-type-Rename type1 to type2
X
X(defun rename-type (type1 type2)
X (declare (type symbol type1 type2))
X
X (let
X (
X (class (class-named type1 T))
X (newclass (class-named type2 T))
X )
X
X ;;Signal an error for special cases
X
X (when (or (null type2) (eq type2 't))
X (error "RENAME-TYPE: New name cannot be NIL or T.~%")
X )
X
X ;;Signal an error when arguments aren't symbols
X
X (when (or (not (symbolp type1)) (not (symbolp type2)))
X (error "RENAME-TYPE: Arguments must be symbols.~%")
X )
X
X ;;Signal error if TYPE2 already exists
X
X (when newclass
X (error "RENAME-TYPE: Type ~S already exists.~%" type2)
X )
X
X ;;Signal an error if class isn't CommonObjects class
X
X (when (not (eq (class-name (class-of class)) 'common-objects-class))
X (error "RENAME-TYPE: Can't rename a built-in type or nonCommonObjects class ~S.~%" type1)
X )
X
X ;;Signal an error if the class is not defined
X
X (if class
X (progn
X (rename-class class type2)
X type2
X
X ) ;progn
X (error "RENAME-TYPE: The type ~S is not defined.~%" type1)
X ) ;if
X
X ) ;let
X
X) ;end rename-type
X
X;;undefine-type-Undefine type typename
X
X(defun undefine-type (typename)
X (declare (type symbol typename))
X
X ;;Check if typename is a symbol
X
X (when (not (symbolp typename))
X (error "UNDEFINE-TYPE: Argument must be a symbol.~%")
X )
X
X (let
X (
X (class (class-named typename T))
X )
X
X (if (and class (eq (class-name (class-of class)) 'common-objects-class))
X (progn
X
X ;;Undefine all the methods first
X
X (undefine-methods class)
X
X ;;Now set the class name
X
X (setf (class-name class) $UNDEFINED-TYPE-NAME)
X (setf (class-named typename) NIL)
X T
X ) ;progn
X
X NIL
X
X ) ;if
X
X ) ;let
X
X) ;end undefine-type
X
X;;undefine-methods-Undefine all the methods on class
X
X(defun undefine-methods (class)
X
X (dolist (meth (class-direct-methods class))
X
X ;;Remove the method from the discriminator
X
X (remove-method (method-discriminator meth) meth)
X
X ;;Now unbind the symbol cell, so call-methods don't work
X
X (fmakunbound (method-function-symbol meth))
X )
X
X) ;undefine-methods
X
X;;undefine-method-Use PCL remove-method to get
X;; rid of method.
X
X(defun undefine-method (typename operation)
X (declare (type symbol typename operation))
X
X ;;Check if the arguments are symbols
X
X (when (not (symbolp typename))
X (error "UNDEFINE-METHOD: Type name must be a symbol.~%")
X )
X
X ;;If the operation is not a symbol, just return.
X
X (when (not (symbolp operation))
X (return-from undefine-method NIL)
X )
X
X (let*
X (
X
X ;;The class object
X
X (class (class-named typename))
X
X ;;The operation
X
X (opname (if (keywordp operation)
X (keyword-standin operation)
X operation
X )
X )
X
X ;;The discriminator (if any)
X
X (disc (discriminator-named opname))
X
X ;;The method (if any)
X
X (meth
X (if disc
X (find-method disc (list typename) NIL T)
X )
X )
X
X )
X
X
X ;;Check if the class is a CommonObjects class
X
X (when (not (eq (class-name (class-of class)) 'common-objects-class))
X (error "UNDEFINE-TYPE: Tried to undefine ~S ~
X which is not a CommonObjects class.~%"
X typename
X )
X )
X
X ;;Check if the method is a universal method and there
X ;; is no type specific method. Warn the user.
X
X (when (and
X (null meth)
X (member operation *universal-methods* :test #'eq)
X )
X (warn
X (format
X NIL
X "UNDEFINE-TYPod NIL)
X )
X
X (let*
X (
X
X ;;The class ob% which cannot be undefined."
X typename
X operation
X )
X )
X (return-from undefine-method NIL)
X )
X
X ;;If a method was found, undefine it
X
X (if (and meth disc)
X (progn
X (remove-method disc meth)
X
X ;;Now unbind the symbol cell, so CALL-METHODs don't work
X
X (fmakunbound (method-function-symbol meth))
X
X ;;Remove the symbol from the package, so that future
X ;; attempts to create CALL-METHODs can't find it.
X ;; But hopefully, existing CALL-METHODs will still
X ;; work.
X
X (unintern (method-function-symbol meth)
X (symbol-package (method-function-symbol meth))
X )
X
X T
X ) ;progn
X
X NIL
X
X ) ;if
X
X ) ;let
X
X) ;end undefine-method
X
X;;assignedp-Indicate whether or not an instance variable is
X;; assigned
X
X(defmacro assignedp (var)
X
X (declare (special co::*current-method-class-name*))
X
X ;;Check for attempt to access outside of a method
X
X (if (null (boundp 'co::*current-method-class-name*))
X (error "DEFINE-METHOD: Attempt to use assignedp outside of a method.~%")
X )
X
X ;;Check for attempt to use on something other than an instance variable
X
X (unless (has-slot-p (class-named *current-method-class-name*) var)
X (error "DEFINE-METHOD: Argument ~S to assignedp ~
X must be an instance variable name.~%"
X var
X )
X )
X
X `(not (equal ,var ',$UNINITIALIZED-VARIABLE-FLAG))
X
X) ;;end assignedp
X
X;;instancep-Return T if this thing is an instance and has a CommonObjects
X;; class
X
X(defun instancep (thing)
X
X ;;Check first if thing is NIL
X
X (if (not thing)
X NIL
X (eq (class-name (class-of (class-of thing))) 'common-objects-class)
X )
X
X
X) ;end instancep
X
X;;supports-operation-p-Return T if method operation METH is supported on type
X;; of OBJ
X
X(defun supports-operation-p (obj meth)
X (declare (special *universal-methods*))
X
X (let
X (
X (class (if obj (class-of obj) obj))
X )
X
X ;;If not a CommonObjects class, then return NIL
X
X (when (or (not class)
X (not (eq (class-name (class-of class)) 'common-objects-class))
X )
X (return-from supports-operation-p NIL)
X )
X
X ;;Check first if its a universal method
X
X (if (member meth *universal-methods*)
X
X T
X
X ;;Otherwise, check in the class object if it's got them
X
X (dolist (methobj (class-direct-methods class))
X
X (when (eq (unkeyword-standin (method-name methobj)) meth)
X (return-from supports-operation-p T)
X )
X
X ) ;dolist
X
X ) ;if
X
X ) ;let
X
X) ;end supports-operation-p
X
X;;Define the instance type
X
X(deftype instance ()
X (list 'apply 'instancep)
X
X) ;end deftype
X
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X; Make-Instance
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;make-instance-Make an instance given the CommonObjects type name
X
X(defmeth make-instance ((class-name symbol) &rest keylist)
X
X ;;Check if the key list and class are OK.
X
X (if (null (listp keylist))
X (error "Make-instance requires a list for the keyword list.~%")
X )
X
X (if (null (class-named class-name T))
X (error "~S is not a defined type.~%" class-name)
X )
X
X (make-instance (class-named class-name) keylist)
X
X) ;end make-instance
X
X;;make-instance-Make an instance given the CommonObjects class object
X
X(defmeth make-instance ((class common-objects-class) &rest keylist)
X (declare (special *outer-self*))
X
X (let*
X (
X (instance NIL)
X (numslots (length (class-user-visible-slots class)))
X (start-slots
X (+ $START-OF-PARENTS (length (class-local-supers class)))
X )
X )
X (let
X (
X (*outer-self* (and (boundp '*outer-self*) *outer-self*))
X )
X (declare (special *outer-self*))
X
X (setf instance (%make-instance (class-of class)
X (+ 2 (class-instance-size class))
X )
X )
X (setf (%instance-ref instance $CLASS-OBJECT-INDEX) class
X (%instance-ref instance $SELF-INDEX) (or *outer-self*
X (setq *outer-self* instance)
X )
X )
X
X ;;Initialize the slots with the uninitialized flag
X
X (dotimes (i numslots)
X (setf
X (%instance-ref instance (+ i start-slots))
X $UNINITIALIZED-VARIABLE-FLAG
X )
X )
X
X ;;Now go through and make parent objects
X
X (do
X (
X (supers (class-local-supers class) (cdr supers))
X (index $START-OF-PARENTS (1+ index))
X )
X ((null supers))
X (setf (%instance-ref instance index)
X (make-instance (car supers) (car keylist))
X )
X ) ;do
X
X ) ;end let for dynamic binding
X
X ;;Check initialization keywords and initialize, but only if
X ;; creating outer self object.
X
X (when (not (boundp '*outer-self*))
X
X ;;If keyword check needed, then check keyword list
X
X (if (class-init-keywords-check class)
X (check-init-keywords class keylist)
X )
X ;;Now initialize, if doing outer self.
X
X (keyword-standin::initialize instance (car keylist))
X
X ) ;when
X
X instance
X
X ) ;end let for lexical binding
X
X) ;end make-instance
X
END_OF_FILE
if test 36944 -ne `wc -c <'co-dtype.l'`; then
echo shar: \"'co-dtype.l'\" unpacked with wrong size!
fi
# end of 'co-dtype.l'
fi
echo shar: End of archive 11 \(of 13\).
cp /dev/null ark11isdone
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