PDP-10.its/src/lspsrc/extstr.97

;;;   EXTSTR			-*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;;   ****************************************************************
;;;   *** MACLISP **** EXTended datatype scheme, basic STRuctures ****
;;;   ****************************************************************
;;;   ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;;   ****************************************************************

(herald EXTSTR /97)

(eval-when (eval compile)
  (or (get 'SUBLOAD 'VERSION)
      (load '((lisp) subload)))
  (subload EXTBAS)
  (subload EXTMAC)
  (subload EXTEND)
  ;; This would like to be a SUBLOAD of VECTOR, but this way it's not circular
  (defmacro VSET (v n val) `(SI:XSET ,v ,n ,val))
 )

;;; Wherein we build HUNKs for each class that will be directly pointed to
;;; by classes defined by DEFVST.  We leave out the interconnections between
;;; classes, to help printing of objects defined by DEFVST.  Loading EXTEND
;;; will supply the missing interconnections.

;;; We also define the basic CLASS creator, SI:DEFCLASS*-2 a sub-primitive that
;;; gives a skeletal class.  This class can then be filled in by calling
;;; SI:INITIALIZE-CLASS (from EXTEND)



(defvar SI:SKELETAL-CLASSES () "At least it wont be unbound in Old lisps")

;;; SI:EXTSTR-SETUP-CLASSES is set up by EXTMAC, and includes things
;;;  like CLASS-CLASS  OBJECT-CLASS STRUCT=INFO-CLASS STRUCT-CLASS VECTOR-CLASS
(declare #.`(SPECIAL ,.si:extstr-setup-classes))

(setq-if-unbound CLASS-CLASS () "Will be set up, at some pain, in this file")
(setq-if-unbound OBJECT-CLASS () "Will be set up, at some pain, in this file")


(declare (own-symbol **SELF-EVAL** SI:DEFCLASS*-2 SI:DEFVST-BARE-INIT))


(defun SI:SELF-QUOTIFY (x) `',x)

(eval-when (eval compile load)
    ;; So that we can easily tell classes apart from random extends
  (defvar SI:CLASS-MARKER '**CLASS-SELF-EVAL**)
  (and (status feature COMPLR)
       (*lexpr SI:DEFCLASS*-2 SI:DEFVST-BARE-INIT))
)

(defprop **SELF-EVAL**     SI:SELF-QUOTIFY MACRO)
(defprop #.SI:CLASS-MARKER SI:SELF-QUOTIFY MACRO)	;**CLASS-SELF-EVAL** 



;;;; SI:DEFCLASS*-2

(defun SI:DEFCLASS*-2 (name typep var superiors 
			    &optional source-file class 
			    &rest ignore )
  (cond ((cond ((null class))
	       ((not (classp class))
		(+internal-lossage 'CLASS 'SI:DEFCLASS*-2 class)
		'T))
	   ;;Note that at initial boot-strap phase, CLASS-CLASS may not exist,
	   ;; but either function -- si:make-extend or si:make-random-extend --
	   ;; will be open-coded by COMPLR
	  (setq class (si:make-random-extend #.si:class-instance-size 
					     CLASS-CLASS))
	  (setf (si:extend-marker-of class) SI:CLASS-MARKER)
	  (setf (si:class-typep class) typep)
	  (setf (si:class-plist class) (ncons name))
	  (setf (si:class-name class) name)))
  (if source-file 
      (setf (get (si:class-plist class) ':SOURCE-FILE) source-file))
  (if var 
      (setf (si:class-var (set var class)) var))
  (cond ((fboundp 'SI:INITIALIZE-CLASS)
	  (setf (si:class-superiors class) superiors) 
	  (si:initialize-class class))
	('T (push `(,class ,superiors) SI:SKELETAL-CLASSES)
	    (setf (si:extend-class-of class) () )
	    (if (boundp 'PURCOPY) (push class PURCOPY))))
  (putprop name class 'CLASS)
  class)

;;;Move &OPTIONAL to after VERSION once old files are flushed (after
;;;  defvst-version 1 is gone).  July 4, 1981  -- JonL --
;;;See also the similar comments in DEFVSY.

(defun SI:DEFVST-BARE-INIT (name var-name cnsn size inis  
				 &optional (version 1) source-file class sinfo
				 &rest ignore)
  (if (pairp inis)
       ;; a slight open-coding of TO-VECTOR  for (SETQ INIS (TO-VECTOR INIS))
      (setq inis (let ((ln (length inis)))
		   (declare (fixnum ln))
		   (do ((v (si:make-extend ln VECTOR-CLASS))
			(i 0 (1+ i))
			(l inis (cdr l)))
		       ((= i ln) v)
		     (declare (fixnum i))
		     (vset v i (car l))))))
  (if (null class) 
      (setq class (or (get name 'CLASS)
		      (si:defclass*-2 name 
				      name 
				      var-name
				      (list STRUCT-CLASS)
				      source-file))))
  (if (null sinfo) 
      (setq sinfo (si:extend STRUCT=INFO-CLASS
			     version 
			     name 
			     cnsn 
			     size
			     inis 
			     class)))
  (putprop name sinfo 'STRUCT=INFO) 
    ;;The STRUCT=INFO property can always be found on the plist of the 'name'
    ;; of the structure (and consequently the 'name' of the class)
    ;;So I've the following line optional, so that it doesn't cause
    ;;  a printing circularity when EXTEND isn't loaded.
  (if (get 'EXTEND 'VERSION)
      (setf (get (si:class-plist class) 'STRUCT=INFO) sinfo)))

;; Setup basics of CLASS hierarchy, if not already done so.  DEFVAR
;;  at beginning of this file ensures that CLASS-CLASS has a value.
(and (null CLASS-CLASS)
     (let (y x)
       (mapc #'(lambda (z)
		 (desetq (x y z) z) 
		 (si:defclass*-2 x x y (if z (list (symeval z)))))
	     '((OBJECT      OBJECT-CLASS      () )
	       (CLASS       CLASS-CLASS       OBJECT-CLASS)
	       (SEQUENCE    SEQUENCE-CLASS    OBJECT-CLASS)
	       (VECTOR      VECTOR-CLASS      SEQUENCE-CLASS) 
	       (STRUCT      STRUCT-CLASS      OBJECT-CLASS)
	       (STRUCT=INFO STRUCT=INFO-CLASS STRUCT-CLASS)))))

;; The following is an open-coding of part of the result of CONS-A-STRUCT=INFO.

(si:defvst-bare-init 
    'STRUCT=INFO 
    'STRUCT=INFO-CLASS 
    'CONS-A-STRUCT=INFO 
    6 
    '( ()						;&REST info
      (VERS STRUCT=INFO-VERS SI:STRUCT=INFO-VERSION )	;1st key
      (NAME STRUCT=INFO-NAME () )			;2nd
      (CNSN STRUCT=INFO-CNSN () )			;3nd
      (SIZE STRUCT=INFO-SIZE 0 )			;4rd
      (INIS STRUCT=INFO-INIS () )			;5th
      (CLSS STRUCT=INFO-CLSS STRUCT=INFO-CLASS) 	;6th
      )
    2)					;Version

(eval-when (eval compile)
(defmacro GEN-SOURCE-FILE-ADDENDA ()
  (if (filep infile)
      `(MAPC #'(LAMBDA (CLASS)
		       (SETF (GET (SI:CLASS-PLIST CLASS) ':SOURCE-FILE)
			     ',(namestring (truename infile))))
	     (LIST CLASS-CLASS OBJECT-CLASS VECTOR-CLASS STRUCT-CLASS
		   STRUCT=INFO-CLASS SEQUENCE-CLASS))))
)

(gen-source-file-addenda)

(if (status feature COMPLR)
    (subload EXTHUK))