;;; -*- Mode:LISP; Package:USER; Readtable:ZL; Base:10 -*-

;;;AARRAY.LISP
;;;
;;;Replacement for some of the useful features of an ART-Q-LIST array.

;;;Flavors --
;;;Supports CAR and RPLACA, but no CDR operations.

(defflavor aarray
	 ((length 0) aarray)
	 (si:property-list-mixin)
  (:settable-instance-variables length))

(defmethod (aarray :check-length) ()
  (check-type length (integer 1)))

(defmethod (aarray :before :init) (ignore)
  (send self :check-length))

(defmethod (aarray :after :init) (ignore)
  (setq aarray (make-array length :type 'art-q :fill-pointer t))
  (describe self))

(defun make-aarray (len)
  (make-instance 'aarray :length len))

(defmethod (aarray :car) ()
  (aref aarray 0))

(defmethod (aarray :set-car) (value)
  (setf (aref aarray 0) value))

;;;Named-Structure approach:
;;;
;;;Would work better if CAR called named-structure handler, like it does for flavors

(defun make-aarray (length)
  (check-type length (integer 1))
  (make-array length :type 'art-q :named-structure-symbol 'aarray :fill-pointer length :leader-length 2))

(defsubst aarray-length (aarray)
  (array-active-length aarray))

(defselect ((:property aarray si:named-structure-invoke) ignore)
  (:print-self (self stream &optional ignore ignore)
    (if *print-escape*
	(si:printing-random-object (self stream :type)
	  (princ (fill-pointer self) stream))
      (princ (fill-pointer self) stream)))
  (:describe (self)
    (let ((*print-length* 4.)(*print-level* 2.))
      (format t "~&A ~D. element AARRAY: ~~{~S~}~" (aarray-length self) (listarray self))))
  (:car () (aref self 0))
  (:set-car (value) (setf (aref self 0) value)))