[armedbear-cvs] r12831 - trunk/abcl/src/org/armedbear/lisp
Alessio Stalla
astalla at common-lisp.net
Wed Jul 28 22:13:16 UTC 2010
Author: astalla
Date: Wed Jul 28 18:13:15 2010
New Revision: 12831
Log:
First stab at Java collections integration with the sequences protocol.
Added:
trunk/abcl/src/org/armedbear/lisp/java-collections.lisp
Modified:
trunk/abcl/src/org/armedbear/lisp/JavaObject.java
trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
trunk/abcl/src/org/armedbear/lisp/java.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/JavaObject.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/JavaObject.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/JavaObject.java Wed Jul 28 18:13:15 2010
@@ -97,18 +97,31 @@
return T;
if (type == BuiltInClass.JAVA_OBJECT)
return T;
- if(type.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) {
+ LispObject cls = NIL;
+ if(type instanceof Symbol) {
+ cls = LispClass.findClass(type, false);
+ }
+ if(cls == NIL) {
+ cls = type;
+ }
+ if(cls.typep(LispClass.findClass(JAVA_CLASS, false)) != NIL) {
if(obj != null) {
- Class c = (Class) JAVA_CLASS_JCLASS.execute(type).javaInstance();
+ Class c = (Class) JAVA_CLASS_JCLASS.execute(cls).javaInstance();
return c.isAssignableFrom(obj.getClass()) ? T : NIL;
} else {
return T;
}
+ } else if(cls == BuiltInClass.SEQUENCE) {
+ //This information is replicated here from java.lisp; it is a very
+ //specific case, not worth implementing CPL traversal in typep
+ if(java.util.List.class.isInstance(obj) ||
+ java.util.Set.class.isInstance(obj)) {
+ return T;
+ }
}
return super.typep(type);
}
-
@Override
public LispObject STRING()
{
Modified: trunk/abcl/src/org/armedbear/lisp/compile-system.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compile-system.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compile-system.lisp Wed Jul 28 18:13:15 2010
@@ -186,6 +186,7 @@
"inspect.lisp"
;;"j.lisp"
"java.lisp"
+ "java-collections.lisp"
"known-functions.lisp"
"known-symbols.lisp"
"late-setf.lisp"
Added: trunk/abcl/src/org/armedbear/lisp/java-collections.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/src/org/armedbear/lisp/java-collections.lisp Wed Jul 28 18:13:15 2010
@@ -0,0 +1,145 @@
+(require "CLOS")
+(require "JAVA")
+(require "EXTENSIBLE-SEQUENCES")
+
+(in-package :java)
+
+(defmethod print-object ((coll (jclass "java.util.Collection")) stream)
+ (print-unreadable-object (coll stream :type t :identity t)
+ (format stream "~A ~A"
+ (jclass-of coll)
+ (jcall "toString" coll))))
+
+;;Lists (java.util.List) are the Java counterpart to Lisp SEQUENCEs.
+(defun jlist-add (list item)
+ (jcall (jmethod "java.util.List" "add" "java.lang.Object")
+ list item))
+
+(defun jlist-set (list index item)
+ (jcall (jmethod "java.util.List" "set" "int" "java.lang.Object")
+ list index item))
+
+(defun jlist-get (list index)
+ (jcall (jmethod "java.util.List" "get" "int")
+ list index))
+
+(defmethod sequence:length ((s (jclass "java.util.List")))
+ (jcall (jmethod "java.util.Collection" "size") s))
+
+(defmethod sequence:elt ((s (jclass "java.util.List")) index)
+ (jlist-get s index))
+
+(defmethod (setf sequence:elt) (value (list (jclass "java.util.List")) index)
+ (jlist-set list index value)
+ value)
+
+(defmethod sequence:make-sequence-like
+ ((s (jclass "java.util.List")) length
+ &rest args &key initial-element initial-contents)
+ (declare (ignorable initial-element initial-contents))
+ (apply #'make-jsequence-like s #'jlist-add args))
+
+(defun make-jsequence-like
+ (s add-fn &key (initial-element nil iep) (initial-contents nil icp))
+ (let ((seq (jnew (jclass-of s))))
+ (cond
+ ((and icp iep)
+ (error "Can't specify both :initial-element and :initial-contents"))
+ (icp
+ (dotimes (i length)
+ (funcall add-fn seq (elt initial-contents i)))) ;;TODO inefficient, use iterator
+ (t
+ (dotimes (i length)
+ (funcall add-fn seq initial-element))))
+ seq))
+
+;;TODO: destruct doesn't signal an error for too-many-args for its options
+;;e.g. this didn't complain:
+;;(defstruct (jlist-iterator (:type list :conc-name #:jlist-it-))
+(defstruct (jlist-iterator (:type list) (:conc-name #:jlist-it-))
+ (native-iterator (error "Native iterator required") :read-only t)
+ element
+ index)
+
+(defmethod sequence:make-simple-sequence-iterator
+ ((s (jclass "java.util.List")) &key from-end (start 0) end)
+ (let* ((end (or end (length s)))
+ (index (if from-end (1- end) start))
+ (it (jcall "listIterator" s index))
+ (iter (make-jlist-iterator :native-iterator it
+ :index (if from-end (1+ index)
+ (1- index))))
+ (limit (if from-end start (1- end))))
+ ;;CL iterator semantics are that first element is present from the start
+ (unless (sequence:iterator-endp s iter limit from-end)
+ (sequence:iterator-step s iter from-end))
+ (values iter limit from-end)))
+
+;;Collection, and not List, because we want to reuse this for Set when applicable
+(defmethod sequence:iterator-step
+ ((s (jclass "java.util.Collection")) it from-end)
+ (if from-end
+ (progn
+ (setf (jlist-it-element it)
+ (jcall "previous" (jlist-it-native-iterator it)))
+ (decf (jlist-it-index it)))
+ (progn
+ (setf (jlist-it-element it)
+ (jcall "next" (jlist-it-native-iterator it)))
+ (incf (jlist-it-index it))))
+ it)
+
+(defmethod sequence:iterator-endp
+ ((s (jclass "java.util.Collection")) it limit from-end)
+ (if from-end
+ (<= (jlist-it-index it) limit)
+ (>= (jlist-it-index it) limit)))
+
+(defmethod sequence:iterator-element
+ ((s (jclass "java.util.Collection")) iterator)
+ (declare (ignore s))
+ (jlist-it-element iterator))
+
+(defmethod (setf sequence:iterator-element)
+ (new-value (s (jclass "java.util.Collection")) it)
+ (jcall "set" (jlist-it-native-iterator it) new-value))
+
+(defmethod sequence:iterator-index
+ ((s (jclass "java.util.Collection")) iterator)
+ (declare (ignore s))
+ (jlist-it-index iterator))
+
+(defmethod sequence:iterator-copy ((s (jclass "java.util.Collection")) iterator)
+ (declare (ignore s iterator))
+ (error "iterator-copy not supported for Java iterators."))
+
+;;However, it makes sense to have some sequence functions available for Sets
+;;(java.util.Set) too, even if they're not sequences.
+(defun jset-add (set item)
+ (jcall (jmethod "java.util.Set" "add" "java.lang.Object")
+ set item))
+
+(defmethod sequence:length ((s (jclass "java.util.Set")))
+ (jcall (jmethod "java.util.Collection" "size") s))
+
+(defmethod sequence:make-sequence-like
+ ((s (jclass "java.util.Set")) length
+ &rest args &key initial-element initial-contents)
+ (declare (ignorable initial-element initial-contents))
+ (apply #'make-jsequence-like s #'jset-add args))
+
+(defmethod sequence:make-simple-sequence-iterator
+ ((s (jclass "java.util.Set")) &key from-end (start 0) end)
+ (when (or from-end (not (= start 0)))
+ (error "Java Sets can only be iterated from the start."))
+ (let* ((end (or end (length s)))
+ (it (jcall "iterator" s))
+ (iter (make-jlist-iterator :native-iterator it
+ :index -1))
+ (limit (1- end)))
+ ;;CL iterator semantics are that first element is present from the start
+ (unless (sequence:iterator-endp s iter limit nil)
+ (sequence:iterator-step s iter nil))
+ (values iter limit nil)))
+
+(provide :java-collections)
\ No newline at end of file
Modified: trunk/abcl/src/org/armedbear/lisp/java.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/java.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/java.lisp Wed Jul 28 18:13:15 2010
@@ -149,6 +149,11 @@
method implementation)))))
lisp-this))
+(defun jequal (obj1 obj2)
+ "Compares obj1 with obj2 using java.lang.Object.equals()"
+ (jcall (jmethod "java.lang.Object" "equals" "java.lang.Object")
+ obj1 obj2))
+
(defun jobject-class (obj)
"Returns the Java class that OBJ belongs to"
(jcall (jmethod "java.lang.Object" "getClass") obj))
@@ -363,6 +368,15 @@
:direct-superclasses (list (find-class 'java-object))
:java-class +java-lang-object+)))
+(defun jclass-additional-superclasses (jclass)
+ "Extension point to put additional CLOS classes on the CPL of a CLOS Java class."
+ (let ((supers nil))
+ (when (jclass-interface-p jclass)
+ (push (find-class 'java-object) supers))
+ (when (jequal jclass (jclass "java.util.List"))
+ (push (find-class 'sequence) supers))
+ supers))
+
(defun ensure-java-class (jclass)
(let ((class (%find-java-class jclass)))
(if class
@@ -378,9 +392,7 @@
(concatenate 'list
(list (jclass-superclass jclass))
(jclass-interfaces jclass))))))
- (if (jclass-interface-p jclass)
- (append supers (list (find-class 'java-object)))
- supers))
+ (append supers (jclass-additional-superclasses jclass)))
:java-class jclass)))))
(defmethod mop::compute-class-precedence-list ((class java-class))
More information about the armedbear-cvs
mailing list