mirror of
https://github.com/PDP-10/its.git
synced 2026-02-16 04:43:01 +00:00
cc8e6c1964
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
405 lines
13 KiB
Common Lisp
Executable File
405 lines
13 KiB
Common Lisp
Executable File
;;; 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 = (<initialization-form> <restrictions>...)
|
||
(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)
|
||
() ))))
|
||
|