-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathjava.ljsp
298 lines (269 loc) · 13.5 KB
/
java.ljsp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
;-*- Mode: Lisp -*-
;;;; java.ljsp
(require 'stuff)
;; Rack down the parenthesis-count a little...
(defun send (obj msg . args) (apply (obj msg) args))
(defun fetch-java-classes clazzes
(let ((roop (lambda (lst)
(unless (end? lst)
(set (car lst) (send Class 'forName (cadr lst)))
(roop (cddr lst))))))
(roop clazzes)))
(fetch-java-classes 'FileReader "java.io.FileReader"
'Array "java.lang.reflect.Array"
'Arrays "java.util.Arrays"
'ArrayList "java.util.ArrayList"
'String "java.lang.String"
'StringBuilder "java.lang.StringBuilder"
'HashMap "java.util.HashMap"
'JFrame "javax.swing.JFrame"
'JLabel "javax.swing.JLabel"
'JPanel "javax.swing.JPanel"
'JButton "javax.swing.JButton"
'JFormattedTextField "javax.swing.JFormattedTextField"
'JTextField "javax.swing.JTextField"
'JTextArea "javax.swing.JTextArea"
'JPanel "javax.swing.JPanel"
'JScrollPane "javax.swing.JScrollPane"
'JList "javax.swing.JList"
'JOptionPane "javax.swing.JOptionPane"
'Box "javax.swing.Box"
'DefaultListModel "javax.swing.DefaultListModel"
'javax.swing.Timer "javax.swing.Timer"
'Thread "java.lang.Thread"
'ActionEvent "java.awt.event.ActionEvent"
'KeyEvent "java.awt.event.KeyEvent"
'MouseEvent "java.awt.event.MouseEvent"
'WindowEvent "java.awt.event.WindowEvent"
'EventQueue "java.awt.EventQueue"
'Color "java.awt.Color"
'GridLayout "java.awt.GridLayout"
'Graphics "java.awt.Graphics"
'Graphics2D "java.awt.Graphics2D"
'Toolkit "java.awt.Toolkit"
'RoundRectangle2D "java.awt.geom.RoundRectangle2D"
'RoundRectangle2D$Double "java.awt.geom.RoundRectangle2D$Double"
'RoundRectangle2D$Float "java.awt.geom.RoundRectangle2D$Float"
'Rectangle2D "java.awt.geom.Rectangle2D"
'Rectangle2D$Double "java.awt.geom.Rectangle2D$Double"
'Rectangle2D$Float "java.awt.geom.Rectangle2D$Float"
'InputStream "java.io.InputStream"
'FileInputStream "java.io.FileInputStream"
'StringReader "java.io.StringReader"
'Boolean "java.lang.Boolean"
'Short "java.lang.Short"
'Integer "java.lang.Integer"
'Long "java.lang.Long"
'Float "java.lang.Float"
'Double "java.lang.Double"
'Character "java.lang.Character"
'Math "java.lang.Math"
'Object "java.lang.Object"
'HashSet "java.util.HashSet"
'System "java.lang.System"
'Font "java.awt.Font"
'Runtime "java.lang.Runtime"
'BigInteger "java.math.BigInteger"
'Symbol "Symbol"
'Cons "Cons"
'Procedure "Procedure"
'LispSubr "LispSubr"
'LispStream "LispStream"
'LispException "LispException")
;; GURBER
(defun make-my-array lst
(let* ((len (length lst))
(idx 0)
(ar (send Array 'newInstance Object len)))
(dolist (l lst)
(send Array 'set ar idx l)
(inc idx))
ar))
(defun java-array->list (ary)
(let ((roop (lambda (cnt acc)
(if (< cnt 0)
acc
(roop (1- cnt) (cons (send Array 'get ary cnt) acc))))))
(roop (1- (send Array 'getLength ary)) nil)))
(defun print-methods (klas)
(dolist (i (mapcar (lambda (x) (send x 'toString))
(java-array->list (send klas 'getMethods))))
(write-string i)
(terpri)))
(defun print-fields (klas)
(dolist (i (mapcar (lambda (x) (send x 'toString))
(java-array->list (send klas 'getFields))))
(write-string i)
(terpri)))
;; (defun instance-of (a b)
;; (send 'isInstance b))
(defun field-value (obj field)
(let ((field (if (send Symbol 'isInstance field)
(prin1-to-string field)
field))
(klas (if (send Class 'isInstance obj)
obj
(send obj 'getClass))))
(send (send klas 'getField field) 'get obj)))
;; Useful when you need to call several methods for side-effects on a single object,
;; like when using swing for example.
(defmacro with-object (a)
(let ((obj-sym (gensym)))
(subst-symbols '(let ((<obj-sym> <obj>))
(progn . <body>)
<obj-sym>)
'<obj-sym> obj-sym
'<obj> (cadr a)
'<body> (mapcar (lambda (x)
(subst-symbols '(send <obj-sym> '<method> . <args>)
'<obj-sym> obj-sym
'<method> (car x)
'<args> (cdr x)))
(cddr a)))))
;; Java-adapted try-catch thingamajing. uses the low-level %try
;; Here we see when substitution-based macro-building is inferior to backquoting (which ljsp lacks at the moment)
(defmacro try-catch-finally (a)
(let* ((rst (cdr a))
(catch-forms (nlet collect ((lst rst) (acc nil))
(let ((x (member 'catch lst)))
(if (end? x)
(reverse! acc)
(collect (cdddr x) (cons (cons (second x) (third x)) acc))))))
(exception-sym (gensym)))
(print 'bajs)
(subst-symbols '(%try (lambda () <try-form>)
(lambda (<exception-sym>) (cond . <cond-body>)))
'<exception-sym> exception-sym
'<try-form> (second (member 'try rst))
'<cond-body> (append
(mapcar (lambda (_)
(subst-symbols '((send <exception-type> 'isInstance <exception-sym>) (let ((<exception-name> <exception-sym>))
<handler-form>))
'<exception-type> (caar _)
'<exception-sym> exception-sym
'<exception-name> (cadar _)
'<handler-form> (cadr _)))
catch-forms)
(list (subst-symbols '(t <finally-form> (throw <exception-sym>))
'<finally-form> (second (member 'finally rst))
'<exception-sym> exception-sym))))))
;; ;; Wants to be replaced
;; (defun read-from-string (str)
;; (let ((make-string-reader (send Array 'get (send StringReader 'getConstructors) 0))
;; (make-lisp-stream (send Array 'get (send LispStream 'getConstructors) 1)))
;; (read (send make-lisp-stream 'newInstance (make-my-array (send make-string-reader 'newInstance (make-my-array str)) nil)))))
;; ;; MEGAUGLY
;; (let ((tmp (send ArrayList 'newInstance)))
;; (setq java-true (send tmp 'add 23))
;; (setq java-false (send tmp 'contains 22)))
;; Some playing around
(setq fib-memo-arraylist (send ArrayList 'newInstance))
(let ((add (fib-memo-arraylist 'add)))
(add 0)
(add 1)
(dotimes (i 3000) (add -1)))
(defun fib-memo-java (n)
(let ((tjo (send fib-memo-arraylist 'get n)))
(if (/= tjo -1)
tjo
(let ((result (+ (fib-memo-java (- n 1)) (fib-memo-java (- n 2)))))
(send fib-memo-arraylist 'set n result)
result))))
(defun hello-warld ()
(setq frame (send JFrame 'newInstance)
label (send JLabel 'newInstance))
(send frame 'setTitle "HelloWorldSwing")
(send label 'setText "Hello World")
(send (send frame 'getContentPane) 'add label)
(send frame 'pack)
(send frame 'setVisible t))
;; (setq newline "
;; ")
;; (setq char-newline #\
;; )
(defun start-listener ()
(setq listener (list 'frame (send JFrame 'newInstance)
'text-field (send JTextField 'newInstance)
'text-area (send JTextArea 'newInstance)
'output-scroll-pane (send JScrollPane 'newInstance)
'list-scroll-pane (send JScrollPane 'newInstance)
'symbol-list (send JList 'newInstance)
'panel (send Box 'createHorizontalBox) ;(send JPanel 'newInstance)
'right-box (send Box 'createVerticalBox)
'history nil
'history-tmp nil))
(with-plist (frame
text-field
text-area
output-scroll-pane
list-scroll-pane
symbol-list
panel
right-box) listener
(with-object text-field
(setText "Write stuffs here for great justice!")
(setColumns 24)
(addActionListener
(make-listener (lambda (e)
(send text-area 'append
(with-output-to-string (*standard-output*)
(let* ((str (send e 'getActionCommand))
(what-i-read (read-from-string str)))
(write-char #\>) (write-char #\>) (write-char #\ ) ;FIXME: GARH
(print what-i-read)
(print (eval what-i-read))
(putf listener 'history (cons str (getf listener 'history))))))
(send text-field 'setText "")
(listener-update-symbol-list))))
(addKeyListener
(make-listener (lambda (e)
(when (= (send e 'getID) (field-value KeyEvent 'KEY_PRESSED))
(unless (getf listener 'history-tmp) (putf listener 'history-tmp (copy-list (getf listener 'history))))
(cond ((= (send e 'getKeyCode) (field-value KeyEvent 'VK_UP))
(send text-field 'setText (car (getf listener 'history-tmp)))
(putf listener 'history-tmp (rotate-left (getf listener 'history-tmp))))
((= (send e 'getKeyCode) (field-value KeyEvent 'VK_DOWN))
(send text-field 'setText (car (getf listener 'history-tmp)))
(putf listener 'history-tmp (rotate-right (getf listener 'history-tmp))))
(t (putf listener 'history-tmp nil))))))))
(with-object text-area
(setRows 24)
(setColumns 72)
(setEditable nil)
(setLineWrap t)
(setAutoscrolls t))
(send output-scroll-pane 'setViewportView text-area)
(with-object symbol-list
(setFixedCellWidth 128)
(addKeyListener
(make-listener (lambda (e)
(and (= (send e 'getID) (field-value KeyEvent 'KEY_PRESSED))
(= (send e 'getKeyCode) (field-value KeyEvent 'VK_ENTER))
(send text-field 'setText
(prin1-to-string (send symbol-list 'getSelectedValue))))))))
(listener-update-symbol-list)
(send list-scroll-pane 'setViewportView symbol-list)
(with-object right-box
(add output-scroll-pane)
(add text-field))
(with-object panel
(add list-scroll-pane)
(add right-box))
(with-object frame
(setTitle "Listener")
(setDefaultCloseOperation (field-value JFrame 'DISPOSE_ON_CLOSE))
(add panel)
(pack)
(setVisible t))))
(defun get-procedure-list ()
(remove-if (lambda (x)
(cond ((send LispSubr 'isInstance (symbol-value x)) nil)
((atom? (symbol-value x)) t)
((eq? (car (symbol-value x)) 'lambda) nil)
((eq? (car (symbol-value x)) 'macro) nil)
(t t)))
(symbols)))
(defun listener-update-symbol-list ()
(send (getf listener 'symbol-list) 'setListData
(apply make-my-array (get-procedure-list))))
(provide 'java)