Changeset 13962


Ignore:
Timestamp:
06/12/12 11:46:11 (9 years ago)
Author:
Mark Evenson
Message:

jfli: fix jref for byte array problem, clean up code.

Patch by Alex Mizrahi, more fully described in [his email to
<armedbear-devel@>][1].

[1]: ​http://article.gmane.org/gmane.lisp.armedbear.devel/2360

  1. make-immediate-object is deprecated now, so we use java:+null+ and friends
  1. boxing extension by A. Vodonosov is described in comment
  1. ensure-java-class was renamed to %ensure-java-class to avoid collision with java:ensure-java-class which does completely different thing. (I thought about shadowing it, but I think renaming makes it clearer.)
  1. support for both int and long in overloads (or however they are called in Java)
  1. new-class functionality was commented out because abcl-side interface have changed. (together with its helper jrc)
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/abcl/contrib/jfli/jfli.lisp

    r13950 r13962  
    88
    99;    Ported to ABCL by asimon@math.bme.hu.
    10 ;    Minor ABCL fixes by A. Vodonosov (avodonosov@yandex.ru).
    11 ;    Ripped out CLOS mirror support
     10;    Minor ABCL fixes by:
     11;    A. Vodonosov (avodonosov@yandex.ru).
     12;    Alex Mizrahi (alex.mizrahi@gmail.com)
    1213
    1314(defpackage :jfli
    … …  
    2627   :new
    2728   :make-new
     29   :make-typed-ref
    2830   :jeq
    2931
    … …  
    4547   :unregister-proxy
    4648
     49   ;conversions
     50   :box-boolean
     51   :box-byte
     52   :box-char
     53   :box-double
     54   :box-float
     55   :box-integer
     56   :box-long
     57   :box-short
     58   :box-string
     59   :unbox-boolean
     60   :unbox-byte
     61   :unbox-char
     62   :unbox-double
     63   :unbox-float
     64   :unbox-integer
     65   :unbox-long
     66   :unbox-short
     67   :unbox-string
     68
     69;   :ensure-package
     70;   :member-symbol
     71;   :class-symbol
     72;   :constructor-symbol
     73
     74   :*null*
     75   :new-class
     76   :super
    4777   ))
    4878
    4979(in-package :jfli)
    5080
    51 #+ignore
     81
    5282(eval-when (:compile-toplevel :load-toplevel :execute)
    53   (defconstant +null+ (make-immediate-object nil :ref))
    54   (defconstant +false+ (make-immediate-object nil :boolean))
    55   (defconstant +true+ (make-immediate-object t :boolean)))
    56 
    57 (eval-when (:compile-toplevel :load-toplevel :execute)
    58   (defun string-append (&rest strings)
    59     (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings)))
    60   (defun intern-and-unexport (string package)
    61     (multiple-value-bind (symbol status)
    62   (find-symbol string package)
    63       (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package))
    64       (intern string package))))
     83(defun string-append (&rest strings)
     84  (apply #'concatenate 'string (mapcar #'(lambda (s) (if (symbolp s) (symbol-name s) s)) strings)))
     85
     86
     87(defun intern-and-unexport (string package)
     88  (multiple-value-bind (symbol status)
     89      (find-symbol string package)
     90    (when (and *compile-file-pathname* (eq status :external)) (unexport symbol package))
     91    (intern string package)))
     92)
    6593
    6694(defun is-assignable-from (class-1 class-2)
    6795  (jcall (jmethod "java.lang.Class" "isAssignableFrom" "java.lang.Class")
    6896   class-2 class-1))  ;;not a typo
     97
     98#+abcl_not_used
     99(defun new-object-array (len element-type initial-element)
     100  (jnew-array-from-array element-type (make-array (list len) :initial-element initial-element)))
     101
    69102
    70103(defun java-ref-p (x)
    … …  
    90123  (jnew (jconstructor "java.lang.String" "java.lang.String") s))
    91124
    92 (defun convert-from-java-string (s)
    93   (values s))
    94 
    95125(define-symbol-macro boolean.type (jfield "java.lang.Boolean" "TYPE"))
    96126(define-symbol-macro byte.type (jfield "java.lang.Byte" "TYPE"))
    … …  
    101131(define-symbol-macro float.type (jfield "java.lang.Float" "TYPE"))
    102132(define-symbol-macro double.type (jfield "java.lang.Double" "TYPE"))
    103 (define-symbol-macro string.type (jclass "java.lang.String"))
    104 (define-symbol-macro object.type (jclass "java.lang.Object"))
    105133(define-symbol-macro void.type (jfield "java.lang.Void" "TYPE"))
     134
     135#|
     136(defconstant boolean.type (jfield "java.lang.Boolean" "TYPE"))
     137(defconstant byte.type (jfield "java.lang.Byte" "TYPE"))
     138(defconstant character.type (jfield "java.lang.Character" "TYPE"))
     139(defconstant short.type (jfield "java.lang.Short" "TYPE"))
     140(defconstant integer.type (jfield "java.lang.Integer" "TYPE"))
     141(defconstant long.type (jfield "java.lang.Long" "TYPE"))
     142(defconstant float.type (jfield "java.lang.Float" "TYPE"))
     143(defconstant double.type (jfield "java.lang.Double" "TYPE"))
     144|#
     145
     146(defconstant *null* java:+null+)
     147
     148(defun identity-or-nil (obj)
     149  (unless (equal obj *null*) obj))
    106150
    107151;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    … …  
    139183  (intern-and-unexport "OBJECT." "java.lang"))
    140184
     185;create object. to bootstrap the hierarchy
     186(defclass |java.lang|::object. ()
     187  ((ref :reader ref :initarg :ref)
     188   (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform nil))
     189  (:documentation "the superclass of all Java typed reference classes"))
     190
    141191(defun get-ref (x)
    142192  "any function taking an object can be passed a raw java-ref ptr or a typed reference instance.
    143193Will also convert strings for use as objects"
     194;; avodonosov:
     195;; typecase instead of etypecase
     196;; to allow not only jfli-wrapped objects
     197;; as a parameters of NEW-CLASS, but also native
     198;; Lisp objects too (in case of ABCL they are java
     199;; instances anyway).
     200;; For example that may be org.armedbear.lisp.Function.
    144201  (typecase x
    145202    (java-ref x)
     203    (|java.lang|::object. (ref x))
    146204    (string (convert-to-java-string x))
    147205    (null nil)
    148206    ((or number character) x)
    149207    ;; avodonosov: otherwise clause
    150     (otherwise x)))
     208  (otherwise x)))
    151209
    152210(defun is-same-object (obj1 obj2)
    … …  
    241299              (:double double.type)
    242300              (:byte byte.type)
    243         (:object object.type)
    244301        (:void void.type)
    245302              (otherwise (get-java-class-ref class-sym-or-string))))
    246303    (string (get-java-class-ref (canonic-class-symbol class-sym-or-string)))))
    247304
    248 ;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
     305;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;;
    249306#|
    250 In an effort to reduce the volume of stuff generated when wrapping entire libraries,
    251 the wrappers just generate minimal stubs, which, if and when invoked at runtime,
    252 complete the work of building thunking closures, so very little code is generated for
    253 things never called (Java libraries have huge numbers of symbols).
    254 Not sure if this approach matters, but that's how it works
     307The library maintains a hierarchy of typed reference classes that parallel the
     308class hierarchy on the Java side
     309new returns a typed reference, but other functions that return objects
     310return raw references (for efficiency)
     311make-typed-ref can create fully-typed wrappers when desired
    255312|#
    256313
    … …  
    276333                              (is-assignable-from x y)))))
    277334      (mapcar #'jclass-name result))))
     335#|
     336(defun get-superclass-names (full-class-name)
     337  (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name)))
     338         (super (class.getsuperclass class))
     339         (interfaces (class.getinterfaces class))
     340         (supers ()))
     341    (do-jarray (i interfaces)
     342      (push (class.getname i) supers))
     343    ;hmmm - where should the base class go in the precedence list?
     344    ;is it more important than the interfaces? this says no
     345    (if super
     346        (push (class.getname super) supers)
     347      (push "java.lang.Object" supers))
     348    (nreverse supers)))
     349|#
     350
     351(defun %ensure-java-class (full-class-name)
     352  "walks the superclass hierarchy and makes sure all the classes are fully defined
     353(they may be undefined or just forward-referenced-class)
     354caches this has been done on the class-symbol's plist"
     355  (let* ((class-sym (class-symbol full-class-name))
     356         (class (find-class class-sym nil)))
     357    (if (or (eql class-sym '|java.lang|::object.)
     358            (get class-sym :ensured))
     359        class
     360  (let ((supers (get-superclass-names full-class-name)))
     361    (dolist (super supers)
     362      (%ensure-java-class super))
     363    (unless (and class (subtypep class 'standard-object))
     364      (setf class
     365      #+abcl
     366      (sys::ensure-class  class-sym :direct-superclasses (mapcar #'(lambda (c) (find-class (class-symbol c))) supers))))
     367    (setf (get class-sym :ensured) t)
     368    class))))
     369
     370
     371(defun ensure-java-hierarchy (class-sym)
     372  "Works off class-sym for efficient use in new
     373This will only work on class-syms created by def-java-class,
     374as it depends upon symbol-value being the canonic class symbol"
     375  (unless (get class-sym :ensured)
     376    (%ensure-java-class (java-class-name class-sym))))
     377
     378(defun make-typed-ref (java-ref)
     379  "Given a raw java-ref, determines the full type of the object
     380and returns an instance of a typed reference wrapper"
     381  (when java-ref
     382    (let ((class (jobject-class java-ref)))
     383      (if (jclass-array-p class)
     384          (error "typed refs not supported for arrays (yet)")
     385        (make-instance (%ensure-java-class (jclass-name class)) :ref java-ref)))))
     386
     387
     388;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;
     389#|
     390In an effort to reduce the volume of stuff generated when wrapping entire libraries,
     391the wrappers just generate minimal stubs, which, if and when invoked at runtime,
     392complete the work of building thunking closures, so very little code is generated for
     393things never called (Java libraries have huge numbers of symbols).
     394Not sure if this approach matters, but that's how it works
     395|#
    278396
    279397(defmacro def-java-class (full-class-name)
    … …  
    285403           (defs
    286404       (list*
     405        #+nil `(format t "!!!!!!!!!!~a~%" ,full-class-name)
    287406        `(ensure-package ,pacakge)
    288         ;;build a path from the simple class symbol to the canonic
     407          ;build a path from the simple class symbol to the canonic
    289408        `(defconstant ,class-sym ',(canonic-class-symbol full-class-name))
    290409        `(export ',class-sym (symbol-package ',class-sym))
    … …  
    301420         (remove (symbol-package class-sym)
    302421           (remove-duplicates (mapcar #'symbol-package supers))))
    303         super-exports))))))
     422        super-exports
     423        (list
     424         `(defclass ,(class-symbol full-class-name)
     425            ,supers ()))))))))
    304426      `(locally ,@defs))))
    305427
    … …  
    404526    (when ctor-list
    405527      (setf (fdefinition (constructor-symbol full-class-name))
    406             (make-ctor-thunk ctor-list)))))
    407 
    408 (defun make-ctor-thunk (ctors)
     528            (make-ctor-thunk ctor-list (class-symbol full-class-name))))))
     529
     530(defun make-ctor-thunk (ctors class-sym)
    409531  (if (rest ctors) ;overloaded
    410       (make-overloaded-ctor-thunk ctors)
    411     (make-non-overloaded-ctor-thunk (first ctors))))
    412 
    413 (defun make-non-overloaded-ctor-thunk (ctor)
     532      (make-overloaded-ctor-thunk ctors class-sym)
     533    (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
     534
     535(defun make-non-overloaded-ctor-thunk (ctor class-sym)
    414536  (let ((arg-boxers (get-arg-boxers (jconstructor-params ctor))))
    415537    (lambda (&rest args)
    416       (let* ((arglist (build-arglist args arg-boxers))
    417        (object (apply #'jnew ctor arglist)))
    418   (unbox-object object)))))
    419 
    420 (defun make-overloaded-ctor-thunk (ctors)
    421   (let ((thunks (make-ctor-thunks-by-args-length ctors)))
     538      (let ((arglist (build-arglist args arg-boxers)))
     539  (ensure-java-hierarchy class-sym)
     540  (make-instance class-sym
     541           :ref (apply #'jnew ctor arglist)
     542           :lisp-allocated t)))))
     543
     544(defun make-overloaded-ctor-thunk (ctors class-sym)
     545  (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym)))
    422546    (lambda (&rest args)
    423547      (let ((fn (cdr (assoc (length args) thunks))))
    … …  
    427551          (error "invalid arity"))))))
    428552
    429 (defun make-ctor-thunks-by-args-length (ctors)
     553(defun make-ctor-thunks-by-args-length (ctors class-sym)
    430554  "returns an alist of thunks keyed by number of args"
    431555  (let ((ctors-by-args-length (make-hash-table))
    … …  
    437561                 (push (cons args-len
    438562                             (if (rest ctors);truly overloaded
    439                                  (make-type-overloaded-ctor-thunk ctors)
     563                                 (make-type-overloaded-ctor-thunk ctors class-sym)
    440564                               ;only one ctor with this number of args
    441                                (make-non-overloaded-ctor-thunk (first ctors))))
     565                               (make-non-overloaded-ctor-thunk (first ctors) class-sym)))
    442566                       thunks-by-args-length))
    443567             ctors-by-args-length)
    444568    thunks-by-args-length))
    445569
    446 (defun make-type-overloaded-ctor-thunk (ctors)
     570(defun make-type-overloaded-ctor-thunk (ctors class-sym)
    447571  "these methods have the same number of args and must be distinguished by type"
    448572  (let ((thunks (mapcar #'(lambda (ctor)
    449                             (list (make-non-overloaded-ctor-thunk ctor)
     573                            (list (make-non-overloaded-ctor-thunk ctor class-sym)
    450574                                  (jarray-to-list (jconstructor-params ctor))))
    451575                        ctors)))
    … …  
    585709          (setf (fdefinition field-sym)
    586710                (lambda ()
    587                   (funcall unboxer (jfield-raw class field-name))))
     711                  (funcall unboxer (jfield-raw class field-name) #+nil (field.get field nil))))
    588712          (setf (fdefinition `(setf ,field-sym))
    589713                (lambda (arg)
    590                   (jfield field-name nil (get-ref (funcall boxer arg)))
     714                  (jfield field-name nil
     715                             (get-ref (if (and boxer (not (boxed? arg)))
     716                                          (funcall boxer arg)
     717                                        arg)))
    591718                  arg)))
    592719      (progn
    593720        (setf (fdefinition field-sym)
    594721              (lambda (obj)
    595                 (funcall unboxer (jfield-raw class field-name (get-ref obj)))))
     722                (funcall unboxer (jfield-raw class field-name (get-ref obj)) #+nil(field.get field (get-ref obj)))))
    596723        (setf (fdefinition `(setf ,field-sym))
    597724              (lambda (arg obj)
    598                 (jfield field-name (get-ref obj) (get-ref (funcall boxer arg)))
     725                (jfield field-name (get-ref obj)
     726                           (get-ref (if (and boxer (not (boxed? arg)))
     727                                        (funcall boxer arg)
     728                                      arg)))
    599729                arg))))))
    600730
    … …  
    628758
    629759(defmacro def-java-methods (full-class-name)
    630   (let ((class-methods (get-class-methods full-class-name))
     760  (let ((methods-by-name (get-methods-by-name full-class-name))
    631761        (defs nil))
    632762    (maphash (lambda (name methods)
    … …  
    634764                 (push `(defun ,method-sym (&rest args)
    635765                          ,(build-method-doc-string name methods)
    636                           (apply #'install-method-and-call ,full-class-name ,name args))
     766                          (apply #'install-methods-and-call ,full-class-name ,name args))
    637767                       defs)
    638768                 (push `(export ',method-sym (symbol-package ',method-sym))
    … …  
    642772                          (when (eql 0 (search prefix name))
    643773                            (let ((setname (string-append "set" (subseq name (length prefix)))))
    644                               (when (gethash setname class-methods)
     774                              (when (gethash setname methods-by-name)
    645775                                (push `(defun (setf ,method-sym) (val &rest args)
    646776                                         (progn
    … …  
    651781                   (add-setter-if "get")
    652782                   (add-setter-if "is"))))
    653              class-methods)
     783             methods-by-name)
    654784    `(locally ,@(nreverse defs))))
    655785
    656 (defun install-method-and-call (full-class-name name &rest args)
     786(defun install-methods-and-call (full-class-name method &rest args)
    657787  "initially all the member function symbols for a class are bound to this function,
    658788when first called it will replace them with the appropriate direct thunks,
    659789then call the requested method - subsequent calls via those symbols will be direct"
    660   (install-method full-class-name name)
    661   (apply (member-symbol full-class-name name) args))
     790  (install-methods full-class-name)
     791  (apply (member-symbol full-class-name method) args))
    662792
    663793(defun decode-array-name (tn)
    … …  
    690820  "Return a method made accessible"
    691821    (jcall (jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean")
    692      method +true+)
     822     method
     823           java:+true+)
    693824    method)
    694825
    … …  
    699830        (remove-if-not #'jmember-protected-p (jclass-methods class :declared t)))))
    700831
    701 (defun get-class-methods (full-class-name)
     832(defun get-methods-by-name (full-class-name)
    702833  "returns an #'equal hashtable of lists of java.lang.Method refs keyed by name"
    703834  (let* ((class-sym (canonic-class-symbol full-class-name))
    704835         (class (get-java-class-ref class-sym))
    705836         (methods (jclass-relevant-methods class))
    706          (class-methods (make-hash-table :test #'equal)))
     837         (methods-by-name (make-hash-table :test #'equal)))
    707838    (loop for method in methods
    708839    do
    709     (push method (gethash (jmethod-name method) class-methods)))
    710     class-methods))
    711 
    712 (defun install-method (full-class-name name)
    713   (let* ((class-methods (get-class-methods full-class-name))
    714    (methods (gethash name class-methods)))
    715     (setf (fdefinition (member-symbol full-class-name name))
    716     (make-method-thunk methods))))
     840    (push method (gethash (jmethod-name method) methods-by-name)))
     841    methods-by-name))
     842
     843(defun install-methods (full-class-name)
     844  (let ((methods-by-name (get-methods-by-name full-class-name)))
     845    (maphash
     846     (lambda (name methods)
     847       (setf (fdefinition (member-symbol full-class-name name))
     848             (make-method-thunk methods)))
     849     methods-by-name)))
    717850
    718851(defun make-method-thunk (methods)
    … …  
    727860  (caller (if is-static #'jstatic-raw #'jcall-raw)))
    728861    (lambda (&rest args)
    729       (let ((object (if is-static nil (get-ref (first args))))
    730       (arglist (build-arglist (if is-static args (rest args)) arg-boxers)))
    731   (funcall unboxer-fn (apply caller method object arglist))))))
     862      (let ((arglist (build-arglist (if is-static args (rest args)) arg-boxers)))
     863  (funcall unboxer-fn
     864     (apply caller  method
     865      (if is-static nil (get-ref (first args)))
     866      arglist))))))
    732867
    733868(defun make-overloaded-thunk (methods)
    … …  
    782917  (apply #'jarray-ref-raw array subscripts))
    783918
     919
    784920(defun (setf jref) (val array &rest subscripts)
    785   (apply #'jarray-set array (get-ref val) subscripts))
     921  (apply #'jarray-set array val subscripts))
     922
     923
    786924
    787925(eval-when (:compile-toplevel :load-toplevel :execute)
    … …  
    795933                  ,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type))
    796934     (assert (every #'integerp subscripts))
    797      (unbox-object (apply #'jarray-ref array subscripts)))
     935     (apply #'jarray-ref array subscripts))
     936
    798937               `(defun (setf ,ref-sym) (val array &rest subscripts)
    799938     (assert (every #'integerp subscripts))
    800      (apply #'jarray-set array val subscripts)
     939     (apply #'jarray-set array ,(if (eql type 'boolean) '(box-boolean val) 'val) subscripts)
    801940                  ))))
    802941          types))))
    … …  
    845984  (apply #'make-new-array long.type dimensions))
    846985
    847 (defmethod make-new-array ((type (eql :object)) &rest dimensions)
    848   (apply #'make-new-array object.type dimensions))
    849 
    850986;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;;
    851987
    … …  
    853989(defun get-arg-boxers (param-types)
    854990  "returns a list with one entry per param, either nil or a function that boxes the arg"
    855   (loop for param-type across param-types collect
    856        (get-boxer-fn (jclass-name param-type))))
     991  (loop for param-type across param-types
     992  collecting (get-boxer-fn (jclass-name param-type))))
     993
     994
    857995
    858996(defun build-arglist (args arg-boxers)
    … …  
    8841022
    8851023;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;;
     1024(defun box-string (s)
     1025  "Given a string or symbol, returns reference to a Java string"
     1026  (convert-to-java-string s))
     1027
     1028(defun unbox-string (ref &optional delete-local)
     1029  "Given a reference to a Java string, returns a Lisp string"
     1030  (declare (ignore delete-local))
     1031  (convert-from-java-string (get-ref ref)))
     1032
     1033
     1034
    8861035(defun get-boxer-fn (class-name)
    8871036  (if (string= class-name "boolean")
    8881037      #'box-boolean
    889       #'identity))
     1038      nil))
    8901039
    8911040(defun get-boxer-fn-sym (class-name)
    … …  
    9021051   ((null x) nil)
    9031052   ((boxed? x) (jobject-class (get-ref x)))
    904    ((integerp x) integer.type)
     1053   ((typep x '(integer -2147483648 +2147483647)) integer.type)
     1054   ((typep x '(integer -9223372036854775808 +9223372036854775807)) long.type)
    9051055   ((numberp x) double.type)
     1056   ; ((characterp x) character.type) ;;;FIXME!!
    9061057   ((eq x t) boolean.type)
    907    ((stringp x) string.type)
    908    ((symbolp x) string.type)
    909    (t object.type)
     1058   ((or (stringp x) (symbolp x))
     1059    (get-java-class-ref '|java.lang|::|String|))
    9101060   (t (error "can't infer box type"))))
    9111061
     1062
    9121063(defun get-unboxer-fn (class-name)
    913   (cond ((string= class-name "void") #'unbox-void)
    914   ((is-name-of-primitive class-name) #'unbox-primitive)
    915   ((string= class-name "java.lang.String") #'unbox-string)
    916   ((string= class-name "java.lang.Boolean") #'unbox-boolean)
    917   (t #'unbox-object)))
     1064  (if (string= class-name "void")
     1065      #'unbox-void
     1066      (if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String"))
     1067    #'jobject-lisp-value
     1068    #'identity-or-nil)))
    9181069
    9191070(defun get-unboxer-fn-sym (class-name)
    920   (cond ((string= class-name "void") 'unbox-void)
    921   ((is-name-of-primitive class-name) 'unbox-primitive)
    922   ((string= class-name "java.lang.String") 'unbox-string)
    923   ((string= class-name "java.lang.Boolean") 'unbox-boolean)
    924   (t 'unbox-object)))
     1071  (if (string= class-name "void")
     1072      'unbox-void
     1073      (if (or (is-name-of-primitive class-name) (string= class-name "java.lang.String"))
     1074    'jobject-lisp-value
     1075    'identity-or-nil)))
     1076
    9251077
    9261078(defun unbox-void (x &optional delete-local)
    … …  
    9281080  nil)
    9291081
    930 (defun unbox-primitive (x)
    931   (unless (equal x +null+)
    932     (jobject-lisp-value x)))
    933 
    934 (defun unbox-string (x)
    935   (unless (equal x +null+)
    936     (jobject-lisp-value x)))
    937 
    938 (defun unbox-boolean (x)
    939   (unless (equal x +null+)
    940     (jobject-lisp-value x)))
    941 
    942 (defun unbox-object (x)
    943   (unless (equal x +null+)
    944     (jcoerce x (jclass-of x))))
     1082(defun box-void (x)
     1083  (declare (ignore x))
     1084  nil)
    9451085
    9461086(defun box-boolean (x)
    947   (if x +true+ +false+))
     1087  (if x java:+true+ java:+false+))
    9481088
    9491089;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;;
    … …  
    10261166      `(java::%jnew-proxy ,@(process-idefs interface-defs)))))
    10271167
     1168
     1169#+nil
     1170(defun jrc (class-name super-name interfaces constructors methods fields &optional filename)
     1171  "A friendlier version of jnew-runtime-class."
     1172  #+nil (format t "~s~%~s~%~s~%~s~%~s~%~s~%" class-name super-name interfaces constructors methods fields filename)
     1173  (if (java:jruntime-class-exists-p class-name)
     1174      (progn
     1175  (warn "Java class ~a already exists. Redefining methods." class-name)
     1176  (loop for
     1177        (argument-types function super-invocation-args) in constructors
     1178        do
     1179        (java:jredefine-method class-name nil argument-types function))
     1180  (loop for
     1181        (method-name return-type argument-types function &rest modifiers)
     1182        in methods
     1183        do
     1184        (java:jredefine-method class-name method-name argument-types function)))
     1185      (java:jnew-runtime-class class-name super-name interfaces constructors methods fields filename)))
     1186
     1187
    10281188(defun get-modifiers (member)
    10291189  (jcall (jmethod "java.lang.reflect.Member" "getModifiers") member))
    … …  
    10471207    collect mod)))
    10481208
     1209
     1210(defun get-java-object (x)
     1211  (typecase x
     1212    (|java.lang|::object. (ref x))
     1213    (t x)))
     1214
    10491215(defun find-java-class-name-in-macro (c)
    10501216  (etypecase c
    … …  
    10521218    (string c)))
    10531219
    1054 
    1055 
     1220#+nil
     1221(defmacro new-class (class-name super-and-interface-names constructor-defs method-defs field-defs)
     1222  "class-name -> string
     1223   super-and-interface-names -> class-name | (class-name interface-name*)
     1224   constructor-defs -> (constructor-def*)
     1225   constructor-def -> (ctr-arg-defs body)
     1226   /the first form in body may be (super arg-name+); this will call the constructor of the superclass
     1227    with the listed arguments/
     1228   ctr-arg-def -> (arg-name arg-type)
     1229   method-def -> (method-name return-type access-modifiers arg-defs* body)
     1230   /access-modifiers may be nil (to get the modifiers from the superclass), a keyword, or
     1231   a list of keywords/
     1232   method-name -> string
     1233arg-def -> arg-name | (arg-name arg-type)
     1234arg-type -> \"package.qualified.ClassName\" | classname. | :primitive
     1235class-name -> \"package.qualified.ClassName\" | classname.
     1236interface-name -> \"package.qualified.InterfaceName\" | interfacename.
     1237
     1238Creates, registers and returns a Java object that implements the supplied interfaces"
     1239  (let ((this (intern "THIS" *package*))
     1240        (defined-method-names))
     1241    (labels ((process-ctr-def (ctr-def ctrs)
     1242         (destructuring-bind ((&rest arg-defs) &body body)
     1243                   ctr-def
     1244                 (let ((ctr-param-names
     1245      (mapcar
     1246       #'(lambda (arg-def) (find-java-class-name-in-macro (cadr arg-def)))
     1247       arg-defs))
     1248           ;(ctr-param-names (mapcar #'cadr arg-defs))
     1249           (gargs (gensym))
     1250           (head (car body))
     1251           (sia))
     1252       (when (and (consp head) (eq (car head) 'super))
     1253         (setq sia (mapcar
     1254        #'(lambda (arg-name)
     1255           (1+ (position arg-name arg-defs :key #'car)))
     1256        (cdr head))
     1257         body (cdr body)))
     1258                   `(,ctr-param-names
     1259                     (lambda (&rest ,gargs)
     1260       (let ,(arg-lets (append arg-defs (list this))
     1261           (append
     1262            ctr-param-names
     1263            (list class-name))
     1264           gargs
     1265           0)
     1266         ,@body))
     1267                     ,sia))))
     1268       (process-method-def (method-def methods)
     1269               (destructuring-bind (method-name return-type modifiers (&rest arg-defs) &body body)
     1270                   method-def
     1271                 (push method-name defined-method-names)
     1272                 (let* ((method (matching-method method-name arg-defs methods))
     1273                        (method-params
     1274                         (if method
     1275                             (jarray-to-list (jmethod-params method))
     1276                             (mapcar #'(lambda (arg-def) (find-java-class-in-macro (cadr arg-def))) arg-defs)))
     1277                        (method-param-names
     1278                         #+nil
     1279        (if method
     1280                             (mapcar #'jclass-name (jarray-to-list method-params))
     1281                             (mapcar #'cadr arg-defs))
     1282        (mapcar #'jclass-name method-params))
     1283                        (return-type-name
     1284                         (jclass-name
     1285                          (if method (jmethod-return-type method) (find-java-class-in-macro return-type))))
     1286                        (modifiers
     1287       #+nil
     1288        (if method (get-modifier-list method) '("public"))
     1289        (cond ((and (null modifiers) method) (get-modifier-list method))
     1290        ((symbolp modifiers) (list (string-downcase (symbol-name modifiers))))
     1291        ((consp modifiers) (mapcar #'(lambda (m) (string-downcase (symbol-name m))) modifiers))
     1292        (t (error (format t "Need to provide modifiers for method ~A" method-name)))))
     1293                        (gargs (gensym)))
     1294                   `(,method-name ,return-type-name ,method-param-names
     1295                     (lambda (&rest ,gargs)
     1296           ;;(,(get-boxer-fn-sym return-type-name)
     1297           (get-java-object  ;;check!
     1298       (let ,(arg-lets (append arg-defs (list this))
     1299           (append
     1300            method-param-names
     1301            #+nil (map 'list #'(lambda (p) (jclass-name p)) method-params)
     1302            (list class-name))
     1303           gargs
     1304           0)
     1305         ,@body))
     1306           )
     1307                     ,@modifiers))))
     1308             (arg-lets (arg-defs params gargs idx)
     1309               (when arg-defs
     1310                 (let ((arg (first arg-defs))
     1311                       (param (first params)))
     1312                   (cons `(,(if (atom arg) arg (first arg))
     1313                           (,(get-unboxer-fn-sym param)
     1314                            (nth ,idx ,gargs)))
     1315                         (arg-lets (rest arg-defs) (rest params) gargs (1+ idx))))))
     1316             (matching-method (method-name arg-defs methods)
     1317               (let (match)
     1318                 (loop for method across methods
     1319                       when (method-matches method-name arg-defs method)
     1320                       do
     1321                       (if match
     1322                           (error (format nil "more than one method matches ~A" method-name))
     1323                           (setf match method)))
     1324                 match))
     1325             (method-matches (method-name arg-defs method)
     1326               (when (string-equal method-name (jmethod-name method))
     1327                 (let ((params (jmethod-params method)))
     1328                   (when (= (length arg-defs) (length params))
     1329                     (is-congruent arg-defs params)))))
     1330             (is-congruent (arg-defs params)
     1331               (every (lambda (arg param)
     1332                        (or (atom arg)  ;no type spec matches anything
     1333                            (jeq (find-java-class-in-macro (second arg)) param)))
     1334                      arg-defs (jarray-to-list params))))
     1335      (unless (consp super-and-interface-names)
     1336  (setq super-and-interface-names (list super-and-interface-names)))
     1337      (let* ((super-name (find-java-class-name-in-macro (car super-and-interface-names)))
     1338       (interfaces (mapcar #'find-java-class-name-in-macro (cdr super-and-interface-names)))
     1339       (super (jclass super-name))
     1340             (super-ctrs (jclass-constructors super))
     1341             (ctrs-ret (loop for ctr-def in constructor-defs collecting
     1342                        (process-ctr-def ctr-def super-ctrs)))
     1343       (super-methods (jclass-methods super))
     1344             (iface-methods
     1345              (apply #'concatenate 'vector
     1346                     (mapcar #'(lambda (ifn)
     1347                                 (jclass-methods (jclass ifn)))
     1348                             interfaces)))
     1349             (methods-ret (loop for method-def in method-defs collecting
     1350                        (process-method-def
     1351                         method-def
     1352                         (concatenate 'vector super-methods iface-methods)))))
     1353        ;;check to make sure every function is defined
     1354        (loop for method across iface-methods
     1355              for mname = (jmethod-name method)
     1356              unless (member mname defined-method-names :test #'string-equal)
     1357              do
     1358              (warn (format nil "class doesn't define:~%~A" mname)))
     1359  `(progn
     1360    (jrc ,class-name ,super-name ,interfaces
     1361     ',ctrs-ret
     1362     ',methods-ret
     1363     (loop for (fn type . mods) in ',field-defs
     1364      collecting `(,fn ,(find-java-class-name-in-macro type)
     1365       ,@(mapcar #'(lambda (mod) (string-downcase (symbol-name mod))) mods)))
     1366    #+nil ,(namestring (merge-pathnames class-name "/tmp/")))
     1367    (eval '(def-java-class ,class-name)))))))
     1368
     1369
Note: See TracChangeset for help on using the changeset viewer.