Skip to content

Instantly share code, notes, and snippets.

@killerstorm

killerstorm/jfli.diff

Created June 12, 2012 11:10
Show Gist options
  • Save killerstorm/2916945 to your computer and use it in GitHub Desktop.
Save killerstorm/2916945 to your computer and use it in GitHub Desktop.
Download ZIP
difference between original jfli-abcl and Ole's version
Raw
jfli.diff
--- /home/alex/jfli-abcl-orig/jfli-abcl/jfli-abcl.lisp 2004-11-20 21:03:04.000000000 +0200
+++ /home/alex/jfli/jfli.lisp 2012-05-27 19:46:23.955496247 +0300
@@ -6,6 +6,9 @@
; the terms of this license.
; You must not remove this notice, or any other, from this software.
+; Ported to ABCL by [email protected].
+; Minor ABCL fixes by A. Vodonosov ([email protected]).
+; Ripped out CLOS mirror support
(defpackage :jfli
(:use :common-lisp :java)
@@ -22,7 +25,6 @@
:find-java-class
:new
:make-new
- :make-typed-ref
:jeq
;array support
@@ -42,60 +44,29 @@
:new-proxy
:unregister-proxy
- ;conversions
- :box-boolean
- :box-byte
- :box-char
- :box-double
- :box-float
- :box-integer
- :box-long
- :box-short
- :box-string
- :unbox-boolean
- :unbox-byte
- :unbox-char
- :unbox-double
- :unbox-float
- :unbox-integer
- :unbox-long
- :unbox-short
- :unbox-string
-
-; :ensure-package
-; :member-symbol
-; :class-symbol
-; :constructor-symbol
-
- :*null*
- :new-class
- :super
))
(in-package :jfli)
-
+#+ignore
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun string-append (&rest strings)
- (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings)))
-
+ (defconstant +null+ (make-immediate-object nil :ref))
+ (defconstant +false+ (make-immediate-object nil :boolean))
+ (defconstant +true+ (make-immediate-object t :boolean)))
-(defun intern-and-unexport (string package)
- (multiple-value-bind (symbol status)
- (find-symbol string package)
- (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package))
- (intern string package)))
-)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun string-append (&rest strings)
+ (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings)))
+ (defun intern-and-unexport (string package)
+ (multiple-value-bind (symbol status)
+ (find-symbol string package)
+ (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package))
+ (intern string package))))
(defun is-assignable-from (class-1 class-2)
(jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class")
class-2 class-1)) ;;not a typo
-#+abcl_not_used
-(defun new-object-array (len element-type initial-element)
- (jnew-array-from-array element-type (make-array (list len) :initial-element initial-element)))
-
-
(defun java-ref-p (x)
(java-object-p x))
@@ -118,6 +89,9 @@
(defun convert-to-java-string (s)
(jnew (jconstructor "java.lang.String" "java.lang.String") s))
+(defun convert-from-java-string (s)
+ (values s))
+
(define-symbol-macro boolean.type (jfield "java.lang.Boolean" "TYPE"))
(define-symbol-macro byte.type (jfield "java.lang.Byte" "TYPE"))
(define-symbol-macro character.type (jfield "java.lang.Character" "TYPE"))
@@ -126,24 +100,10 @@
(define-symbol-macro long.type (jfield "java.lang.Long" "TYPE"))
(define-symbol-macro float.type (jfield "java.lang.Float" "TYPE"))
(define-symbol-macro double.type (jfield "java.lang.Double" "TYPE"))
+(define-symbol-macro string.type (jclass "java.lang.String"))
+(define-symbol-macro object.type (jclass "java.lang.Object"))
(define-symbol-macro void.type (jfield "java.lang.Void" "TYPE"))
-#|
-(defconstant boolean.type (jfield "java.lang.Boolean" "TYPE"))
-(defconstant byte.type (jfield "java.lang.Byte" "TYPE"))
-(defconstant character.type (jfield "java.lang.Character" "TYPE"))
-(defconstant short.type (jfield "java.lang.Short" "TYPE"))
-(defconstant integer.type (jfield "java.lang.Integer" "TYPE"))
-(defconstant long.type (jfield "java.lang.Long" "TYPE"))
-(defconstant float.type (jfield "java.lang.Float" "TYPE"))
-(defconstant double.type (jfield "java.lang.Double" "TYPE"))
-|#
-
-(defconstant *null* (make-immediate-object nil :ref))
-
-(defun identity-or-nil (obj)
- (unless (equal obj *null*) obj))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
@@ -178,21 +138,16 @@
(eval-when (:compile-toplevel)
(intern-and-unexport "OBJECT." "java.lang"))
-;create object. to bootstrap the hierarchy
-(defclass |java.lang|::object. ()
- ((ref :reader ref :initarg :ref)
- (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform nil))
- (:documentation "the superclass of all Java typed reference classes"))
-
(defun get-ref (x)
"any function taking an object can be passed a raw java-ref ptr or a typed reference instance.
Will also convert strings for use as objects"
- (etypecase x
+ (typecase x
(java-ref x)
- (|java.lang|::object. (ref x))
(string (convert-to-java-string x))
(null nil)
- ((or number character) x)))
+ ((or number character) x)
+ ;; avodonosov: otherwise clause
+ (otherwise x)))
(defun is-same-object (obj1 obj2)
(equal obj1 obj2))
@@ -285,17 +240,18 @@
(:short short.type)
(:double double.type)
(:byte byte.type)
+ (:object object.type)
(:void void.type)
(otherwise (get-java-class-ref class-sym-or-string))))
(string (get-java-class-ref (canonic-class-symbol class-sym-or-string)))))
-;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
-The library maintains a hierarchy of typed reference classes that parallel the
-class hierarchy on the Java side
-new returns a typed reference, but other functions that return objects
-return raw references (for efficiency)
-make-typed-ref can create fully-typed wrappers when desired
+In an effort to reduce the volume of stuff generated when wrapping entire libraries,
+the wrappers just generate minimal stubs, which, if and when invoked at runtime,
+complete the work of building thunking closures, so very little code is generated for
+things never called (Java libraries have huge numbers of symbols).
+Not sure if this approach matters, but that's how it works
|#
(defun get-superclass-names (full-class-name)
@@ -319,67 +275,6 @@
(lambda (x y)
(is-assignable-from x y)))))
(mapcar #'jclass-name result))))
-#|
-(defun get-superclass-names (full-class-name)
- (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)))
- (super (class.getsuperclass class))
- (interfaces (class.getinterfaces class))
- (supers ()))
- (do-jarray (i interfaces)
- (push (class.getname i) supers))
- ;hmmm - where should the base class go in the precedence list?
- ;is it more important than the interfaces? this says no
- (if super
- (push (class.getname super) supers)
- (push "java.lang.Object" supers))
- (nreverse supers)))
-|#
-
-(defun ensure-java-class (full-class-name)
- "walks the superclass hierarchy and makes sure all the classes are fully defined
-(they may be undefined or just forward-referenced-class)
-caches this has been done on the class-symbol's plist"
- (let* ((class-sym (class-symbol full-class-name))
- (class (find-class class-sym nil)))
- (if (or (eql class-sym '|java.lang|::object.)
- (get class-sym :ensured))
- class
- (let ((supers (get-superclass-names full-class-name)))
- (dolist (super supers)
- (ensure-java-class super))
- (unless (and class (subtypep class 'standard-object))
- (setf class
- #+abcl
- (sys::ensure-class class-sym :direct-superclasses (mapcar #'(lambda (c) (find-class (class-symbol c))) supers))))
- (setf (get class-sym :ensured) t)
- class))))
-
-
-(defun ensure-java-hierarchy (class-sym)
- "Works off class-sym for efficient use in new
-This will only work on class-syms created by def-java-class,
-as it depends upon symbol-value being the canonic class symbol"
- (unless (get class-sym :ensured)
- (ensure-java-class (java-class-name class-sym))))
-
-(defun make-typed-ref (java-ref)
- "Given a raw java-ref, determines the full type of the object
-and returns an instance of a typed reference wrapper"
- (when java-ref
- (let ((class (jobject-class java-ref)))
- (if (jclass-array-p class)
- (error "typed refs not supported for arrays (yet)")
- (make-instance (ensure-java-class (jclass-name class)) :ref java-ref)))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-In an effort to reduce the volume of stuff generated when wrapping entire libraries,
-the wrappers just generate minimal stubs, which, if and when invoked at runtime,
-complete the work of building thunking closures, so very little code is generated for
-things never called (Java libraries have huge numbers of symbols).
-Not sure if this approach matters, but that's how it works
-|#
(defmacro def-java-class (full-class-name)
"Given the package-qualified, case-correct name of a java class, will generate
@@ -389,9 +284,8 @@
(let* ((class-sym (unexported-class-symbol full-class-name))
(defs
(list*
- #+nil `(format t "!!!!!!!!!!~a~%" ,full-class-name)
`(ensure-package ,pacakge)
- ;build a path from the simple class symbol to the canonic
+ ;;build a path from the simple class symbol to the canonic
`(defconstant ,class-sym ',(canonic-class-symbol full-class-name))
`(export ',class-sym (symbol-package ',class-sym))
`(def-java-constructors ,full-class-name)
@@ -406,10 +300,7 @@
(lambda (p) `(ensure-package ,(package-name p)))
(remove (symbol-package class-sym)
(remove-duplicates (mapcar #'symbol-package supers))))
- super-exports
- (list
- `(defclass ,(class-symbol full-class-name)
- ,supers ()))))))))
+ super-exports))))))
`(locally ,@defs))))
(defun jarfile.new (fn)
@@ -512,24 +403,22 @@
(let* ((ctor-list (get-ctor-list full-class-name)))
(when ctor-list
(setf (fdefinition (constructor-symbol full-class-name))
- (make-ctor-thunk ctor-list (class-symbol full-class-name))))))
+ (make-ctor-thunk ctor-list)))))
-(defun make-ctor-thunk (ctors class-sym)
+(defun make-ctor-thunk (ctors)
(if (rest ctors) ;overloaded
- (make-overloaded-ctor-thunk ctors class-sym)
- (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
+ (make-overloaded-ctor-thunk ctors)
+ (make-non-overloaded-ctor-thunk (first ctors))))
-(defun make-non-overloaded-ctor-thunk (ctor class-sym)
+(defun make-non-overloaded-ctor-thunk (ctor)
(let ((arg-boxers (get-arg-boxers (jconstructor-params ctor))))
(lambda (&rest args)
- (let ((arglist (build-arglist args arg-boxers)))
- (ensure-java-hierarchy class-sym)
- (make-instance class-sym
- :ref (apply #'jnew ctor arglist)
- :lisp-allocated t)))))
+ (let* ((arglist (build-arglist args arg-boxers))
+ (object (apply #'jnew ctor arglist)))
+ (unbox-object object)))))
-(defun make-overloaded-ctor-thunk (ctors class-sym)
- (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym)))
+(defun make-overloaded-ctor-thunk (ctors)
+ (let ((thunks (make-ctor-thunks-by-args-length ctors)))
(lambda (&rest args)
(let ((fn (cdr (assoc (length args) thunks))))
(if fn
@@ -537,7 +426,7 @@
args)
(error "invalid arity"))))))
-(defun make-ctor-thunks-by-args-length (ctors class-sym)
+(defun make-ctor-thunks-by-args-length (ctors)
"returns an alist of thunks keyed by number of args"
(let ((ctors-by-args-length (make-hash-table))
(thunks-by-args-length nil))
@@ -547,17 +436,17 @@
(maphash #'(lambda (args-len ctors)
(push (cons args-len
(if (rest ctors);truly overloaded
- (make-type-overloaded-ctor-thunk ctors class-sym)
+ (make-type-overloaded-ctor-thunk ctors)
;only one ctor with this number of args
- (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
+ (make-non-overloaded-ctor-thunk (first ctors))))
thunks-by-args-length))
ctors-by-args-length)
thunks-by-args-length))
-(defun make-type-overloaded-ctor-thunk (ctors class-sym)
+(defun make-type-overloaded-ctor-thunk (ctors)
"these methods have the same number of args and must be distinguished by type"
(let ((thunks (mapcar #'(lambda (ctor)
- (list (make-non-overloaded-ctor-thunk ctor class-sym)
+ (list (make-non-overloaded-ctor-thunk ctor)
(jarray-to-list (jconstructor-params ctor))))
ctors)))
(lambda (&rest args)
@@ -695,24 +584,18 @@
(progn
(setf (fdefinition field-sym)
(lambda ()
- (funcall unboxer (jfield-raw class field-name) #+nil (field.get field nil))))
+ (funcall unboxer (jfield-raw class field-name))))
(setf (fdefinition `(setf ,field-sym))
(lambda (arg)
- (jfield field-name nil
- (get-ref (if (and boxer (not (boxed? arg)))
- (funcall boxer arg)
- arg)))
+ (jfield field-name nil (get-ref (funcall boxer arg)))
arg)))
(progn
(setf (fdefinition field-sym)
(lambda (obj)
- (funcall unboxer (jfield-raw class field-name (get-ref obj)) #+nil(field.get field (get-ref obj)))))
+ (funcall unboxer (jfield-raw class field-name (get-ref obj)))))
(setf (fdefinition `(setf ,field-sym))
(lambda (arg obj)
- (jfield field-name (get-ref obj)
- (get-ref (if (and boxer (not (boxed? arg)))
- (funcall boxer arg)
- arg)))
+ (jfield field-name (get-ref obj) (get-ref (funcall boxer arg)))
arg))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -744,13 +627,13 @@
(mapcar #'class-name-for-doc (jarray-to-list (jmethod-params m)))))))
(defmacro def-java-methods (full-class-name)
- (let ((methods-by-name (get-methods-by-name full-class-name))
+ (let ((class-methods (get-class-methods full-class-name))
(defs nil))
(maphash (lambda (name methods)
(let ((method-sym (unexported-member-symbol full-class-name name)))
(push `(defun ,method-sym (&rest args)
,(build-method-doc-string name methods)
- (apply #'install-methods-and-call ,full-class-name ,name args))
+ (apply #'install-method-and-call ,full-class-name ,name args))
defs)
(push `(export ',method-sym (symbol-package ',method-sym))
defs)
@@ -758,7 +641,7 @@
(flet ((add-setter-if (prefix)
(when (eql 0 (search prefix name))
(let ((setname (string-append "set" (subseq name (length prefix)))))
- (when (gethash setname methods-by-name)
+ (when (gethash setname class-methods)
(push `(defun (setf ,method-sym) (val &rest args)
(progn
(apply #',(member-symbol full-class-name setname)
@@ -767,15 +650,15 @@
defs))))))
(add-setter-if "get")
(add-setter-if "is"))))
- methods-by-name)
+ class-methods)
`(locally ,@(nreverse defs))))
-(defun install-methods-and-call (full-class-name method &rest args)
+(defun install-method-and-call (full-class-name name &rest args)
"initially all the member function symbols for a class are bound to this function,
when first called it will replace them with the appropriate direct thunks,
then call the requested method - subsequent calls via those symbols will be direct"
- (install-methods full-class-name)
- (apply (member-symbol full-class-name method) args))
+ (install-method full-class-name name)
+ (apply (member-symbol full-class-name name) args))
(defun decode-array-name (tn)
(let ((prim (assoc tn
@@ -806,8 +689,7 @@
(defun jmethod-made-accessible (method)
"Return a method made accessible"
(jcall (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean")
- method
- (make-immediate-object t :boolean))
+ method +true+)
method)
(defun jclass-relevant-methods (class)
@@ -816,24 +698,22 @@
(map 'list #'jmethod-made-accessible
(remove-if-not #'jmember-protected-p (jclass-methods class :declared t)))))
-(defun get-methods-by-name (full-class-name)
+(defun get-class-methods (full-class-name)
"returns an #'equal hashtable of lists of java.lang.Method refs keyed by name"
(let* ((class-sym (canonic-class-symbol full-class-name))
(class (get-java-class-ref class-sym))
(methods (jclass-relevant-methods class))
- (methods-by-name (make-hash-table :test #'equal)))
+ (class-methods (make-hash-table :test #'equal)))
(loop for method in methods
do
- (push method (gethash (jmethod-name method) methods-by-name)))
- methods-by-name))
+ (push method (gethash (jmethod-name method) class-methods)))
+ class-methods))
-(defun install-methods (full-class-name)
- (let ((methods-by-name (get-methods-by-name full-class-name)))
- (maphash
- (lambda (name methods)
- (setf (fdefinition (member-symbol full-class-name name))
- (make-method-thunk methods)))
- methods-by-name)))
+(defun install-method (full-class-name name)
+ (let* ((class-methods (get-class-methods full-class-name))
+ (methods (gethash name class-methods)))
+ (setf (fdefinition (member-symbol full-class-name name))
+ (make-method-thunk methods))))
(defun make-method-thunk (methods)
(if (rest methods) ;overloaded
@@ -846,11 +726,9 @@
(is-static (jmember-static-p method))
(caller (if is-static #'jstatic-raw #'jcall-raw)))
(lambda (&rest args)
- (let ((arglist (build-arglist (if is-static args (rest args)) arg-boxers)))
- (funcall unboxer-fn
- (apply caller method
- (if is-static nil (get-ref (first args)))
- arglist))))))
+ (let ((object (if is-static nil (get-ref (first args))))
+ (arglist (build-arglist (if is-static args (rest args)) arg-boxers)))
+ (funcall unboxer-fn (apply caller method object arglist))))))
(defun make-overloaded-thunk (methods)
(let ((thunks (make-thunks-by-args-length methods)))
@@ -903,11 +781,8 @@
(defun jref (array &rest subscripts)
(apply #'jarray-ref-raw array subscripts))
-
(defun (setf jref) (val array &rest subscripts)
- (apply #'jarray-set array val subscripts))
-
-
+ (apply #'jarray-set array (get-ref val) subscripts))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro def-refs (&rest types)
@@ -919,11 +794,10 @@
`(defun ,ref-sym (array &rest subscripts)
,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type))
(assert (every #'integerp subscripts))
- (apply #'jarray-ref array subscripts))
-
+ (unbox-object (apply #'jarray-ref array subscripts)))
`(defun (setf ,ref-sym) (val array &rest subscripts)
(assert (every #'integerp subscripts))
- (apply #'jarray-set array ,(if (eql type 'boolean) '(box-boolean val) 'val) subscripts)
+ (apply #'jarray-set array val subscripts)
))))
types))))
@@ -970,15 +844,16 @@
(defmethod make-new-array ((type (eql :long)) &rest dimensions)
(apply #'make-new-array long.type dimensions))
+(defmethod make-new-array ((type (eql :object)) &rest dimensions)
+ (apply #'make-new-array object.type dimensions))
+
;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;;
(defun get-arg-boxers (param-types)
"returns a list with one entry per param, either nil or a function that boxes the arg"
- (loop for param-type across param-types
- collecting (get-boxer-fn (jclass-name param-type))))
-
-
+ (loop for param-type across param-types collect
+ (get-boxer-fn (jclass-name param-type))))
(defun build-arglist (args arg-boxers)
(when args
@@ -1008,21 +883,10 @@
;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun box-string (s)
- "Given a string or symbol, returns reference to a Java string"
- (convert-to-java-string s))
-
-(defun unbox-string (ref &optional delete-local)
- "Given a reference to a Java string, returns a Lisp string"
- (declare (ignore delete-local))
- (convert-from-java-string (get-ref ref)))
-
-
-
(defun get-boxer-fn (class-name)
(if (string= class-name "boolean")
#'box-boolean
- nil))
+ #'identity))
(defun get-boxer-fn-sym (class-name)
(if (string= class-name "boolean")
@@ -1039,38 +903,48 @@
((boxed? x) (jobject-class (get-ref x)))
((integerp x) integer.type)
((numberp x) double.type)
- ; ((characterp x) character.type) ;;;FIXME!!
((eq x t) boolean.type)
- ((or (stringp x) (symbolp x))
- (get-java-class-ref '|java.lang|::|String|))
+ ((stringp x) string.type)
+ ((symbolp x) string.type)
+ (t object.type)
(t (error "can't infer box type"))))
-
(defun get-unboxer-fn (class-name)
- (if (string= class-name "void")
- #'unbox-void
- (if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String"))
- #'jobject-lisp-value
- #'identity-or-nil)))
+ (cond ((string= class-name "void") #'unbox-void)
+ ((is-name-of-primitive class-name) #'unbox-primitive)
+ ((string= class-name "java.lang.String") #'unbox-string)
+ ((string= class-name "java.lang.Boolean") #'unbox-boolean)
+ (t #'unbox-object)))
(defun get-unboxer-fn-sym (class-name)
- (if (string= class-name "void")
- 'unbox-void
- (if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String"))
- 'jobject-lisp-value
- 'identity-or-nil)))
-
+ (cond ((string= class-name "void") 'unbox-void)
+ ((is-name-of-primitive class-name) 'unbox-primitive)
+ ((string= class-name "java.lang.String") 'unbox-string)
+ ((string= class-name "java.lang.Boolean") 'unbox-boolean)
+ (t 'unbox-object)))
(defun unbox-void (x &optional delete-local)
(declare (ignore x delete-local))
nil)
-(defun box-void (x)
- (declare (ignore x))
- nil)
+(defun unbox-primitive (x)
+ (unless (equal x +null+)
+ (jobject-lisp-value x)))
+
+(defun unbox-string (x)
+ (unless (equal x +null+)
+ (jobject-lisp-value x)))
+
+(defun unbox-boolean (x)
+ (unless (equal x +null+)
+ (jobject-lisp-value x)))
+
+(defun unbox-object (x)
+ (unless (equal x +null+)
+ (jcoerce x (jclass-of x))))
(defun box-boolean (x)
- (make-immediate-object x :boolean))
+ (if x +true+ +false+))
;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1151,26 +1025,6 @@
arg-defs (jarray-to-list params))))
`(java::%jnew-proxy ,@(process-idefs interface-defs)))))
-
-
-(defun jrc (class-name super-name interfaces constructors methods fields &optional filename)
- "A friendlier version of jnew-runtime-class."
- #+nil (format t "~s~%~s~%~s~%~s~%~s~%~s~%" class-name super-name interfaces constructors methods fields filename)
- (if (java:jruntime-class-exists-p class-name)
- (progn
- (warn "Java class ~a already exists. Redefining methods." class-name)
- (loop for
- (argument-types function super-invocation-args) in constructors
- do
- (java:jredefine-method class-name nil argument-types function))
- (loop for
- (method-name return-type argument-types function &rest modifiers)
- in methods
- do
- (java:jredefine-method class-name method-name argument-types function)))
- (java:jnew-runtime-class class-name super-name interfaces constructors methods fields filename)))
-
-
(defun get-modifiers (member)
(jcall (jmethod "java.lang.reflect.Member" "getModifiers") member))
@@ -1192,163 +1046,10 @@
mods)
collect mod)))
-
-(defun get-java-object (x)
- (typecase x
- (|java.lang|::object. (ref x))
- (t x)))
-
(defun find-java-class-name-in-macro (c)
(etypecase c
(symbol (jclass-name (find-java-class (symbol-value c))))
(string c)))
-(defmacro new-class (class-name super-and-interface-names constructor-defs method-defs field-defs)
- "class-name -> string
- super-and-interface-names -> class-name | (class-name interface-name*)
- constructor-defs -> (constructor-def*)
- constructor-def -> (ctr-arg-defs body)
- /the first form in body may be (super arg-name+); this will call the constructor of the superclass
- with the listed arguments/
- ctr-arg-def -> (arg-name arg-type)
- method-def -> (method-name return-type access-modifiers arg-defs* body)
- /access-modifiers may be nil (to get the modifiers from the superclass), a keyword, or
- a list of keywords/
- method-name -> string
-arg-def -> arg-name | (arg-name arg-type)
-arg-type -> \"package.qualified.ClassName\" | classname. | :primitive
-class-name -> \"package.qualified.ClassName\" | classname.
-interface-name -> \"package.qualified.InterfaceName\" | interfacename.
-
-Creates, registers and returns a Java object that implements the supplied interfaces"
- (let ((this (intern "THIS" *package*))
- (defined-method-names))
- (labels ((process-ctr-def (ctr-def ctrs)
- (destructuring-bind ((&rest arg-defs) &body body)
- ctr-def
- (let ((ctr-param-names
- (mapcar
- #'(lambda (arg-def) (find-java-class-name-in-macro (cadr arg-def)))
- arg-defs))
- ;(ctr-param-names (mapcar #'cadr arg-defs))
- (gargs (gensym))
- (head (car body))
- (sia))
- (when (and (consp head) (eq (car head) 'super))
- (setq sia (mapcar
- #'(lambda (arg-name)
- (1+ (position arg-name arg-defs :key #'car)))
- (cdr head))
- body (cdr body)))
- `(,ctr-param-names
- (lambda (&rest ,gargs)
- (let ,(arg-lets (append arg-defs (list this))
- (append
- ctr-param-names
- (list class-name))
- gargs
- 0)
- ,@body))
- ,sia))))
- (process-method-def (method-def methods)
- (destructuring-bind (method-name return-type modifiers (&rest arg-defs) &body body)
- method-def
- (push method-name defined-method-names)
- (let* ((method (matching-method method-name arg-defs methods))
- (method-params
- (if method
- (jarray-to-list (jmethod-params method))
- (mapcar #'(lambda (arg-def) (find-java-class-in-macro (cadr arg-def))) arg-defs)))
- (method-param-names
- #+nil
- (if method
- (mapcar #'jclass-name (jarray-to-list method-params))
- (mapcar #'cadr arg-defs))
- (mapcar #'jclass-name method-params))
- (return-type-name
- (jclass-name
- (if method (jmethod-return-type method) (find-java-class-in-macro return-type))))
- (modifiers
- #+nil
- (if method (get-modifier-list method) '("public"))
- (cond ((and (null modifiers) method) (get-modifier-list method))
- ((symbolp modifiers) (list (string-downcase (symbol-name modifiers))))
- ((consp modifiers) (mapcar #'(lambda (m) (string-downcase (symbol-name m))) modifiers))
- (t (error (format t "Need to provide modifiers for method ~A" method-name)))))
- (gargs (gensym)))
- `(,method-name ,return-type-name ,method-param-names
- (lambda (&rest ,gargs)
- ;;(,(get-boxer-fn-sym return-type-name)
- (get-java-object ;;check!
- (let ,(arg-lets (append arg-defs (list this))
- (append
- method-param-names
- #+nil (map 'list #'(lambda (p) (jclass-name p)) method-params)
- (list class-name))
- gargs
- 0)
- ,@body))
- )
- ,@modifiers))))
- (arg-lets (arg-defs params gargs idx)
- (when arg-defs
- (let ((arg (first arg-defs))
- (param (first params)))
- (cons `(,(if (atom arg) arg (first arg))
- (,(get-unboxer-fn-sym param)
- (nth ,idx ,gargs)))
- (arg-lets (rest arg-defs) (rest params) gargs (1+ idx))))))
- (matching-method (method-name arg-defs methods)
- (let (match)
- (loop for method across methods
- when (method-matches method-name arg-defs method)
- do
- (if match
- (error (format nil "more than one method matches ~A" method-name))
- (setf match method)))
- match))
- (method-matches (method-name arg-defs method)
- (when (string-equal method-name (jmethod-name method))
- (let ((params (jmethod-params method)))
- (when (= (length arg-defs) (length params))
- (is-congruent arg-defs params)))))
- (is-congruent (arg-defs params)
- (every (lambda (arg param)
- (or (atom arg) ;no type spec matches anything
- (jeq (find-java-class-in-macro (second arg)) param)))
- arg-defs (jarray-to-list params))))
- (unless (consp super-and-interface-names)
- (setq super-and-interface-names (list super-and-interface-names)))
- (let* ((super-name (find-java-class-name-in-macro (car super-and-interface-names)))
- (interfaces (mapcar #'find-java-class-name-in-macro (cdr super-and-interface-names)))
- (super (jclass super-name))
- (super-ctrs (jclass-constructors super))
- (ctrs-ret (loop for ctr-def in constructor-defs collecting
- (process-ctr-def ctr-def super-ctrs)))
- (super-methods (jclass-methods super))
- (iface-methods
- (apply #'concatenate 'vector
- (mapcar #'(lambda (ifn)
- (jclass-methods (jclass ifn)))
- interfaces)))
- (methods-ret (loop for method-def in method-defs collecting
- (process-method-def
- method-def
- (concatenate 'vector super-methods iface-methods)))))
- ;;check to make sure every function is defined
- (loop for method across iface-methods
- for mname = (jmethod-name method)
- unless (member mname defined-method-names :test #'string-equal)
- do
- (warn (format nil "class doesn't define:~%~A" mname)))
- `(progn
- (jrc ,class-name ,super-name ,interfaces
- ',ctrs-ret
- ',methods-ret
- (loop for (fn type . mods) in ',field-defs
- collecting `(,fn ,(find-java-class-name-in-macro type)
- ,@(mapcar #'(lambda (mod) (string-downcase (symbol-name mod))) mods)))
- #+nil ,(namestring (merge-pathnames class-name "/tmp/")))
- (eval '(def-java-class ,class-name)))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment