Artifact a012f0708aa022308064c45ed957494779335c51969ca4716d9ae706401d6fc8:

• File psl-1983/3-1/util/struct.initial — 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: 1778) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/util/struct.initial — 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: 1778) [annotate] [blame] [check-ins using]

;;;-*-lisp-*-

(defmacro defstruct ((name . opts) . slots)
  (let ((dp (cadr (assq 'default-pointer opts)))
	(conc-name (cadr (assq 'conc-name opts)))
	(cons-name (implode (append '(m a k e -) (explodec name)))))
;    #Q (fset-carefully cons-name '(macro . initial_defstruct-cons))
;    #M (putprop cons-name 'initial_defstruct-cons 'macro)
;    PSL change
	(putd cons-name 'macro (cdr (getd 'initial_defstruct-cons)))
;    PSL change    1+ ==> add1
    (do ((i 0 (add1 i))
	 (l slots (cdr l))
	 (foo nil (cons (list slot init) foo))
	 (chars (explodec conc-name))
	 (slot) (acsor) (init))
	((null l)
	 (putprop cons-name foo 'initial_defstruct-inits)
	 `',name)
      (cond ((atom (car l))
	     (setq slot (car l))
	     (setq init nil))
	    (t (setq slot (caar l))
	       (setq init (cadar l))))
      (setq acsor (implode (append chars (explodec slot))))
      (putprop acsor dp 'initial_defstruct-dp)
;      #Q (fset-carefully acsor '(macro . initial_defstruct-ref))
;      #M (putprop acsor 'initial_defstruct-ref 'macro)
;      PSL change
	  (putd acsor 'macro (cdr (getd 'initial_defstruct-ref)))
      (putprop acsor i 'initial_defstruct-i))))

(defun initial_defstruct-ref (form)
  (let ((i (get (car form) 'initial_defstruct-i))
	(p (if (null (cdr form))
	       (get (car form) 'initial_defstruct-dp)
	       (cadr form))))
;     PSL change	incompatible NTH
    #-Multics `(nth ,p ,(add1 i))
;    #-Multics `(nth ,i ,p)
    #+Multics `(car ,(do ((i i (1- i))
			  (x p `(cdr ,x)))
			 ((zerop i) x)))
    ))

(defun initial_defstruct-cons (form)
  (do ((inits (get (car form) 'initial_defstruct-inits)
	      (cdr inits))
       (gen (gensym))
       (x nil (cons (or (get form (caar inits))
			(cadar inits))
		    x)))
      ((null inits)
       `(list . ,x))))