rs@uunet.UU.NET (Rich Salz) (08/04/87)
Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM>
Posting-number: Volume 10, Issue 84
Archive-name: comobj.lisp/Part10
#! /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 10 (of 13)."
# Contents: braid.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'braid.l' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'braid.l'\"
else
echo shar: Extracting \"'braid.l'\" \(34250 characters\)
sed "s/^X//" >'braid.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation. All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted. Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;; CommonLoops Coordinator
X;;; Xerox Artifical Intelligence Systems
X;;; 2400 Hanover St.
X;;; Palo Alto, CA 94303
X;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; The meta-braid and defstruct.
X;;;
X;;; NOTE: This file must be loaded before it can be compiled.
X
X#| *** TO DO ***
X
X|#
X(in-package 'pcl)
X
X ;;
X;;;;;; Medium-level support for the class CLASS.
X ;;
X;;; The low-level macros are defined by the file portable-low (or a special
X;;; version) of that file if there is one for this implementation. This is
X;;; the lowest-level completely portable code which operates on instances
X;;; with meta-class class.
X
X(defmacro get-static-slot--class (iwmc-class slot-index)
X `(%static-slot-storage-get-slot--class
X (iwmc-class-static-slots ,iwmc-class)
X ,slot-index))
X
X(defmacro get-dynamic-slot--class (iwmc-class slot-name default)
X `(%dynamic-slot-storage-get-slot--class
X (iwmc-class-dynamic-slots ,iwmc-class)
X ,slot-name
X ,default))
X
X(defmacro remove-dynamic-slot--class (iwmc-class slot-name)
X `(%dynamic-slot-storage-remove-slot--class
X (iwmc-class-dynamic-slots ,iwmc-class)
X ,slot-name))
X
X
X ;;
X;;;;;; defmeth -- defining methods
X ;;
X;;; We need to be able to define something like methods before we really have
X;;; real method functionality available.
X;;;
X;;; defmeth expands by calling expand-defmeth, this means that we can define
X;;; an early version of defmeth just by defining an early version of expand-
X;;; defmeth.
X;;;
X(defmacro defmethod (&rest args)
X ;(declare (zl:arglist name qualifier* arglist &body body))
X (let ((name (pop args))
X (qualifiers ())
X (arglist ())
X (body nil))
X (multiple-value-setq (qualifiers args) (defmethod-qualifiers args))
X (setq arglist (pop args)
X body args)
X `(defmeth (,name . ,qualifiers) ,arglist . ,body)))
X
X(defmacro defmethod-setf (&rest args)
X (let ((name (pop args))
X (qualifiers ())
X (arglist ())
X (new-value-arglist ())
X (body nil))
X (multiple-value-setq (qualifiers args) (defmethod-qualifiers args))
X (setq arglist (pop args)
X new-value-arglist (pop args)
X body args)
X `(defmeth (,name (:setf ,new-value-arglist) ,.qualifiers) ,arglist
X ,@body)))
X
X(defun defmethod-qualifiers (args)
X (declare (values qualifiers arglist-and-body))
X (let ((qualifiers ()))
X (loop (if (and (car args) (listp (car args)))
X (return (values (nreverse qualifiers) args))
X (push (pop args) qualifiers)))))
X
X(defun defmethod-argument-specializers (arglist)
X (let ((arg (car arglist)))
X (cond ((null arglist) nil)
X ((memq arg '(&optional &rest &key &aux)) nil) ;Don't allow any
X ;argument specializers
X ;after one of these.
X ((memq arg lambda-list-keywords) ;Or one of these!!
X (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
X Assuming that no argument specializers appear after it."
X arg)
X nil)
X (t
X (let ((tail (defmethod-argument-specializers (cdr arglist)))
X (specializer (and (listp arg) (cadr arg))))
X (or (and tail (cons (or specializer 't) tail))
X (and specializer (cons specializer ()))))))))
X
X
X(defmacro defmeth (name&options arglist &body body)
X (expand-defmeth name&options arglist body))
X
X(eval-when (compile load eval)
X ;; Make sure we call bootstrap-expand-defmeth during bootstrapping.
X ;; - Can't say (setf (symbol-fu ..) #'bootstrap-expand-defmeth because
X ;; bootstrap-expand-defmeth isn't defined yet and that isn't legal
X ;; in Common Lisp.
X ;; - Can't say (setf (symbol-fu ..) 'bootstrap-expand-defmeth because
X ;; not all Common Lisps like having symbols in the function cell.
X (setf (symbol-function 'expand-defmeth)
X #'(lambda (name&options arglist body)
X (bootstrap-expand-defmeth name&options arglist body)))
X )
X
X ;;
X;;;;;; Early methods
X ;;
X
X(defvar *real-methods-exist-p*)
X(eval-when (compile load eval)
X (setq *real-methods-exist-p* nil))
X
X(eval-when (load)
X (setq *error-when-defining-method-on-existing-function* 'bootstrapping))
X
X(defvar *protected-early-selectors* '(print-instance))
X
X(defparameter *early-defmeths* ())
X
X(defmacro simple-type-specs (arglist)
X `(let ((type-specs
X (iterate ((arg in ,arglist))
X (until (memq arg '(&optional &rest &key &aux)))
X (collect (if (listp arg) (cadr arg) 't)))))
X (setq type-specs (nreverse type-specs))
X (iterate ((type-spec in type-specs))
X (until (neq type-spec 't))
X (pop type-specs))
X (nreverse type-specs)))
X
X(defmacro simple-without-type-specs (arglist)
X `(iterate ((loc on ,arglist))
X (cond ((memq (car loc) '(&optional &rest &key &aux))
X (join loc) (until t))
X (t
X (collect (if (listp (car loc))
X (caar loc)
X (car loc)))))))
X(defmacro simple-args (arglist)
X `(iterate ((arg in ,arglist))
X (until (eq arg '&aux))
X (unless (memq arg '(&optional &rest &key))
X (collect (if (listp arg) (car arg) arg)))))
X
X(defun bootstrap-expand-defmeth (name&options arglist body)
X ;; Some SIMPLE local macros for getting the type-specifiers out of the
X ;; argument list. Unfortunately, it is important that these simple
X ;; macros and the methods which come along later and do this job better
X ;; be compatible. This will become less of an issue once methods don't
X ;; have names anymore.
X; (macrolet ()
X (multiple-value-bind (documentation declares body)
X (extract-declarations body)
X (or (listp name&options) (setq name&options (list name&options)))
X (keyword-parse ((setf () setfp))
X (cdr name&options)
X (let* ((name (car name&options))
X (discriminator-name (if setfp
X (make-setf-discriminator-name name)
X name))
X (method-name (if setfp
X (make-setf-method-name
X name
X (simple-type-specs setf)
X (simple-type-specs arglist))
X (make-method-name
X name (simple-type-specs arglist))))
X (method-arglist (simple-without-type-specs
X (if setfp
X (cons (car arglist)
X (append setf (cdr arglist)))
X arglist))))
X `(progn
X ;; Record this early defmeth so that fixup-early-defmeths will
X ;; know to fix it up later.
X (eval-when (compile load eval)
X (record-early-defmeth
X ',discriminator-name ',name&options ',arglist ',body))
X (record-definition ',discriminator-name 'method)
X (defun ,method-name ,method-arglist
X ,@(and documentation (list documentation))
X ,@declares
X; #+Symbolics(declare (sys:function-parent ,name defmeth))
X . ,body)
X ,(unless (memq discriminator-name *protected-early-selectors*)
X `(eval-when (load eval)
X (setf (symbol-function ',discriminator-name)
X (symbol-function ',method-name))))
X ,@(and setfp
X (not (memq discriminator-name *protected-early-selectors*))
X (let ((args (simple-without-type-specs arglist))
X (setf-args (simple-without-type-specs setf)))
X `((defsetf ,name ,args ,setf-args
X (list ',discriminator-name
X ,(car args)
X ,@(simple-args setf)
X ,@(simple-args (cdr args))))))))))))
X;)
X
X(defun record-early-defmeth (discriminator-name name&options arglist body)
X (pushnew (list* 'defmeth discriminator-name name&options arglist body)
X *early-defmeths*
X :test #'equal))
X
X(defun record-early-discriminator (discriminator-name)
X (pushnew (list 'clear discriminator-name) *early-defmeths* :test #'equal))
X
X(defun record-early-method-fixup (form)
X (pushnew (list 'eval form) *early-defmeths* :test #'equal))
X
X(defmacro fix-early-defmeths ()
X (let ((resets ())
X (evals ()))
X (dolist (entry *early-defmeths*)
X (ecase (car entry)
X (defmeth (push (cons 'defmeth (cddr entry)) evals)
X (push (cadr entry) resets))
X (clear (push (cadr entry) resets))
X (eval (push (cadr entry) evals))))
X `(progn
X ;; The first thing to do is go through and get rid of all the old
X ;; discriminators. This only needs to happen when we are being
X ;; loaded into the same VMem we were compiled in. The WHEN is
X ;; making that optimization.
X (defun fix-early-defmeths-1 ()
X (when (discriminator-named ',(car resets))
X (dolist (x ',resets) (setf (discriminator-named x) nil))))
X (fix-early-defmeths-1)
X ,@evals)))
X
X#| This is useful for debugging.
X(defmacro unfix-early-defmeths ()
X `(progn
X (do-symbols (x)
X (remprop x 'discriminator)
X (remprop x 'setf-discriminator))
X . ,(mapcar '(lambda (x) (cons 'defmeth x)) (reverse *early-defmeths*))))
X
X(unfix-early-defmeths)
X|#
X
X(defun make-setf-discriminator-name (name)
X (intern (string-append name " :SETF-discriminator")
X (symbol-package name)))
X
X(defun make-method-name (selector type-specifiers)
X (intern (apply #'string-append
X (list* "Method "
X selector
X " "
X (make-method-name-internal type-specifiers)))
X (symbol-package selector)))
X
X(defun make-setf-method-name (selector setf-type-specifiers type-specifiers)
X (intern (apply #'string-append
X (list* "Method "
X selector
X " ("
X (apply #'string-append
X ":SETF "
X (make-method-name-internal setf-type-specifiers))
X ") "
X (make-method-name-internal type-specifiers)))
X (symbol-package selector)))
X
X(defun make-method-name-internal (type-specifiers)
X (if type-specifiers
X (iterate ((type-spec on type-specifiers))
X (collect (string (car type-spec)))
X (when (cdr type-spec) (collect " ")))
X '("Default")))
X
X
X
X ;;
X;;;;;; SLOTDS and DS-OPTIONS
X ;;
X;;;
X;;; A slot-description is the thing which appears in a defstruct. A SLOTD is
X;;; an internal description of a slot.
X;;;
X;;; The SLOTD structure corresponds to the kind of slot the structure-class
X;;; meta-class creates (the kind of slot that appears in Steele Edition 1).
X;;; Other metaclasses which need to have more elaborate slot options and
X;;; slotds, they :include that class in their slotds.
X;;;
X;;; slotds are :type list for 2 important reasons:
X;;; - so that looking up a slotd in a list of lists will compile
X;;; into a call to assq
X;;; - PCL assumes only the existence of the simplest of defstructs
X;;; this allows PCL to be used to implement a real defstruct.
X;;;
X(defstruct (essential-slotd (:type list)
X (:constructor make-slotd--essential-class))
X name)
X
X;;;
X;;; Slotd-position is used to find the position of a slot with a particular
X;;; name in a list of slotds. Specifically it is used in the case of a
X;;; get-slot cache miss to find this slot index. That means it is used in
X;;; about 2% of the total slot accesses so it should be fast.
X;;;
X(defmacro slotd-position (slotd-name slotds)
X `(let ((slotd-name ,slotd-name))
X (do ((pos 0 (+ pos 1))
X (slotds ,slotds (cdr slotds)))
X ((null slotds) nil)
X (declare (type integer pos) (type list slotds))
X (and (eq slotd-name (slotd-name (car slotds)))
X (return pos)))))
X
X(defmacro slotd-member (slotd-name slotds) ;I wonder how
X `(member ,slotd-name ,slotds :test #'eq :key #'slotd-name)) ;many compilers
X ;are really
X ;smart enough.
X(defmacro slotd-assoc (slotd-name slotds)
X `(assq ,slotd-name ,slotds))
X
X;;;
X;;; Once defstruct-options are defaulted and parsed, they are stored in a
X;;; ds-options (defstruct-options) structure. This modularity makes it
X;;; easier to build the meta-braid which has to do some slot and option
X;;; parsing long before the real new defstruct exists. More importantly,
X;;; this allows new meta-classes to inherit the option parsing code
X;;; from other metaclasses.
X;;;
X(defstruct (ds-options (:constructor make-ds-options--class))
X name
X constructors ;The constructor argument, a list whose car is the
X ;name of the constructor and whose cadr if present
X ;is the argument-list for the constructor.
X copier ;(defaulted) value of the :copier option.
X predicate ;ditto for :predicate
X print-function ;ditto for :print-function
X generate-accessors ;ditto for :generate-accessors
X conc-name ;ditto for :conc-name
X includes ;The included structures (car of :include)
X slot-includes ;The included slot modifications (cdr of :include)
X initial-offset ;(defaulted) value of the :initial-offset option.
X )
X
X
X
X ;;
X;;;;;; The beginnings of the meta-class CLASS (parsing the defstruct)
X ;;
X
X(defmeth make-ds-options ((class basic-class) name)
X (ignore class)
X (make-ds-options--class :name name))
X
X(defmeth parse-defstruct-options ((class basic-class) name options)
X (parse-defstruct-options-internal
X class name options
X (default-ds-options class name (make-ds-options class name))))
X
X(defmeth default-ds-options ((class basic-class) name ds-options)
X (ignore class)
X (setf
X (ds-options-constructors ds-options) `((,(symbol-append "MAKE-"
X name)))
X (ds-options-copier ds-options) (symbol-append "COPY-" name)
X (ds-options-predicate ds-options) (symbol-append name "-P")
X (ds-options-print-function ds-options) nil
X (ds-options-generate-accessors ds-options) 'method
X (ds-options-conc-name ds-options) (symbol-append name "-")
X (ds-options-includes ds-options) ()
X (ds-options-slot-includes ds-options) ()
X (ds-options-initial-offset ds-options) 0)
X ds-options)
X
X(defmeth parse-defstruct-options-internal ((class basic-class)
X name options ds-options)
X (ignore class name)
X (keyword-parse ((conc-name (ds-options-conc-name ds-options))
X (constructor () constructor-p :allowed :multiple
X :return-cdr t)
X (copier (ds-options-copier ds-options))
X (predicate (ds-options-predicate ds-options))
X (include () include-p :return-cdr t)
X (print-function () print-function-p)
X (initial-offset (ds-options-initial-offset ds-options))
X (generate-accessors (ds-options-generate-accessors
X ds-options)))
X options
X (setf (ds-options-conc-name ds-options) conc-name)
X (when constructor-p
X (setf (ds-options-constructors ds-options) constructor))
X (setf (ds-options-copier ds-options) copier)
X (setf (ds-options-predicate ds-options) predicate)
X (when include-p
X (destructuring-bind (includes . slot-includes) include
X (setf (ds-options-includes ds-options) (if (listp includes)
X includes
X (list includes))
X (ds-options-slot-includes ds-options) slot-includes)))
X (when print-function-p
X (setf (ds-options-print-function ds-options)
X (cond ((null print-function) nil)
X ((symbolp print-function) print-function)
X ((and (listp print-function)
X (eq (car print-function) 'lambda)
X (listp (cadr print-function)))
X print-function)
X (t
X (error "The :PRINT-FUNCTION option, ~S~%~
X is not either nil or a function suitable for the~
X function special form."
X print-function)))))
X (setf (ds-options-initial-offset ds-options) initial-offset)
X (setf (ds-options-generate-accessors ds-options) generate-accessors)
X ds-options))
X
X;;;
X;;;
X
X(defvar *slotd-unsupplied* (list nil))
X
X(defstruct (class-slotd (:include essential-slotd)
X (:type list)
X (:conc-name slotd-)
X (:constructor make-slotd--class)
X (:copier copy-slotd))
X keyword
X (default *slotd-unsupplied*)
X (type *slotd-unsupplied*)
X (read-only *slotd-unsupplied*)
X (accessor *slotd-unsupplied*)
X (allocation *slotd-unsupplied*)
X get-function ;NIL if no :get(put)-function argument was supplied.
X put-function ;Otherwise, a function of two (three)arguments, the
X ;object, the name of the slot (and the new-value).
X )
X
X(defmeth make-slotd ((class basic-class) &rest keywords-and-options)
X (ignore class)
X (apply #'make-slotd--class keywords-and-options))
X
X(defmeth parse-slot-descriptions ((class basic-class) ds-options slot-descriptions)
X (iterate ((slot-description in slot-descriptions))
X (collect (parse-slot-description class ds-options slot-description))))
X
X(defmeth parse-slot-description ((class basic-class) ds-options slot-description)
X (parse-slot-description-internal
X class ds-options slot-description (make-slotd class)))
X
X(defmeth parse-slot-description-internal ((class basic-class) ds-options slot-description slotd)
X (ignore class)
X (let ((conc-name (ds-options-conc-name ds-options))
X (generate-accessors (ds-options-generate-accessors ds-options)))
X #+Lucid (declare (special conc-name generate-accessors))
X (destructuring-bind (name default . args)
X slot-description
X (keyword-bind ((type nil)
X (read-only nil)
X (generate-accessor generate-accessors)
X (allocation :instance)
X (get-function nil)
X (put-function nil)
X
X (accessor nil accessor-p)
X (initform nil) ;ignore
X )
X args
X #+Lucid(declare (special type read-only generate-accessor allocation
X get-function put-function))
X (check-member allocation '(:class :instance :dynamic)
X :test #'eq
X :pretty-name "the :allocation option")
X (setf (slotd-name slotd) name
X (slotd-keyword slotd) (make-keyword name)
X (slotd-default slotd) default
X (slotd-type slotd) type
X (slotd-read-only slotd) read-only
X (slotd-accessor slotd) (if accessor-p
X accessor
X (and generate-accessor
X (if conc-name
X (symbol-append conc-name
X name)
X name)))
X (slotd-allocation slotd) allocation
X (slotd-get-function slotd) (and get-function
X (if (and (consp get-function)
X (eq (car get-function) 'function))
X get-function
X (list 'function get-function)))
X (slotd-put-function slotd) (and put-function
X (if (and (consp put-function)
X (eq (car put-function) 'function))
X put-function
X (list 'function put-function))))
X slotd))))
X
X;;;
X;;; Take two lists of slotds and return t if they describe an set of slots of
X;;; the same shape. Otherwise return nil. Sets of slots are have the same
X;;; same shape if they have they both have the same :allocation :instance
X;;; slots and if those slots appear in the same order.
X;;;
X(defun same-shape-slots-p (old-slotds new-slotds)
X (do ()
X ((and (null old-slotds) (null new-slotds)) t)
X (let* ((old (pop old-slotds))
X (new (pop new-slotds))
X (old-allocation (and old (slotd-allocation old)))
X (new-allocation (and new (slotd-allocation new))))
X ;; For the old and new slotd check all the possible reasons
X ;; why they might not match.
X ;; - One or the other is null means that a slot either
X ;; disappeared or got added.
X ;; - The names are different means that a slot moved
X ;; disappared or go added.
X ;; - If the allocations are different, and one of them
X ;; is :instance then a slot either became or ceased
X ;; to be :allocation :instance.
X (when (or (null old)
X (null new)
X (neq (slotd-name old) (slotd-name new))
X (and (neq old-allocation new-allocation)
X (or (eq old-allocation :instance)
X (eq new-allocation :instance))))
X (return nil)))))
X
X(defmeth slots-with-allocation ((class basic-class) slotds allocation)
X (ignore class)
X (iterate ((slotd in slotds))
X (when (eq (slotd-allocation slotd) allocation)
X (collect slotd))))
X
X(defmeth slots-with-allocation-not ((class basic-class) slotds allocation)
X (ignore class)
X (iterate ((slotd in slotds))
X (unless (eq (slotd-allocation slotd) allocation)
X (collect slotd))))
X
X ;;
X;;;;;; GET-SLOT and PUT-SLOT
X ;;
X;;; Its still too early to fully define get-slot and put-slot since they need
X;;; the meta-braid to work.
X;;;
X;;; But its nice if as part of defining the meta-braid we can define and compile
X;;; code which does get-slots and setfs of get-slots and in order to do this we
X;;; need to have get-slot around. Actually we could do with just the defsetf of
X;;; get-slot but might as well put all 3 here.
X;;;
X;;; The code bootstrap meta-braid defines with get-slot in it is all done with
X;;; defmeth, so these get-slots will all get recompiled once the optimizers
X;;; exist don't worry.
X(defun get-slot (object slot-name)
X (get-slot-using-class (class-of object) object slot-name))
X
X(defun put-slot (object slot-name new-value)
X (put-slot-using-class (class-of object) object slot-name new-value))
X
X(defun setf-of-get-slot (new-value object slot-name)
X (put-slot-using-class (class-of object) object slot-name new-value))
X
X(defsetf get-slot (object slot-name &rest extra-args) (new-value)
X `(setf-of-get-slot ,new-value ,object ,slot-name . ,extra-args))
X
X(defun get-slot-always (object slot-name &optional default)
X (get-slot-using-class (class-of object) object slot-name t default))
X
X(defun put-slot-always (object slot-name new-value)
X (put-slot-using-class (class-of object) object slot-name new-value t))
X
X(defsetf get-slot-always (object slot-name &optional default) (new-value)
X `(put-slot-always ,object ,slot-name ,new-value))
X
X(defun remove-dynamic-slot (object slot-name)
X (remove-dynamic-slot-using-class (class-of object) object slot-name))
X
X
X
X
X ;;
X;;;;;; Actually bootstrapping the meta-braid
X ;;
X;;;
X;;; *meta-braid* is the list from which the initial meta-classes are created.
X;;; The elements look sort of like defstructs. The car of each element is
X;;; the name of the class; the cadr is the defstruct options; the caddr is
X;;; the slot-descriptions.
X;;;
X(defvar *meta-braid*
X '((t
X ((:include ()))
X ())
X (object
X ((:include (t)))
X ())
X (essential-class
X ((:include (object))
X (:conc-name class-))
X ((name nil) ;A symbol, the name of the class.
X (class-precedence-list ()) ;The class's class-precedence-list
X ;see compute-class-precedence-list
X (local-supers ()) ;This class's direct superclasses.
X (local-slots ())
X (direct-subclasses ()) ;All the classes which have this
X ;class on their local-supers.
X (direct-methods ())
X ))
X (basic-class
X ((:include (essential-class))
X (:conc-name class-))
X ((no-of-instance-slots 0) ;The # of slots with :allocation :instance
X ;in an instance of this class.
X (instance-slots ()) ;The slotds of those slots.
X (non-instance-slots ()) ;The declared slots with :allocation other
X ;than :instance. instance-slots + non-
X ;instance-slots = all-slots.
X (wrapper nil) ;The class-wrapper which instances of
X ;this class point to.
X (direct-discriminators ())
X (discriminators-which-combine-methods ())
X (prototype nil :get-function (lambda (c slot-name)
X (ignore slot-name)
X (or (get-slot c 'prototype)
X (setf (get-slot c 'prototype)
X (make c)))))
X (ds-options ())))
X (class
X ((:include (basic-class)))
X ())))
X
X;;;
X;;; *bootstrap-slots* is a list of the slotds corresponding to the slots of class
X;;; class with :allocation :instance. It is used by bootstrap-get-slot during the
X;;; bootstrapping of the meta-braid.
X;;;
X(defvar *bootstrap-slots*)
X
X(defmacro bootstrap-get-slot (iwmc-class slot-name)
X `(get-static-slot--class ,iwmc-class
X (%convert-slotd-position-to-slot-index
X (slotd-position ,slot-name *bootstrap-slots*))))
X
X(defun bootstrap-initialize (iwmc-class name includes local-slots
X prototype wrapper ds-options)
X (let ((cpl ())
X (all-slots ())
X (instance-slots ()))
X (setf (bootstrap-get-slot iwmc-class 'name) name)
X (setf (bootstrap-get-slot iwmc-class 'local-supers)
X (iterate ((i in includes)) (collect (class-named i))))
X (setf (bootstrap-get-slot iwmc-class 'class-precedence-list)
X (setq cpl (bootstrap-compute-class-precedence-list iwmc-class)))
X (setq all-slots (append (iterate ((super in (reverse (cdr cpl))))
X (join (bootstrap-get-slot super 'local-slots)))
X local-slots))
X (setf (bootstrap-get-slot iwmc-class 'instance-slots)
X (setq instance-slots (slots-with-allocation () all-slots :instance)))
X (setf (bootstrap-get-slot iwmc-class 'non-instance-slots)
X (slots-with-allocation-not () all-slots :instance))
X (setf (bootstrap-get-slot iwmc-class 'no-of-instance-slots)
X (length instance-slots))
X (setf (bootstrap-get-slot iwmc-class 'local-slots) local-slots)
X (setf (bootstrap-get-slot iwmc-class 'direct-discriminators) ())
X (setf (bootstrap-get-slot iwmc-class 'direct-methods) ())
X (setf (bootstrap-get-slot iwmc-class 'prototype) prototype)
X (setf (bootstrap-get-slot iwmc-class 'wrapper) wrapper)
X (setf (bootstrap-get-slot iwmc-class 'ds-options) ds-options)))
X
X(defun bootstrap-compute-class-precedence-list (class)
X ;; Used by define-meta-braid to compute the class-precedence-list of a class.
X (let ((local-supers (bootstrap-get-slot class 'local-supers)))
X (cons class
X (and local-supers
X (iterate ((ls in local-supers))
X (join (bootstrap-compute-class-precedence-list ls)))))))
X
X;;; bootstrap-meta-braid sets *bootstrap-slots* and builds the meta-braid.
X;;; Note that while it is somewhat general-purpose and driven off of *meta-braid*,
X;;; it has several important built-in assumptions about the meta-braid.
X;;; Namely:
X;;; - The class of every class in the meta-braid is class.
X;;; - The class class inherits its slots from every other class in the
X;;; meta-braid. Put another way, bootstrap-meta-braid figures out the
X;;; slots of class by appending the slots of all the other classes
X;;; in the meta-braid.
X;;;
X(defmacro bootstrap-meta-braid ()
X ;; Parse *meta-braid* and setup *bootstrap-slots* so that we can call
X ;; bootstrap-get-slot to fill in the slotds of the classes we create.
X (let* ((meta-braid
X (iterate ((classd in *meta-braid*))
X (let* ((name (car classd))
X (ds-options (parse-defstruct-options ()
X name
X (cadr classd)))
X (slotds (parse-slot-descriptions ()
X ds-options
X (caddr classd))))
X (collect (list name ds-options slotds)))))
X (all-slots-of-class-class
X (iterate ((classd in meta-braid))
X (join (caddr classd)))))
X (setq *bootstrap-slots* (slots-with-allocation ()
X all-slots-of-class-class
X :instance))
X `(progn
X (setq *bootstrap-slots* ',*bootstrap-slots*)
X ;; First make the class class. It is the class of all the classes in
X ;; the metabraid so we need it and a wrapper of it so that we can set
X ;; the wrapped class field of the other metaclasses as we make them.
X (let* ((class-class
X (%allocate-class-class ,(length *bootstrap-slots*)))
X (wrapper-of-class-class (make-class-wrapper class-class)))
X ,@(iterate ((classd in meta-braid))
X (collect
X (destructuring-bind (met-name met-ds-options met-slotds)
X classd
X (let ((met-includes (ds-options-includes met-ds-options)))
X `(let* ((name ',met-name)
X (includes ',met-includes)
X (ds-options ',met-ds-options)
X (slotds ',met-slotds)
X (class ,(if (eq met-name 'class)
X 'class-class
X `(%allocate-instance--class
X ,(length *bootstrap-slots*)
X (class-named 'class))))
X (class-wrapper ,(if (eq met-name 'class)
X 'wrapper-of-class-class
X '(make-class-wrapper class))))
X (setf (iwmc-class-class-wrapper class)
X wrapper-of-class-class)
X (setf (class-named name) class)
X (bootstrap-initialize class
X name
X includes
X slotds
X (if (eq class class-class)
X class
X ())
X class-wrapper
X ds-options))))))
X (let ((class-cpl (bootstrap-get-slot class-class
X 'class-precedence-list)))
X (iterate ((sub in class-cpl)
X (sup in (cdr class-cpl)))
X (push sub (bootstrap-get-slot sup 'direct-subclasses)))))
X ;; CLASS-INSTANCE-SLOTS has to be defined specially!
X ;; It cannot be defined in terms of get-slot since it is the method
X ;; that the get-slot mechanism (actually get-slot-using-class) appeals
X ;; to to find out what slots are in an instance of a particular class.
X ;;
X ;; The fact that class-instance-slots is defined specially this way
X ;; means that any change to the class class which changes the location
X ;; of the instance-slots slot must redefine and recompile
X ;; class-instance-slots.
X (defun class-instance-slots (class)
X (get-static-slot--class class
X ,(%convert-slotd-position-to-slot-index
X (slotd-position 'instance-slots *bootstrap-slots*))))
X (defun class-non-instance-slots (class)
X (get-static-slot--class class
X ,(%convert-slotd-position-to-slot-index
X (slotd-position 'non-instance-slots *bootstrap-slots*))))
X ;; Now define the other accessors and :setf methods for those
X ;; accessors.
X ,@(iterate ((classd in meta-braid))
X (destructuring-bind (name () slotds) classd
X (join
X (iterate ((slotd in slotds))
X (let* ((slot-name (slotd-name slotd))
X (accessor-name (slotd-accessor slotd)))
X (unless (memq slot-name '(instance-slots
X non-instance-slots))
X (collect
X `(defmeth ,accessor-name ((,name ,name))
X (funcall ,(or (slotd-get-function slotd)
X ''get-slot)
X ,name
X ',(slotd-name slotd)))))
X (collect
X `(defmeth (,accessor-name (:setf (.new_value.)))
X ((,name ,name))
X (funcall ,(or (slotd-put-function slotd) ''put-slot)
X ,name
X ',(slotd-name slotd)
X .new_value.))))))))
X t)))
X
X
X(eval-when (eval load)
X (clrhash *class-name-hash-table*)
X (bootstrap-meta-braid)
X (recompile-class-of))
X
X(defmeth class-slots ((class class))
X (append (class-non-instance-slots class)
X (class-instance-slots class)))
X
X(defmeth (class-direct-methods (:setf (nv))) ((class class))
X (setf (get-slot class 'direct-methods) nv)
X (dolist (m nv) (pushnew (method-discriminator m)
X (get-slot class 'direct-discriminators))))
X
END_OF_FILE
if test 34250 -ne `wc -c <'braid.l'`; then
echo shar: \"'braid.l'\" unpacked with wrong size!
fi
# end of 'braid.l'
fi
echo shar: End of archive 10 \(of 13\).
cp /dev/null ark10isdone
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