Changeset 13025


Ignore:
Timestamp:
11/16/10 19:40:03 (11 years ago)
Author:
astalla
Message:

Added with-code-to-method to pass2 to compile the constructor and, in the future, the static initializer.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r13022 r13025  
    525525     (when (fixnum-type-p declared-type) 'FIXNUM)
    526526     (find-if #'(lambda (type) (eq type declared-type))
    527         '(SYMBOL CHARACTER CONS HASH-TABLE))
    528      (find-if #'(lambda (type) (subtypep declared-type type)) 
    529         '(STRING VECTOR STREAM)))))
     527              '(SYMBOL CHARACTER CONS HASH-TABLE))
     528     (find-if #'(lambda (type) (subtypep declared-type type))
     529              '(STRING VECTOR STREAM)))))
    530530
    531531
    532532(defknown generate-type-check-for-variable (t) t)
    533533(defun generate-type-check-for-variable (variable)
    534   (let ((type-to-use 
    535   (find-type-for-type-check (variable-declared-type variable))))
     534  (let ((type-to-use
     535        (find-type-for-type-check (variable-declared-type variable))))
    536536    (when type-to-use
    537537      (generate-instanceof-type-check-for-variable variable type-to-use))))
     
    641641(defun compile-forms-and-maybe-emit-clear-values (&rest forms-and-compile-args)
    642642  (let ((forms-for-emit-clear
    643   (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr
    644       do (compile-form form arg1 arg2)
    645       collecting form)))
     643        (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr
     644            do (compile-form form arg1 arg2)
     645            collecting form)))
    646646    (apply #'maybe-emit-clear-values forms-for-emit-clear)))
    647647
     
    749749         (args (cdr form))
    750750         (ok (if minimum
    751     (>= (length args) n)
    752          (= (length args) n))))
     751                (>= (length args) n)
     752                 (= (length args) n))))
    753753    (declare (type boolean ok))
    754754    (unless ok
     
    796796(defun make-constructor (class)
    797797  (let* ((*compiler-debug* nil)
     798         (method (make-method :constructor :void nil
     799                              :flags '(:public)))
     800         ;; We don't normally need to see debugging output for constructors.
    798801         (super (class-file-superclass class))
    799802         (lambda-name (abcl-class-file-lambda-name class))
    800803         (args (abcl-class-file-lambda-list class))
    801          ;; We don't normally need to see debugging output for constructors.
    802          (method (make-method :constructor :void nil
    803                               :flags '(:public)))
    804          (code (method-add-code method))
    805804         req-params-register
    806805         opt-params-register
     
    808807         rest-p
    809808         keys-p
    810          more-keys-p
    811          (*code* ())
    812          (*current-code-attribute* code))
    813     (setf (code-max-locals code) 1)
    814     (unless (eq super +lisp-compiled-primitive+)
    815       (multiple-value-bind
    816             (req opt key key-p rest
    817                  allow-other-keys-p)
    818           (parse-lambda-list args)
    819         (setf rest-p rest
    820               more-keys-p allow-other-keys-p
    821               keys-p key-p)
    822         (macrolet
    823             ((parameters-to-array ((param params register) &body body)
    824                (let ((count-sym (gensym)))
    825                  `(progn
    826                     (emit-push-constant-int (length ,params))
    827                     (emit-anewarray +lisp-closure-parameter+)
    828                     (astore (setf ,register (code-max-locals code)))
    829                     (incf (code-max-locals code))
    830                     (do* ((,count-sym 0 (1+ ,count-sym))
    831                           (,params ,params (cdr ,params))
    832                           (,param (car ,params) (car ,params)))
    833                         ((endp ,params))
    834                       (declare (ignorable ,param))
    835                       (aload ,register)
    836                       (emit-push-constant-int ,count-sym)
    837                       (emit-new +lisp-closure-parameter+)
    838                       (emit 'dup)
    839                       ,@body
    840                       (emit 'aastore))))))
    841           ;; process required args
    842           (parameters-to-array (ignore req req-params-register)
    843              (emit-push-t) ;; we don't need the actual symbol
    844              (emit-invokespecial-init +lisp-closure-parameter+
    845                                       (list +lisp-symbol+)))
    846 
    847           (parameters-to-array (param opt opt-params-register)
    848              (emit-push-t) ;; we don't need the actual variable-symbol
    849              (emit-read-from-string (second param)) ;; initform
    850              (if (null (third param))               ;; supplied-p
    851                  (emit-push-nil)
    852                  (emit-push-t)) ;; we don't need the actual supplied-p symbol
    853              (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
    854              (emit-invokespecial-init +lisp-closure-parameter+
    855                                       (list +lisp-symbol+ +lisp-object+
    856                                             +lisp-object+ :int)))
    857 
    858           (parameters-to-array (param key key-params-register)
    859              (let ((keyword (fourth param)))
    860                (if (keywordp keyword)
    861                    (progn
    862                      (emit 'ldc (pool-string (symbol-name keyword)))
    863                      (emit-invokestatic +lisp+ "internKeyword"
    864                                         (list +java-string+) +lisp-symbol+))
    865                    ;; symbol is not really a keyword; yes, that's allowed!
    866                    (progn
    867                      (emit 'ldc (pool-string (symbol-name keyword)))
    868                      (emit 'ldc (pool-string
    869                                  (package-name (symbol-package keyword))))
    870                      (emit-invokestatic +lisp+ "internInPackage"
    871                                         (list +java-string+ +java-string+)
    872                                         +lisp-symbol+))))
    873              (emit-push-t) ;; we don't need the actual variable-symbol
    874              (emit-read-from-string (second (car key)))
    875              (if (null (third param))
    876                  (emit-push-nil)
    877                  (emit-push-t)) ;; we don't need the actual supplied-p symbol
    878              (emit-invokespecial-init +lisp-closure-parameter+
    879                                       (list +lisp-symbol+ +lisp-symbol+
    880                                             +lisp-object+ +lisp-object+))))))
    881     (aload 0) ;; this
    882     (cond ((eq super +lisp-compiled-primitive+)
    883            (emit-constructor-lambda-name lambda-name)
    884            (emit-constructor-lambda-list args)
    885            (emit-invokespecial-init super (lisp-object-arg-types 2)))
    886           ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
    887            (aload req-params-register)
    888            (aload opt-params-register)
    889            (aload key-params-register)
    890            (if keys-p
    891                (emit-push-t)
    892                (emit-push-nil-symbol))
    893            (if rest-p
    894                (emit-push-t)
    895                (emit-push-nil-symbol))
    896            (if more-keys-p
    897                (emit-push-t)
    898                (emit-push-nil-symbol))
    899            (emit-invokespecial-init super
    900                                     (list +lisp-closure-parameter-array+
    901                                           +lisp-closure-parameter-array+
    902                                           +lisp-closure-parameter-array+
    903                                           +lisp-symbol+
    904                                           +lisp-symbol+ +lisp-symbol+)))
    905           (t
    906            (aver nil)))
    907     (setf *code* (append *static-code* *code*))
    908     (emit 'return)
    909     (setf (code-code code) *code*)
     809         more-keys-p)
     810    (with-code-to-method (class method)
     811      (allocate-register)
     812      (unless (eq super +lisp-compiled-primitive+)
     813        (multiple-value-bind
     814             (req opt key key-p rest
     815                  allow-other-keys-p)
     816            (parse-lambda-list args)
     817          (setf rest-p rest
     818                more-keys-p allow-other-keys-p
     819                keys-p key-p)
     820          (macrolet
     821              ((parameters-to-array ((param params register) &body body)
     822                 (let ((count-sym (gensym)))
     823                   `(progn
     824                      (emit-push-constant-int (length ,params))
     825                      (emit-anewarray +lisp-closure-parameter+)
     826                      (astore (setf ,register *registers-allocated*))
     827                      (allocate-register)
     828                      (do* ((,count-sym 0 (1+ ,count-sym))
     829                            (,params ,params (cdr ,params))
     830                            (,param (car ,params) (car ,params)))
     831                           ((endp ,params))
     832                        (declare (ignorable ,param))
     833                        (aload ,register)
     834                        (emit-push-constant-int ,count-sym)
     835                        (emit-new +lisp-closure-parameter+)
     836                        (emit 'dup)
     837                        ,@body
     838                        (emit 'aastore))))))
     839            ;; process required args
     840            (parameters-to-array (ignore req req-params-register)
     841               (emit-push-t) ;; we don't need the actual symbol
     842               (emit-invokespecial-init +lisp-closure-parameter+
     843                                        (list +lisp-symbol+)))
     844
     845            (parameters-to-array (param opt opt-params-register)
     846               (emit-push-t) ;; we don't need the actual variable-symbol
     847               (emit-read-from-string (second param)) ;; initform
     848               (if (null (third param))               ;; supplied-p
     849                   (emit-push-nil)
     850                   (emit-push-t)) ;; we don't need the actual supplied-p symbol
     851               (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
     852               (emit-invokespecial-init +lisp-closure-parameter+
     853                                        (list +lisp-symbol+ +lisp-object+
     854                                              +lisp-object+ :int)))
     855
     856            (parameters-to-array (param key key-params-register)
     857               (let ((keyword (fourth param)))
     858                 (if (keywordp keyword)
     859                     (progn
     860                       (emit 'ldc (pool-string (symbol-name keyword)))
     861                       (emit-invokestatic +lisp+ "internKeyword"
     862                                          (list +java-string+) +lisp-symbol+))
     863                     ;; symbol is not really a keyword; yes, that's allowed!
     864                     (progn
     865                       (emit 'ldc (pool-string (symbol-name keyword)))
     866                       (emit 'ldc (pool-string
     867                                   (package-name (symbol-package keyword))))
     868                       (emit-invokestatic +lisp+ "internInPackage"
     869                                          (list +java-string+ +java-string+)
     870                                          +lisp-symbol+))))
     871               (emit-push-t) ;; we don't need the actual variable-symbol
     872               (emit-read-from-string (second (car key)))
     873               (if (null (third param))
     874                   (emit-push-nil)
     875                   (emit-push-t)) ;; we don't need the actual supplied-p symbol
     876               (emit-invokespecial-init +lisp-closure-parameter+
     877                                        (list +lisp-symbol+ +lisp-symbol+
     878                                              +lisp-object+ +lisp-object+))))))
     879      (aload 0) ;; this
     880      (cond ((eq super +lisp-compiled-primitive+)
     881             (emit-constructor-lambda-name lambda-name)
     882             (emit-constructor-lambda-list args)
     883             (emit-invokespecial-init super (lisp-object-arg-types 2)))
     884            ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
     885             (aload req-params-register)
     886             (aload opt-params-register)
     887             (aload key-params-register)
     888             (if keys-p
     889                 (emit-push-t)
     890                 (emit-push-nil-symbol))
     891             (if rest-p
     892                 (emit-push-t)
     893                 (emit-push-nil-symbol))
     894             (if more-keys-p
     895                 (emit-push-t)
     896                 (emit-push-nil-symbol))
     897             (emit-invokespecial-init super
     898                                      (list +lisp-closure-parameter-array+
     899                                            +lisp-closure-parameter-array+
     900                                            +lisp-closure-parameter-array+
     901                                            +lisp-symbol+
     902                                            +lisp-symbol+ +lisp-symbol+)))
     903            (t
     904             (sys::%format t "unhandled superclass ~A for ~A~%"
     905                           super
     906                           (abcl-class-file-class-name class))
     907             (aver nil))))
    910908    method))
    911909
     910(defun make-static-initializer (class)
     911  (let ((*compiler-debug* nil)
     912        (method (make-method :static-initializer
     913                             :void nil :flags '(:public :static))))
     914    ;; We don't normally need to see debugging output for <clinit>.
     915    (with-code-to-method (class method)
     916      (setf (code-max-locals *current-code-attribute*) 0)
     917      (emit 'return)
     918      method)))
    912919
    913920(defvar *source-line-number* nil)
     
    919926The compiler calls this function to indicate it doesn't want to
    920927extend the class any further."
    921   (class-add-method class (make-constructor class))
     928  (with-code-to-method (class (abcl-class-file-constructor class))
     929    (emit 'return))
    922930  (finalize-class-file class)
    923931  (write-class-file class stream))
     
    951959
    952960(defmacro declare-with-hashtable (declared-item hashtable hashtable-var
    953           item-var &body body)
     961                                  item-var &body body)
    954962  `(let* ((,hashtable-var ,hashtable)
    955     (,item-var (gethash1 ,declared-item ,hashtable-var)))
     963          (,item-var (gethash1 ,declared-item ,hashtable-var)))
    956964     (declare (type hash-table ,hashtable-var))
    957965     (unless ,item-var
     
    10871095on the equality indicator in the `serialization-table'.
    10881096
    1089 Code to restore the serialized object is inserted into `*code' or
    1090 `*static-code*' if `*declare-inline*' is non-nil.
     1097Code to restore the serialized object is inserted into the current method or
     1098the constructor if `*declare-inline*' is non-nil.
    10911099"
    10921100  ;; TODO: rewrite to become EMIT-LOAD-EXTERNALIZED-OBJECT which
     
    11181126      (cond
    11191127        ((not *file-compilation*)
    1120          (let ((*code* *static-code*))
     1128         (with-code-to-method
     1129             (*class-file* (abcl-class-file-constructor *class-file*))
    11211130           (remember field-name object)
    11221131           (emit 'ldc (pool-string field-name))
     
    11251134           (when (not (eq field-type +lisp-object+))
    11261135             (emit-checkcast field-type))
    1127            (emit-putstatic *this-class* field-name field-type)
    1128            (setf *static-code* *code*)))
     1136           (emit-putstatic *this-class* field-name field-type)))
    11291137        (*declare-inline*
    11301138         (funcall dispatch-fn object)
    11311139         (emit-putstatic *this-class* field-name field-type))
    11321140        (t
    1133          (let ((*code* *static-code*))
     1141         (with-code-to-method
     1142             (*class-file* (abcl-class-file-constructor *class-file*))
    11341143           (funcall dispatch-fn object)
    1135            (emit-putstatic *this-class* field-name field-type)
    1136            (setf *static-code* *code*))))
     1144           (emit-putstatic *this-class* field-name field-type))))
    11371145
    11381146      (emit-getstatic *this-class* field-name field-type)
     
    11641172                       (declare-object symbol))
    11651173              class *this-class*))
    1166      (let (saved-code)
    1167        (let ((*code* (if *declare-inline* *code* *static-code*)))
    1168          (if (eq class *this-class*)
    1169              (progn ;; generated by the DECLARE-OBJECT*'s above
    1170                (emit-getstatic class name +lisp-object+)
    1171                (emit-checkcast +lisp-symbol+))
    1172              (emit-getstatic class name +lisp-symbol+))
    1173          (emit-invokevirtual +lisp-symbol+
    1174                              (if setf
    1175                                  "getSymbolSetfFunctionOrDie"
    1176                                  "getSymbolFunctionOrDie")
    1177                              nil +lisp-object+)
    1178          ;; make sure we're not cacheing a proxied function
    1179          ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
    1180          (emit-invokevirtual +lisp-object+
    1181                              "resolve" nil +lisp-object+)
    1182          (emit-putstatic *this-class* f +lisp-object+)
    1183          (if *declare-inline*
    1184              (setf saved-code *code*)
    1185              (setf *static-code* *code*))
    1186          (setf (gethash symbol ht) f))
    1187        (when *declare-inline*
    1188          (setf *code* saved-code))
    1189        f))))
     1174     (with-code-to-method (*class-file*
     1175                           (if *declare-inline* *method*
     1176                               (abcl-class-file-constructor *class-file*)))
     1177       (if (eq class *this-class*)
     1178           (progn ;; generated by the DECLARE-OBJECT*'s above
     1179             (emit-getstatic class name +lisp-object+)
     1180             (emit-checkcast +lisp-symbol+))
     1181           (emit-getstatic class name +lisp-symbol+))
     1182       (emit-invokevirtual +lisp-symbol+
     1183                           (if setf
     1184                               "getSymbolSetfFunctionOrDie"
     1185                               "getSymbolFunctionOrDie")
     1186                           nil +lisp-object+)
     1187       ;; make sure we're not cacheing a proxied function
     1188       ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
     1189       (emit-invokevirtual +lisp-object+
     1190                           "resolve" nil +lisp-object+)
     1191       (emit-putstatic *this-class* f +lisp-object+)
     1192       (setf (gethash symbol ht) f))
     1193     f)))
    11901194
    11911195(defknown declare-setf-function (name) string)
     
    11991203   local-function *declared-functions* ht g
    12001204   (setf g (symbol-name (gensym "LFUN")))
    1201    (let* ((class-name (abcl-class-file-class-name
    1202                        (local-function-class-file local-function)))
    1203           (*code* *static-code*))
    1204      ;; fixme *declare-inline*
    1205      (declare-field g +lisp-object+)
    1206      (emit-new class-name)
    1207      (emit 'dup)
    1208      (emit-invokespecial-init class-name '())
    1209      (emit-putstatic *this-class* g +lisp-object+)
    1210      (setf *static-code* *code*)
    1211      (setf (gethash local-function ht) g))))
     1205   (let ((class-name (abcl-class-file-class-name
     1206                      (local-function-class-file local-function))))
     1207     (with-code-to-method
     1208         (*class-file* (abcl-class-file-constructor *class-file*))
     1209       ;; fixme *declare-inline*
     1210       (declare-field g +lisp-object+)
     1211       (emit-new class-name)
     1212       (emit 'dup)
     1213       (emit-invokespecial-init class-name '())
     1214       (emit-putstatic *this-class* g +lisp-object+)
     1215       (setf (gethash local-function ht) g)))))
    12121216
    12131217
     
    12221226  ;;  EMIT-LOAD-EXTERNALIZED-OBJECT, which serializes *and*
    12231227  ;;  emits the right loading code (not just de-serialization anymore)
    1224   (let (saved-code
    1225         (g (symbol-name (gensym "OBJSTR"))))
    1226     (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
    1227            (*code* (if *declare-inline* *code* *static-code*)))
     1228  (let ((g (symbol-name (gensym "OBJSTR")))
     1229        (s (with-output-to-string (stream) (dump-form obj stream))))
     1230    (with-code-to-method
     1231        (*class-file*
     1232         (if *declare-inline* *method*
     1233             (abcl-class-file-constructor *class-file*)))
    12281234      ;; strings may contain evaluated bits which may depend on
    12291235      ;; previous statements
     
    12321238      (emit-invokestatic +lisp+ "readObjectFromString"
    12331239                         (list +java-string+) +lisp-object+)
    1234       (emit-putstatic *this-class* g +lisp-object+)
    1235       (if *declare-inline*
    1236           (setf saved-code *code*)
    1237           (setf *static-code* *code*)))
    1238     (when *declare-inline*
    1239       (setf *code* saved-code))
     1240      (emit-putstatic *this-class* g +lisp-object+))
    12401241    g))
    12411242
    12421243(defun declare-load-time-value (obj)
    12431244  (let ((g (symbol-name (gensym "LTV")))
    1244         saved-code)
    1245     (let* ((s (with-output-to-string (stream) (dump-form obj stream)))
    1246            (*code* (if *declare-inline* *code* *static-code*)))
    1247       ;; The readObjectFromString call may require evaluation of
    1248       ;; lisp code in the string (think #.() syntax), of which the outcome
    1249       ;; may depend on something which was declared inline
    1250       (declare-field g +lisp-object+)
    1251       (emit 'ldc (pool-string s))
    1252       (emit-invokestatic +lisp+ "readObjectFromString"
    1253                          (list +java-string+) +lisp-object+)
    1254       (emit-invokestatic +lisp+ "loadTimeValue"
    1255                          (lisp-object-arg-types 1) +lisp-object+)
    1256       (emit-putstatic *this-class* g +lisp-object+)
    1257       (if *declare-inline*
    1258           (setf saved-code *code*)
    1259           (setf *static-code* *code*)))
    1260     (when *declare-inline*
    1261       (setf *code* saved-code))
    1262     g))
     1245        (s (with-output-to-string (stream) (dump-form obj stream))))
     1246     (with-code-to-method
     1247         (*class-file*
     1248          (if *declare-inline* *method*
     1249              (abcl-class-file-constructor *class-file*)))
     1250       ;; The readObjectFromString call may require evaluation of
     1251       ;; lisp code in the string (think #.() syntax), of which the outcome
     1252       ;; may depend on something which was declared inline
     1253       (declare-field g +lisp-object+)
     1254       (emit 'ldc (pool-string s))
     1255       (emit-invokestatic +lisp+ "readObjectFromString"
     1256                          (list +java-string+) +lisp-object+)
     1257       (emit-invokestatic +lisp+ "loadTimeValue"
     1258                          (lisp-object-arg-types 1) +lisp-object+)
     1259       (emit-putstatic *this-class* g +lisp-object+))
     1260     g))
    12631261
    12641262(declaim (ftype (function (t) string) declare-object))
     
    12711269    ;; fixme *declare-inline*?
    12721270    (remember g obj)
    1273     (let* ((*code* *static-code*))
     1271    (with-code-to-method
     1272        (*class-file* (abcl-class-file-constructor *class-file*))
    12741273      (declare-field g +lisp-object+)
    12751274      (emit 'ldc (pool-string g))
    12761275      (emit-invokestatic +lisp+ "recall"
    12771276                         (list +java-string+) +lisp-object+)
    1278       (emit-putstatic *this-class* g +lisp-object+)
    1279       (setf *static-code* *code*)
    1280       g)))
     1277      (emit-putstatic *this-class* g +lisp-object+))
     1278    g))
    12811279
    12821280(defknown compile-constant (t t t) t)
     
    14061404(defmacro define-inlined-function (name params preamble-and-test &body body)
    14071405  (let* ((test (second preamble-and-test))
    1408   (preamble (and test (first preamble-and-test)))
    1409   (test (or test (first preamble-and-test))))
     1406        (preamble (and test (first preamble-and-test)))
     1407        (test (or test (first preamble-and-test))))
    14101408    `(defun ,name ,params
    14111409       ,preamble
    14121410       (unless ,test
    1413   (compile-function-call ,@params)
    1414   (return-from ,name))
     1411        (compile-function-call ,@params)
     1412        (return-from ,name))
    14151413       ,@body)))
    14161414
     
    14241422    (cond ((and boxed-method-name unboxed-method-name)
    14251423           (let ((arg (cadr form)))
    1426        (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     1424             (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    14271425             (ecase representation
    14281426               (:boolean
     
    14621460    (let ((s (gethash1 op (the hash-table *unary-operators*))))
    14631461      (cond (s
    1464        (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     1462             (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    14651463             (emit-invoke-method s target representation)
    14661464             t)
     
    14981496        (arg2 (cadr args)))
    14991497    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1500                  arg2 'stack nil)
     1498                                               arg2 'stack nil)
    15011499    (emit-invokevirtual +lisp-object+ op
    1502       (lisp-object-arg-types 1) +lisp-object+)
     1500                        (lisp-object-arg-types 1) +lisp-object+)
    15031501    (fix-boxing representation nil)
    15041502    (emit-move-from-stack target representation)))
     
    15511549         (arg2 (%cadr args)))
    15521550    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1553                  arg2 'stack nil)
     1551                                               arg2 'stack nil)
    15541552     (let ((LABEL1 (gensym))
    15551553           (LABEL2 (gensym)))
     
    15771575    (cond ((and (fixnum-type-p type1)
    15781576                (fixnum-type-p type2))
    1579      (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    1580                   arg2 'stack :int)
     1577           (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     1578                                                      arg2 'stack :int)
    15811579           (let ((label1 (gensym))
    15821580                 (label2 (gensym)))
     
    15881586             (label label2)))
    15891587          ((fixnum-type-p type2)
    1590      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1591                   arg2 'stack :int)
    1592      (emit-ifne-for-eql representation '(:int)))
     1588           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     1589                                                      arg2 'stack :int)
     1590           (emit-ifne-for-eql representation '(:int)))
    15931591          ((fixnum-type-p type1)
    1594      (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    1595                   arg2 'stack nil)
     1592           (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     1593                                                      arg2 'stack nil)
    15961594           (emit 'swap)
    1597      (emit-ifne-for-eql representation '(:int)))
     1595           (emit-ifne-for-eql representation '(:int)))
    15981596          ((eq type2 'CHARACTER)
    1599      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1600                   arg2 'stack :char)
    1601      (emit-ifne-for-eql representation '(:char)))
     1597           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     1598                                                      arg2 'stack :char)
     1599           (emit-ifne-for-eql representation '(:char)))
    16021600          ((eq type1 'CHARACTER)
    1603      (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    1604                   arg2 'stack nil)
     1601           (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
     1602                                                      arg2 'stack nil)
    16051603           (emit 'swap)
    1606      (emit-ifne-for-eql representation '(:char)))
     1604           (emit-ifne-for-eql representation '(:char)))
    16071605          (t
    1608      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1609                   arg2 'stack nil)
     1606           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     1607                                                      arg2 'stack nil)
    16101608           (ecase representation
    16111609             (:boolean
     
    16951693             (arg2 (second args))
    16961694             (arg3 (third args)))
    1697   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    1698                 arg2 'stack nil
    1699                 arg3 'stack nil)
     1695        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     1696                                                    arg2 'stack nil
     1697                                                    arg3 'stack nil)
    17001698         (emit-invokestatic +lisp+ "getf"
    17011699                            (lisp-object-arg-types 3) +lisp-object+)
     
    20622060                (let ((LABEL1 (gensym))
    20632061                      (LABEL2 (gensym)))
    2064       (compile-forms-and-maybe-emit-clear-values
     2062                  (compile-forms-and-maybe-emit-clear-values
    20652063                          arg1 'stack common-rep
    20662064                          arg2 'stack common-rep)
     
    20742072                (return-from p2-numeric-comparison))
    20752073               ((fixnump arg2)
    2076     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     2074                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    20772075                (emit-push-constant-int arg2)
    20782076                (emit-invokevirtual +lisp-object+
     
    22412239    `(let ((,tmpform ,form))
    22422240       (when (check-arg-count ,tmpform 1)
    2243   (let ((arg (%cadr ,tmpform)))
    2244      (cond ((fixnum-type-p (derive-compiler-type arg))
    2245       (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    2246       ,@instructions)
    2247     (t
    2248       (p2-test-predicate ,tmpform ,predicate))))))))
     2241        (let ((arg (%cadr ,tmpform)))
     2242           (cond ((fixnum-type-p (derive-compiler-type arg))
     2243                  (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
     2244                  ,@instructions)
     2245                (t
     2246                  (p2-test-predicate ,tmpform ,predicate))))))))
    22492247
    22502248(defun p2-test-evenp (form)
    22512249  (p2-test-integer-predicate form "evenp"
    2252            (emit-push-constant-int 1)
    2253            (emit 'iand)
    2254            'ifne))
     2250                             (emit-push-constant-int 1)
     2251                             (emit 'iand)
     2252                             'ifne))
    22552253
    22562254(defun p2-test-oddp (form)
    22572255  (p2-test-integer-predicate form "oddp"
    2258            (emit-push-constant-int 1)
    2259            (emit 'iand)
    2260            'ifeq))
     2256                             (emit-push-constant-int 1)
     2257                             (emit 'iand)
     2258                             'ifeq))
    22612259
    22622260(defun p2-test-floatp (form)
     
    22712269           (arg-type (derive-compiler-type arg)))
    22722270      (cond ((memq arg-type '(CONS LIST NULL))
    2273        (compile-forms-and-maybe-emit-clear-values arg nil nil)
     2271             (compile-forms-and-maybe-emit-clear-values arg nil nil)
    22742272             :consequent)
    22752273            ((neq arg-type t)
    2276        (compile-forms-and-maybe-emit-clear-values arg nil nil)
     2274             (compile-forms-and-maybe-emit-clear-values arg nil nil)
    22772275             :alternate)
    22782276            (t
     
    23412339         :alternate)
    23422340        ((eq (derive-compiler-type test-form) 'BOOLEAN)
    2343   (compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean)
     2341        (compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean)
    23442342         'ifeq)
    23452343        (t
    2346   (compile-forms-and-maybe-emit-clear-values test-form 'stack nil)
     2344        (compile-forms-and-maybe-emit-clear-values test-form 'stack nil)
    23472345         (emit-push-nil)
    23482346         'if_acmpeq)))
     
    23752373           (arg2 (%caddr form)))
    23762374      (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2377             arg2 'stack :char)
     2375                                                arg2 'stack :char)
    23782376      'if_icmpne)))
    23792377
     
    23832381          (arg2 (%caddr form)))
    23842382      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2385             arg2 'stack nil)
     2383                                                arg2 'stack nil)
    23862384     'if_acmpne)))
    23872385
     
    24122410           (type2 (derive-compiler-type arg2)))
    24132411      (cond ((and (fixnum-type-p type1) (fixnum-type-p type2))
    2414        (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2415               arg2 'stack :int)
     2412             (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     2413                                                        arg2 'stack :int)
    24162414             'if_icmpne)
    24172415            ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER))
    2418        (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2419               arg2 'stack :char)
     2416             (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
     2417                                                        arg2 'stack :char)
    24202418             'if_icmpne)
    24212419            ((eq type2 'CHARACTER)
    2422        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2423               arg2 'stack :char)
     2420             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2421                                                        arg2 'stack :char)
    24242422             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    24252423             'ifeq)
    24262424            ((eq type1 'CHARACTER)
    2427        (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    2428               arg2 'stack nil)
     2425             (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
     2426                                                        arg2 'stack nil)
    24292427             (emit 'swap)
    24302428             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    24312429             'ifeq)
    24322430            ((fixnum-type-p type2)
    2433        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2434               arg2 'stack :int)
     2431             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2432                                                        arg2 'stack :int)
    24352433             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    24362434             'ifeq)
    24372435            ((fixnum-type-p type1)
    2438        (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2439               arg2 'stack nil)
     2436             (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     2437                                                        arg2 'stack nil)
    24402438             (emit 'swap)
    24412439             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    24422440             'ifeq)
    24432441            (t
    2444        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2445               arg2 'stack nil)
     2442             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2443                                                        arg2 'stack nil)
    24462444             (emit-invokevirtual +lisp-object+ "eql"
    24472445                                 (lisp-object-arg-types 1) :boolean)
     
    24572455           (arg2 (%caddr form)))
    24582456      (cond ((fixnum-type-p (derive-compiler-type arg2))
    2459        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2460               arg2 'stack :int)
     2457             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2458                                                        arg2 'stack :int)
    24612459             (emit-invokevirtual +lisp-object+
    24622460                                 translated-op
    24632461                                 '(:int) :boolean))
    24642462            (t
    2465        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2466               arg2 'stack nil)
     2463             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2464                                                        arg2 'stack nil)
    24672465             (emit-invokevirtual +lisp-object+
    24682466                                 translated-op
     
    24752473          (arg2 (%caddr form)))
    24762474      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2477             arg2 'stack nil)
     2475                                                arg2 'stack nil)
    24782476      (emit-invokevirtual +lisp-object+ "typep"
    24792477                          (lisp-object-arg-types 1) +lisp-object+)
     
    24862484          (arg2 (%caddr form)))
    24872485      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2488             arg2 'stack nil)
     2486                                                arg2 'stack nil)
    24892487      (emit-invokestatic +lisp+ "memq"
    24902488                         (lisp-object-arg-types 2) :boolean)
     
    24962494          (arg2 (%caddr form)))
    24972495      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2498             arg2 'stack nil)
     2496                                                arg2 'stack nil)
    24992497      (emit-invokestatic +lisp+ "memql"
    25002498                         (lisp-object-arg-types 2) :boolean)
     
    25112509            ((and (fixnum-type-p type1)
    25122510                  (fixnum-type-p type2))
    2513        (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2514               arg2 'stack :int)
     2511             (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     2512                                                        arg2 'stack :int)
    25152513             'if_icmpeq)
    25162514            ((fixnum-type-p type2)
    2517        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2518               arg2 'stack :int)
     2515             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2516                                                        arg2 'stack :int)
    25192517             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    25202518             'ifeq)
     
    25222520             ;; FIXME Compile the args in reverse order and avoid the swap if
    25232521             ;; either arg is a fixnum or a lexical variable.
    2524        (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2525               arg2 'stack nil)
     2522             (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     2523                                                        arg2 'stack nil)
    25262524             (emit 'swap)
    25272525             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    25282526             'ifeq)
    25292527            (t
    2530        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2531               arg2 'stack nil)
     2528             (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2529                                                        arg2 'stack nil)
    25322530             (emit-invokevirtual +lisp-object+ "isNotEqualTo"
    25332531                                 (lisp-object-arg-types 1) :boolean)
     
    25462544               (if (funcall op arg1 arg2) :consequent :alternate))
    25472545              ((and (fixnum-type-p type1) (fixnum-type-p type2))
    2548          (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2549                 arg2 'stack :int)
     2546               (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     2547                                                          arg2 'stack :int)
    25502548               (ecase op
    25512549                 (<  'if_icmpge)
     
    25552553                 (=  'if_icmpne)))
    25562554              ((and (java-long-type-p type1) (java-long-type-p type2))
    2557          (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    2558                 arg2 'stack :long)
     2555               (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     2556                                                          arg2 'stack :long)
    25592557               (emit 'lcmp)
    25602558               (ecase op
     
    25652563                 (=  'ifne)))
    25662564              ((fixnum-type-p type2)
    2567          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2568                 arg2 'stack :int)
     2565               (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2566                                                          arg2 'stack :int)
    25692567               (emit-invokevirtual +lisp-object+
    25702568                                   (ecase op
     
    25792577               ;; FIXME We can compile the args in reverse order and avoid
    25802578               ;; the swap if either arg is a fixnum or a lexical variable.
    2581          (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    2582                 arg2 'stack nil)
     2579               (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     2580                                                          arg2 'stack nil)
    25832581               (emit 'swap)
    25842582               (emit-invokevirtual +lisp-object+
     
    25922590               'ifeq)
    25932591              (t
    2594          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2595                 arg2 'stack nil)
     2592               (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2593                                                          arg2 'stack nil)
    25962594               (emit-invokevirtual +lisp-object+
    25972595                                   (ecase op
     
    26242622                  (let ((arg1 (second arg))
    26252623                        (arg2 (third arg)))
    2626         (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    2627                      arg2 'stack nil)
     2624                    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     2625                                                               arg2 'stack nil)
    26282626                    (emit 'if_acmpeq LABEL1)))
    26292627                 ((eq (derive-compiler-type arg) 'BOOLEAN)
    2630       (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
     2628                  (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
    26312629                  (emit 'ifne LABEL1))
    26322630                 (t
    2633       (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     2631                  (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    26342632                  (emit-push-nil)
    26352633                  (emit 'if_acmpne LABEL1))))
     
    26562654        (t
    26572655         (dolist (arg args)
    2658      (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
    2659      (emit 'ifeq LABEL1)
    2660            )
     2656           (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
     2657           (emit 'ifeq LABEL1))
    26612658         (compile-form consequent target representation)
    26622659         (emit 'goto LABEL2)
     
    26822679           (let ((type (derive-compiler-type arg)))
    26832680             (cond ((eq type 'BOOLEAN)
    2684         (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
     2681                    (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
    26852682                    (emit 'ifeq LABEL1))
    26862683                   (t
    2687         (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     2684                    (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    26882685                    (emit-push-nil)
    26892686                    (emit 'if_acmpeq LABEL1)))))
     
    27082705           (compile-form consequent target representation))
    27092706          ((equal (derive-compiler-type test) +true-type+)
    2710      (compile-forms-and-maybe-emit-clear-values test nil nil)
     2707           (compile-forms-and-maybe-emit-clear-values test nil nil)
    27112708           (compile-form consequent target representation))
    27122709          ((and (consp test) (eq (car test) 'OR))
     
    29082905(defun restore-environment-and-make-handler (register label-START)
    29092906  (let ((label-END (gensym))
    2910   (label-EXIT (gensym)))
     2907        (label-EXIT (gensym)))
    29112908    (emit 'goto label-EXIT)
    29122909    (label label-END)
     
    29452942    (aver (= (length vars) (length variables)))
    29462943    (cond ((= (length vars) 1)
    2947      (compile-forms-and-maybe-emit-clear-values (third form) 'stack nil)
     2944           (compile-forms-and-maybe-emit-clear-values (third form) 'stack nil)
    29482945           (compile-binding (car variables)))
    29492946          (t
     
    34813478                 (enclosed-by-environment-setting-block-p tag-block))
    34823479        ;; If there's a dynamic environment to restore, do it.
    3483   (restore-dynamic-environment (environment-register-to-restore tag-block)))
     3480        (restore-dynamic-environment (environment-register-to-restore tag-block)))
    34843481      (maybe-generate-interrupt-check)
    34853482      (emit 'goto (tag-label tag))
     
    35253522  (let ((arg (%cadr form)))
    35263523    (cond ((null target)
    3527      (compile-forms-and-maybe-emit-clear-values arg nil nil))
     3524           (compile-forms-and-maybe-emit-clear-values arg nil nil))
    35283525          (t
    3529      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     3526           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    35303527           (emit-instanceof java-class)
    35313528           (convert-representation :boolean representation)
     
    36783675           (emit-invoke-method "cadr" target representation))
    36793676          (t
    3680      (emit-car/cdr arg target representation "car")))))
     3677           (emit-car/cdr arg target representation "car")))))
    36813678
    36823679(define-inlined-function p2-cdr (form target representation)
     
    36933690         (arg2 (%cadr args)))
    36943691    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    3695                  arg2 'stack nil))
     3692                                               arg2 'stack nil))
    36963693  (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
    36973694  (emit-move-from-stack target))
     
    38433840    (when (compiland-closure-register parent)
    38443841      (dformat t "(compiland-closure-register parent) = ~S~%"
    3845          (compiland-closure-register parent))
     3842               (compiland-closure-register parent))
    38463843      (emit-checkcast +lisp-compiled-closure+)
    38473844      (duplicate-closure-array parent)
    38483845      (emit-invokestatic +lisp+ "makeCompiledClosure"
    3849       (list +lisp-object+ +closure-binding-array+)
    3850       +lisp-object+)))
     3846                        (list +lisp-object+ +closure-binding-array+)
     3847                        +lisp-object+)))
    38513848  (emit-move-to-variable (local-function-variable local-function)))
    38523849
     
    40034000                     g +lisp-object+))))) ; Stack: template-function
    40044001         ((and (member name *functions-defined-in-current-file* :test #'equal)
    4005          (not (notinline-p name)))
     4002               (not (notinline-p name)))
    40064003          (emit-getstatic *this-class*
    40074004                (declare-setf-function name) +lisp-object+)
     
    40844081          ((and (fixnum-type-p type1)
    40854082                low2 high2 (<= -31 low2 high2 0)) ; Negative shift.
    4086      (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4087                   arg2 'stack :int)
     4083           (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4084                                                      arg2 'stack :int)
    40884085           (emit 'ineg)
    40894086           (emit 'ishr)
     
    40944091                       (java-long-type-p type1)
    40954092                       (java-long-type-p result-type))
    4096       (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4097                    arg2 'stack :int)
     4093                  (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     4094                                                             arg2 'stack :int)
    40984095                  (emit 'lshl)
    40994096                  (convert-representation :long representation))
     
    41014098                       (java-long-type-p type1)
    41024099                       (java-long-type-p result-type))
    4103       (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4104                    arg2 'stack :int)
     4100                  (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     4101                                                             arg2 'stack :int)
    41054102                  (emit 'ineg)
    41064103                  (emit 'lshr)
    41074104                  (convert-representation :long representation))
    41084105                 (t
    4109       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4110                    arg2 'stack :int)
     4106                  (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4107                                                             arg2 'stack :int)
    41114108                  (emit-invokevirtual +lisp-object+ "ash" '(:int) +lisp-object+)
    41124109                  (fix-boxing representation result-type)))
     
    41284125                (compile-constant (logand arg1 arg2) target representation))
    41294126               ((and (integer-type-p type1) (eql arg2 0))
    4130     (compile-forms-and-maybe-emit-clear-values arg1 nil nil)
     4127                (compile-forms-and-maybe-emit-clear-values arg1 nil nil)
    41314128                (compile-constant 0 target representation))
    41324129               ((eql (fixnum-constant-value type1) -1)
    4133     (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    4134                  arg2 target representation))
     4130                (compile-forms-and-maybe-emit-clear-values arg1 nil nil
     4131                                                           arg2 target representation))
    41354132               ((eql (fixnum-constant-value type2) -1)
    4136     (compile-forms-and-maybe-emit-clear-values arg1 target representation
    4137                  arg2 nil nil))
     4133                (compile-forms-and-maybe-emit-clear-values arg1 target representation
     4134                                                           arg2 nil nil))
    41384135               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    41394136                ;; Both arguments are fixnums.
    4140     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4141                  arg2 'stack :int)
     4137                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4138                                                           arg2 'stack :int)
    41424139                (emit 'iand)
    41434140                (convert-representation :int representation)
     
    41484145                         (compiler-subtypep type2 'unsigned-byte)))
    41494146                ;; One of the arguments is a positive fixnum.
    4150     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4151                  arg2 'stack :int)
     4147                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4148                                                           arg2 'stack :int)
    41524149                (emit 'iand)
    41534150                (convert-representation :int representation)
     
    41554152               ((and (java-long-type-p type1) (java-long-type-p type2))
    41564153                ;; Both arguments are longs.
    4157     (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4158                  arg2 'stack :long)
     4154                (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     4155                                                           arg2 'stack :long)
    41594156                (emit 'land)
    41604157                (convert-representation :long representation)
     
    41654162                         (compiler-subtypep type2 'unsigned-byte)))
    41664163                ;; One of the arguments is a positive long.
    4167     (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4168                  arg2 'stack :long)
     4164                (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     4165                                                           arg2 'stack :long)
    41694166                (emit 'land)
    41704167                (convert-representation :long representation)
    41714168                (emit-move-from-stack target representation))
    41724169               ((fixnum-type-p type2)
    4173     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4174                  arg2 'stack :int)
     4170                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4171                                                           arg2 'stack :int)
    41754172                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
    41764173                (fix-boxing representation result-type)
     
    41784175               ((fixnum-type-p type1)
    41794176                ;; arg1 is a fixnum, but arg2 is not
    4180     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4181                  arg2 'stack nil)
     4177                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4178                                                           arg2 'stack nil)
    41824179                ;; swap args
    41834180                (emit 'swap)
     
    41864183                (emit-move-from-stack target representation))
    41874184               (t
    4188     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4189                  arg2 'stack nil)
     4185                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4186                                                           arg2 'stack nil)
    41904187                (emit-invokevirtual +lisp-object+ "LOGAND"
    41914188                                    (lisp-object-arg-types 1) +lisp-object+)
     
    42034200      (1
    42044201       (let ((arg (%car args)))
    4205   (compile-forms-and-maybe-emit-clear-values arg target representation)))
     4202        (compile-forms-and-maybe-emit-clear-values arg target representation)))
    42064203      (2
    42074204       (let* ((arg1 (%car args))
     
    42184215               result-type (derive-compiler-type form))
    42194216         (cond ((and (fixnum-constant-value type1) (fixnum-constant-value type2))
    4220     (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    4221                  arg2 nil nil)
     4217                (compile-forms-and-maybe-emit-clear-values arg1 nil nil
     4218                                                           arg2 nil nil)
    42224219                (compile-constant (logior (fixnum-constant-value type1)
    42234220                                          (fixnum-constant-value type2))
    42244221                                  target representation))
    42254222               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4226     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4227                  arg2 'stack :int)
     4223                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4224                                                           arg2 'stack :int)
    42284225                (emit 'ior)
    42294226                (convert-representation :int representation)
    42304227                (emit-move-from-stack target representation))
    42314228               ((and (eql (fixnum-constant-value type1) 0) (< *safety* 3))
    4232     (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    4233                  arg2 target representation))
     4229                (compile-forms-and-maybe-emit-clear-values arg1 nil nil
     4230                                                           arg2 target representation))
    42344231               ((and (eql (fixnum-constant-value type2) 0) (< *safety* 3))
    4235     (compile-forms-and-maybe-emit-clear-values arg1 target representation
    4236                  arg2 nil nil))
     4232                (compile-forms-and-maybe-emit-clear-values arg1 target representation
     4233                                                           arg2 nil nil))
    42374234               ((or (eq representation :long)
    42384235                    (and (java-long-type-p type1) (java-long-type-p type2)))
    4239     (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4240                  arg2 'stack :long)
     4236                (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     4237                                                           arg2 'stack :long)
    42414238                (emit 'lor)
    42424239                (convert-representation :long representation)
    42434240                (emit-move-from-stack target representation))
    42444241               ((fixnum-type-p type2)
    4245     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4246                  arg2 'stack :int)
     4242                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4243                                                           arg2 'stack :int)
    42474244                (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
    42484245                (fix-boxing representation result-type)
     
    42504247               ((fixnum-type-p type1)
    42514248                ;; arg1 is of fixnum type, but arg2 is not
    4252     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4253                  arg2 'stack nil)
     4249                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4250                                                           arg2 'stack nil)
    42544251                ;; swap args
    42554252                (emit 'swap)
     
    42584255                (emit-move-from-stack target representation))
    42594256               (t
    4260     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4261                  arg2 'stack nil)
     4257                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4258                                                           arg2 'stack nil)
    42624259                (emit-invokevirtual +lisp-object+ "LOGIOR"
    42634260                                    (lisp-object-arg-types 1) +lisp-object+)
     
    42784275      (1
    42794276       (let ((arg (%car args)))
    4280   (compile-forms-and-maybe-emit-clear-values arg target representation)))
     4277        (compile-forms-and-maybe-emit-clear-values arg target representation)))
    42814278      (2
    42824279       (let* ((arg1 (%car args))
     
    42934290               result-type (derive-compiler-type form))
    42944291         (cond ((eq representation :int)
    4295     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4296                  arg2 'stack :int)
     4292                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4293                                                           arg2 'stack :int)
    42974294                (emit 'ixor))
    42984295               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4299     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4300                  arg2 'stack :int)
     4296                (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4297                                                           arg2 'stack :int)
    43014298                (emit 'ixor)
    43024299                (convert-representation :int representation))
    43034300               ((and (java-long-type-p type1) (java-long-type-p type2))
    4304     (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
    4305                  arg2 'stack :long)
     4301                (compile-forms-and-maybe-emit-clear-values arg1 'stack :long
     4302                                                           arg2 'stack :long)
    43064303                (emit 'lxor)
    43074304                (convert-representation :long representation))
    43084305               ((fixnum-type-p type2)
    4309     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4310                  arg2 'stack :int)
     4306                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4307                                                           arg2 'stack :int)
    43114308                (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+)
    43124309                (fix-boxing representation result-type))
    43134310               (t
    4314     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4315                  arg2 'stack nil)
     4311                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4312                                                           arg2 'stack nil)
    43164313                (emit-invokevirtual +lisp-object+ "LOGXOR"
    43174314                                    (lisp-object-arg-types 1) +lisp-object+)
     
    43284325  (cond ((and (fixnum-type-p (derive-compiler-type form)))
    43294326         (let ((arg (%cadr form)))
    4330      (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
     4327           (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    43314328           (emit 'iconst_m1)
    43324329           (emit 'ixor)
     
    43354332        (t
    43364333         (let ((arg (%cadr form)))
    4337      (compile-forms-and-maybe-emit-clear-values arg 'stack nil))
     4334           (compile-forms-and-maybe-emit-clear-values arg 'stack nil))
    43384335         (emit-invokevirtual +lisp-object+ "LOGNOT" nil +lisp-object+)
    43394336         (fix-boxing representation nil)
     
    43564353    ;; need an unboxed fixnum result.
    43574354    (cond ((eql size 0)
    4358      (compile-forms-and-maybe-emit-clear-values size-arg nil nil
    4359                   position-arg nil nil
    4360                   arg3 nil nil)
     4355           (compile-forms-and-maybe-emit-clear-values size-arg nil nil
     4356                                                      position-arg nil nil
     4357                                                      arg3 nil nil)
    43614358           (compile-constant 0 target representation))
    43624359          ((and size position)
    43634360           (cond ((<= (+ position size) 31)
    4364       (compile-forms-and-maybe-emit-clear-values size-arg nil nil
    4365                    position-arg nil nil
    4366                    arg3 'stack :int)
     4361                  (compile-forms-and-maybe-emit-clear-values size-arg nil nil
     4362                                                             position-arg nil nil
     4363                                                             arg3 'stack :int)
    43674364                  (unless (zerop position)
    43684365                    (emit-push-constant-int position)
     
    43734370                  (emit-move-from-stack target representation))
    43744371                 ((<= (+ position size) 63)
    4375       (compile-forms-and-maybe-emit-clear-values size-arg nil nil
    4376                    position-arg nil nil
    4377                    arg3 'stack :long)
     4372                  (compile-forms-and-maybe-emit-clear-values size-arg nil nil
     4373                                                             position-arg nil nil
     4374                                                             arg3 'stack :long)
    43784375                  (unless (zerop position)
    43794376                    (emit-push-constant-int position)
     
    43904387                  (emit-move-from-stack target representation))
    43914388                 (t
    4392       (compile-forms-and-maybe-emit-clear-values arg3 'stack nil)
     4389                  (compile-forms-and-maybe-emit-clear-values arg3 'stack nil)
    43934390                  (emit-push-constant-int size)
    43944391                  (emit-push-constant-int position)
     
    43984395          ((and (fixnum-type-p size-type)
    43994396                (fixnum-type-p position-type))
    4400      (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int
    4401                   position-arg 'stack :int
    4402                   arg3 'stack nil)
     4397           (compile-forms-and-maybe-emit-clear-values size-arg 'stack :int
     4398                                                      position-arg 'stack :int
     4399                                                      arg3 'stack nil)
    44034400           (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved
    44044401           (emit 'pop)
     
    44204417                (fixnum-type-p type1)
    44214418                (fixnum-type-p type2))
    4422      (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    4423                   arg2 'stack :int)
     4419           (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     4420                                                      arg2 'stack :int)
    44244421           (emit-invokestatic +lisp+ "mod" '(:int :int) :int)
    44254422           (emit-move-from-stack target representation))
    44264423          ((fixnum-type-p type2)
    4427      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4428                   arg2 'stack :int)
     4424           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4425                                                      arg2 'stack :int)
    44294426           (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+)
    44304427           (fix-boxing representation nil) ; FIXME use derived result type
    44314428           (emit-move-from-stack target representation))
    44324429          (t
    4433      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4434                   arg2 'stack nil)
     4430           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4431                                                      arg2 'stack nil)
    44354432           (emit-invokevirtual +lisp-object+ "MOD"
    44364433                               (lisp-object-arg-types 1) +lisp-object+)
     
    44454442         (type (derive-compiler-type arg)))
    44464443    (cond ((fixnum-type-p type)
    4447      (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
     4444           (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    44484445           (let ((LABEL1 (gensym))
    44494446                 (LABEL2 (gensym)))
     
    44644461             (emit-move-from-stack target representation)))
    44654462          ((java-long-type-p type)
    4466      (compile-forms-and-maybe-emit-clear-values arg 'stack :long)
     4463           (compile-forms-and-maybe-emit-clear-values arg 'stack :long)
    44674464           (emit 'lconst_0)
    44684465           (emit 'lcmp)
     
    44774474             (emit-move-from-stack target representation)))
    44784475          (t
    4479      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     4476           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    44804477           (emit-invoke-method "ZEROP" target representation)))))
    44814478
     
    45074504      (2
    45084505       (let ((arg2 (second args)))
    4509   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4510                 arg2 'stack :boolean)
     4506        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     4507                                                    arg2 'stack :boolean)
    45114508         (emit-invokestatic +lisp-class+ "findClass"
    45124509                            (list +lisp-object+ :boolean) +lisp-object+)
     
    45254522      (2
    45264523       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4527               arg2 'stack nil)
     4524                                                  arg2 'stack nil)
    45284525       (emit 'swap)
    45294526       (cond (target
     
    45454542         (arg2 (second args)))
    45464543    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4547                  arg2 'stack nil)
     4544                                               arg2 'stack nil)
    45484545    (emit-invokevirtual +lisp-object+ "SLOT_VALUE"
    45494546                        (lisp-object-arg-types 1) +lisp-object+)
     
    45624559         (value-register (when target (allocate-register))))
    45634560    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    4564                  arg2 'stack nil
    4565                  arg3 'stack nil)
     4561                                               arg2 'stack nil
     4562                                               arg3 'stack nil)
    45664563    (when value-register
    45674564      (emit 'dup)
     
    45794576  (let ((arg (%cadr form)))
    45804577    (cond ((eq (derive-compiler-type arg) 'STREAM)
    4581      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     4578           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    45824579           (emit-checkcast +lisp-stream+)
    45834580           (emit-invokevirtual +lisp-stream+ "getElementType"
     
    46264623              (type1 (derive-compiler-type arg1)))
    46274624         (cond ((compiler-subtypep type1 'stream)
    4628     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     4625                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    46294626                (emit-checkcast +lisp-stream+)
    46304627                (emit-push-constant-int 1)
     
    46404637              (arg2 (%cadr args)))
    46414638         (cond ((and (compiler-subtypep type1 'stream) (null arg2))
    4642     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     4639                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    46434640                (emit-checkcast +lisp-stream+)
    46444641                (emit-push-constant-int 0)
     
    49344931(defun derive-compiler-types (args op)
    49354932  (flet ((combine (x y)
    4936       (derive-type-numeric-op op x y)))
     4933           (derive-type-numeric-op op x y)))
    49374934    (reduce #'combine (cdr args) :key #'derive-compiler-type
    4938       :initial-value (derive-compiler-type (car args)))))
     4935            :initial-value (derive-compiler-type (car args)))))
    49394936
    49404937(defknown derive-type-minus (t) t)
     
    52265223(defun cons-for-list/list* (form target representation &optional list-star-p)
    52275224  (let* ((args (cdr form))
    5228   (length (length args))
    5229   (cons-heads (if list-star-p
    5230       (butlast args 1)
    5231            args)))
     5225        (length (length args))
     5226        (cons-heads (if list-star-p
     5227                        (butlast args 1)
     5228                         args)))
    52325229    (cond ((>= 4 length 1)
    5233      (dolist (cons-head cons-heads)
    5234        (emit-new +lisp-cons+)
    5235        (emit 'dup)
    5236        (compile-form cons-head 'stack nil))
    5237      (if list-star-p
    5238          (compile-form (first (last args)) 'stack nil)
    5239        (progn
    5240          (emit-invokespecial-init
    5241     +lisp-cons+ (lisp-object-arg-types 1))
    5242          (pop cons-heads))) ; we've handled one of the args, so remove it
    5243      (dolist (cons-head cons-heads)
    5244        (declare (ignore cons-head))
    5245        (emit-invokespecial-init
    5246         +lisp-cons+ (lisp-object-arg-types 2)))
    5247      (if list-star-p
    5248          (progn
    5249      (apply #'maybe-emit-clear-values args)
    5250      (emit-move-from-stack target representation))
    5251        (progn
    5252          (unless (every 'single-valued-p args)
    5253      (emit-clear-values))
    5254          (emit-move-from-stack target))))
    5255     (t
    5256      (compile-function-call form target representation)))))
    5257      
    5258  
     5230           (dolist (cons-head cons-heads)
     5231             (emit-new +lisp-cons+)
     5232             (emit 'dup)
     5233             (compile-form cons-head 'stack nil))
     5234           (if list-star-p
     5235               (compile-form (first (last args)) 'stack nil)
     5236               (progn
     5237                 (emit-invokespecial-init
     5238                  +lisp-cons+ (lisp-object-arg-types 1))
     5239                 (pop cons-heads))) ; we've handled one of the args, so remove it
     5240           (dolist (cons-head cons-heads)
     5241             (declare (ignore cons-head))
     5242             (emit-invokespecial-init
     5243              +lisp-cons+ (lisp-object-arg-types 2)))
     5244           (if list-star-p
     5245               (progn
     5246                 (apply #'maybe-emit-clear-values args)
     5247                 (emit-move-from-stack target representation))
     5248               (progn
     5249                 (unless (every 'single-valued-p args)
     5250                   (emit-clear-values))
     5251                 (emit-move-from-stack target))))
     5252          (t
     5253           (compile-function-call form target representation)))))
    52595254
    52605255(defun p2-list (form target representation)
     
    52695264        (list-form (third form)))
    52705265    (compile-forms-and-maybe-emit-clear-values index-form 'stack :int
    5271                  list-form 'stack nil)
     5266                                               list-form 'stack nil)
    52725267    (emit 'swap)
    52735268    (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)
     
    53065301                       (sys::format t "p2-times: unsupported rep case"))))
    53075302              (convert-representation result-rep representation)
    5308         (emit-move-from-stack target representation))
     5303              (emit-move-from-stack target representation))
    53095304             ((fixnump arg2)
    5310         (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     5305              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    53115306              (emit-push-int arg2)
    53125307              (emit-invokevirtual +lisp-object+ "multiplyBy" '(:int) +lisp-object+)
     
    53935388              (compile-constant (+ arg1 arg2) target representation))
    53945389             ((and (numberp arg1) (eql arg1 0))
    5395         (compile-forms-and-maybe-emit-clear-values arg1 nil nil
    5396               arg2 'stack representation)
     5390              (compile-forms-and-maybe-emit-clear-values arg1 nil nil
     5391                                                        arg2 'stack representation)
    53975392              (emit-move-from-stack target representation))
    53985393             ((and (numberp arg2) (eql arg2 0))
    5399         (compile-forms-and-maybe-emit-clear-values arg1 'stack representation
    5400               arg2 nil nil)
     5394              (compile-forms-and-maybe-emit-clear-values arg1 'stack representation
     5395                                                        arg2 nil nil)
    54015396              (emit-move-from-stack target representation))
    54025397             (result-rep
     
    54175412              (emit-move-from-stack target representation))
    54185413             ((eql arg2 1)
    5419         (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     5414              (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    54205415              (emit-invoke-method "incr" target representation))
    54215416             ((eql arg1 1)
    5422         (compile-forms-and-maybe-emit-clear-values arg2 'stack nil)
     5417              (compile-forms-and-maybe-emit-clear-values arg2 'stack nil)
    54235418              (emit-invoke-method "incr" target representation))
    54245419             ((or (fixnum-type-p type1) (fixnum-type-p type2))
    5425         (compile-forms-and-maybe-emit-clear-values
     5420              (compile-forms-and-maybe-emit-clear-values
    54265421                    arg1 'stack (when (fixnum-type-p type1) :int)
    54275422                    arg2 'stack (when (null (fixnum-type-p type1)) :int))
     
    54665461              (emit-move-from-stack target representation))
    54675462             (t
    5468         (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     5463              (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    54695464              (emit-invokevirtual +lisp-object+ "negate"
    54705465                                  nil +lisp-object+)
     
    54815476              (compile-constant (- arg1 arg2) target representation))
    54825477             (result-rep
    5483         (compile-forms-and-maybe-emit-clear-values
     5478              (compile-forms-and-maybe-emit-clear-values
    54845479                        arg1 'stack result-rep
    54855480                        arg2 'stack result-rep)
     
    54965491              (emit-move-from-stack target representation))
    54975492             ((fixnum-type-p type2)
    5498         (compile-forms-and-maybe-emit-clear-values
     5493              (compile-forms-and-maybe-emit-clear-values
    54995494                    arg1 'stack nil
    55005495                    arg2 'stack :int)
     
    55415536           (emit-move-from-stack target representation))
    55425537          ((fixnum-type-p type2)
    5543      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5544                   arg2 'stack :int)
     5538           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5539                                                      arg2 'stack :int)
    55455540           (emit-invokevirtual +lisp-object+
    55465541                               (symbol-name op) ;; "CHAR" or "SCHAR"
     
    55965591         (let ((arg1 (%cadr form))
    55975592               (arg2 (%caddr form)))
    5598      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5599                   arg2 'stack :int)
     5593           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5594                                                      arg2 'stack :int)
    56005595           (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+)
    56015596           (fix-boxing representation nil)
     
    56685663       (ecase representation
    56695664         (:int
    5670     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5671                  arg2 'stack :int)
     5665          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5666                                                     arg2 'stack :int)
    56725667          (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
    56735668         (:long
    5674     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5675                  arg2 'stack :int)
     5669          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5670                                                     arg2 'stack :int)
    56765671          (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
    56775672         (:char
     
    56845679                                     "charAt" '(:int) :char))
    56855680                (t
    5686     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5687                   arg2 'stack :int)
     5681                (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5682                                                            arg2 'stack :int)
    56885683                 (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    56895684                 (emit-unbox-character))))
     
    56915686          ;;###FIXME for float and double, we probably want
    56925687          ;; separate java methods to retrieve the values.
    5693     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5694                  arg2 'stack :int)
     5688          (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5689                                                     arg2 'stack :int)
    56955690          (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    56965691          (convert-representation nil representation)))
     
    57485743    (cond ((and (fixnump arg2)
    57495744                (null representation))
    5750      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     5745           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    57515746           (case arg2
    57525747             (0
     
    57685763           (emit-move-from-stack target representation))
    57695764          ((fixnump arg2)
    5770      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     5765           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    57715766           (emit-push-constant-int arg2)
    57725767           (ecase representation
     
    57975792          (let* ((*register* *register*)
    57985793                 (value-register (when target (allocate-register))))
    5799      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    5800                   arg3 'stack nil)
     5794            (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     5795                                                       arg3 'stack nil)
    58015796            (when value-register
    58025797              (emit 'dup)
     
    58395834          ((and (consp arg)
    58405835                (memq (%car arg) '(NOT NULL)))
    5841      (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil)
     5836           (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil)
    58425837           (emit-push-nil)
    58435838           (let ((LABEL1 (gensym))
     
    58505845             (label LABEL2)))
    58515846          ((eq representation :boolean)
    5852      (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
     5847           (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
    58535848           (emit 'iconst_1)
    58545849           (emit 'ixor))
    58555850          ((eq (derive-compiler-type arg) 'BOOLEAN)
    5856      (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
     5851           (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
    58575852           (let ((LABEL1 (gensym))
    58585853                 (LABEL2 (gensym)))
     
    58645859             (label LABEL2)))
    58655860          (t
    5866      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     5861           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    58675862           (let ((LABEL1 (gensym))
    58685863                 (LABEL2 (gensym)))
     
    58825877         (arg2 (%cadr args)))
    58835878    (cond ((fixnum-type-p (derive-compiler-type arg1))
    5884      (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    5885                   arg2 'stack nil)
     5879           (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
     5880                                                      arg2 'stack nil)
    58865881           (emit 'swap)
    58875882           (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+)
     
    59055900             (FAIL (gensym))
    59065901             (DONE (gensym)))
    5907   (compile-forms-and-maybe-emit-clear-values arg1 'stack :boolean)
     5902        (compile-forms-and-maybe-emit-clear-values arg1 'stack :boolean)
    59085903         (emit 'ifeq FAIL)
    59095904         (ecase representation
    59105905           (:boolean
    5911       (compile-forms-and-maybe-emit-clear-values arg2 'stack :boolean)
     5906            (compile-forms-and-maybe-emit-clear-values arg2 'stack :boolean)
    59125907            (emit 'goto DONE)
    59135908            (label FAIL)
     
    59395934             (LABEL1 (gensym))
    59405935             (LABEL2 (gensym)))
    5941   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
     5936        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    59425937         (emit 'dup)
    59435938         (emit-push-nil)
     
    59655960      (1
    59665961       (let ((arg (%car args)))
    5967   (compile-forms-and-maybe-emit-clear-values arg target representation)))
     5962        (compile-forms-and-maybe-emit-clear-values arg target representation)))
    59685963      (2
    59695964       (emit-push-current-thread)
     
    61146109             (emit-push-current-thread)
    61156110             (emit-load-externalized-object name)
    6116        (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil)
     6111             (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil)
    61176112             (emit-invokevirtual +lisp-thread+ "pushSpecial"
    61186113                                 (list +lisp-symbol+ +lisp-object+) +lisp-object+))
     
    61206115             (emit-push-current-thread)
    61216116             (emit-load-externalized-object name)
    6122        (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
     6117             (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    61236118             (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
    61246119                                 (list +lisp-symbol+ +lisp-object+) +lisp-object+)))
     
    61306125      ;; If we never read the variable, we don't have to set it.
    61316126      (cond (target
    6132        (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
     6127             (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    61336128             (fix-boxing representation nil)
    61346129             (emit-move-from-stack target representation))
     
    61996194  (cond ((check-arg-count form 1)
    62006195         (let ((arg (%cadr form)))
    6201      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     6196           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    62026197           (emit-invokevirtual +lisp-object+ "sxhash" nil :int)
    62036198           (convert-representation :int representation)
     
    62116206  (let ((arg (%cadr form)))
    62126207    (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
    6213      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     6208           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    62146209           (emit-checkcast +lisp-symbol+)
    62156210           (emit-getfield  +lisp-symbol+ "name" +lisp-simple-string+)
     
    62236218  (let ((arg (%cadr form)))
    62246219    (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
    6225      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     6220           (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    62266221           (emit-checkcast +lisp-symbol+)
    62276222           (emit-invokevirtual +lisp-symbol+ "getPackage"
     
    62376232    (let ((arg (%cadr form)))
    62386233      (when (eq (derive-compiler-type arg) 'SYMBOL)
    6239   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
     6234        (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    62406235        (emit-checkcast +lisp-symbol+)
    62416236        (emit-push-current-thread)
     
    62586253                            (HASH-TABLE +lisp-hash-table+)
    62596254                            (FIXNUM     +lisp-fixnum+)
    6260           (STREAM     +lisp-stream+)
     6255                            (STREAM     +lisp-stream+)
    62616256                            (STRING     +lisp-abstract-string+)
    62626257                            (VECTOR     +lisp-abstract-vector+)))
     
    63146309           ;; we change the representation between the above and here
    63156310           ;;  ON PURPOSE!
    6316      (convert-representation :int representation)
     6311           (convert-representation :int representation)
    63176312           (emit-move-from-stack target representation))
    63186313          (t
     
    63226317(define-inlined-function p2-java-jclass (form target representation)
    63236318  ((and (= 2 (length form))
    6324   (stringp (cadr form))))
     6319        (stringp (cadr form))))
    63256320  (let ((c (ignore-errors (java:jclass (cadr form)))))
    63266321    (if c (compile-constant c target representation)
     
    63316326(define-inlined-function p2-java-jconstructor (form target representation)
    63326327  ((and (< 1 (length form))
    6333   (every #'stringp (cdr form))))
     6328        (every #'stringp (cdr form))))
    63346329  (let ((c (ignore-errors (apply #'java:jconstructor (cdr form)))))
    63356330    (if c (compile-constant c target representation)
     
    63406335(define-inlined-function p2-java-jmethod (form target representation)
    63416336  ((and (< 1 (length form))
    6342   (every #'stringp (cdr form))))
     6337        (every #'stringp (cdr form))))
    63436338  (let ((m (ignore-errors (apply #'java:jmethod (cdr form)))))
    63446339    (if m (compile-constant m target representation)
     
    63496344(define-inlined-function p2-java-jcall (form target representation)
    63506345  ((and (> *speed* *safety*)
    6351   (< 1 (length form))
    6352   (eq 'jmethod (car (cadr form)))
    6353   (every #'stringp (cdr (cadr form)))))
     6346        (< 1 (length form))
     6347        (eq 'jmethod (car (cadr form)))
     6348        (every #'stringp (cdr (cadr form)))))
    63546349  (let ((m (ignore-errors (eval (cadr form)))))
    6355     (if m 
    6356   (let ((must-clear-values nil)
    6357         (arg-types (raw-arg-types (jmethod-params m))))
    6358     (declare (type boolean must-clear-values))
    6359     (dolist (arg (cddr form))
    6360       (compile-form arg 'stack nil)
    6361       (unless must-clear-values
    6362         (unless (single-valued-p arg)
    6363     (setf must-clear-values t))))
    6364     (when must-clear-values
    6365       (emit-clear-values))
    6366     (dotimes (i (jarray-length raw-arg-types))
    6367       (push (jarray-ref raw-arg-types i) arg-types))
    6368     (emit-invokevirtual (jclass-name (jmethod-declaring-class m))
    6369             (jmethod-name m)
    6370             (nreverse arg-types)
    6371             (jmethod-return-type m)))
     6350    (if m
     6351        (let ((must-clear-values nil)
     6352              (arg-types (raw-arg-types (jmethod-params m))))
     6353          (declare (type boolean must-clear-values))
     6354          (dolist (arg (cddr form))
     6355            (compile-form arg 'stack nil)
     6356            (unless must-clear-values
     6357              (unless (single-valued-p arg)
     6358                (setf must-clear-values t))))
     6359          (when must-clear-values
     6360            (emit-clear-values))
     6361          (dotimes (i (jarray-length raw-arg-types))
     6362            (push (jarray-ref raw-arg-types i) arg-types))
     6363          (emit-invokevirtual (jclass-name (jmethod-declaring-class m))
     6364                              (jmethod-name m)
     6365                              (nreverse arg-types)
     6366                              (jmethod-return-type m)))
    63726367      ;; delay resolving the method to run-time; it's unavailable now
    63736368      (compile-function-call form target representation))))|#
     
    63956390      (cond ((characterp arg1)
    63966391             (emit-push-constant-int (char-code arg1))
    6397        (compile-forms-and-maybe-emit-clear-values arg2 'stack :char))
     6392             (compile-forms-and-maybe-emit-clear-values arg2 'stack :char))
    63986393            ((characterp arg2)
    6399        (compile-forms-and-maybe-emit-clear-values arg1 'stack :char)
     6394             (compile-forms-and-maybe-emit-clear-values arg1 'stack :char)
    64006395             (emit-push-constant-int (char-code arg2)))
    64016396            (t
    6402        (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    6403               arg2 'stack :char)))
     6397             (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
     6398                                                        arg2 'stack :char)))
    64046399      (let ((LABEL1 (gensym))
    64056400            (LABEL2 (gensym)))
     
    67696764         (method (make-method "execute" +lisp-object+ arg-types
    67706765                               :flags '(:final :public)))
    6771          (code (method-add-code method))
    6772          (*current-code-attribute* code)
    6773          (*code* ())
    6774          (*register* 1) ;; register 0: "this" pointer
    6775          (*registers-allocated* 1)
    67766766         (*visible-variables* *visible-variables*)
    67776767
     
    67816771
    67826772    (class-add-method class-file method)
    6783     (when (fixnump *source-line-number*)
    6784       (let ((table (make-line-numbers-attribute)))
    6785         (method-add-attribute method table)
    6786         (line-numbers-add-line table 0 *source-line-number*)))
    6787 
    6788     (dolist (var (compiland-arg-vars compiland))
    6789       (push var *visible-variables*))
    6790     (dolist (var (compiland-free-specials compiland))
    6791       (push var *visible-variables*))
    6792 
    6793     (when *using-arg-array*
    6794       (setf (compiland-argument-register compiland) (allocate-register)))
    6795 
    6796     ;; Assign indices or registers, depending on where the args are
    6797     ;; located: the arg-array or the call-stack
    6798     (let ((index 0))
    6799       (dolist (variable (compiland-arg-vars compiland))
    6800         (aver (null (variable-register variable)))
    6801         (aver (null (variable-index variable)))
    6802         (if *using-arg-array*
    6803             (setf (variable-index variable) index)
    6804             (setf (variable-register variable) (allocate-register)))
    6805         (incf index)))
    6806 
    6807     ;; Reserve the next available slot for the thread register.
    6808     (setf *thread* (allocate-register))
    6809 
    6810     (when *closure-variables*
    6811       (setf (compiland-closure-register compiland) (allocate-register))
    6812       (dformat t "p2-compiland 2 closure register = ~S~%"
    6813                (compiland-closure-register compiland)))
    6814 
    6815     (when *closure-variables*
    6816       (if (not *child-p*)
    6817           (progn
    6818             ;; if we're the ultimate parent: create the closure array
    6819             (emit-push-constant-int (length *closure-variables*))
    6820             (emit-anewarray +lisp-closure-binding+))
    6821         (progn
    6822           (aload 0)
    6823           (emit-getfield +lisp-compiled-closure+ "ctx"
    6824                 +closure-binding-array+)
    6825           (when local-closure-vars
    6826             ;; in all other cases, it gets stored in the register below
    6827             (emit 'astore (compiland-closure-register compiland))
    6828             (duplicate-closure-array compiland)))))
    6829 
    6830     ;; Move args from their original registers to the closure variables array
    6831     (when (or closure-args
    6832               (and *closure-variables* (not *child-p*)))
    6833       (dformat t "~S moving arguments to closure array~%"
    6834                (compiland-name compiland))
    6835       (dotimes (i (length *closure-variables*))
    6836         ;; Loop over all slots, setting their value
    6837         ;;  unconditionally if we're the parent creating it (using null
    6838         ;;  values if no real value is available)
    6839         ;; or selectively if we're a child binding certain slots.
    6840         (let ((variable (find i closure-args
    6841                               :key #'variable-closure-index
    6842                               :test #'eql)))
    6843           (when (or (not *child-p*) variable)
    6844             ;; we're the parent, or we have a variable to set.
    6845             (emit 'dup) ; array
    6846             (emit-push-constant-int i)
    6847             (emit-new +lisp-closure-binding+)
    6848             (emit 'dup)
    6849             (cond
    6850               ((null variable)
    6851                (assert (not *child-p*))
    6852                (emit 'aconst_null))
    6853               ((variable-register variable)
    6854                (assert (not (eql (variable-register variable)
    6855                                  (compiland-closure-register compiland))))
    6856                (aload (variable-register variable))
    6857                (setf (variable-register variable) nil))
    6858               ((variable-index variable)
    6859                (aload (compiland-argument-register compiland))
    6860                (emit-push-constant-int (variable-index variable))
    6861                (emit 'aaload)
    6862                (setf (variable-index variable) nil))
    6863               (t
    6864                (assert (not "Can't happen!!"))))
    6865             (emit-invokespecial-init +lisp-closure-binding+
    6866                                      (list +lisp-object+))
    6867             (emit 'aastore)))))
    6868 
    6869     (when *closure-variables*
    6870       (aver (not (null (compiland-closure-register compiland))))
    6871       (astore (compiland-closure-register compiland))
    6872       (dformat t "~S done moving arguments to closure array~%"
    6873                (compiland-name compiland)))
    6874 
    6875     ;; If applicable, move args from arg array to registers.
    6876     (when *using-arg-array*
    6877       (dolist (variable (compiland-arg-vars compiland))
    6878         (unless (or (variable-special-p variable)
    6879                     (null (variable-index variable)) ;; not in the array anymore
    6880                     (< (+ (variable-reads variable)
    6881                           (variable-writes variable)) 2))
    6882           (let ((register (allocate-register)))
    6883             (aload (compiland-argument-register compiland))
    6884             (emit-push-constant-int (variable-index variable))
    6885             (emit 'aaload)
    6886             (astore register)
    6887             (setf (variable-register variable) register)
    6888             (setf (variable-index variable) nil)))))
    6889 
    6890     (p2-compiland-process-type-declarations body)
    6891     (generate-type-checks-for-variables (compiland-arg-vars compiland))
    6892 
    6893     ;; Unbox variables.
    6894     (dolist (variable (compiland-arg-vars compiland))
    6895       (p2-compiland-unbox-variable variable))
    6896 
    6897     ;; Establish dynamic bindings for any variables declared special.
    6898     (when (some #'variable-special-p (compiland-arg-vars compiland))
    6899       ;; Save the dynamic environment
    6900       (setf (compiland-environment-register compiland)
    6901             (allocate-register))
    6902       (save-dynamic-environment (compiland-environment-register compiland))
    6903       (label label-START)
    6904       (dolist (variable (compiland-arg-vars compiland))
    6905         (when (variable-special-p variable)
    6906           (setf (variable-binding-register variable) (allocate-register))
    6907           (emit-push-current-thread)
    6908           (emit-push-variable-name variable)
    6909           (cond ((variable-register variable)
     6773
     6774    (setf (abcl-class-file-lambda-list class-file) args)
     6775    (setf (abcl-class-file-superclass class-file)
     6776          (if (or *hairy-arglist-p*
     6777                  (and *child-p* *closure-variables*))
     6778              +lisp-compiled-closure+
     6779              +lisp-compiled-primitive+))
     6780
     6781    (let ((constructor (make-constructor class-file)))
     6782      (setf (abcl-class-file-constructor class-file) constructor)
     6783      (class-add-method class-file constructor))
     6784    #+enable-when-generating-clinit
     6785    (let ((clinit (make-static-initializer class-file)))
     6786      (setf (abcl-class-file-static-initializer class-file) clinit)
     6787      (class-add-method class-file clinit))
     6788
     6789    (with-code-to-method (class-file method)
     6790      (setf *register* 1 ;; register 0: "this" pointer
     6791            *registers-allocated* 1)
     6792
     6793      (when (fixnump *source-line-number*)
     6794        (let ((table (make-line-numbers-attribute)))
     6795          (method-add-attribute method table)
     6796          (line-numbers-add-line table 0 *source-line-number*)))
     6797
     6798      (dolist (var (compiland-arg-vars compiland))
     6799        (push var *visible-variables*))
     6800      (dolist (var (compiland-free-specials compiland))
     6801        (push var *visible-variables*))
     6802
     6803      (when *using-arg-array*
     6804        (setf (compiland-argument-register compiland) (allocate-register)))
     6805
     6806      ;; Assign indices or registers, depending on where the args are
     6807      ;; located: the arg-array or the call-stack
     6808      (let ((index 0))
     6809        (dolist (variable (compiland-arg-vars compiland))
     6810          (aver (null (variable-register variable)))
     6811          (aver (null (variable-index variable)))
     6812          (if *using-arg-array*
     6813              (setf (variable-index variable) index)
     6814              (setf (variable-register variable) (allocate-register)))
     6815          (incf index)))
     6816
     6817      ;; Reserve the next available slot for the thread register.
     6818      (setf *thread* (allocate-register))
     6819
     6820      (when *closure-variables*
     6821        (setf (compiland-closure-register compiland) (allocate-register))
     6822        (dformat t "p2-compiland 2 closure register = ~S~%"
     6823                 (compiland-closure-register compiland)))
     6824
     6825      (when *closure-variables*
     6826        (if (not *child-p*)
     6827            (progn
     6828              ;; if we're the ultimate parent: create the closure array
     6829              (emit-push-constant-int (length *closure-variables*))
     6830              (emit-anewarray +lisp-closure-binding+))
     6831            (progn
     6832              (aload 0)
     6833              (emit-getfield +lisp-compiled-closure+ "ctx"
     6834                             +closure-binding-array+)
     6835              (when local-closure-vars
     6836                ;; in all other cases, it gets stored in the register below
     6837                (emit 'astore (compiland-closure-register compiland))
     6838                (duplicate-closure-array compiland)))))
     6839
     6840      ;; Move args from their original registers to the closure variables array
     6841      (when (or closure-args
     6842                (and *closure-variables* (not *child-p*)))
     6843        (dformat t "~S moving arguments to closure array~%"
     6844                 (compiland-name compiland))
     6845        (dotimes (i (length *closure-variables*))
     6846          ;; Loop over all slots, setting their value
     6847          ;;  unconditionally if we're the parent creating it (using null
     6848          ;;  values if no real value is available)
     6849          ;; or selectively if we're a child binding certain slots.
     6850          (let ((variable (find i closure-args
     6851                                :key #'variable-closure-index
     6852                                :test #'eql)))
     6853            (when (or (not *child-p*) variable)
     6854              ;; we're the parent, or we have a variable to set.
     6855              (emit 'dup)               ; array
     6856              (emit-push-constant-int i)
     6857              (emit-new +lisp-closure-binding+)
     6858              (emit 'dup)
     6859              (cond
     6860                ((null variable)
     6861                 (assert (not *child-p*))
     6862                 (emit 'aconst_null))
     6863                ((variable-register variable)
     6864                 (assert (not (eql (variable-register variable)
     6865                                   (compiland-closure-register compiland))))
    69106866                 (aload (variable-register variable))
    69116867                 (setf (variable-register variable) nil))
     
    69146870                 (emit-push-constant-int (variable-index variable))
    69156871                 (emit 'aaload)
    6916                  (setf (variable-index variable) nil)))
    6917           (emit-invokevirtual +lisp-thread+ "bindSpecial"
    6918                               (list +lisp-symbol+ +lisp-object+)
    6919                               +lisp-special-binding+)
    6920           (astore (variable-binding-register variable)))))
    6921 
    6922     (compile-progn-body body 'stack)
    6923 
    6924     (when (compiland-environment-register compiland)
    6925       (restore-dynamic-environment (compiland-environment-register compiland)))
    6926 
    6927     (unless *code*
    6928       (emit-push-nil))
    6929     (emit 'areturn)
    6930 
    6931     ;; Warn if any unused args. (Is this the right place?)
    6932     (check-for-unused-variables (compiland-arg-vars compiland))
    6933 
    6934     ;; Go back and fill in prologue.
    6935     (let ((code *code*))
    6936       (setf *code* ())
    6937       (let ((arity (compiland-arity compiland)))
    6938         (when arity
    6939           (generate-arg-count-check arity)))
    6940 
    6941       (when *hairy-arglist-p*
    6942         (aload 0) ; this
    6943         (aver (not (null (compiland-argument-register compiland))))
    6944         (aload (compiland-argument-register compiland)) ; arg vector
    6945         (cond ((or (memq '&OPTIONAL args) (memq '&KEY args))
    6946                (ensure-thread-var-initialized)
    6947                (maybe-initialize-thread-var)
    6948          (emit-push-current-thread)
    6949                (emit-invokevirtual *this-class* "processArgs"
    6950                                    (list +lisp-object-array+ +lisp-thread+)
    6951                                    +lisp-object-array+))
    6952               (t
    6953                (emit-invokevirtual *this-class* "fastProcessArgs"
    6954                                    (list +lisp-object-array+)
    6955                                    +lisp-object-array+)))
    6956         (astore (compiland-argument-register compiland)))
    6957 
    6958       (unless (and *hairy-arglist-p*
    6959                    (or (memq '&OPTIONAL args) (memq '&KEY args)))
    6960         (maybe-initialize-thread-var))
    6961       (setf *code* (nconc code *code*)))
    6962 
    6963     (setf (abcl-class-file-superclass class-file)
    6964           (if (or *hairy-arglist-p*
    6965       (and *child-p* *closure-variables*))
    6966         +lisp-compiled-closure+
    6967       +lisp-compiled-primitive+))
    6968 
    6969     (setf (abcl-class-file-lambda-list class-file) args)
    6970     (setf (code-max-locals code) *registers-allocated*)
    6971     (setf (code-code code) *code*))
    6972 
    6973 
     6872                 (setf (variable-index variable) nil))
     6873                (t
     6874                 (assert (not "Can't happen!!"))))
     6875              (emit-invokespecial-init +lisp-closure-binding+
     6876                                       (list +lisp-object+))
     6877              (emit 'aastore)))))
     6878
     6879      (when *closure-variables*
     6880        (aver (not (null (compiland-closure-register compiland))))
     6881        (astore (compiland-closure-register compiland))
     6882        (dformat t "~S done moving arguments to closure array~%"
     6883                 (compiland-name compiland)))
     6884
     6885      ;; If applicable, move args from arg array to registers.
     6886      (when *using-arg-array*
     6887        (dolist (variable (compiland-arg-vars compiland))
     6888          (unless (or (variable-special-p variable)
     6889                      (null (variable-index variable)) ;; not in the array anymore
     6890                      (< (+ (variable-reads variable)
     6891                            (variable-writes variable)) 2))
     6892            (let ((register (allocate-register)))
     6893              (aload (compiland-argument-register compiland))
     6894              (emit-push-constant-int (variable-index variable))
     6895              (emit 'aaload)
     6896              (astore register)
     6897              (setf (variable-register variable) register)
     6898              (setf (variable-index variable) nil)))))
     6899
     6900      (p2-compiland-process-type-declarations body)
     6901      (generate-type-checks-for-variables (compiland-arg-vars compiland))
     6902
     6903      ;; Unbox variables.
     6904      (dolist (variable (compiland-arg-vars compiland))
     6905        (p2-compiland-unbox-variable variable))
     6906
     6907      ;; Establish dynamic bindings for any variables declared special.
     6908      (when (some #'variable-special-p (compiland-arg-vars compiland))
     6909        ;; Save the dynamic environment
     6910        (setf (compiland-environment-register compiland)
     6911              (allocate-register))
     6912        (save-dynamic-environment (compiland-environment-register compiland))
     6913        (label label-START)
     6914        (dolist (variable (compiland-arg-vars compiland))
     6915          (when (variable-special-p variable)
     6916            (setf (variable-binding-register variable) (allocate-register))
     6917            (emit-push-current-thread)
     6918            (emit-push-variable-name variable)
     6919            (cond ((variable-register variable)
     6920                   (aload (variable-register variable))
     6921                   (setf (variable-register variable) nil))
     6922                  ((variable-index variable)
     6923                   (aload (compiland-argument-register compiland))
     6924                   (emit-push-constant-int (variable-index variable))
     6925                   (emit 'aaload)
     6926                   (setf (variable-index variable) nil)))
     6927            (emit-invokevirtual +lisp-thread+ "bindSpecial"
     6928                                (list +lisp-symbol+ +lisp-object+)
     6929                                +lisp-special-binding+)
     6930            (astore (variable-binding-register variable)))))
     6931
     6932      (compile-progn-body body 'stack)
     6933
     6934      (when (compiland-environment-register compiland)
     6935        (restore-dynamic-environment (compiland-environment-register compiland)))
     6936
     6937      (unless *code*
     6938        (emit-push-nil))
     6939      (emit 'areturn)
     6940
     6941      ;; Warn if any unused args. (Is this the right place?)
     6942      (check-for-unused-variables (compiland-arg-vars compiland))
     6943
     6944      ;; Go back and fill in prologue.
     6945      (let ((code *code*))
     6946        (setf *code* ())
     6947        (let ((arity (compiland-arity compiland)))
     6948          (when arity
     6949            (generate-arg-count-check arity)))
     6950
     6951        (when *hairy-arglist-p*
     6952          (aload 0) ; this
     6953          (aver (not (null (compiland-argument-register compiland))))
     6954          (aload (compiland-argument-register compiland)) ; arg vector
     6955          (cond ((or (memq '&OPTIONAL args) (memq '&KEY args))
     6956                 (ensure-thread-var-initialized)
     6957                 (maybe-initialize-thread-var)
     6958                 (emit-push-current-thread)
     6959                 (emit-invokevirtual *this-class* "processArgs"
     6960                                     (list +lisp-object-array+ +lisp-thread+)
     6961                                     +lisp-object-array+))
     6962                (t
     6963                 (emit-invokevirtual *this-class* "fastProcessArgs"
     6964                                     (list +lisp-object-array+)
     6965                                     +lisp-object-array+)))
     6966          (astore (compiland-argument-register compiland)))
     6967
     6968        (unless (and *hairy-arglist-p*
     6969                     (or (memq '&OPTIONAL args) (memq '&KEY args)))
     6970          (maybe-initialize-thread-var))
     6971        (setf *code* (nconc code *code*)))
     6972      ))
    69746973  t)
    69756974
     
    69786977  (destructuring-bind (&optional target-var repr-var) (cadr form)
    69796978    (eval `(let (,@(when target-var `((,target-var ,target)))
    6980     ,@(when repr-var `((,repr-var ,representation))))
    6981        ,@(cddr form)))))
     6979                ,@(when repr-var `((,repr-var ,representation))))
     6980             ,@(cddr form)))))
    69826981
    69836982(defun compile-1 (compiland stream)
  • trunk/abcl/src/org/armedbear/lisp/jvm-class-file.lisp

    r12932 r13025  
    11401140
    11411141(defvar *current-code-attribute* nil)
     1142(defvar *method*)
    11421143
    11431144(defun save-code-specials (code)
     
    11591160         (save-code-specials *current-code-attribute*))
    11601161       (let* ((,m ,method)
     1162              (*method* ,m)
    11611163              (,c (method-ensure-code ,method))
    11621164              (*pool* (class-file-constants ,class-file))
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r12918 r13025  
    125125  lambda-name
    126126  lambda-list ; as advertised
    127   static-code
     127  static-initializer
     128  constructor
    128129  objects ;; an alist of externalized objects and their field names
    129130  (functions (make-hash-table :test 'equal)) ;; because of (SETF ...) functions
     
    177178            (*class-file*           ,var)
    178179            (*pool*                 (abcl-class-file-constants ,var))
    179             (*static-code*          (abcl-class-file-static-code ,var))
    180180            (*externalized-objects* (abcl-class-file-objects ,var))
    181181            (*declared-functions*   (abcl-class-file-functions ,var)))
    182182       (progn ,@body)
    183        (setf (abcl-class-file-static-code ,var)  *static-code*
    184              (abcl-class-file-objects ,var)      *externalized-objects*
     183       (setf (abcl-class-file-objects ,var)      *externalized-objects*
    185184             (abcl-class-file-functions ,var)    *declared-functions*))))
    186185
Note: See TracChangeset for help on using the changeset viewer.