Changeset 8401


Ignore:
Timestamp:
01/25/05 05:37:05 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8400 r8401  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.370 2005-01-25 02:06:59 piso Exp $
     4;;; $Id: jvm.lisp,v 1.371 2005-01-25 05:37:05 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
    … …  
    167167;; returns variable or nil
    168168(defun unboxed-fixnum-variable (obj)
    169   (cond
    170    ((symbolp obj)
    171     (let ((variable (find-visible-variable obj)))
    172       (if (and variable
    173                (eq (variable-representation variable) :unboxed-fixnum))
    174           variable
    175           nil)))
    176    ((variable-p obj)
    177     (if (eq (variable-representation obj) :unboxed-fixnum)
    178         obj
    179         nil))
    180    (t
    181     nil)))
     169  (cond ((symbolp obj)
     170         (let ((variable (find-visible-variable obj)))
     171           (if (and variable
     172                    (eq (variable-representation variable) :unboxed-fixnum))
     173               variable
     174               nil)))
     175        ((variable-p obj)
     176         (if (eq (variable-representation obj) :unboxed-fixnum)
     177             obj
     178             nil))
     179        (t
     180         nil)))
    182181
    183182(defun arg-is-fixnum-p (arg)
    … …  
    348347                         (t
    349348                          (dformat t "adding free special ~S~%" sym)
    350                           (push (make-variable :name sym :special-p t) free-specials))))
    351                  ))
     349                          (push (make-variable :name sym :special-p t) free-specials))))))
    352350              (TYPE
    353351               (dolist (sym (cddr decl))
    … …  
    592590          (progn
    593591            (incf (variable-writes variable))
    594             (cond
    595              ((eq (variable-compiland variable) *current-compiland*)
    596               (dformat t "p1-setq: write ~S~%" arg1))
    597              (t
    598               (dformat t "p1-setq: non-local write ~S~%" arg1)
    599               (setf (variable-used-non-locally-p variable) t))))
     592            (cond ((eq (variable-compiland variable) *current-compiland*)
     593                   (dformat t "p1-setq: write ~S~%" arg1))
     594                  (t
     595                   (dformat t "p1-setq: non-local write ~S~%" arg1)
     596                   (setf (variable-used-non-locally-p variable) t))))
    600597          (dformat t "p1-setq: unknown variable ~S~%" arg1)))
    601598    (list 'SETQ arg1 (p1 arg2))))
    … …  
    605602  (let ((type (second form))
    606603        (expr (third form)))
    607     (cond
    608      ((and (listp type) (eq (car type) 'VALUES))
    609       ;; FIXME
    610       (p1 expr))
    611      ((= *safety* 3)
    612       (dformat t "p1-the expr = ~S~%" expr)
    613       (let* ((sym (gensym))
    614              (new-expr
    615               `(let ((,sym ,expr))
    616                  (sys::require-type ,sym ',type)
    617                  ,sym)))
    618         (dformat t "p1-the new-expr = ~S~%" new-expr)
    619         (p1 new-expr)))
    620      (t
    621       (dformat t "p1-the t case expr = ~S~%" expr)
    622       (if (subtypep type 'FIXNUM)
    623           (list 'THE type (p1 expr))
    624           (p1 expr))))))
     604    (cond ((and (listp type) (eq (car type) 'VALUES))
     605           ;; FIXME
     606           (p1 expr))
     607          ((= *safety* 3)
     608           (dformat t "p1-the expr = ~S~%" expr)
     609           (let* ((sym (gensym))
     610                  (new-expr
     611                   `(let ((,sym ,expr))
     612                      (sys::require-type ,sym ',type)
     613                      ,sym)))
     614             (dformat t "p1-the new-expr = ~S~%" new-expr)
     615             (p1 new-expr)))
     616          (t
     617           (dformat t "p1-the t case expr = ~S~%" expr)
     618           (if (subtypep type 'FIXNUM)
     619               (list 'THE type (p1 expr))
     620               (p1 expr))))))
    625621
    626622(defun p1-default (form)
    … …  
    647643
    648644(defun p1 (form)
    649   (cond
    650    ((symbolp form)
    651     (cond
    652      ((constantp form) ; a DEFCONSTANT
    653       (let ((value (symbol-value form)))
    654         (if (numberp value)
    655             value
    656             form)))
    657      ((keywordp form)
    658       form)
    659      (t
    660       (let ((variable (find-visible-variable form)))
    661         (if variable
    662             (progn
    663               (incf (variable-reads variable))
    664               (cond
    665                ((eq (variable-compiland variable) *current-compiland*)
    666                 (dformat t "p1: read ~S~%" form))
     645  (cond ((symbolp form)
     646         (cond ((constantp form) ; a DEFCONSTANT
     647                (let ((value (symbol-value form)))
     648                  (if (numberp value)
     649                      value
     650                      form)))
     651               ((keywordp form)
     652                form)
    667653               (t
    668                 (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
    669                          form
    670                          (compiland-name (variable-compiland variable))
    671                          (compiland-name *current-compiland*))
    672                 (setf (variable-used-non-locally-p variable) t))))
    673             (dformat t "p1: unknown variable ~S~%" form)))
    674       form)))
    675    ((atom form)
    676     form)
    677    (t
    678     (let ((op (car form))
    679           handler)
    680       (cond ((symbolp op)
    681              (cond ((setf handler (get op 'p1-handler))
    682                     (funcall handler form))
    683                    ((macro-function op)
    684                     (p1 (macroexpand form)))
    685                    ((special-operator-p op)
    686                     (error "P1: unsupported special operator ~S" op))
    687                    (t
    688                     ;; Function call.
    689                     (let ((new-form (rewrite-function-call form)))
    690                       (when (neq new-form form)
    691                         (dformat t "old form = ~S~%" form)
    692                         (dformat t "new form = ~S~%" new-form)
    693                         (return-from p1 (p1 new-form))))
    694                     (let ((source-transform (source-transform op)))
    695                       (when source-transform
    696                         (let ((new-form (expand-source-transform form)))
    697                           (when (neq new-form form)
    698                             (return-from p1 (p1 new-form))))))
    699                     (let ((expansion (inline-expansion op)))
    700                       (when expansion
    701                         (return-from p1 (p1 (expand-inline form expansion)))))
    702                     (let ((local-function (find-local-function op)))
    703                       (when local-function
    704                         (dformat t "p1 local function ~S~%" op)
    705                         (unless (eq (local-function-compiland local-function)
    706                                     *current-compiland*)
    707                           (let ((variable (local-function-variable local-function)))
    708                             (when variable
    709                               (unless (eq (variable-compiland variable) *current-compiland*)
    710                                 (dformat t "p1 ~S used non-locally~%" (variable-name variable))
    711                                 (setf (variable-used-non-locally-p variable) t)))))))
    712                     (list* op (mapcar #'p1 (cdr form)))
    713                     )))
    714             ((and (consp op) (eq (car op) 'LAMBDA))
    715              (p1 (list* 'FUNCALL form)))
    716             (t
    717              form))))))
     654                (let ((variable (find-visible-variable form)))
     655                  (if variable
     656                      (progn
     657                        (incf (variable-reads variable))
     658                        (cond
     659                         ((eq (variable-compiland variable) *current-compiland*)
     660                          (dformat t "p1: read ~S~%" form))
     661                         (t
     662                          (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
     663                                   form
     664                                   (compiland-name (variable-compiland variable))
     665                                   (compiland-name *current-compiland*))
     666                          (setf (variable-used-non-locally-p variable) t))))
     667                      (dformat t "p1: unknown variable ~S~%" form)))
     668                form)))
     669        ((atom form)
     670         form)
     671        (t
     672         (let ((op (car form))
     673               handler)
     674           (cond ((symbolp op)
     675                  (cond ((setf handler (get op 'p1-handler))
     676                         (funcall handler form))
     677                        ((macro-function op)
     678                         (p1 (macroexpand form)))
     679                        ((special-operator-p op)
     680                         (error "P1: unsupported special operator ~S" op))
     681                        (t
     682                         ;; Function call.
     683                         (let ((new-form (rewrite-function-call form)))
     684                           (when (neq new-form form)
     685                             (dformat t "old form = ~S~%" form)
     686                             (dformat t "new form = ~S~%" new-form)
     687                             (return-from p1 (p1 new-form))))
     688                         (let ((source-transform (source-transform op)))
     689                           (when source-transform
     690                             (let ((new-form (expand-source-transform form)))
     691                               (when (neq new-form form)
     692                                 (return-from p1 (p1 new-form))))))
     693                         (let ((expansion (inline-expansion op)))
     694                           (when expansion
     695                             (return-from p1 (p1 (expand-inline form expansion)))))
     696                         (let ((local-function (find-local-function op)))
     697                           (when local-function
     698                             (dformat t "p1 local function ~S~%" op)
     699                             (unless (eq (local-function-compiland local-function)
     700                                         *current-compiland*)
     701                               (let ((variable (local-function-variable local-function)))
     702                                 (when variable
     703                                   (unless (eq (variable-compiland variable) *current-compiland*)
     704                                     (dformat t "p1 ~S used non-locally~%" (variable-name variable))
     705                                     (setf (variable-used-non-locally-p variable) t)))))))
     706                         (list* op (mapcar #'p1 (cdr form)))
     707                         )))
     708                 ((and (consp op) (eq (car op) 'LAMBDA))
     709                  (p1 (list* 'FUNCALL form)))
     710                 (t
     711                  form))))))
    718712
    719713(defun install-p1-handler (symbol handler)
    … …  
    14871481           (aver (variable-p variable))
    14881482           (dformat t "var-ref variable = ~S " (variable-name variable))
    1489            (cond
    1490             ((variable-register variable)
    1491              (dformat t "register = ~S~%" (variable-register variable))
    1492              (emit 'aload (variable-register variable))
    1493              (emit-move-from-stack target))
    1494             ((variable-special-p variable)
    1495              (dformat t "soecial~%")
    1496              (compile-special-reference (variable-name variable) target nil))
    1497             ((variable-closure-index variable)
    1498              (dformat t "closure-index = ~S~%" (variable-closure-index variable))
    1499              (aver (not (null (compiland-closure-register *current-compiland*))))
    1500              (emit 'aload (compiland-closure-register *current-compiland*))
    1501              (emit-push-constant-int (variable-closure-index variable))
    1502              (emit 'aaload)
    1503              (emit-move-from-stack target))
    1504             ((variable-index variable)
    1505              (dformat t "index = ~S~%" (variable-index variable))
    1506              (aver (not (null (compiland-argument-register *current-compiland*))))
    1507              (emit 'aload (compiland-argument-register *current-compiland*))
    1508              (emit-push-constant-int (variable-index variable))
    1509              (emit 'aaload)
    1510              (emit-move-from-stack target))
    1511             (t
    1512              (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable))
    1513              (aver (progn 'unhandled-case nil))))
     1483           (cond ((variable-register variable)
     1484                  (dformat t "register = ~S~%" (variable-register variable))
     1485                  (emit 'aload (variable-register variable))
     1486                  (emit-move-from-stack target))
     1487                 ((variable-special-p variable)
     1488                  (dformat t "soecial~%")
     1489                  (compile-special-reference (variable-name variable) target nil))
     1490                 ((variable-closure-index variable)
     1491                  (dformat t "closure-index = ~S~%" (variable-closure-index variable))
     1492                  (aver (not (null (compiland-closure-register *current-compiland*))))
     1493                  (emit 'aload (compiland-closure-register *current-compiland*))
     1494                  (emit-push-constant-int (variable-closure-index variable))
     1495                  (emit 'aaload)
     1496                  (emit-move-from-stack target))
     1497                 ((variable-index variable)
     1498                  (dformat t "index = ~S~%" (variable-index variable))
     1499                  (aver (not (null (compiland-argument-register *current-compiland*))))
     1500                  (emit 'aload (compiland-argument-register *current-compiland*))
     1501                  (emit-push-constant-int (variable-index variable))
     1502                  (emit 'aaload)
     1503                  (emit-move-from-stack target))
     1504                 (t
     1505                  (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable))
     1506                  (aver (progn 'unhandled-case nil))))
    15141507           (when (eq representation :unboxed-fixnum)
    15151508             (dformat t "resolve-variables calling emit-unbox-fixnum~%")
    … …  
    15301523                  (emit 'bipush (variable-closure-index variable))
    15311524                  (emit 'swap) ; array index value
    1532                   (emit 'aastore)
    1533                   )
     1525                  (emit 'aastore))
    15341526                 (t
    15351527                  (dformat t "var-set fall-through case~%")
    … …  
    20182010              (g (gethash symbol *declared-symbols*)))
    20192011          (cond (g
    2020                  (emit 'getstatic
    2021                        *this-class*
    2022                        g
    2023                        +lisp-symbol+))
     2012                 (emit 'getstatic *this-class* g +lisp-symbol+))
    20242013                (t
    20252014                 (emit 'ldc (pool-string (symbol-name symbol)))
    … …  
    22782267             (emit-move-from-stack target)
    22792268             t)
    2280             (t nil)))))
     2269            (t
     2270             nil)))))
    22812271
    22822272(defparameter binary-operators (make-hash-table :test 'eq))
    … …  
    23822372  (let ((arg1 (second form))
    23832373        (arg2 (third form)))
    2384     (cond
    2385      ((and (fixnum-or-unboxed-variable-p arg1)
    2386            (fixnum-or-unboxed-variable-p arg2))
    2387       (emit-push-int arg1)
    2388       (emit-push-int arg2)
    2389       (let ((label1 (gensym))
    2390             (label2 (gensym)))
    2391         (emit 'if_icmpeq `,label1)
    2392         (emit-push-nil)
    2393         (emit 'goto `,label2)
    2394         (emit 'label `,label1)
    2395         (emit-push-t)
    2396         (emit 'label `,label2))
    2397       (emit-move-from-stack target))
    2398      ((fixnum-or-unboxed-variable-p arg1)
    2399       (emit-push-int arg1)
    2400       (compile-form arg2 :target :stack)
    2401       (maybe-emit-clear-values arg2)
    2402       (emit 'swap)
    2403       (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
    2404       (let ((label1 (gensym))
    2405             (label2 (gensym)))
    2406         (emit 'ifne `,label1)
    2407         (emit-push-nil)
    2408         (emit 'goto `,label2)
    2409         (emit 'label `,label1)
    2410         (emit-push-t)
    2411         (emit 'label `,label2))
    2412       (emit-move-from-stack target))
    2413      ((fixnum-or-unboxed-variable-p arg2)
    2414       (compile-form arg1 :target :stack)
    2415       (maybe-emit-clear-values arg1)
    2416       (emit-push-int arg2)
    2417       (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
    2418       (let ((label1 (gensym))
    2419             (label2 (gensym)))
    2420         (emit 'ifne `,label1)
    2421         (emit-push-nil)
    2422         (emit 'goto `,label2)
    2423         (emit 'label `,label1)
    2424         (emit-push-t)
    2425         (emit 'label `,label2))
    2426       (emit-move-from-stack target))
    2427      (t
    2428       (compile-form arg1 :target :stack)
    2429       (compile-form arg2 :target :stack)
    2430       (unless (and (single-valued-p arg1)
    2431                    (single-valued-p arg2))
    2432         (emit-clear-values))
    2433       (emit-invokevirtual +lisp-object-class+ "EQL" (list +lisp-object+) +lisp-object+)
    2434       (emit-move-from-stack target)))))
     2374    (cond ((and (fixnum-or-unboxed-variable-p arg1)
     2375                (fixnum-or-unboxed-variable-p arg2))
     2376           (emit-push-int arg1)
     2377           (emit-push-int arg2)
     2378           (let ((label1 (gensym))
     2379                 (label2 (gensym)))
     2380             (emit 'if_icmpeq `,label1)
     2381             (emit-push-nil)
     2382             (emit 'goto `,label2)
     2383             (emit 'label `,label1)
     2384             (emit-push-t)
     2385             (emit 'label `,label2))
     2386           (emit-move-from-stack target))
     2387          ((fixnum-or-unboxed-variable-p arg1)
     2388           (emit-push-int arg1)
     2389           (compile-form arg2 :target :stack)
     2390           (maybe-emit-clear-values arg2)
     2391           (emit 'swap)
     2392           (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
     2393           (let ((label1 (gensym))
     2394                 (label2 (gensym)))
     2395             (emit 'ifne `,label1)
     2396             (emit-push-nil)
     2397             (emit 'goto `,label2)
     2398             (emit 'label `,label1)
     2399             (emit-push-t)
     2400             (emit 'label `,label2))
     2401           (emit-move-from-stack target))
     2402          ((fixnum-or-unboxed-variable-p arg2)
     2403           (compile-form arg1 :target :stack)
     2404           (maybe-emit-clear-values arg1)
     2405           (emit-push-int arg2)
     2406           (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
     2407           (let ((label1 (gensym))
     2408                 (label2 (gensym)))
     2409             (emit 'ifne `,label1)
     2410             (emit-push-nil)
     2411             (emit 'goto `,label2)
     2412             (emit 'label `,label1)
     2413             (emit-push-t)
     2414             (emit 'label `,label2))
     2415           (emit-move-from-stack target))
     2416          (t
     2417           (compile-form arg1 :target :stack)
     2418           (compile-form arg2 :target :stack)
     2419           (unless (and (single-valued-p arg1)
     2420                        (single-valued-p arg2))
     2421             (emit-clear-values))
     2422           (emit-invokevirtual +lisp-object-class+ "EQL"
     2423                              (list +lisp-object+) +lisp-object+)
     2424           (emit-move-from-stack target)))))
    24352425
    24362426(defun compile-function-call-3 (op args target)
    … …  
    25712561      (unless (> *speed* *debug*)
    25722562        (emit-push-current-thread))
    2573       (cond
    2574        ((eq op (compiland-name *current-compiland*)) ; recursive call
    2575         (emit 'aload 0)) ; this
    2576        ((inline-ok op)
    2577         (emit 'getstatic
    2578               *this-class*
    2579               (declare-function op)
    2580               +lisp-object+))
    2581        ((null (symbol-package op))
    2582         (let ((g (if *compile-file-truename*
    2583                      (declare-object-as-string op)
    2584                      (declare-object op))))
    2585           (emit 'getstatic
    2586                 *this-class*
    2587                 g
    2588                 +lisp-object+)))
    2589        (t
    2590         (emit 'getstatic
    2591               *this-class*
    2592               (declare-symbol op)
    2593               +lisp-symbol+)))
     2563      (cond ((eq op (compiland-name *current-compiland*)) ; recursive call
     2564             (emit 'aload 0)) ; this
     2565            ((inline-ok op)
     2566             (emit 'getstatic *this-class* (declare-function op) +lisp-object+))
     2567            ((null (symbol-package op))
     2568             (let ((g (if *compile-file-truename*
     2569                          (declare-object-as-string op)
     2570                          (declare-object op))))
     2571               (emit 'getstatic *this-class* g +lisp-object+)))
     2572            (t
     2573             (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)))
    25942574      (process-args args)
    25952575      (if (> *speed* *debug*)
    … …  
    26902670                         (declare-local-function local-function)
    26912671                         (declare-object (local-function-function local-function)))))
    2692              (emit 'getstatic
    2693                    *this-class*
    2694                    g
    2695                    +lisp-object+)))) ; Stack: template-function
     2672             (emit 'getstatic *this-class* g +lisp-object+)))) ; Stack: template-function
    26962673
    26972674    (when *closure-variables*
    … …  
    28252802             (second (second args))
    28262803             var1 var2)
    2827          (cond
    2828           ((and (fixnump first) (fixnump second))
    2829            (dformat t "p2-numeric-comparison form = ~S~%" form)
    2830            (if (funcall op first second)
    2831                (emit-push-t)
    2832                (emit-push-nil))
    2833            (return-from p2-numeric-comparison))
    2834           ((fixnump second)
    2835            (dformat t "p2-numeric-comparison form = ~S~%" form)
    2836            (compile-form (car args) :target :stack)
    2837            (unless (single-valued-p first)
    2838              (emit-clear-values))
    2839            (emit-push-constant-int second)
    2840            (emit-invokevirtual +lisp-object-class+
    2841                                (case op
    2842                                  (<  "isLessThan")
    2843                                  (<= "isLessThanOrEqualTo")
    2844                                  (>  "isGreaterThan")
    2845                                  (>= "isGreaterThanOrEqualTo")
    2846                                  (=  "isEqualTo")
    2847                                  (/= "isNotEqualTo"))
    2848                                '("I")
    2849                                "Z")
    2850            ;; Java boolean on stack here
    2851            (let ((LABEL1 (gensym))
    2852                  (LABEL2 (gensym)))
    2853              (emit 'ifeq LABEL1)
    2854              (emit-push-t)
    2855              (emit 'goto LABEL2)
    2856              (label LABEL1)
    2857              (emit-push-nil)
    2858              (label LABEL2)
    2859              (emit-move-from-stack target))
    2860            (return-from p2-numeric-comparison))
    2861           ((and (setf var1 (unboxed-fixnum-variable first))
    2862                 (setf var2 (unboxed-fixnum-variable second)))
    2863            (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
    2864            (let ((LABEL1 (gensym))
    2865                  (LABEL2 (gensym)))
    2866            (emit 'iload (variable-register var1))
    2867            (emit 'iload (variable-register var2))
    2868            (emit (case op
    2869                    (<  'if_icmpge)
    2870                    (<= 'if_icmpgt)
    2871                    (>  'if_icmple)
    2872                    (>= 'if_icmplt)
    2873                    (=  'if_icmpne)
    2874                    (/= 'if_icmpeq))
    2875                  LABEL1)
    2876              (emit-push-t)
    2877              (emit 'goto LABEL2)
    2878              (label LABEL1)
    2879              (emit-push-nil)
    2880              (label LABEL2)
    2881              (emit-move-from-stack target)
    2882              (return-from p2-numeric-comparison))
    2883            )
    2884           ) ; cond
    2885        ))))
     2804         (cond ((and (fixnump first) (fixnump second))
     2805                (dformat t "p2-numeric-comparison form = ~S~%" form)
     2806                (if (funcall op first second)
     2807                    (emit-push-t)
     2808                    (emit-push-nil))
     2809                (return-from p2-numeric-comparison))
     2810               ((fixnump second)
     2811                (dformat t "p2-numeric-comparison form = ~S~%" form)
     2812                (compile-form (car args) :target :stack)
     2813                (unless (single-valued-p first)
     2814                  (emit-clear-values))
     2815                (emit-push-constant-int second)
     2816                (emit-invokevirtual +lisp-object-class+
     2817                                    (case op
     2818                                      (<  "isLessThan")
     2819                                      (<= "isLessThanOrEqualTo")
     2820                                      (>  "isGreaterThan")
     2821                                      (>= "isGreaterThanOrEqualTo")
     2822                                      (=  "isEqualTo")
     2823                                      (/= "isNotEqualTo"))
     2824                                    '("I")
     2825                                    "Z")
     2826                ;; Java boolean on stack here
     2827                (let ((LABEL1 (gensym))
     2828                      (LABEL2 (gensym)))
     2829                  (emit 'ifeq LABEL1)
     2830                  (emit-push-t)
     2831                  (emit 'goto LABEL2)
     2832                  (label LABEL1)
     2833                  (emit-push-nil)
     2834                  (label LABEL2)
     2835                  (emit-move-from-stack target))
     2836                (return-from p2-numeric-comparison))
     2837               ((and (setf var1 (unboxed-fixnum-variable first))
     2838                     (setf var2 (unboxed-fixnum-variable second)))
     2839                (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
     2840                (let ((LABEL1 (gensym))
     2841                      (LABEL2 (gensym)))
     2842                  (emit 'iload (variable-register var1))
     2843                  (emit 'iload (variable-register var2))
     2844                  (emit (case op
     2845                          (<  'if_icmpge)
     2846                          (<= 'if_icmpgt)
     2847                          (>  'if_icmple)
     2848                          (>= 'if_icmplt)
     2849                          (=  'if_icmpne)
     2850                          (/= 'if_icmpeq))
     2851                        LABEL1)
     2852                  (emit-push-t)
     2853                  (emit 'goto LABEL2)
     2854                  (label LABEL1)
     2855                  (emit-push-nil)
     2856                  (label LABEL2)
     2857                  (emit-move-from-stack target)
     2858                  (return-from p2-numeric-comparison))))))))
    28862859  ;; Still here?
    2887   (compile-function-call form target representation)
    2888   )
     2860  (compile-function-call form target representation))
    28892861
    28902862(defun compile-test-3 (form negatep)
    2891 ;;   (dformat t "compile-test-3 form = ~S~%" form)
    28922863  (let ((op (car form))
    28932864        (args (cdr form)))
    … …  
    29632934              (second (second args))
    29642935              variable)
    2965           (cond
    2966            ((fixnump second)
    2967             (compile-form first :target :stack)
    2968             (maybe-emit-clear-values first)
    2969             (emit-push-constant-int second)
    2970             (emit-invokevirtual +lisp-object-class+ s '("I") "Z"))
    2971            ((setf variable (unboxed-fixnum-variable second))
    2972             (compile-form first :target :stack)
    2973             (maybe-emit-clear-values first)
    2974             (aver (variable-register variable))
    2975             (emit 'iload (variable-register variable))
    2976             (emit-invokevirtual +lisp-object-class+ s '("I") "Z"))
    2977            (t
    2978             (process-args args)
    2979             (emit-invokevirtual +lisp-object-class+ s (list +lisp-object+) "Z")))
     2936          (cond ((fixnump second)
     2937                 (compile-form first :target :stack)
     2938                 (maybe-emit-clear-values first)
     2939                 (emit-push-constant-int second)
     2940                 (emit-invokevirtual +lisp-object-class+ s '("I") "Z"))
     2941                ((setf variable (unboxed-fixnum-variable second))
     2942                 (compile-form first :target :stack)
     2943                 (maybe-emit-clear-values first)
     2944                 (aver (variable-register variable))
     2945                 (emit 'iload (variable-register variable))
     2946                 (emit-invokevirtual +lisp-object-class+ s '("I") "Z"))
     2947                (t
     2948                 (process-args args)
     2949                 (emit-invokevirtual +lisp-object-class+ s (list +lisp-object+) "Z")))
    29802950          (return-from compile-test-3 (if negatep 'ifne 'ifeq))))))
    29812951
    … …  
    32553225      (let ((initform (variable-initform variable)))
    32563226        (cond (initform
    3257                (cond
    3258                 ((and *trust-user-type-declarations*
    3259                       (variable-register variable)
    3260                       (variable-declared-type variable)
    3261                       (subtypep (variable-declared-type variable) 'FIXNUM))
    3262                  (dformat t "p2-let-bindings declared fixnum case: ~S~%"
    3263                           (variable-name variable))
    3264                  (setf (variable-representation variable) :unboxed-fixnum)
    3265                  (compile-form initform :target :stack :representation :unboxed-fixnum))
    3266                 ((and (variable-register variable)
    3267                       (eql (variable-writes variable) 0)
    3268                       (subtypep (derive-type initform) 'FIXNUM))
    3269                  (dformat t "p2-let-bindings read-only fixnum case: ~S~%"
    3270                           (variable-name variable))
    3271                  (setf (variable-representation variable) :unboxed-fixnum)
    3272                  (compile-form initform :target :stack :representation :unboxed-fixnum))
    3273                 (t
    3274                  (compile-form initform :target :stack)))
     3227               (cond ((and *trust-user-type-declarations*
     3228                           (variable-register variable)
     3229                           (variable-declared-type variable)
     3230                           (subtypep (variable-declared-type variable) 'FIXNUM))
     3231                      (dformat t "p2-let-bindings declared fixnum case: ~S~%"
     3232                               (variable-name variable))
     3233                      (setf (variable-representation variable) :unboxed-fixnum)
     3234                      (compile-form initform :target :stack :representation :unboxed-fixnum))
     3235                     ((and (variable-register variable)
     3236                           (eql (variable-writes variable) 0)
     3237                           (subtypep (derive-type initform) 'FIXNUM))
     3238                      (dformat t "p2-let-bindings read-only fixnum case: ~S~%"
     3239                               (variable-name variable))
     3240                      (setf (variable-representation variable) :unboxed-fixnum)
     3241                      (compile-form initform :target :stack :representation :unboxed-fixnum))
     3242                     (t
     3243                      (compile-form initform :target :stack)))
    32753244               (unless must-clear-values
    32763245                 (unless (single-valued-p initform)
    … …  
    32783247              (t
    32793248               (emit-push-nil)))
    3280         (cond
    3281          ((variable-special-p variable)
    3282           (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register))))
    3283          ((eq (variable-representation variable) :unboxed-fixnum)
    3284           (emit 'istore (variable-register variable)))
    3285          (t
    3286           (compile-binding variable)))))
     3249        (cond ((variable-special-p variable)
     3250               (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register))))
     3251              ((eq (variable-representation variable) :unboxed-fixnum)
     3252               (emit 'istore (variable-register variable)))
     3253              (t
     3254               (compile-binding variable)))))
    32873255    (when must-clear-values
    32883256      (emit-clear-values))
    … …  
    33043272      (let* ((initform (variable-initform variable))
    33053273             (boundp nil))
    3306         (cond
    3307          ((and (variable-special-p variable)
    3308                (eq initform (variable-name variable)))
    3309           (emit-push-current-thread)
    3310           (emit 'getstatic
    3311                 *this-class*
    3312                 (declare-symbol (variable-name variable))
    3313                 +lisp-symbol+)
    3314           (emit-invokevirtual +lisp-thread-class+
    3315                               "bindSpecialToCurrentValue"
    3316                               (list +lisp-symbol+)
    3317                               nil)
    3318           (setf boundp t))
    3319          (initform
    3320           (cond
    3321            ((and *trust-user-type-declarations*
    3322                  (null (variable-closure-index variable))
    3323                  (not (variable-special-p variable))
    3324                  (variable-declared-type variable)
    3325                  (subtypep (variable-declared-type variable) 'FIXNUM))
    3326             (dformat t "p2-let*-bindings declared fixnum case~%")
    3327             (setf (variable-representation variable) :unboxed-fixnum)
    3328             (compile-form initform :target :stack :representation :unboxed-fixnum)
    3329             (setf (variable-register variable) (allocate-register))
    3330             (emit 'istore (variable-register variable))
    3331             (setf boundp t))
    3332            ((and (null (variable-closure-index variable))
    3333                  (not (variable-special-p variable))
    3334                  (eql (variable-writes variable) 0)
    3335                  (subtypep (derive-type initform) 'FIXNUM))
    3336             (dformat t "p2-let*-bindings read-only fixnum case: ~S~%"
    3337                      (variable-name variable))
    3338             (setf (variable-representation variable) :unboxed-fixnum)
    3339             (compile-form initform :target :stack :representation :unboxed-fixnum)
    3340             (setf (variable-register variable) (allocate-register))
    3341             (emit 'istore (variable-register variable))
    3342             (setf boundp t))
    3343            (t
    3344             (compile-form initform :target :stack)))
    3345           (unless must-clear-values
    3346             (unless (single-valued-p initform)
    3347               (setf must-clear-values t))))
    3348          (t
    3349           (emit-push-nil)))
     3274        (cond ((and (variable-special-p variable)
     3275                    (eq initform (variable-name variable)))
     3276               (emit-push-current-thread)
     3277               (emit 'getstatic *this-class*
     3278                     (declare-symbol (variable-name variable)) +lisp-symbol+)
     3279               (emit-invokevirtual +lisp-thread-class+
     3280                                   "bindSpecialToCurrentValue"
     3281                                   (list +lisp-symbol+)
     3282                                   nil)
     3283               (setf boundp t))
     3284              (initform
     3285               (cond ((and *trust-user-type-declarations*
     3286                           (null (variable-closure-index variable))
     3287                           (not (variable-special-p variable))
     3288                           (variable-declared-type variable)
     3289                           (subtypep (variable-declared-type variable) 'FIXNUM))
     3290                      (dformat t "p2-let*-bindings declared fixnum case~%")
     3291                      (setf (variable-representation variable) :unboxed-fixnum)
     3292                      (compile-form initform :target :stack :representation :unboxed-fixnum)
     3293                      (setf (variable-register variable) (allocate-register))
     3294                      (emit 'istore (variable-register variable))
     3295                      (setf boundp t))
     3296                     ((and (null (variable-closure-index variable))
     3297                           (not (variable-special-p variable))
     3298                           (eql (variable-writes variable) 0)
     3299                           (subtypep (derive-type initform) 'FIXNUM))
     3300                      (dformat t "p2-let*-bindings read-only fixnum case: ~S~%"
     3301                               (variable-name variable))
     3302                      (setf (variable-representation variable) :unboxed-fixnum)
     3303                      (compile-form initform :target :stack :representation :unboxed-fixnum)
     3304                      (setf (variable-register variable) (allocate-register))
     3305                      (emit 'istore (variable-register variable))
     3306                      (setf boundp t))
     3307                     (t
     3308                      (compile-form initform :target :stack)))
     3309               (unless must-clear-values
     3310                 (unless (single-valued-p initform)
     3311                   (setf must-clear-values t))))
     3312              (t
     3313               (emit-push-nil)))
    33503314        (unless (variable-special-p variable)
    33513315          (unless (or (variable-closure-index variable) (variable-register variable))
    … …  
    34493413        (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
    34503414        (emit 'astore tag-register)
    3451 
    34523415        (dolist (tag local-tags)
    34533416          (let ((NEXT (gensym)))
    34543417            (emit 'aload tag-register)
    3455             (emit 'getstatic
    3456                   *this-class*
     3418            (emit 'getstatic *this-class*
    34573419                  (if *compile-file-truename*
    34583420                      (declare-object-as-string (tag-label tag))
    34593421                      (declare-object (tag-label tag)))
    34603422                  +lisp-object+)
    3461 
    34623423            (emit 'if_acmpne NEXT) ;; Jump if not EQ.
    34633424            ;; Restore dynamic environment.
    … …  
    34713432        (emit 'aload go-register)
    34723433        (emit 'athrow)
    3473 
    34743434        ;; Finally...
    34753435        (push (make-handler :from BEGIN-BLOCK
    … …  
    37213681            (if (symbol-package obj)
    37223682                (let ((g (declare-symbol obj)))
    3723                   (emit 'getstatic
    3724                         *this-class*
    3725                         g
    3726                         +lisp-symbol+))
     3683                  (emit 'getstatic *this-class* g +lisp-symbol+))
    37273684                ;; An uninterned symbol.
    37283685                (let ((g (if *compile-file-truename*
    37293686                             (declare-object-as-string obj)
    37303687                             (declare-object obj))))
    3731                   (emit 'getstatic
    3732                         *this-class*
    3733                         g
    3734                         +lisp-object+)))
     3688                  (emit 'getstatic *this-class* g +lisp-object+)))
    37353689            (emit-move-from-stack target))
    37363690           ((listp obj)
    … …  
    37383692                         (declare-object-as-string obj)
    37393693                         (declare-object obj))))
    3740               (emit 'getstatic
    3741                     *this-class*
    3742                     g
    3743                     +lisp-object+)
     3694              (emit 'getstatic *this-class* g +lisp-object+)
    37443695              (emit-move-from-stack target)))
    37453696           ((constantp obj)
    … …  
    38123763                          (declare-local-function local-function)
    38133764                          (declare-object function))))
    3814                (emit 'getstatic
    3815                      *this-class*
    3816                      g
    3817                      +lisp-object+)
     3765               (emit 'getstatic *this-class* g +lisp-object+)
    38183766               (emit 'var-set (local-function-variable local-function))))
    38193767            (t
    … …  
    41344082            (var1 (unboxed-fixnum-variable arg1))
    41354083            (var2 (unboxed-fixnum-variable arg2)))
    4136        (cond
    4137         ((and (numberp arg1) (numberp arg2))
    4138          (compile-constant (+ arg1 arg2)
    4139                            :target target
    4140                            :representation representation))
    4141         ((and var1 var2)
    4142          (dformat t "compile-plus case 1~%")
    4143          (dformat t "target = ~S representation = ~S~%" target representation)
    4144          (aver (variable-register var1))
    4145          (aver (variable-register var2))
    4146          (when target
    4147            (cond
    4148             ((eq representation :unboxed-fixnum)
    4149              (emit-push-int var1)
    4150              (emit-push-int arg2)
    4151              (emit 'iadd))
    4152             (t
    4153              (emit 'iload (variable-register var1))
    4154              (emit 'i2l)
    4155              (emit 'iload (variable-register var2))
    4156              (emit 'i2l)
    4157              (emit 'ladd)
    4158              (emit-box-long)))
    4159            (emit-move-from-stack target representation)))
    4160         ((and var1 (fixnump arg2))
    4161          (dformat t "compile-plus case 2~%")
    4162          (aver (variable-register var1))
    4163          (cond
    4164           ((eq representation :unboxed-fixnum)
    4165            (emit-push-int var1)
    4166            (emit-push-int arg2)
    4167            (emit 'iadd))
    4168           (t
    4169            (emit-push-int var1)
    4170            (emit 'i2l)
    4171            (emit-push-int arg2)
    4172            (emit 'i2l)
    4173            (emit 'ladd)
    4174            (emit-box-long)))
    4175          (emit-move-from-stack target representation))
    4176         ((and (fixnump arg1) var2)
    4177          (dformat t "compile-plus case 3~%")
    4178          (aver (variable-register var2))
    4179          (cond
    4180           ((eq representation :unboxed-fixnum)
    4181            (emit-push-int arg1)
    4182            (emit-push-int var2)
    4183            (emit 'iadd))
    4184           (t
    4185            (emit-push-int arg1)
    4186            (emit 'i2l)
    4187            (emit-push-int var2)
    4188            (emit 'i2l)
    4189            (emit 'ladd)
    4190            (emit-box-long)))
    4191          (emit-move-from-stack target representation))
    4192         ((eql arg1 1)
    4193          (dformat t "compile-plus case 4~%")
    4194          (compile-form arg2 :target :stack)
    4195          (maybe-emit-clear-values arg2)
    4196          (emit-invoke-method "incr" target representation))
    4197         ((eql arg2 1)
    4198          (dformat t "compile-plus case 5~%")
    4199          (compile-form arg1 :target :stack)
    4200          (maybe-emit-clear-values arg1)
    4201          (emit-invoke-method "incr" target representation))
    4202         ((arg-is-fixnum-p arg1)
    4203          (dformat t "compile-plus case 6~%")
    4204          (emit-push-int arg1)
    4205          (compile-form arg2 :target :stack)
    4206          (maybe-emit-clear-values arg2)
    4207          (emit 'swap)
    4208          (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
    4209          (when (eq representation :unboxed-fixnum)
    4210            (emit-unbox-fixnum))
    4211          (emit-move-from-stack target representation))
    4212         ((arg-is-fixnum-p arg2)
    4213          (dformat t "compile-plus case 7~%")
    4214          (compile-form arg1 :target :stack)
    4215          (maybe-emit-clear-values arg1)
    4216          (emit-push-int arg2)
    4217          (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
    4218          (when (eq representation :unboxed-fixnum)
    4219            (emit-unbox-fixnum))
    4220          (emit-move-from-stack target representation))
    4221         (t
    4222          (dformat t "compile-plus case 8~%")
    4223          (compile-binary-operation "add" args target representation)))))
     4084       (cond ((and (numberp arg1) (numberp arg2))
     4085              (compile-constant (+ arg1 arg2)
     4086                                :target target
     4087                                :representation representation))
     4088             ((and var1 var2)
     4089              (dformat t "compile-plus case 1~%")
     4090              (dformat t "target = ~S representation = ~S~%" target representation)
     4091              (aver (variable-register var1))
     4092              (aver (variable-register var2))
     4093              (when target
     4094                (cond ((eq representation :unboxed-fixnum)
     4095                       (emit-push-int var1)
     4096                       (emit-push-int arg2)
     4097                       (emit 'iadd))
     4098                      (t
     4099                       (emit 'iload (variable-register var1))
     4100                       (emit 'i2l)
     4101                       (emit 'iload (variable-register var2))
     4102                       (emit 'i2l)
     4103                       (emit 'ladd)
     4104                       (emit-box-long)))
     4105                (emit-move-from-stack target representation)))
     4106             ((and var1 (fixnump arg2))
     4107              (dformat t "compile-plus case 2~%")
     4108              (aver (variable-register var1))
     4109              (cond ((eq representation :unboxed-fixnum)
     4110                     (emit-push-int var1)
     4111                     (emit-push-int arg2)
     4112                     (emit 'iadd))
     4113                    (t
     4114                     (emit-push-int var1)
     4115                     (emit 'i2l)
     4116                     (emit-push-int arg2)
     4117                     (emit 'i2l)
     4118                     (emit 'ladd)
     4119                     (emit-box-long)))
     4120              (emit-move-from-stack target representation))
     4121             ((and (fixnump arg1) var2)
     4122              (dformat t "compile-plus case 3~%")
     4123              (aver (variable-register var2))
     4124              (cond ((eq representation :unboxed-fixnum)
     4125                     (emit-push-int arg1)
     4126                     (emit-push-int var2)
     4127                     (emit 'iadd))
     4128                    (t
     4129                     (emit-push-int arg1)
     4130                     (emit 'i2l)
     4131                     (emit-push-int var2)
     4132                     (emit 'i2l)
     4133                     (emit 'ladd)
     4134                     (emit-box-long)))
     4135              (emit-move-from-stack target representation))
     4136             ((eql arg1 1)
     4137              (dformat t "compile-plus case 4~%")
     4138              (compile-form arg2 :target :stack)
     4139              (maybe-emit-clear-values arg2)
     4140              (emit-invoke-method "incr" target representation))
     4141             ((eql arg2 1)
     4142              (dformat t "compile-plus case 5~%")
     4143              (compile-form arg1 :target :stack)
     4144              (maybe-emit-clear-values arg1)
     4145              (emit-invoke-method "incr" target representation))
     4146             ((arg-is-fixnum-p arg1)
     4147              (dformat t "compile-plus case 6~%")
     4148              (emit-push-int arg1)
     4149              (compile-form arg2 :target :stack)
     4150              (maybe-emit-clear-values arg2)
     4151              (emit 'swap)
     4152              (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
     4153              (when (eq representation :unboxed-fixnum)
     4154                (emit-unbox-fixnum))
     4155              (emit-move-from-stack target representation))
     4156             ((arg-is-fixnum-p arg2)
     4157              (dformat t "compile-plus case 7~%")
     4158              (compile-form arg1 :target :stack)
     4159              (maybe-emit-clear-values arg1)
     4160              (emit-push-int arg2)
     4161              (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+)
     4162              (when (eq representation :unboxed-fixnum)
     4163                (emit-unbox-fixnum))
     4164              (emit-move-from-stack target representation))
     4165             (t
     4166              (dformat t "compile-plus case 8~%")
     4167              (compile-binary-operation "add" args target representation)))))
    42244168    (4
    42254169     (dformat t "compile-plus case 9~%")
    … …  
    42414185            (var1 (unboxed-fixnum-variable arg1))
    42424186            (var2 (unboxed-fixnum-variable arg2)))
    4243        (cond
    4244         ((and (numberp arg1) (numberp arg2))
    4245          (compile-constant (- arg1 arg2)
    4246                            :target target
    4247                            :representation representation))
    4248         ((and var1 var2)
    4249          (dformat t "compile-minus case 1~%")
    4250          (aver (variable-register var1))
    4251          (aver (variable-register var2))
    4252          (when target
    4253            (cond
    4254             ((eq representation :unboxed-fixnum)
    4255              (emit 'iload (variable-register var1))
    4256              (emit 'iload (variable-register var2))
    4257              (emit 'isub))
    4258             (t
    4259              (emit 'iload (variable-register var1))
    4260              (emit 'i2l)
    4261              (emit 'iload (variable-register var2))
    4262              (emit 'i2l)
    4263              (emit 'lsub)
    4264              (emit-box-long)))
    4265            (emit-move-from-stack target representation)))
    4266         ((and var1 (fixnump arg2))
    4267          (dformat t "compile-minus case 2~%")
    4268          (aver (variable-register var1))
    4269          (cond
    4270           ((eq representation :unboxed-fixnum)
    4271            (emit-push-int var1)
    4272            (emit-push-int arg2)
    4273            (emit 'isub))
    4274           (t
    4275            (emit-push-int var1)
    4276            (emit 'i2l)
    4277            (emit-push-int arg2)
    4278            (emit 'i2l)
    4279            (emit 'lsub)
    4280            (emit-box-long)))
    4281          (emit-move-from-stack target representation))
    4282         ((and (fixnump arg1) var2)
    4283          (dformat t "compile-minus case 3~%")
    4284          (aver (variable-register var2))
    4285          (cond
    4286           ((eq representation :unboxed-fixnum)
    4287            (emit-push-int arg1)
    4288            (emit-push-int var2)
    4289            (emit 'isub))
    4290           (t
    4291            (emit-push-int arg1)
    4292            (emit 'i2l)
    4293            (emit-push-int var2)
    4294            (emit 'i2l)
    4295            (emit 'lsub)
    4296            (emit-box-long)))
    4297          (emit-move-from-stack target representation))
    4298         ((eql arg2 1)
    4299          (dformat t "compile-minus case 5~%")
    4300          (compile-form arg1 :target :stack)
    4301          (maybe-emit-clear-values arg2)
    4302          (emit-invoke-method "decr" target representation))
    4303         ((arg-is-fixnum-p arg2)
    4304          (dformat t "compile-minus case 7~%")
    4305          (compile-form arg1 :target :stack)
    4306          (maybe-emit-clear-values arg1)
    4307          (emit-push-int arg2)
    4308          (emit-invokevirtual +lisp-object-class+ "subtract" '("I") +lisp-object+)
    4309          (when (eq representation :unboxed-fixnum)
    4310            (emit-unbox-fixnum))
    4311          (emit-move-from-stack target representation))
    4312         (t
    4313          (dformat t "compile-minus case 8~%")
    4314          (compile-binary-operation "subtract" args target representation)))))
     4187       (cond ((and (numberp arg1) (numberp arg2))
     4188              (compile-constant (- arg1 arg2)
     4189                                :target target
     4190                                :representation representation))
     4191             ((and var1 var2)
     4192              (dformat t "compile-minus case 1~%")
     4193              (aver (variable-register var1))
     4194              (aver (variable-register var2))
     4195              (when target
     4196                (cond
     4197                 ((eq representation :unboxed-fixnum)
     4198                  (emit 'iload (variable-register var1))
     4199                  (emit 'iload (variable-register var2))
     4200                  (emit 'isub))
     4201                 (t
     4202                  (emit 'iload (variable-register var1))
     4203                  (emit 'i2l)
     4204                  (emit 'iload (variable-register var2))
     4205                  (emit 'i2l)
     4206                  (emit 'lsub)
     4207                  (emit-box-long)))
     4208                (emit-move-from-stack target representation)))
     4209             ((and var1 (fixnump arg2))
     4210              (dformat t "compile-minus case 2~%")
     4211              (aver (variable-register var1))
     4212              (cond
     4213               ((eq representation :unboxed-fixnum)
     4214                (emit-push-int var1)
     4215                (emit-push-int arg2)
     4216                (emit 'isub))
     4217               (t
     4218                (emit-push-int var1)
     4219                (emit 'i2l)
     4220                (emit-push-int arg2)
     4221                (emit 'i2l)
     4222                (emit 'lsub)
     4223                (emit-box-long)))
     4224              (emit-move-from-stack target representation))
     4225             ((and (fixnump arg1) var2)
     4226              (dformat t "compile-minus case 3~%")
     4227              (aver (variable-register var2))
     4228              (cond ((eq representation :unboxed-fixnum)
     4229                     (emit-push-int arg1)
     4230                     (emit-push-int var2)
     4231                     (emit 'isub))
     4232                    (t
     4233                     (emit-push-int arg1)
     4234                     (emit 'i2l)
     4235                     (emit-push-int var2)
     4236                     (emit 'i2l)
     4237                     (emit 'lsub)
     4238                     (emit-box-long)))
     4239              (emit-move-from-stack target representation))
     4240             ((eql arg2 1)
     4241              (dformat t "compile-minus case 5~%")
     4242              (compile-form arg1 :target :stack)
     4243              (maybe-emit-clear-values arg2)
     4244              (emit-invoke-method "decr" target representation))
     4245             ((arg-is-fixnum-p arg2)
     4246              (dformat t "compile-minus case 7~%")
     4247              (compile-form arg1 :target :stack)
     4248              (maybe-emit-clear-values arg1)
     4249              (emit-push-int arg2)
     4250              (emit-invokevirtual +lisp-object-class+ "subtract" '("I") +lisp-object+)
     4251              (when (eq representation :unboxed-fixnum)
     4252                (emit-unbox-fixnum))
     4253              (emit-move-from-stack target representation))
     4254             (t
     4255              (dformat t "compile-minus case 8~%")
     4256              (compile-binary-operation "subtract" args target representation)))))
    43154257    (4
    43164258     (dformat t "compile-minus case 9~%")
    … …  
    44264368
    44274369(defun compile-special-reference (name target representation)
    4428   (emit 'getstatic
    4429         *this-class*
    4430         (declare-symbol name)
    4431         +lisp-symbol+)
     4370  (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+)
    44324371  (emit-push-current-thread)
    4433   (emit-invokevirtual +lisp-symbol-class+
    4434                       "symbolValue"
    4435                       (list +lisp-thread+)
    4436                       +lisp-object+)
     4372  (emit-invokevirtual +lisp-symbol-class+ "symbolValue"
     4373                      (list +lisp-thread+) +lisp-object+)
    44374374  (when (eq representation :unboxed-fixnum)
    44384375    (emit-unbox-fixnum))
    … …  
    47304667                  (error "COMPILE-FORM unhandled case ~S" form)))))
    47314668        ((symbolp form)
    4732 ;;          (dformat t "compile-form symbolp case form = ~S~%" form)
    4733          (cond
    4734           ((null form)
    4735            (emit-push-nil)
    4736            (emit-move-from-stack target))
    4737           ((eq form t)
    4738            (emit-push-t)
    4739            (emit-move-from-stack target))
    4740           ((keywordp form)
    4741            (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+)
    4742            (emit-move-from-stack target))
    4743           (t
    4744            ;; Maybe it's a symbol macro...
    4745            (let ((expansion (macroexpand form)))
    4746              (if (eq expansion form)
    4747                  (compile-variable-reference form target representation)
    4748                  (compile-form expansion :target target :representation representation))))))
     4669         (cond ((null form)
     4670                (emit-push-nil)
     4671                (emit-move-from-stack target))
     4672               ((eq form t)
     4673                (emit-push-t)
     4674                (emit-move-from-stack target))
     4675               ((keywordp form)
     4676                (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+)
     4677                (emit-move-from-stack target))
     4678               (t
     4679                ;; Maybe it's a symbol macro...
     4680                (let ((expansion (macroexpand form)))
     4681                  (if (eq expansion form)
     4682                      (compile-variable-reference form target representation)
     4683                      (compile-form expansion :target target :representation representation))))))
    47494684        ((block-node-p form)
    47504685         (cond ((equal (block-name form) '(TAGBODY))
    … …  
    47804715                         (get-descriptor (list +lisp-object-array+)
    47814716                                          +lisp-object+))))
    4782       (cond
    4783        (*closure-variables*
    4784         (return-from analyze-args
    4785                      (cond ((<= arg-count 4)
    4786                             (get-descriptor (list* +lisp-object-array+
    4787                                                     (make-list arg-count :initial-element +lisp-object+))
    4788                                              +lisp-object+))
    4789                            (t (setf *using-arg-array* t)
    4790                               (setf *arity* arg-count)
    4791                               (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
    4792                                                +lisp-object+)))))
    4793        (t
    4794         (return-from analyze-args
    4795                      (cond ((<= arg-count 4)
    4796                             (get-descriptor (make-list arg-count :initial-element +lisp-object+)
    4797                                              +lisp-object+))
    4798                            (t (setf *using-arg-array* t)
    4799                               (setf *arity* arg-count)
    4800                               (get-descriptor (list +lisp-object-array+)
    4801                                                +lisp-object+)))))))
     4717      (cond (*closure-variables*
     4718             (return-from analyze-args
     4719                          (cond ((<= arg-count 4)
     4720                                 (get-descriptor (list* +lisp-object-array+
     4721                                                        (make-list arg-count :initial-element +lisp-object+))
     4722                                                 +lisp-object+))
     4723                                (t (setf *using-arg-array* t)
     4724                                   (setf *arity* arg-count)
     4725                                   (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
     4726                                                   +lisp-object+)))))
     4727            (t
     4728             (return-from analyze-args
     4729                          (cond ((<= arg-count 4)
     4730                                 (get-descriptor (make-list arg-count :initial-element +lisp-object+)
     4731                                                 +lisp-object+))
     4732                                (t (setf *using-arg-array* t)
     4733                                   (setf *arity* arg-count)
     4734                                   (get-descriptor (list +lisp-object-array+)
     4735                                                   +lisp-object+)))))))
    48024736    (when (or (memq '&KEY args)
    48034737              (memq '&OPTIONAL args)
    … …  
    50675001             (aver (eql (compiland-closure-register compiland) 1))
    50685002             (when (some #'variable-closure-index parameters)
    5069                (emit 'aload (compiland-closure-register compiland)))
    5070              )
     5003               (emit 'aload (compiland-closure-register compiland))))
    50715004            (t
    50725005             (emit-push-constant-int (length *closure-variables*))
    … …  
    50775010        (when (variable-closure-index variable)
    50785011          (dformat t "moving variable ~S~%" (variable-name variable))
    5079           (cond
    5080            ((variable-register variable)
    5081 ;;             (aver (variable-register variable)) ;; FIXME need to handle the arg-array case too!
    5082             (when (eql (variable-register variable) (compiland-closure-register compiland))
    5083               (error "ERROR! compiland closure register = ~S var ~S register = ~S~%"
    5084                      (compiland-closure-register compiland)
    5085                      (variable-name variable)
    5086                      (variable-register variable)))
    5087             (emit 'dup) ; array
    5088             (emit-push-constant-int (variable-closure-index variable))
    5089             (emit 'aload (variable-register variable))
    5090             (emit 'aastore)
    5091             (setf (variable-register variable) nil) ; The variable has moved.
    5092             )
    5093            ((variable-index variable)
    5094 ;;             (aver (null (compiland-parent compiland))) ;; FIXME
    5095             (emit 'dup) ; array
    5096             (emit-push-constant-int (variable-closure-index variable))
    5097             (emit 'aload (compiland-argument-register compiland))
    5098             (emit-push-constant-int (variable-index variable))
    5099             (emit 'aaload)
    5100             (emit 'aastore)
    5101             (setf (variable-index variable) nil) ; The variable has moved.
    5102             )
    5103           )))
     5012          (cond ((variable-register variable)
     5013                 (when (eql (variable-register variable)
     5014                            (compiland-closure-register compiland))
     5015                   (error "ERROR! compiland closure register = ~S var ~S register = ~S~%"
     5016                          (compiland-closure-register compiland)
     5017                          (variable-name variable)
     5018                          (variable-register variable)))
     5019                 (emit 'dup) ; array
     5020                 (emit-push-constant-int (variable-closure-index variable))
     5021                 (emit 'aload (variable-register variable))
     5022                 (emit 'aastore)
     5023                 (setf (variable-register variable) nil)) ; The variable has moved.
     5024                ((variable-index variable)
     5025                 (emit 'dup) ; array
     5026                 (emit-push-constant-int (variable-closure-index variable))
     5027                 (emit 'aload (compiland-argument-register compiland))
     5028                 (emit-push-constant-int (variable-index variable))
     5029                 (emit 'aaload)
     5030                 (emit 'aastore)
     5031                 (setf (variable-index variable) nil))))) ; The variable has moved.
    51045032      (aver (not (null (compiland-closure-register compiland))))
    51055033      (cond (*child-p*
    … …  
    51095037             (emit 'astore (compiland-closure-register compiland))))
    51105038      (dformat t "~S done moving arguments to closure array~%"
    5111                (compiland-name compiland))
    5112       )
     5039               (compiland-name compiland)))
    51135040
    51145041    ;; Establish dynamic bindings for any variables declared special.
    … …  
    51175044        (cond ((variable-register variable)
    51185045               (emit-push-current-thread)
    5119                (emit 'getstatic
    5120                      *this-class*
     5046               (emit 'getstatic *this-class*
    51215047                     (declare-symbol (variable-name variable))
    51225048                     +lisp-symbol+)
    51235049               (emit 'aload (variable-register variable))
    5124                (emit-invokevirtual +lisp-thread-class+
    5125                                    "bindSpecial"
    5126                                    (list +lisp-symbol+ +lisp-object+)
    5127                                    nil)
     5050               (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     5051                                   (list +lisp-symbol+ +lisp-object+) nil)
    51285052               (setf (variable-register variable) nil))
    51295053              ((variable-index variable)
    51305054               (emit-push-current-thread)
    5131                (emit 'getstatic
    5132                      *this-class*
    5133                      (declare-symbol (variable-name variable))
    5134                      +lisp-symbol+)
     5055               (emit 'getstatic *this-class*
     5056                     (declare-symbol (variable-name variable)) +lisp-symbol+)
    51355057               (emit 'aload 1)
    51365058               (emit 'bipush (variable-index variable))
    51375059               (emit 'aaload)
    5138                (emit-invokevirtual +lisp-thread-class+
    5139                                    "bindSpecial"
    5140                                    (list +lisp-symbol+ +lisp-object+)
    5141                                    nil)
     5060               (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     5061                                   (list +lisp-symbol+ +lisp-object+) nil)
    51425062               (setf (variable-index variable) nil)))))
    51435063
    … …  
    51725092        (emit 'astore (compiland-argument-register compiland)))
    51735093
    5174       (cond
    5175        ((and (not *child-p*) (not *using-arg-array*))
    5176         (dolist (variable (reverse *visible-variables*))
    5177           (when (eq (variable-representation variable) :unboxed-fixnum)
    5178             (emit 'aload (variable-register variable))
    5179             (emit-unbox-fixnum)
    5180             (emit 'istore (variable-register variable))))))
     5094      (cond ((and (not *child-p*) (not *using-arg-array*))
     5095             (dolist (variable (reverse *visible-variables*))
     5096               (when (eq (variable-representation variable) :unboxed-fixnum)
     5097                 (emit 'aload (variable-register variable))
     5098                 (emit-unbox-fixnum)
     5099                 (emit 'istore (variable-register variable))))))
    51815100
    51825101      (maybe-initialize-thread-var)
    … …  
    53405259                  (setf (fdefinition name) (sys::make-macro name compiled-definition))
    53415260                  (setf (fdefinition name) compiled-definition)))
    5342             (cond
    5343              ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
    5344               (setf warnings-p nil failure-p nil))
    5345              ((zerop (+ jvm::*errors* jvm::*warnings*))
    5346               (setf failure-p nil)))
     5261            (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
     5262                   (setf warnings-p nil failure-p nil))
     5263                  ((zerop (+ jvm::*errors* jvm::*warnings*))
     5264                   (setf failure-p nil)))
    53475265            (when *compile-print*
    53485266              (if name
Note: See TracChangeset for help on using the changeset viewer.