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

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

Work in progress (tested).

File size: 220.0 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: jvm.lisp,v 1.355 2005-01-17 16:34:39 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 "EXT")
21
22(export 'defsubst)
23
24(in-package "JVM")
25
26(export '(compile-defun *catch-errors* jvm-compile jvm-compile-package))
27
28(import '(sys::%format
29          sys::source-transform
30          sys::define-source-transform
31          sys::expand-source-transform))
32
33(require :source-transform)
34
35(require '#:opcodes)
36
37(shadow '(method variable))
38
39(defparameter *trust-user-type-declarations* t)
40
41(defvar *closure-variables* nil)
42
43(defvar *enable-dformat* nil)
44
45(defun dformat (destination control-string &rest args)
46  (when *enable-dformat*
47    (apply #'sys::%format destination control-string args)))
48
49(defun inline-expansion (name)
50  (let ((info (sys::function-info name)))
51    (and info (getf info :inline-expansion))))
52
53(defun (setf inline-expansion) (expansion name)
54  (let ((info (sys::function-info name)))
55    (setf info (sys::%putf info :inline-expansion expansion))
56    (setf (sys::function-info name) info))
57  expansion)
58
59;; Just an experiment...
60(defmacro defsubst (name lambda-list &rest body)
61  `(progn
62     (sys::%defun ',name ',lambda-list ',body)
63     (precompile ',name)
64     (setf (inline-expansion ',name)
65           (precompile-form (list* 'LAMBDA ',lambda-list ',body) t))
66     ',name))
67#+nil
68(defmacro defsubst (&rest args)
69  `(defun ,@args))
70
71;; (defvar *use-locals-vector* nil)
72
73(defvar *compiler-debug* nil)
74
75(defstruct compiland
76  name
77  lambda-expression
78  arg-vars
79  p1-result
80  classfile
81  parent
82  (children 0) ; Number of local functions defined with FLET or LABELS.
83  contains-lambda
84  argument-register
85  closure-register
86  )
87
88(defvar *current-compiland* nil)
89
90(defvar *pool* nil)
91(defvar *pool-count* 1)
92(defvar *pool-entries* nil)
93
94;; (defvar *stream* nil)
95(defvar *this-class* nil)
96
97(defvar *code* ())
98(defvar *static-code* ())
99(defvar *fields* ())
100
101;; All tags visible at the current point of compilation, some of which may not
102;; be in the current compiland.
103(defvar *visible-tags* ())
104
105;; Next available register.
106(defvar *register* 0)
107
108;; Total number of registers allocated.
109(defvar *registers-allocated* 0)
110
111(defvar *handlers* ())
112
113(defstruct handler
114  from
115  to
116  code
117  catch-type)
118
119;; Variables visible at the current point of compilation.
120(defvar *visible-variables* ())
121
122;; All variables seen so far.
123(defvar *all-variables* ())
124
125;; Undefined variables that we've already warned about.
126(defvar *undefined-variables* ())
127
128(defvar *dump-variables* nil)
129
130(defun dump-1-variable (variable)
131  (%format t "  ~S special-p = ~S register = ~S level = ~S index = ~S declared-type = ~S~%"
132           (variable-name variable)
133           (variable-special-p variable)
134           (variable-register variable)
135           (variable-level variable)
136           (variable-index variable)
137           (variable-declared-type variable)))
138
139(defun dump-variables (list caption &optional (force nil))
140  (when (or force *dump-variables*)
141    (write-string caption)
142    (if list
143        (dolist (variable list)
144          (dump-1-variable variable))
145        (%format t "  None.~%"))))
146
147(defstruct variable
148  name
149  initform
150  temp-register
151  special-p
152  (declared-type t)
153  representation ; NIL (i.e. a LispObject reference) or :UNBOXED-FIXNUM
154  register ; register number or NIL
155  index
156  closure-index
157  (reads 0)
158  (writes 0)
159  used-non-locally-p
160  (compiland *current-compiland*))
161
162;; obj can be a symbol or variable
163;; returns variable or nil
164(defun unboxed-fixnum-variable (obj)
165  (cond
166   ((symbolp obj)
167    (let ((variable (find-visible-variable obj)))
168      (if (and variable
169               (eq (variable-representation variable) :unboxed-fixnum))
170          variable
171          nil)))
172   ((variable-p obj)
173    (if (eq (variable-representation obj) :unboxed-fixnum)
174        obj
175        nil))
176   (t
177    nil)))
178
179(defun arg-is-fixnum-p (arg)
180  (or (fixnump arg)
181      (unboxed-fixnum-variable arg)))
182
183;; True for local functions defined with FLET or LABELS.
184(defvar *child-p* nil)
185
186(defvar *child-count* 0)
187
188(defun find-visible-variable (name)
189  (dolist (variable *visible-variables*)
190    (when (eq name (variable-name variable))
191      (return variable))))
192
193(defun unboxed-fixnum-variable-p (obj)
194;;   (let ((variable (and (symbolp obj)
195;;                        (find-visible-variable obj))))
196;;     (and variable
197;;          (eq (variable-representation variable) :unboxed-fixnum))))
198  (unboxed-fixnum-variable obj))
199
200(defun allocate-register ()
201  (let* ((register *register*)
202         (next-register (1+ register)))
203    (declare (type fixnum register next-register))
204    (setf *register* next-register)
205    (when (< *registers-allocated* next-register)
206      (setf *registers-allocated* next-register))
207    register))
208
209(defstruct local-function
210  name
211  compiland
212  function
213  classfile
214  variable)
215
216(defvar *local-functions* ())
217
218(defun find-local-function (name)
219  (find name *local-functions* :key #'local-function-name))
220
221(defvar *using-arg-array* nil)
222(defvar *hairy-arglist-p* nil)
223(defvar *arity* nil)
224
225(defvar *val* nil) ; index of value register
226
227(defstruct node
228  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
229  name
230  form
231  (compiland *current-compiland*))
232
233;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as
234;; BLOCKs per se.
235(defstruct (block-node (:conc-name block-) (:include node))
236  (exit (gensym))
237  target
238  catch-tag
239  ;; True if there is any RETURN from this block.
240  return-p
241  ;; True if there is a non-local RETURN from this block.
242  non-local-return-p
243  ;; True if a tag in this tagbody is the target of a non-local GO.
244  non-local-go-p
245  ;; If non-nil, register containing saved dynamic environment for this block.
246  environment-register
247  ;; Only used in LET/LET*/M-V-B nodes.
248  vars
249  free-specials
250  )
251
252(defun node-constant-p (object)
253  (cond ((block-node-p object)
254         nil)
255        ((constantp object)
256         t)
257        (t
258         nil)))
259
260(defvar *blocks* ())
261
262(defun find-block (name)
263  (dolist (block *blocks*)
264    (when (eq name (block-name block))
265      (return block))))
266
267(defstruct tag
268  name
269  label
270  block
271  (compiland *current-compiland*))
272
273;;; Pass 1.
274
275(defun p1-let-vars (varlist)
276  (let ((vars ()))
277    (dolist (varspec varlist)
278      (cond ((consp varspec)
279             (let ((name (car varspec))
280                   (initform (p1 (cadr varspec))))
281               (push (make-variable :name name :initform initform) vars)))
282            (t
283             (push (make-variable :name varspec) vars))))
284    (setf vars (nreverse vars))
285    (dolist (variable vars)
286      (push variable *visible-variables*)
287      (push variable *all-variables*))
288    vars))
289
290(defun p1-let*-vars (varlist)
291  (let ((vars ()))
292    (dolist (varspec varlist)
293      (cond ((consp varspec)
294             (let* ((name (car varspec))
295                    (initform (p1 (cadr varspec)))
296                    (var (make-variable :name name :initform initform)))
297               (push var vars)
298               (push var *visible-variables*)
299               (push var *all-variables*)))
300            (t
301             (let ((var (make-variable :name varspec)))
302               (push var vars)
303               (push var *visible-variables*)
304               (push var *all-variables*)))))
305    (nreverse vars)))
306
307(defun p1-let/let* (form)
308  (let* ((*visible-variables* *visible-variables*)
309         (block (make-block-node :name '(LET)))
310         (*blocks* (cons block *blocks*))
311         (op (car form))
312         (varlist (cadr form))
313         (body (cddr form)))
314    (aver (or (eq op 'LET) (eq op 'LET*)))
315    (when (eq op 'LET)
316      ;; Convert to LET* if possible.
317      (dolist (varspec varlist (setf op 'LET*))
318        (or (atom varspec)
319            (constantp (cadr varspec))
320            (eq (car varspec) (cadr varspec))
321            (return nil))))
322    (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist)))
323          (free-specials '()))
324      (dformat t "p1-let/let* vars = ~S~%" (mapcar #'variable-name vars))
325      ;; Check for globally declared specials.
326      (dolist (variable vars)
327        (when (special-variable-p (variable-name variable))
328          (setf (variable-special-p variable) t)))
329      ;; Process declarations.
330      (dolist (subform body)
331        (unless (and (consp subform) (eq (car subform) 'DECLARE))
332          (return))
333        (let ((decls (cdr subform)))
334          (dolist (decl decls)
335            (case (car decl)
336              (SPECIAL
337               (dolist (sym (cdr decl))
338;;                  (dolist (variable vars)
339;;                    (when (eq sym (variable-name variable))
340;;                      (setf (variable-special-p variable) t)))
341                 (let ((variable (find sym vars :key #'variable-name)))
342                   (cond (variable
343                          (setf (variable-special-p variable) t))
344                         (t
345                          (dformat t "adding free special ~S~%" sym)
346                          (push (make-variable :name sym :special-p t) free-specials))))
347                 ))
348              (TYPE
349               (dolist (sym (cddr decl))
350                 (dolist (variable vars)
351                   (when (eq sym (variable-name variable))
352                     (setf (variable-declared-type variable) (cadr decl))))))))))
353      (setf (block-vars block) vars)
354      (setf (block-free-specials block) free-specials))
355    (setf body (mapcar #'p1 body))
356    (setf (block-form block) (list* op varlist body))
357    block))
358
359(defun p1-m-v-b (form)
360;;   (dformat t "p1-multiple-value-bind~%")
361  (let* ((*visible-variables* *visible-variables*)
362         (block (make-block-node :name '(MULTIPLE-VALUE-BIND)))
363         (*blocks* (cons block *blocks*))
364         (varlist (cadr form))
365         (values-form (caddr form))
366         (body (cdddr form)))
367    ;; Process the values-form first. ("The scopes of the name binding and
368    ;; declarations do not include the values-form.")
369    (setf values-form (p1 values-form))
370    (let ((vars ()))
371      (dolist (symbol varlist)
372        (let ((var (make-variable :name symbol)))
373          (push var vars)
374          (push var *visible-variables*)
375          (push var *all-variables*)))
376      ;; Check for globally declared specials.
377      (dolist (variable vars)
378        (when (special-variable-p (variable-name variable))
379          (setf (variable-special-p variable) t)))
380      ;; Process declarations.
381      (dolist (subform body)
382        (unless (and (consp subform) (eq (car subform) 'DECLARE))
383          (return))
384        (let ((decls (cdr subform)))
385          (dolist (decl decls)
386            (case (car decl)
387              (SPECIAL
388               (dolist (sym (cdr decl))
389                 (dolist (variable vars)
390                   (when (eq sym (variable-name variable))
391                     (setf (variable-special-p variable) t)))))
392              (TYPE
393               (dolist (sym (cddr decl))
394                 (dolist (variable vars)
395                   (when (eq sym (variable-name variable))
396                     (setf (variable-declared-type variable) (cadr decl))))))))))
397      (setf (block-vars block) (nreverse vars)))
398    (setf body (mapcar #'p1 body))
399    (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
400    block))
401
402(defun p1-block (form)
403  (let* ((block (make-block-node :name (cadr form)))
404         (*blocks* (cons block *blocks*)))
405    (setf (block-form block) (list* 'BLOCK (cadr form) (mapcar #'p1 (cddr form))))
406    block))
407
408(defun p1-return-from (form)
409  (let* ((name (second form))
410         (result-form (third form))
411         (block (find-block name)))
412    (cond ((null block)
413           (error "P1-RETURN-FROM: no block named ~S is currently visible." name))
414          ((eq (block-compiland block) *current-compiland*)
415           (setf (block-return-p block) t))
416          (t
417           (setf (block-return-p block) t)
418           (setf (block-non-local-return-p block) t))))
419  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
420
421(defun p1-tagbody (form)
422  (let* ((block (make-block-node :name '(TAGBODY)))
423         (*blocks* (cons block *blocks*))
424         (*visible-tags* *visible-tags*)
425         (body (cdr form)))
426    ;; Make all the tags visible before processing the body forms.
427    (dolist (subform body)
428      (when (or (symbolp subform) (integerp subform))
429        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
430          (push tag *visible-tags*))))
431    (let ((new-body '()))
432      (dolist (subform body)
433        (push (if (or (symbolp subform) (integerp subform))
434                  subform
435                  (p1 subform))
436              new-body))
437      (setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
438    block))
439
440(defun p1-go (form)
441  (let* ((name (cadr form))
442         (tag (find-tag name)))
443    (unless tag
444      (error "p1-go: tag not found: ~S" name))
445    (unless (eq (tag-compiland tag) *current-compiland*)
446      (setf (block-non-local-go-p (tag-block tag)) t)))
447  form)
448
449(defun p1-flet (form)
450;;   (when *current-compiland*
451    (incf (compiland-children *current-compiland*) (length (cadr form)))
452;;     )
453  (let ((*current-compiland* *current-compiland*)
454        (compilands ()))
455    (dolist (definition (cadr form))
456      (let* ((name (car definition))
457             (lambda-list (cadr definition))
458             (body (cddr definition))
459             (compiland (make-compiland :name name
460                                        :parent *current-compiland*)))
461        (multiple-value-bind (body decls)
462            (sys::parse-body body)
463          (setf (compiland-lambda-expression compiland)
464                `(lambda ,lambda-list ,@decls (block ,name ,@body)))
465          (let ((*visible-variables* *visible-variables*)
466                (*current-compiland* compiland))
467            (p1-compiland compiland)))
468        (push compiland compilands)))
469  (list* (car form) (nreverse compilands) (mapcar #'p1 (cddr form)))))
470
471(defun p1-labels (form)
472  (incf (compiland-children *current-compiland*) (length (cadr form)))
473  (let ((*visible-variables* *visible-variables*)
474        (*local-functions* *local-functions*)
475        (*current-compiland* *current-compiland*)
476        (local-functions ()))
477    (dolist (definition (cadr form))
478      (let* ((name (car definition))
479             (lambda-list (cadr definition))
480             (body (cddr definition))
481             (compiland (make-compiland :name name
482                                        :parent *current-compiland*))
483             (variable (make-variable :name (copy-symbol name)))
484             (local-function (make-local-function :name name
485                                                  :compiland compiland
486                                                  :variable variable)))
487        (multiple-value-bind (body decls)
488          (sys::parse-body body)
489          (setf (compiland-lambda-expression compiland)
490                `(lambda ,lambda-list ,@decls (block ,name ,@body))))
491        (push variable *all-variables*)
492        (push local-function local-functions)))
493    (setf local-functions (nreverse local-functions))
494    ;; Make the local functions visible.
495    (dolist (local-function local-functions)
496      (push local-function *local-functions*)
497      (push (local-function-variable local-function) *visible-variables*))
498    (dolist (local-function local-functions)
499      (let ((*visible-variables* *visible-variables*)
500            (*current-compiland* (local-function-compiland local-function)))
501        (p1-compiland (local-function-compiland local-function))))
502    (list* (car form) local-functions (mapcar #'p1 (cddr form)))))
503
504(defun p1-function (form)
505  (let (local-function)
506    (cond ((and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
507           (when *current-compiland*
508             (incf (compiland-children *current-compiland*)))
509           (let* ((*current-compiland* *current-compiland*)
510                  (lambda-form (cadr form))
511                  (lambda-list (cadr lambda-form))
512                  (body (cddr lambda-form))
513                  (compiland (make-compiland :name (gensym "ANONYMOUS-LAMBDA-")
514                                             :lambda-expression lambda-form
515                                             :parent *current-compiland*)))
516             (multiple-value-bind (body decls)
517               (sys::parse-body body)
518               (setf (compiland-lambda-expression compiland)
519                     `(lambda ,lambda-list ,@decls (block nil ,@body)))
520               (let ((*visible-variables* *visible-variables*)
521                     (*current-compiland* compiland))
522                 (p1-compiland compiland)))
523             (list 'FUNCTION compiland)))
524          ((setf local-function (find-local-function (cadr form)))
525           (dformat t "p1-function local function ~S~%" (cadr form))
526           (let ((variable (local-function-variable local-function)))
527             (when variable
528               (unless (or (eq (variable-compiland variable) *current-compiland*)
529                           (eq (local-function-compiland local-function) *current-compiland*))
530                 (dformat t "p1-function ~S used non-locally~%" (variable-name variable))
531                 (setf (variable-used-non-locally-p variable) t))))
532           form)
533          (t
534           form))))
535
536(defun p1-lambda (form)
537  (let* ((lambda-list (cadr form))
538         (body (cddr form))
539         (auxvars (memq '&AUX lambda-list)))
540    (when auxvars
541      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
542      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
543    (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body)))))
544
545(defun p1-eval-when (form)
546  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
547
548(defun p1-quote (form)
549  (if (numberp (second form))
550      (second form)
551      form))
552
553(defun p1-setq (form)
554  (unless (= (length form) 3)
555    (error "Too many arguments for SETQ."))
556  (let ((arg1 (second form))
557        (arg2 (third form)))
558    (let ((variable (find-visible-variable arg1)))
559      (if variable
560          (progn
561            (incf (variable-writes variable))
562            (cond
563             ((eq (variable-compiland variable) *current-compiland*)
564              (dformat t "p1-setq: write ~S~%" arg1))
565             (t
566              (dformat t "p1-setq: non-local write ~S~%" arg1)
567              (setf (variable-used-non-locally-p variable) t))))
568          (dformat t "p1-setq: unknown variable ~S~%" arg1)))
569    (list 'SETQ arg1 (p1 arg2))))
570
571(defun p1-the (form)
572  (dformat t "p1-the form = ~S~%" form)
573  (let ((type (second form))
574        (expr (third form)))
575    (cond
576     ((and (listp type) (eq (car type) 'VALUES))
577      ;; FIXME
578      (p1 expr))
579     ((= *safety* 3)
580      (dformat t "p1-the expr = ~S~%" expr)
581      (let* ((sym (gensym))
582             (new-expr
583              `(let ((,sym ,expr))
584                 (sys::require-type ,sym ',type)
585                 ,sym)))
586        (dformat t "p1-the new-expr = ~S~%" new-expr)
587        (p1 new-expr)))
588     (t
589      (dformat t "p1-the t case expr = ~S~%" expr)
590      (if (subtypep type 'FIXNUM)
591          (list 'THE type (p1 expr))
592          (p1 expr))))))
593
594(defun p1-default (form)
595  (list* (car form) (mapcar #'p1 (cdr form))))
596
597(defun p1-throw (form)
598  (let ((new-form (rewrite-throw form)))
599    (when (neq new-form form)
600      (return-from p1-throw (p1 new-form))))
601  (list* 'THROW (mapcar #'p1 (cdr form))))
602
603(defun expand-inline (form expansion)
604  (let ((args (cdr form))
605        (vars (cadr expansion))
606        (varlist ())
607        new-form)
608    (do ((vars vars (cdr vars))
609         (args args (cdr args)))
610        ((null vars))
611      (push (list (car vars) (car args)) varlist))
612    (setf varlist (nreverse varlist))
613    (setf new-form (list* 'LET varlist (cddr expansion)))
614    new-form))
615
616(defun p1 (form)
617  (cond
618   ((symbolp form)
619    (cond
620     ((constantp form) ; a DEFCONSTANT
621      (let ((value (symbol-value form)))
622        (if (numberp value)
623            value
624            form)))
625     ((keywordp form)
626      form)
627     (t
628      (let ((variable (find-visible-variable form)))
629        (if variable
630            (progn
631              (incf (variable-reads variable))
632              (cond
633               ((eq (variable-compiland variable) *current-compiland*)
634                (dformat t "p1: read ~S~%" form))
635               (t
636                (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
637                         form
638                         (compiland-name (variable-compiland variable))
639                         (compiland-name *current-compiland*))
640                (setf (variable-used-non-locally-p variable) t))))
641            (dformat t "p1: unknown variable ~S~%" form)))
642      form)))
643   ((atom form)
644    form)
645   (t
646    (let ((op (car form))
647          handler)
648      (cond ((symbolp op)
649             (cond ((setf handler (get op 'p1-handler))
650                    (funcall handler form))
651                   ((macro-function op)
652                    (p1 (macroexpand form)))
653                   ((special-operator-p op)
654                    (error "P1: unsupported special operator ~S" op))
655                   (t
656                    ;; Function call.
657                    (let ((new-form (rewrite-function-call form)))
658                      (when (neq new-form form)
659                        (dformat t "old form = ~S~%" form)
660                        (dformat t "new form = ~S~%" new-form)
661                        (return-from p1 (p1 new-form))))
662                    (let ((source-transform (source-transform op)))
663                      (when source-transform
664                        (let ((new-form (expand-source-transform form)))
665                          (when (neq new-form form)
666                            (return-from p1 (p1 new-form))))))
667                    (let ((expansion (inline-expansion op)))
668                      (when expansion
669                        (return-from p1 (p1 (expand-inline form expansion)))))
670                    (let ((local-function (find-local-function op)))
671                      (when local-function
672                        (dformat t "p1 local function ~S~%" op)
673                        (unless (eq (local-function-compiland local-function)
674                                    *current-compiland*)
675                          (let ((variable (local-function-variable local-function)))
676                            (when variable
677                              (unless (eq (variable-compiland variable) *current-compiland*)
678                                (dformat t "p1 ~S used non-locally~%" (variable-name variable))
679                                (setf (variable-used-non-locally-p variable) t)))))))
680                    (list* op (mapcar #'p1 (cdr form)))
681                    )))
682            ((and (consp op) (eq (car op) 'LAMBDA))
683             (p1 (list* 'FUNCALL form)))
684            (t
685             form))))))
686
687(defun install-p1-handler (symbol handler)
688  (setf (get symbol 'p1-handler) handler))
689
690(install-p1-handler 'block                'p1-block)
691(install-p1-handler 'catch                'p1-default)
692(install-p1-handler 'declare              'identity)
693(install-p1-handler 'eval-when            'p1-eval-when)
694(install-p1-handler 'flet                 'p1-flet)
695(install-p1-handler 'function             'p1-function)
696(install-p1-handler 'go                   'p1-go)
697(install-p1-handler 'if                   'p1-default)
698(install-p1-handler 'labels               'p1-labels)
699(install-p1-handler 'lambda               'p1-lambda)
700(install-p1-handler 'let                  'p1-let/let*)
701(install-p1-handler 'let*                 'p1-let/let*)
702(install-p1-handler 'load-time-value      'identity)
703(install-p1-handler 'locally              'p1-default)
704(install-p1-handler 'multiple-value-bind  'p1-m-v-b)
705(install-p1-handler 'multiple-value-call  'p1-default)
706(install-p1-handler 'multiple-value-list  'p1-default)
707(install-p1-handler 'multiple-value-prog1 'p1-default)
708(install-p1-handler 'progn                'p1-default)
709(install-p1-handler 'progv                'identity)
710(install-p1-handler 'quote                'p1-quote)
711(install-p1-handler 'return-from          'p1-return-from)
712(install-p1-handler 'setq                 'p1-setq)
713(install-p1-handler 'symbol-macrolet      'identity)
714(install-p1-handler 'tagbody              'p1-tagbody)
715(install-p1-handler 'the                  'p1-the)
716(install-p1-handler 'throw                'p1-throw)
717(install-p1-handler 'unwind-protect       'p1-default)
718
719(defun dump-pool ()
720  (let ((pool (reverse *pool*))
721        entry type)
722    (dotimes (index (1- *pool-count*))
723      (setq entry (car pool))
724      (setq type (case (car entry)
725                   (7 'class)
726                   (9 'field)
727                   (10 'method)
728                   (11 'interface)
729                   (8 'string)
730                   (3 'integer)
731                   (4 'float)
732                   (5 'long)
733                   (6 'double)
734                   (12 'name-and-type)
735                   (1 'utf8)))
736      (%format t "~D: ~A ~S~%" (1+ index) type entry)
737      (setq pool (cdr pool))))
738  t)
739
740(defun pool-get (entry)
741  (declare (optimize speed))
742  (let ((index (gethash entry *pool-entries*)))
743    (unless index
744      (setf index *pool-count*)
745      (push entry *pool*)
746      (setf (gethash entry *pool-entries*) index)
747      (setf *pool-count* (1+ index)))
748    index))
749
750(defun pool-name (name)
751  (declare (optimize speed))
752  (pool-get (list 1 (length name) name)))
753
754(defun pool-name-and-type (name type)
755  (declare (optimize speed))
756  (pool-get (list 12
757                  (pool-name name)
758                  (pool-name type))))
759
760;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp"
761;; as opposed to "org.armedbear.lisp.Lisp").
762(defun pool-class (class-name)
763  (declare (optimize speed))
764  (pool-get (list 7 (pool-name class-name))))
765
766;; (tag class-index name-and-type-index)
767(defun pool-field (class-name field-name type-name)
768  (declare (optimize speed))
769  (pool-get (list 9
770                  (pool-class class-name)
771                  (pool-name-and-type field-name type-name))))
772
773;; (tag class-index name-and-type-index)
774(defun pool-method (class-name method-name type-name)
775  (declare (optimize speed))
776  (pool-get (list 10
777                  (pool-class class-name)
778                  (pool-name-and-type method-name type-name))))
779
780(defun pool-string (string)
781  (declare (optimize speed))
782  (pool-get (list 8 (pool-name string))))
783
784(defun pool-int (n)
785  (declare (optimize speed))
786  (pool-get (list 3 n)))
787
788(defun u2 (n)
789  (declare (optimize speed))
790  (declare (type fixnum n))
791  (list (logand (ash n -8) #xff)
792        (logand n #xff)))
793
794(locally (declare (optimize speed))
795  (defstruct (instruction
796              (:constructor make-instruction (opcode args)))
797    opcode
798    args
799    stack
800    depth))
801
802(defun print-instruction (instruction)
803  (%format nil "~A ~A stack = ~S depth = ~S"
804          (opcode-name (instruction-opcode instruction))
805          (instruction-args instruction)
806          (instruction-stack instruction)
807          (instruction-depth instruction)))
808
809(defun inst (instr &optional args)
810  (let ((opcode (if (numberp instr)
811                    instr
812                    (opcode-number instr))))
813    (unless (listp args)
814      (setf args (list args)))
815    (make-instruction opcode args)))
816
817(defun emit (instr &rest args)
818  (declare (optimize speed))
819  (let ((instruction (inst instr args)))
820    (push instruction *code*)
821    instruction))
822
823(defun label (symbol)
824  (declare (optimize speed))
825  (emit 'label symbol)
826  (setf (symbol-value symbol) nil))
827
828(defconstant +java-string+ "Ljava/lang/String;")
829(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
830(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
831(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
832(defconstant +lisp-string+ "Lorg/armedbear/lisp/SimpleString;")
833(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
834(defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;")
835(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
836(defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
837(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
838(defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
839(defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
840(defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString")
841(defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;")
842(defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;")
843(defconstant +lisp-binding+ "Lorg/armedbear/lisp/Binding;")
844(defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw")
845(defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
846(defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
847(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
848
849(defsubst emit-push-nil ()
850  (emit 'getstatic +lisp-class+ "NIL" +lisp-object+))
851
852(defsubst emit-push-t ()
853  (emit 'getstatic +lisp-class+ "T" +lisp-symbol+))
854
855(defun emit-push-constant-int (n)
856  (if (<= -32768 n 32767)
857      (emit 'sipush n)
858      (emit 'ldc (pool-int n))))
859
860(defun make-descriptor (arg-types return-type)
861  (with-output-to-string (s)
862    (princ #\( s)
863    (dolist (type arg-types)
864      (princ type s))
865    (princ #\) s)
866    (princ (if return-type return-type "V") s)))
867
868(defun descriptor (designator)
869  (cond ((stringp designator)
870         designator)
871        ((listp designator)
872         (unless (= (length designator) 2)
873           (error "Bad method type descriptor ~S." designator))
874         (make-descriptor (car designator) (cadr designator)))
875        (t
876         (error "Bad method type descriptor ~S." designator))))
877
878(defun emit-invokestatic (class-name method-name descriptor stack)
879  (aver stack)
880  (let ((instruction (emit 'invokestatic
881                           class-name method-name (descriptor descriptor))))
882    (setf (instruction-stack instruction) stack)
883    (aver (eql (instruction-stack instruction) stack))))
884
885(defun emit-invokespecial (class-name method-name descriptor stack)
886  (let ((instruction (emit 'invokespecial
887                           class-name method-name (descriptor descriptor))))
888    (setf (instruction-stack instruction) stack)))
889
890(defun emit-invokevirtual (class-name method-name descriptor stack)
891  (let ((instruction (emit 'invokevirtual
892                           class-name method-name (descriptor descriptor))))
893    (setf (instruction-stack instruction) stack)))
894
895;; Index of local variable used to hold the current thread.
896(defvar *thread* nil)
897
898(defvar *initialize-thread-var* nil)
899
900(defun maybe-initialize-thread-var ()
901  (when *initialize-thread-var*
902    (emit-invokestatic +lisp-thread-class+
903                       "currentThread"
904                       (make-descriptor () +lisp-thread+)
905                       1)
906    (emit 'astore *thread*)))
907
908(defsubst ensure-thread-var-initialized ()
909  (setf *initialize-thread-var* t))
910
911(defun emit-push-current-thread ()
912  (declare (optimize speed))
913  (ensure-thread-var-initialized)
914  (emit 'aload *thread*))
915
916(defun maybe-generate-arg-count-check ()
917  (when *arity*
918    (let ((label1 (gensym)))
919      (aver (fixnump *arity*))
920      (aver (not (minusp *arity*)))
921      (emit 'aload 1)
922      (emit 'arraylength)
923      (emit 'bipush *arity*)
924      (emit 'if_icmpeq `,label1)
925      (emit 'aload 0) ; this
926      (emit-invokevirtual *this-class*
927                          "argCountError"
928                          "()V"
929                          -1)
930      (emit 'label `,label1))))
931
932(defun maybe-generate-interrupt-check ()
933  (unless (> *speed* *safety*)
934    (let ((label1 (gensym)))
935      (emit 'getstatic +lisp-class+ "interrupted" "Z")
936      (emit 'ifeq `,label1)
937      (emit-invokestatic +lisp-class+
938                         "handleInterrupt"
939                         "()V"
940                         0)
941      (emit 'label `,label1))))
942
943(defun single-valued-p-init ()
944  (dolist (op '(+ - * /
945                1+ 1- < > <= >= = /=
946                car cdr caar cadr cdar cddr cadar caddr cdddr cddddr
947                first second third
948                eq eql equal equalp
949                length
950                constantp symbolp
951                list list*
952                macro-function
953                compiler-macro-function
954                sys::%defun
955                get
956                atom
957                compiled-function-p
958                fdefinition
959                special-operator-p keywordp functionp fboundp zerop consp listp
960                numberp integerp floatp
961                plusp minusp
962                complexp arrayp readtablep packagep
963                array-dimensions array-rank array-total-size
964                array-element-type upgraded-array-element-type
965                simple-vector-p simple-string-p bit-vector-p simple-bit-vector-p
966                stringp
967                row-major-aref
968                quote function
969                mapcar
970                find position
971                append nconc subseq adjoin
972                revappend nreconc
973                copy-seq
974                assoc assoc-if assoc-if-not acons assq assql
975                char-code code-char char-int digit-char-p
976                member ext:memq
977                remove remove-if remove-if-not delete delete-if delete-if-not
978                special-variable-p
979                gensym
980                symbol-name symbol-function
981                coerce
982                reverse nreverse
983                last
984                cons rplaca rplacd
985                sys::%rplaca sys::%rplacd
986                copy-list copy-tree
987                make-sequence make-list make-array make-package make-hash-table
988                make-string
989                find-package
990                pathname make-pathname pathname-name directory
991                package-used-by-list package-shadowing-symbols
992                nthcdr
993                aref elt
994                not null endp
995                concatenate
996                format sys::%format
997                prin1 princ print write
998                compute-restarts find-restart restart-name
999                string
1000                string=
1001                setq
1002                multiple-value-list push pop
1003                type-of class-of
1004                typep sys::%typep
1005                abs
1006                ash
1007                float-radix
1008                logand logandc1 logandc2 logeqv logior lognand
1009                lognot logorc1 logorc2 logxor
1010                logbitp
1011                slot-boundp slot-value slot-exists-p
1012                allocate-instance
1013                find-class
1014                class-name
1015                constantly
1016                exp expt log
1017                min max
1018                realpart imagpart
1019                integer-length
1020                sqrt isqrt gcd lcm signum
1021                char schar
1022                open
1023                svref
1024                fill-pointer
1025                symbol-value symbol-package package-name
1026                fourth
1027                vector-push vector-push-extend
1028                union nunion
1029                remove-duplicates delete-duplicates
1030                read-byte
1031                fresh-line terpri
1032                lambda
1033                ext:classp
1034                ext:fixnump
1035                ext:memql
1036                sys::generic-function-name
1037                sys::puthash
1038                precompiler::precompile1
1039                declare
1040                go
1041                sys::%structure-ref
1042                inst
1043                emit
1044                label
1045                maybe-emit-clear-values
1046                single-valued-p
1047                sys:single-valued-p
1048                sys:write-8-bits
1049                ))
1050    (setf (sys:single-valued-p op) t)))
1051
1052(eval-when (:load-toplevel :execute)
1053  (single-valued-p-init))
1054
1055(defun single-valued-p (form)
1056  (cond ((block-node-p form)
1057         (if (equal (block-name form) '(TAGBODY))
1058             t
1059             (single-valued-p (node-form form))))
1060        ((atom form)
1061         t)
1062        ((eq (first form) 'IF)
1063         (and ;;(single-valued-p (second form))
1064              (single-valued-p (third form))
1065              (single-valued-p (fourth form))))
1066        ((eq (first form) 'PROGN)
1067         (single-valued-p (car (last form))))
1068        ((memq (first form) '(LET LET*))
1069         (single-valued-p (car (last (cddr form)))))
1070        ((memq (car form) '(AND OR))
1071         (every #'single-valued-p (cdr form)))
1072        ((eq (first form) 'RETURN-FROM)
1073         (single-valued-p (third form)))
1074        (t
1075         (sys:single-valued-p (car form)))))
1076
1077(defun emit-clear-values ()
1078;;   (break "EMIT-CLEAR-VALUES called~%")
1079  (ensure-thread-var-initialized)
1080  (emit 'clear-values))
1081
1082(defun maybe-emit-clear-values (form)
1083  (declare (optimize speed))
1084  (unless (single-valued-p form)
1085;;     (format t "Not single-valued: ~S~%" form)
1086    (ensure-thread-var-initialized)
1087    (emit 'clear-values)))
1088
1089(defun emit-unbox-fixnum ()
1090  (declare (optimize speed))
1091  (cond ((= *safety* 3)
1092         (emit-invokestatic +lisp-fixnum-class+
1093                            "getValue"
1094                            "(Lorg/armedbear/lisp/LispObject;)I"
1095                            0))
1096        (t
1097         (emit 'checkcast +lisp-fixnum-class+)
1098         (emit 'getfield +lisp-fixnum-class+ "value" "I"))))
1099
1100(defun emit-box-long ()
1101  (declare (optimize speed))
1102  (emit-invokestatic +lisp-class+
1103                     "number"
1104                     "(J)Lorg/armedbear/lisp/LispObject;"
1105                     -1))
1106
1107;; Expects value on stack.
1108(defun emit-invoke-method (method-name target representation)
1109  (emit-invokevirtual +lisp-object-class+
1110                      method-name
1111                      "()Lorg/armedbear/lisp/LispObject;"
1112                      0)
1113  (when (eq representation :unboxed-fixnum)
1114    (emit-unbox-fixnum))
1115  (emit-move-from-stack target representation))
1116
1117(defvar *style-warnings* nil)
1118(defvar *warnings* nil)
1119(defvar *errors* nil)
1120
1121(defun compiler-style-warn (format-control &rest format-arguments)
1122  (incf *style-warnings*)
1123  (warn 'style-warning
1124        :format-control format-control
1125        :format-arguments format-arguments))
1126
1127(defun compiler-warn (format-control &rest format-arguments)
1128  (incf *warnings*)
1129  (warn 'warning
1130        :format-control format-control
1131        :format-arguments format-arguments))
1132
1133(defun check-args (form n)
1134  (declare (type fixnum n))
1135  (cond ((= (length form) (1+ n))
1136         t)
1137        (t
1138         (compiler-style-warn "Wrong number of arguments for ~A." (car form))
1139         nil)))
1140
1141(defparameter *resolvers* (make-hash-table :test #'eql))
1142
1143(defun unsupported-opcode (instruction)
1144  (error "Unsupported opcode ~D."
1145         (instruction-opcode instruction)))
1146
1147(dotimes (n (1+ *last-opcode*))
1148  (setf (gethash n *resolvers*) #'unsupported-opcode))
1149
1150;; The following opcodes resolve to themselves.
1151(dolist (n '(0 ; NOP
1152             1 ; ACONST_NULL
1153             2 ; ICONST_M1
1154             3 ; ICONST_0
1155             4 ; ICONST_1
1156             5 ; ICONST_2
1157             6 ; ICONST_3
1158             7 ; ICONST_4
1159             8 ; ICONST_5
1160             42 ; ALOAD_0
1161             43 ; ALOAD_1
1162             44 ; ALOAD_2
1163             45 ; ALOAD_3
1164             50 ; AALOAD
1165             75 ; ASTORE_0
1166             76 ; ASTORE_1
1167             77 ; ASTORE_2
1168             78 ; ASTORE_3
1169             83 ; AASTORE
1170             87 ; POP
1171             89 ; DUP
1172             90 ; DUP_X1
1173             91 ; DUP_X2
1174             95 ; SWAP
1175             96 ; IADD
1176             97 ; LADD
1177             101 ; LSUB
1178             116 ; INEG
1179             120 ; ISHL
1180             121 ; LSHL
1181             122 ; ISHR
1182             123 ; LSHR
1183             126 ; IAND
1184             132 ; IINC
1185             133 ; I2L
1186             136 ; L2I
1187             153 ; IFEQ
1188             154 ; IFNE
1189             155 ; IFGE
1190             156 ; IFGT
1191             157 ; IFGT
1192             158 ; IFLE
1193             159 ; IF_ICMPEQ
1194             160 ; IF_ICMPNE
1195             161 ; IF_ICMPLT
1196             162 ; IF_ICMPGE
1197             163 ; IF_ICMPGT
1198             164 ; IF_ICMPLE
1199             165 ; IF_ACMPEQ
1200             166 ; IF_ACMPNE
1201             167 ; GOTO
1202             168 ; JSR
1203             169 ; RET
1204             176 ; ARETURN
1205             177 ; RETURN
1206             190 ; ARRAYLENGTH
1207             191 ; ATHROW
1208             198 ; IFNULL
1209             202 ; LABEL
1210             ))
1211  (setf (gethash n *resolvers*) nil))
1212
1213(defmacro define-resolver (opcodes args &body body)
1214  (let ((name (gensym)))
1215    (if (listp opcodes)
1216        `(progn
1217           (defun ,name ,args ,@body)
1218           (eval-when (:load-toplevel :execute)
1219             (dolist (op ',opcodes)
1220               (setf (gethash op *resolvers*) (symbol-function ',name)))))
1221        `(progn
1222           (defun ,name ,args ,@body)
1223           (eval-when (:load-toplevel :execute)
1224             (setf (gethash ,opcodes *resolvers*) (symbol-function ',name)))))))
1225
1226;; ALOAD
1227(define-resolver 25 (instruction)
1228 (let* ((args (instruction-args instruction))
1229        (index (car args)))
1230   (cond ((<= 0 index 3)
1231          (inst (+ index 42)))
1232         ((<= 0 index 255)
1233          (inst 25 index))
1234         (t
1235          (error "ALOAD unsupported case")))))
1236
1237;; ILOAD
1238(define-resolver 21 (instruction)
1239  (let* ((args (instruction-args instruction))
1240         (index (car args)))
1241    (cond ((<= 0 index 3)
1242           (inst (+ index 26)))
1243          ((<= 0 index 255)
1244           (inst 21 index))
1245          (t
1246           (error "ILOAD unsupported case")))))
1247
1248;; ASTORE
1249(define-resolver 58 (instruction)
1250  (let* ((args (instruction-args instruction))
1251         (index (car args)))
1252    (cond ((<= 0 index 3)
1253           (inst (+ index 75)))
1254          ((<= 0 index 255)
1255           (inst 58 index))
1256          (t
1257           (error "ASTORE unsupported case")))))
1258
1259;; ISTORE
1260(define-resolver 54 (instruction)
1261  (let* ((args (instruction-args instruction))
1262         (index (car args)))
1263    (cond ((<= 0 index 3)
1264           (inst (+ index 59)))
1265          ((<= 0 index 255)
1266           (inst 54 index))
1267          (t
1268           (error "ASTORE unsupported case")))))
1269
1270;; GETSTATIC, PUTSTATIC
1271(define-resolver (178 179) (instruction)
1272  (let* ((args (instruction-args instruction))
1273         (index (pool-field (first args) (second args) (third args))))
1274    (inst (instruction-opcode instruction) (u2 index))))
1275
1276;; BIPUSH, SIPUSH
1277(define-resolver (16 17) (instruction)
1278  (let* ((args (instruction-args instruction))
1279         (n (first args)))
1280    (cond ((<= 0 n 5)
1281           (inst (+ n 3)))
1282          ((<= -128 n 127)
1283           (inst 16 (logand n #xff))) ; BIPUSH
1284          (t ; SIPUSH
1285           (inst 17 (u2 n))))))
1286
1287;; INVOKEVIRTUAL, INVOKESPECIAL, INVOKESTATIC class-name method-name descriptor
1288(define-resolver (182 183 184) (instruction)
1289  (let* ((args (instruction-args instruction))
1290         (index (pool-method (first args) (second args) (third args))))
1291    (setf (instruction-args instruction) (u2 index))
1292    instruction))
1293
1294;; LDC
1295(define-resolver 18 (instruction)
1296  (let* ((args (instruction-args instruction)))
1297    (unless (= (length args) 1)
1298      (error "Wrong number of args for LDC."))
1299    (if (> (car args) 255)
1300        (inst 19 (u2 (car args))) ; LDC_W
1301        (inst 18 args))))
1302
1303;; GETFIELD, PUTFIELD class-name field-name type-name
1304(define-resolver (180 181) (instruction)
1305  (let* ((args (instruction-args instruction))
1306         (index (pool-field (first args) (second args) (third args))))
1307    (inst (instruction-opcode instruction) (u2 index))))
1308
1309;; NEW, ANEWARRAY, CHECKCAST, INSTANCEOF class-name
1310(define-resolver (187 189 192 193) (instruction)
1311  (let* ((args (instruction-args instruction))
1312         (index (pool-class (first args))))
1313    (inst (instruction-opcode instruction) (u2 index))))
1314
1315(defun resolve-instruction (instruction)
1316  (declare (optimize speed))
1317  (let ((resolver (gethash (instruction-opcode instruction) *resolvers*)))
1318    (if resolver
1319        (funcall resolver instruction)
1320        instruction)))
1321
1322(defun resolve-instructions (code)
1323  (let ((vector (make-array 512 :fill-pointer 0 :adjustable t)))
1324    (dotimes (index (the fixnum (length code)) vector)
1325      (declare (type fixnum index))
1326      (let ((instruction (svref code index)))
1327        (case (instruction-opcode instruction)
1328          (205 ; CLEAR-VALUES
1329           (let ((instructions
1330                  (list
1331                   (inst 'aload *thread*)
1332                   (inst 'aconst_null)
1333                   (inst 'putfield (list +lisp-thread-class+ "_values"
1334                                         "[Lorg/armedbear/lisp/LispObject;")))))
1335             (dolist (instruction instructions)
1336               (vector-push-extend (resolve-instruction instruction) vector))))
1337          (t
1338           (vector-push-extend (resolve-instruction instruction) vector)))))))
1339
1340(defconstant +branch-opcodes+
1341  '(153 ; IFEQ
1342    154 ; IFNE
1343    155 ; IFLT
1344    156 ; IFGE
1345    157 ; IFGT
1346    158 ; IFLE
1347    159 ; IF_ICMPEQ
1348    160 ; IF_ICMPNE
1349    161 ; IF_ICMPLT
1350    162 ; IF_ICMPGE
1351    163 ; IF_ICMPGT
1352    164 ; IF_ICMPLE
1353    165 ; IF_ACMPEQ
1354    166 ; IF_ACMPNE
1355    167 ; GOTO
1356    168 ; JSR
1357    198 ; IFNULL
1358    ))
1359
1360(defsubst branch-opcode-p (opcode)
1361  (declare (optimize speed))
1362  (member opcode +branch-opcodes+))
1363
1364(defun walk-code (code start-index depth)
1365  (declare (optimize speed))
1366  (do* ((i start-index (1+ i))
1367        (limit (length code)))
1368       ((>= i limit))
1369    (declare (type fixnum i limit))
1370    (let ((instruction (aref code i)))
1371      (when (instruction-depth instruction)
1372        (unless (eql (instruction-depth instruction) (+ depth (instruction-stack instruction)))
1373          (fresh-line)
1374          (%format t "Stack inconsistency at index ~D: found ~S, expected ~S.~%"
1375                   i
1376                   (instruction-depth instruction)
1377                   (+ depth (instruction-stack instruction))))
1378        (return-from walk-code))
1379      (let ((opcode (instruction-opcode instruction)))
1380        (unless (eql opcode 168) ; JSR
1381          (setf depth (+ depth (instruction-stack instruction))))
1382        (setf (instruction-depth instruction) depth)
1383        (if (eql opcode 168) ; JSR
1384            (let ((label (car (instruction-args instruction))))
1385              (walk-code code (symbol-value label) (1+ depth)))
1386            (when (branch-opcode-p opcode)
1387              (let ((label (car (instruction-args instruction))))
1388                (walk-code code (symbol-value label) depth))))
1389        (when (member opcode '(167 169 191)) ; GOTO RET ATHROW
1390          ;; Current path ends.
1391          (return-from walk-code))))))
1392
1393(defun analyze-stack ()
1394  (let* ((code *code*)
1395         (code-length (length code)))
1396    (declare (type fixnum code-length))
1397    (aver (vectorp code))
1398    (dotimes (i code-length)
1399      (declare (type fixnum i))
1400      (let* ((instruction (aref code i))
1401             (opcode (instruction-opcode instruction)))
1402        (when (eql opcode 202) ; LABEL
1403          (let ((label (car (instruction-args instruction))))
1404            (set label i)))
1405        (if (instruction-stack instruction)
1406            (when (opcode-stack-effect opcode)
1407              (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode))
1408                (%format t "instruction-stack = ~S opcode-stack-effect = ~S~%"
1409                         (instruction-stack instruction)
1410                         (opcode-stack-effect opcode))
1411                (%format t "index = ~D instruction = ~A~%" i (print-instruction instruction))))
1412            (setf (instruction-stack instruction) (opcode-stack-effect opcode)))
1413;;         (aver (not (null (instruction-stack instruction))))
1414        (unless (instruction-stack instruction)
1415          (%format t "no stack information for instruction ~D~%" (instruction-opcode instruction))
1416          (aver nil))))
1417    (walk-code code 0 0)
1418    (dolist (handler *handlers*)
1419      ;; Stack depth is always 1 when handler is called.
1420      (walk-code code (symbol-value (handler-code handler)) 1))
1421    (let ((max-stack 0))
1422      (dotimes (i code-length)
1423        (declare (type fixnum i))
1424        (let* ((instruction (aref code i))
1425               (depth (instruction-depth instruction)))
1426          (when depth
1427            (setf max-stack (max max-stack depth)))))
1428      (when *compiler-debug*
1429        (%format t "compiland name = ~S~%" (compiland-name *current-compiland*))
1430        (%format t "max-stack = ~D~%" max-stack)
1431        (%format t "----- after stack analysis -----~%")
1432        (print-code))
1433      max-stack)))
1434
1435(defun emit-move-from-stack (target &optional representation)
1436  (declare (optimize speed))
1437  (cond ((null target)
1438         (emit 'pop))
1439        ((eq target :stack))
1440        ((fixnump target)
1441         (emit (if (eq representation :unboxed-fixnum) 'istore 'astore) target))
1442        (t
1443         (aver nil))))
1444
1445(defun resolve-variables ()
1446  (let ((code (nreverse *code*)))
1447    (setf *code* nil)
1448    (dolist (instruction code)
1449      (case (instruction-opcode instruction)
1450        (206 ; VAR-REF
1451         (let* ((instruction-args (instruction-args instruction))
1452                (variable (first instruction-args))
1453                (target (second instruction-args))
1454                (representation (third instruction-args)))
1455           (aver (variable-p variable))
1456           (cond
1457            ((variable-register variable)
1458             (dformat t "variable = ~S register = ~S~%"
1459                      (variable-name variable)
1460                      (variable-register variable))
1461             (emit 'aload (variable-register variable))
1462             (emit-move-from-stack target))
1463            ((variable-special-p variable)
1464             (compile-special-reference (variable-name variable) target nil))
1465            ((variable-closure-index variable)
1466             (dformat t "variable = ~S closure-index = ~S~%"
1467                      (variable-name variable) (variable-closure-index variable))
1468             (aver (not (null (compiland-closure-register *current-compiland*))))
1469             (emit 'aload (compiland-closure-register *current-compiland*))
1470             (emit 'bipush (variable-closure-index variable))
1471             (emit 'aaload)
1472             (emit-move-from-stack target))
1473            ((variable-index variable)
1474             (aver (not (null (compiland-argument-register *current-compiland*))))
1475             (emit 'aload (compiland-argument-register *current-compiland*))
1476             (emit-push-constant-int (variable-index variable))
1477             (emit 'aaload)
1478             (emit-move-from-stack target))
1479            (t
1480             (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable))
1481             (aver (progn 'unhandled-case nil))))
1482           (when (eq representation :unboxed-fixnum)
1483             (dformat t "resolve-variables calling emit-unbox-fixnum~%")
1484             (emit-unbox-fixnum))))
1485        (207 ; VAR-SET
1486         (let ((variable (car (instruction-args instruction))))
1487           (dformat t "var-set var = ~S reg = ~S closure index = ~S~%"
1488                    (variable-name variable)
1489                    (variable-register variable)
1490                    (variable-closure-index variable)
1491                    )
1492           (aver (variable-p variable))
1493           (aver (not (variable-special-p variable)))
1494           (cond ((variable-register variable)
1495                  (emit 'astore (variable-register variable)))
1496                 ((variable-closure-index variable)
1497                  (dformat t "variable = ~S closure-index = ~S~%"
1498                           (variable-name variable) (variable-closure-index variable))
1499                  (aver (not (null (compiland-closure-register *current-compiland*))))
1500                  (emit 'aload (compiland-closure-register *current-compiland*))
1501                  (emit 'swap) ; array value
1502                  (emit 'bipush (variable-closure-index variable))
1503                  (emit 'swap) ; array index value
1504                  (emit 'aastore)
1505                  )
1506                 (t
1507                  (dformat t "var-set fall-through case~%")
1508                  (aver (not (null (compiland-argument-register *current-compiland*))))
1509                  (emit 'aload (compiland-argument-register *current-compiland*)) ; Stack: value array
1510                  (emit 'swap) ; array value
1511                  (emit 'bipush (variable-index variable)) ; array value index
1512                  (emit 'swap) ; array index value
1513                  (emit 'aastore)))))
1514        (t
1515         (push instruction *code*))))))
1516
1517(defun finalize-code ()
1518  (setf *code* (nreverse (coerce *code* 'vector))))
1519
1520(defun print-code()
1521  (dotimes (i (length *code*))
1522    (let ((instruction (aref *code* i)))
1523      (%format t "~D ~A ~S ~S ~S~%"
1524               i
1525               (opcode-name (instruction-opcode instruction))
1526               (instruction-args instruction)
1527               (instruction-stack instruction)
1528               (instruction-depth instruction)))))
1529
1530(defun validate-labels (code)
1531  (let ((code (coerce code 'list))
1532        (i 0))
1533    (dolist (instruction code)
1534      (when (eql (instruction-opcode instruction) 202) ; LABEL
1535        (let ((label (car (instruction-args instruction))))
1536          (set label i)))
1537      (incf i))))
1538
1539;; Remove unused labels.
1540(defun optimize-1 ()
1541  (let ((code (coerce *code* 'list))
1542        (changed nil)
1543        (marker (gensym)))
1544    ;; Mark the labels that are actually branched to.
1545    (dolist (instruction code)
1546      (when (branch-opcode-p (instruction-opcode instruction))
1547        (let ((label (car (instruction-args instruction))))
1548          (set label marker))))
1549    ;; Add labels used for exception handlers.
1550    (dolist (handler *handlers*)
1551      (set (handler-from handler) marker)
1552      (set (handler-to handler) marker)
1553      (set (handler-code handler) marker))
1554    ;; Remove labels that are not used as branch targets.
1555    (let ((tail code))
1556      (loop
1557        (when (null tail)
1558          (return))
1559        (let ((instruction (car tail)))
1560          (when (= (instruction-opcode instruction) 202) ; LABEL
1561            (let ((label (car (instruction-args instruction))))
1562              (unless (eq (symbol-value label) marker)
1563                (setf (car tail) nil)
1564                (setf changed t)))))
1565        (setf tail (cdr tail))))
1566    (when changed
1567      (setf *code* (delete nil code))
1568      t)))
1569
1570(defun optimize-2 ()
1571  (let* ((code (coerce *code* 'list))
1572         (tail code)
1573         (changed nil))
1574    (loop
1575      (when (null (cdr tail))
1576        (return))
1577      (let ((instruction (car tail))
1578            next-instruction)
1579        (when (and instruction
1580                   (= (instruction-opcode instruction) 167) ; GOTO
1581                   (setf next-instruction (cadr tail)))
1582          (cond ((and (= (instruction-opcode next-instruction) 202) ; LABEL
1583                      (eq (car (instruction-args instruction))
1584                          (car (instruction-args next-instruction))))
1585                 ;; GOTO next instruction: we don't need this one.
1586                 (setf (car tail) nil)
1587                 (setf changed t))
1588                ((= (instruction-opcode next-instruction) 167) ; GOTO
1589                 ;; Two GOTOs in a row: the next instruction is unreachable.
1590                 (setf (cadr tail) nil)
1591                 (setf changed t)))))
1592      (setf tail (cdr tail)))
1593    (when changed
1594      (setf *code* (delete nil code))
1595      t)))
1596
1597;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
1598;; GETSTATIC POP => nothing
1599(defun optimize-3 ()
1600  (let* ((code (coerce *code* 'list))
1601         (tail code)
1602         (changed nil))
1603    (loop
1604      (when (null (cdr tail))
1605        (return))
1606      (let ((this-opcode (instruction-opcode (car tail)))
1607            (next-opcode (instruction-opcode (cadr tail))))
1608        (case this-opcode
1609          (205 ; CLEAR-VALUES
1610           (when (eql next-opcode 205) ; CLEAR-VALUES
1611             (setf (car tail) (cadr tail)
1612                   (cdr tail) (cddr tail)
1613                   changed t)))
1614          (178 ; GETSTATIC
1615           (when (eql next-opcode 87) ; POP
1616             (setf (car tail) (caddr tail)
1617                   (cdr tail) (cdddr tail)
1618                   changed t)))))
1619      (setf tail (cdr tail)))
1620    (when changed
1621      (setf *code* code)
1622      t)))
1623
1624(defvar *delete-unreachable-code-flag* t)
1625
1626(defun delete-unreachable-code ()
1627  (when *delete-unreachable-code-flag*
1628    ;; Look for unreachable code after GOTO.
1629    (unless (listp *code*)
1630      (setf *code* (coerce *code* 'list)))
1631    (validate-labels *code*)
1632    (let* ((code *code*)
1633           (tail code)
1634           (locally-changed-p nil)
1635           (after-goto nil))
1636      (loop
1637        (when (null tail)
1638          (return))
1639        (let ((instruction (car tail)))
1640          (cond (after-goto
1641                 (if (= (instruction-opcode instruction) 202) ; LABEL
1642                     (setf after-goto nil)
1643                     ;; Unreachable.
1644                     (progn
1645                       (setf (car tail) nil)
1646                       (setf locally-changed-p t))))
1647                ((= (instruction-opcode instruction) 167) ; GOTO
1648                 (setf after-goto t))))
1649        (setf tail (cdr tail)))
1650      (when locally-changed-p
1651        (setf *code* (delete nil code))
1652        t))))
1653
1654(defvar *enable-optimization* t)
1655
1656(defun optimize-code ()
1657  (unless *enable-optimization*
1658    (%format t "optimizations are disabled~%"))
1659  (when *enable-optimization*
1660    (when *compiler-debug*
1661      (%format t "----- before optimization -----~%")
1662      (print-code))
1663    (loop
1664      (let ((changed-p nil))
1665        (setf changed-p (or (optimize-1) changed-p))
1666        (setf changed-p (or (optimize-2) changed-p))
1667        (setf changed-p (or (optimize-3) changed-p))
1668        (setf changed-p (or (delete-unreachable-code) changed-p))
1669        (unless changed-p
1670          (return))))
1671    (unless (typep *code* 'vector)
1672      (setf *code* (coerce *code* 'vector)))
1673    (when *compiler-debug*
1674      (%format t "----- after optimization -----~%")
1675      (print-code))))
1676
1677(defun code-bytes (code)
1678  (let ((length 0))
1679;;     (declare (type fixnum length))
1680    ;; Pass 1: calculate label offsets and overall length.
1681    (dotimes (i (length code))
1682      (declare (type fixnum i))
1683      (let* ((instruction (aref code i))
1684             (opcode (instruction-opcode instruction)))
1685        (if (= opcode 202) ; LABEL
1686            (let ((label (car (instruction-args instruction))))
1687              (set label length))
1688            (incf length (opcode-size opcode)))))
1689    ;; Pass 2: replace labels with calculated offsets.
1690    (let ((index 0))
1691;;       (declare (type fixnum index))
1692      (dotimes (i (length code))
1693        (declare (type fixnum i))
1694        (let ((instruction (aref code i)))
1695          (when (branch-opcode-p (instruction-opcode instruction))
1696            (let* ((label (car (instruction-args instruction)))
1697                   (offset (- (symbol-value `,label) index)))
1698              (setf (instruction-args instruction) (u2 offset))))
1699          (unless (= (instruction-opcode instruction) 202) ; LABEL
1700            (incf index (opcode-size (instruction-opcode instruction)))))))
1701    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
1702    (let ((bytes (make-array length))
1703          (index 0))
1704;;       (declare (type fixnum index))
1705      (dotimes (i (length code))
1706        (declare (type fixnum i))
1707        (let ((instruction (aref code i)))
1708          (unless (= (instruction-opcode instruction) 202) ; LABEL
1709            (setf (svref bytes index) (instruction-opcode instruction))
1710            (incf index)
1711            (dolist (byte (instruction-args instruction))
1712              (setf (svref bytes index) byte)
1713              (incf index)))))
1714      bytes)))
1715
1716(defsubst write-u1 (n stream)
1717  (declare (optimize speed))
1718  (sys::write-8-bits n stream))
1719
1720(defun write-u2 (n stream)
1721  (declare (optimize speed))
1722  (sys::write-8-bits (ash n -8) stream)
1723  (sys::write-8-bits (logand n #xFF) stream))
1724
1725(defun write-u4 (n stream)
1726  (declare (optimize speed))
1727  (write-u2 (ash n -16) stream)
1728  (write-u2 (logand n #xFFFF) stream))
1729
1730(defun write-s4 (n stream)
1731  (declare (optimize speed))
1732  (cond ((minusp n)
1733         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
1734        (t
1735         (write-u4 n stream))))
1736
1737(defun write-utf8 (string stream)
1738  (declare (optimize speed))
1739  (dotimes (i (length string))
1740    (declare (type fixnum i))
1741    (let ((c (schar string i)))
1742      (if (eql c #\null)
1743          (progn
1744            (sys::write-8-bits #xC0 stream)
1745            (sys::write-8-bits #x80 stream))
1746          (sys::write-8-bits (char-int c) stream)))))
1747
1748(defun utf8-length (string)
1749  (declare (optimize speed))
1750  (let ((length (length string)))
1751    (declare (type fixnum length))
1752    (dotimes (i length)
1753      (declare (type fixnum i))
1754      (when (eql (schar string i) #\null)
1755        (incf length)))
1756    length))
1757
1758(defun write-constant-pool-entry (entry stream)
1759  (declare (optimize speed))
1760  (let ((tag (first entry)))
1761    (write-u1 tag stream)
1762    (case tag
1763      (1 ; UTF8
1764       (write-u2 (utf8-length (third entry)) stream)
1765       (write-utf8 (third entry) stream))
1766      (3 ; int
1767       (write-s4 (second entry) stream))
1768      ((5 6)
1769       (write-u4 (second entry) stream)
1770       (write-u4 (third entry)) stream)
1771      ((9 10 11 12)
1772       (write-u2 (second entry) stream)
1773       (write-u2 (third entry) stream))
1774      ((7 8)
1775       (write-u2 (second entry) stream))
1776      (t
1777       (error "WRITE-CP-ENTRY unhandled tag ~D~%" tag)))))
1778
1779(defun write-constant-pool (stream)
1780  (declare (optimize speed))
1781  (write-u2 *pool-count* stream)
1782  (dolist (entry (reverse *pool*))
1783    (write-constant-pool-entry entry stream)))
1784
1785(defstruct field
1786  access-flags
1787  name
1788  descriptor
1789  name-index
1790  descriptor-index)
1791
1792(defstruct method
1793  access-flags
1794  name
1795  descriptor
1796  name-index
1797  descriptor-index
1798  max-stack
1799  max-locals
1800  code
1801  handlers)
1802
1803(defun make-constructor (super name args body)
1804  (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors.
1805         (constructor (make-method :name "<init>"
1806                                   :descriptor "()V"))
1807         (*code* ())
1808         (*handlers* nil))
1809    (dformat t "make-constructor super = ~S~%" super)
1810    (setf (method-name-index constructor) (pool-name (method-name constructor)))
1811    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
1812    (setf (method-max-locals constructor) 1)
1813    (cond
1814     (*hairy-arglist-p*
1815      (emit 'aload_0) ;; this
1816      (emit 'aconst_null) ;; name
1817      (let* ((*print-level* nil)
1818             (*print-length* nil)
1819             (s (%format nil "~S" args)))
1820        (emit 'ldc
1821              (pool-string s))
1822        (emit-invokestatic +lisp-class+
1823                           "readObjectFromString"
1824                           "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1825                           0))
1826      (emit-push-nil) ;; body
1827      (emit 'aconst_null) ;; environment
1828      (emit-invokespecial super
1829                          "<init>"
1830                          ;;                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
1831                          `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil)
1832                          -5))
1833     (*child-p*
1834      (cond
1835       ((null *closure-variables*)
1836        (emit 'aload_0)
1837        (emit-invokespecial super
1838                            "<init>"
1839                            "()V"
1840                            -1))
1841        (t
1842         (emit 'aload_0) ;; this
1843         (let* ((*print-level* nil)
1844                (*print-length* nil)
1845                (s (%format nil "~S" args)))
1846           (emit 'ldc
1847                 (pool-string s))
1848           (emit-invokestatic +lisp-class+
1849                              "readObjectFromString"
1850                              "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1851                              0))
1852         (emit-invokespecial super
1853                             "<init>"
1854                             "(Lorg/armedbear/lisp/LispObject;)V"
1855                             -2))))
1856     (t
1857      (emit 'aload_0)
1858      (emit-invokespecial super
1859                          "<init>"
1860                          "()V"
1861                          -1)))
1862    (setf *code* (append *static-code* *code*))
1863    (emit 'return)
1864    (finalize-code)
1865;;     (optimize-code)
1866    (setf *code* (resolve-instructions *code*))
1867    (setf (method-max-stack constructor) (analyze-stack))
1868    (setf (method-code constructor) (code-bytes *code*))
1869    (setf (method-handlers constructor) (nreverse *handlers*))
1870    constructor))
1871
1872(defun write-exception-table (method stream)
1873  (let ((handlers (method-handlers method)))
1874    (write-u2 (length handlers) stream) ; number of entries
1875    (dolist (handler handlers)
1876      (write-u2 (symbol-value (handler-from handler)) stream)
1877      (write-u2 (symbol-value (handler-to handler)) stream)
1878      (write-u2 (symbol-value (handler-code handler)) stream)
1879      (write-u2 (handler-catch-type handler) stream))))
1880
1881(defun write-code-attr (method stream)
1882  (declare (optimize speed))
1883  (let* ((name-index (pool-name "Code"))
1884         (code (method-code method))
1885         (code-length (length code))
1886         (length (+ code-length 12
1887                    (* (length (method-handlers method)) 8)))
1888         (max-stack (or (method-max-stack method) 20))
1889         (max-locals (or (method-max-locals method) 1)))
1890    (write-u2 name-index stream)
1891    (write-u4 length stream)
1892    (write-u2 max-stack stream)
1893    (write-u2 max-locals stream)
1894    (write-u4 code-length stream)
1895    (dotimes (i code-length)
1896      (declare (type fixnum i))
1897      (write-u1 (svref code i) stream))
1898    (write-exception-table method stream)
1899    (write-u2 0 stream) ; attributes count
1900    ))
1901
1902(defun write-method (method stream)
1903  (declare (optimize speed))
1904  (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
1905  (write-u2 (method-name-index method) stream)
1906  (write-u2 (method-descriptor-index method) stream)
1907  (write-u2 1 stream) ; attributes count
1908  (write-code-attr method stream))
1909
1910(defun write-field (field stream)
1911  (declare (optimize speed))
1912  (write-u2 (or (field-access-flags field) #x1) stream) ; access flags
1913  (write-u2 (field-name-index field) stream)
1914  (write-u2 (field-descriptor-index field) stream)
1915  (write-u2 0 stream)) ; attributes count
1916
1917(defun declare-field (name descriptor)
1918  (let ((field (make-field :name name :descriptor descriptor)))
1919    (setf (field-access-flags field) (logior #x8 #x2)) ; private static
1920    (setf (field-name-index field) (pool-name (field-name field)))
1921    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
1922    (setq *fields* (cons field *fields*))))
1923
1924(defun sanitize (symbol)
1925  (declare (optimize speed))
1926  (let* ((input (symbol-name symbol))
1927         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
1928    (dotimes (i (length input))
1929      (declare (type fixnum i))
1930      (let ((c (char-upcase (char input i))))
1931        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
1932               (vector-push c output))
1933              ((eql c #\-)
1934               (vector-push #\_ output)))))
1935    (when (plusp (length output))
1936      output)))
1937
1938(defvar *declared-symbols* nil)
1939(defvar *declared-functions* nil)
1940(defvar *declared-strings* nil)
1941(defvar *declared-fixnums* nil)
1942
1943(defun declare-symbol (symbol)
1944  (let ((g (gethash symbol *declared-symbols*)))
1945    (unless g
1946      (let ((*code* *static-code*)
1947            (s (sanitize symbol)))
1948        (setf g (symbol-name (gensym)))
1949        (when s
1950          (setf g (concatenate 'string g "_" s)))
1951        (declare-field g +lisp-symbol+)
1952        (emit 'ldc (pool-string (symbol-name symbol)))
1953        (emit 'ldc (pool-string (package-name (symbol-package symbol))))
1954        (emit-invokestatic +lisp-class+
1955                           "internInPackage"
1956                           "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1957                           -1)
1958        (emit 'putstatic
1959              *this-class*
1960              g
1961              +lisp-symbol+)
1962        (setf *static-code* *code*)
1963        (setf (gethash symbol *declared-symbols*) g)))
1964    g))
1965
1966(defun declare-keyword (symbol)
1967  (let ((g (gethash symbol *declared-symbols*)))
1968    (unless g
1969      (let ((*code* *static-code*))
1970        (setf g (symbol-name (gensym)))
1971        (declare-field g +lisp-symbol+)
1972        (emit 'ldc (pool-string (symbol-name symbol)))
1973        (emit-invokestatic "org/armedbear/lisp/Keyword"
1974                           "internKeyword"
1975                           "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1976                           0)
1977        (emit 'putstatic
1978              *this-class*
1979              g
1980              +lisp-symbol+)
1981        (setf *static-code* *code*)
1982        (setf (gethash symbol *declared-symbols*) g)))
1983    g))
1984
1985(defun declare-function (symbol)
1986  (let ((f (gethash symbol *declared-functions*)))
1987    (unless f
1988      (setf f (symbol-name (gensym)))
1989      (let ((s (sanitize symbol)))
1990        (when s
1991          (setf f (concatenate 'string f "_" s))))
1992      (let ((*code* *static-code*)
1993            (g (gethash symbol *declared-symbols*)))
1994        (cond (g
1995               (emit 'getstatic
1996                     *this-class*
1997                     g
1998                     +lisp-symbol+))
1999              (t
2000               (emit 'ldc (pool-string (symbol-name symbol)))
2001               (emit 'ldc (pool-string (package-name (symbol-package symbol))))
2002               (emit-invokestatic +lisp-class+
2003                                  "internInPackage"
2004                                  "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
2005                                  -1)))
2006        (declare-field f +lisp-object+)
2007        (emit-invokevirtual +lisp-symbol-class+
2008                            "getSymbolFunctionOrDie"
2009                            "()Lorg/armedbear/lisp/LispObject;"
2010                            0)
2011        (emit 'putstatic
2012              *this-class*
2013              f
2014              +lisp-object+)
2015        (setq *static-code* *code*)
2016        (setf (gethash symbol *declared-functions*) f)))
2017    f))
2018
2019(defun declare-setf-function (name)
2020  (let ((f (gethash name *declared-functions*)))
2021    (unless f
2022      (let ((symbol (cadr name)))
2023        (setf f (symbol-name (gensym)))
2024        (let ((s (sanitize symbol)))
2025          (when s
2026            (setf f (concatenate 'string f "_SETF_" s))))
2027        (let ((*code* *static-code*)
2028              (g (gethash symbol *declared-symbols*)))
2029          (cond (g
2030                 (emit 'getstatic
2031                       *this-class*
2032                       g
2033                       +lisp-symbol+))
2034                (t
2035                 (emit 'ldc (pool-string (symbol-name symbol)))
2036                 (emit 'ldc (pool-string (package-name (symbol-package symbol))))
2037                 (emit-invokestatic +lisp-class+
2038                                    "internInPackage"
2039                                    "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
2040                                    -1)))
2041          (declare-field f +lisp-object+)
2042          (emit-invokevirtual +lisp-symbol-class+
2043                              "getSymbolSetfFunctionOrDie"
2044                              "()Lorg/armedbear/lisp/LispObject;"
2045                              0)
2046          (emit 'putstatic
2047                *this-class*
2048                f
2049                +lisp-object+)
2050          (setq *static-code* *code*)
2051          (setf (gethash name *declared-functions*) f))))
2052    f))
2053
2054(defun declare-fixnum (n)
2055  (declare (type fixnum n))
2056  (let ((g (gethash n *declared-fixnums*)))
2057    (unless g
2058      (let ((*code* *static-code*))
2059        (setf g (%format nil "FIXNUM_~A~D"
2060                         (if (minusp n) "MINUS_" "")
2061                         (abs n)))
2062        (declare-field g +lisp-fixnum+)
2063        (emit 'new +lisp-fixnum-class+)
2064        (emit 'dup)
2065        (case n
2066          (-1
2067           (emit 'iconst_m1))
2068          (0
2069           (emit 'iconst_0))
2070          (1
2071           (emit 'iconst_1))
2072          (2
2073           (emit 'iconst_2))
2074          (3
2075           (emit 'iconst_3))
2076          (4
2077           (emit 'iconst_4))
2078          (5
2079           (emit 'iconst_5))
2080          (t
2081           (emit 'ldc (pool-int n))))
2082        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
2083        (emit 'putstatic *this-class* g +lisp-fixnum+)
2084        (setf *static-code* *code*)
2085        (setf (gethash n *declared-fixnums*) g)))
2086    g))
2087
2088(defun declare-object-as-string (obj)
2089  (let* ((g (symbol-name (gensym)))
2090         (*print-level* nil)
2091         (*print-length* nil)
2092         (s (%format nil "~S" obj))
2093         (*code* *static-code*))
2094    (declare-field g +lisp-object+)
2095    (emit 'ldc
2096          (pool-string s))
2097    (emit-invokestatic +lisp-class+
2098                       "readObjectFromString"
2099                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2100                       0)
2101    (emit 'putstatic
2102          *this-class*
2103          g
2104          +lisp-object+)
2105    (setf *static-code* *code*)
2106    g))
2107
2108(defun declare-package (obj)
2109  (let* ((g (symbol-name (gensym)))
2110         (*print-level* nil)
2111         (*print-length* nil)
2112         (s (%format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
2113         (*code* *static-code*))
2114    (declare-field g +lisp-object+)
2115    (emit 'ldc
2116          (pool-string s))
2117    (emit-invokestatic +lisp-class+
2118                       "readObjectFromString"
2119                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2120                       0)
2121    (emit 'putstatic
2122          *this-class*
2123          g
2124          +lisp-object+)
2125    (setf *static-code* *code*)
2126    g))
2127
2128(defun declare-object (obj)
2129  (let ((key (symbol-name (gensym))))
2130    (sys::remember key obj)
2131    (let* ((g1 (declare-string key))
2132           (g2 (symbol-name (gensym)))
2133           (*code* *static-code*))
2134      (declare-field g2 +lisp-object+)
2135      (emit 'getstatic
2136            *this-class*
2137            g1
2138            +lisp-string+)
2139;;       (emit 'dup)
2140      (emit-invokestatic +lisp-class+
2141                         "recall"
2142                         "(Lorg/armedbear/lisp/SimpleString;)Lorg/armedbear/lisp/LispObject;"
2143                         0)
2144      (emit 'putstatic
2145            *this-class*
2146            g2
2147            +lisp-object+)
2148;;       (emit-invokestatic +lisp-class+
2149;;                          "forget"
2150;;                          "(Lorg/armedbear/lisp/SimpleString;)V"
2151;;                          -1)
2152      (setf *static-code* *code*)
2153      g2)))
2154
2155(defun declare-lambda (obj)
2156  (let* ((g (symbol-name (gensym)))
2157         (*print-level* nil)
2158         (*print-length* nil)
2159         (s (%format nil "~S" obj))
2160         (*code* *static-code*))
2161    (declare-field g +lisp-object+)
2162    (emit 'ldc
2163          (pool-string s))
2164    (emit-invokestatic +lisp-class+
2165                       "readObjectFromString"
2166                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2167                       0)
2168    (emit-invokestatic +lisp-class+
2169                       "coerceToFunction"
2170                       "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2171                       0)
2172    (emit 'putstatic
2173          *this-class*
2174          g
2175          +lisp-object+)
2176    (setf *static-code* *code*)
2177    g))
2178
2179(defun declare-local-function (local-function)
2180  (let* ((g (symbol-name (gensym)))
2181         (classfile (local-function-classfile local-function))
2182         (*code* *static-code*))
2183    (declare-field g +lisp-object+)
2184    (emit 'ldc
2185          (pool-string (file-namestring classfile)))
2186    (emit-invokestatic +lisp-class+
2187                       "loadCompiledFunction"
2188                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2189                       0)
2190    (emit 'putstatic
2191          *this-class*
2192          g
2193          +lisp-object+)
2194    (setf *static-code* *code*)
2195    g))
2196
2197(defun declare-string (string)
2198  (let ((g (gethash string *declared-strings*)))
2199    (unless g
2200      (let ((*code* *static-code*))
2201        (setf g (symbol-name (gensym)))
2202        (declare-field g +lisp-simple-string+)
2203        (emit 'new +lisp-simple-string-class+)
2204        (emit 'dup)
2205        (emit 'ldc (pool-string string))
2206        (emit-invokespecial +lisp-simple-string-class+
2207                            "<init>"
2208                            "(Ljava/lang/String;)V"
2209                            -2)
2210        (emit 'putstatic
2211              *this-class*
2212              g
2213              +lisp-simple-string+)
2214        (setf *static-code* *code*)
2215        (setf (gethash string *declared-strings*) g)))
2216    g))
2217
2218(defun compile-constant (form &key (target *val*) representation)
2219  (unless target
2220    (return-from compile-constant))
2221  (when (eq representation :unboxed-fixnum)
2222    (cond
2223     ((fixnump form)
2224      (emit-push-constant-int form)
2225      (emit-move-from-stack target)
2226      (return-from compile-constant))
2227     (t
2228      (assert nil))))
2229  (cond ((numberp form)
2230         (if (fixnump form)
2231             (let* ((n form)
2232                    (translations '(( 0 . "ZERO")
2233                                    ( 1 . "ONE")
2234                                    ( 2 . "TWO")
2235                                    ( 3 . "THREE")
2236                                    (-1 . "MINUS_ONE")))
2237                    (translation (cdr (assoc n translations))))
2238               (if translation
2239                   (emit 'getstatic
2240                         +lisp-fixnum-class+
2241                         translation
2242                         +lisp-fixnum+)
2243                   (emit 'getstatic
2244                         *this-class*
2245                         (declare-fixnum n)
2246                         +lisp-fixnum+)))
2247             (emit 'getstatic
2248                   *this-class*
2249                   (declare-object-as-string form)
2250                   +lisp-object+)))
2251        ((stringp form)
2252         (if *compile-file-truename*
2253             (emit 'getstatic
2254                   *this-class*
2255                   (declare-string form)
2256                   +lisp-simple-string+)
2257             (emit 'getstatic
2258                   *this-class*
2259                   (declare-object form)
2260                   +lisp-object+)))
2261        ((vectorp form)
2262         (if *compile-file-truename*
2263             (emit 'getstatic
2264                   *this-class*
2265                   (declare-object-as-string form)
2266                   +lisp-object+)
2267             (emit 'getstatic
2268                   *this-class*
2269                   (declare-object form)
2270                   +lisp-object+)))
2271        ((characterp form)
2272         (emit 'getstatic
2273               *this-class*
2274               (declare-object-as-string form)
2275               +lisp-object+))
2276        ((or (classp form) (hash-table-p form) (typep form 'generic-function))
2277         (emit 'getstatic
2278               *this-class*
2279               (declare-object form)
2280               +lisp-object+))
2281        ((pathnamep form)
2282         (let ((g (if *compile-file-truename*
2283                      (declare-object-as-string form)
2284                      (declare-object form))))
2285           (emit 'getstatic
2286                 *this-class*
2287                 g
2288                 +lisp-object+)))
2289        ((packagep form)
2290         (let ((g (if *compile-file-truename*
2291                      (declare-package form)
2292                      (declare-object form))))
2293           (emit 'getstatic
2294                 *this-class*
2295                 g
2296                 +lisp-object+)))
2297        (t
2298         (if *compile-file-truename*
2299             (error "COMPILE-CONSTANT unhandled case ~S" form)
2300             (emit 'getstatic
2301                   *this-class*
2302                   (declare-object form)
2303                   +lisp-object+))))
2304  (emit-move-from-stack target))
2305
2306(defparameter unary-operators (make-hash-table :test 'eq))
2307
2308(defun define-unary-operator (operator translation)
2309  (setf (gethash operator unary-operators) translation))
2310
2311(define-unary-operator '1+              "incr")
2312(define-unary-operator '1-              "decr")
2313(define-unary-operator 'ABS             "ABS")
2314(define-unary-operator 'ATOM            "ATOM")
2315(define-unary-operator 'BIT-VECTOR-P    "BIT_VECTOR_P")
2316(define-unary-operator 'CADR            "cadr")
2317(define-unary-operator 'CAR             "car")
2318(define-unary-operator 'CDDR            "cddr")
2319(define-unary-operator 'CDR             "cdr")
2320(define-unary-operator 'CHARACTERP      "CHARACTERP")
2321(define-unary-operator 'CLASS-OF        "classOf")
2322(define-unary-operator 'COMPLEXP        "COMPLEXP")
2323(define-unary-operator 'CONSTANTP       "CONSTANTP")
2324(define-unary-operator 'DENOMINATOR     "DENOMINATOR")
2325(define-unary-operator 'ENDP            "ENDP")
2326(define-unary-operator 'EVENP           "EVENP")
2327(define-unary-operator 'FIRST           "car")
2328(define-unary-operator 'FLOATP          "FLOATP")
2329(define-unary-operator 'INTEGERP        "INTEGERP")
2330(define-unary-operator 'LENGTH          "LENGTH")
2331(define-unary-operator 'LISTP           "LISTP")
2332(define-unary-operator 'MINUSP          "MINUSP")
2333(define-unary-operator 'NREVERSE        "nreverse")
2334(define-unary-operator 'NUMBERP         "NUMBERP")
2335(define-unary-operator 'NUMERATOR       "NUMERATOR")
2336(define-unary-operator 'ODDP            "ODDP")
2337(define-unary-operator 'PLUSP           "PLUSP")
2338(define-unary-operator 'RATIONALP       "RATIONALP")
2339(define-unary-operator 'REALP           "REALP")
2340(define-unary-operator 'REST            "cdr")
2341(define-unary-operator 'SECOND          "cadr")
2342(define-unary-operator 'SIMPLE-STRING-P "SIMPLE_STRING_P")
2343(define-unary-operator 'STRING          "STRING")
2344(define-unary-operator 'STRINGP         "STRINGP")
2345(define-unary-operator 'SYMBOLP         "SYMBOLP")
2346(define-unary-operator 'VECTORP         "VECTORP")
2347(define-unary-operator 'ZEROP           "ZEROP")
2348
2349(defun compile-function-call-1 (fun args target representation)
2350  (let ((arg (first args)))
2351    (when (eq fun '1+)
2352      (return-from compile-function-call-1 (compile-plus (list '+ 1 arg)
2353                                                         :target target
2354                                                         :representation representation)))
2355    (let ((s (gethash fun unary-operators)))
2356      (cond (s
2357             (compile-form arg :target :stack)
2358             (maybe-emit-clear-values arg)
2359             (emit-invoke-method s target representation)
2360             t)
2361            ((eq fun 'LIST)
2362             (emit 'new +lisp-cons-class+)
2363             (emit 'dup)
2364             (compile-form arg :target :stack)
2365             (maybe-emit-clear-values arg)
2366             (emit-invokespecial +lisp-cons-class+
2367                                 "<init>"
2368                                 "(Lorg/armedbear/lisp/LispObject;)V"
2369                                 -2)
2370             (emit-move-from-stack target)
2371             t)
2372            (t
2373             nil)))))
2374
2375(defparameter binary-operators (make-hash-table :test 'eq))
2376
2377(defun define-binary-operator (operator translation)
2378  (setf (gethash operator binary-operators) translation))
2379
2380(define-binary-operator 'eql                 "EQL")
2381(define-binary-operator 'equal               "EQUAL")
2382(define-binary-operator '+                   "add")
2383(define-binary-operator '-                   "subtract")
2384(define-binary-operator '/                   "divideBy")
2385(define-binary-operator '*                   "multiplyBy")
2386(define-binary-operator '<                   "IS_LT")
2387(define-binary-operator '<=                  "IS_LE")
2388(define-binary-operator '>                   "IS_GT")
2389(define-binary-operator '>=                  "IS_GE")
2390(define-binary-operator ' =                  "IS_E")
2391(define-binary-operator '/=                  "IS_NE")
2392(define-binary-operator 'mod                 "MOD")
2393(define-binary-operator 'ash                 "ash")
2394(define-binary-operator 'logand              "logand")
2395(define-binary-operator 'aref                "AREF")
2396(define-binary-operator 'sys::simple-typep   "typep")
2397(define-binary-operator 'rplaca              "RPLACA")
2398(define-binary-operator 'rplacd              "RPLACD")
2399(define-binary-operator 'sys::%rplaca        "_RPLACA")
2400(define-binary-operator 'sys::%rplacd        "_RPLACD")
2401
2402(defun compile-binary-operation (op args target representation)
2403;;   (dformat t "compile-binary-operation op = ~S representation = ~S~%"
2404;;            op representation)
2405  (compile-form (first args) :target :stack)
2406  (compile-form (second args) :target :stack)
2407  (unless (and (single-valued-p (first args))
2408               (single-valued-p (second args)))
2409    (emit-clear-values))
2410  (emit-invokevirtual +lisp-object-class+
2411                      op
2412                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2413                      -1)
2414  (when (eq representation :unboxed-fixnum)
2415    (emit-unbox-fixnum))
2416  (emit-move-from-stack target))
2417
2418(defun compile-function-call-2 (op args target representation)
2419  (let ((translation (gethash op binary-operators))
2420        (first (first args))
2421        (second (second args)))
2422    (if translation
2423        (compile-binary-operation translation args target representation)
2424        (case op
2425          (EQ
2426           (compile-form first :target :stack)
2427           (compile-form second :target :stack)
2428           (unless (and (single-valued-p first)
2429                        (single-valued-p second))
2430             (emit-clear-values))
2431           (let ((label1 (gensym))
2432                 (label2 (gensym)))
2433             (emit 'if_acmpeq `,label1)
2434             (emit-push-nil)
2435             (emit 'goto `,label2)
2436             (emit 'label `,label1)
2437             (emit-push-t)
2438             (emit 'label `,label2))
2439           (emit-move-from-stack target)
2440           t)
2441          (LIST
2442           (compile-form first :target :stack)
2443           (compile-form second :target :stack)
2444           (unless (and (single-valued-p first)
2445                        (single-valued-p second))
2446             (emit-clear-values))
2447           (emit-invokestatic +lisp-class+
2448                              "list2"
2449                              "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
2450                              -1)
2451           (emit-move-from-stack target)
2452           t)
2453          (SYS::%STRUCTURE-REF
2454           (when (fixnump second)
2455             (compile-form first :target :stack)
2456             (maybe-emit-clear-values first)
2457             (emit 'sipush second)
2458             (emit-invokevirtual +lisp-object-class+
2459                                 "getSlotValue"
2460                                 "(I)Lorg/armedbear/lisp/LispObject;"
2461                                 -1)
2462             (when (eq representation :unboxed-fixnum)
2463               (emit-unbox-fixnum))
2464             (emit-move-from-stack target representation)
2465             t))
2466          (t
2467           nil)))))
2468
2469(defun fixnum-or-unboxed-variable-p (arg)
2470  (or (fixnump arg)
2471      (unboxed-fixnum-variable arg)))
2472
2473(defun emit-push-int (arg)
2474  (if (fixnump arg)
2475      (emit-push-constant-int arg)
2476      (let ((variable (unboxed-fixnum-variable arg)))
2477        (if variable
2478            (emit 'iload (variable-register variable))
2479            (aver nil)))))
2480
2481(defun p2-eql (form &key (target *val*) representation)
2482;;   (dformat t "p2-eql form = ~S~%" form)
2483  (unless (= (length form) 3)
2484    (error "Wrong number of arguments for EQL."))
2485  (let ((arg1 (second form))
2486        (arg2 (third form)))
2487;;     (dformat t "arg1 = ~S~%" arg1)
2488;;     (dformat t "arg2 = ~S~%" arg2)
2489    (cond
2490     ((and (fixnum-or-unboxed-variable-p arg1)
2491           (fixnum-or-unboxed-variable-p arg2))
2492;;       (dformat t "p2-eql case 1~%")
2493      (emit-push-int arg1)
2494      (emit-push-int arg2)
2495      (let ((label1 (gensym))
2496            (label2 (gensym)))
2497        (emit 'if_icmpeq `,label1)
2498        (emit-push-nil)
2499        (emit 'goto `,label2)
2500        (emit 'label `,label1)
2501        (emit-push-t)
2502        (emit 'label `,label2))
2503      (emit-move-from-stack target))
2504     ((fixnum-or-unboxed-variable-p arg1)
2505      (emit-push-int arg1)
2506      (compile-form arg2 :target :stack)
2507      (maybe-emit-clear-values arg2)
2508      (emit 'swap)
2509      (emit-invokevirtual +lisp-object-class+
2510                          "eql"
2511                          "(I)Z"
2512                          -1)
2513      (let ((label1 (gensym))
2514            (label2 (gensym)))
2515        (emit 'ifne `,label1)
2516        (emit-push-nil)
2517        (emit 'goto `,label2)
2518        (emit 'label `,label1)
2519        (emit-push-t)
2520        (emit 'label `,label2))
2521      (emit-move-from-stack target))
2522     ((fixnum-or-unboxed-variable-p arg2)
2523      (compile-form arg1 :target :stack)
2524      (maybe-emit-clear-values arg1)
2525      (emit-push-int arg2)
2526      (emit-invokevirtual +lisp-object-class+
2527                          "eql"
2528                          "(I)Z"
2529                          -1)
2530      (let ((label1 (gensym))
2531            (label2 (gensym)))
2532        (emit 'ifne `,label1)
2533        (emit-push-nil)
2534        (emit 'goto `,label2)
2535        (emit 'label `,label1)
2536        (emit-push-t)
2537        (emit 'label `,label2))
2538      (emit-move-from-stack target))
2539     (t
2540;;       (dformat t "p2-eql case 3~%")
2541      (compile-form arg1 :target :stack)
2542      (compile-form arg2 :target :stack)
2543      (unless (and (single-valued-p arg1)
2544                   (single-valued-p arg2))
2545        (emit-clear-values))
2546      (emit-invokevirtual +lisp-object-class+
2547                          "EQL"
2548                          "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2549                          -1)
2550      (emit-move-from-stack target))))
2551  )
2552
2553(defun compile-function-call-3 (op args target)
2554  (case op
2555    (LIST
2556     (compile-form (first args) :target :stack)
2557     (compile-form (second args) :target :stack)
2558     (compile-form (third args) :target :stack)
2559     (unless (every 'single-valued-p args)
2560       (emit-clear-values))
2561     (emit-invokestatic +lisp-class+
2562                        "list3"
2563                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
2564                        -2)
2565     (emit-move-from-stack target)
2566     t)
2567    (SYS::%STRUCTURE-SET
2568     (when (fixnump (second args))
2569       (compile-form (first args) :target :stack)
2570       (maybe-emit-clear-values (first args))
2571       (emit 'sipush (second args))
2572       (compile-form (third args) :target :stack)
2573       (maybe-emit-clear-values (third args))
2574       (emit-invokevirtual +lisp-object-class+
2575                           "setSlotValue"
2576                           "(ILorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2577                           -2)
2578       (emit-move-from-stack target)
2579       t))
2580    (t
2581     nil)))
2582
2583(defvar *toplevel-defuns* nil)
2584
2585(defsubst notinline-p (name)
2586  (declare (optimize speed))
2587  (eq (get name '%inline) 'NOTINLINE))
2588
2589(defun inline-ok (name)
2590  (declare (optimize speed))
2591  (cond ((notinline-p name)
2592         nil)
2593        ((sys:built-in-function-p name)
2594         t)
2595        ((memq name *toplevel-defuns*)
2596         t)
2597        (t
2598         nil)))
2599
2600(defun unsafe-p (args)
2601  (cond ((node-p args)
2602         (unsafe-p (node-form args)))
2603        ((atom args)
2604         nil)
2605        (t
2606         (case (car args)
2607           (QUOTE
2608            nil)
2609           (LAMBDA
2610            nil)
2611           ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
2612            t)
2613           (t
2614            (dolist (arg args)
2615              (when (unsafe-p arg)
2616                (return t))))))))
2617
2618(defun rewrite-function-call (form)
2619  (let ((args (cdr form)))
2620    (if (unsafe-p args)
2621        (let ((syms ())
2622              (lets ()))
2623          ;; Preserve the order of evaluation of the arguments!
2624          (dolist (arg args)
2625            (if (constantp arg)
2626                (push arg syms)
2627                (let ((sym (gensym)))
2628                  (push sym syms)
2629                  (push (list sym arg) lets))))
2630          (list 'LET* (nreverse lets) (list* (car form) (nreverse syms))))
2631        form)))
2632
2633(defun process-args (args)
2634  (let ((numargs (length args)))
2635    (when (plusp numargs)
2636      (let ((must-clear-values nil))
2637        (cond ((<= numargs 4)
2638               (dolist (arg args)
2639                 (compile-form arg :target :stack)
2640                 (unless must-clear-values
2641                   (unless (single-valued-p arg)
2642                     (setf must-clear-values t)))))
2643              (t
2644               (emit 'sipush numargs)
2645               (emit 'anewarray "org/armedbear/lisp/LispObject")
2646               (let ((i 0))
2647                 (dolist (arg args)
2648                   (emit 'dup)
2649                   (emit 'sipush i)
2650                   (compile-form arg :target :stack)
2651                   (emit 'aastore) ; store value in array
2652                   (unless must-clear-values
2653                     (unless (single-valued-p arg)
2654                       (setf must-clear-values t)))
2655                   (incf i)))))
2656        (when must-clear-values
2657          (emit-clear-values))))))
2658
2659(defun emit-call-execute (numargs)
2660  (let ((descriptor
2661         (case numargs
2662           (0 "()Lorg/armedbear/lisp/LispObject;")
2663           (1 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2664           (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2665           (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2666           (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2667           (t "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
2668        (stack-effect (if (< numargs 5)
2669                          (- numargs)
2670                          -1)))
2671    (emit-invokevirtual +lisp-object-class+ "execute" descriptor stack-effect)))
2672
2673(defun emit-call-thread-execute (numargs)
2674  (let ((descriptor
2675         (case numargs
2676           (0 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2677           (1 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2678           (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2679           (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2680           (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2681           (t "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
2682        (stack-effect (if (< numargs 5)
2683                          (- (1+ numargs))
2684                          -2)))
2685    (emit-invokevirtual +lisp-thread-class+ "execute" descriptor stack-effect)))
2686
2687(defun compile-function-call (form target representation)
2688  (let ((op (car form))
2689        (args (cdr form)))
2690    (unless (symbolp op)
2691      (error "COMPILE-FUNCTION-CALL ~S is not a symbol" op))
2692    (when (find-local-function op)
2693      (return-from compile-function-call (compile-local-function-call form target)))
2694    (let ((numargs (length args)))
2695      (case (length args)
2696        (1
2697         (when (compile-function-call-1 op args target representation)
2698           (return-from compile-function-call)))
2699        (2
2700         (when (compile-function-call-2 op args target representation)
2701           (return-from compile-function-call)))
2702        (3
2703         (when (compile-function-call-3 op args target)
2704           (return-from compile-function-call))))
2705      (unless (> *speed* *debug*)
2706        (emit-push-current-thread))
2707      (cond
2708       ((eq op (compiland-name *current-compiland*)) ; recursive call
2709        (emit 'aload 0)) ; this
2710       ((inline-ok op)
2711        (emit 'getstatic
2712              *this-class*
2713              (declare-function op)
2714              +lisp-object+))
2715       ((null (symbol-package op))
2716        (let ((g (if *compile-file-truename*
2717                     (declare-object-as-string op)
2718                     (declare-object op))))
2719          (emit 'getstatic
2720                *this-class*
2721                g
2722                +lisp-object+)))
2723       (t
2724        (emit 'getstatic
2725              *this-class*
2726              (declare-symbol op)
2727              +lisp-symbol+)))
2728      (process-args args)
2729      (if (> *speed* *debug*)
2730          (emit-call-execute numargs)
2731          (emit-call-thread-execute numargs))
2732      (when (eq representation :unboxed-fixnum)
2733        (emit-unbox-fixnum))
2734      (emit-move-from-stack target))))
2735
2736(defun compile-call (args)
2737  (let ((numargs (length args)))
2738    (cond ((> *speed* *debug*)
2739           (process-args args)
2740           (emit-call-execute numargs))
2741          (t
2742           (emit-push-current-thread)
2743           (emit 'swap) ; Stack: thread function
2744           (process-args args)
2745           (emit-call-thread-execute numargs)))))
2746
2747(define-source-transform funcall (&whole form fun &rest args)
2748  (cond ((> *debug* *speed*)
2749         form)
2750        ((and (consp fun)
2751              (eq (car fun) 'FUNCTION)
2752              (symbolp (cadr fun)))
2753         `(,(cadr fun) ,@args))
2754        ((and (consp fun)
2755              (eq (car fun) 'QUOTE))
2756         (let ((sym (cadr fun)))
2757           (if (and (symbolp sym)
2758                    (eq (symbol-package sym) (find-package "CL"))
2759                    (not (special-operator-p sym))
2760                    (not (macro-function sym)))
2761               `(,(cadr fun) ,@args)
2762               form)))
2763        (t
2764         form)))
2765
2766(defun compile-funcall (form &key (target *val*) representation)
2767  (unless (> (length form) 1)
2768    (compiler-style-warn "Wrong number of arguments for ~A." (car form))
2769    (compile-function-call form target representation))
2770  (when (> *debug* *speed*)
2771    (return-from compile-funcall (compile-function-call form target representation)))
2772  (compile-form (cadr form) :target :stack)
2773  (maybe-emit-clear-values (cadr form))
2774  (compile-call (cddr form))
2775  (emit-move-from-stack target))
2776
2777(defun compile-local-function-call (form target)
2778  (dformat t "compile-local-function-call~%")
2779  (let* ((op (car form))
2780         (args (cdr form))
2781         (local-function (find-local-function op)))
2782    (cond
2783     ((eq (local-function-compiland local-function) *current-compiland*)
2784      (emit 'aload_0))
2785     ((local-function-variable local-function)
2786      ;; LABELS
2787      (dformat t "compile-local-function-call LABELS case~%")
2788      (emit 'var-ref (local-function-variable local-function) :stack))
2789     (t
2790      (let* ((g (if *compile-file-truename*
2791                    (declare-local-function local-function)
2792                    (declare-object (local-function-function local-function)))))
2793        (emit 'getstatic
2794              *this-class*
2795              g
2796              +lisp-object+)))) ; Stack: template-function
2797
2798    (when *closure-variables*
2799      (emit 'checkcast +lisp-ctf-class+))
2800
2801    (when *closure-variables*
2802      ;; First arg is closure variable array.
2803      (aver (not (null (compiland-closure-register *current-compiland*))))
2804      (emit 'aload (compiland-closure-register *current-compiland*)))
2805    (cond
2806     ((> (length args) 4)
2807      (emit-push-constant-int (length args))
2808      (emit 'anewarray "org/armedbear/lisp/LispObject")
2809      (let ((i 0)
2810            (must-clear-values nil))
2811        (dolist (arg args)
2812          (emit 'dup)
2813          (emit 'sipush i)
2814          (compile-form arg :target :stack)
2815          (emit 'aastore) ; store value in array
2816          (unless must-clear-values
2817            (unless (single-valued-p arg)
2818              (setf must-clear-values t)))
2819          (incf i))
2820        (when must-clear-values
2821          (emit-clear-values)))) ; array left on stack here
2822     (t
2823      (let ((must-clear-values nil))
2824        (dolist (arg args)
2825          (compile-form arg :target :stack)
2826          (unless must-clear-values
2827            (unless (single-valued-p arg)
2828              (setf must-clear-values t))))
2829        (when must-clear-values
2830          (emit-clear-values))))) ; args left on stack here
2831
2832    (if *closure-variables*
2833          (case (length args)
2834            (0
2835             (emit-invokevirtual +lisp-ctf-class+
2836                                 "execute"
2837                                 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2838                                 -1))
2839            (1
2840             (emit-invokevirtual +lisp-ctf-class+
2841                                 "execute"
2842                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2843                                 -2))
2844            (2
2845             (emit-invokevirtual +lisp-ctf-class+
2846                                 "execute"
2847                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2848                                 -3))
2849            (3
2850             (emit-invokevirtual +lisp-ctf-class+
2851                                 "execute"
2852                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2853                                 -4))
2854            (4
2855             (emit-invokevirtual +lisp-ctf-class+
2856                                 "execute"
2857                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2858                                 -5))
2859            (t
2860             (emit-invokevirtual +lisp-ctf-class+
2861                                 "execute"
2862                                 "([Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2863                                 -2)))
2864          ;; No closure variables.
2865          (case (length args)
2866            (0
2867             (emit-invokevirtual +lisp-object-class+
2868                                 "execute"
2869                                 "()Lorg/armedbear/lisp/LispObject;"
2870                                 0))
2871            (1
2872             (emit-invokevirtual +lisp-object-class+
2873                                 "execute"
2874                                 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2875                                 -1))
2876            (2
2877             (emit-invokevirtual +lisp-object-class+
2878                                 "execute"
2879                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2880                                 -2))
2881            (3
2882             (emit-invokevirtual +lisp-object-class+
2883                                 "execute"
2884                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2885                                 -3))
2886            (4
2887             (emit-invokevirtual +lisp-object-class+
2888                                 "execute"
2889                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2890                                 -4))
2891            (t
2892             (emit-invokevirtual +lisp-object-class+
2893                                 "execute"
2894                                 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2895                                 -1))))
2896    (cond ((null target)
2897           (emit 'pop)
2898           (maybe-emit-clear-values form))
2899          ((eq target :stack))
2900          ((fixnump target)
2901           (emit 'astore target))
2902          (t
2903           (%format t "line 1876~%")
2904           (aver nil)))))
2905
2906(defparameter java-predicates (make-hash-table :test 'eq))
2907
2908(defun define-java-predicate (predicate translation)
2909  (setf (gethash predicate java-predicates) translation))
2910
2911(define-java-predicate 'CHARACTERP         "characterp")
2912(define-java-predicate 'CONSTANTP          "constantp")
2913(define-java-predicate 'ENDP               "endp")
2914(define-java-predicate 'EVENP              "evenp")
2915(define-java-predicate 'FLOATP             "floatp")
2916(define-java-predicate 'INTEGERP           "integerp")
2917(define-java-predicate 'LISTP              "listp")
2918(define-java-predicate 'MINUSP             "minusp")
2919(define-java-predicate 'NUMBERP            "numberp")
2920(define-java-predicate 'ODDP               "oddp")
2921(define-java-predicate 'PLUSP              "plusp")
2922(define-java-predicate 'RATIONALP          "rationalp")
2923(define-java-predicate 'REALP              "realp")
2924(define-java-predicate 'STRINGP            "stringp")
2925(define-java-predicate 'SPECIAL-VARIABLE-P "isSpecialVariable")
2926(define-java-predicate 'VECTORP            "vectorp")
2927(define-java-predicate 'ZEROP              "zerop")
2928
2929(defun compile-test-2 (form negatep)
2930  (let* ((op (car form))
2931         (args (cdr form))
2932         (arg (car args))
2933         variable)
2934    (when (memq op '(NOT NULL))
2935      (return-from compile-test-2 (compile-test arg (not negatep))))
2936    (when (setf variable (unboxed-fixnum-variable arg))
2937      (case op
2938        (MINUSP
2939         (dformat t "compile-test-2 minusp case~%")
2940         (aver (variable-register variable))
2941         (emit 'iload (variable-register variable))
2942         (return-from compile-test-2 (if negatep 'iflt 'ifge))
2943         )
2944        ))
2945    (when (eq op 'SYMBOLP)
2946      (process-args args)
2947      (emit 'instanceof +lisp-symbol-class+)
2948      (return-from compile-test-2 (if negatep 'ifne 'ifeq)))
2949    (when (eq op 'FIXNUMP)
2950      (process-args args)
2951      (emit 'instanceof +lisp-fixnum-class+)
2952      (return-from compile-test-2 (if negatep 'ifne 'ifeq)))
2953    (when (eq op 'CONSP)
2954      (process-args args)
2955      (emit 'instanceof +lisp-cons-class+)
2956      (return-from compile-test-2 (if negatep 'ifne 'ifeq)))
2957    (when (eq op 'ATOM)
2958      (process-args args)
2959      (emit 'instanceof +lisp-cons-class+)
2960      (return-from compile-test-2 (if negatep 'ifeq 'ifne)))
2961    (let ((s (gethash op java-predicates)))
2962      (when s
2963        (process-args args)
2964        (emit-invokevirtual +lisp-object-class+
2965                            s
2966                            "()Z"
2967                            0)
2968        (return-from compile-test-2 (if negatep 'ifne 'ifeq)))))
2969  ;; Otherwise...
2970  (compile-form form :target :stack)
2971  (maybe-emit-clear-values form)
2972  (emit-push-nil)
2973  (if negatep 'if_acmpne 'if_acmpeq))
2974
2975(defun p2-numeric-comparison (form &key (target *val*) representation)
2976  (let ((op (car form))
2977        (args (cdr form)))
2978    (case (length args)
2979      (2
2980       (let ((first (first args))
2981             (second (second args))
2982             var1 var2)
2983         (cond
2984          ((and (fixnump first) (fixnump second))
2985           (dformat t "p2-numeric-comparison form = ~S~%" form)
2986           (if (funcall op first second)
2987               (emit-push-t)
2988               (emit-push-nil))
2989           (return-from p2-numeric-comparison))
2990          ((fixnump second)
2991           (dformat t "p2-numeric-comparison form = ~S~%" form)
2992           (compile-form (car args) :target :stack)
2993           (unless (single-valued-p first)
2994             (emit-clear-values))
2995           (emit-push-constant-int second)
2996           (emit-invokevirtual +lisp-object-class+
2997                               (case op
2998                                 (<  "isLessThan")
2999                                 (<= "isLessThanOrEqualTo")
3000                                 (>  "isGreaterThan")
3001                                 (>= "isGreaterThanOrEqualTo")
3002                                 (=  "isEqualTo")
3003                                 (/= "isNotEqualTo"))
3004                               "(I)Z"
3005                               -1)
3006           ;; Java boolean on stack here
3007           (let ((LABEL1 (gensym))
3008                 (LABEL2 (gensym)))
3009             (emit 'ifeq LABEL1)
3010             (emit-push-t)
3011             (emit 'goto LABEL2)
3012             (label LABEL1)
3013             (emit-push-nil)
3014             (label LABEL2)
3015             (emit-move-from-stack target))
3016           (return-from p2-numeric-comparison))
3017          ((and (setf var1 (unboxed-fixnum-variable first))
3018                (setf var2 (unboxed-fixnum-variable second)))
3019           (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
3020           (let ((LABEL1 (gensym))
3021                 (LABEL2 (gensym)))
3022           (emit 'iload (variable-register var1))
3023           (emit 'iload (variable-register var2))
3024           (emit (case op
3025                   (<  'if_icmpge)
3026                   (<= 'if_icmpgt)
3027                   (>  'if_icmple)
3028                   (>= 'if_icmplt)
3029                   (=  'if_icmpne)
3030                   (/= 'if_icmpeq))
3031                 LABEL1)
3032             (emit-push-t)
3033             (emit 'goto LABEL2)
3034             (label LABEL1)
3035             (emit-push-nil)
3036             (label LABEL2)
3037             (emit-move-from-stack target)
3038             (return-from p2-numeric-comparison))
3039           )
3040          ) ; cond
3041       ))))
3042  ;; Still here?
3043  (compile-function-call form target representation)
3044  )
3045
3046(defun compile-test-3 (form negatep)
3047;;   (dformat t "compile-test-3 form = ~S~%" form)
3048  (let ((op (car form))
3049        (args (cdr form)))
3050    (when (eq op 'EQ)
3051      (process-args args)
3052      (return-from compile-test-3 (if negatep 'if_acmpeq 'if_acmpne)))
3053    (let* ((arg1 (first args))
3054           (arg2 (second args))
3055           (var1 (unboxed-fixnum-variable arg1))
3056           (var2 (unboxed-fixnum-variable arg2)))
3057      (when (memq op '(< <= > >= = /=))
3058        (when (and (arg-is-fixnum-p arg1)
3059                   (arg-is-fixnum-p arg2))
3060          (emit-push-int arg1)
3061          (emit-push-int arg2)
3062          (case op
3063            (<
3064             (return-from compile-test-3 (if negatep 'if_icmplt 'if_icmpge)))
3065            (<=
3066             (return-from compile-test-3 (if negatep 'if_icmple 'if_icmpgt)))
3067            (>
3068             (return-from compile-test-3 (if negatep 'if_icmpgt 'if_icmple)))
3069            (>=
3070             (return-from compile-test-3 (if negatep 'if_icmpge 'if_icmplt)))
3071            (=
3072             (return-from compile-test-3 (if negatep 'if_icmpeq 'if_icmpne)))
3073            (/=
3074             (return-from compile-test-3 (if negatep 'if_icmpne 'if_icmpeq)))
3075            ))
3076
3077        ;; Otherwise...
3078        (when (arg-is-fixnum-p arg2)
3079          (compile-form arg1 :target :stack)
3080          (maybe-emit-clear-values arg1)
3081          (emit-push-int arg2)
3082          (emit-invokevirtual +lisp-object-class+
3083                              (case op
3084                                (<  "isLessThan")
3085                                (<= "isLessThanOrEqualTo")
3086                                (>  "isGreaterThan")
3087                                (>= "isGreaterThanOrEqualTo")
3088                                (=  "isEqualTo")
3089                                (/= "isNotEqualTo"))
3090                              "(I)Z"
3091                              -1)
3092          (return-from compile-test-3 (if negatep 'ifne 'ifeq))))
3093
3094      (when (eq op '<)
3095          (when var1
3096            (dformat t "compile-test-3 unboxed fixnum var1 comparison case~%")
3097            (aver (variable-register var1))
3098            (emit 'iload (variable-register var1))
3099            (compile-form arg2 :target :stack)
3100            (emit 'swap)
3101            (emit-invokevirtual +lisp-object-class+
3102                                "isGreaterThan"
3103                                "(I)Z"
3104                                -1)
3105            (return-from compile-test-3 (if negatep 'ifne 'ifeq)))))
3106
3107    (let ((s (cdr (assq op
3108                        '((=      . "isEqualTo")
3109                          (/=     . "isNotEqualTo")
3110                          (<      . "isLessThan")
3111                          (<=     . "isLessThanOrEqualTo")
3112                          (>      . "isGreaterThan")
3113                          (>=     . "isGreaterThanOrEqualTo")
3114                          (EQL    . "eql")
3115                          (EQUAL  . "equal")
3116                          (EQUALP . "equalp"))))))
3117      (when s
3118        (let ((first (first args))
3119              (second (second args))
3120              variable)
3121          (cond
3122           ((fixnump second)
3123            (compile-form first :target :stack)
3124            (maybe-emit-clear-values first)
3125            (emit-push-constant-int second)
3126            (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))
3127           ((setf variable (unboxed-fixnum-variable second))
3128            (compile-form first :target :stack)
3129            (maybe-emit-clear-values first)
3130            (aver (variable-register variable))
3131            (emit 'iload (variable-register variable))
3132            (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))
3133           (t
3134            (process-args args)
3135            (emit-invokevirtual +lisp-object-class+
3136                                s
3137                                "(Lorg/armedbear/lisp/LispObject;)Z"
3138                                -1)))
3139          (return-from compile-test-3 (if negatep 'ifne 'ifeq))))))
3140
3141  ;; Otherwise...
3142  (compile-form form :target :stack)
3143  (maybe-emit-clear-values form)
3144  (emit-push-nil)
3145  (if negatep 'if_acmpne 'if_acmpeq))
3146
3147(defun compile-test (form negatep)
3148  ;; Use a Java boolean if possible.
3149  (when (and (consp form)
3150             (not (special-operator-p (car form))))
3151    (case (length form)
3152      (2
3153       (return-from compile-test (compile-test-2 form negatep)))
3154      (3
3155       (return-from compile-test (compile-test-3 form negatep)))))
3156  ;; Otherwise...
3157  (compile-form form :target :stack)
3158  (maybe-emit-clear-values form)
3159  (emit-push-nil)
3160  (if negatep 'if_acmpne 'if_acmpeq))
3161
3162(defun compile-if (form &key (target *val*) representation)
3163;;   (dformat t "compile-if form = ~S~%" form)
3164  (let* ((test (second form))
3165         (consequent (third form))
3166         (alternate (fourth form))
3167         (LABEL1 (gensym))
3168         (LABEL2 (gensym)))
3169    (cond ((eq test t)
3170           (compile-form consequent :target target :representation representation))
3171          ((null test)
3172           (compile-form alternate :target target :representation representation))
3173          ((numberp test)
3174           (compile-form consequent :target target :representation representation))
3175          (t
3176           (emit (compile-test test nil) LABEL1)
3177           (compile-form consequent :target target)
3178           (emit 'goto LABEL2)
3179           (label LABEL1)
3180           (compile-form alternate :target target)
3181           (label LABEL2)))))
3182
3183(defun compile-multiple-value-list (form &key (target *val*) representation)
3184  ;; Added Dec 9 2004 7:52 PM
3185  (emit-clear-values)
3186
3187  (compile-form (second form) :target :stack)
3188  (emit-invokestatic +lisp-class+
3189                     "multipleValueList"
3190                     "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3191                     0)
3192  (emit-move-from-stack target))
3193
3194(defun compile-multiple-value-prog1 (form &key (target *val*) representation)
3195  (let ((first-subform (cadr form))
3196        (subforms (cddr form))
3197        (result-register (allocate-register))
3198        (values-register (allocate-register)))
3199
3200    ;; Added Dec 9 2004 3:46 AM
3201    ;; Make sure there are no leftover values from previous calls.
3202    (emit-clear-values)
3203
3204    (compile-form first-subform :target result-register)
3205    ;; Save multiple values returned by first subform.
3206    (emit-push-current-thread)
3207    (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
3208    (emit 'astore values-register)
3209    (dolist (subform subforms)
3210      (compile-form subform :target nil))
3211    ;; Restore multiple values returned by first subform.
3212    (emit-push-current-thread)
3213    (emit 'aload values-register)
3214    (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
3215    ;; Result.
3216    (emit 'aload result-register)
3217    (emit-move-from-stack target)))
3218
3219(defun compile-multiple-value-call (form &key (target *val*) representation)
3220  (case (length form)
3221    (1
3222     (error "Wrong number of arguments for MULTIPLE-VALUE-CALL."))
3223    (2
3224     (compile-form (second form) :target :stack)
3225     (emit-invokestatic +lisp-class+
3226                        "coerceToFunction"
3227                        "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3228                        0)
3229     (emit-invokevirtual +lisp-object-class+
3230                         "execute"
3231                         "()Lorg/armedbear/lisp/LispObject;"
3232                         0)
3233     (emit-move-from-stack target))
3234    (3
3235     (let* ((*register* *register*)
3236            (function-register (allocate-register)))
3237       (compile-form (second form) :target function-register)
3238       (compile-form (third form) :target :stack)
3239       (emit 'aload function-register)
3240       (emit-push-current-thread)
3241       (emit-invokestatic +lisp-class+
3242                          "multipleValueCall1"
3243                          "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;"
3244                          -2)
3245       (emit-move-from-stack target)))
3246    (t
3247     ;; The general case.
3248     (let* ((*register* *register*)
3249            (function-register (allocate-register))
3250            (values-register (allocate-register)))
3251       (compile-form (second form) :target :stack)
3252       (emit-invokestatic +lisp-class+
3253                          "coerceToFunction"
3254                          "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3255                          0)
3256       (emit-move-from-stack function-register)
3257       (emit 'aconst_null)
3258       (emit 'astore values-register)
3259       (dolist (values-form (cddr form))
3260         (compile-form values-form :target :stack)
3261         (emit-push-current-thread)
3262         (emit 'swap)
3263         (emit 'aload values-register)
3264         (emit-invokevirtual +lisp-thread-class+
3265                             "accumulateValues"
3266                             "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;"
3267                             -2)
3268         (emit 'astore values-register)
3269         (maybe-emit-clear-values values-form))
3270       (emit 'aload function-register)
3271       (emit 'aload values-register)
3272       (emit-invokevirtual +lisp-object-class+
3273                           "execute"
3274                           "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3275                           -1)
3276       (emit-move-from-stack target)))))
3277
3278;; Generates code to bind variable to value at top of runtime stack.
3279(defun compile-binding (variable)
3280  (cond ((variable-register variable)
3281         (emit 'astore (variable-register variable)))
3282        ((variable-special-p variable)
3283         (emit-push-current-thread)
3284         (emit 'swap)
3285         (emit 'getstatic
3286               *this-class*
3287               (declare-symbol (variable-name variable))
3288               +lisp-symbol+)
3289         (emit 'swap)
3290         (emit-invokevirtual +lisp-thread-class+
3291                             "bindSpecial"
3292                             "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
3293                             -3))
3294        ((variable-closure-index variable)
3295         (emit 'aload (compiland-closure-register *current-compiland*))
3296         (emit 'swap) ; array value
3297         (emit-push-constant-int (variable-closure-index variable))
3298         (emit 'swap) ; array index value
3299         (emit 'aastore))
3300        (t
3301         (aver nil))))
3302
3303(defun p2-m-v-b-node (block target)
3304  (let* ((*blocks* (cons block *blocks*))
3305         (*register* *register*)
3306         (form (block-form block))
3307         (*visible-variables* *visible-variables*)
3308         (specials ())
3309         (vars (second form))
3310         (bind-special-p nil)
3311         (variables (block-vars block)))
3312    (dolist (variable variables)
3313      (let ((special-p (variable-special-p variable)))
3314        (cond (special-p
3315               (setf bind-special-p t))
3316              (t
3317;;                (setf (variable-index variable) (length (context-vars *context*)))
3318               (unless (variable-closure-index variable)
3319                 (setf (variable-register variable) (allocate-register)))
3320;;                (add-variable-to-context variable)
3321               ))))
3322    ;; If we're going to bind any special variables...
3323    (when bind-special-p
3324      ;; Save current dynamic environment.
3325      (setf (block-environment-register block) (allocate-register))
3326      (emit-push-current-thread)
3327      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3328      (emit 'astore (block-environment-register block)))
3329
3330    ;; Added Dec 9 2004 3:46 AM
3331    ;; Make sure there are no leftover values from previous calls.
3332    (emit-clear-values)
3333
3334    ;; Bind the variables.
3335    (aver (= (length vars) (length variables)))
3336    (cond ((= (length vars) 1)
3337           (compile-form (third form) :target :stack)
3338           (maybe-emit-clear-values (third form))
3339           (compile-binding (car variables)))
3340          (t
3341           (let* ((*register* *register*)
3342                  (result-register (allocate-register))
3343                  (values-register (allocate-register))
3344                  (LABEL1 (gensym))
3345                  (LABEL2 (gensym)))
3346             ;; Store primary value from values form in result register.
3347             (compile-form (third form) :target result-register)
3348             ;; Store values from values form in values register.
3349             (emit-push-current-thread)
3350             (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
3351             (emit-move-from-stack values-register)
3352             ;; Did we get just one value?
3353             (emit 'aload values-register)
3354             (emit 'ifnull LABEL1)
3355             ;; Reaching here, we have multiple values (or no values at all). We need
3356             ;; the slow path if we have more variables than values.
3357             (emit 'aload values-register)
3358             (emit 'arraylength)
3359             (emit 'bipush (length vars))
3360             (emit 'if_icmplt LABEL1)
3361             ;; Reaching here, we have enough values for all the variables. We can use
3362             ;; the values we have. This is the fast path.
3363             (emit 'aload values-register)
3364             (emit 'goto LABEL2)
3365             (label LABEL1)
3366             (emit-push-current-thread)
3367             (emit 'aload result-register)
3368             (emit 'bipush (length vars))
3369             (emit-invokevirtual +lisp-thread-class+
3370                                 "getValues"
3371                                 "(Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"
3372                                 -2)
3373             ;; Values array is now on the stack at runtime.
3374             (label LABEL2)
3375             (let ((index 0))
3376               (dolist (variable variables)
3377                 (when (< index (1- (length vars)))
3378                   (emit 'dup))
3379                 (emit 'bipush index)
3380                 (incf index)
3381                 (emit 'aaload)
3382                 ;; Value is on the runtime stack at this point.
3383                 (compile-binding variable)))
3384             (maybe-emit-clear-values (third form)))))
3385    ;; Make the variables visible for the body forms.
3386    (dolist (variable variables)
3387      (push variable *visible-variables*)
3388;;       (push variable *all-variables*)
3389      )
3390    ;; Body.
3391    (compile-progn-body (cdddr form) target)
3392    (when bind-special-p
3393      ;; Restore dynamic environment.
3394      (emit 'aload *thread*)
3395      (emit 'aload (block-environment-register block))
3396      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
3397
3398(defun p2-let/let*-node (block target)
3399  (let* ((*blocks* (cons block *blocks*))
3400         (*register* *register*)
3401         (form (block-form block))
3402         (*visible-variables* *visible-variables*)
3403         (specialp nil))
3404    ;; Are we going to bind any special variables?
3405    (dolist (variable (block-vars block))
3406      (when (variable-special-p variable)
3407        (setf specialp t)
3408        (return)))
3409    ;; If so...
3410    (when specialp
3411      ;; Save current dynamic environment.
3412      (setf (block-environment-register block) (allocate-register))
3413      (emit-push-current-thread)
3414      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3415      (emit 'astore (block-environment-register block)))
3416    (ecase (car form)
3417      (LET
3418       (p2-let-bindings block))
3419      (LET*
3420       (p2-let*-bindings block)))
3421    ;; Make declarations of free specials visible.
3422    (dolist (variable (block-free-specials block))
3423      (push variable *visible-variables*))
3424    ;; Body of LET/LET*.
3425    (compile-progn-body (cddr form) target)
3426    (when specialp
3427      ;; Restore dynamic environment.
3428      (emit 'aload *thread*)
3429      (emit 'aload (block-environment-register block))
3430      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
3431
3432(defun p2-let-bindings (block)
3433  (dolist (variable (block-vars block))
3434    (unless (variable-special-p variable)
3435      (unless (variable-closure-index variable)
3436        (setf (variable-register variable) (allocate-register)))))
3437  (let ((*register* *register*)
3438        (must-clear-values nil))
3439    ;; Evaluate each initform. If the variable being bound is special, allocate
3440    ;; a temporary register for the result; LET bindings must be done in
3441    ;; parallel, so we can't modify any specials until all the initforms have
3442    ;; been evaluated. Note that we can't just push the values on the stack
3443    ;; because we'll lose JVM stack consistency if there is a non-local
3444    ;; transfer of control from one of the initforms.
3445    (dolist (variable (block-vars block))
3446      (dformat t "variable = ~S writes = ~S~%" (variable-name variable) (variable-writes variable))
3447      (let ((initform (variable-initform variable)))
3448        (cond (initform
3449               (cond
3450                ((and *trust-user-type-declarations*
3451                      (variable-register variable)
3452                      (variable-declared-type variable)
3453                      (subtypep (variable-declared-type variable) 'FIXNUM))
3454                 (dformat t "p2-let-bindings declared fixnum case: ~S~%"
3455                          (variable-name variable))
3456                 (setf (variable-representation variable) :unboxed-fixnum)
3457                 (compile-form initform :target :stack :representation :unboxed-fixnum))
3458                ((and (variable-register variable)
3459                      (eql (variable-writes variable) 0)
3460                      (subtypep (derive-type initform) 'FIXNUM))
3461                 (dformat t "p2-let-bindings read-only fixnum case: ~S~%"
3462                          (variable-name variable))
3463                 (setf (variable-representation variable) :unboxed-fixnum)
3464                 (compile-form initform :target :stack :representation :unboxed-fixnum))
3465                (t
3466                 (compile-form initform :target :stack)))
3467               (unless must-clear-values
3468                 (unless (single-valued-p initform)
3469                   (setf must-clear-values t))))
3470              (t
3471               (emit-push-nil)))
3472        (cond
3473         ((variable-special-p variable)
3474          (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register))))
3475         ((eq (variable-representation variable) :unboxed-fixnum)
3476          (emit 'istore (variable-register variable)))
3477         (t
3478          (compile-binding variable)))))
3479    (when must-clear-values
3480      (emit-clear-values))
3481    ;; Now that all the initforms have been evaluated, move the results from
3482    ;; the temporary registers (if any) to their proper destinations.
3483    (dolist (variable (block-vars block))
3484      (when (variable-temp-register variable)
3485        (aver (variable-special-p variable))
3486        (emit 'aload (variable-temp-register variable))
3487        (compile-binding variable))))
3488  ;; Now make the variables visible.
3489  (dolist (variable (block-vars block))
3490    (push variable *visible-variables*)))
3491
3492(defun p2-let*-bindings (block)
3493  (let ((must-clear-values nil))
3494    ;; Generate code to evaluate initforms and bind variables.
3495    (dolist (variable (block-vars block))
3496      (let* ((initform (variable-initform variable))
3497             (boundp nil))
3498        (cond
3499         ((and (variable-special-p variable)
3500               (eq initform (variable-name variable)))
3501          (emit-push-current-thread)
3502          (emit 'getstatic
3503                *this-class*
3504                (declare-symbol (variable-name variable))
3505                +lisp-symbol+)
3506          (emit-invokevirtual +lisp-thread-class+
3507                              "bindSpecialToCurrentValue"
3508                              "(Lorg/armedbear/lisp/Symbol;)V"
3509                              -2)
3510          (setf boundp t))
3511         (initform
3512          (cond
3513           ((and *trust-user-type-declarations*
3514;;                  (not *use-locals-vector*)
3515                 (null (variable-closure-index variable))
3516                 (not (variable-special-p variable))
3517                 (variable-declared-type variable)
3518                 (subtypep (variable-declared-type variable) 'FIXNUM))
3519            (dformat t "p2-let*-bindings declared fixnum case~%")
3520            (setf (variable-representation variable) :unboxed-fixnum)
3521            (compile-form initform :target :stack :representation :unboxed-fixnum)
3522            (setf (variable-register variable) (allocate-register))
3523            (emit 'istore (variable-register variable))
3524            (setf boundp t))
3525           ((and ;;(not *use-locals-vector*)
3526                 (null (variable-closure-index variable))
3527                 (not (variable-special-p variable))
3528                 (eql (variable-writes variable) 0)
3529                 (subtypep (derive-type initform) 'FIXNUM))
3530            (dformat t "p2-let*-bindings read-only fixnum case: ~S~%"
3531                     (variable-name variable))
3532            (setf (variable-representation variable) :unboxed-fixnum)
3533            (compile-form initform :target :stack :representation :unboxed-fixnum)
3534            (setf (variable-register variable) (allocate-register))
3535            (emit 'istore (variable-register variable))
3536            (setf boundp t))
3537           (t
3538            (compile-form initform :target :stack)))
3539          (unless must-clear-values
3540            (unless (single-valued-p initform)
3541              (setf must-clear-values t))))
3542         (t
3543          (emit-push-nil)))
3544        (unless (variable-special-p variable)
3545          (unless (or (variable-closure-index variable) (variable-register variable))
3546            (setf (variable-register variable) (allocate-register))))
3547        (push variable *visible-variables*)
3548        (unless boundp
3549          (compile-binding variable))))
3550    (when must-clear-values
3551      (emit-clear-values))))
3552
3553;; Returns list of declared specials.
3554(defun process-special-declarations (forms)
3555  (let ((specials ()))
3556    (dolist (form forms)
3557      (unless (and (consp form) (eq (car form) 'declare))
3558        (return))
3559      (let ((decls (cdr form)))
3560        (dolist (decl decls)
3561          (when (eq (car decl) 'special)
3562            (setf specials (append (cdr decl) specials))))))
3563    specials))
3564
3565(defun compile-locally (form &key (target *val*) representation)
3566  (let ((*visible-variables* *visible-variables*)
3567        (specials (process-special-declarations (cdr form))))
3568    (dolist (var specials)
3569      (push (make-variable :name var :special-p t) *visible-variables*))
3570    (cond ((null (cdr form))
3571           (when target
3572             (emit-push-nil)
3573             (emit-move-from-stack target)))
3574          (t
3575           (do ((forms (cdr form) (cdr forms)))
3576               ((null forms))
3577             (compile-form (car forms) :target (if (cdr forms) nil target)))))))
3578
3579(defun find-tag (name)
3580  (dolist (tag *visible-tags*)
3581    (when (eql name (tag-name tag))
3582      (return tag))))
3583
3584(defun p2-tagbody-node (block target)
3585  (let* ((*blocks* (cons block *blocks*))
3586         (*visible-tags* *visible-tags*)
3587         (*register* *register*)
3588         (form (block-form block))
3589         (body (cdr form))
3590         (local-tags ())
3591         (BEGIN-BLOCK (gensym))
3592         (END-BLOCK (gensym))
3593         (EXIT (gensym))
3594         environment-register
3595         (must-clear-values nil))
3596    ;; Scan for tags.
3597    (dolist (subform body)
3598      (when (or (symbolp subform) (integerp subform))
3599        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
3600          (push tag local-tags)
3601          (push tag *visible-tags*))))
3602
3603    ;; FIXME Pass 1 doesn't detect all non-local GOs! (HANDLER-CASE.17)
3604    ;; So we do this unconditionally for now...
3605    (when (or t (block-non-local-go-p block))
3606      (setf environment-register (allocate-register))
3607      (emit-push-current-thread)
3608      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3609      (emit 'astore environment-register))
3610
3611    (label BEGIN-BLOCK)
3612    (do* ((rest body (cdr rest))
3613          (subform (car rest) (car rest)))
3614         ((null rest))
3615      (cond ((or (symbolp subform) (integerp subform))
3616             (let ((tag (find-tag subform)))
3617               (unless tag
3618                 (error "COMPILE-TAGBODY: tag not found: ~S~%" subform))
3619               (label (tag-label tag))))
3620            (t
3621             (when (and (null (cdr rest)) ;; Last subform.
3622                        (consp subform)
3623                        (eq (car subform) 'GO))
3624               (maybe-generate-interrupt-check))
3625             (compile-form subform :target nil)
3626             (unless must-clear-values
3627               (unless (single-valued-p subform)
3628                 (setf must-clear-values t))))))
3629    (label END-BLOCK)
3630    (emit 'goto EXIT)
3631    (when (block-non-local-go-p block)
3632      ; We need a handler to catch non-local GOs.
3633      (let* ((HANDLER (gensym))
3634             (*register* *register*)
3635             (go-register (allocate-register))
3636             (tag-register (allocate-register)))
3637        (label HANDLER)
3638        ;; The Go object is on the runtime stack. Stack depth is 1.
3639        (emit 'dup)
3640        (emit 'astore go-register)
3641        ;; Get the tag.
3642        (emit 'checkcast +lisp-go-class+)
3643        (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
3644        (emit 'astore tag-register)
3645
3646        (dolist (tag local-tags)
3647          (let ((NEXT (gensym)))
3648            (emit 'aload tag-register)
3649            (emit 'getstatic
3650                  *this-class*
3651                  (if *compile-file-truename*
3652                      (declare-object-as-string (tag-label tag))
3653                      (declare-object (tag-label tag)))
3654                  +lisp-object+)
3655
3656            (emit 'if_acmpne NEXT) ;; Jump if not EQ.
3657            ;; Restore dynamic environment.
3658            (emit-push-current-thread)
3659            (aver (fixnump environment-register))
3660            (emit 'aload environment-register)
3661            (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3662            (emit 'goto (tag-label tag))
3663            (label NEXT)))
3664        ;; Not found. Re-throw Go.
3665        (emit 'aload go-register)
3666        (emit 'athrow)
3667
3668        ;; Finally...
3669        (push (make-handler :from BEGIN-BLOCK
3670                            :to END-BLOCK
3671                            :code HANDLER
3672                            :catch-type (pool-class +lisp-go-class+))
3673              *handlers*)))
3674    (label EXIT)
3675    (when must-clear-values
3676;;       (dformat t "p2-tagbody-node calling emit-clear-values~%")
3677      (emit-clear-values))
3678    ;; TAGBODY returns NIL.
3679    (when target
3680      (emit-push-nil)
3681      (emit-move-from-stack target))))
3682
3683(defun compile-go (form &key target representation)
3684  (let* ((name (cadr form))
3685         (tag (find-tag name)))
3686    (unless tag
3687      (error "COMPILE-GO: tag not found: ~S" name))
3688    (cond ((eq (tag-compiland tag) *current-compiland*)
3689           ;; Local case.
3690           (let ((tag-block (tag-block tag))
3691                 (register nil))
3692             ;; Does the GO leave an enclosing UNWIND-PROTECT?
3693             (let ((protected
3694                    (dolist (enclosing-block *blocks*)
3695                      (when (eq enclosing-block tag-block)
3696                        (return nil))
3697                      (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
3698                        (return t)))))
3699               (when protected
3700                 (error "COMPILE-GO: enclosing UNWIND-PROTECT")))
3701             (dolist (block *blocks*)
3702               (if (eq block tag-block)
3703                   (return)
3704                   (setf register (or (block-environment-register block) register))))
3705             (when register
3706               ;; Restore dynamic environment.
3707               (emit 'aload *thread*)
3708               (emit 'aload register)
3709               (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))
3710           (maybe-generate-interrupt-check) ;; FIXME not exactly right, but better than nothing
3711           (emit 'goto (tag-label tag)))
3712          (t
3713           ;; Non-local GO.
3714           (emit 'new +lisp-go-class+)
3715           (emit 'dup)
3716           (compile-form `',(tag-label tag) :target :stack) ; Tag.
3717           (emit-invokespecial +lisp-go-class+
3718                               "<init>"
3719                               "(Lorg/armedbear/lisp/LispObject;)V"
3720                               -2)
3721           (emit 'athrow)
3722           ;; Following code will not be reached, but is needed for JVM stack
3723           ;; consistency.
3724           (when target
3725             (emit-push-nil)
3726             (emit-move-from-stack target))))))
3727
3728(defun compile-atom (form &key (target *val*) representation)
3729  (unless (= (length form) 2)
3730    (error "Wrong number of arguments for ATOM."))
3731  (compile-form (cadr form) :target :stack)
3732  (maybe-emit-clear-values (cadr form))
3733  (emit 'instanceof +lisp-cons-class+)
3734  (let ((LABEL1 (gensym))
3735        (LABEL2 (gensym)))
3736    (emit 'ifeq LABEL1)
3737    (emit-push-nil)
3738    (emit 'goto LABEL2)
3739    (label LABEL1)
3740    (emit-push-t)
3741    (label LABEL2)
3742    (emit-move-from-stack target)))
3743
3744(defun contains-return (form)
3745  (if (atom form)
3746      (if (node-p form)
3747          (contains-return (node-form form))
3748          nil)
3749      (case (car form)
3750        (QUOTE
3751         nil)
3752        (RETURN-FROM
3753         t)
3754        (t
3755         (dolist (subform form)
3756           (when (contains-return subform)
3757             (return t)))))))
3758
3759(defun compile-block (form &key (target *val*) representation)
3760;;   (format t "compile-block ~S~%" (cadr form))
3761  ;; This shouldn't be called, now that we have pass 1.
3762;;   (assert nil)
3763  (let ((block (make-block-node :form form
3764                                :name (cadr form)
3765                                :target target)))
3766    (compile-block-node block target)
3767  ))
3768
3769(defun compile-block-node (block target)
3770;;   (dformat t "COMPILE-BLOCK-NODE ~S block-return-p = ~S~%"
3771;;            (block-name block) (block-return-p block))
3772  (unless (block-node-p block)
3773    (%format t "type-of block = ~S~%" (type-of block))
3774    (aver (block-node-p block)))
3775  (let* ((*blocks* (cons block *blocks*))
3776         (*register* *register*))
3777    (setf (block-target block) target)
3778    (when (block-return-p block)
3779      ;; Save current dynamic environment.
3780      (setf (block-environment-register block) (allocate-register))
3781      (emit-push-current-thread)
3782      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3783      (emit 'astore (block-environment-register block)))
3784    (setf (block-catch-tag block) (gensym))
3785    (let* ((*register* *register*)
3786           (BEGIN-BLOCK (gensym))
3787           (END-BLOCK (gensym))
3788           (BLOCK-EXIT (block-exit block)))
3789      (label BEGIN-BLOCK) ; Start of protected range.
3790      ;; Implicit PROGN.
3791      (compile-progn-body (cddr (block-form block)) target)
3792      (label END-BLOCK) ; End of protected range.
3793      (emit 'goto BLOCK-EXIT) ; Jump over handler (if any).
3794      (when (block-non-local-return-p block)
3795        ; We need a handler to catch non-local RETURNs.
3796        (let ((HANDLER (gensym))
3797              (RETHROW (gensym)))
3798          (label HANDLER)
3799          ;; The Return object is on the runtime stack. Stack depth is 1.
3800          (emit 'dup) ; Stack depth is 2.
3801          (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
3802          (compile-form `',(block-catch-tag block) :target :stack) ; Tag. Stack depth is 3.
3803          ;; If it's not the tag we're looking for...
3804          (emit 'if_acmpne RETHROW) ; Stack depth is 1.
3805          (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
3806          (emit-move-from-stack target) ; Stack depth is 0.
3807          (emit 'goto BLOCK-EXIT)
3808          (label RETHROW)
3809          ;; Not the tag we're looking for.
3810          (emit 'athrow)
3811          ;; Finally...
3812          (push (make-handler :from BEGIN-BLOCK
3813                              :to END-BLOCK
3814                              :code HANDLER
3815                              :catch-type (pool-class +lisp-return-class+))
3816                *handlers*)))
3817      (label BLOCK-EXIT))
3818    (when (block-environment-register block)
3819      ;; We saved the dynamic environment above. Restore it now.
3820      (emit 'aload *thread*)
3821      (emit 'aload (block-environment-register block))
3822      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
3823
3824(defun p2-return-from (form &key (target *val*) representation)
3825  (let* ((name (second form))
3826         (result-form (third form))
3827         (block (find-block name)))
3828    (cond
3829     ((null block)
3830      (error "No block named ~S is currently visible." name))
3831     ((eq (block-compiland block) *current-compiland*)
3832      ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which
3833      ;; is inside the block we're returning from?
3834      (let ((protected
3835             (dolist (enclosing-block *blocks*)
3836               (when (eq enclosing-block block)
3837                 (return nil))
3838               (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
3839                 (return t)))))
3840        (when protected
3841          (error "COMPILE-RETURN-FROM: enclosing UNWIND-PROTECT")))
3842      (emit-clear-values)
3843      (compile-form result-form :target (block-target block))
3844      (emit 'goto (block-exit block)))
3845     (t
3846      ;; Non-local RETURN.
3847      (setf (block-non-local-return-p block) t)
3848      (cond ((node-constant-p result-form)
3849             (emit 'new +lisp-return-class+)
3850             (emit 'dup)
3851             (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
3852             (emit-clear-values)
3853             (compile-form result-form :target :stack)) ; Result.
3854            (t
3855             (let* ((*register* *register*)
3856                    (temp-register (allocate-register)))
3857               (emit-clear-values)
3858               (compile-form result-form :target temp-register) ; Result.
3859               (emit 'new +lisp-return-class+)
3860               (emit 'dup)
3861               (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
3862               (emit 'aload temp-register))))
3863      (emit-invokespecial +lisp-return-class+
3864                          "<init>"
3865                          "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
3866                          -3)
3867      (emit 'athrow)
3868      ;; Following code will not be reached, but is needed for JVM stack
3869      ;; consistency.
3870      (when target
3871        (emit-push-nil)
3872        (emit-move-from-stack target))))))
3873
3874(defun compile-cons (form &key (target *val*) representation)
3875  (unless (check-args form 2)
3876    (compile-function-call form target representation)
3877    (return-from compile-cons))
3878  (emit 'new +lisp-cons-class+)
3879  (emit 'dup)
3880  (process-args (cdr form))
3881  (emit-invokespecial "org/armedbear/lisp/Cons"
3882                      "<init>"
3883                      "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
3884                      -3)
3885  (emit-move-from-stack target))
3886
3887(defun compile-progn-body (body target)
3888  (cond ((null body)
3889         (when target
3890           (emit-push-nil)
3891           (emit-move-from-stack target)))
3892        (t
3893         (let ((must-clear-values nil))
3894           (do* ((forms body (cdr forms))
3895                 (form (car forms) (car forms)))
3896                ((null forms))
3897             (when (null (cdr forms))
3898               ;; Last form.
3899               (when must-clear-values
3900                 (emit-clear-values)))
3901             (compile-form form :target (if (cdr forms) nil target))
3902             (unless (null (cdr forms))
3903               (unless must-clear-values
3904                 (unless (single-valued-p form)
3905;;                    (dformat t "compile-progn-body not single-valued: ~S~%" form)
3906                   (setf must-clear-values t)))))))))
3907
3908(defun compile-progn (form &key (target *val*) representation)
3909  (compile-progn-body (cdr form) target)
3910  (when (eq representation :unboxed-fixnum)
3911    (emit-unbox-fixnum)))
3912
3913(defun compile-quote (form &key (target *val*) representation)
3914   (let ((obj (second form)))
3915     (cond ((null obj)
3916            (when target
3917              (emit-push-nil)
3918              (emit-move-from-stack target)))
3919           ((symbolp obj)
3920            (if (symbol-package obj)
3921                (let ((g (declare-symbol obj)))
3922                  (emit 'getstatic
3923                        *this-class*
3924                        g
3925                        +lisp-symbol+))
3926                ;; An uninterned symbol.
3927                (let ((g (if *compile-file-truename*
3928                             (declare-object-as-string obj)
3929                             (declare-object obj))))
3930                  (emit 'getstatic
3931                        *this-class*
3932                        g
3933                        +lisp-object+)))
3934            (emit-move-from-stack target))
3935           ((listp obj)
3936            (let ((g (if *compile-file-truename*
3937                         (declare-object-as-string obj)
3938                         (declare-object obj))))
3939              (emit 'getstatic
3940                    *this-class*
3941                    g
3942                    +lisp-object+)
3943              (emit-move-from-stack target)))
3944           ((constantp obj)
3945            (compile-constant obj :target target))
3946           (t
3947            (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
3948
3949(defun compile-rplacd (form &key (target *val*) representation)
3950  (let ((args (cdr form)))
3951    (unless (= (length args) 2)
3952      (error "wrong number of arguments for RPLACD"))
3953    (compile-form (first args) :target :stack)
3954    (when target
3955      (emit 'dup))
3956    (compile-form (second args) :target :stack)
3957    (emit-invokevirtual +lisp-object-class+
3958                        "setCdr"
3959                        "(Lorg/armedbear/lisp/LispObject;)V"
3960                        -2)
3961    (when target
3962      (emit-move-from-stack target))))
3963
3964(defun compile-declare (form &key target representation)
3965  (when target
3966    (emit-push-nil)
3967    (emit-move-from-stack target)))
3968
3969(defun p2-local-function (compiland local-function)
3970  (let* ((name (compiland-name compiland))
3971         (arglist (cadr (compiland-lambda-expression compiland)))
3972         form
3973         function
3974         classfile)
3975    (when (or (memq '&optional arglist)
3976              (memq '&key arglist))
3977      (let ((state nil))
3978        (dolist (arg arglist)
3979          (cond ((memq arg lambda-list-keywords)
3980                 (setf state arg))
3981                ((memq state '(&optional &key))
3982                 (when (and (consp arg)
3983                            (not (constantp (second arg))))
3984                   (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
3985    (setf form (compiland-lambda-expression compiland))
3986    (setf classfile (if *compile-file-truename*
3987                        (sys::next-classfile-name)
3988                        (prog1
3989                         (%format nil "local-~D.class" *child-count*)
3990                         (incf *child-count*))))
3991    (setf (compiland-classfile compiland) classfile)
3992    (let ((*current-compiland* compiland)
3993          (*speed* *speed*)
3994          (*safety* *safety*)
3995          (*debug* *debug*))
3996      (p2-compiland compiland))
3997    (cond (*compile-file-truename*
3998           ;; Verify that the class file is loadable.
3999           (unless (ignore-errors (sys:load-compiled-function classfile))
4000             (error "P2-LOCAL-FUNCTION: unable to load ~S." classfile)))
4001          (t
4002           (setf function (sys:load-compiled-function classfile))))
4003    (cond (local-function
4004           (setf (local-function-classfile local-function) classfile)
4005           (let ((g (if *compile-file-truename*
4006                        (declare-local-function local-function)
4007                        (declare-object function))))
4008             (emit 'getstatic
4009                   *this-class*
4010                   g
4011                   +lisp-object+)
4012             (emit 'var-set (local-function-variable local-function))))
4013          (t
4014           (push (make-local-function :name name
4015                                      :function function
4016                                      :classfile classfile)
4017                 *local-functions*)))))
4018
4019(defun p2-flet (form &key (target *val*) representation)
4020  (let ((*local-functions* *local-functions*)
4021        (compilands (cadr form))
4022        (body (cddr form)))
4023    (dolist (compiland compilands)
4024      (p2-local-function compiland nil))
4025    (do ((forms body (cdr forms)))
4026        ((null forms))
4027      (compile-form (car forms) :target (if (cdr forms) nil target)))))
4028
4029(defun p2-labels (form &key target representation)
4030  (let ((*local-functions* *local-functions*)
4031        (local-functions (cadr form))
4032        (body (cddr form)))
4033    (dolist (local-function local-functions)
4034      (push local-function *local-functions*)
4035      (push (local-function-variable local-function) *visible-variables*))
4036    (dolist (local-function local-functions)
4037      (let ((variable (local-function-variable local-function)))
4038        (aver (null (variable-register variable)))
4039        (unless (variable-closure-index variable)
4040          (setf (variable-register variable) (allocate-register)))
4041        (setf (variable-index variable) nil)))
4042    (dolist (local-function local-functions)
4043      (p2-local-function (local-function-compiland local-function) local-function))
4044    (do ((forms body (cdr forms)))
4045        ((null forms))
4046      (compile-form (car forms) :target (if (cdr forms) nil target)))))
4047
4048(defun contains-symbol (symbol form)
4049  (cond ((node-p form)
4050         (contains-symbol symbol (node-form form)))
4051        ((atom form)
4052         (eq form symbol))
4053        (t
4054         (or (contains-symbol symbol (car form))
4055             (contains-symbol symbol (cdr form))))))
4056
4057(defun contains-go (form)
4058  (cond ((node-p form)
4059         (contains-go (node-form form)))
4060        ((atom form)
4061         nil)
4062        (t
4063         (case (car form)
4064           (QUOTE
4065            nil)
4066           (GO
4067            t)
4068           (t
4069            (dolist (subform form)
4070              (when (contains-go subform)
4071                (return t))))))))
4072
4073(defun p2-lambda (compiland target)
4074  (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
4075    (when (or (memq '&optional lambda-list)
4076              (memq '&key lambda-list))
4077      (let ((state nil))
4078        (dolist (arg lambda-list)
4079          (cond ((memq arg lambda-list-keywords)
4080                 (setf state arg))
4081                ((memq state '(&optional &key))
4082                 (when (and (consp arg)
4083                            (not (constantp (second arg))))
4084                   (error "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
4085    (cond (*compile-file-truename*
4086
4087           (setf (compiland-classfile compiland) (sys::next-classfile-name))
4088
4089           (let ((*current-compiland* compiland)
4090                 (*speed* *speed*)
4091                 (*safety* *safety*)
4092                 (*debug* *debug*)
4093                 compiled-function)
4094             (p2-compiland compiland))
4095
4096           (let* ((local-function (make-local-function :classfile (compiland-classfile compiland)))
4097                  (g (declare-local-function local-function)))
4098             (emit 'getstatic
4099                   *this-class*
4100                   g
4101                   +lisp-object+))
4102
4103;;              )
4104           )
4105          (t
4106           (setf (compiland-classfile compiland)
4107                 (prog1
4108                    (%format nil "local-~D.class" *child-count*)
4109                    (incf *child-count*)))
4110           (let ((*current-compiland* compiland)
4111                 (*speed* *speed*)
4112                 (*safety* *safety*)
4113                 (*debug* *debug*)
4114                 compiled-function)
4115             (p2-compiland compiland)
4116             (setf compiled-function
4117                   (sys:load-compiled-function (compiland-classfile compiland)))
4118             (emit 'getstatic
4119                   *this-class*
4120                   (declare-object compiled-function)
4121                   +lisp-object+))))
4122    (cond
4123     ((null *closure-variables*)) ; Nothing to do.
4124     ((compiland-closure-register *current-compiland*)
4125      (emit 'aload (compiland-closure-register *current-compiland*))
4126      (emit-invokestatic +lisp-class+
4127                         "makeCompiledClosure"
4128                         "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4129                         -1)
4130      (emit 'checkcast "org/armedbear/lisp/CompiledClosure")
4131      ) ; Stack: compiled-closure
4132     (t
4133      ;; Shouldn't happen.
4134      (aver (progn 'unexpected nil))
4135      (emit-push-constant-int 0)
4136      (emit 'anewarray "org/armedbear/lisp/LispObject")))
4137    (emit-move-from-stack target)))
4138
4139(defun p2-function (form &key (target *val*) representation)
4140  (let ((name (second form))
4141        (local-function))
4142    (cond ((symbolp name)
4143           (cond ((setf local-function (find-local-function name))
4144                  (dformat t "p2-function 1~%")
4145                  (when (eq (local-function-compiland local-function) *current-compiland*)
4146                    (emit 'aload 0) ; this
4147                    (emit-move-from-stack target)
4148                    (return-from p2-function))
4149                  (cond ((local-function-variable local-function)
4150                         (dformat t "p2-function 2~%")
4151                         (emit 'var-ref (local-function-variable local-function) :stack))
4152                        (t
4153                         (let ((g (if *compile-file-truename*
4154                                      (declare-local-function local-function)
4155                                      (declare-object (local-function-function local-function)))))
4156                           (emit 'getstatic
4157                                 *this-class*
4158                                 g
4159                                 +lisp-object+)))) ; Stack: template-function
4160                  (cond ((null *closure-variables*)) ; Nothing to do.
4161                        ((compiland-closure-register *current-compiland*)
4162                         (dformat t "p2-function 3~%")
4163                         (emit 'aload (compiland-closure-register *current-compiland*))
4164                         (emit-invokestatic +lisp-class+
4165                                            "makeCompiledClosure"
4166                                            "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4167                                            -1)) ; Stack: compiled-closure
4168                        (t
4169                         (aver (progn 'unexpected nil))))
4170                  (emit-move-from-stack target))
4171                 ((inline-ok name)
4172                  (emit 'getstatic
4173                        *this-class*
4174                        (declare-function name)
4175                        +lisp-object+)
4176                  (emit-move-from-stack target))
4177                 (t
4178                  (emit 'getstatic
4179                        *this-class*
4180                        (declare-symbol name)
4181                        +lisp-symbol+)
4182                  (emit-invokevirtual +lisp-object-class+
4183                                      "getSymbolFunctionOrDie"
4184                                      "()Lorg/armedbear/lisp/LispObject;"
4185                                      0)
4186                  (emit-move-from-stack target))))
4187          ((and (consp name) (eq (car name) 'SETF))
4188           ; FIXME Need to check for NOTINLINE declaration!
4189           (cond ((member name *toplevel-defuns* :test #'equal)
4190                  (emit 'getstatic
4191                        *this-class*
4192                        (declare-setf-function name)
4193                        +lisp-object+)
4194                  (emit-move-from-stack target))
4195                 ((and (null *compile-file-truename*)
4196                       (fdefinition name))
4197                  (emit 'getstatic
4198                        *this-class*
4199                        (declare-object (fdefinition name))
4200                        +lisp-object+)
4201                  (emit-move-from-stack target))
4202                 (t
4203                  (emit 'getstatic
4204                        *this-class*
4205                        (declare-symbol (cadr name))
4206                        +lisp-symbol+)
4207                  (emit-invokevirtual +lisp-symbol-class+
4208                                      "getSymbolSetfFunctionOrDie"
4209                                      "()Lorg/armedbear/lisp/LispObject;"
4210                                      0)
4211                  (emit-move-from-stack target))))
4212          ((compiland-p name)
4213           (p2-lambda name target))
4214          (t
4215           (error "p2-function: unsupported case: ~S" form)))))
4216
4217(defun p2-ash (form &key (target *val*) representation)
4218  (dformat t "p2-ash form = ~S representation = ~S~%" form representation)
4219  (unless (check-args form 2)
4220    (compile-function-call form target representation)
4221    (return-from p2-ash))
4222  (let* ((args (cdr form))
4223         (len (length args))
4224         (arg1 (first args))
4225         (arg2 (second args))
4226         (var1 (unboxed-fixnum-variable arg1))
4227         (var2 (unboxed-fixnum-variable arg2)))
4228    (cond
4229     ((and (numberp arg1) (numberp arg2))
4230      (dformat t "p2-ash case 1~%")
4231      (compile-constant (ash arg1 arg2)
4232                        :target target
4233                        :representation representation))
4234     ((and var1 (fixnump arg2) (< 0 arg2 32))
4235      (dformat t "p2-ash case 2~%")
4236      (case representation
4237        (:unboxed-fixnum
4238         (emit-push-int var1)
4239         (emit-push-constant-int arg2)
4240         (emit 'ishl))
4241        (t
4242         (emit-push-int var1)
4243         (emit 'i2l)
4244         (emit-push-constant-int arg2)
4245         (emit 'lshl)
4246         (emit-box-long)))
4247      (emit-move-from-stack target representation))
4248     ((and var1 (fixnump arg2) (< -32 arg2 0))
4249      (dformat t "p2-ash case 3~%")
4250      (unless (eq representation :unboxed-fixnum)
4251        (emit 'new +lisp-fixnum-class+)
4252        (emit 'dup))
4253      (emit-push-int var1)
4254      (emit-push-constant-int (- arg2))
4255      (emit 'ishr)
4256      (unless (eq representation :unboxed-fixnum)
4257        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
4258      (emit-move-from-stack target representation))
4259     (var2
4260      (dformat t "p2-ash case 4~%")
4261      (compile-form arg1 :target :stack)
4262      (maybe-emit-clear-values arg1)
4263      (emit 'iload (variable-register var2))
4264      (emit-invokevirtual +lisp-object-class+
4265                          "ash"
4266                          "(I)Lorg/armedbear/lisp/LispObject;"
4267                          -1)
4268      (when (eq representation :unboxed-fixnum)
4269        (emit-unbox-fixnum))
4270      (emit-move-from-stack target representation))
4271     ((fixnump arg2)
4272      (dformat t "p2-ash case 5~%")
4273      (compile-form arg1 :target :stack)
4274      (maybe-emit-clear-values arg1)
4275      (emit-push-constant-int arg2)
4276      (emit-invokevirtual +lisp-object-class+
4277                          "ash"
4278                          "(I)Lorg/armedbear/lisp/LispObject;"
4279                          -1)
4280      (when (eq representation :unboxed-fixnum)
4281        (emit-unbox-fixnum))
4282      (emit-move-from-stack target representation))
4283     (t
4284      (dformat t "p2-ash case 6~%")
4285      (compile-function-call form target representation)))))
4286
4287(defun p2-logand (form &key (target *val*) representation)
4288  (let* ((args (cdr form))
4289         (len (length args)))
4290    (when (= len 2)
4291      (let* ((arg1 (first args))
4292             (arg2 (second args))
4293             (var1 (unboxed-fixnum-variable arg1)))
4294        (dformat t "p2-logand var1 = ~S~%" var1)
4295        (dformat t "p2-logand type-of arg2 is ~S~%" (type-of arg2))
4296        (cond
4297         ((and (integerp arg1) (integerp arg2))
4298          (dformat t "p2-logand case 1~%")
4299          (compile-constant (logand arg1 arg2) :target target :representation representation)
4300          (return-from p2-logand t))
4301         ((and (fixnump arg2) (zerop arg2))
4302          (dformat t "p2-logand case 2~%")
4303          (compile-constant 0 :target target :representation representation)
4304          (return-from p2-logand t))
4305         ((and var1 (fixnump arg2))
4306          (dformat t "p2-logand case 3~%")
4307          (unless (eq representation :unboxed-fixnum)
4308            (emit 'new +lisp-fixnum-class+)
4309            (emit 'dup))
4310          (emit 'iload (variable-register var1))
4311          (emit-push-constant-int arg2)
4312          (emit 'iand)
4313          (unless (eq representation :unboxed-fixnum)
4314            (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
4315          (emit-move-from-stack target representation)
4316          (return-from p2-logand t))
4317         ((fixnump arg2)
4318          (dformat t "p2-logand case 4~%")
4319          (let ((type (derive-type arg1)))
4320            (dformat t "p2-logand arg1 derived type = ~S~%" type)
4321            (cond
4322             ((subtypep type 'fixnum)
4323              (dformat t "p2-logand case 4a~%")
4324              (unless (eq representation :unboxed-fixnum)
4325                (emit 'new +lisp-fixnum-class+)
4326                (emit 'dup))
4327              (compile-form arg1 :target :stack :representation :unboxed-fixnum)
4328              (maybe-emit-clear-values arg1)
4329              (emit-push-constant-int arg2)
4330              (emit 'iand)
4331              (unless (eq representation :unboxed-fixnum)
4332                (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
4333              (emit-move-from-stack target representation))
4334             (t
4335              (dformat t "p2-logand case 4b~%")
4336              (compile-form arg1 :target :stack)
4337              (maybe-emit-clear-values arg1)
4338              (emit-push-constant-int arg2)
4339              (emit-invokevirtual +lisp-object-class+
4340                                  "logand"
4341                                  "(I)Lorg/armedbear/lisp/LispObject;"
4342                                  -1)
4343              (when (eq representation :unboxed-fixnum)
4344                (emit-unbox-fixnum))
4345              (emit-move-from-stack target representation))))
4346          (return-from p2-logand t))))))
4347  (dformat t "p2-logand default case~%")
4348  (compile-function-call form target representation))
4349
4350(defun derive-type (form)
4351  (cond
4352   ((fixnump form)
4353    (return-from derive-type 'fixnum))
4354   ((unboxed-fixnum-variable form)
4355    (return-from derive-type 'fixnum))
4356   ((consp form)
4357    (let ((op (first form)))
4358      (case op
4359        (ASH
4360         (dformat t "derive-type ASH case form = ~S~%" form)
4361         (let* ((arg1 (second form))
4362                (var1 (unboxed-fixnum-variable arg1))
4363                (arg2 (third form)))
4364           (dformat t "derive-type ASH case var1 = ~S~%" var1)
4365           (when (and var1 (fixnump arg2) (minusp arg2))
4366             (return-from derive-type 'FIXNUM))))
4367        (THE
4368         (dformat t "derive-type THE case form = ~S~%" form)
4369         (when (subtypep (second form) 'FIXNUM)
4370           (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form)
4371           (return-from derive-type 'FIXNUM))
4372         )))))
4373  t)
4374
4375(defun compile-length (form &key (target *val*) representation)
4376  (check-args form 1)
4377  (let ((arg (cadr form)))
4378    (compile-form arg :target :stack)
4379    (maybe-emit-clear-values arg)
4380    (cond
4381     ((eq representation :unboxed-fixnum)
4382      (emit-invokevirtual +lisp-object-class+
4383                          "length"
4384                          "()I"
4385                          0))
4386     (t
4387      (emit-invokevirtual +lisp-object-class+
4388                          "LENGTH"
4389                          "()Lorg/armedbear/lisp/LispObject;"
4390                          0)))
4391    (emit-move-from-stack target representation)))
4392
4393(defun compile-nth (form &key (target *val*) representation)
4394  (unless (check-args form 2)
4395    (compile-function-call form target representation)
4396    (return-from compile-nth))
4397  (let ((index-form (second form))
4398        (list-form (third form)))
4399    (compile-form index-form :target :stack :representation :unboxed-fixnum)
4400    (compile-form list-form :target :stack)
4401    (unless (and (single-valued-p index-form)
4402                 (single-valued-p list-form))
4403      (emit-clear-values))
4404    (emit 'swap)
4405    (emit-invokevirtual +lisp-object-class+
4406                        "NTH"
4407                        "(I)Lorg/armedbear/lisp/LispObject;"
4408                        -1)
4409    (when (eq representation :unboxed-fixnum)
4410      (emit-unbox-fixnum))
4411    (emit-move-from-stack target representation)))
4412
4413(defun compile-plus (form &key (target *val*) representation)
4414  (case (length form)
4415    (3
4416     (let* ((args (cdr form))
4417            (arg1 (first args))
4418            (arg2 (second args))
4419            (var1 (unboxed-fixnum-variable arg1))
4420            (var2 (unboxed-fixnum-variable arg2)))
4421       (cond
4422        ((and (numberp arg1) (numberp arg2))
4423         (compile-constant (+ arg1 arg2)
4424                           :target target
4425                           :representation representation))
4426        ((and var1 var2)
4427         (dformat t "compile-plus case 1~%")
4428         (dformat t "target = ~S representation = ~S~%" target representation)
4429         (aver (variable-register var1))
4430         (aver (variable-register var2))
4431         (when target
4432           (cond
4433            ((eq representation :unboxed-fixnum)
4434             (emit-push-int var1)
4435             (emit-push-int arg2)
4436             (emit 'iadd))
4437            (t
4438             (emit 'iload (variable-register var1))
4439             (emit 'i2l)
4440             (emit 'iload (variable-register var2))
4441             (emit 'i2l)
4442             (emit 'ladd)
4443             (emit-box-long)))
4444           (emit-move-from-stack target representation)))
4445        ((and var1 (fixnump arg2))
4446         (dformat t "compile-plus case 2~%")
4447         (aver (variable-register var1))
4448         (cond
4449          ((eq representation :unboxed-fixnum)
4450           (emit-push-int var1)
4451           (emit-push-int arg2)
4452           (emit 'iadd))
4453          (t
4454           (emit-push-int var1)
4455           (emit 'i2l)
4456           (emit-push-int arg2)
4457           (emit 'i2l)
4458           (emit 'ladd)
4459           (emit-box-long)))
4460         (emit-move-from-stack target representation))
4461        ((and (fixnump arg1) var2)
4462         (dformat t "compile-plus case 3~%")
4463         (aver (variable-register var2))
4464         (cond
4465          ((eq representation :unboxed-fixnum)
4466           (emit-push-int arg1)
4467           (emit-push-int var2)
4468           (emit 'iadd))
4469          (t
4470           (emit-push-int arg1)
4471           (emit 'i2l)
4472           (emit-push-int var2)
4473           (emit 'i2l)
4474           (emit 'ladd)
4475           (emit-box-long)))
4476         (emit-move-from-stack target representation))
4477        ((eql arg1 1)
4478         (dformat t "compile-plus case 4~%")
4479         (compile-form arg2 :target :stack)
4480         (maybe-emit-clear-values arg2)
4481         (emit-invoke-method "incr" target representation))
4482        ((eql arg2 1)
4483         (dformat t "compile-plus case 5~%")
4484         (compile-form arg1 :target :stack)
4485         (maybe-emit-clear-values arg1)
4486         (emit-invoke-method "incr" target representation))
4487        ((arg-is-fixnum-p arg1)
4488         (dformat t "compile-plus case 6~%")
4489         (emit-push-int arg1)
4490         (compile-form arg2 :target :stack)
4491         (maybe-emit-clear-values arg2)
4492         (emit 'swap)
4493         (emit-invokevirtual +lisp-object-class+
4494                             "add"
4495                             "(I)Lorg/armedbear/lisp/LispObject;"
4496                             -1)
4497         (when (eq representation :unboxed-fixnum)
4498           (emit-unbox-fixnum))
4499         (emit-move-from-stack target representation))
4500        ((arg-is-fixnum-p arg2)
4501         (dformat t "compile-plus case 7~%")
4502         (compile-form arg1 :target :stack)
4503         (maybe-emit-clear-values arg1)
4504         (emit-push-int arg2)
4505         (emit-invokevirtual +lisp-object-class+
4506                             "add"
4507                             "(I)Lorg/armedbear/lisp/LispObject;"
4508                             -1)
4509         (when (eq representation :unboxed-fixnum)
4510           (emit-unbox-fixnum))
4511         (emit-move-from-stack target representation))
4512        (t
4513         (dformat t "compile-plus case 8~%")
4514         (compile-binary-operation "add" args target representation)))))
4515    (4
4516     (dformat t "compile-plus case 9~%")
4517     ;; (+ a b c) => (+ (+ a b) c)
4518     (let ((new-form `(+ (+ ,(second form) ,(third form)) ,(fourth form))))
4519       (dformat t "form = ~S~%" form)
4520       (dformat t "new-form = ~S~%" new-form)
4521       (compile-plus new-form :target target :representation representation)))
4522    (t
4523     (dformat t "compile-plus case 10~%")
4524     (compile-function-call form target representation))))
4525
4526(defun compile-minus (form &key (target *val*) representation)
4527  (case (length form)
4528    (3
4529     (let* ((args (cdr form))
4530            (arg1 (first args))
4531            (arg2 (second args))
4532            (var1 (unboxed-fixnum-variable arg1))
4533            (var2 (unboxed-fixnum-variable arg2)))
4534       (cond
4535        ((and (numberp arg1) (numberp arg2))
4536         (compile-constant (- arg1 arg2)
4537                           :target target
4538                           :representation representation))
4539        ((and var1 var2)
4540         (dformat t "compile-minus case 1~%")
4541         (aver (variable-register var1))
4542         (aver (variable-register var2))
4543         (when target
4544           (cond
4545            ((eq representation :unboxed-fixnum)
4546             (emit 'iload (variable-register var1))
4547             (emit 'iload (variable-register var2))
4548             (emit 'isub))
4549            (t
4550             (emit 'iload (variable-register var1))
4551             (emit 'i2l)
4552             (emit 'iload (variable-register var2))
4553             (emit 'i2l)
4554             (emit 'lsub)
4555             (emit-box-long)))
4556           (emit-move-from-stack target representation)))
4557        ((and var1 (fixnump arg2))
4558         (dformat t "compile-minus case 2~%")
4559         (aver (variable-register var1))
4560         (cond
4561          ((eq representation :unboxed-fixnum)
4562           (emit-push-int var1)
4563           (emit-push-int arg2)
4564           (emit 'isub))
4565          (t
4566           (emit-push-int var1)
4567           (emit 'i2l)
4568           (emit-push-int arg2)
4569           (emit 'i2l)
4570           (emit 'lsub)
4571           (emit-box-long)))
4572         (emit-move-from-stack target representation))
4573        ((and (fixnump arg1) var2)
4574         (dformat t "compile-minus case 3~%")
4575         (aver (variable-register var2))
4576         (cond
4577          ((eq representation :unboxed-fixnum)
4578           (emit-push-int arg1)
4579           (emit-push-int var2)
4580           (emit 'isub))
4581          (t
4582           (emit-push-int arg1)
4583           (emit 'i2l)
4584           (emit-push-int var2)
4585           (emit 'i2l)
4586           (emit 'lsub)
4587           (emit-box-long)))
4588         (emit-move-from-stack target representation))
4589        ((eql arg2 1)
4590         (dformat t "compile-minus case 5~%")
4591         (compile-form arg1 :target :stack)
4592         (maybe-emit-clear-values arg2)
4593         (emit-invoke-method "decr" target representation))
4594        ((arg-is-fixnum-p arg2)
4595         (dformat t "compile-minus case 7~%")
4596         (compile-form arg1 :target :stack)
4597         (maybe-emit-clear-values arg1)
4598         (emit-push-int arg2)
4599         (emit-invokevirtual +lisp-object-class+
4600                             "subtract"
4601                             "(I)Lorg/armedbear/lisp/LispObject;"
4602                             -1)
4603         (when (eq representation :unboxed-fixnum)
4604           (emit-unbox-fixnum))
4605         (emit-move-from-stack target representation))
4606        (t
4607         (dformat t "compile-minus case 8~%")
4608         (compile-binary-operation "subtract" args target representation)))))
4609    (4
4610     (dformat t "compile-minus case 9~%")
4611     ;; (- a b c) => (- (- a b) c)
4612     (let ((new-form `(- (- ,(second form) ,(third form)) ,(fourth form))))
4613       (dformat t "form = ~S~%" form)
4614       (dformat t "new-form = ~S~%" new-form)
4615       (compile-minus new-form :target target :representation representation)))
4616    (t
4617     (dformat t "compile-minus case 10~%")
4618     (compile-function-call form target representation))))
4619
4620(defun compile-schar (form &key (target *val*) representation)
4621  (unless (= (length form) 3)
4622    (error 'program-error
4623           :format-control "Wrong number of arguments for ~S."
4624           :format-arguments (list (car form))))
4625  (compile-form (second form) :target :stack)
4626  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
4627  (unless (and (single-valued-p (second form))
4628               (single-valued-p (third form)))
4629    (emit-clear-values))
4630  (emit-invokevirtual +lisp-object-class+
4631                      "SCHAR"
4632                      "(I)Lorg/armedbear/lisp/LispObject;"
4633                      -1)
4634  (emit-move-from-stack target))
4635
4636(defun compile-aref (form &key (target *val*) representation)
4637;;   (dformat t "compile-aref form = ~S~%" form)
4638  (unless (= (length form) 3)
4639    (return-from compile-aref (compile-function-call form target representation)))
4640  (compile-form (second form) :target :stack)
4641  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
4642  (unless (and (single-valued-p (second form))
4643               (single-valued-p (third form)))
4644    (emit-clear-values))
4645  (emit-invokevirtual +lisp-object-class+
4646                      "AREF"
4647                      "(I)Lorg/armedbear/lisp/LispObject;"
4648                      -1)
4649  (emit-move-from-stack target))
4650
4651(defun compile-not/null (form &key (target *val*) representation)
4652  (unless (= (length form) 2)
4653    (error 'program-error
4654           :format-control "Wrong number of arguments for ~S."
4655           :format-arguments (list (car form))))
4656  (let ((arg (second form)))
4657;;     (dformat t "arg = ~S~%" arg)
4658    (cond ((null arg)
4659           (emit-push-t))
4660          ((and (constantp arg) (not (block-node-p arg)))
4661;;            (dformat t "compile-not/null constantp case~%")
4662           (emit-push-nil))
4663          ((and (consp arg)
4664                (memq (car arg) '(NOT NULL)))
4665           (compile-form (second arg) :target :stack)
4666           (maybe-emit-clear-values (second arg))
4667           (emit-push-nil)
4668           (let ((label1 (gensym))
4669                 (label2 (gensym)))
4670             (emit 'if_acmpeq `,label1)
4671             (emit-push-t)
4672             (emit 'goto `,label2)
4673             (emit 'label `,label1)
4674             (emit-push-nil)
4675             (emit 'label `,label2)))
4676          (t
4677           (compile-form arg :target :stack)
4678           (maybe-emit-clear-values arg)
4679           (emit-push-nil)
4680           (let ((label1 (gensym))
4681                 (label2 (gensym)))
4682             (emit 'if_acmpeq `,label1)
4683             (emit-push-nil)
4684             (emit 'goto `,label2)
4685             (emit 'label `,label1)
4686             (emit-push-t)
4687             (emit 'label `,label2)))))
4688  (emit-move-from-stack target))
4689
4690(defun compile-values (form &key (target *val*) representation)
4691  (let ((args (cdr form)))
4692    (case (length args)
4693      (1
4694       (let ((arg (first args)))
4695         (compile-form arg :target target)
4696         (unless (single-valued-p arg)
4697           (emit-clear-values))))
4698      (2
4699       (emit-push-current-thread)
4700       (let ((arg1 (first args))
4701             (arg2 (second args)))
4702         (cond ((and (eq arg1 t)
4703                     (eq arg2 t))
4704                (emit-push-t)
4705                (emit 'dup))
4706               ((and (eq arg1 nil)
4707                     (eq arg2 nil))
4708                (emit-push-nil)
4709                (emit 'dup))
4710               (t
4711                (compile-form arg1 :target :stack)
4712                (compile-form arg2 :target :stack))))
4713       (emit-invokevirtual +lisp-thread-class+
4714                           "setValues"
4715                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4716                           -2)
4717       (emit-move-from-stack target))
4718      (3
4719       (emit-push-current-thread)
4720       (dolist (arg args)
4721         (compile-form arg :target :stack))
4722       (emit-invokevirtual +lisp-thread-class+
4723                           "setValues"
4724                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4725                           -3)
4726       (emit-move-from-stack target))
4727      (t
4728       (compile-function-call form target representation)))))
4729
4730(defun compile-special-reference (name target representation)
4731  (emit 'getstatic
4732        *this-class*
4733        (declare-symbol name)
4734        +lisp-symbol+)
4735  (emit-push-current-thread)
4736  (emit-invokevirtual +lisp-symbol-class+
4737                      "symbolValue"
4738                      "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;"
4739                      -1)
4740  (when (eq representation :unboxed-fixnum)
4741    (emit-unbox-fixnum))
4742  (emit-move-from-stack target representation))
4743
4744(defun compile-variable-reference (name target representation)
4745  (dformat t "compile-variable-reference ~S~%" name)
4746  (let ((variable (find-visible-variable name)))
4747    (cond
4748     ((null variable)
4749      (when (and (special-variable-p name)
4750                 (constantp name))
4751        (let ((value (symbol-value name)))
4752          (when (or (null *compile-file-truename*)
4753                    ;; FIXME File compilation doesn't support all constant
4754                    ;; types yet.
4755                    (stringp value)
4756                    (numberp value)
4757                    (packagep value))
4758            (compile-constant value :target target :representation representation)
4759            (return-from compile-variable-reference))))
4760      (unless (special-variable-p name)
4761        (unless (memq name *undefined-variables*)
4762          (compiler-warn "Undefined variable ~S" name)
4763          (push name *undefined-variables*)))
4764      (compile-special-reference name target representation))
4765     ((eq (variable-representation variable) :unboxed-fixnum)
4766      (dformat t "compile-variable-reference unboxed-fixnum case~%")
4767      (cond
4768       ((eq representation :unboxed-fixnum)
4769        (aver (variable-register variable))
4770        (emit 'iload (variable-register variable)))
4771       (t
4772        (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%"
4773                 name)
4774        (emit 'new +lisp-fixnum-class+)
4775        (emit 'dup)
4776        (aver (variable-register variable))
4777        (emit 'iload (variable-register variable))
4778        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)))
4779      (emit-move-from-stack target representation))
4780     (t
4781;;       (dformat t "compile-variable-reference name = ~S representation = ~S~%"
4782;;                name representation)
4783      (dformat t "compile-variable-reference ~S closure index = ~S~%"
4784               name (variable-closure-index variable))
4785      (emit 'var-ref variable target representation)))))
4786
4787(defun rewrite-setq (form)
4788  (let ((expr (third form)))
4789    (if (unsafe-p expr)
4790        (let ((sym (gensym)))
4791          (list 'LET (list (list sym expr)) (list 'SETQ (second form) sym)))
4792        form)))
4793
4794(defun compile-setq (form &key (target *val*) representation)
4795;;   (dformat t "compile-setq form = ~S target = ~S representation = ~S~%"
4796;;            form target representation)
4797  (unless (= (length form) 3)
4798    (return-from compile-setq (compile-form (precompiler::precompile-setq form)
4799                                            :target target)))
4800  (let ((expansion (macroexpand (second form))))
4801    (unless (eq expansion (second form))
4802      (compile-form (list 'SETF expansion (third form)))
4803      (return-from compile-setq)))
4804  (let* ((name (second form))
4805         (value-form (third form))
4806         (variable (find-visible-variable name)))
4807    (cond ((or (null variable)
4808               (variable-special-p variable))
4809           (let ((new-form (rewrite-setq form)))
4810             (when (neq new-form form)
4811               (return-from compile-setq (compile-form (p1 new-form) :target target))))
4812           (emit-push-current-thread)
4813           (emit 'getstatic
4814                 *this-class*
4815                 (declare-symbol name)
4816                 +lisp-symbol+)
4817           (compile-form value-form :target :stack)
4818           (maybe-emit-clear-values value-form)
4819           (emit-invokevirtual +lisp-thread-class+
4820                              "setSpecialVariable"
4821                              "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4822                              -2)
4823           (emit-move-from-stack target))
4824          ((and (eq (variable-representation variable) :unboxed-fixnum)
4825                (or (equal value-form (list '1+ (variable-name variable)))
4826                    (equal value-form (list '+ (variable-name variable) 1))
4827                    (equal value-form (list '+ 1 (variable-name variable)))))
4828           (dformat t "compile-setq incf unboxed-fixnum case~%")
4829           (emit 'iinc (variable-register variable) 1)
4830           (when target
4831             (dformat t "compile-setq constructing boxed fixnum for ~S~%"
4832                      (variable-name variable))
4833             (emit 'new +lisp-fixnum-class+)
4834             (emit 'dup)
4835             (aver (variable-register variable))
4836             (emit 'iload (variable-register variable))
4837             (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
4838             (emit-move-from-stack target)))
4839          ((eq (variable-representation variable) :unboxed-fixnum)
4840           (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form)
4841           (compile-form value-form :target :stack)
4842           (maybe-emit-clear-values value-form)
4843           (when target
4844             (emit 'dup))
4845           (emit-unbox-fixnum)
4846           (emit 'istore (variable-register variable))
4847           (when target
4848             (emit-move-from-stack target))
4849           )
4850          (t
4851           (compile-form value-form :target :stack)
4852           (maybe-emit-clear-values value-form)
4853           (when target
4854             (emit 'dup))
4855           (emit 'var-set variable)
4856           (when target
4857             (when (eq representation