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

Last change on this file since 5245 was 5245, checked in by piso, 17 years ago

Work in progress.

File size: 89.3 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: jvm.lisp,v 1.61 2003-12-23 15:24:04 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(in-package "JVM")
21
22(export '(jvm-compile jvm-compile-package))
23
24(import 'sys::%format)
25
26(shadow 'method)
27
28(defvar *debug* nil)
29
30(defvar *instructions*
31  '(nop             aconst_null  iconst_m1       iconst_0      iconst_1     ;   0
32    iconst_2        iconst_3     iconst_4        iconst_5      lconst_0     ;   5
33    lconst_1        fconst_0     fconst_1        fconst_2      dconst_0     ;  10
34    dconst_1        bipush       sipush          ldc           ldc_w        ;  15
35    ldc2_w          iload        lload           fload         dload        ;  20
36    aload           iload_0      iload_1         iload_2       iload_3      ;  25
37    lload_0         lload_1      lload_2         lload_3       fload_0      ;  30
38    fload_1         fload_2      fload_3         dload_0       dload_1      ;  35
39    dload_2         dload_3      aload_0         aload_1       aload_2      ;  40
40    aload_3         iaload       laload          faload        daload       ;  45
41    aaload          baload       caload          saload        istore       ;  50
42    lstore          fstore       dstore          astore        istore_0     ;  55
43    istore_1        istore_2     istore_3        lstore_0      lstore_1     ;  60
44    lstore_2        lstore_3     fstore_0        fstore_1      fstore_2     ;  65
45    fstore_3        dstore_0     dstore_1        dstore_2      dstore_3     ;  70
46    astore_0        astore_1     astore_2        astore_3      iastore      ;  75
47    lastore         fastore      dastore         aastore       bastore      ;  80
48    castore         sastore      pop             pop2          dup          ;  85
49    dup_x1          dup_x2       dup2            dup2_x1       dup2_x2      ;  90
50    swap            iadd         ladd            fadd          dadd         ;  95
51    isub            lsub         fsub            dsub          imul         ; 100
52    lmul            fmul         dmul            idiv          ldiv         ; 105
53    fdiv            ddiv         irem            lrem          frem         ; 110
54    drem            ineg         lneg            fneg          dneg         ; 115
55    ishl            lshl         ishr            lshr          iushr        ; 120
56    lushr           iand         land            ior           lor          ; 125
57    ixor            lxor         iinc            i2l           i2f          ; 130
58    i2d             l2i          l2f             l2d           f2i          ; 135
59    f2l             f2d          d2i             d2l           d2f          ; 140
60    i2b             i2c          i2s             lcmp          fcmpl        ; 145
61    fcmpg           dcmpl        dcmpg           ifeq          ifne         ; 150
62    iflt            ifge         ifgt            ifle          if_icmpeq    ; 155
63    if_icmpne       if_icmplt    if_icmpge       if_icmpgt     if_icmple    ; 160
64    if_acmpeq       if_acmpne    goto            jsr           ret          ; 165
65    tableswitch     lookupswitch ireturn         lreturn       freturn      ; 170
66    dreturn         areturn      return          getstatic     putstatic    ; 175
67    getfield        putfield     invokevirtual   invokespecial invokestatic ; 180
68    invokeinterface unused       new             newarray      anewarray    ; 185
69    arraylength     athrow       checkcast       instanceof    monitorenter ; 190
70    monitorexit     wide         multianewarray  ifnull        ifnonnull    ; 195
71    goto_w          jsr_w        label           push-value    store-value  ; 200
72    ))
73
74(unless (vectorp *instructions*)
75  (let* ((list *instructions*)
76         (vector (make-array (length *instructions*)))
77         (index 0))
78    (dolist (instr list)
79      (setf (get instr 'opcode) index)
80      (setf (svref vector index) instr)
81      (incf index))
82    (setq *instructions* vector)))
83
84(defun instr (opcode)
85  (svref *instructions* opcode))
86
87(defparameter *opcode-size*
88  ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9
89  '#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 3 2 3  ;; 000-019
90     3 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 020-039
91     1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 1  ;; 040-059
92     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 060-079
93     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 080-099
94     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 100-119
95     1 1 1 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1  ;; 120-139
96     1 1 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3  ;; 140-159
97     3 3 3 3 3 3 3 3 3 2 0 0 1 1 1 1 1 1 3 3  ;; 160-179
98     3 3 3 3 3 5 0 3 2 3 1 1 3 3 1 1 0 4 3 3  ;; 180-199
99     5 5 0                                    ;; 200-202
100     ))
101
102(defun opcode-size (opcode)
103  (svref *opcode-size* opcode))
104
105(defvar *pool* nil)
106
107(defun read-u1 (stream)
108  (read-byte stream))
109
110(defun read-u2 (stream)
111  (+ (ash (read-byte stream) 8) (read-byte stream)))
112
113(defun read-u4 (stream)
114  (+ (ash (read-u2 stream) 16) (read-u2 stream)))
115
116(defun lookup-utf8 (index)
117  (let ((entry (svref *pool* index)))
118    (when (eql (car entry) 1)
119      (caddr entry))))
120
121(defun read-constant-pool-entry (stream)
122  (let ((tag (read-u1 stream)))
123    (case tag
124      ((7 8)
125       (list tag (read-u2 stream)))
126      (1
127       (let* ((len (read-u2 stream))
128              (s (make-string len)))
129         (dotimes (i len)
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 *variables* ())
307
308(defstruct variable
309  name
310  special-p
311  index)
312
313(defun push-variable (var special-p index)
314  (push (make-variable :name var :special-p special-p :index index) *variables*))
315
316(defun find-variable (var)
317  (find var *variables* :key 'variable-name))
318
319;; (defun specialp (var)
320;;   (let ((info (find-variable var)))
321;;     (if info
322;;         (cdr info)
323;;         ;; Not found in variables list.
324;;         (special-variable-p var))))
325
326(defvar *local-functions* ())
327
328(defstruct local-function
329  name
330  args-to-add
331  function)
332
333(defvar *args* nil)
334(defvar *using-arg-array* nil)
335(defvar *hairy-arglist-p* nil)
336
337(defvar *val* nil) ; index of value register
338
339(defun clear ()
340  (setf *pool* nil
341        *pool-count* 1
342        *code* nil)
343  t)
344
345(defun dump-pool ()
346  (let ((pool (reverse *pool*))
347        entry)
348    (dotimes (index (1- *pool-count*))
349      (setq entry (car pool))
350      (setq type (case (car entry)
351                   (7 'class)
352                   (9 'field)
353                   (10 'method)
354                   (11 'interface)
355                   (8 'string)
356                   (3 'integer)
357                   (4 'float)
358                   (5 'long)
359                   (6 'double)
360                   (12 'name-and-type)
361                   (1 'utf8)))
362      (format t "~D: ~A ~S~%" (1+ index) type entry)
363      (setq pool (cdr pool))))
364  t)
365
366;; Returns index of entry (1-based).
367(defun pool-add (entry)
368  (setq *pool* (cons entry *pool*))
369  (prog1
370    *pool-count*
371    (incf *pool-count*)))
372
373;; Returns index of entry (1-based).
374(defun pool-find-entry (entry)
375  (do* ((remaining *pool* (cdr remaining))
376        (i 0 (1+ i))
377        (current (car remaining) (car remaining)))
378       ((null remaining) nil)
379    (when (equal current entry)
380      (return-from pool-find-entry (- *pool-count* 1 i)))))
381
382;; Adds entry if not already in pool. Returns index of entry (1-based).
383(defun pool-get (entry)
384  (or (pool-find-entry entry) (pool-add entry)))
385
386(defun pool-name (name)
387  (pool-get (list 1 (length name) name)))
388
389;; "org.armedbear.lisp.LispObject" => "Lorg/armedbear/lisp/LispObject;"
390;; (defun type-descriptor (type)
391;;   (unless (find #\. type)
392;;     (setq type (concatenate 'string "org.armedbear.lisp." type)))
393;;   (let ((res (concatenate 'string "L" type ";")))
394;;     (dotimes (i (length res))
395;;       (when (eql (char res i) #\.)
396;;         (setf (char res i) #\/)))
397;;     res))
398
399(defun pool-name-and-type (name type)
400  (let* ((name-index (pool-name name))
401         (type-index (pool-name type)))
402    (pool-get (list 12 name-index type-index))))
403
404(defun pool-class (class-name)
405  (let ((class-name class-name))
406    (dotimes (i (length class-name))
407      (when (eql (char class-name i) #\.)
408        (setf (char class-name i) #\/)))
409    (pool-get (list 7 (pool-name class-name)))))
410
411;; (tag class-index name-and-type-index)
412(defun pool-field (class-name field-name type-name)
413  (let* ((class-index (pool-class class-name))
414         (name-and-type-index (pool-name-and-type field-name type-name)))
415    (pool-get (list 9 class-index name-and-type-index))))
416
417;; (tag class-index name-and-type-index)
418(defun pool-method (class-name method-name type-name)
419  (let* ((class-index (pool-class class-name))
420         (name-and-type-index (pool-name-and-type method-name type-name)))
421    (pool-get (list 10 class-index name-and-type-index))))
422
423(defun pool-string (string)
424  (pool-get (list 8 (pool-name string))))
425
426(defun u2 (n)
427  (list (ash n -8) (logand n #xff)))
428
429(defstruct instruction opcode args stack depth)
430
431(defun inst (opcode &optional args)
432  (unless (listp args)
433    (setq args (list args)))
434  (make-instruction :opcode opcode :args args :stack nil :depth nil))
435
436(defun emit (instr &rest args)
437  (unless (numberp instr)
438    (setq instr (get instr 'opcode)))
439  (let ((instruction (inst instr args)))
440    (setq *code* (cons instruction *code*))
441    instruction))
442
443(defmacro emit-store-value ()
444;;   `(case *val*
445;;      (0
446;;       (emit 'astore_0))
447;;      (1
448;;       (emit 'astore_1))
449;;      (2
450;;       (emit 'astore_2))
451;;      (3
452;;       (emit 'astore_3))
453;;      (t
454;;       (emit 'astore *val*))))
455  `(emit 'store-value))
456
457(defmacro emit-push-value ()
458;;   `(case *val*
459;;      (0
460;;       (emit 'aload_0))
461;;      (1
462;;       (emit 'aload_1))
463;;      (2
464;;       (emit 'aload_2))
465;;      (3
466;;       (emit 'aload_3))
467;;      (t
468;;       (emit 'aload *val*))))
469  `(emit 'push-value))
470
471(defun remove-store-value ()
472;;   (let* ((instruction (car *code*))
473;;          (opcode (instruction-opcode instruction))
474;;          slot)
475;;     (case opcode
476;;       (75
477;;        (setf slot 0))
478;;       (76
479;;        (setf slot 1))
480;;       (77
481;;        (setf slot 2))
482;;       (78
483;;        (setf slot 3))
484;;       (58
485;;        (setf slot (car (instruction-args instruction)))))
486;;     (when (and slot (= slot *val*))
487;;       (setf *code* (cdr *code*))
488;;       t)))
489  (let* ((instruction (car *code*))
490         (opcode (instruction-opcode instruction)))
491;;     (format t "REMOVE-STORE-VALUE called opcode = ~S~%" opcode)
492    (when (eql opcode 204) ; STORE-VALUE
493;;       (format t "removing STORE-VALUE~%")
494      (setf *code* (cdr *code*))
495      t)))
496
497(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
498(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
499(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
500(defconstant +lisp-string+ "Lorg/armedbear/lisp/LispString;")
501(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
502(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
503(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
504
505(defun emit-push-nil ()
506  (emit 'getstatic
507        +lisp-class+
508        "NIL"
509        +lisp-object+))
510
511(defun emit-push-t ()
512  (emit 'getstatic
513        +lisp-class+
514        "T"
515        "Lorg/armedbear/lisp/Symbol;"))
516
517(defun emit-invokestatic (class-name method-name descriptor stack)
518  (assert stack)
519  (let ((instruction (emit 'invokestatic class-name method-name descriptor)))
520    (setf (instruction-stack instruction) stack)
521    (assert (eql (instruction-stack instruction) stack))))
522
523(defun emit-invokespecial (class-name method-name descriptor stack)
524  (let ((instruction (emit 'invokespecial class-name method-name descriptor)))
525    (setf (instruction-stack instruction) stack)))
526
527(defun emit-invokevirtual (class-name method-name descriptor stack)
528  (let ((instruction (emit 'invokevirtual class-name method-name descriptor)))
529    (setf (instruction-stack instruction) stack)))
530
531;; Index of local variable used to hold the current thread.
532(defvar *thread* nil)
533(defvar *thread-var-initialized* nil)
534
535(defun ensure-thread-var-initialized ()
536  (unless *thread-var-initialized*
537    ;; Put the code to initialize the local at the very beginning of the
538    ;; function, to guarantee that the local gets initialized even if the code
539    ;; at our current location is never executed, since the local may be
540    ;; referenced elsewhere too.
541    (let ((code *code*))
542      (setf *code* ())
543      (emit-invokestatic +lisp-thread-class+
544                         "currentThread"
545                         "()Lorg/armedbear/lisp/LispThread;"
546                         1)
547      (emit 'astore *thread*)
548      (setf *code* (append code *code*)))
549    (setf *thread-var-initialized* t)))
550
551(defun emit-clear-values ()
552  (ensure-thread-var-initialized)
553  (emit 'aload *thread*)
554  (emit-invokevirtual +lisp-thread-class+ "clearValues" "()V" -1))
555
556(defun emit-invoke-method (method-name)
557  (unless (remove-store-value)
558    (emit-push-value))
559  (emit-invokevirtual +lisp-object-class+
560                      method-name
561                      "()Lorg/armedbear/lisp/LispObject;"
562                      0)
563  (emit-store-value))
564
565;; CODE is a list.
566(defun resolve-args (instruction)
567  (let ((opcode (instruction-opcode instruction))
568        (args (instruction-args instruction)))
569    (case opcode
570      (203 ; PUSH-VALUE
571       (case *val*
572         (0
573          (inst 42)) ; ALOAD_0
574         (1
575          (inst 43)) ; ALOAD_1
576         (2
577          (inst 44)) ; ALOAD_2
578         (3
579          (inst 45)) ; ALOAD_3
580         (t
581          (inst 25 *val*))))
582      (204 ; STORE-VALUE
583       (case *val*
584         (0
585          (inst 75)) ; ASTORE_0
586         (1
587          (inst 76)) ; ASTORE_1
588         (2
589          (inst 77)) ; ASTORE_2
590         (3
591          (inst 78)) ; ASTORE_3
592         (t
593          (inst 58 *val*))))
594      ((1 ; ACONST_NULL
595        42 ; ALOAD_0
596        43 ; ALOAD_1
597        44 ; ALOAD_2
598        45 ; ALOAD_3
599        50 ; AALOAD
600        75 ; ASTORE_0
601        76 ; ASTORE_1
602        77 ; ASTORE_2
603        78 ; ASTORE_3
604        83 ; AASTORE
605        87 ; POP
606        89 ; DUP
607        95 ; SWAP
608        153 ; IFEQ
609        154 ; IFNE
610        166 ; IF_ACMPNE
611        165 ; IF_ACMPEQ
612        167 ; GOTO
613        176 ; ARETURN
614        177 ; RETURN
615        202 ; LABEL
616        )
617       instruction)
618      (25 ; ALOAD
619       (let ((index (car args)))
620         (cond ((= index 0)
621                (inst 42)) ; ALOAD_O
622               ((= index 1)
623                (inst 43)) ; ALOAD_1
624               ((= index 2)
625                (inst 44)) ; ALOAD_2
626               ((= index 3)
627                (inst 45)) ; ALOAD_3
628               ((<= 0 index 255)
629                (inst 25 index))
630               (t
631                (error "ALOAD unsupported case")))))
632      (58 ; ASTORE
633       (let ((index (car args)))
634         (cond ((= index 0)
635                (inst 75)) ; ASTORE_O
636               ((= index 1)
637                (inst 76)) ; ASTORE_1
638               ((= index 2)
639                (inst 77)) ; ASTORE_2
640               ((= index 3)
641                (inst 78)) ; ASTORE_3
642               ((<= 0 index 255)
643                (inst 58 index))
644               (t
645                (error "ASTORE unsupported case")))))
646      ((178 ; GETSTATIC class-name field-name type-name
647        179 ; PUTSTATIC class-name field-name type-name
648        )
649       (let ((index (pool-field (first args) (second args) (third args))))
650         (inst opcode (u2 index))))
651      ((182 ; INVOKEVIRTUAL class-name method-name descriptor
652        183 ; INVOKESPECIAL class-name method-name descriptor
653        184 ; INVOKESTATIC class-name method-name descriptor
654        )
655       (let ((index (pool-method (first args) (second args) (third args))))
656;;          (inst opcode (u2 index))))
657         (setf (instruction-args instruction) (u2 index))
658         instruction))
659      ((187 ; NEW class-name
660        189 ; ANEWARRAY class-name
661        193 ; INSTANCEOF class-name
662        )
663       (let ((index (pool-class (first args))))
664         (inst opcode (u2 index))))
665      ((16 ; BIPUSH
666        17 ; SIPUSH
667        )
668       (let ((n (first args)))
669         (cond ((= n 0)
670                (inst 3)) ; ICONST_0
671               ((= n 1)
672                (inst 4)) ; ICONST_1
673               ((= n 2)
674                (inst 5)) ; ICONST_2
675               ((= n 3)
676                (inst 6)) ; ICONST_3
677               ((= n 4)
678                (inst 7)) ; ICONST_4
679               ((= n 5)
680                (inst 8)) ; ICONST_5
681               ((<= -128 n 127)
682                (inst 16 (logand n #xff))) ; BIPUSH
683               (t ; SIPUSH
684                (inst 17 (u2 n))))))
685      (18 ; LDC
686       (unless (= (length args) 1)
687         (error "wrong number of args for LDC"))
688       (if (> (car args) 255)
689           (inst 19 (u2 (car args))) ; LDC_W
690           (inst opcode args)))
691      (t
692       (error "RESOLVE-ARGS unsupported opcode ~D" opcode)))))
693
694;; CODE is a list of INSTRUCTIONs.
695(defun resolve-opcodes (code)
696  (map 'vector #'resolve-args code))
697
698(defun branch-opcode-p (opcode)
699  (member opcode
700    '(153 ; IFEQ
701      154 ; IFNE
702      165 ; IF_ACMPEQ
703      166 ; IF_ACMPNE
704      167 ; GOTO
705      )))
706
707(defun stack-effect (opcode)
708  (case opcode
709    (203 ; PUSH-VALUE
710     1)
711    (204 ; STORE-VALUE
712     -1)
713    ((25 ; ALOAD
714      42 ; ALOAD_0
715      43 ; ALOAD_1
716      44 ; ALOAD_2
717      45 ; ALOAD_3
718      )
719     1)
720    ((58 ; ASTORE
721      75 ; ASTORE_0
722      76 ; ASTORE_1
723      77 ; ASTORE_2
724      78 ; ASTORE_3
725      )
726     -1)
727    (50 ; AALOAD
728     -1)
729    (83 ; AASTORE
730     -3)
731    ((1 ; ACONST_NULL
732      3 4 5 6 7 8 ; ICONST_0 ... ICONST_5
733      16 ; BIPUSH
734      17 ; SIPUSH
735      )
736     1)
737    (18 ; LDC
738     1)
739    (178 ; GETSTATIC
740     1)
741    (179 ; PUTSTATIC
742     -1)
743    (187 ; NEW
744     1)
745    (189 ; ANEWARRAY
746     0)
747    (193 ; INSTANCEOF
748     0)
749    ((153 ; IFEQ
750      154 ; IFNE
751      )
752     -1)
753    ((165 ; IF_ACMPEQ
754      166 ; IF_ACMPNE
755      )
756     -2)
757    ((167 ; GOTO
758      202 ; LABEL
759      )
760     0)
761    (89 ; DUP
762     1)
763    (95 ; SWAP
764     0)
765    (87 ; POP
766     -1)
767    (176 ; ARETURN
768     -1)
769    (177 ; RETURN
770     0)
771    (t
772     (format t "STACK-EFFECT unsupported opcode ~S~%" opcode)
773     0)))
774
775(defun walk-code (code start-index depth)
776  (do* ((i start-index (1+ i))
777        (limit (length code)))
778       ((>= i limit) depth)
779    (let ((instruction (svref code i)))
780      (when (instruction-depth instruction)
781        (return-from walk-code))
782      (setf (instruction-depth instruction) depth)
783      (setf depth (+ depth (instruction-stack instruction)))
784      (if (branch-opcode-p (instruction-opcode instruction))
785          (let ((label (car (instruction-args instruction))))
786;;             (format t "target = ~S~%" target)
787            (walk-code code (symbol-value label) depth)
788            )
789          ()))))
790
791(defun analyze-stack ()
792  (sys::require-type *code* 'vector)
793  (dotimes (i (length *code*))
794    (let* ((instruction (svref *code* i))
795           (opcode (instruction-opcode instruction)))
796      (when (eql opcode 202)
797        (let ((label (car (instruction-args instruction))))
798          (set label i)))
799      (unless (instruction-stack instruction)
800        (setf (instruction-stack instruction) (stack-effect opcode)))))
801  (walk-code *code* 0 0)
802  (let ((max-stack 0))
803    (dotimes (i (length *code*))
804      (let ((instruction (svref *code* i)))
805        (setf max-stack (max max-stack (instruction-depth instruction)))))
806;;     (format t "max-stack = ~D~%" max-stack)
807    max-stack))
808
809(defun finalize-code ()
810  (setf *code* (nreverse (coerce *code* 'vector))))
811
812(defun print-code()
813  (dotimes (i (length *code*))
814    (let ((instruction (svref *code* i)))
815      (format t "~A ~S~%"
816              (instr (instruction-opcode instruction))
817              (instruction-args instruction)))))
818
819(defun validate-labels ()
820  (dotimes (i (length *code*))
821    (let* ((instruction (svref *code* i))
822           (opcode (instruction-opcode instruction)))
823      (when (eql opcode 202)
824        (let ((label (car (instruction-args instruction))))
825          (set label i))))))
826
827(defun optimize-code ()
828  (when *debug*
829    (format t "----- before optimization -----~%")
830    (print-code))
831  (loop
832    (let ((changed-p nil))
833      ;; Make a list of the labels that are actually branched to.
834      (let ((branch-targets ()))
835        (dotimes (i (length *code*))
836          (let ((instruction (svref *code* i)))
837            (when (branch-opcode-p (instruction-opcode instruction))
838              (push (car (instruction-args instruction)) branch-targets))))
839;;         (format t "branch-targets = ~S~%" branch-targets)
840        ;; Remove labels that are not used as branch targets.
841        (dotimes (i (length *code*))
842          (let ((instruction (svref *code* i)))
843            (when (= (instruction-opcode instruction) 202) ; LABEL
844              (let ((label (car (instruction-args instruction))))
845                (unless (member label branch-targets)
846                  (setf (instruction-opcode instruction) 0)'
847                  (setf changed-p t)))))))
848      (setf *code* (delete 0 *code* :key #'instruction-opcode))
849      (dotimes (i (length *code*))
850        (let ((instruction (svref *code* i)))
851          (when (and (< i (1- (length *code*)))
852                     (= (instruction-opcode instruction) 167) ; GOTO
853                     (let ((next-instruction (svref *code* (1+ i))))
854                       (cond ((and (= (instruction-opcode next-instruction) 202) ; LABEL
855                                   (eq (car (instruction-args instruction))
856                                       (car (instruction-args next-instruction))))
857                              ;; GOTO next instruction.
858                              (setf (instruction-opcode instruction) 0)
859                              (setf changed-p t))
860                             ((= (instruction-opcode next-instruction) 167) ; GOTO
861                              ;; One GOTO right after another.
862                              (setf (instruction-opcode next-instruction) 0)
863                              (setf changed-p t))
864                              ))))))
865      (setf *code* (delete 0 *code* :key #'instruction-opcode))
866      ;; Reduce GOTOs.
867      (validate-labels)
868      (dotimes (i (length *code*))
869        (let ((instruction (svref *code* i)))
870          (when (eql (instruction-opcode instruction) 167) ; GOTO
871            (let* ((label (car (instruction-args instruction)))
872                   (target-index (1+ (symbol-value label)))
873                   (instr1 (svref *code* target-index))
874                   (instr2 (if (eql (instruction-opcode instr1) 203) ; PUSH-VALUE
875                               (svref *code* (1+ target-index))
876                               nil)))
877              (when (and instr2 (eql (instruction-opcode instr2) 176)) ; ARETURN
878                (let ((previous-instruction (svref *code* (1- i))))
879                  (when (eql (instruction-opcode previous-instruction) 204) ; STORE-VALUE
880                    (setf (instruction-opcode previous-instruction) 176) ; ARETURN
881                    (setf (instruction-opcode instruction) 0)
882                    (setf changed-p t))))))))
883      (setf *code* (delete 0 *code* :key #'instruction-opcode))
884      ;; Look for sequence STORE-VALUE LOAD-VALUE ARETURN.
885      (dotimes (i (- (length *code*) 2))
886        (let ((instr1 (svref *code* i))
887              (instr2 (svref *code* (+ i 1)))
888              (instr3 (svref *code* (+ i 2))))
889          (when (and (eql (instruction-opcode instr1) 204)
890                     (eql (instruction-opcode instr2) 203)
891                     (eql (instruction-opcode instr3) 176))
892            (setf (instruction-opcode instr1) 176)
893            (setf (instruction-opcode instr2) 0)
894            (setf (instruction-opcode instr3) 0)
895            (setf changed-p t))))
896      (setf *code* (delete 0 *code* :key #'instruction-opcode))
897      (unless changed-p
898          (return))))
899  (when *debug*
900    (format t "----- after optimization -----~%")
901    (print-code)))
902
903(defvar *max-stack*)
904
905;; CODE is a list of INSTRUCTIONs.
906(defun code-bytes (code)
907  (let ((code (resolve-opcodes code))
908        (length 0))
909    ;; Pass 1: calculate label offsets and overall length.
910    (dotimes (i (length code))
911      (let* ((instruction (aref code i))
912             (opcode (instruction-opcode instruction)))
913        (if (= opcode 202) ; LABEL
914            (let ((label (car (instruction-args instruction))))
915              (set label length))
916            (incf length (opcode-size opcode)))))
917    ;; Pass 2: replace labels with calculated offsets.
918    (let ((index 0))
919      (dotimes (i (length code))
920        (let ((instruction (aref code i)))
921          (when (branch-opcode-p (instruction-opcode instruction))
922            (let* ((label (car (instruction-args instruction)))
923                   (offset (- (symbol-value `,label) index)))
924              (setf (instruction-args instruction) (u2 offset))))
925          (unless (= (instruction-opcode instruction) 202) ; LABEL
926            (incf index (opcode-size (instruction-opcode instruction)))))))
927    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
928    (let ((bytes (make-array length))
929          (index 0))
930      (dotimes (i (length code))
931        (let ((instruction (aref code i)))
932          (unless (= (instruction-opcode instruction) 202) ; LABEL
933            (setf (svref bytes index) (instruction-opcode instruction))
934            (incf index)
935            (dolist (byte (instruction-args instruction))
936              (setf (svref bytes index) byte)
937              (incf index)))))
938      bytes)))
939
940(defun write-u1 (n)
941  (write-byte (logand n #xFF) *stream*))
942
943(defun write-u2 (n)
944  (write-byte (ash n -8) *stream*)
945  (write-byte (logand n #xFF) *stream*))
946
947(defun write-u4 (n)
948  (write-u2 (ash n -16))
949  (write-u2 (logand n #xFFFF)))
950
951(defun write-utf8 (string)
952  (dotimes (i (length string))
953    (let ((c (char string i)))
954      (if (eql c #\null)
955          (progn
956            (write-u1 #xC0)
957            (write-u1 #x80))
958          (write-u1 (char-int c))))))
959
960(defun utf8-length (string)
961  (let ((len 0))
962    (dotimes (i (length string))
963      (incf len (if (eql (char string i) #\null) 2 1)))
964    len))
965
966(defun write-cp-entry (entry)
967  (write-u1 (first entry))
968  (case (first entry)
969    (1 ; UTF8
970     (write-u2 (utf8-length (third entry)))
971     (write-utf8 (third entry)))
972    ((5 6)
973     (write-u4 (second entry))
974     (write-u4 (third entry)))
975    ((9 10 11 12)
976     (write-u2 (second entry))
977     (write-u2 (third entry)))
978    ((7 8)
979     (write-u2 (second entry)))
980    (t
981     (error "WRITE-CP-ENTRY unhandled tag ~D~%" (car entry)))
982  ))
983
984(defun write-pool ()
985  (write-u2 *pool-count*)
986  (dolist (entry (reverse *pool*))
987    (write-cp-entry entry)))
988
989(defstruct field
990  access-flags
991  name
992  descriptor
993  name-index
994  descriptor-index)
995
996(defstruct method
997  access-flags
998  name
999  descriptor
1000  name-index
1001  descriptor-index
1002  max-stack
1003  max-locals
1004  code)
1005
1006(defun make-constructor (super name args body)
1007  (let* ((constructor (make-method :name "<init>"
1008                                   :descriptor "()V"))
1009         (*code* ()))
1010    (setf (method-name-index constructor) (pool-name (method-name constructor)))
1011    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
1012    (setf (method-max-locals constructor) 1)
1013    (cond (*hairy-arglist-p*
1014           (emit 'aload_0) ;; this
1015           (emit 'aconst_null) ;; name
1016           (let ((s (format nil "~S" args)))
1017             (emit 'ldc
1018                   (pool-string s))
1019             (emit-invokestatic "org/armedbear/lisp/Lisp"
1020                                "readObjectFromString"
1021                                "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1022                                0))
1023           (emit-push-nil) ;; body
1024           (emit 'aconst_null) ;; environment
1025           (emit-invokespecial super
1026                               "<init>"
1027                               "(Ljava/lang/String;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
1028                               -4))
1029          (t
1030           (emit 'aload_0)
1031           (emit-invokespecial super
1032                               "<init>"
1033                               "()V"
1034                               0)))
1035    (setf *code* (append *static-code* *code*))
1036    (emit 'return)
1037    (finalize-code)
1038    (optimize-code)
1039    (setf (method-max-stack constructor) (analyze-stack))
1040    (setf (method-code constructor) (code-bytes *code*))
1041    constructor))
1042
1043(defun write-code-attr (method)
1044  (let* ((name-index (pool-name "Code"))
1045         (code (method-code method))
1046         (code-length (length code))
1047         (length (+ code-length 12))
1048         (max-stack (or (method-max-stack method) 20))
1049         (max-locals (or (method-max-locals method) 1)))
1050    (write-u2 name-index)
1051    (write-u4 length)
1052    (write-u2 max-stack)
1053    (write-u2 max-locals)
1054    (write-u4 code-length)
1055    (dotimes (i code-length)
1056      (write-u1 (svref code i)))
1057    (write-u2 0) ; handler table length
1058    (write-u2 0) ; attributes count
1059    ))
1060
1061(defun write-method (method)
1062  (write-u2 (or (method-access-flags method) #x1)) ; access flags
1063  (write-u2 (method-name-index method))
1064  (write-u2 (method-descriptor-index method))
1065  (write-u2 1) ; attributes count
1066  (write-code-attr method))
1067
1068(defun write-field (field)
1069  (write-u2 (or (field-access-flags field) #x1)) ; access flags
1070  (write-u2 (field-name-index field))
1071  (write-u2 (field-descriptor-index field))
1072  (write-u2 0)) ; attributes count
1073
1074(defun declare-field (name descriptor)
1075  (let ((field (make-field :name name :descriptor descriptor)))
1076    (setf (field-access-flags field) (logior #x8 #x2)) ; private static
1077    (setf (field-name-index field) (pool-name (field-name field)))
1078    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
1079    (setq *fields* (cons field *fields*))))
1080
1081(defun sanitize (symbol)
1082  (let* ((input (symbol-name symbol))
1083         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
1084    (dotimes (i (length input))
1085      (let ((c (char-upcase (char input i))))
1086        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
1087               (vector-push c output))
1088              ((eql c #\-)
1089               (vector-push #\_ output)))))
1090    (when (plusp (length output))
1091      output)))
1092
1093(defvar *declared-symbols* ())
1094(defvar *declared-functions* ())
1095
1096(defun declare-symbol (symbol)
1097  (let ((g (gethash symbol *declared-symbols*)))
1098    (unless g
1099      (let ((*code* *static-code*)
1100            (s (sanitize symbol)))
1101        (setq g (symbol-name (gensym)))
1102        (when s
1103          (setq g (concatenate 'string g "_" s)))
1104        (declare-field g "Lorg/armedbear/lisp/Symbol;")
1105        (emit 'ldc
1106              (pool-string (symbol-name symbol)))
1107        (emit 'ldc
1108              (pool-string (package-name (symbol-package symbol))))
1109        (emit-invokestatic +lisp-class+
1110                           "internInPackage"
1111                           "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1112                           -1)
1113        (emit 'putstatic
1114              *this-class*
1115              g
1116              "Lorg/armedbear/lisp/Symbol;")
1117        (setq *static-code* *code*)
1118        (setf (gethash symbol *declared-symbols*) g)))
1119    g))
1120
1121(defun declare-function (symbol)
1122  (let ((f (gethash symbol *declared-functions*)))
1123    (unless f
1124      (setf f (symbol-name (gensym)))
1125      (let ((s (sanitize symbol)))
1126        (when s
1127          (setf f (concatenate 'string f "_" s))))
1128      (let ((*code* *static-code*)
1129            (g (gethash symbol *declared-symbols*)))
1130        (cond (g
1131               (emit 'getstatic
1132                     *this-class*
1133                     g
1134                     "Lorg/armedbear/lisp/Symbol;"))
1135              (t
1136               (emit 'ldc
1137                     (pool-string (symbol-name symbol)))
1138               (emit 'ldc
1139                     (pool-string (package-name (symbol-package symbol))))
1140               (emit-invokestatic +lisp-class+
1141                                  "internInPackage"
1142                                  "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1143                                  -1)))
1144        (declare-field f "Lorg/armedbear/lisp/LispObject;")
1145        (emit-invokevirtual +lisp-symbol-class+
1146                            "getSymbolFunctionOrDie"
1147                            "()Lorg/armedbear/lisp/LispObject;"
1148                            0)
1149        (emit 'putstatic
1150              *this-class*
1151              f
1152              "Lorg/armedbear/lisp/LispObject;")
1153        (setq *static-code* *code*)
1154        (setf (gethash symbol *declared-functions*) f)))
1155    f))
1156
1157(defun declare-keyword (symbol)
1158  (let ((g (symbol-name (gensym)))
1159        (*code* *static-code*))
1160    (declare-field g "Lorg/armedbear/lisp/Symbol;")
1161    (emit 'ldc
1162          (pool-string (symbol-name symbol)))
1163    (emit-invokestatic "org/armedbear/lisp/Keyword"
1164                       "internKeyword"
1165                       "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1166                       0)
1167    (emit 'putstatic
1168          *this-class*
1169          g
1170          "Lorg/armedbear/lisp/Symbol;")
1171    (setq *static-code* *code*)
1172    g))
1173
1174(defun declare-object-as-string (obj)
1175  (let ((g (symbol-name (gensym)))
1176        (s (format nil "~S" obj))
1177        (*code* *static-code*))
1178    (declare-field g +lisp-object+)
1179    (emit 'ldc
1180          (pool-string s))
1181    (emit-invokestatic +lisp-class+
1182                       "readObjectFromString"
1183                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1184                       0)
1185    (emit 'putstatic
1186          *this-class*
1187          g
1188          +lisp-object+)
1189    (setq *static-code* *code*)
1190    g))
1191
1192(defun declare-object (obj)
1193  (let ((key (symbol-name (gensym))))
1194    (sys::remember key obj)
1195    (let* ((g1 (declare-string key))
1196           (g2 (symbol-name (gensym)))
1197           (*code* *static-code*))
1198      (declare-field g2 +lisp-object+)
1199      (emit 'getstatic
1200            *this-class*
1201            g1
1202            +lisp-string+)
1203      (emit 'dup)
1204      (emit-invokestatic +lisp-class+
1205                         "recall"
1206                         "(Lorg/armedbear/lisp/LispString;)Lorg/armedbear/lisp/LispObject;"
1207                         0)
1208      (emit 'putstatic
1209            *this-class*
1210            g2
1211            +lisp-object+)
1212      (emit-invokestatic +lisp-class+
1213                         "forget"
1214                         "(Lorg/armedbear/lisp/LispString;)V"
1215                         -1)
1216      (setq *static-code* *code*)
1217      g2)))
1218
1219(defun declare-string (string)
1220  (let ((g (symbol-name (gensym)))
1221        (*code* *static-code*))
1222    (declare-field g "Lorg/armedbear/lisp/LispString;")
1223    (emit 'ldc
1224          (pool-string string))
1225    (emit-invokestatic "org/armedbear/lisp/LispString"
1226                       "getInstance"
1227                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispString;"
1228                       0)
1229    (emit 'putstatic
1230          *this-class*
1231          g
1232          +lisp-string+)
1233    (setq *static-code* *code*)
1234    g))
1235
1236(defun compile-constant (form)
1237  (cond
1238   ((fixnump form)
1239    (let ((n form))
1240      (cond ((zerop n)
1241             (emit 'getstatic
1242                   "org/armedbear/lisp/Fixnum"
1243                   "ZERO"
1244                   "Lorg/armedbear/lisp/Fixnum;")
1245             (emit-store-value))
1246            ((= n 1)
1247             (emit 'getstatic
1248                   "org/armedbear/lisp/Fixnum"
1249                   "ONE"
1250                   "Lorg/armedbear/lisp/Fixnum;")
1251             (emit-store-value))
1252            ((= n 2)
1253             (emit 'getstatic
1254                   "org/armedbear/lisp/Fixnum"
1255                   "TWO"
1256                   "Lorg/armedbear/lisp/Fixnum;")
1257             (emit-store-value))
1258            (t
1259             (let ((g (declare-object-as-string n)))
1260               (emit 'getstatic
1261                     *this-class*
1262                     g
1263                     "Lorg/armedbear/lisp/LispObject;")
1264               (emit-store-value))))))
1265   ((numberp form)
1266    (let ((g (declare-object-as-string form)))
1267      (emit 'getstatic
1268            *this-class*
1269            g
1270            "Lorg/armedbear/lisp/LispObject;")
1271      (emit-store-value)))
1272   ((stringp form)
1273    (let ((g (declare-string form)))
1274      (emit 'getstatic
1275            *this-class*
1276            g
1277            "Lorg/armedbear/lisp/LispString;")
1278      (emit-store-value)))
1279   ((vectorp form)
1280    (let ((g (declare-object-as-string form)))
1281      (emit 'getstatic
1282            *this-class*
1283            g
1284            "Lorg/armedbear/lisp/LispObject;")
1285      (emit-store-value)))
1286   ((characterp form)
1287    (let ((g (declare-object-as-string form)))
1288      (emit 'getstatic
1289            *this-class*
1290            g
1291            "Lorg/armedbear/lisp/LispObject;")
1292      (emit-store-value)))
1293   ((symbolp form)
1294    (when (null (symbol-package form))
1295      ;; An uninterned symbol.
1296      (let ((g (declare-object form)))
1297        (emit 'getstatic
1298              *this-class*
1299              g
1300              "Lorg/armedbear/lisp/LispObject;")
1301        (emit-store-value))))
1302   (t
1303    (error "COMPILE-CONSTANT unhandled case ~S" form))))
1304
1305(defun compile-binary-operation (op args)
1306  (compile-form (first args))
1307  (unless (remove-store-value)
1308    (emit-push-value))
1309  (compile-form (second args))
1310  (unless (remove-store-value)
1311    (emit-push-value))
1312  (unless (every 'constantp args)
1313    (emit-clear-values))
1314  (emit-invokevirtual +lisp-object-class+
1315                      op
1316                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1317                      -1)
1318  (emit-store-value))
1319
1320(defparameter unary-operators (make-hash-table))
1321
1322(setf (gethash '1+              unary-operators) "incr")
1323(setf (gethash '1-              unary-operators) "decr")
1324(setf (gethash 'ATOM            unary-operators) "ATOM")
1325(setf (gethash 'BIT-VECTOR-P    unary-operators) "BIT_VECTOR_P")
1326(setf (gethash 'CADR            unary-operators) "cadr")
1327(setf (gethash 'CAR             unary-operators) "car")
1328(setf (gethash 'CDDR            unary-operators) "cddr")
1329(setf (gethash 'CDR             unary-operators) "cdr")
1330(setf (gethash 'COMPLEXP        unary-operators) "COMPLEXP")
1331(setf (gethash 'CONSTANTP       unary-operators) "CONSTANTP")
1332(setf (gethash 'DENOMINATOR     unary-operators) "DENOMINATOR")
1333(setf (gethash 'ENDP            unary-operators) "ENDP")
1334(setf (gethash 'EVENP           unary-operators) "EVENP")
1335(setf (gethash 'FIRST           unary-operators) "car")
1336(setf (gethash 'FLOATP          unary-operators) "FLOATP")
1337(setf (gethash 'INTEGERP        unary-operators) "INTEGERP")
1338(setf (gethash 'LENGTH          unary-operators) "LENGTH")
1339(setf (gethash 'LISTP           unary-operators) "LISTP")
1340(setf (gethash 'MINUSP          unary-operators) "MINUSP")
1341(setf (gethash 'NOT             unary-operators) "NOT")
1342(setf (gethash 'NREVERSE        unary-operators) "nreverse")
1343(setf (gethash 'NULL            unary-operators) "NOT")
1344(setf (gethash 'NUMBERP         unary-operators) "NUMBERP")
1345(setf (gethash 'NUMERATOR       unary-operators) "NUMERATOR")
1346(setf (gethash 'ODDP            unary-operators) "ODDP")
1347(setf (gethash 'PLUSP           unary-operators) "PLUSP")
1348(setf (gethash 'RATIONALP       unary-operators) "RATIONALP")
1349(setf (gethash 'REALP           unary-operators) "REALP")
1350(setf (gethash 'REST            unary-operators) "cdr")
1351(setf (gethash 'SECOND          unary-operators) "cadr")
1352(setf (gethash 'SIMPLE-STRING-P unary-operators) "SIMPLE_STRING_P")
1353(setf (gethash 'STRINGP         unary-operators) "STRINGP")
1354(setf (gethash 'SYMBOLP         unary-operators) "SYMBOLP")
1355(setf (gethash 'VECTORP         unary-operators) "VECTORP")
1356(setf (gethash 'ZEROP           unary-operators) "ZEROP")
1357
1358(defun compile-function-call-1 (fun args)
1359  (let ((s (gethash fun unary-operators)))
1360    (when s
1361      (compile-form (first args))
1362      (emit-invoke-method s)
1363      (return-from compile-function-call-1 t)))
1364    nil)
1365
1366(defun compile-function-call-2 (fun args)
1367  (case fun
1368    (EQ
1369     (compile-form (first args))
1370     (unless (remove-store-value)
1371       (emit-push-value))
1372     (compile-form (second args))
1373     (unless (remove-store-value)
1374       (emit-push-value))
1375     (let ((label1 (gensym))
1376           (label2 (gensym)))
1377       (emit 'if_acmpeq `,label1)
1378       (emit-push-nil)
1379       (emit 'goto `,label2)
1380       (emit 'label `,label1)
1381       (emit-push-t)
1382       (emit 'label `,label2))
1383     (emit-store-value)
1384     t)
1385    (EQL
1386     (compile-binary-operation "EQL" args)
1387     t)
1388    (+
1389     (compile-binary-operation "add" args)
1390     t)
1391    (-
1392     (compile-binary-operation "subtract" args)
1393     t)
1394    (/
1395     (compile-binary-operation "divideBy" args)
1396     t)
1397    (*
1398     (compile-binary-operation "multiplyBy" args)
1399     t)
1400    (<
1401     (compile-binary-operation "IS_LT" args)
1402     t)
1403    (<=
1404     (compile-binary-operation "IS_LE" args)
1405     t)
1406    (>
1407     (compile-binary-operation "IS_GT" args)
1408     t)
1409    (>=
1410     (compile-binary-operation "IS_GE" args)
1411     t)
1412    (=
1413     (compile-binary-operation "IS_E" args)
1414     t)
1415    (/=
1416     (compile-binary-operation "IS_NE" args)
1417     t)
1418    (AREF
1419     (compile-binary-operation "AREF" args)
1420     t)
1421    (LIST
1422     (compile-form (first args))
1423     (unless (remove-store-value)
1424       (emit-push-value))
1425     (compile-form (second args))
1426     (unless (remove-store-value)
1427       (emit-push-value))
1428     (emit-invokestatic +lisp-class+
1429                        "list2"
1430                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
1431                        -1)
1432     (emit-store-value)
1433     t)
1434    (SYS::SIMPLE-TYPEP
1435     (compile-binary-operation "typep" args))
1436    (t
1437     nil)))
1438
1439(defun compile-function-call-3 (fun args)
1440  (case fun
1441    (LIST
1442     (compile-form (first args))
1443     (unless (remove-store-value)
1444       (emit-push-value))
1445     (compile-form (second args))
1446     (unless (remove-store-value)
1447       (emit-push-value))
1448     (compile-form (third args))
1449     (unless (remove-store-value)
1450       (emit-push-value))
1451     (unless (every 'constantp args)
1452       (emit-clear-values))
1453     (emit-invokestatic +lisp-class+
1454                        "list3"
1455                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
1456                        -2)
1457     (emit-store-value)
1458     t)
1459    (t
1460     nil)))
1461
1462(defconstant +known-packages+ (list (find-package "COMMON-LISP")
1463                                    (find-package "SYSTEM")
1464                                    (find-package "EXTENSIONS")))
1465
1466(defun compile-function-call (fun args &optional for-effect)
1467;;   (format t "compile-function-call fun = ~S args = ~S~%" fun args)
1468  (unless (symbolp fun)
1469    (error "COMPILE-FUNCTION-CALL ~S is not a symbol" fun))
1470  (let ((numargs (length args))
1471        local-function)
1472    (cond ((= numargs 1)
1473           (when (compile-function-call-1 fun args)
1474             (return-from compile-function-call)))
1475          ((= numargs 2)
1476           (when (compile-function-call-2 fun args)
1477             (return-from compile-function-call)))
1478          ((= numargs 3)
1479           (when (compile-function-call-3 fun args)
1480             (return-from compile-function-call))))
1481
1482    ;; FIXME This shouldn't go here! Do this in the constructor of the
1483    ;; compiled function!
1484    (resolve fun)
1485
1486    (cond
1487     ((setf local-function
1488            (find fun *local-functions* :key #'local-function-name))
1489      (format t "compiling call to local function ~S~%" local-function)
1490      (when (local-function-args-to-add local-function)
1491        (format t "args-to-add = ~S~%" (local-function-args-to-add local-function))
1492        (setf args (append (local-function-args-to-add local-function) args))
1493        (setf numargs (length args))
1494        (format t "args = ~S~%" args))
1495      (let* ((g (declare-object (local-function-function local-function))))
1496        (emit 'getstatic
1497              *this-class*
1498              g
1499              "Lorg/armedbear/lisp/LispObject;")))
1500     ((eq fun *defun-name*)
1501      (emit 'aload 0)) ; this
1502     ((memq (symbol-package fun) +known-packages+)
1503      (let ((f (declare-function fun)))
1504        (emit 'getstatic
1505              *this-class*
1506              f
1507              "Lorg/armedbear/lisp/LispObject;")))
1508     (t
1509      (let ((g (declare-symbol fun)))
1510        (emit 'getstatic
1511              *this-class*
1512              g
1513              "Lorg/armedbear/lisp/Symbol;"))
1514      (emit-invokevirtual +lisp-symbol-class+
1515                          "getSymbolFunctionOrDie"
1516                          "()Lorg/armedbear/lisp/LispObject;"
1517                          0)))
1518    (case numargs
1519      (0
1520       (emit-invokevirtual +lisp-object-class+
1521                           "execute"
1522                           "()Lorg/armedbear/lisp/LispObject;"
1523                           0))
1524      (1
1525       (compile-form (first args))
1526       (unless (remove-store-value)
1527         (emit-push-value))
1528       (unless (constantp (first args))
1529         (emit-clear-values))
1530       (emit-invokevirtual +lisp-object-class+
1531                           "execute"
1532                           "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1533                           -1))
1534      (2
1535       (compile-form (first args))
1536       (unless (remove-store-value)
1537         (emit-push-value))
1538       (compile-form (second args))
1539       (unless (remove-store-value)
1540         (emit-push-value))
1541       (unless (every 'constantp args)
1542         (emit-clear-values))
1543       (emit-invokevirtual +lisp-object-class+
1544                           "execute"
1545                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1546                           -2))
1547      (3
1548       (compile-form (first args))
1549       (unless (remove-store-value)
1550         (emit-push-value))
1551       (compile-form (second args))
1552       (unless (remove-store-value)
1553         (emit-push-value))
1554       (compile-form (third args))
1555       (unless (remove-store-value)
1556         (emit-push-value))
1557       (unless (every 'constantp args)
1558         (emit-clear-values))
1559       (emit-invokevirtual +lisp-object-class+
1560                           "execute"
1561                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1562                           -3))
1563      (t
1564       (emit 'sipush (length args))
1565       (emit 'anewarray "org/armedbear/lisp/LispObject")
1566       (let ((i 0))
1567         (dolist (form args)
1568           (emit 'dup)
1569           (emit 'sipush i)
1570           (compile-form form)
1571           (unless (remove-store-value)
1572             (emit-push-value)) ; leaves value on stack
1573           (emit 'aastore) ; store value in array
1574           (incf i))) ; array left on stack here
1575       ;; Stack: function array-ref
1576       (unless (every 'constantp args)
1577         (emit-clear-values))
1578       (emit-invokevirtual +lisp-object-class+
1579                           "execute"
1580                           "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1581                           -1)))
1582    (if for-effect
1583        (emit 'pop)
1584        (emit-store-value))))
1585
1586(defun compile-test (form)
1587  ;; Use a Java boolean if possible.
1588  (when (consp form)
1589    (case (length form)
1590      (2 (when (memq (car form) '(NOT NULL))
1591           (compile-form (second form))
1592           (unless (remove-store-value)
1593             (emit-push-value))
1594           (emit-push-nil)
1595           (return-from compile-test 'if_acmpne))
1596         (when (eq (car form) 'SYMBOLP)
1597           (compile-form (second form))
1598           (unless (remove-store-value)
1599             (emit-push-value))
1600           (emit 'instanceof +lisp-symbol-class+)
1601           (return-from compile-test 'ifeq))
1602         (when (eq (car form) 'CONSP)
1603           (compile-form (second form))
1604           (unless (remove-store-value)
1605             (emit-push-value))
1606           (emit 'instanceof +lisp-cons-class+)
1607           (return-from compile-test 'ifeq))
1608         (when (eq (car form) 'ATOM)
1609           (compile-form (second form))
1610           (unless (remove-store-value)
1611             (emit-push-value))
1612           (emit 'instanceof +lisp-cons-class+)
1613           (return-from compile-test 'ifne))
1614         (let ((s (cdr (assq (car form)
1615                             '((EVENP     . "evenp")
1616                               (FLOATP    . "floatp")
1617                               (INTEGERP  . "integerp")
1618                               (MINUSP    . "minusp")
1619                               (LISTP     . "listp")
1620                               (NUMBERP   . "numberp")
1621                               (ODDP      . "oddp")
1622                               (PLUSP     . "plusp")
1623                               (RATIONALP . "rationalp")
1624                               (REALP     . "realp")
1625                               (VECTORP   . "vectorp")
1626                               (ZEROP     . "zerop")
1627                               )))))
1628           (when s
1629             (compile-form (second form))
1630             (unless (remove-store-value)
1631               (emit-push-value))
1632             (emit-invokevirtual +lisp-object-class+
1633                                 s
1634                                 "()Z"
1635                                 0)
1636             (return-from compile-test 'ifeq))))
1637      (3 (when (eq (car form) 'EQ)
1638           (compile-form (second form))
1639           (unless (remove-store-value)
1640             (emit-push-value))
1641           (compile-form (third form))
1642           (unless (remove-store-value)
1643             (emit-push-value))
1644           (return-from compile-test 'if_acmpne))
1645         (let ((s (cdr (assq (car form)
1646                             '((=      . "isEqualTo")
1647                               (/=     . "isNotEqualTo")
1648                               (<      . "isLessThan")
1649                               (<=     . "isLessThanOrEqualTo")
1650                               (>      . "isGreaterThan")
1651                               (>=     . "isGreaterThanOrEqualTo")
1652                               (EQL    . "eql")
1653                               (EQUAL  . "equal")
1654                               (EQUALP . "equalp")
1655                               )))))
1656           (when s
1657             (compile-form (second form))
1658             (unless (remove-store-value)
1659               (emit-push-value))
1660             (compile-form (third form))
1661             (unless (remove-store-value)
1662               (emit-push-value))
1663             (emit-invokevirtual +lisp-object-class+
1664                                 s
1665                                 "(Lorg/armedbear/lisp/LispObject;)Z"
1666                                 -1)
1667             (return-from compile-test 'ifeq))))))
1668  ;; Otherwise...
1669  (compile-form form)
1670  (unless (remove-store-value)
1671    (emit-push-value))
1672  (unless (atom form) ; FIXME There are other safe cases too!
1673    (emit-clear-values))
1674  (emit-push-nil)
1675  'if_acmpeq)
1676
1677(defun compile-if (form for-effect)
1678  (let* ((test (second form))
1679         (consequent (third form))
1680         (alternate (fourth form))
1681         (label1 (gensym))
1682         (label2 (gensym)))
1683    (emit (compile-test test) `,label1)
1684    (compile-form consequent for-effect)
1685    (emit 'goto `,label2)
1686    (emit 'label `,label1)
1687    (compile-form alternate for-effect)
1688    (emit 'label `,label2)))
1689
1690(defun compile-multiple-value-list (form for-effect)
1691  (compile-form (second form))
1692  (unless (remove-store-value)
1693    (emit-push-value))
1694  (emit-invokestatic +lisp-class+
1695                     "multipleValueList"
1696                     "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1697                     0)
1698  (emit-store-value))
1699
1700(defun compile-let/let* (form for-effect)
1701  (let* ((*variables* *variables*)
1702         (specials ())
1703         (saved-fp (fill-pointer *locals*))
1704         (varlist (cadr form))
1705         (specialp nil)
1706         env-var)
1707    ;; Process declarations.
1708    (dolist (f (cddr form))
1709      (unless (and (consp f) (eq (car f) 'declare))
1710        (return))
1711      (let ((decls (cdr f)))
1712        (dolist (decl decls)
1713          (when (eq (car decl) 'special)
1714            (setf specials (append (cdr decl) specials))))))
1715    ;; Are we going to bind any special variables?
1716    (dolist (varspec varlist)
1717      (let ((var (if (consp varspec) (car varspec) varspec)))
1718        (when (or (memq var specials) (special-variable-p var))
1719          (setq specialp t)
1720          (return))))
1721    ;; If so...
1722    (when specialp
1723      ;; Save current dynamic environment.
1724      (setf env-var (vector-push nil *locals*))
1725      (setf *max-locals* (max *max-locals* (fill-pointer *locals*)))
1726      (ensure-thread-var-initialized)
1727      (emit 'aload *thread*)
1728      (emit-invokevirtual +lisp-thread-class+
1729                          "getDynamicEnvironment"
1730                          "()Lorg/armedbear/lisp/Environment;"
1731                          0)
1732      (emit 'astore env-var))
1733    (ecase (car form)
1734      (LET
1735       (compile-let-vars varlist specials))
1736      (LET*
1737       (compile-let*-vars varlist specials)))
1738    ;; Body of LET/LET*.
1739    (emit-clear-values)
1740    (do ((body (cddr form) (cdr body)))
1741        ((null (cdr body))
1742         (compile-form (car body) for-effect))
1743      (compile-form (car body) t))
1744    (when specialp
1745      ;; Restore dynamic environment.
1746      (emit 'aload *thread*)
1747      (emit 'aload env-var)
1748      (emit-invokevirtual +lisp-thread-class+
1749                          "setDynamicEnvironment"
1750                          "(Lorg/armedbear/lisp/Environment;)V"
1751                          -2))
1752    ;; Restore fill pointer to its saved value so the slots used by these
1753    ;; bindings will again be available.
1754    (setf (fill-pointer *locals*) saved-fp)))
1755
1756(defun compile-let-vars (varlist specials)
1757;;   (format t "compile-let-vars *locals* = ~S~%" *locals*)
1758  ;; Generate code to evaluate the initforms and leave the resulting values
1759  ;; on the stack.
1760  (let ((last-push-was-nil nil))
1761    (dolist (varspec varlist)
1762      (let (var initform)
1763        (if (consp varspec)
1764            (setq var (car varspec)
1765                  initform (cadr varspec))
1766            (setq var varspec
1767                  initform nil))
1768        (cond (initform
1769               (compile-form initform)
1770               (unless (remove-store-value)
1771                 (emit-push-value))
1772               (setf last-push-was-nil nil))
1773              (t
1774               (if last-push-was-nil
1775                   (emit 'dup)
1776                   (emit-push-nil))
1777               (setf last-push-was-nil t))))))
1778  ;; Add local variables to local variables vector.
1779  (dolist (varspec varlist)
1780    (let* ((var (if (consp varspec) (car varspec) varspec))
1781           (specialp (if (or (memq var specials) (special-variable-p var)) t nil))
1782           (index (if specialp nil (fill-pointer *locals*))))
1783      (push-variable var specialp index)
1784      (unless specialp
1785;;         (format t "pushing ~S~%" var)
1786        (vector-push var *locals*)
1787;;         (format t "after push *locals* = ~S~%" *locals*)
1788        )))
1789  (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1790  ;; At this point the initial values are on the stack. Now generate code to
1791  ;; pop them off one by one and store each one in the corresponding local or
1792  ;; special variable. In order to do this, we must process the variable list
1793  ;; in reverse order.
1794  (do* ((varlist (reverse varlist) (cdr varlist))
1795        (varspec (car varlist) (car varlist)))
1796;;         (i (1- (fill-pointer *locals*)) (1- i)))
1797       ((null varlist))
1798    (let* ((var (if (consp varspec) (car varspec) varspec))
1799           (v (find-variable var)))
1800;;       (format t "varlist = ~S varspec = ~S var = ~S~%" varlist varspec var)
1801;;       (format t "processing ~S~%" var)
1802;;       (format t "var = ~S v = ~S~%" var v)
1803      (cond ((or (memq var specials) (special-variable-p var))
1804             (let ((g (declare-symbol var)))
1805               (emit 'getstatic
1806                     *this-class*
1807                     g
1808                     "Lorg/armedbear/lisp/Symbol;")
1809               (emit 'swap)
1810               (emit-invokestatic +lisp-class+
1811                                  "bindSpecialVariable"
1812                                  "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
1813                                  -2)))
1814            (t
1815             (let ((index (position var *locals* :from-end t)))
1816;;                (format t "index = ~S i = ~S~%" index i)
1817;;                (unless (= index i)
1818;;                  (format t "*locals* = ~S~%" *locals*)))
1819;;              (emit 'astore i))))))
1820               (unless index
1821                 (error "COMPILE-LET-VARS can't find local variable"))
1822               (unless (eql index (variable-index v))
1823                 (error "COMPILE-LET-VARS wrong index"))
1824               (emit 'astore index)))))))
1825
1826(defun compile-let*-vars (varlist specials)
1827  ;; Generate code to evaluate initforms and bind variables.
1828  (let ((i (fill-pointer *locals*)))
1829    (dolist (varspec varlist)
1830      (let (var initform specialp)
1831        (if (consp varspec)
1832            (setf var (car varspec)
1833                  initform (cadr varspec))
1834            (setf var varspec
1835                  initform nil))
1836        (setf specialp (if (or (memq var specials) (special-variable-p var)) t nil))
1837        (push-variable var specialp i)
1838        (cond (initform
1839               (compile-form initform)
1840               (unless (remove-store-value)
1841                 (emit-push-value)))
1842              (t
1843               (emit-push-nil)))
1844        (cond (specialp
1845               (let ((g (declare-symbol var)))
1846                 (emit 'getstatic
1847                       *this-class*
1848                       g
1849                       "Lorg/armedbear/lisp/Symbol;")
1850                 (emit 'swap)
1851                 (emit-invokestatic +lisp-class+
1852                                    "bindSpecialVariable"
1853                                    "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
1854                                    -2)))
1855              (t
1856               (emit 'astore i)
1857               (vector-push var *locals*)
1858               (incf i))))))
1859  (setq *max-locals* (max *max-locals* (fill-pointer *locals*))))
1860
1861;; Returns list of declared specials.
1862(defun process-special-declarations (forms)
1863  (let ((specials ()))
1864    (dolist (form forms)
1865      (unless (and (consp form) (eq (car form) 'declare))
1866        (return))
1867      (let ((decls (cdr form)))
1868        (dolist (decl decls)
1869          (when (eq (car decl) 'special)
1870            (setf specials (append (cdr decl) specials))))))
1871    specials))
1872
1873(defun compile-locally (form for-effect)
1874  (let ((*variables* *variables*)
1875        (specials (process-special-declarations (cdr form))))
1876    (dolist (var specials)
1877      (push-variable var t nil))
1878    (cond ((null (cdr form))
1879           (emit-push-nil)
1880           (emit-store-value))
1881          (t
1882           (do ((forms (cdr form) (cdr forms)))
1883               ((null forms))
1884             (compile-form (car forms) (cdr forms)))))))
1885
1886(defvar *tags* ())
1887
1888(defstruct tag name label)
1889
1890(defun label-for-tag (name)
1891  (let ((index (position name *tags* :from-end t :key #'tag-name)))
1892;;     (format t "find-tag index = ~S~%" index)
1893    (when index
1894      (tag-label (aref *tags* index)))))
1895
1896(defun compile-tagbody (form for-effect)
1897  (let ((saved-fp (fill-pointer *tags*))
1898        (body (cdr form)))
1899    ;; Scan for tags.
1900    (dolist (f body)
1901      (when (atom f)
1902        (let ((name f)
1903              (label (gensym)))
1904          (vector-push (make-tag :name name :label label) *tags*))))
1905    (dolist (f body)
1906      (cond ((atom f)
1907             (let ((label (label-for-tag f)))
1908               (unless label
1909                 (error "COMPILE-TAGBODY: tag not found: ~S" f))
1910               (emit 'label label)))
1911            (t
1912             (compile-form f t))))
1913    (setf (fill-pointer *tags*) saved-fp))
1914  (unless for-effect
1915    ;; TAGBODY returns NIL.
1916    (emit-clear-values)
1917    (emit-push-nil)
1918    (emit-store-value)))
1919
1920(defun compile-go (form for-effect)
1921  (let* ((name (cadr form))
1922         (label (label-for-tag name)))
1923    (unless label
1924      (error "COMPILE-GO: tag not found: ~S" name))
1925  (emit 'goto label)))
1926
1927(defun compile-atom (form for-effect)
1928  (unless (= (length form) 2)
1929    (error "wrong number of arguments for ATOM"))
1930  (compile-form (cadr form) nil)
1931  (unless (remove-store-value)
1932    (emit-push-value))
1933  (emit 'instanceof +lisp-cons-class+)
1934  (let ((label1 (gensym))
1935        (label2 (gensym)))
1936    (emit 'ifeq `,label1)
1937    (emit-push-nil)
1938    (emit 'goto `,label2)
1939    (emit 'label `,label1)
1940    (emit-push-t)
1941    (emit 'label `,label2)
1942    (emit-store-value)))
1943
1944(defun compile-block (form for-effect)
1945  (let* ((rest (cdr form))
1946         (block-label (car rest))
1947         (block-exit (gensym))
1948         (*blocks* (acons block-label block-exit *blocks*)))
1949    (do ((forms (cdr rest) (cdr forms)))
1950        ((null forms))
1951      (compile-form (car forms) (or (cdr forms) for-effect)))
1952    (emit 'label `,block-exit)))
1953
1954(defun compile-cons (form for-effect)
1955  (unless (= (length form) 3)
1956    (error "wrong number of arguments for CONS"))
1957  (emit 'new +lisp-cons-class+)
1958  (emit 'dup)
1959  (compile-form (second form))
1960  (unless (remove-store-value)
1961    (emit-push-value))
1962  (compile-form (third form))
1963  (unless (remove-store-value)
1964    (emit-push-value))
1965  (emit-invokespecial "org/armedbear/lisp/Cons"
1966                      "<init>"
1967                      "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
1968                      -3)
1969  (emit-store-value))
1970
1971(defun compile-progn (form for-effect)
1972  (cond ((null (cdr form))
1973         (emit-push-nil)
1974         (emit-store-value))
1975        (t
1976         (do ((forms (cdr form) (cdr forms)))
1977             ((null forms))
1978           (compile-form (car forms) (cdr forms))))))
1979
1980(defun compile-setq (form for-effect)
1981  (unless (= (length form) 3)
1982    (error "COMPILE-SETQ too many args for SETQ"))
1983  (let* ((rest (cdr form))
1984         (sym (car rest))
1985         (index (position sym *locals* :from-end t)))
1986    (when index
1987      (compile-form (cadr rest))
1988      (unless (remove-store-value)
1989        (emit-push-value))
1990      (cond (for-effect
1991             (emit 'astore index))
1992            (t
1993             (emit 'dup)
1994             (emit 'astore index)
1995             (emit-store-value)))
1996      (return-from compile-setq))
1997    ;; index is NIL, look in *args* ...
1998    (setq index (position sym *args*))
1999    (when index
2000      (cond (*using-arg-array*
2001             (emit 'aload 1)
2002             (emit 'bipush index)
2003             (compile-form (cadr rest))
2004             (emit-push-value)
2005             (emit 'aastore))
2006            (t
2007             (compile-form (cadr rest))
2008             (emit-push-value)
2009             (emit 'astore (1+ index))))
2010      (return-from compile-setq))
2011    ;; still not found
2012    ;; must be a global variable
2013    (let ((g (declare-symbol sym)))
2014      (emit 'getstatic
2015            *this-class*
2016            g
2017            "Lorg/armedbear/lisp/Symbol;")
2018      (compile-form (cadr rest))
2019      (unless (remove-store-value)
2020        (emit-push-value))
2021      (emit-invokestatic +lisp-class+
2022                         "setSpecialVariable"
2023                         "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2024                         -1)
2025      (emit-store-value))))
2026
2027(defun compile-quote (form for-effect)
2028   (let ((obj (second form)))
2029     (cond ((null obj)
2030            (emit-push-nil)
2031            (emit-store-value))
2032           ((symbolp obj)
2033            (if (symbol-package obj)
2034                (let ((g (declare-symbol obj)))
2035                  (emit 'getstatic
2036                        *this-class*
2037                        g
2038                        "Lorg/armedbear/lisp/Symbol;")
2039                  (emit-store-value))
2040                (compile-constant obj)))
2041           ((listp obj)
2042            (let ((g (declare-object-as-string obj)))
2043              (emit 'getstatic
2044                    *this-class*
2045                    g
2046                    +lisp-object+)
2047              (emit-store-value)))
2048           ((constantp obj)
2049            (compile-constant obj))
2050           (t
2051            (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
2052
2053(defun compile-rplacd (form for-effect)
2054  (let ((args (cdr form)))
2055    (unless (= (length args) 2)
2056      (error "wrong number of arguments for RPLACD"))
2057    (compile-form (first args))
2058    (unless (remove-store-value)
2059      (emit-push-value))
2060    (unless for-effect
2061      (emit 'dup))
2062    (compile-form (second args))
2063    (unless (remove-store-value)
2064      (emit-push-value))
2065    (emit-invokevirtual +lisp-object-class+
2066                        "setCdr"
2067                        "(Lorg/armedbear/lisp/LispObject;)V"
2068                        -2)
2069    (unless for-effect
2070      (emit-store-value))))
2071
2072(defun compile-declare (form for-effect)
2073  ;; Nothing to do.
2074  )
2075
2076(defun compile-local-function-def (def)
2077  (format t "*locals* = ~S~%" *locals*)
2078  (format t "*args* = ~S~%" *args*)
2079  (let* ((name (car def))
2080         (arglist (cadr def))
2081         (body (cddr def))
2082         (form (list* 'lambda arglist body))
2083         (args-to-add (remove-duplicates (union (remove nil (coerce *locals* 'list))
2084                                                (remove nil (coerce *args* 'list))))))
2085    (format t "form = ~S~%" form)
2086    (format t "args-to-add = ~S~%" args-to-add)
2087    (format t "new arglist = ~S~%" (append args-to-add arglist))
2088    (when args-to-add
2089      (setf arglist (append args-to-add arglist))
2090      (setf form (list* 'lambda arglist body)))
2091    (format t "form = ~S~%" form)
2092    (setf function (compile-defun name form "flet.out"))
2093    (format t "function = ~S~%" function)
2094    (push (make-local-function :name name
2095                               :args-to-add args-to-add
2096                               :function function)
2097          *local-functions*)))
2098
2099(defun compile-local-functions (defs)
2100  (dolist (def defs)
2101    (compile-local-function-def def)))
2102
2103(defun compile-flet (form for-effect)
2104  (if nil
2105      (let ((*local-functions* *local-functions*)
2106            (locals (cadr form))
2107            (body (cddr form)))
2108        (compile-local-functions locals)
2109        (do ((forms body (cdr forms)))
2110            ((null forms))
2111          (compile-form (car forms) (cdr forms))))
2112      (error "COMPILE-FLET: unsupported case")))
2113
2114(defun compile-function (form for-effect)
2115   (let ((obj (second form)))
2116     (cond ((symbolp obj)
2117            (let ((g (declare-symbol obj)))
2118              (emit 'getstatic
2119                    *this-class*
2120                    g
2121                    "Lorg/armedbear/lisp/Symbol;")
2122              (emit-invokevirtual +lisp-object-class+
2123                                  "getSymbolFunctionOrDie"
2124                                  "()Lorg/armedbear/lisp/LispObject;"
2125                                  0)
2126              (emit-store-value)))
2127           #+nil
2128           ((and (consp obj) (eq (car obj) 'LAMBDA))
2129            ;; FIXME We need to construct a proper lexical environment here
2130            ;; and pass it to coerceToFunction().
2131            (let ((g (declare-object-as-string obj)))
2132              (emit 'getstatic
2133                    *this-class*
2134                    g
2135                    +lisp-object+)
2136              (emit-invokestatic +lisp-class+
2137                                 "coerceToFunction"
2138                                 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Function;"
2139                                 0)
2140              (emit-store-value)))
2141           (t
2142            (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
2143
2144(defun compile-return-from (form for-effect)
2145   (let* ((rest (cdr form))
2146          (block-label (car rest))
2147          (block-exit (cdr (assoc block-label *blocks*)))
2148          (result-form (cadr rest)))
2149     (unless block-exit
2150       (error "no block named ~S is currently visible" block-label))
2151     (compile-form result-form)
2152     (emit 'goto `,block-exit)))
2153
2154(defun compile-plus (form for-effect)
2155  (let* ((args (cdr form))
2156         (len (length args)))
2157    (case len
2158      (2
2159       (let ((first (first args))
2160             (second (second args)))
2161         (cond
2162          ((eql first 1)
2163           (compile-form second)
2164           (emit-invoke-method "incr"))
2165          ((eql second 1)
2166           (compile-form first)
2167           (emit-invoke-method "incr"))
2168          (t
2169           (compile-binary-operation "add" args)))))
2170      (t
2171       (compile-function-call '+ args)))))
2172
2173(defun compile-minus (form for-effect)
2174  (let* ((args (cdr form))
2175         (len (length args)))
2176    (case len
2177      (2
2178       (let ((first (first args))
2179             (second (second args)))
2180         (cond
2181          ((eql second 1)
2182           (compile-form first)
2183           (emit-invoke-method "decr"))
2184          (t
2185           (compile-binary-operation "subtract" args)))))
2186      (t
2187       (compile-function-call '- args)))))
2188
2189(defun compile-values (form for-effect)
2190  (let ((args (cdr form)))
2191    (cond ((= (length args) 2)
2192           (ensure-thread-var-initialized)
2193           (emit 'aload *thread*)
2194           (cond ((and (eq (car args) t)
2195                       (eq (cadr args) t))
2196                  (emit-push-t)
2197                  (emit 'dup))
2198                 ((and (eq (car args) nil)
2199                       (eq (cadr args) nil))
2200                  (emit-push-nil)
2201                  (emit 'dup))
2202                 (t
2203                  (compile-form (car args))
2204                  (unless (remove-store-value)
2205                    (emit-push-value))
2206                  (compile-form (cadr args))
2207                  (unless (remove-store-value)
2208                    (emit-push-value))))
2209           (emit-invokevirtual +lisp-thread-class+
2210                               "setValues"
2211                               "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2212                               -2)
2213           (emit-store-value))
2214          (t
2215           (compile-function-call (car form) (cdr form))))))
2216
2217(defun compile-variable-ref (form)
2218  (let ((v (find-variable form)))
2219    (unless (and v (variable-special-p v))
2220      (let ((index (position form *locals* :from-end t)))
2221        (when index
2222          (emit 'aload index)
2223          (emit-store-value)
2224          (return-from compile-variable-ref)))
2225      ;; Not found in locals; look in args.
2226      (let ((index (position form *args*)))
2227        (when index
2228          (cond (*using-arg-array*
2229                 (emit 'aload 1)
2230                 (emit 'bipush index)
2231                 (emit 'aaload)
2232                 (emit-store-value)
2233                 (return-from compile-variable-ref))
2234                (t
2235                 (emit 'aload (1+ index))
2236                 (emit-store-value)
2237                 (return-from compile-variable-ref))))))
2238    ;; Otherwise it must be a global variable.
2239    (let ((g (declare-symbol form)))
2240      (emit 'getstatic
2241            *this-class*
2242            g
2243            "Lorg/armedbear/lisp/Symbol;")
2244      (emit-invokevirtual +lisp-symbol-class+
2245                          "symbolValue"
2246                          "()Lorg/armedbear/lisp/LispObject;"
2247                          0)
2248      (emit-store-value)
2249      (return-from compile-variable-ref))))
2250
2251;; If for-effect is true, no value needs to be left on the stack.
2252(defun compile-form (form &optional for-effect)
2253  (cond
2254   ((consp form)
2255    (let ((op (car form))
2256          (args (cdr form)))
2257      (when (macro-function op)
2258        (compile-form (macroexpand form))
2259        (return-from compile-form))
2260      (when (symbolp op)
2261        (let ((handler (get op 'jvm-compile-handler)))
2262          (when handler
2263            (funcall handler form for-effect)
2264            (return-from compile-form))))
2265      (cond
2266       ((special-operator-p op)
2267        (error "COMPILE-FORM unsupported special operator ~S" op))
2268       (t ; Function call.
2269        (compile-function-call op args for-effect)))))
2270   ((eq form '())
2271    (unless for-effect
2272      (emit-push-nil)
2273      (emit-store-value)))
2274   ((eq form t)
2275    (unless for-effect
2276      (emit-push-t)
2277      (emit-store-value)))
2278   ((symbolp form)
2279    (when (keywordp form)
2280      (let ((g (declare-keyword form)))
2281        (emit 'getstatic
2282              *this-class*
2283              g
2284              "Lorg/armedbear/lisp/Symbol;"))
2285      (emit-store-value)
2286      (return-from compile-form))
2287
2288    (compile-variable-ref form))
2289   ((constantp form)
2290    (unless for-effect
2291      (compile-constant form)))
2292   (t
2293    (error "COMPILE-FORM unhandled case ~S" form))))
2294
2295;; Returns descriptor.
2296(defun analyze-args (args)
2297  (assert (not (memq '&AUX args)))
2298  (when (or (memq '&KEY args)
2299            (memq '&OPTIONAL args)
2300            (memq '&REST args))
2301    (setq *using-arg-array* t)
2302    (setq *hairy-arglist-p* t)
2303    (return-from analyze-args #.(format nil "([~A)~A" +lisp-object+ +lisp-object+)))
2304  (case (length args)
2305    (0 #.(format nil "()~A" +lisp-object+))
2306    (1 #.(format nil "(~A)~A" +lisp-object+ +lisp-object+))
2307    (2 #.(format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
2308    (3 #.(format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
2309    (t (setq *using-arg-array* t)
2310       #.(format nil "([~A)~A" +lisp-object+ +lisp-object+))))
2311
2312(defun compile-defun (name form &optional (classfile "out.class"))
2313  (unless (eq (car form) 'LAMBDA)
2314    (return-from compile-defun nil))
2315  (setf form (precompile-form form t))
2316  (let* ((*defun-name* name)
2317         (*declared-symbols* (make-hash-table))
2318         (*declared-functions* (make-hash-table))
2319         (*this-class* "org/armedbear/lisp/out")
2320         (args (cadr form))
2321         (body (cddr form))
2322         (*using-arg-array* nil)
2323         (*hairy-arglist-p* nil)
2324         (descriptor (analyze-args args))
2325         (execute-method (make-method :name "execute"
2326                                      :descriptor descriptor))
2327         (*code* ())
2328         (*static-code* ())
2329         (*fields* ())
2330         (*blocks* ())
2331         (*tags* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
2332         (*args* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
2333         (*locals* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
2334         (*max-locals* 0)
2335         (*variables* ())
2336         (*pool* ())
2337         (*pool-count* 1)
2338         (*val* nil)
2339         (*thread* nil)
2340         (*thread-var-initialized* nil))
2341    (setf (method-name-index execute-method)
2342          (pool-name (method-name execute-method)))
2343    (setf (method-descriptor-index execute-method)
2344          (pool-name (method-descriptor execute-method)))
2345    (if *hairy-arglist-p*
2346        (let* ((fun (sys::make-compiled-function nil args body))
2347               (vars (sys::varlist fun)))
2348          (dolist (var vars)
2349            (vector-push var *args*)))
2350        (dolist (arg args)
2351          (vector-push arg *args*)))
2352    (if *using-arg-array*
2353        ;; Using arg array: slot 0 is "this" pointer, slot 1 is arg array,
2354        ;; first available slot is 2.
2355        (setf (fill-pointer *locals*) 2)
2356        ;; Not using arg array: slot 0 is "this" pointer, next N slots are used
2357        ;; for args.
2358        (setf (fill-pointer *locals*) (1+ (length args))))
2359    ;; Reserve the next available slot for the value register.
2360    (setq *val* (fill-pointer *locals*))
2361    (incf (fill-pointer *locals*))
2362    (setf *max-locals* (fill-pointer *locals*))
2363    ;; Reserve the next available slot for the thread register.
2364    (setq *thread* (fill-pointer *locals*))
2365    (incf (fill-pointer *locals*))
2366    (setf *max-locals* (fill-pointer *locals*))
2367    (when *hairy-arglist-p*
2368      (emit 'aload_0)
2369      (emit 'aload_1)
2370      (emit-invokevirtual *this-class*
2371                          "processArgs"
2372                          "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;"
2373                          -1)
2374      (emit 'astore_1))
2375    (dolist (f body)
2376      (compile-form f))
2377    (unless (remove-store-value)
2378      (emit-push-value)) ; leave result on stack
2379    (emit 'areturn)
2380    (finalize-code)
2381    (optimize-code)
2382    (setf (method-max-stack execute-method) (analyze-stack))
2383    (setf (method-code execute-method) (code-bytes *code*))
2384;;     (setf (method-max-stack execute-method) *max-stack*)
2385    (setf (method-max-locals execute-method) *max-locals*)
2386
2387    (let* ((super
2388            (if *hairy-arglist-p*
2389                "org.armedbear.lisp.CompiledFunction"
2390                (case (length args)
2391                  (0 "org.armedbear.lisp.Primitive0")
2392                  (1 "org.armedbear.lisp.Primitive1")
2393                  (2 "org.armedbear.lisp.Primitive2")
2394                  (3 "org.armedbear.lisp.Primitive3")
2395                  (t "org.armedbear.lisp.Primitive"))))
2396           (this-index (pool-class *this-class*))
2397           (super-index (pool-class super))
2398           (constructor (make-constructor super *defun-name* args body)))
2399      (pool-name "Code") ; Must be in pool!
2400
2401      ;; Write class file.
2402      (with-open-file (*stream* classfile
2403                                :direction :output
2404                                :element-type 'unsigned-byte
2405                                :if-exists :supersede)
2406        (write-u4 #xCAFEBABE)
2407        (write-u2 3)
2408        (write-u2 45)
2409        (write-pool)
2410        ;; access flags
2411        (write-u2 #x21)
2412        (write-u2 this-index)
2413        (write-u2 super-index)
2414        ;; interfaces count
2415        (write-u2 0)
2416        ;; fields count
2417        (write-u2 (length *fields*))
2418        ;; fields
2419        (dolist (field *fields*)
2420          (write-field field))
2421        ;; methods count
2422        (write-u2 2)
2423        ;; methods
2424        (write-method execute-method)
2425        (write-method constructor)
2426        ;; attributes count
2427        (write-u2 0))))
2428  (sys::load-compiled-function classfile))
2429
2430(defun get-lambda-to-compile (definition-designator)
2431  (if (and (consp definition-designator)
2432           (eq (car definition-designator) 'LAMBDA))
2433      definition-designator
2434      (multiple-value-bind (lambda-expression closure-p)
2435        (function-lambda-expression definition-designator)
2436        (when closure-p
2437          (error "unable to compile function defined in non-null lexical environment"))
2438  (unless lambda-expression
2439    (error "can't find a definition"))
2440        lambda-expression)))
2441
2442(defun load-verbose-prefix ()
2443  (with-output-to-string (s)
2444    (princ #\; s)
2445    (dotimes (i (1- sys::*load-depth*))
2446      (princ #\space s))))
2447
2448(defvar *compile-print* t)
2449
2450(defun jvm-compile (name &optional definition)
2451  (let ((prefix (load-verbose-prefix)))
2452    (when *compile-print*
2453      (if name
2454          (progn
2455            (%format t "~A Compiling ~S ...~%" prefix name)
2456            (when (and (fboundp name) (typep (fdefinition name) 'generic-function))
2457              (%format t "~A Unable to compile generic function ~S~%" prefix name)
2458              (return-from jvm-compile (values name nil t)))
2459            (unless (symbolp name)
2460              (%format t "~A Unable to compile ~S~%" prefix name)
2461              (return-from jvm-compile (values name nil t))))
2462          (%format t "~A Compiling top-level form ...~%" prefix)))
2463    (unless definition
2464      (resolve name)
2465      (setf definition (fdefinition name))
2466      (when (compiled-function-p definition)
2467        (when (and *compile-print* name)
2468          (%format t "~A Already compiled ~S~%" prefix name))
2469        (return-from jvm-compile (values name nil nil))))
2470    (handler-case
2471        (let* ((*package* (if (and name (symbol-package name))
2472                              (symbol-package name)
2473                              *package*))
2474               (expr (get-lambda-to-compile definition))
2475               (compiled-definition (compile-defun name expr)))
2476          (when (and name (functionp compiled-definition))
2477            (sys::%set-lambda-name compiled-definition name)
2478            (sys::%set-call-count compiled-definition (sys::%call-count definition))
2479            (sys::%set-arglist compiled-definition (sys::arglist definition))
2480            (if (macro-function name)
2481                (setf (fdefinition name) (sys::make-macro compiled-definition))
2482                (setf (fdefinition name) compiled-definition)))
2483          (when *compile-print*
2484            (if name
2485                (%format t "~A Compiled ~S~%" prefix name)
2486                (%format t "~A Compiled top-level form~%" prefix)))
2487          (values (or name compiled-definition) nil nil))
2488      (error (c)
2489             (%format t "Error: ~A~%" c)
2490             (when name
2491               (%format t "~A Unable to compile ~S~%" prefix name))
2492             (values (or name (sys::coerce-to-function definition)) nil t)))))
2493
2494(defun jvm-compile-package (package-designator)
2495  (let ((pkg (if (packagep package-designator)
2496                 package-designator
2497                 (find-package package-designator))))
2498      (dolist (sym (sys::package-symbols pkg))
2499        (when (fboundp sym)
2500          (unless (or (special-operator-p sym) (macro-function sym))
2501            ;; Force autoload to be resolved.
2502            (resolve sym)
2503            (let ((f (fdefinition sym)))
2504              (unless (compiled-function-p f)
2505                (jvm-compile sym)))))))
2506  t)
2507
2508(defun install-handler (fun &optional handler)
2509  (let ((handler (or handler
2510                     (find-symbol (concatenate 'string "COMPILE-" (symbol-name fun)) 'jvm))))
2511    (unless (and handler (fboundp handler))
2512      (error "no handler for ~S" fun))
2513    (setf (get fun 'jvm-compile-handler) handler)))
2514
2515(mapc #'install-handler '(atom
2516                          block
2517                          cons
2518                          declare
2519                          flet
2520                          function
2521                          go
2522                          if
2523                          locally
2524                          multiple-value-list
2525                          progn
2526                          quote
2527                          return-from
2528                          rplacd
2529                          setq
2530                          tagbody
2531                          values))
2532
2533(install-handler 'let  'compile-let/let*)
2534(install-handler 'let* 'compile-let/let*)
2535(install-handler '+    'compile-plus)
2536(install-handler '-    'compile-minus)
2537
2538(defun process-optimization-declarations (forms)
2539  (let (alist ())
2540    (dolist (form forms)
2541      (unless (and (consp form) (eq (car form) 'declare))
2542        (return))
2543      (let ((decl (cadr form)))
2544        (when (eq (car decl) 'optimize)
2545          (dolist (spec (cdr decl))
2546            (let ((val 3)
2547                  (quantity spec))
2548              (if (consp spec)
2549                  (setq quantity (car spec) val (cadr spec)))
2550              (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
2551                  (push (cons quantity val) alist)))))))
2552    alist))
2553
2554(defun compile (name &optional definition)
2555  (when (consp name)
2556    (return-from compile (values name nil nil)))
2557  (when (and name (fboundp name) (typep (symbol-function name) 'generic-function))
2558    (return-from compile (values name nil nil)))
2559  (unless definition
2560    (setq definition (or (and (symbolp name) (macro-function name))
2561                         (fdefinition name))))
2562  (when (compiled-function-p definition)
2563    (return-from compile (values name nil nil)))
2564  (let ((expr (get-lambda-to-compile definition))
2565        (speed nil))
2566    (when (eq (car expr) 'lambda)
2567      (let ((decls (process-optimization-declarations (cddr expr))))
2568        (setf speed (cdr (assoc 'speed decls)))))
2569    (if (or (eql speed 3)
2570            (and (null speed) *auto-compile*))
2571        (progn
2572          (precompile name definition)
2573          (jvm-compile name definition))
2574        (progn
2575          (precompile name definition)
2576          ))))
2577
2578(defmacro defun (name lambda-list &rest body)
2579  `(progn
2580     (sys::%defun ',name ',lambda-list ',body)
2581     (compile ',name)
2582     ',name))
2583
2584(let ((*auto-compile* nil))
2585  (mapc #'jvm-compile '(pool-add
2586                        pool-find-entry
2587                        pool-name
2588                        pool-get
2589                        compile-form)))
Note: See TracBrowser for help on using the repository browser.