File psl-1983/3-1/util/fast-struct.lsp artifact 71cbe0b1b5 on branch master

(defstruct-define-type :fast-vector
  (:named :named-fast-vector)			; but probably not much point
  (:cons
    (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(vector ,@arg))
  (:defstruct (x) (let ((*insideload t)) (load fast-vector) nil))
  (:ref
    (n description arg)
    description		;ignored
    `(igetv ,arg ,n)))

;added for PSL

(defstruct-define-type :named-fast-vector
  (:keywords :make-vector)
  :named (:overhead 1)
  (:cons
    (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(vector ',(defstruct-description-name) ,@arg))
  (:defstruct (x) (let ((*insideload t)) (load fast-vector) nil))
  (:ref
    (n description arg)
    description		;ignored
    `(igetv ,arg ,(add1 n))))

(defstruct-define-type hashed-list
  (:named :named-hashed-list)
  (:cons
    (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(hlist . ,arg))
  (:ref
    (n description arg)
    description		;ignored
    #+Multics `(,(let ((i (\ n 4)))
		   (cond ((= i 0) 'car)
			 ((= i 1) 'cadr)
			 ((= i 2) 'caddr)
			 (t 'cadddr)))
		,(do ((a arg `(cddddr ,a))
		      (i (// n 4) (1- i)))
		     ((= i 0) a)))
;     PSL change     incompatible NTH
    #-Multics `(nth ,arg ,(add1 n))))
;    #-Multics `(nth ,n ,arg)))

(defstruct-define-type :named-hashed-list
  :named (:overhead 1)
  (:cons
    (arg description etc) :list
    etc			;ignored
    `(hlist ',(defstruct-description-name) . ,arg))
  (:ref
    (n description arg)
    description		;ignored
;    #+Multics `(,(let ((i (\ (1+ n) 4)))
;		   (cond ((= i 0) 'car)
;			 ((= i 1) 'cadr)
;			 ((= i 2) 'caddr)
;			 (t 'cadddr)))
;		,(do ((a arg `(cddddr ,a))
;		      (i (// (1+ n) 4) (1- i)))
;		     ((= i 0) a)))
;     PSL change	incompatible NTH
     #-Multics `(nth ,arg ,(+ n 2))))
;    #-Multics `(nth ,(1+ n) ,arg)))

(defstruct-define-type :hashed-list*
  (:cons
    (arg description etc) :list
    description		;ignored
    etc			;ignored
    `(hcons . ,arg))
  (:ref
    (n description arg)
;     PSL change	1- ==> sub1
    (let ((size (sub1 (defstruct-description-size))))
;    (let ((size (1- (defstruct-description-size))))
      #+Multics (do ((a arg `(cddddr ,a))
		     (i (// n 4) (1- i)))
		    ((= i 0)
		     (let* ((i (\ n 4))
			    (a (cond ((= i 0) a)
				     ((= i 1) `(cdr ,a))
				     ((= i 2) `(cddr ,a))
				     (t `(cdddr ,a)))))
		       (if (< n size) `(car ,a) a))))
      #-Multics (if (< n size)
;     PSL change	incompatible NTH
		    `(nth ,arg ,(add1 n))
		    `(pnth ,arg ,(add1 n)))))
;		    `(nth ,n ,arg)
;		    `(nthcdr ,n ,arg))))
  (:defstruct (description)
    (and (defstruct-description-include)
	 (defstruct-error
	   "Structure of type hashed-list* cannot include another"
	   (defstruct-description-name)))
    nil))

(defstruct-define-type :hashed-tree
  (:cons
    (arg description etc) :list
    etc			;ignored
    (if (null arg) (defstruct-error
		     "defstruct cannot make an empty tree"
		     (defstruct-description-name)))
    (make-hashed-tree-for-defstruct arg (defstruct-description-size)))
  (:ref
    (n description arg)
    (do ((size (defstruct-description-size))
	 (a arg)
	 (tem))
	(())
      (cond ((= size 1) (return a))
;     PSL change	// ==> /
	    ((< n (setq tem (/ size 2)))
;	    ((< n (setq tem (// size 2)))
	     (setq a `(car ,a))
	     (setq size tem))
	    (t (setq a `(cdr ,a))
	       (setq size (- size tem))
	       (setq n (- n tem))))))
  (:defstruct (description)
    (and (defstruct-description-include)
	 (defstruct-error
	   "Structure of type tree cannot include another"
	   (defstruct-description-name)))
    nil))

(defun make-hashed-tree-for-defstruct (arg size)
       (cond ((= size 1) (car arg))
	     ((= size 2) `(hcons ,(car arg) ,(cadr arg)))
	     (t (do ((a (cdr arg) (cdr a))
;     PSL change	// ==> /, 1- ==> sub1
		     (m (/ size 2))
		     (n (sub1 (/ size 2)) (sub1 n)))
;		     (m (// size 2))
;		     (n (1- (// size 2)) (1- n)))
		    ((zerop n)
		     `(hcons
			,(make-hashed-tree-for-defstruct arg m)
			,(make-hashed-tree-for-defstruct a (- size m))))))))