source: project/release/4/javahack/javahack.scm @ 14825

Last change on this file since 14825 was 14825, checked in by felix winkelmann, 11 years ago

java-ref accepts string or symbol

File size: 4.5 KB
Line 
1;;;; javahack.scm
2
3
4(module javahack (java-run
5                  java-stop
6                  java-send
7                  java-object?
8                  java
9                  java-ref
10                  java-import
11                  java-memoize)
12
13  (import scheme chicken)
14  (use utils posix srfi-18 srfi-69 matchable extras data-structures files)
15
16(define-for-syntax java:*cache-enabled* #t)
17
18(define-syntax (java-enable-cache x r c)
19  (let ((flag (cadr x)))
20    (set! java:*cache-enabled* (c flag 'on)) 
21    `(,(r 'void))))
22
23(define-syntax (java x r c)
24  (let* ((x (cadr x))
25         (x (if (string? x) (string->symbol x) x)))
26    (if (and java:*cache-enabled* 
27             (let ((str (symbol->string (strip-syntax x))))
28               (not (char=? #\$ (string-ref str (sub1 (string-length str))))) ) )
29        `(,(r 'java-memoize) ',(gensym) (,(r 'lambda) () (,(r 'java-send) ',x)))
30        `(,(r 'java-send) ,(list (r 'quasiquote) x)) ) ) )
31
32(define-constant +java-executable+ "java")
33
34(define *scheme-jar-location* (make-pathname (repository-path) "jscheme.jar"))
35
36(define *in* #f)
37(define *out* #f)
38(define *debug* #f)
39(define *pid* #f)
40(define *lock* (make-mutex))
41(define *callback-table* (make-hash-table eq?))
42(define *callback-count* 0)
43(define *finalized* '())
44
45(define (java-run #!key (java +java-executable+) (jar *scheme-jar-location*) (debug #f) (options '()) classpath)
46  (set! *debug* debug)
47  (set!-values 
48   (*in* *out* *pid*)
49   (let ((cmd (conc java
50                    " "
51                    (if (string? options) options (string-intersperse options))
52                    " -classpath " (if classpath (conc jar ":" classpath) jar)
53                    " jsint.Scheme " (make-pathname (repository-path) "javahack-wrap.scm") ) ) )
54     (when debug (printf "[java: running ~s]~%" cmd))
55     (process cmd) ) ) )
56
57(define (java-stop)
58  (cond (*pid*
59         (display "#f\n" *out*)
60         (flush-output *out*)
61         (close-output-port *out*)
62         (close-input-port *in*)
63         (set! *pid* #f) )
64        (else
65         (warning 'java-stop "no java process active") ) ) )
66
67(implicit-exit-handler
68 (let ((old (implicit-exit-handler)))
69   (lambda ()
70     (when *pid* (java-stop))
71     (old) ) ) )
72
73(define (java-send expr)
74  (unless *pid* (java-run))
75  (dynamic-wind
76      (cut mutex-lock! *lock*)
77      (lambda ()
78        (when (pair? *finalized*)
79          (set! expr `(begin ,@(map (lambda (id) `(release ,id)) *finalized*) ,expr))
80          (set! *finalized* '()) )
81        (when *debug* 
82          (printf "[java: sending: ~s ~!" expr) )
83        (write expr *out*)
84        (newline *out*)
85        (flush-output *out*)
86        (let loop ()
87          (let ((x (read *in*)))
88            (when *debug*
89              (printf "--> ~s]~%" x) )
90            (match x
91              (('ref id) (id->java-object id))
92              (('val x) x)
93              (('null) (void))
94              (('proc id) (id->java-procedure id))
95              (('call id . args) 
96               (when *debug*
97                 (printf "[java: callback (~a) ~!" id) )
98               (let ((x (apply (hash-table-ref *callback-table* id) args)))
99                 (when *debug* (printf "--> ~s]~%" x))
100                 (write x *out*)
101                 (newline *out*) 
102                 (flush-output *out*)
103                 (loop) ) )
104              (('err str) 
105               (signal 
106                (make-composite-condition
107                 (make-property-condition 'exn 'message str 'location 'java-send)
108                 (make-property-condition 'java 'expression expr) ) ) )
109              (_ (error 'java-send "invalid result returned by wrapper" x)) ) ) ) )
110      (cut mutex-unlock! *lock*) ) )
111
112(define-record java-object id)
113
114(define-record-printer (java-object x p)
115  (fprintf p "#<java-object ~a>" (java-object-id x)) )
116
117(define (java-object-finalizer x)
118  (when *debug*
119    (fprintf (current-error-port) "[java: finalizing ~s]~%" x) )
120  (set! *finalized* (cons (java-object-id x) *finalized*)) )
121
122(define (id->java-object id)
123  (let ((o (make-java-object id)))
124    (set-finalizer! o java-object-finalizer) ) )
125
126(define (java-argument x)
127  (cond ((java-object? x) `(.get *id-table* ',(java-object-id x)))
128        ((procedure? x) 
129         (let ((id *callback-count*))
130           (set! *callback-count* (fx+ id 1))
131           (hash-table-set! *callback-table* id x)
132           `(callback ,id) ) )
133        ((eq? (void) x) '(void))
134        (else x) ) )
135
136(define ((id->java-procedure id) . args)
137  (java-send `((.get *id-table* ',id) ,@(map java-argument args))) )
138
139(define (name->symbol x)
140  (cond ((symbol? x) x)
141        ((string? x) (string->symbol x))
142        (else (error 'java-ref "invalid name" x))))
143
144(define java-ref
145  (getter-with-setter
146   (lambda (s) (java-send (name->symbol s)))
147   (lambda (s x)
148     (java-send `(set! ,(name->symbol s) ,(java-argument x)) ) ) ) )
149
150(define (java-import . xs)
151  (java-send `(begin ,@(map (lambda (x) `(import ,(->string x))) xs))) )
152
153(define (java-memoize sym thunk)
154  (if (##sys#symbol-has-toplevel-binding? sym)
155      (##sys#slot sym 0)
156      (let ((x (thunk)))
157        (##sys#setslot sym 0 x)
158        x) ) )
159
160)
Note: See TracBrowser for help on using the repository browser.