source: trunk/j/src/org/armedbear/lisp/jvm.lisp @ 4642

Last change on this file since 4642 was 4642, checked in by piso, 19 years ago

Work in progress.

File size: 67.5 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: jvm.lisp,v 1.6 2003-11-04 18:35:30 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(require 'transform)
21
22(in-package "JVM")
23
24(export '(jvm-compile jvm-compile-package))
25
26(shadow 'method)
27
28(defvar *instructions*
29  '(nop             aconst_null  iconst_m1       iconst_0      iconst_1     ;   0
30    iconst_2        iconst_3     iconst_4        iconst_5      lconst_0     ;   5
31    lconst_1        fconst_0     fconst_1        fconst_2      dconst_0     ;  10
32    dconst_1        bipush       sipush          ldc           ldc_w        ;  15
33    ldc2_w          iload        lload           fload         dload        ;  20
34    aload           iload_0      iload_1         iload_2       iload_3      ;  25
35    lload_0         lload_1      lload_2         lload_3       fload_0      ;  30
36    fload_1         fload_2      fload_3         dload_0       dload_1      ;  35
37    dload_2         dload_3      aload_0         aload_1       aload_2      ;  40
38    aload_3         iaload       laload          faload        daload       ;  45
39    aaload          baload       caload          saload        istore       ;  50
40    lstore          fstore       dstore          astore        istore_0     ;  55
41    istore_1        istore_2     istore_3        lstore_0      lstore_1     ;  60
42    lstore_2        lstore_3     fstore_0        fstore_1      fstore_2     ;  65
43    fstore_3        dstore_0     dstore_1        dstore_2      dstore_3     ;  70
44    astore_0        astore_1     astore_2        astore_3      iastore      ;  75
45    lastore         fastore      dastore         aastore       bastore      ;  80
46    castore         sastore      pop             pop2          dup          ;  85
47    dup_x1          dup_x2       dup2            dup2_x1       dup2_x2      ;  90
48    swap            iadd         ladd            fadd          dadd         ;  95
49    isub            lsub         fsub            dsub          imul         ; 100
50    lmul            fmul         dmul            idiv          ldiv         ; 105
51    fdiv            ddiv         irem            lrem          frem         ; 110
52    drem            ineg         lneg            fneg          dneg         ; 115
53    ishl            lshl         ishr            lshr          iushr        ; 120
54    lushr           iand         land            ior           lor          ; 125
55    ixor            lxor         iinc            i2l           i2f          ; 130
56    i2d             l2i          l2f             l2d           f2i          ; 135
57    f2l             f2d          d2i             d2l           d2f          ; 140
58    i2b             i2c          i2s             lcmp          fcmpl        ; 145
59    fcmpg           dcmpl        dcmpg           ifeq          ifne         ; 150
60    iflt            ifge         ifgt            ifle          if_icmpeq    ; 155
61    if_icmpne       if_icmplt    if_icmpge       if_icmpgt     if_icmple    ; 160
62    if_acmpeq       if_acmpne    goto            jsr           ret          ; 165
63    tableswitch     lookupswitch ireturn         lreturn       freturn      ; 170
64    dreturn         areturn      return          getstatic     putstatic    ; 175
65    getfield        putfield     invokevirtual   invokespecial invokestatic ; 180
66    invokeinterface unused       new             newarray      anewarray    ; 185
67    arraylength     athrow       checkcast       instanceof    monitorenter ; 190
68    monitorexit     wide         multianewarray  ifnull        ifnonnull    ; 195
69    goto_w          jsr_w        label                                      ; 200
70    ))
71
72(unless (vectorp *instructions*)
73  (let* ((list *instructions*)
74         (vector (make-array (length *instructions*)))
75         (index 0))
76    (dolist (instr list)
77      (setf (get instr 'opcode) index)
78      (setf (svref vector index) instr)
79      (incf index))
80    (setq *instructions* vector)))
81
82(defun instr (opcode)
83  (svref *instructions* opcode))
84
85(defparameter *opcode-size*
86  ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9
87  '#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 3 2 3  ;; 000-019
88     3 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 020-039
89     1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 1  ;; 040-059
90     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 060-079
91     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 080-099
92     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 100-119
93     1 1 1 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1  ;; 120-139
94     1 1 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3  ;; 140-159
95     3 3 3 3 3 3 3 3 3 2 0 0 1 1 1 1 1 1 3 3  ;; 160-179
96     3 3 3 3 3 5 0 3 2 3 1 1 3 3 1 1 0 4 3 3  ;; 180-199
97     5 5 0                                    ;; 200-202
98     ))
99
100(defun opcode-size (opcode)
101  (svref *opcode-size* opcode))
102
103(defvar *pool* nil)
104
105(defun read-u1 (stream)
106  (read-byte stream))
107
108(defun read-u2 (stream)
109  (+ (ash (read-byte stream) 8) (read-byte stream)))
110
111(defun read-u4 (stream)
112  (+ (ash (read-u2 stream) 16) (read-u2 stream)))
113
114(defun lookup-utf8 (index)
115  (let ((entry (svref *pool* index)))
116    (when (eql (car entry) 1)
117      (caddr entry))))
118
119(defun read-constant-pool-entry (stream)
120  (let ((tag (read-u1 stream))
121        info)
122    (case tag
123      ((7 8)
124       (list tag (read-u2 stream)))
125      (1
126       (let* ((len (read-u2 stream))
127              (s (make-string len)))
128         (dotimes (i len)
129;;            (setf (char s i) (coerce (read-u1 stream) 'character)))
130           (setf (char s i) (code-char (read-u1 stream))))
131         (list tag len s)))
132      ((3 4)
133       (list tag (read-u4 stream)))
134      ((5 6)
135       (list tag (read-u4 stream) (read-u4 stream)))
136      ((12 9 10 11)
137       (list tag (read-u2 stream) (read-u2 stream)))
138      (t
139       (error "READ-CONSTANT-POOL-ENTRY unhandled tag ~D" tag)))))
140
141(defvar *indent* 0)
142
143(defparameter *spaces* (make-string 256 :initial-element #\space))
144
145(defmacro out (&rest args)
146  `(progn (format t (subseq *spaces* 0 *indent*)) (format t ,@args)))
147
148(defun dump-code (code)
149  (let ((code-length (length code)))
150    (do ((i 0))
151        ((>= i code-length))
152      (let* ((opcode (svref code i))
153             (size (opcode-size opcode)))
154        (out "~D (#x~X) ~A~%" opcode opcode (instr opcode))
155        (incf i)
156        (dotimes (j (1- size))
157          (let ((byte (svref code i)))
158            (out "~D (#x~X)~%" byte byte))
159          (incf i))))))
160
161(defun dump-code-attribute (stream)
162  (let ((*indent* (+ *indent* 2)))
163    (out "Stack: ~D~%" (read-u2 stream))
164    (out "Locals: ~D~%" (read-u2 stream))
165    (let* ((code-length (read-u4 stream))
166           (code (make-array code-length)))
167      (out "Code length: ~D~%" code-length)
168      (out "Code:~%")
169      (dotimes (i code-length)
170        (setf (svref code i) (read-u1 stream)))
171      (let ((*indent* (+ *indent* 2)))
172        (dump-code code)))
173    (let ((exception-table-length (read-u2 stream)))
174      (out "Exception table length: ~D~%" exception-table-length)
175      (let ((*indent* (+ *indent* 2)))
176        (dotimes (i exception-table-length)
177          (out "Start PC: ~D~%" (read-u2 stream))
178          (out "End PC: ~D~%" (read-u2 stream))
179          (out "Handler PC: ~D~%" (read-u2 stream))
180          (out "Catch type: ~D~%" (read-u2 stream)))))
181    (let ((attributes-count (read-u2 stream)))
182      (out "Number of attributes: ~D~%" attributes-count)
183      (let ((*indent* (+ *indent* 2)))
184        (dotimes (i attributes-count)
185          (read-attribute i stream))))))
186
187(defun dump-exceptions (stream)
188  )
189
190(defun read-attribute (index stream)
191  (let* ((name-index (read-u2 stream))
192         (length (read-u4 stream))
193         (*indent (+ *indent* 2)))
194    (setq name (lookup-utf8 name-index))
195    (out "Attribute ~D: Name index: ~D (~S)~%" index name-index name)
196    (out "Attribute ~D: Length: ~D~%" index length)
197    (cond ((string= name "Code")
198           (dump-code-attribute stream))
199          ((string= name "Exceptions")
200           (let ((count (read-u2 stream)))
201             (out "Attribute ~D: Number of exceptions: ~D~%" index count)
202             (let ((*indent* (+ *indent* 2)))
203               (dotimes (i count)
204                 (out "Exception ~D: ~D~%" i (read-u2 stream))))))
205          (t
206           (dotimes (i length)
207             (read-u1 stream))))))
208
209(defun read-info (index stream type)
210  (let* ((access-flags (read-u2 stream))
211         (name-index (read-u2 stream))
212         (descriptor-index (read-u2 stream))
213         (attributes-count (read-u2 stream))
214         (*indent* (+ *indent* 2))
215         (type (case type
216                 ('field "Field")
217                 ('method "Method")))
218         name)
219    (out "~A ~D: Access flags: #x~X~%" type index access-flags)
220    (out "~A ~D: Name index: ~D (~S)~%" type index name-index (lookup-utf8 name-index))
221    (out "~A ~D: Descriptor index: ~D~%" type index descriptor-index)
222    (out "~A ~D: Number of attributes: ~D~%" type index attributes-count)
223    (let ((*indent* (+ *indent* 2)))
224      (dotimes (i attributes-count)
225        (read-attribute i stream)))))
226
227(defun dump-class (filename)
228  (let ((*indent* 0)
229        (*pool* nil))
230    (with-open-file (stream filename :direction :input :element-type 'unsigned-byte)
231      (handler-bind ((end-of-file
232                      #'(lambda (c) (return-from dump-class c))))
233        (out "Magic number: #x~X~%" (read-u4 stream))
234        (let ((minor (read-u2 stream))
235              (major (read-u2 stream)))
236          (out "Version: ~D.~D~%" major minor))
237        ;; Constant pool.
238        (let ((count (read-u2 stream))
239              entry type)
240          (out "Constant pool (~D entries):~%" count)
241          (setq *pool* (make-array count))
242          (let ((*indent* (+ *indent* 2)))
243            (dotimes (index (1- count))
244              (setq entry (read-constant-pool-entry stream))
245              (setf (svref *pool* (1+ index)) entry)
246              (setq type (case (car entry)
247                           (7 'class)
248                           (9 'field)
249                           (10 'method)
250                           (11 'interface)
251                           (8 'string)
252                           (3 'integer)
253                           (4 'float)
254                           (5 'long)
255                           (6 'double)
256                           (12 'name-and-type)
257                           (1 'utf8)))
258              (out "~D: ~A ~S~%" (1+ index) type entry))))
259        (out "Access flags: #x~X~%" (read-u2 stream))
260        (out "This class: ~D~%" (read-u2 stream))
261        (out "Superclass: ~D~%" (read-u2 stream))
262        ;; Interfaces.
263        (let ((count (read-u2 stream)))
264          (cond ((zerop count)
265                 (out "No interfaces~%"))
266                (t
267                 (out "Interfaces (~D):~%" count)
268                 (dotimes (i count)
269                   (out "  ~D: ~D~%" i (read-u2 stream))))))
270        ;; Fields.
271        (let ((count (read-u2 stream)))
272          (cond ((zerop count)
273                 (out "No fields~%"))
274                (t
275                 (out "Fields (~D):~%" count)))
276          (dotimes (index count)
277            (read-info index stream 'field)))
278        ;; Methods.
279        (let ((count (read-u2 stream)))
280          (cond ((zerop count)
281                 (out "No methods~%"))
282                (t
283                 (out "Methods (~D):~%" count)))
284          (dotimes (index count)
285            (read-info index stream 'method)))
286        (let ((count (read-u2 stream)))
287          (cond ((zerop count)
288                 (out "No attributes~%"))
289                (t
290                 (out "Attributes (~D):~%" count)))))))
291  t)
292
293(defvar *stream* nil)
294(defvar *defun-name* nil)
295(defvar *this-class* nil)
296(defvar *pool-count* 1)
297
298(defvar *code* ())
299(defvar *static-code* ())
300(defvar *fields* ())
301
302(defvar *blocks* ())
303(defvar *locals* ())
304(defvar *max-locals* 0)
305
306(defvar *args* nil)
307(defvar *using-arg-array* nil)
308(defvar *hairy-arglist-p* nil)
309
310(defvar *val* ()) ; index of value register
311
312(defun clear ()
313  (setq *pool* nil
314        *pool-count* 1
315        *code* nil)
316  t)
317
318(defun dump-pool ()
319  (let ((pool (reverse *pool*))
320        entry)
321    (dotimes (index (1- *pool-count*))
322      (setq entry (car pool))
323      (setq type (case (car entry)
324                   (7 'class)
325                   (9 'field)
326                   (10 'method)
327                   (11 'interface)
328                   (8 'string)
329                   (3 'integer)
330                   (4 'float)
331                   (5 'long)
332                   (6 'double)
333                   (12 'name-and-type)
334                   (1 'utf8)))
335      (format t "~D: ~A ~S~%" (1+ index) type entry)
336      (setq pool (cdr pool))))
337  t)
338
339;; Returns index of entry (1-based).
340(defun pool-add (entry)
341  (setq *pool* (cons entry *pool*))
342  (prog1
343    *pool-count*
344    (incf *pool-count*)))
345
346;; Returns index of entry (1-based).
347(defun pool-find-entry (entry)
348  (do* ((remaining *pool* (cdr remaining))
349        (i 0 (1+ i))
350        (current (car remaining) (car remaining)))
351       ((null remaining) nil)
352    (when (equal current entry)
353      (return-from pool-find-entry (- *pool-count* 1 i)))))
354
355;; Adds entry if not already in pool. Returns index of entry (1-based).
356(defun pool-get (entry)
357  (or (pool-find-entry entry) (pool-add entry)))
358
359(defun pool-name (name)
360  (pool-get (list 1 (length name) name)))
361
362;; "org.armedbear.lisp.LispObject" => "Lorg/armedbear/lisp/LispObject;"
363;; (defun type-descriptor (type)
364;;   (unless (find #\. type)
365;;     (setq type (concatenate 'string "org.armedbear.lisp." type)))
366;;   (let ((res (concatenate 'string "L" type ";")))
367;;     (dotimes (i (length res))
368;;       (when (eql (char res i) #\.)
369;;         (setf (char res i) #\/)))
370;;     res))
371
372(defun pool-name-and-type (name type)
373  (let* ((name-index (pool-name name))
374         (type-index (pool-name type)))
375    (pool-get (list 12 name-index type-index))))
376
377(defun pool-class (class-name)
378  (let ((class-name class-name))
379    (dotimes (i (length class-name))
380      (when (eql (char class-name i) #\.)
381        (setf (char class-name i) #\/)))
382    (pool-get (list 7 (pool-name class-name)))))
383
384;; (tag class-index name-and-type-index)
385(defun pool-field (class-name field-name type-name)
386  (let* ((class-index (pool-class class-name))
387         (name-and-type-index (pool-name-and-type field-name type-name)))
388    (pool-get (list 9 class-index name-and-type-index))))
389
390;; (tag class-index name-and-type-index)
391(defun pool-method (class-name method-name type-name)
392  (let* ((class-index (pool-class class-name))
393         (name-and-type-index (pool-name-and-type method-name type-name)))
394    (pool-get (list 10 class-index name-and-type-index))))
395
396(defun pool-string (string)
397  (pool-get (list 8 (pool-name string))))
398
399(defun u2 (n)
400  (list (ash n -8) (logand n #xff)))
401
402(defstruct instruction opcode args stack)
403
404(defun inst (opcode &optional args)
405  (unless (listp args)
406    (setq args (list args)))
407  (make-instruction :opcode opcode :args args :stack 0))
408
409(defun emit (instr &rest args)
410  (unless (numberp instr)
411    (setq instr (get instr 'opcode)))
412  (setq *code* (cons (inst instr args) *code*)))
413
414(defmacro emit-store-value ()
415  `(case *val*
416     (0
417      (emit 'astore_0))
418     (1
419      (emit 'astore_1))
420     (2
421      (emit 'astore_2))
422     (3
423      (emit 'astore_3))
424     (t
425      (emit 'astore *val*))))
426
427(defmacro emit-push-value ()
428  `(case *val*
429     (0
430      (emit 'aload_0))
431     (1
432      (emit 'aload_1))
433     (2
434      (emit 'aload_2))
435     (3
436      (emit 'aload_3))
437     (t
438      (emit 'aload *val*))))
439
440(defun remove-store-value ()
441  (let* ((instruction (car *code*))
442         (opcode (instruction-opcode instruction))
443         slot)
444    (case opcode
445      (75
446       (setf slot 0))
447      (76
448       (setf slot 1))
449      (77
450       (setf slot 2))
451      (78
452       (setf slot 3))
453      (58
454       (setf slot (car (instruction-args instruction)))))
455    (when (and slot (= slot *val*))
456      (setf *code* (cdr *code*))
457      t)))
458
459(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
460
461(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
462(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
463
464(defconstant +lisp-string+ "Lorg/armedbear/lisp/LispString;")
465
466(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
467
468(defun emit-push-nil ()
469  (emit 'getstatic
470        +lisp-class+
471        "NIL"
472        +lisp-object+))
473
474(defun emit-push-t ()
475  (emit 'getstatic
476        +lisp-class+
477        "T"
478        "Lorg/armedbear/lisp/Symbol;"))
479
480(defun emit-clear-values ()
481  (emit 'invokestatic
482        +lisp-thread-class+
483        "currentThread"
484        "()Lorg/armedbear/lisp/LispThread;")
485  (emit 'invokevirtual
486        +lisp-thread-class+
487        "clearValues"
488        "()V"))
489
490(defun emit-invoke-method (method-name)
491  (unless (remove-store-value)
492    (emit-push-value))
493  (emit 'invokevirtual
494        +lisp-object-class+
495        method-name
496        "()Lorg/armedbear/lisp/LispObject;")
497  (emit-store-value))
498
499;; CODE is a list.
500(defun resolve-args (instruction)
501  (let ((opcode (instruction-opcode instruction))
502        (args (instruction-args instruction)))
503    (case opcode
504      ((1 ; ACONST_NULL
505        42 ; ALOAD_0
506        43 ; ALOAD_1
507        44 ; ALOAD_2
508        45 ; ALOAD_3
509        50 ; AALOAD
510        75 ; ASTORE_0
511        76 ; ASTORE_1
512        77 ; ASTORE_2
513        78 ; ASTORE_3
514        83 ; AASTORE
515        87 ; POP
516        89 ; DUP
517        95 ; SWAP
518        153 ; IFEQ
519        154 ; IFNE
520        166 ; IF_ACMPNE
521        165 ; IF_ACMPEQ
522        167 ; GOTO
523        176 ; ARETURN
524        177 ; RETURN
525        202 ; LABEL
526        )
527       instruction)
528      (25 ; ALOAD
529       (let ((index (car args)))
530         (cond ((= index 0)
531                (inst 42)) ; ALOAD_O
532               ((= index 1)
533                (inst 43)) ; ALOAD_1
534               ((= index 2)
535                (inst 44)) ; ALOAD_2
536               ((= index 3)
537                (inst 45)) ; ALOAD_3
538               ((<= 0 index 255)
539                (inst 25 index))
540               (t
541                (error "ALOAD unsupported case")))))
542      (58 ; ASTORE
543       (let ((index (car args)))
544         (cond ((= index 0)
545                (inst 75)) ; ASTORE_O
546               ((= index 1)
547                (inst 76)) ; ASTORE_1
548               ((= index 2)
549                (inst 77)) ; ASTORE_2
550               ((= index 3)
551                (inst 78)) ; ASTORE_3
552               ((<= 0 index 255)
553                (inst 58 index))
554               (t
555                (error "ASTORE unsupported case")))))
556      ((178 ; GETSTATIC class-name field-name type-name
557        179 ; PUTSTATIC class-name field-name type-name
558        )
559       (let ((index (pool-field (first args) (second args) (third args))))
560         (inst opcode (u2 index))))
561      ((182 ; INVOKEVIRTUAL class-name method-name descriptor
562        183 ; INVOKESPECIAL class-name method-name descriptor
563        184 ; INVOKESTATIC class-name method-name descriptor
564        )
565       (let ((index (pool-method (first args) (second args) (third args))))
566         (inst opcode (u2 index))))
567      ((189 ; ANEWARRAY class-name
568        )
569       (let ((index (pool-class (first args))))
570         (inst opcode (u2 index))))
571      ((16 ; BIPUSH
572        17 ; SIPUSH
573        )
574       (let ((n (first args)))
575         (cond ((= n 0)
576                (inst 3)) ; ICONST_0
577               ((= n 1)
578                (inst 4)) ; ICONST_1
579               ((= n 2)
580                (inst 5)) ; ICONST_2
581               ((= n 3)
582                (inst 6)) ; ICONST_3
583               ((= n 4)
584                (inst 7)) ; ICONST_4
585               ((= n 5)
586                (inst 8)) ; ICONST_5
587               ((<= -128 n 127)
588                (inst 16 (logand n #xff))) ; BIPUSH
589               (t ; SIPUSH
590                (inst 17 (u2 n))))))
591      (18 ; LDC
592       (unless (= (length args) 1)
593         (error "wrong number of args for LDC"))
594       (if (> (car args) 255)
595           (inst 19 (u2 (car args))) ; LDC_W
596           (inst opcode args)))
597      (t
598       (error "RESOLVE-ARGS unsupported opcode ~D" opcode)))))
599
600;; CODE is a list of INSTRUCTIONs.
601(defun resolve-opcodes (code)
602  (map 'vector #'resolve-args code))
603
604;; CODE is a list of INSTRUCTIONs.
605(defun code-bytes (code)
606  (setf code (coerce code 'vector))
607  (setf code (nreverse code))
608
609  (dotimes (i (length code))
610    (let ((instruction (svref code i)))
611      (when (and (< i (1- (length code)))
612                 (= (instruction-opcode instruction) 167) ; GOTO
613        (let ((next-instruction (svref code (1+ i))))
614          (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
615                     (eq (car (instruction-args instruction))
616                         (car (instruction-args next-instruction))))
617            (setf (instruction-opcode instruction) 'nop)))))))
618
619  (setf code (delete 'nop code :key #'instruction-opcode))
620;;   (setf code (coerce code 'list))
621
622  (let ((code (resolve-opcodes code))
623        (length 0))
624    ;; Pass 1: calculate label offsets and overall length.
625    (dotimes (i (length code))
626      (let* ((instruction (aref code i))
627             (opcode (instruction-opcode instruction)))
628        (if (= opcode 202) ; LABEL
629            (let ((label (car (instruction-args instruction))))
630              (set label length))
631            (incf length (opcode-size opcode)))))
632    ;; Pass 2: replace labels with calculated offsets.
633    (let ((index 0))
634      (dotimes (i (length code))
635        (let ((instruction (aref code i)))
636          (case (instruction-opcode instruction)
637            ((153 ; IFEQ
638              154 ; IFNE
639              166 ; IF_ACMPNE
640              165 ; IF_ACMPEQ
641              167 ; GOTO
642              )
643             (let* ((label (car (instruction-args instruction)))
644                    (offset (- (symbol-value `,label) index)))
645               (setf (instruction-args instruction) (u2 offset)))))
646          (unless (= (instruction-opcode instruction) 202) ; LABEL
647            (incf index (opcode-size (instruction-opcode instruction)))))))
648    ;; FIXME Do stack analysis here!
649    ;; Convert list to vector.
650    (let ((vector (make-array length))
651          (index 0))
652      (dotimes (i (length code))
653        (let ((instruction (aref code i)))
654          (unless (= (instruction-opcode instruction) 202) ; LABEL
655            (setf (svref vector index) (instruction-opcode instruction))
656            (incf index)
657            (dolist (byte (instruction-args instruction))
658              (setf (svref vector index) byte)
659              (incf index)))))
660      vector)))
661
662(defun write-u1 (n)
663  (write-byte (logand n #xFF) *stream*))
664
665(defun write-u2 (n)
666  (write-byte (ash n -8) *stream*)
667  (write-byte (logand n #xFF) *stream*))
668
669(defun write-u4 (n)
670  (write-u2 (ash n -16))
671  (write-u2 (logand n #xFFFF)))
672
673(defun write-utf8 (string)
674  (dotimes (i (length string))
675    (write-u1 (char-int (char string i)))))
676
677(defun write-cp-entry (entry)
678  (write-u1 (first entry))
679  (case (first entry)
680    (1
681     (write-u2 (second entry))
682     (write-utf8 (third entry)))
683    ((5 6)
684     (write-u4 (second entry))
685     (write-u4 (third entry)))
686    ((9 10 11 12)
687     (write-u2 (second entry))
688     (write-u2 (third entry)))
689    ((7 8)
690     (write-u2 (second entry)))
691    (t
692     (error "WRITE-CP-ENTRY unhandled tag ~D~%" (car entry)))
693  ))
694
695(defun write-pool ()
696  (write-u2 *pool-count*)
697  (dolist (entry (reverse *pool*))
698    (write-cp-entry entry)))
699
700(defstruct field
701  access-flags
702  name
703  descriptor
704  name-index
705  descriptor-index)
706
707(defstruct method
708  access-flags
709  name
710  descriptor
711  name-index
712  descriptor-index
713  max-stack
714  max-locals
715  code)
716
717(defun make-constructor (super name args body)
718  (let* ((constructor (make-method :name "<init>"
719                                   :descriptor "()V"))
720         (*code* ()))
721    (setf (method-name-index constructor) (pool-name (method-name constructor)))
722    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
723    (setf (method-max-locals constructor) 1)
724    (cond (*hairy-arglist-p*
725           (emit 'aload_0) ;; this
726           (emit 'aconst_null) ;; name
727           (let ((s (format nil "~S" args)))
728             (emit 'ldc
729                   (pool-string s))
730             (emit 'invokestatic
731                   "org/armedbear/lisp/Lisp"
732                   "readObjectFromString"
733                   "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"))
734           (emit-push-nil) ;; body
735           (emit 'aconst_null) ;; environment
736           (emit 'invokespecial
737                 super
738                 "<init>"
739                 "(Ljava/lang/String;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"))
740          (t
741           (emit 'aload_0)
742           (emit 'invokespecial
743                 super
744                 "<init>"
745                 "()V")))
746    (setq *code* (append *static-code* *code*))
747    (emit 'return)
748    (setf (method-code constructor) (code-bytes *code*))
749    constructor))
750
751(defun write-code-attr (method)
752  (let* ((name-index (pool-name "Code"))
753         (code (method-code method))
754         (code-length (length code))
755         (length (+ code-length 12))
756         (max-stack (or (method-max-stack method) 20))
757         (max-locals (or (method-max-locals method) 1)))
758    (write-u2 name-index)
759    (write-u4 length)
760    (write-u2 max-stack)
761    (write-u2 max-locals)
762    (write-u4 code-length)
763    (dotimes (i code-length)
764      (write-u1 (svref code i)))
765    (write-u2 0) ; exception table length
766    (write-u2 0) ; attributes count
767    ))
768
769(defun write-method (method)
770  (write-u2 (or (method-access-flags method) #x1)) ; access flags
771  (write-u2 (method-name-index method))
772  (write-u2 (method-descriptor-index method))
773  (write-u2 1) ; attributes count
774  (write-code-attr method))
775
776(defun write-field (field)
777  (write-u2 (or (field-access-flags field) #x1)) ; access flags
778  (write-u2 (field-name-index field))
779  (write-u2 (field-descriptor-index field))
780  (write-u2 0)) ; attributes count
781
782(defun declare-field (name descriptor)
783  (let ((field (make-field :name name :descriptor descriptor)))
784    (setf (field-access-flags field) (logior #x8 #x2)) ; private static
785    (setf (field-name-index field) (pool-name (field-name field)))
786    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
787    (setq *fields* (cons field *fields*))))
788
789(defun sanitize (symbol)
790  (let* ((input (symbol-name symbol))
791         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
792    (dotimes (i (length input))
793      (let ((c (char-upcase (char input i))))
794        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
795               (vector-push c output))
796              ((eql c #\-)
797               (vector-push #\_ output)))))
798    (when (plusp (length output))
799      output)))
800
801(defvar *declared-symbols* ())
802(defvar *declared-functions* ())
803
804(defun declare-symbol (symbol)
805  (let ((g (gethash symbol *declared-symbols*)))
806    (unless g
807      (let ((*code* *static-code*)
808            (s (sanitize symbol)))
809        (setq g (symbol-name (gensym)))
810        (when s
811          (setq g (concatenate 'string g "_" s)))
812        (declare-field g "Lorg/armedbear/lisp/Symbol;")
813        (emit 'ldc
814              (pool-string (symbol-name symbol)))
815        (emit 'ldc
816              (pool-string (package-name (symbol-package symbol))))
817        (emit 'invokestatic
818              +lisp-class+
819              "internInPackage"
820              "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;")
821        (emit 'putstatic
822              *this-class*
823              g
824              "Lorg/armedbear/lisp/Symbol;")
825        (setq *static-code* *code*)
826        (setf (gethash symbol *declared-symbols*) g)))
827    g))
828
829(defun declare-function (symbol)
830  (let ((f (gethash symbol *declared-functions*)))
831    (unless f
832      (setf f (symbol-name (gensym)))
833      (let ((s (sanitize symbol)))
834        (when s
835          (setf f (concatenate 'string f "_" s))))
836      (let ((*code* *static-code*)
837            (g (gethash symbol *declared-symbols*)))
838        (cond (g
839               (emit 'getstatic
840                     *this-class*
841                     g
842                     "Lorg/armedbear/lisp/Symbol;"))
843              (t
844               (emit 'ldc
845                     (pool-string (symbol-name symbol)))
846               (emit 'ldc
847                     (pool-string (package-name (symbol-package symbol))))
848               (emit 'invokestatic
849                     +lisp-class+
850                     "internInPackage"
851                     "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;")))
852        (declare-field f "Lorg/armedbear/lisp/LispObject;")
853        (emit 'invokevirtual
854              "org/armedbear/lisp/Symbol"
855              "getSymbolFunctionOrDie"
856              "()Lorg/armedbear/lisp/LispObject;")
857        (emit 'putstatic
858              *this-class*
859              f
860              "Lorg/armedbear/lisp/LispObject;")
861        (setq *static-code* *code*)
862        (setf (gethash symbol *declared-functions*) f)))
863    f))
864
865(defun declare-keyword (symbol)
866  (let ((g (symbol-name (gensym)))
867        (*code* *static-code*))
868    (declare-field g "Lorg/armedbear/lisp/Symbol;")
869    (emit 'ldc
870          (pool-string (symbol-name symbol)))
871    (emit 'invokestatic
872          "org/armedbear/lisp/Keyword"
873          "internKeyword"
874          "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;")
875    (emit 'putstatic
876          *this-class*
877          g
878          "Lorg/armedbear/lisp/Symbol;")
879    (setq *static-code* *code*)
880    g))
881
882(defun declare-object-as-string (obj)
883  (let ((g (symbol-name (gensym)))
884        (s (format nil "~S" obj))
885        (*code* *static-code*))
886    (declare-field g +lisp-object+)
887    (emit 'ldc
888          (pool-string s))
889    (emit 'invokestatic
890          "org/armedbear/lisp/Lisp"
891          "readObjectFromString"
892          "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;")
893    (emit 'putstatic
894          *this-class*
895          g
896          +lisp-object+)
897    (setq *static-code* *code*)
898    g))
899
900(defun declare-object (obj)
901  (let ((key (symbol-name (gensym))))
902    (sys::remember key obj)
903    (let* ((g1 (declare-string key))
904           (g2 (symbol-name (gensym)))
905           (*code* *static-code*))
906      (declare-field g2 +lisp-object+)
907      (emit 'getstatic
908            *this-class*
909            g1
910            +lisp-string+)
911      (emit 'dup)
912      (emit 'invokestatic
913            +lisp-class+
914            "recall"
915            "(Lorg/armedbear/lisp/LispString;)Lorg/armedbear/lisp/LispObject;")
916      (emit 'putstatic
917            *this-class*
918            g2
919            +lisp-object+)
920      (emit 'invokestatic
921            +lisp-class+
922            "forget"
923            "(Lorg/armedbear/lisp/LispString;)V")
924      (setq *static-code* *code*)
925      g2)))
926
927(defun declare-string (string)
928  (let ((g (symbol-name (gensym)))
929        (*code* *static-code*))
930    (declare-field g "Lorg/armedbear/lisp/LispString;")
931    (emit 'ldc
932          (pool-string string))
933    (emit 'invokestatic
934          "org/armedbear/lisp/LispString"
935          "getInstance"
936          "(Ljava/lang/String;)Lorg/armedbear/lisp/LispString;")
937    (emit 'putstatic
938          *this-class*
939          g
940          +lisp-string+)
941    (setq *static-code* *code*)
942    g))
943
944(defun compile-constant (form)
945  (cond
946   ((sys::fixnump form)
947    (let ((n form))
948      (cond ((zerop n)
949             (emit 'getstatic
950                   "org/armedbear/lisp/Fixnum"
951                   "ZERO"
952                   "Lorg/armedbear/lisp/Fixnum;")
953             (emit-store-value))
954            ((= n 1)
955             (emit 'getstatic
956                   "org/armedbear/lisp/Fixnum"
957                   "ONE"
958                   "Lorg/armedbear/lisp/Fixnum;")
959             (emit-store-value))
960            ((= n 2)
961             (emit 'getstatic
962                   "org/armedbear/lisp/Fixnum"
963                   "TWO"
964                   "Lorg/armedbear/lisp/Fixnum;")
965             (emit-store-value))
966            (t
967             (let ((g (declare-object-as-string n)))
968               (emit 'getstatic
969                     *this-class*
970                     g
971                     "Lorg/armedbear/lisp/LispObject;")
972               (emit-store-value))))))
973   ((numberp form)
974    (let ((g (declare-object-as-string form)))
975      (emit 'getstatic
976            *this-class*
977            g
978            "Lorg/armedbear/lisp/LispObject;")
979      (emit-store-value)))
980   ((vectorp form)
981    (let ((g (declare-object-as-string form)))
982      (emit 'getstatic
983            *this-class*
984            g
985            "Lorg/armedbear/lisp/LispObject;")
986      (emit-store-value)))
987   ((stringp form)
988    (let ((g (declare-string form)))
989      (emit 'getstatic
990            *this-class*
991            g
992            "Lorg/armedbear/lisp/LispString;")
993      (emit-store-value)))
994   ((characterp form)
995    (let ((g (declare-object-as-string form)))
996      (emit 'getstatic
997            *this-class*
998            g
999            "Lorg/armedbear/lisp/LispObject;")
1000      (emit-store-value)))
1001   ((symbolp form)
1002    (when (null (symbol-package form))
1003      ;; An uninterned symbol.
1004      (let ((g (declare-object form)))
1005        (emit 'getstatic
1006              *this-class*
1007              g
1008              "Lorg/armedbear/lisp/LispObject;")
1009        (emit-store-value))))
1010   (t
1011    (error "COMPILE-CONSTANT unhandled case ~S" form))))
1012
1013(defun compile-binary-operation (op args)
1014  (compile-form (first args))
1015  (unless (remove-store-value)
1016    (emit-push-value))
1017  (compile-form (second args))
1018  (unless (remove-store-value)
1019    (emit-push-value))
1020  (emit 'invokevirtual
1021        "org/armedbear/lisp/LispObject"
1022        op
1023        "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
1024  (emit-store-value))
1025
1026(defparameter unary-operators (make-hash-table))
1027
1028(setf (gethash '1+              unary-operators) "incr")
1029(setf (gethash '1-              unary-operators) "decr")
1030(setf (gethash 'ATOM            unary-operators) "ATOM")
1031(setf (gethash 'BIT-VECTOR-P    unary-operators) "BIT_VECTOR_P")
1032(setf (gethash 'CADR            unary-operators) "cadr")
1033(setf (gethash 'CAR             unary-operators) "car")
1034(setf (gethash 'CDDR            unary-operators) "cddr")
1035(setf (gethash 'CDR             unary-operators) "cdr")
1036(setf (gethash 'COMPLEXP        unary-operators) "COMPLEXP")
1037(setf (gethash 'CONSTANTP       unary-operators) "CONSTANTP")
1038(setf (gethash 'DENOMINATOR     unary-operators) "DENOMINATOR")
1039(setf (gethash 'ENDP            unary-operators) "ENDP")
1040(setf (gethash 'EVENP           unary-operators) "EVENP")
1041(setf (gethash 'FIRST           unary-operators) "car")
1042(setf (gethash 'FLOATP          unary-operators) "FLOATP")
1043(setf (gethash 'INTEGERP        unary-operators) "INTEGERP")
1044(setf (gethash 'LENGTH          unary-operators) "LENGTH")
1045(setf (gethash 'LISTP           unary-operators) "LISTP")
1046(setf (gethash 'MINUSP          unary-operators) "MINUSP")
1047(setf (gethash 'NOT             unary-operators) "NOT")
1048(setf (gethash 'NULL            unary-operators) "NOT")
1049(setf (gethash 'NUMBERP         unary-operators) "NUMBERP")
1050(setf (gethash 'NUMERATOR       unary-operators) "NUMERATOR")
1051(setf (gethash 'ODDP            unary-operators) "ODDP")
1052(setf (gethash 'PLUSP           unary-operators) "PLUSP")
1053(setf (gethash 'RATIONALP       unary-operators) "RATIONALP")
1054(setf (gethash 'REALP           unary-operators) "REALP")
1055(setf (gethash 'REST            unary-operators) "cdr")
1056(setf (gethash 'SECOND          unary-operators) "cadr")
1057(setf (gethash 'SIMPLE-STRING-P unary-operators) "SIMPLE_STRING_P")
1058(setf (gethash 'STRINGP         unary-operators) "STRINGP")
1059(setf (gethash 'SYMBOLP         unary-operators) "SYMBOLP")
1060(setf (gethash 'VECTORP         unary-operators) "VECTORP")
1061(setf (gethash 'ZEROP           unary-operators) "ZEROP")
1062
1063
1064(defun compile-function-call-1 (fun args)
1065  (let ((s (gethash fun unary-operators)))
1066    (when s
1067      (compile-form (first args))
1068      (emit-invoke-method s)
1069      (return-from compile-function-call-1 t)))
1070    nil)
1071
1072(defun compile-function-call-2 (fun args)
1073  (case fun
1074    (EQ
1075     (compile-form (first args))
1076     (unless (remove-store-value)
1077       (emit-push-value))
1078     (compile-form (second args))
1079     (unless (remove-store-value)
1080       (emit-push-value))
1081     (let ((label1 (gensym))
1082           (label2 (gensym)))
1083       (emit 'if_acmpeq `,label1)
1084       (emit-push-nil)
1085       (emit 'goto `,label2)
1086       (emit 'label `,label1)
1087       (emit-push-t)
1088       (emit 'label `,label2))
1089     (emit-store-value)
1090     t)
1091    (EQL
1092     (compile-binary-operation "EQL" args)
1093     t)
1094    (+
1095     (compile-binary-operation "add" args)
1096     t)
1097    (-
1098     (compile-binary-operation "subtract" args)
1099     t)
1100    (/
1101     (compile-binary-operation "divideBy" args)
1102     t)
1103    (*
1104     (compile-binary-operation "multiplyBy" args)
1105     t)
1106    (<
1107     (compile-binary-operation "IS_LT" args)
1108     t)
1109    (<=
1110     (compile-binary-operation "IS_LE" args)
1111     t)
1112    (>
1113     (compile-binary-operation "IS_GT" args)
1114     t)
1115    (>=
1116     (compile-binary-operation "IS_GE" args)
1117     t)
1118    (=
1119     (compile-binary-operation "IS_E" args)
1120     t)
1121    (/=
1122     (compile-binary-operation "IS_NE" args)
1123     t)
1124    (AREF
1125     (compile-binary-operation "AREF" args)
1126     t)
1127    (LIST
1128     (compile-form (first args))
1129     (unless (remove-store-value)
1130       (emit-push-value))
1131     (compile-form (second args))
1132     (unless (remove-store-value)
1133       (emit-push-value))
1134     (emit 'invokestatic
1135           +lisp-class+
1136           "list2"
1137           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;")
1138     (emit-store-value)
1139     t)
1140    (SYS::SIMPLE-TYPEP
1141     (compile-binary-operation "typep" args))
1142    (t
1143     nil)))
1144
1145(defun compile-function-call-3 (fun args)
1146  (case fun
1147    (LIST
1148     (compile-form (first args))
1149     (unless (remove-store-value)
1150       (emit-push-value))
1151     (compile-form (second args))
1152     (unless (remove-store-value)
1153       (emit-push-value))
1154     (compile-form (third args))
1155     (unless (remove-store-value)
1156       (emit-push-value))
1157     (emit 'invokestatic
1158           +lisp-class+
1159           "list3"
1160           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;")
1161     (emit-store-value)
1162     t)
1163    (t
1164     nil)))
1165
1166(defconstant +cl-package+ (find-package "COMMON-LISP"))
1167(defconstant +sys-package+ (find-package "SYSTEM"))
1168
1169(defun compile-function-call (fun args &optional for-effect)
1170;;   (format t "compile-function-call fun = ~S args = ~S~%" fun args)
1171  (unless (symbolp fun)
1172    (error "COMPILE-FUNCTION-CALL ~S is not a symbol" fun))
1173  (let ((numargs (length args)))
1174    (cond ((= numargs 1)
1175           (when (compile-function-call-1 fun args)
1176             (return-from compile-function-call)))
1177          ((= numargs 2)
1178           (when (compile-function-call-2 fun args)
1179             (return-from compile-function-call)))
1180          ((= numargs 3)
1181           (when (compile-function-call-3 fun args)
1182             (return-from compile-function-call))))
1183
1184    ;; FIXME This shouldn't go here! Do this in the constructor of the
1185    ;; compiled function!
1186    (sys::resolve fun)
1187
1188    (cond
1189     ((eq fun *defun-name*)
1190      (emit 'aload 0)) ; this
1191     ((memq (symbol-package fun) '(+cl-package+ +sys-package+))
1192      (let ((f (declare-function fun)))
1193        (emit 'getstatic
1194              *this-class*
1195              f
1196              "Lorg/armedbear/lisp/LispObject;")))
1197     (t
1198      (let ((g (declare-symbol fun)))
1199        (emit 'getstatic
1200              *this-class*
1201              g
1202              "Lorg/armedbear/lisp/Symbol;"))
1203      (emit 'invokevirtual
1204            "org/armedbear/lisp/Symbol"
1205            "getSymbolFunctionOrDie"
1206            "()Lorg/armedbear/lisp/LispObject;")))
1207    (case numargs
1208      (0
1209       (emit 'invokevirtual
1210             "org/armedbear/lisp/LispObject"
1211             "execute"
1212             "()Lorg/armedbear/lisp/LispObject;"))
1213      (1
1214       (compile-form (first args))
1215       (unless (remove-store-value)
1216         (emit-push-value))
1217       (emit 'invokevirtual
1218             "org/armedbear/lisp/LispObject"
1219             "execute"
1220             "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
1221      (2
1222       (compile-form (first args))
1223       (unless (remove-store-value)
1224         (emit-push-value))
1225       (compile-form (second args))
1226       (unless (remove-store-value)
1227         (emit-push-value))
1228       (emit 'invokevirtual
1229             "org/armedbear/lisp/LispObject"
1230             "execute"
1231             "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
1232      (3
1233       (compile-form (first args))
1234       (unless (remove-store-value)
1235         (emit-push-value))
1236       (compile-form (second args))
1237       (unless (remove-store-value)
1238         (emit-push-value))
1239       (compile-form (third args))
1240       (unless (remove-store-value)
1241         (emit-push-value))
1242       (emit 'invokevirtual
1243             "org/armedbear/lisp/LispObject"
1244             "execute"
1245             "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))
1246      (t
1247       (emit 'sipush (length args))
1248       (emit 'anewarray "org/armedbear/lisp/LispObject")
1249       (let ((i 0))
1250         (dolist (form args)
1251           (emit 'dup)
1252           (emit 'sipush i)
1253           (compile-form form)
1254           (unless (remove-store-value)
1255             (emit-push-value)) ; leaves value on stack
1256           (emit 'aastore) ; store value in array
1257           (incf i))) ; array left on stack here
1258       ;; Stack: function array-ref
1259       (emit 'invokevirtual
1260             "org/armedbear/lisp/LispObject"
1261             "execute"
1262             "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
1263    (if for-effect
1264        (emit 'pop)
1265        (emit-store-value))))
1266
1267(defun compile-test (form)
1268  ;; Use a Java boolean if possible.
1269  (when (consp form)
1270    (case (length form)
1271      (2 (when (memq (car form) '(NOT NULL))
1272           (compile-form (second form))
1273           (unless (remove-store-value)
1274             (emit-push-value))
1275           (emit-push-nil)
1276           (return-from compile-test 'if_acmpne))
1277         (let ((s (cdr (assoc (car form)
1278                              '((ATOM      . "atom")
1279                                (EVENP     . "evenp")
1280                                (FLOATP    . "floatp")
1281                                (INTEGERP  . "integerp")
1282                                (MINUSP    . "minusp")
1283                                (LISTP     . "listp")
1284                                (NUMBERP   . "numberp")
1285                                (ODDP      . "oddp")
1286                                (PLUSP     . "plusp")
1287                                (RATIONALP . "rationalp")
1288                                (REALP     . "realp")
1289                                (VECTORP   . "vectorp")
1290                                (ZEROP     . "zerop")
1291                                )))))
1292           (when s
1293             (compile-form (second form))
1294             (unless (remove-store-value)
1295               (emit-push-value))
1296             (emit 'invokevirtual
1297                   +lisp-object-class+
1298                   s
1299                   "()Z")
1300             (return-from compile-test 'ifeq))))
1301      (3 (when (eq (car form) 'EQ)
1302           (compile-form (second form))
1303           (unless (remove-store-value)
1304             (emit-push-value))
1305           (compile-form (third form))
1306           (unless (remove-store-value)
1307             (emit-push-value))
1308           (return-from compile-test 'if_acmpne))
1309         (let ((s (cdr (assoc (car form)
1310                              '((=      . "isEqualTo")
1311                                (/=     . "isNotEqualTo")
1312                                (<      . "isLessThan")
1313                                (<=     . "isLessThanOrEqualTo")
1314                                (>      . "isGreaterThan")
1315                                (>=     . "isGreaterThanOrEqualTo")
1316                                (EQL    . "eql")
1317                                (EQUAL  . "equal")
1318                                (EQUALP . "equalp")
1319                                )))))
1320           (when s
1321             (compile-form (second form))
1322             (unless (remove-store-value)
1323               (emit-push-value))
1324             (compile-form (third form))
1325             (unless (remove-store-value)
1326               (emit-push-value))
1327             (emit 'invokevirtual
1328                   +lisp-object-class+
1329                   s
1330                   "(Lorg/armedbear/lisp/LispObject;)Z")
1331             (return-from compile-test 'ifeq))))))
1332  ;; Otherwise...
1333  (compile-form form)
1334  (unless (remove-store-value)
1335    (emit-push-value))
1336  (emit-push-nil)
1337  'if_acmpeq)
1338
1339(defun compile-if (form)
1340  (let* ((test (second form))
1341         (consequent (third form))
1342         (alternate (fourth form))
1343         (label1 (gensym))
1344         (label2 (gensym))
1345         (instr (compile-test test)))
1346    (emit-clear-values)
1347    (emit instr `,label1)
1348    (compile-form consequent)
1349    (emit 'goto `,label2)
1350    (emit 'label `,label1)
1351    (compile-form alternate)
1352    (emit 'label `,label2)))
1353
1354(defun compile-multiple-value-list (form)
1355  (compile-form (second form))
1356  (unless (remove-store-value)
1357    (emit-push-value))
1358  (emit 'invokestatic
1359        "org/armedbear/lisp/Lisp"
1360        "multipleValueList"
1361        "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
1362  (emit-store-value))
1363
1364(defun compile-let/let* (form)
1365  (let* ((saved-fp (fill-pointer *locals*))
1366         (varlist (second form))
1367         (specialp nil)
1368         thread-var env-var)
1369    ;; Are we going to bind any special variables?
1370    (dolist (varspec varlist)
1371      (let ((var (if (consp varspec) (car varspec) varspec)))
1372        (when (special-variable-p var)
1373          (setq specialp t)
1374          (return))))
1375    ;; If so...
1376    (when specialp
1377      ;; Save current thread in a local variable.
1378      (setq thread-var (vector-push nil *locals*))
1379      (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1380      (emit 'invokestatic
1381            +lisp-thread-class+
1382            "currentThread"
1383            "()Lorg/armedbear/lisp/LispThread;")
1384      (emit 'astore thread-var)
1385      ;; Save current dynamic environment.
1386      (setq env-var (vector-push nil *locals*))
1387      (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1388      (emit 'aload thread-var)
1389      (emit 'invokevirtual
1390            +lisp-thread-class+
1391            "getDynamicEnvironment"
1392            "()Lorg/armedbear/lisp/Environment;")
1393      (emit 'astore env-var))
1394    (ecase (car form)
1395      (LET
1396       (compile-let-vars varlist))
1397      (LET*
1398       (compile-let*-vars varlist)))
1399    ;; Body of LET.
1400    (do ((body (cddr form) (cdr body)))
1401        ((null (cdr body))
1402         (compile-form (car body) nil))
1403      (compile-form (car body) t))
1404    (when specialp
1405      ;; Restore dynamic environment.
1406      (emit 'aload thread-var)
1407      (emit 'aload env-var)
1408      (emit 'invokevirtual
1409            +lisp-thread-class+
1410            "setDynamicEnvironment"
1411            "(Lorg/armedbear/lisp/Environment;)V"))
1412    ;; Restore fill pointer to its saved value so the slots used by these
1413    ;; bindings will again be available.
1414    (setf (fill-pointer *locals*) saved-fp)))
1415
1416(defun compile-let-vars (varlist)
1417  ;; Generate code to evaluate the initforms and leave the resulting values
1418  ;; on the stack.
1419  (dolist (varspec varlist)
1420    (let (var initform)
1421      (cond ((consp varspec)
1422             (setq var (car varspec)
1423                   initform (cadr varspec)))
1424            (t
1425             (setq var varspec
1426                   initform nil)))
1427      (cond (initform
1428             (compile-form initform)
1429             (emit-push-value))
1430            (t
1431             (emit-push-nil)))))
1432  ;; Add local variables to local variables vector.
1433  (dolist (varspec varlist)
1434    (let ((var (if (consp varspec) (car varspec) varspec)))
1435      (unless (special-variable-p var)
1436        (vector-push var *locals*))))
1437  (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1438  ;; At this point the initial values are on the stack. Now generate code to
1439  ;; pop them off one by one and store each one in the corresponding local or
1440  ;; special variable. In order to do this, we must process the variable list
1441  ;; in reverse order.
1442  (do* ((varlist (reverse varlist) (cdr varlist))
1443        (varspec (car varlist) (car varlist))
1444        (var (if (consp varspec) (car varspec) varspec))
1445        (i (1- (fill-pointer *locals*)) (1- i)))
1446       ((null varlist))
1447    (cond ((special-variable-p var)
1448           (let ((g (declare-symbol var)))
1449             (emit 'getstatic
1450                   *this-class*
1451                   g
1452                   "Lorg/armedbear/lisp/Symbol;")
1453             (emit 'swap)
1454             (emit 'invokestatic
1455                   "org/armedbear/lisp/Lisp"
1456                   "bindSpecialVariable"
1457                   "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V")))
1458          (t
1459           (emit 'astore i)))))
1460
1461(defun compile-let*-vars (varlist)
1462  ;; Generate code to evaluate initforms and bind variables.
1463  (let ((i (fill-pointer *locals*)))
1464    (dolist (varspec varlist)
1465      (let (var initform)
1466        (cond ((consp varspec)
1467               (setq var (car varspec)
1468                     initform (cadr varspec)))
1469              (t
1470               (setq var varspec
1471                     initform nil)))
1472        (cond (initform
1473               (compile-form initform)
1474               (emit-push-value))
1475              (t
1476               (emit-push-nil)))
1477        (cond ((special-variable-p var)
1478               (let ((g (declare-symbol var)))
1479                 (emit 'getstatic
1480                       *this-class*
1481                       g
1482                       "Lorg/armedbear/lisp/Symbol;")
1483                 (emit 'swap)
1484                 (emit 'invokestatic
1485                       "org/armedbear/lisp/Lisp"
1486                       "bindSpecialVariable"
1487                       "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V")))
1488              (t
1489               (emit 'astore i)
1490               (vector-push var *locals*)
1491               (incf i))))))
1492  (setq *max-locals* (max *max-locals* (fill-pointer *locals*))))
1493
1494(defvar *tags* ())
1495
1496(defstruct tag name label)
1497
1498(defun label-for-tag (name)
1499  (let ((index (position name *tags* :from-end t :key #'tag-name)))
1500;;     (format t "find-tag index = ~S~%" index)
1501    (when index
1502      (tag-label (aref *tags* index)))))
1503
1504(defun compile-tagbody (form)
1505  (let ((saved-fp (fill-pointer *tags*))
1506        (body (cdr form)))
1507    ;; Scan for tags.
1508    (dolist (f body)
1509      (when (atom f)
1510        (let ((name f)
1511              (label (gensym)))
1512          (vector-push (make-tag :name name :label label) *tags*))))
1513    (dolist (f body)
1514      (cond ((atom f)
1515             (let ((label (label-for-tag f)))
1516               (unless label
1517                 (error "COMPILE-TAGBODY: tag not found: ~S" f))
1518               (emit 'label label)))
1519            (t
1520             (compile-form f t))))
1521    (setf (fill-pointer *tags*) saved-fp))
1522  ;; TAGBODY returns NIL.
1523  (emit-push-nil)
1524  (emit-store-value))
1525
1526(defun compile-go (form)
1527  (let* ((name (cadr form))
1528         (label (label-for-tag name)))
1529    (unless label
1530      (error "COMPILE-GO: tag not found: ~S" name))
1531  (emit 'goto label)))
1532
1533(defun compile-block (form)
1534   (let* ((rest (cdr form))
1535          (block-label (car rest))
1536          (block-exit (gensym))
1537          (*blocks* (acons block-label block-exit *blocks*))
1538          (forms (cdr rest)))
1539     (dolist (form forms)
1540       (compile-form form))
1541     (emit 'label `,block-exit)))
1542
1543(defun compile-progn (form)
1544  (dolist (form (cdr form))
1545    (compile-form form)))
1546
1547(defun compile-setq (form)
1548  (let* ((rest (cdr form))
1549         (len (length rest))
1550         (sym (car rest))
1551         (index (position sym *locals* :from-end t)))
1552    (unless (= len 2)
1553      (error "COMPILE-SETQ too many args for SETQ"))
1554    (when index
1555      (compile-form (cadr rest))
1556      (emit-push-value)
1557      (emit 'astore index)
1558      (return-from compile-setq))
1559    ;; index is NIL, look in *args* ...
1560    (setq index (position sym *args*))
1561    (when index
1562      (cond (*using-arg-array*
1563             (emit 'aload 1)
1564             (emit 'bipush index)
1565             (compile-form (cadr rest))
1566             (emit-push-value)
1567             (emit 'aastore))
1568            (t
1569             (compile-form (cadr rest))
1570             (emit-push-value)
1571             (emit 'astore (1+ index))))
1572      (return-from compile-setq))
1573    ;; still not found
1574    ;; must be a global variable
1575    (let ((g (declare-symbol sym)))
1576      (emit 'getstatic
1577            *this-class*
1578            g
1579            "Lorg/armedbear/lisp/Symbol;")
1580      (compile-form (cadr rest))
1581      (unless (remove-store-value)
1582        (emit-push-value))
1583      (emit 'invokestatic
1584            +lisp-class+
1585            "setSpecialVariable"
1586            "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
1587      (emit-store-value))))
1588
1589(defun compile-quote (form)
1590   (let ((obj (second form)))
1591     (cond ((null obj)
1592            (emit-push-nil)
1593            (emit-store-value))
1594           ((symbolp obj)
1595            (if (symbol-package obj)
1596                (let ((g (declare-symbol obj)))
1597                  (emit 'getstatic
1598                        *this-class*
1599                        g
1600                        "Lorg/armedbear/lisp/Symbol;")
1601                  (emit-store-value))
1602                (compile-constant obj)))
1603           ((listp obj)
1604            (let ((g (declare-object-as-string obj)))
1605              (emit 'getstatic
1606                    *this-class*
1607                    g
1608                    +lisp-object+)
1609              (emit-store-value)))
1610           ((constantp obj)
1611            (compile-constant obj))
1612           (t
1613            (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
1614
1615(defun compile-function (form)
1616   (let ((obj (second form)))
1617     (cond ((symbolp obj)
1618            (let ((g (declare-symbol obj)))
1619              (emit 'getstatic
1620                    *this-class*
1621                    g
1622                    "Lorg/armedbear/lisp/Symbol;")
1623              (emit 'invokevirtual
1624                    +lisp-object-class+
1625                    "getSymbolFunctionOrDie"
1626                    "()Lorg/armedbear/lisp/LispObject;")
1627              (emit-store-value)))
1628           #+nil
1629           ((and (consp obj) (eq (car obj) 'LAMBDA))
1630            ;; FIXME We need to construct a proper lexical environment here
1631            ;; and pass it to coerceToFunction().
1632            (let ((g (declare-object-as-string obj)))
1633              (emit 'getstatic
1634                    *this-class*
1635                    g
1636                    +lisp-object+)
1637              (emit 'invokestatic
1638                    +lisp-class+
1639                    "coerceToFunction"
1640                    "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Function;")
1641              (emit-store-value)))
1642           (t
1643            (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
1644
1645(defun compile-return (form)
1646   (let* ((rest (cdr form))
1647          (block-label nil)
1648          (block-exit (cdr (assoc block-label *blocks*)))
1649          (result-form (car rest)))
1650     (unless block-exit
1651       (error "no block named ~S is currently visible" block-label))
1652     (compile-form result-form)
1653     (emit 'goto `,block-exit)))
1654
1655(defun compile-return-from (form)
1656   (let* ((rest (cdr form))
1657          (block-label (car rest))
1658          (block-exit (cdr (assoc block-label *blocks*)))
1659          (result-form (cadr rest)))
1660     (unless block-exit
1661       (error "no block named ~S is currently visible" block-label))
1662     (compile-form result-form)
1663     (emit 'goto `,block-exit)))
1664
1665(defun compile-plus (form)
1666  (let* ((args (cdr form))
1667         (len (length args)))
1668    (case len
1669      (2
1670       (let ((first (first args))
1671             (second (second args)))
1672         (cond
1673          ((eql first 1)
1674           (compile-form second)
1675           (emit-invoke-method "incr"))
1676          ((eql second 1)
1677           (compile-form first)
1678           (emit-invoke-method "incr"))
1679          (t
1680           (compile-binary-operation "add" args)))))
1681      (t
1682       (compile-function-call '+ args)))))
1683
1684(defun compile-minus (form)
1685  (let* ((args (cdr form))
1686         (len (length args)))
1687    (case len
1688      (2
1689       (let ((first (first args))
1690             (second (second args)))
1691         (cond
1692          ((eql second 1)
1693           (compile-form first)
1694           (emit-invoke-method "decr"))
1695          (t
1696           (compile-binary-operation "subtract" args)))))
1697      (t
1698       (compile-function-call '- args)))))
1699
1700(defun compile-variable-ref (form)
1701  (let ((index (position form *locals* :from-end t)))
1702    (when index
1703      (emit 'aload index)
1704      (emit-store-value)
1705      (return-from compile-variable-ref)))
1706  ;; Not found in locals; look in args.
1707  (let ((index (position form *args*)))
1708    (when index
1709      (cond (*using-arg-array*
1710             (emit 'aload 1)
1711             (emit 'bipush index)
1712             (emit 'aaload)
1713             (emit-store-value)
1714             (return-from compile-variable-ref))
1715            (t
1716             (emit 'aload (1+ index))
1717             (emit-store-value)
1718             (return-from compile-variable-ref)))))
1719
1720  ;; Otherwise it must be a global variable.
1721  (let ((g (declare-symbol form)))
1722    (emit 'getstatic
1723          *this-class*
1724          g
1725          "Lorg/armedbear/lisp/Symbol;")
1726    (emit 'invokevirtual
1727          "org/armedbear/lisp/Symbol"
1728          "symbolValue"
1729          "()Lorg/armedbear/lisp/LispObject;")
1730    (emit-store-value)
1731    (return-from compile-variable-ref)))
1732
1733
1734;; If for-effect is true, no value needs to be left on the stack.
1735(defun compile-form (form &optional for-effect)
1736  (cond
1737   ((consp form)
1738    (let ((first (first form))
1739          (rest (rest form)))
1740      (when (macro-function first)
1741        (compile-form (macroexpand form))
1742        (return-from compile-form))
1743      (when (symbolp first)
1744        (let ((handler (get first 'jvm-compile)))
1745          (when handler
1746            (funcall handler form)
1747            (return-from compile-form))))
1748      (cond
1749       ((special-operator-p first)
1750        (error "COMPILE-FORM unhandled special operator ~S" first))
1751       (t ; Function call.
1752        (compile-function-call first rest for-effect)))))
1753   ((eq form '())
1754    (unless for-effect
1755      (emit-push-nil)
1756      (emit-store-value)))
1757   ((eq form t)
1758    (unless for-effect
1759      (emit-push-t)
1760      (emit-store-value)))
1761   ((symbolp form)
1762    (when (keywordp form)
1763      (let ((g (declare-keyword form)))
1764        (emit 'getstatic
1765              *this-class*
1766              g
1767              "Lorg/armedbear/lisp/Symbol;"))
1768      (emit-store-value)
1769      (return-from compile-form))
1770
1771    (compile-variable-ref form))
1772   ((constantp form)
1773    (unless for-effect
1774      (compile-constant form)))
1775   (t
1776    (error "COMPILE-FORM unhandled case ~S" form))))
1777
1778;; Returns descriptor.
1779(defun analyze-args (args)
1780  (assert (not (memq '&AUX args)))
1781  (when (or (memq '&KEY args)
1782            (memq '&OPTIONAL args)
1783            (memq '&REST args))
1784    (setq *using-arg-array* t)
1785    (setq *hairy-arglist-p* t)
1786    (return-from analyze-args #.(format nil "([~A)~A" +lisp-object+ +lisp-object+)))
1787  (case (length args)
1788    (0 #.(format nil "()~A" +lisp-object+))
1789    (1 #.(format nil "(~A)~A" +lisp-object+ +lisp-object+))
1790    (2 #.(format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
1791    (3 #.(format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
1792    (t (setq *using-arg-array* t)
1793       #.(format nil "([~A)~A" +lisp-object+ +lisp-object+))))
1794
1795(defun compile-defun (name form)
1796  (unless (eq (car form) 'LAMBDA)
1797    (return-from compile-defun nil))
1798  (setq form (transform form))
1799  (let* ((*defun-name* name)
1800         (*declared-symbols* (make-hash-table))
1801         (*declared-functions* (make-hash-table))
1802         (*this-class* "org/armedbear/lisp/out")
1803         (args (cadr form))
1804         (body (cddr form))
1805         (*using-arg-array* nil)
1806         (*hairy-arglist-p* nil)
1807         (descriptor (analyze-args args))
1808         (execute-method (make-method :name "execute"
1809                                      :descriptor descriptor))
1810         (*code* ())
1811         (*static-code* ())
1812         (*fields* ())
1813         (*blocks* ())
1814         (*tags* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
1815         (*args* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
1816         (*locals* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
1817         (*max-locals* 0)
1818         (*pool* ())
1819         (*pool-count* 1)
1820         (*val* 0))
1821    (setf (method-name-index execute-method)
1822          (pool-name (method-name execute-method)))
1823    (setf (method-descriptor-index execute-method)
1824          (pool-name (method-descriptor execute-method)))
1825    (if *hairy-arglist-p*
1826        (let* ((fun (sys::make-compiled-function nil args body))
1827               (vars (sys::varlist fun)))
1828          (dolist (var vars)
1829            (vector-push var *args*)))
1830        (dolist (arg args)
1831          (vector-push arg *args*)))
1832    (if *using-arg-array*
1833        ;; Using arg array: slot 0 is "this" pointer, slot 1 is arg array,
1834        ;; first available slot is 2.
1835        (setf (fill-pointer *locals*) 2)
1836        ;; Not using arg array: slot 0 is "this" pointer, next N slots are used
1837        ;; for args.
1838        (setf (fill-pointer *locals*) (1+ (length args))))
1839    ;; Reserve the next available slot for the value register.
1840    (setq *val* (fill-pointer *locals*))
1841    (incf (fill-pointer *locals*))
1842    (setf *max-locals* (fill-pointer *locals*))
1843    (when *hairy-arglist-p*
1844      (emit 'aload_0)
1845      (emit 'aload_1)
1846      (emit 'invokevirtual
1847            *this-class*
1848            "processArgs"
1849            "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;")
1850      (emit 'astore_1))
1851    (dolist (f body)
1852      (compile-form f))
1853    (unless (remove-store-value)
1854      (emit-push-value)) ; leave result on stack
1855    (emit 'areturn)
1856    (setf (method-code execute-method) (code-bytes *code*))
1857    (setf (method-max-locals execute-method) *max-locals*)
1858
1859    (let* ((super
1860            (if *hairy-arglist-p*
1861                "org.armedbear.lisp.CompiledFunction"
1862                (case (length args)
1863                  (0 "org.armedbear.lisp.Primitive0")
1864                  (1 "org.armedbear.lisp.Primitive1")
1865                  (2 "org.armedbear.lisp.Primitive2")
1866                  (3 "org.armedbear.lisp.Primitive3")
1867                  (t "org.armedbear.lisp.Primitive"))))
1868           (this-index (pool-class *this-class*))
1869           (super-index (pool-class super))
1870           (constructor (make-constructor super *defun-name* args body)))
1871      (pool-name "Code") ; Must be in pool!
1872
1873      ;; Write class file (out.class in current directory).
1874      (with-open-file (*stream* "out.class"
1875                                :direction :output
1876                                :element-type 'unsigned-byte
1877                                :if-exists :supersede)
1878        (write-u4 #xCAFEBABE)
1879        (write-u2 3)
1880        (write-u2 45)
1881        (write-pool)
1882        ;; access flags
1883        (write-u2 #x21)
1884        (write-u2 this-index)
1885        (write-u2 super-index)
1886        ;; interfaces count
1887        (write-u2 0)
1888        ;; fields count
1889        (write-u2 (length *fields*))
1890        ;; fields
1891        (dolist (field *fields*)
1892          (write-field field))
1893        ;; methods count
1894        (write-u2 2)
1895        ;; methods
1896        (write-method execute-method)
1897        (write-method constructor)
1898        ;; attributes count
1899        (write-u2 0))))
1900  (sys::load-compiled-function "out.class"))
1901
1902(defun get-lambda-to-compile (definition-designator)
1903  (if (and (consp definition-designator)
1904           (eq (car definition-designator) 'LAMBDA))
1905      definition-designator
1906      (multiple-value-bind (lambda-expression closure-p)
1907        (function-lambda-expression definition-designator)
1908        (when closure-p
1909          (error "unable to compile function defined in non-null lexical environment"))
1910  (unless lambda-expression
1911    (error "can't find a definition"))
1912        lambda-expression)))
1913
1914(defun load-verbose-prefix ()
1915  (with-output-to-string (s)
1916    (princ #\; s)
1917    (dotimes (i (1- sys::*load-depth*))
1918      (princ #\space s))))
1919
1920(defun jvm-compile (name &optional definition)
1921  (let ((prefix (load-verbose-prefix)))
1922    (when name
1923      (format t "~A Compiling ~S ...~%" prefix name)
1924      (when (and (fboundp name) (typep (fdefinition name) 'generic-function))
1925        (format t "~A Unable to compile generic function ~S~%" prefix name)
1926        (return-from jvm-compile (values name nil t)))
1927      (unless (symbolp name)
1928        (format t "~A Unable to compile ~S~%" prefix name)
1929        (return-from jvm-compile (values name nil t))))
1930    (unless definition
1931      (sys::resolve name)
1932      (setf definition (fdefinition name))
1933      (when (compiled-function-p definition)
1934        (when name
1935          (format t "~A Already compiled ~S~%" prefix name))
1936        (return-from jvm-compile (values name nil nil))))
1937    (handler-case
1938        (let* ((*package* (if (and name (symbol-package name))
1939                              (symbol-package name)
1940                              *package*))
1941               (expr (get-lambda-to-compile definition))
1942               (compiled-definition (compile-defun name expr)))
1943          (when (and name (functionp compiled-definition))
1944            (sys::%set-lambda-name compiled-definition name)
1945            (sys::%set-call-count compiled-definition (sys::%call-count definition))
1946            (sys::%set-arglist compiled-definition (sys::arglist definition))
1947            (if (macro-function name)
1948                (setf (fdefinition name) (sys::make-macro compiled-definition))
1949                (setf (fdefinition name) compiled-definition)))
1950          (when name
1951            (format t "~A Compiled ~S~%" prefix name))
1952          (values (or name compiled-definition) nil nil))
1953      (error (c)
1954             (format t "Error: ~S~%" c)
1955             (when name (format t "~A Unable to compile ~S~%" prefix name))
1956             (values (or name (sys::coerce-to-function definition)) nil t)))))
1957
1958(defun jvm-compile-package (package-designator)
1959  (let ((pkg (if (packagep package-designator)
1960                 package-designator
1961                 (find-package package-designator))))
1962      (dolist (sym (sys::package-symbols pkg))
1963        (when (fboundp sym)
1964          (unless (or (special-operator-p sym) (macro-function sym))
1965            ;; Force autoload to be resolved.
1966            (sys::resolve sym)
1967            (let ((f (fdefinition sym)))
1968              (unless (compiled-function-p f)
1969                (jvm-compile sym)))))))
1970  t)
1971
1972(defun install-handler (fun &optional handler)
1973  (let ((handler (or handler
1974                     (find-symbol (concatenate 'string "COMPILE-" (symbol-name fun)) 'jvm))))
1975    (unless (and handler (fboundp handler))
1976      (error "no handler for ~S" fun))
1977    (setf (get fun 'jvm-compile) handler)))
1978
1979(mapc #'install-handler '(block
1980                          function
1981                          go
1982                          if
1983                          multiple-value-list
1984                          progn
1985                          quote
1986                          return
1987                          return-from
1988                          setq
1989                          tagbody))
1990
1991(install-handler 'let  'compile-let/let*)
1992(install-handler 'let* 'compile-let/let*)
1993(install-handler '+    'compile-plus)
1994(install-handler '-    'compile-minus)
1995
1996#+nil
1997(defun compile (name &optional definition)
1998  (jvm:jvm-compile name definition))
1999
2000(defmacro defun (name lambda-list &rest body)
2001  `(progn
2002     (sys::%defun ',name ',lambda-list ',body)
2003     (compiler::%compile ',name)
2004     (when *auto-compile*
2005       (jvm-compile ',name))
2006     ',name))
2007
2008(mapc #'jvm-compile '(pool-add
2009                      pool-find-entry
2010                      pool-name
2011                      pool-get
2012                      compile-form))
Note: See TracBrowser for help on using the repository browser.