mirror of
https://github.com/PDP-10/its.git
synced 2026-01-17 08:43:21 +00:00
a5f1fa0412
The current value doesn't match FN2, as I forgot to update it the last time I updated this file. Removing the explicit version number will cause HERALD to display the FN2 as the version number. Resolves #1318.
325 lines
9.2 KiB
Common Lisp
Executable File
325 lines
9.2 KiB
Common Lisp
Executable File
;;; VECTOR -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
||
;;; **************************************************************************
|
||
;;; *** MacLISP ******** VECTOR support **************************************
|
||
;;; **************************************************************************
|
||
;;; ******** (c) Copyright 1982 Massachusetts Institute of Technology ********
|
||
;;; **************************************************************************
|
||
|
||
(herald VECTOR)
|
||
|
||
;; This file cannot be run interpretively, due to the dependence upon
|
||
;; the SOURCE-TRANS being expanded while compiling -- if you *must*
|
||
;; try it interpretively, then just turn the SOURCE-TRANS's into
|
||
;; ordinary macros.
|
||
|
||
(eval-when (eval compile)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
(subload MACAID)
|
||
(subload UMLMAC)
|
||
;; Remember, EXTMAC down-loads CERROR
|
||
(subload EXTMAC)
|
||
(subload DEFSETF)
|
||
(subload SUBSEQ)
|
||
(subload LOOP)
|
||
|
||
(setq USE-STRT7 'T MACROS () )
|
||
(setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED)
|
||
|
||
)
|
||
|
||
|
||
(eval-when (eval load compile)
|
||
(subload EXTEND)
|
||
(cond ((status feature COMPLR)
|
||
(special VECTOR-CLASS)
|
||
(*lexpr MAKE-VECTOR)))
|
||
)
|
||
|
||
(def-or-autoloadable FLUSH-MACROMEMOS DEFMAX)
|
||
|
||
|
||
(define-loop-path (vector-elements vector-element)
|
||
si:loop-sequence-elements-path
|
||
(of from to below above downto in by)
|
||
vref vector-length vector notype)
|
||
|
||
|
||
;;;; Source-trans's necessary for compiling the subrs
|
||
|
||
(eval-when (eval compile load)
|
||
|
||
(defun si:VECTOR-SRCTRNS (x)
|
||
(let ((winp () ))
|
||
(caseq (car x)
|
||
(MAKE-VECTOR (if (= (length x) 2)
|
||
(setq x `(SI:MAKE-EXTEND ,(cadr x) VECTOR-CLASS)
|
||
winp 'T)))
|
||
((VREF VSET) (setq x (cons (if (eq (car x) 'VREF)
|
||
'SI:XREF
|
||
'SI:XSET)
|
||
(cdr x))
|
||
winp 'T))
|
||
(VECTOR (setq x `(SI:EXTEND VECTOR-CLASS ,.(cdr x)) winp 'T))
|
||
(VECTOR-LENGTH (setq x `(SI:EXTEND-LENGTH ,.(cdr x)) winp 'T)))
|
||
(values x winp)))
|
||
|
||
(and
|
||
(status feature COMPLR)
|
||
(let (y)
|
||
(mapc '(lambda (x)
|
||
(or (memq 'si:VECTOR-SRCTRNS (setq y (get x 'SOURCE-TRANS)))
|
||
(putprop x (cons 'si:VECTOR-SRCTRNS y) 'SOURCE-TRANS)))
|
||
'(VECTOR VECTOR-LENGTH VREF VSET MAKE-VECTOR))))
|
||
)
|
||
|
||
|
||
;;;; VECTORP,VREF,VSET,MAKE-VECTOR,VECTOR,VECTOR-LENGTH,SET-VECTOR-LENGTH
|
||
|
||
(defun VECTORP (x) (eq (si:class-typep (class-of x)) 'VECTOR))
|
||
|
||
(defun VREF (seq index)
|
||
(when *RSET
|
||
(let ((cnt 1))
|
||
(check-subsequence (seq index cnt) 'VECTOR 'VREF)))
|
||
(vref seq index))
|
||
|
||
(defsetf VREF ((() seq index) val) ()
|
||
`(VSET ,seq ,index ,val))
|
||
|
||
(defun VSET (seq index val)
|
||
(when *RSET
|
||
(let ((cnt 1))
|
||
(check-subsequence (seq index cnt) 'VECTOR 'VREF)))
|
||
(vset seq index val)
|
||
seq)
|
||
|
||
|
||
(defun MAKE-VECTOR (n &optional fill)
|
||
(when *RSET (check-type n #'SI:MAX-EXTEND-SIZEP 'MAKE-VECTOR))
|
||
(let ((v (make-vector n)))
|
||
(if fill
|
||
(do ((i 0 (1+ i)))
|
||
((>= i n))
|
||
(vset v i fill)))
|
||
v))
|
||
|
||
(defun VECTOR n
|
||
(when *RSET (check-type n #'SI:MAX-EXTEND-SIZEP 'VECTOR))
|
||
(let ((v (make-vector n)))
|
||
(dotimes (i n) (vset v i (arg (1+ i))))
|
||
v))
|
||
|
||
|
||
(defun VECTOR-LENGTH (seq)
|
||
(when *RSET (check-type seq #'VECTORP 'VECTOR-LENGTH))
|
||
(vector-length seq))
|
||
|
||
|
||
|
||
(defun SET-VECTOR-LENGTH (seq newsize)
|
||
(when *RSET
|
||
(let ((i 0))
|
||
(check-subsequence (seq i newsize) 'VECTOR 'SET-VECTOR-LENGTH)))
|
||
;; What a crock!
|
||
(do ((max (1- (hunksize seq)))
|
||
(i (+ 2 newsize))
|
||
(crock (munkam #o777777)))
|
||
((> i max))
|
||
(rplacx i seq crock))
|
||
seq)
|
||
|
||
|
||
(defun |&restv-ify/|| (n &aux allp)
|
||
;; Cooperates with output of DEFUN& to snarf args off pdl and into a VECTOR
|
||
(declare (fixnum n arg-offset))
|
||
(cond ((< n 0) (setq n (- n))) ;Take ABS of 'n'
|
||
('T (setq allp 'T))) ;Are we getting all the args?
|
||
(let ((v (make-vector n))
|
||
(arg-offset (if allp
|
||
1
|
||
(- (arg () ) n -1))))
|
||
(dotimes (i n) (vset v i (arg (+ i arg-offset))))
|
||
v))
|
||
|
||
(defmacro dolist-with-index ((var form index) &rest body &aux dummy decls)
|
||
(setq decls (cond ((and body
|
||
(not (atom (car body)))
|
||
(eq (caar body) 'DECLARE))
|
||
(prog2 () (cdar body) (pop body)))))
|
||
(cond (index (push `(FIXNUM ,INDEX) decls)
|
||
(setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))))
|
||
(and decls (setq decls (ncons `(DECLARE ,.decls))))
|
||
(si:gen-local-var dummy)
|
||
`(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
|
||
((NULL ,DUMMY))
|
||
,@decls
|
||
(SETQ ,VAR (CAR ,DUMMY)) ,.BODY))
|
||
|
||
|
||
(defun |#-MACRO-/(| (x) ;#(...) is VECTOR notation
|
||
(let ((form (read)) v)
|
||
(if (or x
|
||
(and form (atom form))
|
||
(and (setq x (cdr (last form))) (atom x)))
|
||
(error "Not a proper list for #/(" (list x form)))
|
||
(setq v (make-vector (length form)))
|
||
(dolist-with-index (item form i) (vset v i item))
|
||
v))
|
||
|
||
|
||
(defvar /#-MACRO-DATALIST () )
|
||
|
||
;; An open-coding of SETSYNTAX-SHARP-MACRO
|
||
(let ((x (get 'SHARPM 'VERSION))
|
||
(y '(#/( T MACRO . |#-MACRO-/(| )))
|
||
(cond ((and x (alphalessp x '/82))
|
||
(push y /#-MACRO-DATALIST))
|
||
('T (if (null (setq x (assoc READTABLE /#-MACRO-DATALIST)))
|
||
(push (setq x `(,READTABLE . () )) /#-MACRO-DATALIST))
|
||
(push y (cdr x)))))
|
||
|
||
|
||
;;;; DOVECTOR, VECTOR-POSASSQ, SI:COMPONENT-EQUAL, and SI:SUBST-INTO-EXTEND
|
||
|
||
(defmacro DOVECTOR ((var form index) &rest body &aux (cntr index) vec vecl)
|
||
(or cntr (si:gen-local-var cntr))
|
||
(si:gen-local-var vec)
|
||
(si:gen-local-var vecl)
|
||
`(LET ((,vec ,form))
|
||
(DO ((,cntr 0 (1+ ,cntr))
|
||
(,var)
|
||
(,vecl (VECTOR-LENGTH ,vec)))
|
||
((= ,cntr ,vecl))
|
||
(DECLARE (FIXNUM ,cntr ,vecl))
|
||
,.(and var (symbolp var) `((SETQ ,var (VREF ,vec ,cntr))))
|
||
,.body)))
|
||
|
||
(def-or-autoloadable GENTEMP MACAID)
|
||
|
||
(defun VECTOR-POSASSQ (x v)
|
||
(dovector (e v i) (and (pairp e) (eq x (car e)) (return i))))
|
||
|
||
|
||
;; called by EQUAL->VECTOR-CLASS and EQUAL->STRUCT-CLASS
|
||
(defun SI:COMPONENT-EQUAL (ob other)
|
||
(let ((l1 (si:extend-length ob))
|
||
(l2 (si:extend-length other)))
|
||
(declare (fixnum l1 l2 i))
|
||
(and (= l1 l2)
|
||
(do ((i 0 (1+ i)))
|
||
((= i l1) 'T)
|
||
(if (not (equal (si:xref ob i) (si:xref other i)))
|
||
(return () ))))))
|
||
|
||
;; called by SUBST->VECTOR-CLASS and SUBST->STRUCT-CLASS
|
||
(defun SI:SUBST-INTO-EXTEND (ob a b)
|
||
(let ((l1 (si:extend-length ob)))
|
||
(declare (fixnum l1 i))
|
||
(do ((i 0 (1+ i))
|
||
(newob (si:make-extend l1 (class-of ob))))
|
||
((= i l1) newob)
|
||
(si:xset newob i (subst a b (si:xref ob i))))))
|
||
|
||
|
||
;;;; Some methods
|
||
|
||
(defmethod* (EQUAL VECTOR-CLASS) (obj other-obj)
|
||
(cond ((not (vectorp obj))
|
||
(+internal-lossage 'VECTORP 'EQUAL->VECTOR-CLASS obj))
|
||
((not (vectorp other-obj)) () )
|
||
((si:component-equal obj other-obj))))
|
||
|
||
(defmethod* (SUBST VECTOR-CLASS) (ob a b)
|
||
(si:subst-into-extend ob a b))
|
||
|
||
(DEFVAR VECTOR-PRINLENGTH () )
|
||
(DEFVAR SI:PRINLEVEL-EXCESS '|#|)
|
||
(DEFVAR SI:PRINLENGTH-EXCESS '|...|)
|
||
|
||
(DEFMETHOD* (:PRINT-SELF VECTOR-CLASS) (OBJ STREAM DEPTH SLASHIFYP)
|
||
(DECLARE (FIXNUM LEN I DEPTH))
|
||
;Be careful where you put the declaration for LEN!
|
||
(LET ((LEN (VECTOR-LENGTH OBJ)))
|
||
(SETQ DEPTH (1+ DEPTH))
|
||
(SETQ STREAM (SI:NORMALIZE-STREAM STREAM))
|
||
(COND
|
||
((= LEN 0) (PRINC "#()" STREAM))
|
||
((AND PRINLEVEL (NOT (< DEPTH PRINLEVEL)))
|
||
(PRINC SI:PRINLEVEL-EXCESS STREAM))
|
||
('T (PRINC "#(" STREAM)
|
||
(DO ((I 0 (1+ I)) FL)
|
||
((= I LEN) )
|
||
(IF FL (TYO #\SPACE STREAM) (SETQ FL 'T))
|
||
(COND ((OR (AND VECTOR-PRINLENGTH (NOT (> VECTOR-PRINLENGTH I)))
|
||
(AND PRINLENGTH (NOT (> PRINLENGTH I))))
|
||
(PRINC SI:PRINLENGTH-EXCESS STREAM)
|
||
(RETURN () )))
|
||
(PRINT-OBJECT (VREF OBJ I) DEPTH SLASHIFYP STREAM))
|
||
(TYO #/) STREAM)))))
|
||
|
||
(DEFMETHOD* (FLATSIZE VECTOR-CLASS) (OBJ PRINTP DEPTH SLASHIFYP
|
||
&AUX (LEN (VECTOR-LENGTH OBJ)))
|
||
(AND DEPTH (SETQ DEPTH (1+ DEPTH)))
|
||
(COND ((ZEROP LEN) 3)
|
||
((AND DEPTH PRINLEVEL (NOT (< DEPTH PRINLEVEL))) 1) ;?
|
||
(PRINTP (+ 2 (FLATSIZE-OBJECT (VREF OBJ 0)
|
||
PRINTP
|
||
DEPTH
|
||
SLASHIFYP)))
|
||
('T (DO ((I (1- LEN) (1- I))
|
||
(CNT 2 (+ CNT
|
||
(FLATSIZE-OBJECT (VREF OBJ I)
|
||
PRINTP
|
||
DEPTH
|
||
SLASHIFYP)
|
||
1)))
|
||
((< I 0) CNT)
|
||
(DECLARE (FIXNUM I CNT))))))
|
||
|
||
|
||
|
||
(DEFMETHOD* (SPRINT VECTOR-CLASS) (SELF N M)
|
||
(IF (= (VECTOR-LENGTH SELF) 0)
|
||
(PRINC "#()")
|
||
(PROGN (SETQ SELF (TO-LIST SELF))
|
||
(PRINC '/#)
|
||
(SPRINT1 SELF (GRCHRCT) M))))
|
||
|
||
(DEFMETHOD* (GFLATSIZE VECTOR-CLASS) (OBJ)
|
||
(DO ((LEN (VECTOR-LENGTH OBJ))
|
||
(I 0 (1+ I))
|
||
(SIZE 2 (+ SIZE (GFLATSIZE (VREF OBJ I)))))
|
||
((= I LEN)
|
||
(COND ((= LEN 0) 3)
|
||
(T (+ SIZE LEN))))
|
||
(DECLARE (FIXNUM MAX I SIZE))))
|
||
|
||
|
||
(DEFMETHOD* (SXHASH VECTOR-CLASS) (OB)
|
||
(SI:HASH-Q-EXTEND OB #,(sxhash 'VECTOR)))
|
||
|
||
;;Someday we'd like this hook, but for now there is just the
|
||
;; complr feature that lets them go out as hunks. Also, DEFVST
|
||
;; puts out a hunk with a computed value in the CDR which sill
|
||
;; be the value of VECTOR-CLASS if it exists.
|
||
;(DEFMETHOD* (USERATOMS-HOOK VECTOR-CLASS) (self)
|
||
; (list `(TO-VECTOR ',(to-list self))))
|
||
|
||
|
||
(defmethod* (DESCRIBE VECTOR-CLASS) (ob stream level)
|
||
(declare (special SI:DESCRIBE-MAX-LEVEL))
|
||
(if (and (not (> level SI:DESCRIBE-MAX-LEVEL))
|
||
(vectorp ob))
|
||
(format stream
|
||
"~%~vTThe vector ~S has ~D elements."
|
||
level ob (vector-length ob))))
|
||
|
||
|
||
(and (status status VECTOR)
|
||
(sstatus VECTOR (list (get 'VECTORP 'SUBR)
|
||
(get 'VECTOR-LENGTH 'SUBR)
|
||
(get 'VREF 'SUBR))))
|
||
|
||
|