source: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp @ 14196

Last change on this file since 14196 was 14114, checked in by ehuelsmann, 8 years ago

Modules defining PRINT-OBJECT methods, should require PRINT-OBJECT.
Make java-collections.lisp do so.

File size: 6.2 KB
Line 
1(require "CLOS")
2(require "JAVA")
3(require "EXTENSIBLE-SEQUENCES")
4(require "PRINT-OBJECT")
5
6(in-package :java)
7
8(let* ((jclass (jclass "java.util.List"))
9       (class (%find-java-class jclass)))
10  (if class
11      (error "java.util.List is already registered as a Lisp class; since JAVA-CLASSes can't be redefined, I can't inject SEQUENCE in its class precedence list. Ensure that you require :java-collections before specializing any method on java.util.List and in general before using java.util.List as a CLOS class.")
12      ;;The code below is adapted from ensure-java-class in java.lisp
13      (%register-java-class
14       jclass (mop::ensure-class
15               (make-symbol (jclass-name jclass))
16               :metaclass (find-class 'java-class)
17               :direct-superclasses
18               (let ((supers
19                      (mapcar #'ensure-java-class
20                              (delete nil
21                                      (concatenate 'list
22                                                   (list (jclass-superclass jclass))
23                                                   (jclass-interfaces jclass))))))
24                 (append supers (list (find-class 'sequence)) (jclass-additional-superclasses jclass)))
25               :java-class jclass))))
26
27(defmethod print-object ((coll (jclass "java.util.Collection")) stream)
28  (print-unreadable-object (coll stream :type t :identity t)
29    (format stream "~A ~A"
30      (jclass-of coll)
31      (jcall "toString" coll))))
32
33;;Lists (java.util.List) are the Java counterpart to Lisp SEQUENCEs.
34(defun jlist-add (list item)
35  (jcall (jmethod "java.util.List" "add" "java.lang.Object")
36   list item))
37
38(defun jlist-set (list index item)
39  (jcall (jmethod "java.util.List" "set" "int" "java.lang.Object")
40   list index item))
41
42(defun jlist-get (list index)
43  (jcall (jmethod "java.util.List" "get" "int")
44   list index))
45
46(defmethod sequence:length ((s (jclass "java.util.List")))
47  (jcall (jmethod "java.util.Collection" "size") s))
48
49(defmethod sequence:elt ((s (jclass "java.util.List")) index)
50  (jlist-get s index))
51
52(defmethod (setf sequence:elt) (value (list (jclass "java.util.List")) index)
53  (jlist-set list index value)
54  value)
55
56(defmethod sequence:make-sequence-like
57    ((s (jclass "java.util.List")) length
58     &rest args &key initial-element initial-contents)
59  (declare (ignorable initial-element initial-contents))
60  (apply #'make-jsequence-like s length #'jlist-add args))
61
62(defun make-jsequence-like
63    (s length add-fn &key (initial-element nil iep) (initial-contents nil icp))
64  (let ((seq (jnew (jclass-of s))))
65    (cond
66      ((and icp iep)
67       (error "Can't specify both :initial-element and :initial-contents"))
68      (icp
69       (dotimes (i length)
70   (funcall add-fn seq (elt initial-contents i)))) ;;TODO inefficient, use iterator
71      (t
72       (dotimes (i length)
73   (funcall add-fn seq initial-element))))
74    seq))
75
76;;TODO: destruct doesn't signal an error for too-many-args for its options
77;;e.g. this didn't complain:
78;;(defstruct (jlist-iterator (:type list :conc-name #:jlist-it-))
79(defstruct (jlist-iterator (:type list) (:conc-name #:jlist-it-))
80  (native-iterator (error "Native iterator required") :read-only t)
81  element
82  index)
83
84(defmethod sequence:make-simple-sequence-iterator
85    ((s (jclass "java.util.List")) &key from-end (start 0) end)
86  (let* ((end (or end (length s)))
87   (index (if from-end end start))
88   (it (jcall "listIterator" s index))
89   (iter (make-jlist-iterator :native-iterator it
90            :index (if from-end (1+ index) (1- index))))
91   (limit (if from-end (1+ start) (1- end))))
92    ;;CL iterator semantics are that first element is present from the start
93    (unless (sequence:iterator-endp s iter limit from-end)
94      (sequence:iterator-step s iter from-end))
95    (values iter limit from-end)))
96
97;;Collection, and not List, because we want to reuse this for Set when applicable
98(defmethod sequence:iterator-step
99    ((s (jclass "java.util.Collection")) it from-end)
100  (let ((native-it (jlist-it-native-iterator it)))
101    (if from-end
102  (progn
103    (setf (jlist-it-element it)
104    (when (jcall "hasPrevious" native-it)
105      (jcall "previous" native-it)))
106    (decf (jlist-it-index it)))
107  (progn
108    (setf (jlist-it-element it)
109    (when (jcall "hasNext" native-it)
110      (jcall "next" native-it)))
111    (incf (jlist-it-index it)))))
112  it)
113
114(defmethod sequence:iterator-endp
115    ((s (jclass "java.util.Collection")) it limit from-end)
116  (if from-end
117      (< (jlist-it-index it) limit)
118      (> (jlist-it-index it) limit)))
119
120(defmethod sequence:iterator-element
121    ((s (jclass "java.util.Collection")) iterator)
122  (declare (ignore s))
123  (jlist-it-element iterator))
124
125(defmethod (setf sequence:iterator-element)
126    (new-value (s (jclass "java.util.Collection")) it)
127  (jcall "set" (jlist-it-native-iterator it) new-value))
128
129(defmethod sequence:iterator-index
130    ((s (jclass "java.util.Collection")) iterator)
131  (declare (ignore s))
132  (jlist-it-index iterator))
133
134(defmethod sequence:iterator-copy ((s (jclass "java.util.Collection")) iterator)
135  (declare (ignore s iterator))
136  (error "iterator-copy not supported for Java iterators."))
137
138;;It makes sense to have some sequence functions available for Sets
139;;(java.util.Set) too, even if they're not sequences.
140(defun jset-add (set item)
141  (jcall (jmethod "java.util.Set" "add" "java.lang.Object")
142   set item))
143
144(defmethod sequence:length ((s (jclass "java.util.Set")))
145  (jcall (jmethod "java.util.Collection" "size") s))
146
147(defmethod sequence:make-sequence-like
148    ((s (jclass "java.util.Set")) length
149     &rest args &key initial-element initial-contents)
150  (declare (ignorable initial-element initial-contents))
151  (apply #'make-jsequence-like s length #'jset-add args))
152
153(defmethod sequence:make-simple-sequence-iterator
154    ((s (jclass "java.util.Set")) &key from-end (start 0) end)
155  (when (or from-end (not (= start 0)))
156    (error "Java Sets can only be iterated from the start."))
157  (let* ((end (or end (length s)))
158   (it (jcall "iterator" s))
159   (iter (make-jlist-iterator :native-iterator it
160            :index -1))
161   (limit (1- end)))
162    ;;CL iterator semantics are that first element is present from the start
163    (unless (sequence:iterator-endp s iter limit nil)
164      (sequence:iterator-step s iter nil))
165    (values iter limit nil)))
166
167(provide :java-collections)
Note: See TracBrowser for help on using the repository browser.