Artifact 71cbe0b1b5f1da1a072d7c0f244649ca6c8ca39c95632e88309e8b5087d88e46:

• File psl-1983/3-1/util/fast-struct.lsp — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4113) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/fast-struct.lsp — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 4113) [annotate] [blame] [check-ins using]

(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))))))))