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

Last change on this file since 4668 was 4668, checked in by piso, 18 years ago

We don't need COMPILE-RETURN, since RETURN is a macro.

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