|
d@33
|
1 (cl:in-package #:amuse)
|
|
d@33
|
2
|
|
d@33
|
3 ;; Defines a set of methods for a sequence one of whose slots is the
|
|
d@33
|
4 ;; real sequence (in this case a list). This allows the allocation of
|
|
d@33
|
5 ;; other slots for state information.
|
|
d@33
|
6 ;;
|
|
d@33
|
7 ;; Requires a lisp with extensible lists (Rhodes, User-extensible
|
|
d@33
|
8 ;; Sequences, 2006/7??). Currently, that means SBCL >1.0 only.
|
|
d@33
|
9 ;;
|
|
d@33
|
10 ;; The code here draws heavily on Christophe's examples
|
|
d@33
|
11
|
|
d@33
|
12 (defclass list-slot-sequence (sequence standard-object)
|
|
d@33
|
13 ((%data :accessor %list-slot-sequence-data
|
|
j@285
|
14 :initarg :%data
|
|
d@33
|
15 :initform nil)))
|
|
d@33
|
16
|
|
d@33
|
17 (defmethod sequence:length ((o list-slot-sequence))
|
|
d@33
|
18 (length (%list-slot-sequence-data o)))
|
|
d@33
|
19
|
|
d@33
|
20 (defmethod sequence:elt ((o list-slot-sequence) index)
|
|
d@33
|
21 (elt (%list-slot-sequence-data o) index))
|
|
d@33
|
22
|
|
d@33
|
23 (defmethod (setf sequence:elt) (new-value (o list-slot-sequence) index)
|
|
d@33
|
24 (setf (elt (%list-slot-sequence-data o) index) new-value))
|
|
d@33
|
25
|
|
d@33
|
26 (defmethod sequence:make-sequence-like ((o list-slot-sequence) length
|
|
d@33
|
27 &key (initial-element nil iep)
|
|
d@33
|
28 (initial-contents nil icp))
|
|
d@33
|
29 (let ((result (make-instance (class-of o))))
|
|
d@33
|
30 (cond
|
|
d@33
|
31 ((and iep icp)
|
|
d@33
|
32 (error "Supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like))
|
|
d@33
|
33 (icp
|
|
d@33
|
34 (unless (= (length initial-contents) length)
|
|
d@33
|
35 (error "Length mismatch in ~S" 'make-sequence-like))
|
|
d@33
|
36 (setf (%list-slot-sequence-data result) (coerce initial-contents 'list))
|
|
d@33
|
37 result)
|
|
d@33
|
38 (t
|
|
d@33
|
39 (dotimes (i length result)
|
|
d@33
|
40 (push initial-element (%list-slot-sequence-data result)))))))
|
|
d@33
|
41
|
|
d@33
|
42 (defmethod sequence:adjust-sequence ((o list-slot-sequence) length
|
|
d@33
|
43 &key initial-element
|
|
d@33
|
44 (initial-contents nil icp))
|
|
d@33
|
45 (cond
|
|
d@33
|
46 ((= length 0)
|
|
d@33
|
47 (setf (%list-slot-sequence-data o) nil))
|
|
d@33
|
48 (icp
|
|
d@33
|
49 (setf (%list-slot-sequence-data o)
|
|
d@33
|
50 (sequence:adjust-sequence (%list-slot-sequence-data o)
|
|
d@33
|
51 length
|
|
d@33
|
52 :initial-contents initial-contents)))
|
|
d@33
|
53 (t (setf (%list-slot-sequence-data o)
|
|
d@33
|
54 (sequence:adjust-sequence (%list-slot-sequence-data o)
|
|
d@33
|
55 length
|
|
d@33
|
56 :initial-element initial-element))))
|
|
d@33
|
57 o)
|
|
d@33
|
58
|
|
d@33
|
59 (defmethod sequence:make-simple-sequence-iterator
|
|
d@33
|
60 ((o list-slot-sequence) &rest args &key from-end start end)
|
|
d@33
|
61 (declare (ignore from-end start end))
|
|
d@33
|
62 (apply #'sequence:make-simple-sequence-iterator
|
|
d@33
|
63 (%list-slot-sequence-data o) args))
|
|
d@33
|
64 (defmethod sequence:iterator-step ((o list-slot-sequence) iterator from-end)
|
|
d@33
|
65 (sequence:iterator-step (%list-slot-sequence-data o) iterator from-end))
|
|
d@33
|
66 (defmethod sequence:iterator-endp ((o list-slot-sequence) iterator limit from-end)
|
|
d@33
|
67 (sequence:iterator-endp (%list-slot-sequence-data o) iterator limit from-end))
|
|
d@33
|
68 (defmethod sequence:iterator-element ((o list-slot-sequence) iterator)
|
|
d@33
|
69 (sequence:iterator-element (%list-slot-sequence-data o) iterator))
|
|
d@33
|
70 (defmethod (setf sequence:iterator-element) (new-value (o list-slot-sequence) iterator)
|
|
d@33
|
71 (setf (sequence:iterator-element (%list-slot-sequence-data o) iterator) new-value))
|
|
d@33
|
72 (defmethod sequence:iterator-index ((o list-slot-sequence) iterator)
|
|
d@33
|
73 (sequence:iterator-index (%list-slot-sequence-data o) iterator))
|
|
d@33
|
74 (defmethod sequence:iterator-copy ((o list-slot-sequence) iterator)
|
|
j@285
|
75 (sequence:iterator-copy (%list-slot-sequence-data o) iterator))
|
