LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032813. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "BRAID1" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388045. :AUTHOR "REL3" :LENGTH-IN-BYTES 8226. :LENGTH-IN-BLOCKS 9. :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.(in-package 'pcl)(eval-when (compile load eval)(defun early-collect-inheritance (class-name)  (declare (values slots cpl direct-subclasses))  (multiple-value-bind (slots cpl)      (early-collect-inheritance-1 class-name)    (values slots    cpl     (iterate ((defclass in *early-defclass-forms*))      (when (memq class-name (caddr defclass))(collect (cadr defclass)))))))(defun early-collect-inheritance-1 (class-name)  (let ((defclass (find class-name *early-defclass-forms* :key #'cadr)))    (unless defclass      (error "~S is not a class in *early-defclass-forms*." class-name))    (destructuring-bind (includes slots . options) (cddr defclass)      (when options(error "options not supported in *early-defclass-forms*."))      (when (cdr includes)(error "multiple supers not allowed in *early-defclass-forms*."))      (if includes  (multiple-value-bind (super-slots super-cpl)      (early-collect-inheritance-1 (car includes))    (values (append super-slots slots)    (cons class-name super-cpl)))  (values slots  (list class-name))))))(defvar *std-class-slots* (early-collect-inheritance 'class))(defvar *std-slotd-slots* (early-collect-inheritance 'standard-slotd))(defconstant class-instance-slots-position     (position 'instance-slots *std-class-slots* :key #'car))(defconstant slotd-name-position     (position 'name *std-slotd-slots* :key #'car)));eval-when;;; CLASS-INSTANCE-SLOTS and SLOTD-NAME have to be defined specially!;;;;;; They cannot be defined using slot-value-using-class like all the other;;; accessors are.  This is because slot-value-using-class itself must call;;; CLASS-INSTANCE-SLOTS and SLOTD-NAME to do the slot access.;;;;;; This 'bottoming out' of the run-time slot-access code will be replaced;;; by a corresponding bootstrapping constraint when permutation vectors;;; happen.(defun class-instance-slots (class)  (get-static-slot--class class  (%convert-slotd-position-to-slot-index    class-instance-slots-position)))(defun set-class-instance-slots (class new-value)  (setf (get-static-slot--class class(%convert-slotd-position-to-slot-index  class-instance-slots-position))new-value))(defun slotd-name (slotd)  (get-static-slot--class slotd  (%convert-slotd-position-to-slot-index    slotd-name-position)))(defun set-slotd-name (slotd new-value)  (setf (get-static-slot--class slotd(%convert-slotd-position-to-slot-index  slotd-name-position))new-value));;;;;;;;;(defun bootstrap-get-slot (type object slot-name)  (get-static-slot--class object  (%convert-slotd-position-to-slot-index    (position slot-name      (ecase type(class *std-class-slots*)(slotd *std-slotd-slots*))      :key #'car))))(defun bootstrap-set-slot (type object slot-name new-value)  (setf (get-static-slot--class  object  (%convert-slotd-position-to-slot-index     (position slot-name      (ecase type(class *std-class-slots*)(slotd *std-slotd-slots*))      :key #'car)))new-value));;; bootstrap-meta-braid;;;   (defun bootstrap-meta-braid ()  (let* ((std-class-size (length *std-class-slots*)) (std-class (%allocate-instance--class std-class-size)) (std-class-wrapper (make-class-wrapper std-class)) (std-slotd (%allocate-instance--class std-class-size)) (std-slotd-wrapper (make-class-wrapper std-slotd)))    ;; First get all the class objects in place.    (dolist (early-defclass *early-defclass-forms*)      (let* ((name (cadr early-defclass))     (class (case name      (class std-class)      (standard-slotd std-slotd)      (otherwise(%allocate-instance--class std-class-size)))))(setf (iwmc-class-class-wrapper class) std-class-wrapper)(setf (class-named name) class)))    ;; Now initialize those classes.        (dolist (early-defclass *early-defclass-forms*)            (multiple-value-bind (instance-slots cpl direct-subclasses)  (early-collect-inheritance (cadr early-defclass))(let* ((name (cadr early-defclass))       (includes (caddr early-defclass))       (local-slots (cadddr early-defclass))       (class (class-named name))       (wrapper (if (eq class std-class)    std-class-wrapper    (make-class-wrapper class)))       (proto nil))    (setq proto (%allocate-instance--class (length instance-slots)))  (setf (iwmc-class-class-wrapper proto) wrapper)  (setq local-slots (bootstrap-parse-slots local-slots   std-slotd-wrapper))  (setq instance-slots (bootstrap-parse-slots instance-slots   std-slotd-wrapper))  (bootstrap-initialize class name includes local-slotsinstance-slots cpl direct-subclasseswrapper proto)    (do-type-predicate-definition class name)  (dolist (slotd instance-slots)    (do-accessor-definitions-internal      class      name      slotd      (bootstrap-get-slot 'slotd slotd 'accessors)      (bootstrap-get-slot 'slotd slotd 'readers))))))))  (defun bootstrap-initialize       (c name includes local-slots slots cpl subs wrapper proto)  (flet ((classes (names) (mapcar #'class-named names)))    (bootstrap-set-slot 'class c 'name name)    (bootstrap-set-slot 'class c 'class-precedence-list (classes cpl))    (bootstrap-set-slot 'class c 'local-supers (classes includes))    (bootstrap-set-slot 'class c 'local-slots local-slots)    (bootstrap-set-slot 'class c 'direct-subclasses (classes subs))    (bootstrap-set-slot 'class c 'direct-methods ())    (bootstrap-set-slot 'class c 'no-of-instance-slots (length slots))    (bootstrap-set-slot 'class c 'instance-slots slots)    (bootstrap-set-slot 'class c 'non-instance-slots ())    (bootstrap-set-slot 'class c 'wrapper wrapper)    (bootstrap-set-slot 'class c 'direct-generic-functions ())    (bootstrap-set-slot 'class c 'generic-functions-which-combine-methods ())    (bootstrap-set-slot 'class c 'prototype proto)))(defun bootstrap-parse-slots (slots std-slotd-wrapper)  (mapcar #'(lambda (slot) (bootstrap-parse-slot slot std-slotd-wrapper))  slots))(defun bootstrap-parse-slot (slot std-slotd-wrapper)  (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))    (setf (iwmc-class-class-wrapper slotd) std-slotd-wrapper)    (let ((name (pop slot))  (initform nil)  (accessors ())  (type 't))      (loop (when (null slot) (return t))    (ecase (car slot)      (:initform (setq initform (cadr slot)))      (:accessor (push (cadr slot) accessors))      (:type (setq type (cadr slot))))    (setq slot (cddr slot)))      (bootstrap-set-slot 'slotd slotd 'name name)      (bootstrap-set-slot 'slotd slotd 'keyword (make-keyword name))      (bootstrap-set-slot 'slotd slotd 'accessors accessors)      (bootstrap-set-slot 'slotd slotd 'readers ())      (bootstrap-set-slot 'slotd slotd 'allocation ':instance)      (bootstrap-set-slot 'slotd slotd 'type type)          slotd)))(eval-when (eval load)  (clrhash *class-name-hash-table*)  (bootstrap-meta-braid)  (precompile-class-of)) ,form)(eval-when (load eval) (,dummy-name)))))(defun defmethod-1 (gf-name specializers arglist qualifiers documentation uid fn)  (record-definition gf-name 'method specializers qualifiers)  (let ((method  (or (and (boundp uid) (symbol-value uid))      (set uid (LOAD-METHOD-1 gf-name      specializers      arglist      qualifiers      documentation)))))    (INSTALL-METHOD-FUNCTION-1 gf-name method fn)    (ADD-METHOD (symbol-function gf-name) method nil)    method))(defun wrap-method-body (mex-generic-function mex-method generic-function-name method-uid load-method-1-args body)  (let ((macroexpand-time-information (list mex-generic-function    mex-method    generic-function-name    method-uid    load-method-1-args)))    `(macrolet ,(iterate (((name arglist params fn) in *method-body-macros*))  (collect `(,name ,arglist       (funcall (function ,fn)',macroexpand-time-information