;;;-*-lisp-*-
(setq rcs-strictini-
   "$Header:structini.l 12.0$")
   "$ACIS:structini.l 12.0$")

#+franz
(declare (macros t))

(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)
    #F (putd cons-name '(macro (x) (initial_defstruct-cons x)))
    (do ((i 0 (1+ 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)
      #F (putd acsor '(macro (x) (initial_defstruct-ref x)))
      (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))))
    #-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))))

