;;; DEFVST -*-Mode:Lisp;Package:SI-*- ;;; ************************************************************************* ;;; ***** NIL ****** NIL/MACLISP/LISPM Structure Definer ******************** ;;; ************************************************************************* ;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ******* ;;; ************ this is a read-only file! (all writes reserved) ************ ;;; ************************************************************************* ;;; Acronym for "DEFine a Vector-like STructure" ;;; For documentation and examples, see the file LIBDOC;DEFVST DOC on the ;;; various ITS systems, and LISP:DEFVST.DOC on TOPS10/20 systems. ;;; For MacLISP, to compile NADEFVST (version to use in NIL-aided MacLISP), ;;; just load the SHARPC module, and set TARGET-FEATURES to 'NILAID (herald DEFVST /164) (eval-when (eval compile) (or (get 'SUBLOAD 'VERSION) (load '((lisp) subload))) #-NIL (subload SHARPCONDITIONALS) ) ;;Remember: a NILAID also will be a MacLISP #+(or LISPM (and NIL (not MacLISP))) (progn (globalize "DEFVST") (globalize "CONSTRUCTOR-NAMESTRING-PREFIX") (globalize "SELECTOR-NAMESTRING-STYLE") ) ;; Load DEFVSX and DEFMAX now to get their "globalizations" ;; Load EXTEND before DEFVSX so that CLASS system will be available #-NIL (eval-when (eval compile load) (subload EXTEND) (subload VECTOR) (subload DEFVSX) ;Will subload DEFMAX and DEFVSY ) #-(local NIL) (eval-when (eval compile) (subload EXTEND) ;Bring these guys in before DEFVSX, (subload EXTMAC) ; so that the CLASS system will be (subload VECTOR) ; alive by then. (subload DEFVSX) ;Loading DEFVSX will also do ; (subload DEFMAX) ; (subload DEFVSY) (subload DEFSETF) (subload UMLMAC) ) (declare (special DEFMACRO-DISPLACE-CALL CONSTRUCTOR-NAMESTRING-PREFIX SELECTOR-NAMESTRING-STYLE STRUCT-CLASS STRUCT=INFO-CLASS |defvst-typchk/|| |defvst-construction/||) #+MacLISP (*lexpr TO-VECTOR)) #+MacLISP (eval-when (eval compile load) (cond ((status feature COMPLR) (*expr |defvst-construction/|| |defvst-construction-1/|| |defvst-typchk/||) (*lexpr |defvst-initialize/||))) ) (MAPC '(LAMBDA (X Y) (AND (NOT (BOUNDP X)) (SET X Y))) '(SELECTOR-NAMESTRING-STYLE CONSTRUCTOR-NAMESTRING-PREFIX ) '(|-| |CONS-A-| )) #+(and MacLISP NIL) (include #+(local ITS) ((NILCOM) DEFVSY >) #-(local ITS) ((LISP) DEFVSY LSP)) #+(and MacLISP NIL) (include #+(local ITS) ((NILCOM) DEFVSX >) #-(local ITS) ((LISP) DEFVSX LSP)) #+(local MacLISP) (eval-when (compile) (defprop DEFVST T SKIP-WARNING) ;; FOO! to prevent circularities when compiling (do ((i 0 (1+ i)) (l '(VERS NAME CNSN SIZE INIS CLSS) (cdr l)) (z)) ((null l)) (setq z (symbolconc 'STRUCT=INFO- (car l))) (eval `(DEFMACRO ,z (X) `(SI:XREF ,X ,,i)))) ) ;;;; DEFVST macro (defmacro (DEFVST defmacro-displace-call () ) (sname &rest selkeys &whole form) (LET ((NKEYS 0) (SELECTOR-NAMESTRING-STYLE SELECTOR-NAMESTRING-STYLE) (CONSTRUCTOR-NAMESTRING-PREFIX CONSTRUCTOR-NAMESTRING-PREFIX) (OUTPUT-SELECTOR-MACROS 'T) CONSTRUCTOR-NAME RESTKEY RESTSIZEFORM RESTP SELINIS MAC-ARG-NM SNAME-CLASS-VAR TMP OPTION-LIST ) (DECLARE (FIXNUM I NKEYS)) (COND ((NOT (ATOM SNAME)) (SETQ OPTION-LIST (CDR SNAME)) (SETQ SNAME (CAR SNAME)) (IF (ASSQ 'NO-SELECTOR-MACROS OPTION-LIST) (SETQ OUTPUT-SELECTOR-MACROS () )))) (AND (OR (NULL SNAME) (NOT (SYMBOLP SNAME))) (ERROR "Bad name arg - DEFVST" FORM)) (SETQ SNAME-CLASS-VAR (SYMBOLCONC SNAME '-CLASS)) (SETQ NKEYS (LENGTH SELKEYS)) (COND ((SETQ TMP (MEMQ '&REST SELKEYS)) (SETQ NKEYS (- NKEYS (LENGTH TMP)) RESTKEY (CADR TMP) RESTSIZEFORM (CADDR TMP)) (AND (OR (NOT (SYMBOLP RESTKEY)) (NULL RESTSIZEFORM)) (ERROR "Bad &REST item - DEFVST" SELKEYS)))) (COND ((GET SNAME 'STRUCT=INFO) (TERPRI MSGFILES) (PRINC "Warning! Redefining the STRUCTURE " MSGFILES) (PRIN1 SNAME MSGFILES))) (SETQ MAC-ARG-NM (SYMBOLCONC SNAME '|-MACRO-ARG|)) (SETQ CONSTRUCTOR-NAME (COND ((SETQ TMP (ASSQ 'CONSTRUCTOR OPTION-LIST)) (CADR TMP)) ('T (SYMBOLCONC CONSTRUCTOR-NAMESTRING-PREFIX SNAME)))) ;RESTP and SELINIS start out null here (DO ( (I 1 (1+ I)) (L SELKEYS (CDR L)) INIFORM TYP /=-/:-COUNT KEYNM SELNM ) ( (OR (NULL L) RESTP) ) (COND ((ATOM (SETQ KEYNM (CAR L))) (COND ((EQ KEYNM '&REST) (SETQ KEYNM RESTKEY RESTP 'T) (AND (NOT (EQ RESTKEY (CADR L))) (+INTERNAL-LOSSAGE '&REST 'DEFVST SELKEYS))) ((NOT (SYMBOLP KEYNM)) (ERROR "Key name not a symbol - DEFVST" KEYNM))) (SETQ INIFORM () )) ('T (AND (OR (NULL (SETQ KEYNM (CAR KEYNM))) (NOT (SYMBOLP KEYNM))) (ERROR "Bad key-list - DEFVST" SELKEYS)) (COND ((ATOM (SETQ TMP (CDAR L))) (SETQ INIFORM () )) ('T (SETQ /=-/:-COUNT 0 ) (AND (NULL (CDR TMP)) ;Allow LISPM- (SETQ TMP `(= ,(car tmp)))) ; style inits (COND ((SETQ TYP (MEMQ '|:| TMP)) (SETQ /=-/:-COUNT 1) (SETQ TYP (COND ((ATOM (CADR TYP)) (LIST (CADR TYP))) ((CADR TYP)))))) (SETQ INIFORM (COND ((SETQ INIFORM (MEMQ '= TMP)) (SETQ /=-/:-COUNT (1+ /=-/:-COUNT)) (CADR INIFORM)) (TYP (CDR (OR (ASSQ (CAR TYP) '((FIXNUM . 0) (FLONUM . 0.0) (BIGNUM . 500000000000000000000.) (LIST . () ) (SYMBOL . 'FOO) (ARRAY . () ) (HUNK . () ) )) #+NIL (ASSQ (CAR TYP) '((SMALL-FLONUM 0.0) (PAIR . '(() )) (VECTOR . #.(if (fboundp 'make-vector) (make-vector 0) () )) (STRING . "" ))) ))))) (AND (NOT (= /=-/:-COUNT 0)) (SETQ INIFORM (CONS INIFORM TYP))) (COND ((NOT (= (* 2 /=-/:-COUNT) (LENGTH TMP))) (PRINT (CAR L) MSGFILES) (PRINC "Option list has options not yet coded "))) )) )) (COND ((NOT OUTPUT-SELECTOR-MACROS) (PUSH `(,keynm) SELINIS)) ('T (SETQ SELNM (IF (NULL SELECTOR-NAMESTRING-STYLE) KEYNM (SYMBOLCONC SNAME SELECTOR-NAMESTRING-STYLE KEYNM))) (COND ((NOT RESTP) ;; INIFORM = ( ...) (PUSH `(,keynm ,selnm ,.iniform) SELINIS)) ('T (SETQ RESTP `(,keynm ,selnm ,restsizeform)) (OR (= I (1+ NKEYS)) (+INTERNAL-LOSSAGE '&REST 'DEFVST i))))))) `(EVAL-WHEN (EVAL COMPILE LOAD) #-NIL #%(DEF-OR-AUTOLOADABLE |defvst-initialize/|| DEFVSY) (AND #-NIL (STATUS FEATURE COMPLR) (SPECIAL ,sname-class-var)) ;; The next line is a crock to replace the line commented out ;; below --RWK (DEFPROP ,sname ,sname-class-var CLASS-VAR) (|defvst-initialize/|| ',sname ',constructor-name ,nkeys ',(to-vector (cons restp (nreverse selinis))) ,SI:STRUCT=INFO-VERSION ;a version number ,(and (filep infile) `',(truename infile)) ;; The next line is commented out until dumped out versions of ;; |defvst-initialize/|| without an &REST IGNORE or this argument ;; are re-dumped. ;; -- RWK, Sunday the twenty-first of June, 1981; 3:12:18 am ;; ,sname-class-var ) ,.(if restp `((DEFPROP ,(cadr restp) (,sname ,(1+ nkeys) &REST) SELECTOR))) ',sname))) ;;;; Structure Printer ;; Someday, hack printing of &REST stuff (DEFVAR SI:PRINLEVEL-EXCESS '|#|) (DEFVAR SI:PRINLENGTH-EXCESS '|...|) (defmethod* (:PRINT-SELF STRUCT-CLASS) (ob stream depth slashifyp) (declare (fixnum depth)) (setq depth (1+ depth)) (if (and prinlevel (not (< depth prinlevel))) (princ SI:PRINLEVEL-EXCESS stream) (let* ((name (si:class-name (class-of ob))) (info (get name 'STRUCT=INFO))) (if (null info) (si:print-extend-maknum ob stream) (progn (si:verify-defvst-version name (STRUCT=INFO-vers info)) (princ '|#{| stream) (do ((z (si:listify-struct-for-print ob name info) (cdr z)) (n 0 (1+ n)) (first 'T ())) ((null z)) (declare (fixnum n)) (or first (tyo #\SPACE stream)) (print-object (car z) depth slashifyp stream) (cond ((and prinlength (not (< n PRINLENGTH))) (tyo #\SPACE stream) (princ SI:PRINLENGTH-EXCESS stream) (return () )))) (tyo #/} stream)))))) (defmethod* (SPRINT STRUCT-CLASS) (ob n m) (declare (special L N M)) (let* ((name (si:class-name (class-of ob))) (info (get name 'STRUCT=INFO))) (if (null info) (si:print-extend-maknum ob outfiles) (let ((z (si:listify-struct-for-print ob name info))) (si:verify-defvst-version name (STRUCT=INFO-vers info)) (if (> (- (grchrct) 3.) (gflatsize z)) (prin1 ob) (progn (princ '|#{|) (prin1 (car z)) (cond ((cdr z) (tyo #\SPACE) (setq N (grchrct) M (1+ M)) (do ((l (cdr z))) ((null l)) (grindform 'LINE) (grindform 'CODE) (cond (l (indent-to N)))))) (tyo #/}))))))) #+(or (not NIL) MacLISP) (eval-when (eval compile) (defmacro (VECTOR-LENGTH defmacro-for-compiling () defmacro-displace-call () ) (&rest w) `(SI:EXTEND-LENGTH ,.w)) (defmacro (VREF defmacro-for-compiling () defmacro-displace-call () ) (&rest w) `(SI:XREF ,.w)) ) ;; Sure, this could do less consing, if it really wanted to. But who ;; wants to trouble to write such hairy code? (DEFUN SI:LISTIFY-STRUCT-FOR-PRINT (OB NAME INFO) (LET* ((SUPPRESS (GET NAME 'SUPPRESSED-COMPONENT-NAMES)) (INIS (STRUCT=INFO-INIS INFO))) (DO ((I 1 (1+ I)) (N (VECTOR-LENGTH INIS)) (THE-LIST (LIST NAME))) ((NOT (< I N)) (NREVERSE THE-LIST)) ;The (1+ i)th component of INIS corresponds to the ith ;component of OB. The 0th component of INIS corresponds ;to the &REST stuff which this code doesn't address. (LET* (((NAME SELECTOR INIT) (VREF INIS I)) (VAL (SI:XREF OB (OR (AND SELECTOR (CADR (GET SELECTOR 'SELECTOR))) (1- I))))) (COND ((MEMQ NAME SUPPRESS)) ;;Incredible kludge to avoid printing defaulted vals ((OR (AND (NULL INIT) (NULL VAL)) (AND (|constant-p/|| INIT) (EQUAL VAL (EVAL INIT))) (AND (PAIRP INIT) (EQ (CAR INIT) 'QUOTE) (EQUAL VAL (CADR INIT))))) (T (PUSH NAME THE-LIST) (PUSH VAL THE-LIST))))))) (defmethod* (EQUAL struct-class) (ob other) (or (eq ob other) ;generally, this will have already been done (let ((ty1 (struct-typep ob)) (ty2 (struct-typep other))) (cond ((or (null ty1) (null ty2) (not (eq ty1 ty2))) () ) ((si:component-equal ob other)))))) (defmethod* (SUBST struct-class) (ob a b) (si:subst-into-extend ob a b)) (defmethod* (SXHASH struct-class) (ob) (si:hash-Q-extend ob #.(sxhash 'STRUCT))) (defmethod* (DESCRIBE struct-class) (ob stream level) (declare (special SI:DESCRIBE-MAX-LEVEL)) (if (not (> level SI:DESCRIBE-MAX-LEVEL)) (let* ((name (struct-typep ob)) (info (get name 'STRUCT=INFO))) (if (null info) () (let* ((inis (STRUCT=INFO-inis info)) (ninis (vector-length inis)) (suppress (get name 'SUPPRESSED-COMPONENT-NAMES))) (si:verify-defvst-version name (STRUCT=INFO-vers info)) (format stream "~%~vTThe named structure has STRUCT-TYPEP ~S" level name) (if suppress (format stream "~%~vtThese component names are suppressed: ~S" level suppress)) (format stream "~%~vtThe ~D. component names and contents are:" level (1- ninis)) (do ((i 1 (1+ i)) (default () ())) ((not (< i ninis))) (let* (((name selector init) (vref inis i)) (sel (get (cadr (vref inis i)) 'SELECTOR)) (val (vref ob (if sel (cadr sel) (1- i))))) (if (or (and (null init) (null val)) (and (|constant-p/|| init) (equal val (eval init))) (and (pairp init) (eq (car init) 'QUOTE) (equal val (cadr init)))) (setq default 'T)) (format stream "~%~vt ~S: ~S ~:[~; [default]~]" level (car (vref inis i)) val default))) (if (vref inis 0) (format stream "~%~vt&REST part hasn't been Described." level))))))) #+(and MacLISP (not NIL)) (or (fboundp 'STRUCT-LET) (equal (get 'STRUCT-LET 'AUTOLOAD) #%(autoload-filename UMLMAC)) (prog2 (defun STRUCT-LET macro (x) ((lambda (n FASLOAD) (cond ((null n)) ((alphalessp n "25") (remprop 'UMLMAC 'VERSION)) ((+internal-lossage 'UMLMAC 'STRUCT-LET n))) (load #%(autoload-filename UMLMAC)) (macroexpand x)) (get 'UMLMAC 'VERSION) () )) (defun STRUCT-SETF macro (x) ((lambda (n FASLOAD) (cond ((null n)) ((alphalessp n "25") (remprop 'UMLMAC 'VERSION)) ((+internal-lossage 'UMLMAC 'STRUCT-SETF n))) (load #%(autoload-filename UMLMAC)) (macroexpand x)) (get 'UMLMAC 'VERSION) () ))))