|
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
|
|
d@33
|
14 :initform nil)))
|
|
d@33
|
15
|
|
d@33
|
16 (defmethod sequence:length ((o list-slot-sequence))
|
|
d@33
|
17 (length (%list-slot-sequence-data o)))
|
|
d@33
|
18
|
|
d@33
|
19 (defmethod sequence:elt ((o list-slot-sequence) index)
|
|
d@33
|
20 (elt (%list-slot-sequence-data o) index))
|
|
d@33
|
21
|
|
d@33
|
22 (defmethod (setf sequence:elt) (new-value (o list-slot-sequence) index)
|
|
d@33
|
23 (setf (elt (%list-slot-sequence-data o) index) new-value))
|
|
d@33
|
24
|
|
d@33
|
25 (defmethod sequence:make-sequence-like ((o list-slot-sequence) length
|
|
d@33
|
26 &key (initial-element nil iep)
|
|
d@33
|
27 (initial-contents nil icp))
|
|
d@33
|
28 (let ((result (make-instance (class-of o))))
|
|
d@33
|
29 (cond
|
|
d@33
|
30 ((and iep icp)
|
|
d@33
|
31 (error "Supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like))
|
|
d@33
|
32 (icp
|
|
d@33
|
33 (unless (= (length initial-contents) length)
|
|
d@33
|
34 (error "Length mismatch in ~S" 'make-sequence-like))
|
|
d@33
|
35 (setf (%list-slot-sequence-data result) (coerce initial-contents 'list))
|
|
d@33
|
36 result)
|
|
d@33
|
37 (t
|
|
d@33
|
38 (dotimes (i length result)
|
|
d@33
|
39 (push initial-element (%list-slot-sequence-data result)))))))
|
|
d@33
|
40
|
|
d@33
|
41 (defmethod sequence:adjust-sequence ((o list-slot-sequence) length
|
|
d@33
|
42 &key initial-element
|
|
d@33
|
43 (initial-contents nil icp))
|
|
d@33
|
44 (cond
|
|
d@33
|
45 ((= length 0)
|
|
d@33
|
46 (setf (%list-slot-sequence-data o) nil))
|
|
d@33
|
47 (icp
|
|
d@33
|
48 (setf (%list-slot-sequence-data o)
|
|
d@33
|
49 (sequence:adjust-sequence (%list-slot-sequence-data o)
|
|
d@33
|
50 length
|
|
d@33
|
51 :initial-contents initial-contents)))
|
|
d@33
|
52 (t (setf (%list-slot-sequence-data o)
|
|
d@33
|
53 (sequence:adjust-sequence (%list-slot-sequence-data o)
|
|
d@33
|
54 length
|
|
d@33
|
55 :initial-element initial-element))))
|
|
d@33
|
56 o)
|
|
d@33
|
57
|
|
d@33
|
58 (defmethod sequence:make-simple-sequence-iterator
|
|
d@33
|
59 ((o list-slot-sequence) &rest args &key from-end start end)
|
|
d@33
|
60 (declare (ignore from-end start end))
|
|
d@33
|
61 (apply #'sequence:make-simple-sequence-iterator
|
|
d@33
|
62 (%list-slot-sequence-data o) args))
|
|
d@33
|
63 (defmethod sequence:iterator-step ((o list-slot-sequence) iterator from-end)
|
|
d@33
|
64 (sequence:iterator-step (%list-slot-sequence-data o) iterator from-end))
|
|
d@33
|
65 (defmethod sequence:iterator-endp ((o list-slot-sequence) iterator limit from-end)
|
|
d@33
|
66 (sequence:iterator-endp (%list-slot-sequence-data o) iterator limit from-end))
|
|
d@33
|
67 (defmethod sequence:iterator-element ((o list-slot-sequence) iterator)
|
|
d@33
|
68 (sequence:iterator-element (%list-slot-sequence-data o) iterator))
|
|
d@33
|
69 (defmethod (setf sequence:iterator-element) (new-value (o list-slot-sequence) iterator)
|
|
d@33
|
70 (setf (sequence:iterator-element (%list-slot-sequence-data o) iterator) new-value))
|
|
d@33
|
71 (defmethod sequence:iterator-index ((o list-slot-sequence) iterator)
|
|
d@33
|
72 (sequence:iterator-index (%list-slot-sequence-data o) iterator))
|
|
d@33
|
73 (defmethod sequence:iterator-copy ((o list-slot-sequence) iterator)
|
|
d@33
|
74 (sequence:iterator-copy (%list-slot-sequence-data o) iterator)) |
