charlock_holmes-jruby 0.1.0-java

data/spec/fixtures/TwigExtensionsDate.es.yml

@@ -0,0 +1,8 @@
+date.year: '%year% año|%year% años'
+date.month: '%month% mes|%month% meses'
+date.day: '%day% día|%day% días'
+date.hour: '%hour% hora|%hour% horas'
+date.minute: '%minute% minuto|%minute% minutos'
+date.second: '%second% segundo|%second% segundos'
+date.new: 'menos de un minuto'
+date.and: ' y '

data/spec/fixtures/cl-messagepack.lisp

@@ -0,0 +1,264 @@
+;;;; cl-messagepack.lisp
+
+(in-package #:messagepack)
+
+(declaim (optimize (debug 3)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun mkstr (&rest args)
+    (format nil "~{~a~}" args))
+  (defun mksymb (&rest args)
+    (intern (apply #'mkstr args))))
+
+(defmacro signed-unsigned-convertors (size)
+  (let ((speed (if (< size 32) 3 0)))
+    `(progn
+       (defun ,(mksymb 'sb size '-> 'ub size) (sb)
+         (declare (optimize (debug 0) (safety 0) (speed ,speed))
+                  (type (integer ,(- (expt 2 (1- size))) ,(1- (expt 2 (1- size)))) sb))
+         (if (< sb 0)
+             (ldb (byte ,size 0) sb)
+             sb))
+       (defun ,(mksymb 'ub size '-> 'sb size) (sb)
+         (declare (optimize (debug 0) (safety 0) (speed ,speed))
+                  (type (mod ,(expt 2 size)) sb))
+         (if (logbitp (1- ,size) sb)
+             (- (1+ (logxor (1- (expt 2 ,size)) sb)))
+             sb)))))
+
+(signed-unsigned-convertors 8)
+(signed-unsigned-convertors 16)
+(signed-unsigned-convertors 32)
+(signed-unsigned-convertors 64)
+
+(defun write-hex (data)
+  (let (line)
+    (loop
+       for i from 0 to (1- (length data))
+       do (push (elt data i) line)
+       when (= (length line) 16)
+       do
+         (format t "~{~2,'0x ~}~%" (nreverse line))
+         (setf line nil))
+    (when line
+      (format t "~{~2,'0x ~}~%" (nreverse line)))))
+
+(defun encode (data)
+  (flexi-streams:with-output-to-sequence (stream)
+    (encode-stream data stream)))
+
+(defun make-hash (data)
+  (let ((result (make-hash-table)))
+    (dolist (kv data)
+      (cond ((consp (cdr kv))
+             (setf (gethash (first kv) result) (second kv)))
+            (t
+             (setf (gethash (car kv) result) (cdr kv)))))
+    result))
+
+(defun is-byte-array (data-type)
+  (and (vectorp data-type)
+       (equal '(unsigned-byte 8) (array-element-type data-type))))
+
+(defun encode-stream (data stream)
+  (cond ((floatp data) (encode-float data stream))
+        ((numberp data) (encode-integer data stream))
+        ((null data) (write-byte #xc0 stream))
+        ((eq data t) (write-byte #xc3 stream))
+        ((stringp data)
+         (encode-string data stream))
+        ((is-byte-array data)
+         (encode-raw-bytes data stream))
+        ((or (consp data) (vectorp data))
+         (encode-array data stream))
+        ((hash-table-p data)
+         (encode-hash data stream))
+        ((symbolp data)
+         (encode-string (symbol-name data) stream))
+        (t (error "Cannot encode data."))))
+
+(defun encode-string (data stream)
+  (encode-raw-bytes (babel:string-to-octets data) stream))
+
+#+sbcl (defun sbcl-encode-float (data stream)
+         (cond ((equal (type-of data) 'single-float)
+                (write-byte #xca stream)
+                (store-big-endian (sb-kernel:single-float-bits data) stream 4))
+               ((equal (type-of data) 'double-float)
+                (write-byte #xcb stream)
+                (store-big-endian (sb-kernel:double-float-high-bits data) stream 4)
+                (store-big-endian (sb-kernel:double-float-low-bits data) stream 4)))
+         t)
+
+(defun encode-float (data stream)
+  (or #+sbcl (sbcl-encode-float data stream)
+      #-(or sbcl) (error "No floating point support yet.")))
+
+(defun encode-each (data stream &optional (encoder #'encode-stream))
+  (cond ((hash-table-p data)
+         (maphash (lambda (key value)
+                    (funcall encoder key stream)
+                    (funcall encoder value stream))
+                  data))
+        ((or (vectorp data) (consp data))
+         (mapc (lambda (subdata)
+                 (funcall encoder subdata stream))
+               (coerce data 'list)))
+        (t (error "Not sequence or hash table."))))
+
+(defun encode-sequence (data stream
+                        short-prefix short-length
+                        typecode-16 typecode-32
+                        &optional (encoder #'encode-stream))
+  (let ((len (if (hash-table-p data)
+                 (hash-table-count data)
+                 (length data))))
+    (cond ((<= 0 len short-length)
+           (write-byte (+ short-prefix len) stream)
+           (encode-each data stream encoder))
+          ((<= 0 len 65535)
+           (write-byte typecode-16 stream)
+           (store-big-endian len stream 2)
+           (encode-each data stream encoder))
+          ((<= 0 len (1- (expt 2 32)))
+           (write-byte typecode-32 stream)
+           (store-big-endian len stream 4)
+           (encode-each data stream encoder)))))
+
+(defun encode-hash (data stream)
+  (encode-sequence data stream #x80 15 #xdc #xdd))
+
+(defun encode-array (data stream)
+  (encode-sequence data stream #x90 15 #xdc #xdd))
+
+(defun encode-raw-bytes (data stream)
+  (encode-sequence data stream #xa0 31 #xda #xdb #'write-byte))
+
+(defun encode-integer (data stream)
+  (cond ((<= 0 data 127) (write-byte data stream))
+        ((<= -32 data -1) (write-byte (sb8->ub8 data) stream))
+        ((<= 0 data 255)
+         (write-byte #xcc stream)
+         (write-byte data stream))
+        ((<= 0 data 65535)
+         (write-byte #xcd stream)
+         (store-big-endian data stream 2))
+        ((<= 0 data (1- (expt 2 32)))
+         (write-byte #xce stream)
+         (store-big-endian data stream 4))
+        ((<= 0 data (1- (expt 2 64)))
+         (write-byte #xcf stream)
+         (store-big-endian data stream 8))
+        ((<= -128 data 127)
+         (write-byte #xd0 stream)
+         (write-byte (sb8->ub8 data) stream))
+        ((<= -32768 data 32767)
+         (write-byte #xd1 stream)
+         (write-byte (sb16->ub16 data) stream))
+        ((<= (- (expt 2 31)) data (1- (expt 2 31)))
+         (write-byte #xd2 stream)
+         (write-byte (sb32->ub32 data) stream))
+        ((<= (- (expt 2 63)) data (1- (expt 2 63)))
+         (write-byte #xd3 stream)
+         (write-byte (sb64->ub64 data) stream))
+        (t (error "Integer too large or too small."))))
+
+(defun store-big-endian (number stream byte-count)
+  (let (byte-list)
+    (loop
+       while (> number 0)
+       do
+         (push (rem number 256)
+               byte-list)
+         (setf number (ash number -8)))
+    (loop
+       while (< (length byte-list) byte-count)
+       do (push 0 byte-list))
+    (when (> (length byte-list) byte-count)
+      (error "Number too large."))
+    (write-sequence byte-list stream)))
+
+(defun decode (byte-array)
+  (flexi-streams:with-input-from-sequence (stream byte-array)
+    (decode-stream stream)))
+
+(defun decode-stream (stream)
+  (let ((byte (read-byte stream)))
+    (cond ((= 0 (ldb (byte 1 7) byte))
+           byte)
+          ((= 7 (ldb (byte 3 5) byte))
+           (ub8->sb8 byte))
+          ((= #xcc byte)
+           (read-byte stream))
+          ((= #xcd byte)
+           (load-big-endian stream 2))
+          ((= #xce byte)
+           (load-big-endian stream 4))
+          ((= #xcf byte)
+           (load-big-endian stream 8))
+          ((= #xd0 byte)
+           (ub8->sb8 (read-byte stream)))
+          ((= #xd1 byte)
+           (ub16->sb16 (load-big-endian stream 2)))
+          ((= #xd2 byte)
+           (ub32->sb32 (load-big-endian stream 4)))
+          ((= #xd3 byte)
+           (ub64->sb64 (load-big-endian stream 8)))
+          ((= #xc0 byte)
+           nil)
+          ((= #xc3 byte)
+           t)
+          ((= #xc2 byte)
+           nil)
+          ((= #xca byte)
+           (or #+sbcl (sb-kernel:make-single-float (load-big-endian stream 4))
+               #-(or sbcl) (error "No floating point support yet.")))
+          ((= #xcb byte)
+           (or #+sbcl (sb-kernel:make-double-float (load-big-endian stream 4)
+                                                   (load-big-endian stream 4))
+               #-(or sbcl) (error "No floating point support yet.")))
+          ((= 5 (ldb (byte 3 5) byte))
+           (decode-raw-sequence (ldb (byte 5 0) byte) stream))
+          ((= #xda byte)
+           (decode-raw-sequence (load-big-endian stream 2) stream))
+          ((= #xdb byte)
+           (decode-raw-sequence (load-big-endian stream 4) stream))
+          ((= 9 (ldb (byte 4 4) byte))
+           (decode-array (- byte #x90) stream))
+          ((= #xdc byte)
+           (decode-array (load-big-endian stream 2) stream))
+          ((= #xdd byte)
+           (decode-array (load-big-endian stream 4) stream))
+          ((= 8 (ldb (byte 4 4) byte))
+           (decode-map (- byte #x80) stream))
+          ((= #xde byte)
+           (decode-map (load-big-endian stream 2) stream))
+          ((= #xdf byte)
+           (decode-map (load-big-endian stream 4) stream)))))
+
+(defun decode-map (length stream)
+  (let ((hash-table (make-hash-table :test #'equal)))
+    (loop repeat length
+       do (let ((key (decode-stream stream))
+                (value (decode-stream stream)))
+            (setf (gethash key hash-table) value)))
+    hash-table))
+
+(defun decode-array (length stream)
+  (let ((array (make-array length)))
+    (dotimes (i length)
+      (setf (aref array i) (decode-stream stream)))
+    array))
+
+(defun decode-raw-sequence (length stream)
+  (let ((seq (make-array length :element-type '(mod 256))))
+    (read-sequence seq stream)
+    (babel:octets-to-string seq)))
+
+(defun load-big-endian (stream byte-count)
+  (let ((result 0))
+    (loop
+       repeat byte-count
+       do (setf result (+ (ash result 8)
+                          (read-byte stream))))
+    result))

data/spec/fixtures/core.rkt

@@ -0,0 +1,254 @@
+#lang racket/base
+
+(require (for-syntax syntax/parse racket/syntax racket)
+         ffi/unsafe racket/function racket/string
+         "start.rkt" "c.rkt")
+
+(struct jtype (signature tag predicate ctype racket->java java->racket))
+(struct jtype/object jtype (class))
+(struct jtype/vector jtype/object (element))
+(struct jvector (cpointer type length))
+(struct jprocedure (args return proc))
+
+(define ((single-compose f1 f2) e) (f1 (f2 e)))
+
+(define (make-jtype obj racket->java java->racket)
+  (let ([composed-racket->java (single-compose (jtype-racket->java obj) racket->java)]
+        [composed-java->racket (single-compose java->racket (jtype-java->racket obj))])
+    ; due to limitation in racket's struct-copy
+    (cond
+      [(jtype/vector? obj)
+       (struct-copy jtype/vector obj
+         [racket->java #:parent jtype composed-racket->java]
+         [java->racket #:parent jtype composed-java->racket])]
+      [(jtype/object? obj)
+       (struct-copy jtype/object obj
+         [racket->java #:parent jtype composed-racket->java]
+         [java->racket #:parent jtype composed-java->racket])]
+      [else
+       (struct-copy jtype obj
+         [racket->java                composed-racket->java]
+         [java->racket                composed-java->racket])])))
+
+(define (jtype->ctype obj)
+  (make-ctype (jtype-ctype obj) (jtype-racket->java obj) (jtype-java->racket obj)))
+
+; --- signature makers ---
+(define (make-class-signature c)  (string-append "L" c ";"))
+(define (make-vector-signature s) (string-append "[" s))
+(define (make-signature args return)
+  (let ([args-signature (string-append* (map jtype-signature args))]
+        [return-signature (jtype-signature return)])
+    (string-append "(" args-signature ")" return-signature)))
+
+; --- predicates for java types on racket ---
+(require (only-in web-server/dispatch/extend make-coerce-safe?) srfi/26/cut)
+
+(define jboolean?   boolean?)
+(define jbyte?      byte?)
+(define jchar?      char?)
+(define jshort?     (make-coerce-safe? (cut < -32768 <> 32767)))
+(define jint?       (make-coerce-safe? (cut < -2147483648 <> 2147483647)))
+(define jlong?      (make-coerce-safe? (cut < -9223372036854775808 <> 9223372036854775807)))
+(define jfloat?     single-flonum?)
+(define jdouble?    flonum?)
+(define jstring?    string?)
+(define ((make-jobject-predicate clss) o) (instance-of? o clss))
+(define ((make-jlist-predicate element?) o) (andmap element? o))
+
+; --- java types ---
+(define _jboolean (jtype "Z" 'boolean jboolean? __jboolean #f            #f))
+(define _jbyte    (jtype "B" 'byte    jbyte?    __jbyte    #f            #f))
+(define _jchar    (jtype "C" 'char    jchar?    __jchar    char->integer integer->char))
+(define _jshort   (jtype "S" 'short   jshort?   __jshort   #f            #f))
+(define _jint     (jtype "I" 'int     jint?     __jint     #f            #f))
+(define _jlong    (jtype "J" 'long    jlong?    __jlong    #f            #f))
+(define _jfloat   (jtype "F" 'float   jfloat?   __jfloat   #f            #f))
+(define _jdouble  (jtype "D" 'double  jdouble?  __jdouble  #f            #f))
+(define _jvoid    (jtype "V" 'void    #f        __jvoid    #f            #f))
+; hack for _jobject and _jlist so that they dual as a jtype and function
+(define _jobject
+  ((λ ()
+     (struct _jobject jtype/object ()
+       #:property prop:procedure 
+       (λ (self class-name [racket->java #f] [java->racket #f] [predicate #f])
+         (let ([class-id (find-class class-name)])
+           (struct-copy jtype/object self
+             [signature    #:parent jtype (make-class-signature class-name)]
+             [predicate    #:parent jtype (or predicate (make-jobject-predicate class-id))]
+             [racket->java #:parent jtype racket->java]
+             [java->racket #:parent jtype java->racket]
+             [class                 class-id]))))
+     (let ([class-id (find-class "Ljava/lang/Object;")])
+       (_jobject "Ljava/lang/Object;" 'object (make-jobject-predicate class-id)
+                 __jobject #f #f class-id)))))
+(define _jstring  (_jobject "java/lang/String" new-string get-string jstring?))
+(define _jlist    
+  ((λ ()
+     (struct _jlist jtype/vector ()
+       #:property prop:procedure
+       (λ (self element)
+         (define-values (make-array array-ref array-set!) (tag->array-info (jtype-tag element)))
+         (when (jtype/object? element)
+           (let ([clss (jtype/object-class element)])
+             (set! make-array (λ (n) (new-object-array n clss #f)))))
+         (let* ([signature (make-vector-signature (jtype-signature element))]
+                [element-racket->java (or (jtype-racket->java element) identity)]
+                [element-java->racket (or (jtype-java->racket element) identity)]
+                [element? (or (jtype-predicate element) (λ (_) #t))])
+           (struct-copy jtype/vector self
+             [signature    #:parent jtype signature]
+             [predicate    #:parent jtype (make-jlist-predicate element?)]
+             [ctype        #:parent jtype __jobject]
+             [racket->java #:parent jtype
+              (λ (c)
+                (let ([array (make-array (length c))])
+                  (for ([e (in-list c)] [i (in-naturals)])
+                    (array-set! array i (element-racket->java e)))
+                  array))]
+             [java->racket #:parent jtype
+              (λ (c)
+                (for/list ([i (in-range (get-array-length c))])
+                  (element-java->racket (array-ref c i))))]
+             [class        #:parent jtype/object (find-class signature)]
+             [element               element]))))
+     (let ([class-id (find-class "[Ljava/lang/Object;")]
+           [element-class-id (jtype/object-class _jobject)])
+       (_jlist "[Ljava/lang/Object;" 'object (make-jobject-predicate element-class-id) __jobject
+               (λ (c)
+                 (let ([array (new-object-array (length c) element-class-id #f)])
+                   (for ([e (in-list c)]
+                         [i (in-naturals)])
+                     (set-object-array-element array i e))
+                   array))
+               (λ (c)
+                 (for/list ([i (in-range (get-array-length c))])
+                   (get-object-array-element c i)))
+               class-id
+               _jobject)))))
+(define-syntax (_jmethod stx)
+  (define-syntax-class type #:literals (->)
+    (pattern (~and x (~not (~or (~literal ...) ->)))))
+  (syntax-parse stx #:literals (->)
+    [(_ arg:type ... (~optional (~seq farg:type (~literal ...))) (~optional (~seq -> return*)))
+     (with-syntax* ([(arg* ...) (generate-temporaries #'(arg ...))]
+                    [(larg ... . marg) #`(arg* ... #,@(if (attribute farg) #'arg-rest #`()))]
+                    [(aarg ...) #`(arg* ... #,@(if (attribute farg) #'(arg-rest) #`()))]
+                    [return (if (attribute return*) #'return* #'_jvoid)])
+       #`(let* ([args  (list arg ... #,@(if (attribute farg) #`((_jlist farg)) #`()))])
+           (jprocedure args return
+            (λ (type jnienv clss method func)
+              (case type
+                [(constructor) (λ (larg ... . marg) (func jnienv clss method aarg ...))]
+                [(static-method) (λ (larg ... . marg) (func jnienv clss method aarg ...))]
+                [(method) (λ (o larg ... . marg) (func jnienv o method aarg ...))]
+                [else (error '_jmethod "invalid type provided")])))))]))
+; dynamic and slower version of _jmethod
+(define (_jprocedure args return #:repeat-last-arg? [repeat-last-arg? #f])
+  (define (nest-at lst i)
+    (if (null? lst) (list null)
+        (let loop ([lst lst] [i i])
+          (cond [(null? lst) null]
+                [(zero? i) (list lst)]
+                [else (cons (car lst) (loop (cdr lst) (sub1 i)))]))))
+ (jprocedure args return
+    (if repeat-last-arg?
+        (let ([repeat-position (sub1 (length args))])
+          (λ (type jnienv clss method func)
+            (case type
+              [(constructor) (λ larg  (apply func jnienv clss method (nest-at larg repeat-position)))]
+              [(static-method) (λ larg (apply func jnienv clss method (nest-at larg repeat-position)))]
+              [(method) (λ (o . larg) (apply func jnienv o method (nest-at larg repeat-position)))])))
+        (λ (type jnienv clss method func)
+          (case type
+            [(constructor) (λ larg (apply func jnienv clss method larg))]
+            [(static-method) (λ larg (apply func jnienv clss method larg))]
+            [(method) (λ (o . larg) (apply func jnienv o method larg))]
+            [else (error '_jprocedure "invalid type provided")])))))
+; get-jmethod/get-jconstructor pass the following arguments (type jnienv class method func) 
+; to a function created by _jmethod or _jprocedure 
+; according to the type the function returns one of the following functions
+; | constructor   (λ (args ...) ; doesn't need to take in an object and the class is static
+; | static-method (λ (args ...) ; same reasoning as above
+; | method        (λ (object args ...)
+
+
+; --- interfacing with java methods ---
+(define (get-jconstructor class-id type)
+  (let* ([args      (jprocedure-args type)]
+         [return    (jprocedure-return type)]
+         [proc      (jprocedure-proc type)]
+         [signature (make-signature args return)]
+         [method-id (get-method-id class-id "<init>" signature)]
+         [ffi-func  (get-jrffi-obj "new-object"
+                      (_cprocedure (list* __jnienv __jclass __jmethodID (map jtype->ctype args))
+                                   __jobject))])
+    (proc 'constructor current-jnienv class-id method-id ffi-func)))
+
+(define (get-jmethod class-id method-name type #:static? [static? #f])
+  (let* ([args      (jprocedure-args type)]
+         [return    (jprocedure-return type)]
+         [proc      (jprocedure-proc type)]
+         [signature (make-signature args return)]
+         [method-id (get-method-id class-id method-name signature #:static? static?)]
+         [type      (if static? 'static-method 'method)]
+         [ffi-func  (get-jrffi-obj 
+                     (format "call-~a~a-method" (if static? "static-" "") (jtype-tag return))       
+                     (_cprocedure (append (list __jnienv (if static? __jclass __jobject)
+                                                __jmethodID) (map jtype->ctype args))
+                                  (jtype->ctype return)))])
+    (proc type current-jnienv class-id method-id ffi-func)))
+
+
+; --- interfacing with java fields ---
+(define (get-jaccessor class-id field-name type #:static? [static? #f])
+  (let* ([signature (jtype-signature class-id field-name (jtype-signature type))]
+         [field-id  (get-field-id class-id field-name signature #:static? static?)]
+         [ffi-func  (get-jrffi-obj
+                     (format "get-~a~a-field" (if static? "static-" "") (jtype-tag type))
+                     (_cprocedure (list __jnienv (if static? __jclass __jobject) __jfieldID) type))])
+    (if static? (λ () (ffi-func current-jnienv class-id field-id))
+        (λ (obj) (ffi-func current-jnienv obj field-id)))))
+
+(define (get-jmutator class-id field-name type #:static? [static? #f])
+  (let* ([signature (jtype-signature class-id field-name (jtype-signature type))]
+         [field-id  (get-field-id class-id field-name signature #:static? static?)]
+         [ffi-func (get-jrffi-obj 
+                    (format "set-~a~a-field" (if static? "static-" "") (jtype-tag type))
+                    (_cprocedure (list __jnienv (if static? __jclass __jobject) __jfieldID type) type))])
+    (if static? (λ (new-value) (ffi-func current-jnienv class-id field-id new-value))
+        (λ (obj new-value) (ffi-func current-jnienv obj field-id new-value)))))
+
+(define (get-jparameter class-id field-name type #:static? [static? #f])
+  (let* ([accessor (get-jaccessor class-id field-name type #:static? static?)]
+         [mutator  (get-jmutator class-id field-name type #:static? static?)])
+    (if static?
+        (case-lambda
+          [() (accessor)]
+          [(new-value) (mutator new-value)])
+        (case-lambda
+          [(obj) (accessor obj)]
+          [(obj new-value) (mutator obj new-value)]))))
+
+
+
+(provide _jboolean _jbyte _jchar _jshort _jint _jlong _jfloat _jdouble _jvoid
+         _jobject _jstring _jlist)
+
+(provide get-jconstructor get-jmethod get-jparameter get-jmutator get-jaccessor)
+
+;(provide instance-of? (rename-out [find-class find-class]) get-method-id get-field-id)
+
+
+(provide (all-defined-out)  : -> current-jnienv)
+
+
+
+
+
+
+
+
+
+
+