d@33: (cl:in-package #:amuse)
d@33: 
d@33: ;; Defines a set of methods for a sequence one of whose slots is the
d@33: ;; real sequence (in this case a list). This allows the allocation of
d@33: ;; other slots for state information.
d@33: ;;
d@33: ;; Requires a lisp with extensible lists (Rhodes, User-extensible
d@33: ;; Sequences, 2006/7??). Currently, that means SBCL >1.0 only.
d@33: ;;
d@33: ;; The code here draws heavily on Christophe's examples
d@33: 
d@33: (defclass list-slot-sequence (sequence standard-object)
d@33:   ((%data :accessor %list-slot-sequence-data
j@285: 	  :initarg :%data
d@33: 	  :initform nil)))
d@33: 
d@33: (defmethod sequence:length ((o list-slot-sequence))
d@33:   (length (%list-slot-sequence-data o)))
d@33: 
d@33: (defmethod sequence:elt ((o list-slot-sequence) index)
d@33:   (elt (%list-slot-sequence-data o) index))
d@33: 
d@33: (defmethod (setf sequence:elt) (new-value (o list-slot-sequence) index)
d@33:   (setf (elt (%list-slot-sequence-data o) index) new-value))
d@33: 
d@33: (defmethod sequence:make-sequence-like ((o list-slot-sequence) length
d@33: 					&key (initial-element nil iep)
d@33: 					(initial-contents nil icp))
d@33:   (let ((result (make-instance (class-of o))))
d@33:     (cond 
d@33:       ((and iep icp)
d@33:        (error "Supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like))
d@33:       (icp
d@33:        (unless (= (length initial-contents) length)
d@33: 	 (error "Length mismatch in ~S" 'make-sequence-like))
d@33:        (setf (%list-slot-sequence-data result) (coerce initial-contents 'list))
d@33:        result)
d@33:       (t
d@33:        (dotimes (i length result)
d@33: 	 (push initial-element (%list-slot-sequence-data result)))))))
d@33: 
d@33: (defmethod sequence:adjust-sequence ((o list-slot-sequence) length
d@33: 				     &key initial-element
d@33: 				     (initial-contents nil icp))
d@33:   (cond
d@33:     ((= length 0)
d@33:      (setf (%list-slot-sequence-data o) nil))
d@33:     (icp
d@33:      (setf (%list-slot-sequence-data o)
d@33: 	   (sequence:adjust-sequence (%list-slot-sequence-data o)
d@33: 				     length
d@33: 				     :initial-contents initial-contents)))
d@33:     (t (setf (%list-slot-sequence-data o)
d@33: 	     (sequence:adjust-sequence (%list-slot-sequence-data o)
d@33: 				       length
d@33: 				       :initial-element initial-element))))
d@33:   o)
d@33: 
d@33: (defmethod sequence:make-simple-sequence-iterator 
d@33:     ((o list-slot-sequence) &rest args &key from-end start end)
d@33:   (declare (ignore from-end start end))
d@33:   (apply #'sequence:make-simple-sequence-iterator
d@33: 	 (%list-slot-sequence-data o) args))
d@33: (defmethod sequence:iterator-step ((o list-slot-sequence) iterator from-end)
d@33:   (sequence:iterator-step (%list-slot-sequence-data o) iterator from-end))
d@33: (defmethod sequence:iterator-endp ((o list-slot-sequence) iterator limit from-end)
d@33:   (sequence:iterator-endp (%list-slot-sequence-data o) iterator limit from-end))
d@33: (defmethod sequence:iterator-element ((o list-slot-sequence) iterator)
d@33:   (sequence:iterator-element (%list-slot-sequence-data o) iterator))
d@33: (defmethod (setf sequence:iterator-element) (new-value (o list-slot-sequence) iterator)
d@33:   (setf (sequence:iterator-element (%list-slot-sequence-data o) iterator) new-value))
d@33: (defmethod sequence:iterator-index ((o list-slot-sequence) iterator)
d@33:   (sequence:iterator-index (%list-slot-sequence-data o) iterator))
d@33: (defmethod sequence:iterator-copy ((o list-slot-sequence) iterator)
j@285:   (sequence:iterator-copy (%list-slot-sequence-data o) iterator))