;;;-*-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.
;;;
;;; The defsetfs for these set-xxx functions are in defs.
;;;
(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))
;;;
;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
;;; the values of slots during bootstrapping. During bootstrapping, there
;;; are only two kinds of objects whose slots we need to access, CLASSes
;;; and SLOTDs. The first argument to these functions tells whether the
;;; object is a CLASS or a SLOTD.
;;;
(defun bootstrap-get-slot (type object slot-name)
(get-static-slot--class object (bootstrap-slot-index type slot-name)))
(defun bootstrap-set-slot (type object slot-name new-value)
(setf (get-static-slot--class object (bootstrap-slot-index type slot-name))
new-value))
(defun bootstrap-slot-index (type slot-name)
(let ((position 0)
(slots (ecase type
(class *std-class-slots*)
(slotd *std-slotd-slots*))))
;; This loop is a hand coded version of:
;;
;; (setq position (position slot-name slots :key #'car))
;;
(loop (cond ((eq (caar slots) slot-name) (return t))
((null slots) (error "~S not found" slot-name))
(t (pop slots) (incf position))))
(%convert-slotd-position-to-slot-index position)))
;;;
;;; 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, make a class object for each of the early classes.
;;
(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 go back and 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-slots
instance-slots cpl direct-subclasses
wrapper proto)
(unless (eq name 't)
(inform-type-system-about-class class name))
(dolist (slotd local-slots)
(bootstrap-accessor-definitions
name
(slotd-name slotd)
(bootstrap-get-slot 'slotd slotd 'accessors)
(bootstrap-get-slot 'slotd slotd 'readers))))))))
(defun bootstrap-accessor-definitions (class-name slot-name accessors readers)
(let ((reader-constructor
(get-templated-function-constructor 'reader-function--std-class))
(writer-constructor
(get-templated-function-constructor 'writer-function--std-class
nil)))
(flet ((do-reader-definition (accessor)
(add-method
(ensure-generic-function accessor)
(make-a-method 'standard-reader-method
()
(list class-name)
(list class-name)
(funcall reader-constructor slot-name)
"automatically generated reader method"
slot-name)))
(do-writer-definition (accessor)
(add-method
(ensure-generic-function `(SETF ,accessor))
(make-a-method 'standard-writer-method
()
(list class-name 'new-value)
(list class-name 'T)
(funcall writer-constructor slot-name t)
"automatically generated writer method"
slot-name))))
(dolist (accessor accessors)
(do-reader-definition accessor)
(do-writer-definition accessor))
(dolist (reader readers)
(do-reader-definition reader)))))
(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 ())
(readers ())
(type 't))
(loop (when (null slot) (return t))
(ecase (car slot)
(:initform (setq initform (cadr slot)))
(:accessor (push (cadr slot) accessors))
(:reader (push (cadr slot) readers))
(: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 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))
;;;
;;;
;;;
(defmethod print-object ((instance object) stream depth)
(declare (ignore depth))
(printing-random-thing (instance stream)
(format stream "Standard-Instance")))
;(defmethod print-object ((instance object) stream depth)
; (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
; (format stream "#S(~S" (class-name (class-of instance)))
; (iterate ((slot-or-value in (all-slots instance))
; (slotp = t (not slotp)))
; (when (numberp length)
; (cond ((<= length 0) (format stream " ...") (return ()))
; (t (decf length))))
; (princ " " stream)
; (let ((*print-level* (cond ((null *print-level*) ())
; (slotp 1)
; (t (- *print-level* depth)))))
; (if (and *print-level* (<= *print-level* 0))
; (princ "#" stream)
; (prin1 slot-or-value stream))))
; (princ ")" stream)))
(defmethod print-object ((class essential-class) stream depth)
(named-object-print-function class stream depth))
(defmethod print-object ((slotd standard-slotd) stream depth)
(named-object-print-function slotd stream depth))