Changeset 13283


Ignore:
Timestamp:
05/21/11 12:41:09 (10 years ago)
Author:
Mark Evenson
Message:

Removed dependency on jscheme.jar. Now standalone!

Needs substantial testing, vigorous pruning of orphaned code, and
optimization of "new" calling procedures (especially the memoization
facility of INVOKE-FIND-METHOD.

Location:
trunk/abcl/contrib/jss
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/contrib/jss/compat.lisp

    r13281 r13283  
    66(defun ensure-compatiblity ()
    77  (setf *cl-user-compatibility* t)
    8   (dolist (symbol '(get-java-field))
     8  (dolist (symbol '(get-java-field new))
    99    (unintern symbol :cl-user)
    1010    (import symbol :cl-user)))
  • trunk/abcl/contrib/jss/invoke.lisp

    r13281 r13283  
    121121;; Tested on windows, linux.
    122122
     123;; 2011-05-21 Mark Evenson
     124;;   "ported" to native ABCL without needing the jscheme.jar or bsh-2.0b4.jar
     125
    123126(in-package :jss)
    124127
     
    193196
    194197(defun invoke-restargs (method object args &optional (raw? nil))
    195   (symbol-macrolet
    196       ((no-argss (load-time-value (jnew-array "java.lang.Object" 0)))
    197        (invoke-class (load-time-value (jclass "jsint.Invoke")))
    198        (ic (load-time-value (find "invokeConstructor" *invoke-methods* :key  'jmethod-name :test 'equal)))
    199        (is (load-time-value (find "invokeStatic"  *invoke-methods* :key  'jmethod-name :test 'equal)))
    200        (ii (load-time-value (find "invokeInstance"  *invoke-methods* :key  'jmethod-name :test 'equal)))
    201        (true (load-time-value (make-immediate-object t :boolean)))
    202        (false (load-time-value (make-immediate-object nil :boolean))))
    203     (let* (
    204     ;; these two lookups happen before argv is filled, because they themselves call invoke.)
    205    (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object)))
    206    (object-as-class (if object-as-class-name (find-java-class object-as-class-name)))
    207    )
    208 ;    (declare (optimize (speed 3) (safety 0)))
    209     (let ((argv (if (null (the list args))
    210         no-argss
    211         (let ((argv (jarray-ref-raw (argvs) (length (the list args))))
    212         (i -1))
    213           (dolist (arg args)
    214       (setf (jarray-ref argv (incf (the fixnum i)))
    215             (if (eq arg t) true (if (eq arg nil) false arg))))
    216           argv))))
    217       (if (eq method 'new)
    218           (apply #'jnew (or object-as-class-name object) args)
    219     (if raw?
    220         (if (symbolp object)
    221       (apply #'jstatic-raw method object-as-class  args)
    222       (apply #'jcall-raw method object  args))
    223         (if (symbolp object)
    224       (apply #'jstatic method object-as-class args)
    225       (apply #'jcall method object args))))))))
    226 
    227 ;; (defconstant no-args (load-time-value (jnew-array "java.lang.Object" 0)))
    228 ;; (defconstant invoke-class (load-time-value (jclass "jsint.Invoke")))
    229 ;; (defconstant ic (load-time-value (find "invokeConstructor" *invoke-methods* :key  'jmethod-name :test 'equal)))
    230 ;; (defconstant is (load-time-value (find "invokeStatic"  *invoke-methods* :key  'jmethod-name :test 'equal)))
    231 ;; (defconstant ii (load-time-value (find "invokeInstance"  *invoke-methods* :key  'jmethod-name :test 'equal)))
    232 ;; (defconstant true (load-time-value (make-immediate-object t :boolean)))
    233 ;; (defconstant false (load-time-value (make-immediate-object nil :boolean)))
    234 
    235 ;; (defun invoke-restargs (method object args &optional (raw? nil))
    236 ;;   (let* (;; these two lookups happen before argv is filled, because they themselves call invoke.
    237 ;;   (object-as-class-name (if (symbolp object) (maybe-resolve-class-against-imports object)))
    238 ;;   (object-as-class (if object-as-class-name (find-java-class object-as-class-name)))
    239 ;;   )
    240 ;;     (declare (optimize (speed 3) (safety 0)))
    241 ;;     (let ((argv (if (null args)
    242 ;;        no-args
    243 ;;        (let ((argv (jarray-ref-raw (argvs) (length args)))
    244 ;;        (i -1))
    245 ;;          (dolist (arg args)
    246 ;;      (setf (jarray-ref argv (incf (the fixnum i)))
    247 ;;            (if (eq arg t) true (if (eq arg nil) false arg))))
    248 ;;          argv))))
    249 ;;       (if (eq method 'new)
    250 ;;    (progn
    251 ;;      (jstatic-raw ic invoke-class object-as-class-name argv))
    252 ;;    (if raw?
    253 ;;        (if (symbolp object)
    254 ;;      (jstatic-raw is invoke-class object-as-class method argv)
    255 ;;      (jstatic-raw ii invoke-class object method argv true))
    256 ;;        (if (symbolp object)
    257 ;;      (jstatic is invoke-class object-as-class method argv)
    258 ;;      (jstatic ii invoke-class object method argv true)
    259 ;;      ))))))
    260 
     198  (let* ((object-as-class-name
     199          (if (symbolp object) (maybe-resolve-class-against-imports object)))
     200         (object-as-class
     201          (if object-as-class-name (find-java-class object-as-class-name))))
     202    (if (eq method 'new)
     203        (apply #'jnew (or object-as-class-name object) args)
     204        (if raw?
     205            (if (symbolp object)
     206                (apply #'jstatic-raw method object-as-class  args)
     207                (apply #'jcall-raw method object  args))
     208            (if (symbolp object)
     209                (apply #'jstatic method object-as-class args)
     210                (apply #'jcall method object args))))))
     211
     212;;; Method name --> Object --> jmethod
     213;;;
     214(defvar *methods-cache* (make-hash-table :test #'equal))
     215
     216(defun get-jmethod (method object)
     217  (when (gethash method *methods-cache*)
     218    (gethash
     219     (if (symbolp object) (lookup-class-name object) (jobject-class object))
     220     (gethash method *methods-cache*))))
     221
     222(defun set-jmethod (method object jmethod)
     223  (unless (gethash method *methods-cache*)
     224    (setf (gethash method *methods-cache*) (make-hash-table :test #'equal)))
     225  (setf
     226   (gethash
     227    (if (symbolp object) (lookup-class-name object) (jobject-class object))
     228    (gethash method *methods-cache*))
     229   jmethod))
     230
     231(defparameter *last-invoke-find-method-args* nil)
     232;;; TODO optimize me!
    261233(defun invoke-find-method (method object args)
    262   (let* ((no-args (load-time-value (jnew-array "java.lang.Object" 0)))
    263    (invoke-class (load-time-value (jclass "jsint.Invoke")))
    264    (ifm (load-time-value (jmethod (jclass "jsint.Invoke") "findMethod" (jclass "[Ljava.lang.Object;") (jclass "[Ljava.lang.Object;"))))
    265    (imt (load-time-value (find "methodTable"  *invoke-methods* :key  'jmethod-name :test 'equal)))
    266    (true (load-time-value (make-immediate-object t :boolean)))
    267    (false (load-time-value (make-immediate-object nil :boolean))))
    268     (let ((args (if (null args)
    269         no-args
    270         (let ((argv (jarray-ref-raw (argvs) (length args)))
    271         (i -1))
    272           (dolist (arg args)
    273       (setf (jarray-ref argv (incf i))
    274             (if (eq arg t) true (if (eq arg nil) false arg))))
    275           argv))))
    276       (if (symbolp object)
    277     (jstatic ifm invoke-class (jstatic-raw imt invoke-class (lookup-class-name object) method true true) args)
    278     (jstatic ifm invoke-class (jstatic-raw imt invoke-class (jobject-class object) method false true) args)))))
    279 
     234  (setf *last-invoke-find-method-args* (list method object args))
     235  (let ((jmethod (get-jmethod method object)))
     236    (unless jmethod
     237      (setf jmethod
     238            (if (symbolp object)
     239                ;;; static method
     240                (apply #'jmethod (lookup-class-name object)
     241                       method (mapcar #'jobject-class args))
     242                  ;;; instance method
     243                (apply #'jresolve-method
     244                       method object args)))
     245      (jcall "setAccessible" jmethod +true+)
     246      (set-jmethod method object jmethod))
     247    jmethod))
    280248
    281249;; This is the reader macro for java methods. it translates the method
     
    296264    (unread-char char stream)
    297265    (let ((name (read stream)))
    298       (if (and arg (eql (abs arg) 1))
    299     (let ((cell (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ; work around bug that gensym here errors when compiling
    300     (object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet
    301     (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)))
    302       (proclaim `(special ,cell))
    303           ;     (set cell nil)
    304       `(lambda (,object-var &rest ,args-var)
    305          (declare (optimize (speed 3) (safety 0)))
    306          (if (boundp ',cell) ;costing me 10% here because I can't force cell to be bound and hence do null test.
    307        (if (null ,args-var)
    308            (jcall ,cell ,object-var)
    309            (if (null (cdr (the cons ,args-var)))
    310          ,(if (minusp arg)
    311         `(jcall-static ,cell ,object-var (car (the cons ,args-var)))
    312         `(jcall ,cell ,object-var (car (the cons ,args-var))))
    313          ,(if (minusp arg)
    314         `(apply 'jcall-static ,cell ,object-var (the list ,args-var))
    315         `(apply 'jcall ,cell ,object-var (the list ,args-var)))))
    316        (progn
    317          (setq ,cell (invoke-find-method ,name ,object-var ,args-var))
    318          ,(if (minusp arg)
    319         `(apply 'jcall-static ,cell ,object-var ,args-var)
    320         `(apply 'jcall ,cell ,object-var ,args-var))))))
    321     (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet
    322     (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)))
    323       `(lambda (,object-var &rest ,args-var)
    324          (invoke-restargs ,name  ,object-var ,args-var ,(eql arg 0)))))))
     266      (let ((object-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)) ;; work around bug in 0.18 symbol-macrolet
     267            (args-var (intern (format nil "G~a" (incf *lcount*)) 'lambdas)))
     268        `(lambda (,object-var &rest ,args-var)
     269           (invoke-restargs ,name  ,object-var ,args-var ,(eql arg 0))))))
    325270  (set-dispatch-macro-character #\# #\" 'read-invoke))
    326271
     
    453398
    454399(defconstant +true+
    455   (jstatic-raw "parseBoolean" "java.lang.Boolean" "true"))
     400  (make-immediate-object t :boolean))
    456401
    457402(defun find-java-class (name)
  • trunk/abcl/contrib/jss/jss.asd

    r13281 r13283  
    11;;;; -*- Mode: LISP -*-
    2 
    3 ;;; XXX
    4 ;;(java:add-to-classpath "~/work/lsw2/lib/jscheme.jar")
    5 
    62(in-package :asdf)
    73
    84(defsystem :jss
    9   :author "Alan Ruttenberg"
    10   :version "2.0"
     5  :author "Alan Ruttenberg, Mark Evenson"
     6  :version "2.0.0"
    117  :components
    128  ((:module base :pathname "" :serial t
  • trunk/abcl/contrib/jss/packages.lisp

    r13281 r13283  
    1515   (:shadow #:add-to-classpath))
    1616
    17 (eval-when (:compile-toplevel :load-toplevel)
    18   (java:add-to-classpath
    19    (merge-pathnames "../../../lsw2/lib/jscheme.jar" (asdf:component-pathname (asdf:find-system :jss)))))
    20 
    21 
Note: See TracChangeset for help on using the changeset viewer.