LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032811. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "BRAID0" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388036. :AUTHOR "REL3" :LENGTH-IN-BYTES 4852. :LENGTH-IN-BLOCKS 5. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-;;;;;; *************************************************************************;;; Copyright (c) 1985, 1986, 1987 Xerox Corporation.  All rights reserved.;;;;;; Use and copying of this software and preparation of derivative works;;; based upon this software are permitted.  Any distribution of this;;; software or derivative works must comply with all applicable United;;; States export control laws.;;; ;;; This software is made available AS IS, and Xerox Corporation makes no;;; warranty about the software, its performance or its conformity to any;;; specification.;;; ;;; Any person obtaining a copy of this software is requested to send their;;; name and post office or electronic mail address to:;;;   CommonLoops Coordinator;;;   Xerox Artifical Intelligence Systems;;;   2400 Hanover St.;;;   Palo Alto, CA 94303;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa);;;;;; Suggestions, comments and requests for improvements are also welcome.;;; *************************************************************************;;;;;; The meta-braid and defstruct.;;;;;; NOTE: This file must be loaded before it can be compiled.(in-package 'pcl);;;;;; *meta-braid* is the list from which the initial meta-classes are created.;;; The elements look sort of like defstructs.  The car of each element is;;; the name of the class;  the cadr is the defstruct options;  the caddr is;;; the slot-descriptions.;;;(eval-when (compile load eval)  (defvar *early-defclass-forms*  '(    (defclass t () ())    (defclass object (t) ())    (defclass essential-class (object) ((name    :initform nil    :accessor class-name)  (class-precedence-list    :initform ()    :accessor class-precedence-list    :accessor class-class-precedence-list)  (local-supers    :initform ()    :accessor class-local-supers)  (local-slots    :initform ()    :accessor class-local-slots)  (direct-subclasses    :initform ()    :accessor class-direct-subclasses)  (direct-methods    :initform ())))    (defclass basic-class (essential-class) ((no-of-instance-slots    :initform 0    :accessor class-no-of-instance-slots)  (instance-slots    :initform ())  (non-instance-slots    :initform ()    :accessor class-non-instance-slots)  (wrapper    :initform nil    :accessor class-wrapper)  (direct-generic-functions    :initform ()    :accessor class-direct-generic-functions)  (generic-functions-which-combine-methods    :initform ()    :accessor class-generic-functions-which-combine-methods)  (prototype    :initform nil)  (ds-options    :initform ()    :accessor class-ds-options)))    (defclass class (basic-class) ())    (defclass standard-slotd (object) ((name    :initform nil)  (keyword    :initform nil    :accessor slotd-keyword)  (initform    :initform nil    :accessor slotd-initform)  (accessors    :initform nil    :accessor slotd-accessors)  (readers    :initform nil    :accessor slotd-readers)  (allocation    :initform nil    :accessor slotd-allocation)  (type    :initform nil    :accessor slotd-type)))          )));eval-when;;;;;; This should probably be moved into MACROS and documented as being able;;; to be redefined by particular ports which have some more effecient way;;; of telling the environment about this.;;; COMMON LISP BUG:;;;    In addition to reifying Compile Time Environments, Common Lisp;;;    should have something like set-setf-method.;;;(eval-when (compile load eval)(defmacro do-defmethod-setf-defsetf (generic-function-name arglist)  `(defsetf ,generic-function-name    ,arglist    (new-value)     `(,',(make-setf-generic-function-name generic-function-name)       ,new-value       ,,@arglist)))(defun type-predicate-name (class-name)  (intern (string-append class-name " type predicate")))(defmacro bootstrap-meta-braid-macro-definitions ()  (let ((accessors ()))    (dolist (defclass *early-defclass-forms*)      (dolist (slot (cadddr defclass))(let ((slot-options (cdr slot)))  (loop (when (null slot-options) (return t))(when (eq (car slot-options) ':accessor)  (push (cadr slot-options) accessors))(setq slot-options (cddr slot-options))))))    `(progn ,@(mapcar #'(lambda (accessor)  `(do-defmethod-setf-defsetf ,accessor (class)))      accessors)    ,@(mapcar #'(lambda (defclass)  (let ((name (cadr defclass)))    (unless (eq name 't)      `(deftype ,name () '(satisfies ,(type-predicate-name name))))))      *early-defclass-forms*)))))(eval-when (load eval)  (bootstrap-meta-braid-macro-definitions))(defsetf class-instance-slots set-class-instance-slots)(defsetf slotd-name set-slotd-name) (car cdr-of-form)))      (return (setq qualifiers (nreverse qualifiers)))      (push (pop cdr-of-form) qualifiers)))    (setq arglist (pop cdr-of-form))    (when setfp      (setq setf-arglist (pop cdr-of-form))      ;; For the time being, no lambda-list keywo