Changeset 12918


Ignore:
Timestamp:
09/24/10 22:35:02 (11 years ago)
Author:
astalla
Message:

generic-class-file branch merged.

Location:
trunk/abcl
Files:
1 deleted
7 edited
3 copied

Legend:

Unmodified
Added
Removed
  • trunk/abcl/abcl.asd

    r12902 r12918  
    3333                     ((:file "compiler-tests")
    3434                      (:file "condition-tests")
     35                      (:file "class-file")
    3536                      (:file "metaclass")
    3637                      #+abcl
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r12761 r12918  
    673673  `(case ,expr ,@clauses))))
    674674
     675(defconstant +fasl-classloader+
     676  (jvm::make-class-name "org.armedbear.lisp.FaslClassLoader"))
     677
    675678(defun generate-loader-function ()
    676679  (let* ((basename (base-classname))
     
    681684       :for i :from 1 :to *class-number*
    682685       :collect
    683        (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i)))
     686       (let* ((class (%format nil "org/armedbear/lisp/~A_~A"
     687                                                basename i))
     688                                (class-name (jvm::make-class-name class)))
    684689         `(,(1- i)
    685690            (jvm::with-inline-code ()
    686691        (jvm::emit 'jvm::aload 1)
    687         (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance"
     692        (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance"
    688693               nil jvm::+java-object+)
    689         (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader")
     694        (jvm::emit-checkcast +fasl-classloader+)
    690695        (jvm::emit 'jvm::dup)
    691696        (jvm::emit-push-constant-int ,(1- i))
    692         (jvm::emit 'jvm::new ,class)
     697        (jvm::emit-new ,class-name)
    693698        (jvm::emit 'jvm::dup)
    694         (jvm::emit-invokespecial-init ,class '())
    695         (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction"
    696                (list "I" jvm::+lisp-object+) jvm::+lisp-object+)
     699        (jvm::emit-invokespecial-init ,class-name '())
     700        (jvm::emit-invokevirtual +fasl-classloader+
     701                                                         "putFunction"
     702               (list :int jvm::+lisp-object+) jvm::+lisp-object+)
    697703        (jvm::emit 'jvm::pop))
    698704            t))))))
  • trunk/abcl/src/org/armedbear/lisp/compile-system.lisp

    r12831 r12918  
    9898      (load (do-compile "compiler-pass1.lisp"))
    9999      (load (do-compile "compiler-pass2.lisp"))
     100      (load (do-compile "jvm-class-file.lisp"))
    100101      (load (do-compile "jvm.lisp"))
    101102      (load (do-compile "source-transform.lisp"))
    102103      (load (do-compile "compiler-macro.lisp"))
    103       (load (do-compile "opcodes.lisp"))
     104      (load (do-compile "jvm-instructions.lisp"))
    104105      (load (do-compile "setf.lisp"))
    105106      (load (do-compile "extensible-sequences-base.lisp"))
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12837 r12918  
    4242  (require "KNOWN-SYMBOLS")
    4343  (require "DUMP-FORM")
    44   (require "OPCODES")
     44  (require "JVM-INSTRUCTIONS")
    4545  (require "JAVA"))
    4646
    4747
    48 (defun dump-pool ()
    49   (let ((pool (reverse *pool*))
    50         entry type)
    51     (dotimes (index (1- *pool-count*))
    52       (setq entry (car pool))
    53       (setq type (case (car entry)
    54                    (7 'class)
    55                    (9 'field)
    56                    (10 'method)
    57                    (11 'interface)
    58                    (8 'string)
    59                    (3 'integer)
    60                    (4 'float)
    61                    (5 'long)
    62                    (6 'double)
    63                    (12 'name-and-type)
    64                    (1 'utf8)))
    65       (format t "~D: ~A ~S~%" (1+ index) type entry)
    66       (setq pool (cdr pool))))
    67   t)
    68 
    69 (defknown pool-get (t) (integer 1 65535))
    70 (defun pool-get (entry)
    71   (declare (optimize speed (safety 0)))
    72   (let* ((ht *pool-entries*)
    73          (index (gethash1 entry ht)))
    74     (declare (type hash-table ht))
    75     (unless index
    76       (setf index *pool-count*)
    77       (push entry *pool*)
    78       (setf (gethash entry ht) index)
    79       (setf *pool-count* (1+ index)))
    80     index))
    81 
    82 (declaim (ftype (function (string) fixnum) pool-name))
    83 (declaim (inline pool-name))
     48(declaim (inline pool-name pool-string pool-name-and-type
     49                 pool-class pool-field pool-method pool-int
     50                 pool-float pool-long pool-double))
     51
    8452(defun pool-name (name)
    85   (declare (optimize speed))
    86   (pool-get (list 1 (length name) name)))
    87 
    88 (declaim (ftype (function (string string) fixnum) pool-name-and-type))
    89 (declaim (inline pool-name-and-type))
     53  (pool-add-utf8 *pool* name))
     54
    9055(defun pool-name-and-type (name type)
    91   (declare (optimize speed))
    92   (pool-get (list 12
    93                   (pool-name name)
    94                   (pool-name type))))
    95 
    96 ;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp"
    97 ;; as opposed to "org.armedbear.lisp.Lisp").
    98 (declaim (ftype (function (string) fixnum) pool-class))
    99 (declaim (inline pool-class))
    100 (defun pool-class (class-name)
    101   (declare (optimize speed))
    102   (pool-get (list 7 (pool-name class-name))))
    103 
    104 ;; (tag class-index name-and-type-index)
    105 (declaim (ftype (function (string string string) fixnum) pool-field))
    106 (declaim (inline pool-field))
     56  (pool-add-name/type *pool* name type))
     57
     58(defun pool-class (name)
     59  (pool-add-class *pool* name))
     60
     61(defun pool-string (string)
     62  (pool-add-string *pool* string))
     63
    10764(defun pool-field (class-name field-name type-name)
    108   (declare (optimize speed))
    109   (pool-get (list 9
    110                   (pool-class class-name)
    111                   (pool-name-and-type field-name type-name))))
    112 
    113 ;; (tag class-index name-and-type-index)
    114 (declaim (ftype (function (string string string) fixnum) pool-method))
    115 (declaim (inline pool-method))
     65  (pool-add-field-ref *pool* class-name field-name type-name))
     66
    11667(defun pool-method (class-name method-name type-name)
    117   (declare (optimize speed))
    118   (pool-get (list 10
    119                   (pool-class class-name)
    120                   (pool-name-and-type method-name type-name))))
    121 
    122 (declaim (ftype (function (string) fixnum) pool-string))
    123 (defun pool-string (string)
    124   (declare (optimize speed))
    125   (pool-get (list 8 (pool-name string))))
    126 
    127 (defknown pool-int (fixnum) (integer 1 65535))
    128 (defun pool-int (n)
    129   (declare (optimize speed))
    130   (pool-get (list 3 n)))
    131 
    132 (defknown pool-float (single-float) (integer 1 65535))
    133 (defun pool-float (n)
    134   (declare (optimize speed))
    135   (pool-get (list 4 (%float-bits n))))
    136 
    137 (defun pool-long/double (entry)
    138   (let* ((ht *pool-entries*)
    139          (index (gethash1 entry ht)))
    140     (declare (type hash-table ht))
    141     (unless index
    142       (setf index *pool-count*)
    143       (push entry *pool*)
    144       (setf (gethash entry ht) index)
    145       ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte
    146       ;; constants take up two entries in the constant_pool table of the class
    147       ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the
    148       ;; item in the constant_pool table at index n, then the next usable item in
    149       ;; the pool is located at index n+2. The constant_pool index n+1 must be
    150       ;; valid but is considered unusable." So:
    151       (setf *pool-count* (+ index 2)))
    152     index))
    153 
    154 (defknown pool-long (integer) (integer 1 65535))
    155 (defun pool-long (n)
    156   (declare (optimize speed))
    157   (declare (type java-long n))
    158   (let* ((entry (list 5
    159                       (logand (ash n -32) #xffffffff)
    160                       (logand n #xffffffff))))
    161     (pool-long/double entry)))
    162 
    163 (defknown pool-double (double-float) (integer 1 65535))
    164 (defun pool-double (n)
    165   (declare (optimize speed))
    166   (let* ((n (%float-bits n))
    167          (entry (list 6
    168                       (logand (ash n -32) #xffffffff)
    169                       (logand n #xffffffff))))
    170     (pool-long/double entry)))
    171 
    172 (defknown u2 (fixnum) cons)
    173 (defun u2 (n)
    174   (declare (optimize speed))
    175   (declare (type (unsigned-byte 16) n))
    176   (when (not (<= 0 n 65535))
    177     (error "u2 argument ~A out of 65k range." n))
    178   (list (logand (ash n -8) #xff)
    179         (logand n #xff)))
    180 
    181 (defknown s1 (fixnum) fixnum)
    182 (defun s1 (n)
    183   (declare (optimize speed))
    184   (declare (type (signed-byte 8) n))
    185   (when (not (<= -128 n 127))
    186     (error "s2 argument ~A out of 16-bit signed range." n))
    187   (if (< n 0)
    188       (1+ (logxor (- n) #xFF))
    189       n))
    190 
    191 
    192 (defknown s2 (fixnum) cons)
    193 (defun s2 (n)
    194   (declare (optimize speed))
    195   (declare (type (signed-byte 16) n))
    196   (when (not (<= -32768 n 32767))
    197     (error "s2 argument ~A out of 16-bit signed range." n))
    198   (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
    199           n)))
    200 
    201 (defconstant +fasl-loader-class+
    202   "org/armedbear/lisp/FaslClassLoader")
    203 (defconstant +java-string+ "Ljava/lang/String;")
    204 (defconstant +java-object+ "Ljava/lang/Object;")
    205 (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
    206 (defconstant +lisp-nil-class+ "org/armedbear/lisp/Nil")
    207 (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass")
    208 (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
    209 (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
    210 (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
    211 (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
    212 (defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding")
    213 (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
    214 (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;")
    215 (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject")
    216 (defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
    217 (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
    218 (defconstant +lisp-load-class+ "org/armedbear/lisp/Load")
    219 (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
    220 (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;")
    221 (defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger")
    222 (defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;")
    223 (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
    224 (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
    225 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
    226 (defconstant +lisp-function-proxy-class+
    227   "org/armedbear/lisp/AutoloadedFunctionProxy")
    228 (defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum")
    229 (defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;")
    230 (defconstant +lisp-single-float-class+ "org/armedbear/lisp/SingleFloat")
    231 (defconstant +lisp-single-float+ "Lorg/armedbear/lisp/SingleFloat;")
    232 (defconstant +lisp-double-float-class+ "org/armedbear/lisp/DoubleFloat")
    233 (defconstant +lisp-double-float+ "Lorg/armedbear/lisp/DoubleFloat;")
    234 (defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter")
    235 (defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;")
    236 (defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;")
    237 (defconstant +lisp-abstract-bit-vector-class+ "org/armedbear/lisp/AbstractBitVector")
    238 (defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector")
    239 (defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString")
    240 (defconstant +lisp-abstract-string+ "Lorg/armedbear/lisp/AbstractString;")
    241 (defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector")
    242 (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString")
    243 (defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;")
    244 (defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;")
    245 (defconstant +lisp-environment-class+ "org/armedbear/lisp/Environment")
    246 (defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;")
    247 (defconstant +lisp-special-binding-class+ "org/armedbear/lisp/SpecialBinding")
    248 (defconstant +lisp-special-bindings-mark+ "Lorg/armedbear/lisp/SpecialBindingsMark;")
    249 (defconstant +lisp-special-bindings-mark-class+ "org/armedbear/lisp/SpecialBindingsMark")
    250 (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw")
    251 (defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
    252 (defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
    253 (defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure")
    254 (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive")
    255 (defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable")
    256 (defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable")
    257 (defconstant +lisp-package-class+ "org/armedbear/lisp/Package")
    258 (defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable")
    259 (defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream")
    260 (defconstant +lisp-closure-class+ "org/armedbear/lisp/Closure")
    261 (defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter")
    262 (defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;")
    263 
    264 (defstruct (instruction (:constructor %make-instruction (opcode args)))
    265   (opcode 0 :type (integer 0 255))
    266   args
    267   stack
    268   depth
    269   wide)
    270 
    271 (defun make-instruction (opcode args)
    272   (let ((inst (apply #'%make-instruction
    273                      (list opcode
    274                            (remove :wide-prefix args)))))
    275     (when (memq :wide-prefix args)
    276       (setf (inst-wide inst) t))
    277     inst))
    278 
    279 (defun print-instruction (instruction)
    280   (sys::%format nil "~A ~A stack = ~S depth = ~S"
    281           (opcode-name (instruction-opcode instruction))
    282           (instruction-args instruction)
    283           (instruction-stack instruction)
    284           (instruction-depth instruction)))
    285 
    286 (defknown inst * t)
    287 (defun inst (instr &optional args)
    288   (declare (optimize speed))
    289   (let ((opcode (if (fixnump instr)
    290                     instr
    291                     (opcode-number instr))))
    292     (unless (listp args)
    293       (setf args (list args)))
    294     (make-instruction opcode args)))
    295 
    296 (defknown %%emit * t)
    297 (defun %%emit (instr &rest args)
    298   (declare (optimize speed))
    299   (let ((instruction (make-instruction instr args)))
    300     (push instruction *code*)
    301     instruction))
    302 
    303 (defknown %emit * t)
    304 (defun %emit (instr &rest args)
    305   (declare (optimize speed))
    306   (let ((instruction (inst instr args)))
    307     (push instruction *code*)
    308     instruction))
    309 
    310 (defmacro emit (instr &rest args)
    311   (when (and (consp instr) (eq (car instr) 'QUOTE) (symbolp (cadr instr)))
    312     (setf instr (opcode-number (cadr instr))))
    313   (if (fixnump instr)
    314       `(%%emit ,instr ,@args)
    315       `(%emit ,instr ,@args)))
    316 
    317 (defknown label (symbol) t)
    318 (defun label (symbol)
    319   (declare (type symbol symbol))
    320   (declare (optimize speed))
    321   (emit 'label symbol)
    322   (setf (symbol-value symbol) nil))
    323 
    324 (defknown aload (fixnum) t)
    325 (defun aload (index)
    326   (case index
    327     (0 (emit 'aload_0))
    328     (1 (emit 'aload_1))
    329     (2 (emit 'aload_2))
    330     (3 (emit 'aload_3))
    331     (t (emit 'aload index))))
    332 
    333 (defknown astore (fixnum) t)
    334 (defun astore (index)
    335   (case index
    336     (0 (emit 'astore_0))
    337     (1 (emit 'astore_1))
    338     (2 (emit 'astore_2))
    339     (3 (emit 'astore_3))
    340     (t (emit 'astore index))))
     68  (pool-add-method-ref *pool* class-name method-name type-name))
     69
     70(defun pool-int (int)
     71  (pool-add-int *pool* int))
     72
     73(defun pool-float (float)
     74  (pool-add-float *pool* float))
     75
     76(defun pool-long (long)
     77  (pool-add-long *pool* long))
     78
     79(defun pool-double (double)
     80  (pool-add-double *pool* double))
     81
     82(defun add-exception-handler (start end handler type)
     83  (code-add-exception-handler *current-code-attribute*
     84                              start end handler type))
     85
     86
    34187
    34288(defknown emit-push-nil () t)
    34389(declaim (inline emit-push-nil))
    34490(defun emit-push-nil ()
    345   (emit-getstatic +lisp-class+ "NIL" +lisp-object+))
     91  (emit-getstatic +lisp+ "NIL" +lisp-object+))
    34692
    34793(defknown emit-push-nil-symbol () t)
    34894(declaim (inline emit-push-nil-symbol))
    34995(defun emit-push-nil-symbol ()
    350   (emit-getstatic +lisp-nil-class+ "NIL" +lisp-symbol+))
     96  (emit-getstatic +lisp-nil+ "NIL" +lisp-symbol+))
    35197
    35298(defknown emit-push-t () t)
    35399(declaim (inline emit-push-t))
    354100(defun emit-push-t ()
    355   (emit-getstatic +lisp-class+ "T" +lisp-symbol+))
     101  (emit-getstatic +lisp+ "T" +lisp-symbol+))
    356102
    357103(defknown emit-push-false (t) t)
     
    456202           (emit 'pop2)))))
    457203
    458 (declaim (ftype (function (t t) cons) make-descriptor-info))
    459 (defun make-descriptor-info (arg-types return-type)
    460   (let ((descriptor (with-standard-io-syntax
    461                       (with-output-to-string (s)
    462                         (princ #\( s)
    463                         (dolist (type arg-types)
    464                           (princ type s))
    465                         (princ #\) s)
    466                         (princ (or return-type "V") s))))
    467         (stack-effect (let ((result (cond ((null return-type) 0)
    468                                           ((or (equal return-type "J")
    469                                                (equal return-type "D")) 2)
    470                                           (t 1))))
    471                         (dolist (type arg-types result)
    472                           (decf result (if (or (equal type "J")
    473                                                (equal type "D"))
    474                                            2 1))))))
    475     (cons descriptor stack-effect)))
    476 
    477 (defparameter *descriptors* (make-hash-table :test #'equal))
    478 
    479 (declaim (ftype (function (t t) cons) get-descriptor-info))
    480 (defun get-descriptor-info (arg-types return-type)
    481   (let* ((key (list arg-types return-type))
    482          (ht *descriptors*)
    483          (descriptor-info (gethash1 key ht)))
    484     (declare (type hash-table ht))
    485     (or descriptor-info
    486         (setf (gethash key ht) (make-descriptor-info arg-types return-type)))))
    487 
    488 (declaim (inline get-descriptor))
    489 (defun get-descriptor (arg-types return-type)
    490   (car (get-descriptor-info arg-types return-type)))
    491 
    492204(declaim (ftype (function * t) emit-invokestatic))
    493205(defun emit-invokestatic (class-name method-name arg-types return-type)
    494   (let* ((info (get-descriptor-info arg-types return-type))
    495          (descriptor (car info))
    496          (stack-effect (cdr info))
    497          (index (pool-method class-name method-name descriptor))
     206  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
     207         (index (pool-add-method-ref *pool* class-name
     208                                     method-name (cons return-type arg-types)))
    498209         (instruction (apply #'%emit 'invokestatic (u2 index))))
    499210    (setf (instruction-stack instruction) stack-effect)))
     
    503214(declaim (ftype (function t string) pretty-java-class))
    504215(defun pretty-java-class (class)
    505   (cond ((equal class +lisp-object-class+)
     216  (cond ((equal class +lisp-object+)
    506217         "LispObject")
    507218        ((equal class +lisp-symbol+)
    508219         "Symbol")
    509         ((equal class +lisp-thread-class+)
     220        ((equal class  +lisp-thread+)
    510221         "LispThread")
    511222        (t
     
    514225(defknown emit-invokevirtual (t t t t) t)
    515226(defun emit-invokevirtual (class-name method-name arg-types return-type)
    516   (let* ((info (get-descriptor-info arg-types return-type))
    517          (descriptor (car info))
    518          (stack-effect (cdr info))
    519          (index (pool-method class-name method-name descriptor))
     227  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
     228         (index (pool-add-method-ref *pool* class-name
     229                                     method-name (cons return-type arg-types)))
    520230         (instruction (apply #'%emit 'invokevirtual (u2 index))))
    521231    (declare (type (signed-byte 8) stack-effect))
     
    532242(defknown emit-invokespecial-init (string list) t)
    533243(defun emit-invokespecial-init (class-name arg-types)
    534   (let* ((info (get-descriptor-info arg-types nil))
    535          (descriptor (car info))
    536          (stack-effect (cdr info))
    537          (index (pool-method class-name "<init>" descriptor))
     244  (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
     245         (index (pool-add-method-ref *pool* class-name
     246                                     "<init>" (cons nil arg-types)))
    538247         (instruction (apply #'%emit 'invokespecial (u2 index))))
    539248    (declare (type (signed-byte 8) stack-effect))
     
    557266                ((equal type +lisp-thread+)
    558267                 "LispThread")
    559                 ((equal type "C")
     268                ((equal type :char)
    560269                 "char")
    561                 ((equal type "I")
     270                ((equal type :int)
    562271                 "int")
    563                 ((equal type "Z")
     272                ((equal type :boolean)
    564273                 "boolean")
    565                 ((null type)
     274                ((or (null type)
     275                     (eq type :void))
    566276                 "void")
    567277                (t
     
    574284(defknown emit-getstatic (t t t) t)
    575285(defun emit-getstatic (class-name field-name type)
    576   (let ((index (pool-field class-name field-name type)))
     286  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
    577287    (apply #'%emit 'getstatic (u2 index))))
    578288
    579289(defknown emit-putstatic (t t t) t)
    580290(defun emit-putstatic (class-name field-name type)
    581   (let ((index (pool-field class-name field-name type)))
     291  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
    582292    (apply #'%emit 'putstatic (u2 index))))
     293
     294(declaim (inline emit-getfield emit-putfield))
     295(defknown emit-getfield (t t t) t)
     296(defun emit-getfield (class-name field-name type)
     297  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
     298    (apply #'%emit 'getfield (u2 index))))
     299
     300(defknown emit-putfield (t t t) t)
     301(defun emit-putfield (class-name field-name type)
     302  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
     303    (apply #'%emit 'putfield (u2 index))))
     304
     305
     306(defknown emit-new (t) t)
     307(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
     308(defun emit-new (class-name)
     309  (apply #'%emit 'new (u2 (pool-class class-name))))
     310
     311(defknown emit-anewarray (t) t)
     312(defun emit-anewarray (class-name)
     313  (apply #'%emit 'anewarray (u2 (pool-class class-name))))
     314
     315(defknown emit-checkcast (t) t)
     316(defun emit-checkcast (class-name)
     317  (apply #'%emit 'checkcast (u2 (pool-class class-name))))
     318
     319(defknown emit-instanceof (t) t)
     320(defun emit-instanceof (class-name)
     321  (apply #'%emit 'instanceof (u2 (pool-class class-name))))
     322
    583323
    584324(defvar type-representations '((:int fixnum)
     
    614354(defknown emit-unbox-boolean () t)
    615355(defun emit-unbox-boolean ()
    616   (emit 'instanceof +lisp-nil-class+)
     356  (emit-instanceof +lisp-nil+)
    617357  (emit 'iconst_1)
    618358  (emit 'ixor))  ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit
     
    621361(defun emit-unbox-character ()
    622362  (cond ((> *safety* 0)
    623          (emit-invokestatic +lisp-character-class+ "getValue"
    624                             (lisp-object-arg-types 1) "C"))
     363         (emit-invokestatic +lisp-character+ "getValue"
     364                            (lisp-object-arg-types 1) :char))
    625365        (t
    626          (emit 'checkcast +lisp-character-class+)
    627          (emit 'getfield +lisp-character-class+ "value" "C"))))
     366         (emit-checkcast +lisp-character+)
     367         (emit-getfield +lisp-character+ "value" :char))))
    628368
    629369;;                     source type /
     
    643383
    644384(defvar rep-classes
    645   '((:boolean  #.+lisp-object-class+        #.+lisp-object+)
    646     (:char     #.+lisp-character-class+     #.+lisp-character+)
    647     (:int      #.+lisp-integer-class+       #.+lisp-integer+)
    648     (:long     #.+lisp-integer-class+       #.+lisp-integer+)
    649     (:float    #.+lisp-single-float-class+  #.+lisp-single-float+)
    650     (:double   #.+lisp-double-float-class+  #.+lisp-double-float+))
     385  `((:boolean . ,+lisp-object+)
     386    (:char    . ,+lisp-character+)
     387    (:int     . ,+lisp-integer+)
     388    (:long    . ,+lisp-integer+)
     389    (:float   . ,+lisp-single-float+)
     390    (:double  . ,+lisp-double-float+))
    651391  "Lists the class on which to call the `getInstance' method on,
    652392when converting the internal representation to a LispObject.")
    653393
    654 (defvar rep-arg-chars
    655   '((:boolean . "Z")
    656     (:char    . "C")
    657     (:int     . "I")
    658     (:long    . "J")
    659     (:float   . "F")
    660     (:double  . "D"))
    661   "Lists the argument type identifiers for each
    662 of the internal representations.")
    663394
    664395(defun convert-representation (in out)
     
    671402    ;; Convert back to a lisp object
    672403    (when in
    673       (let ((class (cdr (assoc in rep-classes)))
    674             (arg-spec (cdr (assoc in rep-arg-chars))))
    675         (emit-invokestatic (first class) "getInstance" (list arg-spec)
    676                            (second class))))
     404      (let ((class (cdr (assoc in rep-classes))))
     405        (emit-invokestatic class "getInstance" (list in) class)))
    677406    (return-from convert-representation))
    678407  (let* ((in-map (cdr (assoc in rep-conversion)))
     
    688417             (funcall op))
    689418            ((stringp op)
    690              (emit-invokevirtual +lisp-object-class+ op nil
    691                                  (cdr (assoc out rep-arg-chars))))
     419             (emit-invokevirtual +lisp-object+ op nil out))
    692420            (t
    693421             (emit op))))))
     
    722450(defun maybe-initialize-thread-var ()
    723451  (when *initialize-thread-var*
    724     (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+)
     452    (emit-invokestatic +lisp-thread+ "currentThread" nil +lisp-thread+)
    725453    (astore *thread*)
    726454    (setf *initialize-thread-var* nil)))
     
    737465  (aload *thread*))
    738466
    739 (defun local-variable-p (variable)
     467(defun variable-local-p (variable)
    740468  "Return non-NIL if `variable' is a local variable.
    741469
     
    746474(defun emit-load-local-variable (variable)
    747475  "Loads a local variable in the top stack position."
    748   (aver (local-variable-p variable))
     476  (aver (variable-local-p variable))
    749477  (if (variable-register variable)
    750478      (aload (variable-register variable))
     
    764492before the emitted code: the code is 'stack-neutral'."
    765493  (declare (type symbol expected-type))
    766   (unless (local-variable-p variable)
     494  (unless (variable-local-p variable)
    767495    (return-from generate-instanceof-type-check-for-variable))
    768496  (let ((instanceof-class (ecase expected-type
    769                             (SYMBOL     +lisp-symbol-class+)
    770                             (CHARACTER  +lisp-character-class+)
    771                             (CONS       +lisp-cons-class+)
    772                             (HASH-TABLE +lisp-hash-table-class+)
    773                             (FIXNUM     +lisp-fixnum-class+)
    774                             (STREAM     +lisp-stream-class+)
    775                             (STRING     +lisp-abstract-string-class+)
    776                             (VECTOR     +lisp-abstract-vector-class+)))
     497                            (SYMBOL     +lisp-symbol+)
     498                            (CHARACTER  +lisp-character+)
     499                            (CONS       +lisp-cons+)
     500                            (HASH-TABLE +lisp-hash-table+)
     501                            (FIXNUM     +lisp-fixnum+)
     502                            (STREAM     +lisp-stream+)
     503                            (STRING     +lisp-abstract-string+)
     504                            (VECTOR     +lisp-abstract-vector+)))
    777505        (expected-type-java-symbol-name (case expected-type
    778506                                          (HASH-TABLE "HASH_TABLE")
     
    781509        (LABEL1 (gensym)))
    782510    (emit-load-local-variable variable)
    783     (emit 'instanceof instanceof-class)
     511    (emit-instanceof instanceof-class)
    784512    (emit 'ifne LABEL1)
    785513    (emit-load-local-variable variable)
    786     (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name
     514    (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name
    787515          +lisp-symbol+)
    788     (emit-invokestatic +lisp-class+ "type_error"
     516    (emit-invokestatic +lisp+ "type_error"
    789517                       (lisp-object-arg-types 2) +lisp-object+)
    790     (emit 'pop) ; Needed for JVM stack consistency.
     518    (emit 'areturn) ; Needed for JVM stack consistency.
    791519    (label LABEL1))
    792520  t)
     
    844572  (unless (> *speed* *safety*)
    845573    (let ((label1 (gensym)))
    846       (emit-getstatic +lisp-class+ "interrupted" "Z")
     574      (emit-getstatic +lisp+ "interrupted" :boolean)
    847575      (emit 'ifeq label1)
    848       (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil)
     576      (emit-invokestatic +lisp+ "handleInterrupt" nil nil)
    849577      (label label1))))
    850578
     
    900628  (declare (optimize speed (safety 0)))
    901629  (ensure-thread-var-initialized)
    902   (emit 'clear-values))
     630  (emit 'clear-values *thread*))
    903631
    904632(defknown maybe-emit-clear-values (&rest t) t)
     
    908636    (unless (single-valued-p form)
    909637      (ensure-thread-var-initialized)
    910       (emit 'clear-values)
     638      (emit 'clear-values *thread*)
    911639      (return))))
    912640
     
    922650  (declare (optimize speed))
    923651  (cond ((= *safety* 3)
    924          (emit-invokestatic +lisp-fixnum-class+ "getValue"
    925                             (lisp-object-arg-types 1) "I"))
     652         (emit-invokestatic +lisp-fixnum+ "getValue"
     653                            (lisp-object-arg-types 1) :int))
    926654        (t
    927          (emit 'checkcast +lisp-fixnum-class+)
    928          (emit 'getfield +lisp-fixnum-class+ "value" "I"))))
     655         (emit-checkcast +lisp-fixnum+)
     656         (emit-getfield +lisp-fixnum+ "value" :int))))
    929657
    930658(defknown emit-unbox-long () t)
    931659(defun emit-unbox-long ()
    932   (emit-invokestatic +lisp-bignum-class+ "longValue"
    933                      (lisp-object-arg-types 1) "J"))
     660  (emit-invokestatic +lisp-bignum+ "longValue"
     661                     (lisp-object-arg-types 1) :long))
    934662
    935663(defknown emit-unbox-float () t)
     
    937665  (declare (optimize speed))
    938666  (cond ((= *safety* 3)
    939          (emit-invokestatic +lisp-single-float-class+ "getValue"
    940                             (lisp-object-arg-types 1) "F"))
     667         (emit-invokestatic +lisp-single-float+ "getValue"
     668                            (lisp-object-arg-types 1) :float))
    941669        (t
    942          (emit 'checkcast +lisp-single-float-class+)
    943          (emit 'getfield +lisp-single-float-class+ "value" "F"))))
     670         (emit-checkcast +lisp-single-float+)
     671         (emit-getfield +lisp-single-float+ "value" :float))))
    944672
    945673(defknown emit-unbox-double () t)
     
    947675  (declare (optimize speed))
    948676  (cond ((= *safety* 3)
    949          (emit-invokestatic +lisp-double-float-class+ "getValue"
    950                             (lisp-object-arg-types 1) "D"))
     677         (emit-invokestatic +lisp-double-float+ "getValue"
     678                            (lisp-object-arg-types 1) :double))
    951679        (t
    952          (emit 'checkcast +lisp-double-float-class+)
    953          (emit 'getfield +lisp-double-float-class+ "value" "D"))))
     680         (emit-checkcast +lisp-double-float+)
     681         (emit-getfield +lisp-double-float+ "value" :double))))
    954682
    955683(defknown fix-boxing (t t) t)
     
    961689         (cond ((and (fixnum-type-p derived-type)
    962690                     (< *safety* 3))
    963                 (emit 'checkcast +lisp-fixnum-class+)
    964                 (emit 'getfield +lisp-fixnum-class+ "value" "I"))
     691                (emit-checkcast +lisp-fixnum+)
     692                (emit-getfield +lisp-fixnum+ "value" :int))
    965693               (t
    966                 (emit-invokevirtual +lisp-object-class+ "intValue" nil "I"))))
     694                (emit-invokevirtual +lisp-object+ "intValue" nil :int))))
    967695        ((eq required-representation :char)
    968696         (emit-unbox-character))
     
    970698         (emit-unbox-boolean))
    971699        ((eq required-representation :long)
    972          (emit-invokevirtual +lisp-object-class+ "longValue" nil "J"))
     700         (emit-invokevirtual +lisp-object+ "longValue" nil :long))
    973701        ((eq required-representation :float)
    974          (emit-invokevirtual +lisp-object-class+ "floatValue" nil "F"))
     702         (emit-invokevirtual +lisp-object+ "floatValue" nil :float))
    975703        ((eq required-representation :double)
    976          (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D"))
     704         (emit-invokevirtual +lisp-object+ "doubleValue" nil :double))
    977705        (t (assert nil))))
    978706
     
    1004732(defknown emit-invoke-method (t t t) t)
    1005733(defun emit-invoke-method (method-name target representation)
    1006   (emit-invokevirtual +lisp-object-class+ method-name nil +lisp-object+)
     734  (emit-invokevirtual +lisp-object+ method-name nil +lisp-object+)
    1007735  (fix-boxing representation nil)
    1008736  (emit-move-from-stack target representation))
     
    1040768  (check-number-of-args form n t))
    1041769
    1042 (defun unsupported-opcode (instruction)
    1043   (error "Unsupported opcode ~D." (instruction-opcode instruction)))
    1044 
    1045 (declaim (type hash-table +resolvers+))
    1046 (defconst +resolvers+ (make-hash-table))
    1047 
    1048 (defun initialize-resolvers ()
    1049   (let ((ht +resolvers+))
    1050     (dotimes (n (1+ *last-opcode*))
    1051       (setf (gethash n ht) #'unsupported-opcode))
    1052     ;; The following opcodes resolve to themselves.
    1053     (dolist (n '(0 ; nop
    1054                  1 ; aconst_null
    1055                  2 ; iconst_m1
    1056                  3 ; iconst_0
    1057                  4 ; iconst_1
    1058                  5 ; iconst_2
    1059                  6 ; iconst_3
    1060                  7 ; iconst_4
    1061                  8 ; iconst_5
    1062                  9 ; lconst_0
    1063                  10 ; lconst_1
    1064                  11 ; fconst_0
    1065                  12 ; fconst_1
    1066                  13 ; fconst_2
    1067                  14 ; dconst_0
    1068                  15 ; dconst_1
    1069                  42 ; aload_0
    1070                  43 ; aload_1
    1071                  44 ; aload_2
    1072                  45 ; aload_3
    1073                  46 ; iaload
    1074                  47 ; laload
    1075                  48 ; faload
    1076                  49 ; daload
    1077                  50 ; aaload
    1078                  75 ; astore_0
    1079                  76 ; astore_1
    1080                  77 ; astore_2
    1081                  78 ; astore_3
    1082                  79 ; iastore
    1083                  80 ; lastore
    1084                  81 ; fastore
    1085                  82 ; dastore
    1086                  83 ; aastore
    1087                  87 ; pop
    1088                  88 ; pop2
    1089                  89 ; dup
    1090                  90 ; dup_x1
    1091                  91 ; dup_x2
    1092                  92 ; dup2
    1093                  93 ; dup2_x1
    1094                  94 ; dup2_x2
    1095                  95 ; swap
    1096                  96 ; iadd
    1097                  97 ; ladd
    1098                  98 ; fadd
    1099                  99 ; dadd
    1100                  100 ; isub
    1101                  101 ; lsub
    1102                  102 ; fsub
    1103                  103 ; dsub
    1104                  104 ; imul
    1105                  105 ; lmul
    1106                  106 ; fmul
    1107                  107 ; dmul
    1108                  116 ; ineg
    1109                  117 ; lneg
    1110                  118 ; fneg
    1111                  119 ; dneg
    1112                  120 ; ishl
    1113                  121 ; lshl
    1114                  122 ; ishr
    1115                  123 ; lshr
    1116                  126 ; iand
    1117                  127 ; land
    1118                  128 ; ior
    1119                  129 ; lor
    1120                  130 ; ixor
    1121                  131 ; lxor
    1122                  133 ; i2l
    1123                  134 ; i2f
    1124                  135 ; i2d
    1125                  136 ; l2i
    1126                  137 ; l2f
    1127                  138 ; l2d
    1128                  141 ; f2d
    1129                  144 ; d2f
    1130                  148 ; lcmp
    1131                  149 ; fcmpd
    1132                  150 ; fcmpg
    1133                  151 ; dcmpd
    1134                  152 ; dcmpg
    1135                  153 ; ifeq
    1136                  154 ; ifne
    1137                  155 ; ifge
    1138                  156 ; ifgt
    1139                  157 ; ifgt
    1140                  158 ; ifle
    1141                  159 ; if_icmpeq
    1142                  160 ; if_icmpne
    1143                  161 ; if_icmplt
    1144                  162 ; if_icmpge
    1145                  163 ; if_icmpgt
    1146                  164 ; if_icmple
    1147                  165 ; if_acmpeq
    1148                  166 ; if_acmpne
    1149                  167 ; goto
    1150                  176 ; areturn
    1151                  177 ; return
    1152                  190 ; arraylength
    1153                  191 ; athrow
    1154                  194 ; monitorenter
    1155                  195 ; monitorexit
    1156                  198 ; ifnull
    1157                  202 ; label
    1158                  ))
    1159       (setf (gethash n ht) nil))))
    1160 
    1161 (initialize-resolvers)
    1162 
    1163 (defmacro define-resolver (opcodes args &body body)
    1164   (let ((name (gensym)))
    1165     `(progn
    1166        (defun ,name ,args ,@body)
    1167        (eval-when (:load-toplevel :execute)
    1168    ,(if (listp opcodes)
    1169         `(dolist (op ',opcodes)
    1170      (setf (gethash op +resolvers+) (symbol-function ',name)))
    1171         `(setf (gethash ,opcodes +resolvers+) (symbol-function ',name)))))))
    1172 
    1173 (defun load/store-resolver (instruction inst-index inst-index2 error-text)
    1174  (let* ((args (instruction-args instruction))
    1175         (index (car args)))
    1176    (declare (type (unsigned-byte 16) index))
    1177    (cond ((<= 0 index 3)
    1178           (inst (+ index inst-index)))
    1179          ((<= 0 index 255)
    1180           (inst inst-index2 index))
    1181          (t
    1182           (error error-text)))))
    1183 
    1184 ;; aload
    1185 (define-resolver 25 (instruction)
    1186   (load/store-resolver instruction 42 25 "ALOAD unsupported case"))
    1187 
    1188 ;; astore
    1189 (define-resolver 58 (instruction)
    1190   (load/store-resolver instruction 75 58 "ASTORE unsupported case"))
    1191 
    1192 ;; iload
    1193 (define-resolver 21 (instruction)
    1194   (load/store-resolver instruction 26 21 "ILOAD unsupported case"))
    1195 
    1196 ;; istore
    1197 (define-resolver 54 (instruction)
    1198   (load/store-resolver instruction 59 54 "ISTORE unsupported case"))
    1199 
    1200 ;; lload
    1201 (define-resolver 22 (instruction)
    1202   (load/store-resolver instruction 30 22 "LLOAD unsupported case"))
    1203 
    1204 ;; lstore
    1205 (define-resolver 55 (instruction)
    1206   (load/store-resolver instruction 63 55 "LSTORE unsupported case"))
    1207 
    1208 ;; getstatic, putstatic
    1209 (define-resolver (178 179) (instruction)
    1210   ;; we used to create the pool-field here; that moved to the emit-* layer
    1211   instruction)
    1212 
    1213 ;; bipush, sipush
    1214 (define-resolver (16 17) (instruction)
    1215   (let* ((args (instruction-args instruction))
    1216          (n (first args)))
    1217     (declare (type fixnum n))
    1218     (cond ((<= 0 n 5)
    1219            (inst (+ n 3)))
    1220           ((<= -128 n 127)
    1221            (inst 16 (logand n #xff))) ; BIPUSH
    1222           (t ; SIPUSH
    1223            (inst 17 (s2 n))))))
    1224 
    1225 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
    1226 (define-resolver (182 183 184) (instruction)
    1227   ;; we used to create the pool-method here; that moved to the emit-* layer
    1228   instruction)
    1229 
    1230 ;; ldc
    1231 (define-resolver 18 (instruction)
    1232   (let* ((args (instruction-args instruction)))
    1233     (unless (= (length args) 1)
    1234       (error "Wrong number of args for LDC."))
    1235     (if (> (car args) 255)
    1236         (inst 19 (u2 (car args))) ; LDC_W
    1237         (inst 18 args))))
    1238 
    1239 ;; ldc2_w
    1240 (define-resolver 20 (instruction)
    1241   (let* ((args (instruction-args instruction)))
    1242     (unless (= (length args) 1)
    1243       (error "Wrong number of args for LDC2_W."))
    1244     (inst 20 (u2 (car args)))))
    1245 
    1246 ;; getfield, putfield class-name field-name type-name
    1247 (define-resolver (180 181) (instruction)
    1248   (let* ((args (instruction-args instruction))
    1249          (index (pool-field (first args) (second args) (third args))))
    1250     (inst (instruction-opcode instruction) (u2 index))))
    1251 
    1252 ;; new, anewarray, checkcast, instanceof class-name
    1253 (define-resolver (187 189 192 193) (instruction)
    1254   (let* ((args (instruction-args instruction))
    1255          (index (pool-class (first args))))
    1256     (inst (instruction-opcode instruction) (u2 index))))
    1257 
    1258 ;; iinc
    1259 (define-resolver 132 (instruction)
    1260   (let* ((args (instruction-args instruction))
    1261          (register (first args))
    1262          (n (second args)))
    1263     (when (not (<= -128 n 127))
    1264       (error "IINC argument ~A out of bounds." n))
    1265     (inst 132 (list register (s1 n)))))
    1266 
    1267 (defknown resolve-instruction (t) t)
    1268 (defun resolve-instruction (instruction)
    1269   (declare (optimize speed))
    1270   (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
    1271     (if resolver
    1272         (funcall resolver instruction)
    1273         instruction)))
    1274 
    1275 (defun resolve-instructions (code)
    1276   (let ((vector (make-array 512 :fill-pointer 0 :adjustable t)))
    1277     (dotimes (index (length code) vector)
    1278       (declare (type (unsigned-byte 16) index))
    1279       (let ((instruction (svref code index)))
    1280         (case (instruction-opcode instruction)
    1281           (205 ; CLEAR-VALUES
    1282            (let ((instructions
    1283                   (list
    1284                    (inst 'aload *thread*)
    1285                    (inst 'aconst_null)
    1286                    (inst 'putfield (list +lisp-thread-class+ "_values"
    1287                                          +lisp-object-array+)))))
    1288              (dolist (instruction instructions)
    1289                (vector-push-extend (resolve-instruction instruction) vector))))
    1290           (t
    1291            (vector-push-extend (resolve-instruction instruction) vector)))))))
    1292 
    1293 (declaim (ftype (function (t) t) branch-opcode-p))
    1294 (declaim (inline branch-opcode-p))
    1295 (defun branch-opcode-p (opcode)
    1296   (declare (optimize speed))
    1297   (declare (type '(integer 0 255) opcode))
    1298   (or (<= 153 opcode 168)
    1299       (= opcode 198)))
    1300 
    1301 (declaim (ftype (function (t t t) t) walk-code))
    1302 (defun walk-code (code start-index depth)
    1303   (declare (optimize speed))
    1304   (declare (type fixnum start-index depth))
    1305   (do* ((i start-index (1+ i))
    1306         (limit (length code)))
    1307        ((>= i limit))
    1308     (declare (type fixnum i limit))
    1309     (let* ((instruction (aref code i))
    1310            (instruction-depth (instruction-depth instruction))
    1311            (instruction-stack (instruction-stack instruction)))
    1312       (declare (type fixnum instruction-stack))
    1313       (when instruction-depth
    1314         (unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack)))
    1315           (internal-compiler-error
    1316            "Stack inconsistency detected in ~A at index ~D: found ~S, expected ~S."
    1317            (compiland-name *current-compiland*)
    1318            i instruction-depth (+ depth instruction-stack)))
    1319         (return-from walk-code))
    1320       (let ((opcode (instruction-opcode instruction)))
    1321         (setf depth (+ depth instruction-stack))
    1322         (setf (instruction-depth instruction) depth)
    1323         (when (branch-opcode-p opcode)
    1324           (let ((label (car (instruction-args instruction))))
    1325             (declare (type symbol label))
    1326             (walk-code code (symbol-value label) depth)))
    1327         (when (member opcode '(167 176 191)) ; GOTO ARETURN ATHROW
    1328           ;; Current path ends.
    1329           (return-from walk-code))))))
    1330 
    1331 (declaim (ftype (function () t) analyze-stack))
    1332 (defun analyze-stack ()
    1333   (declare (optimize speed))
    1334   (let* ((code *code*)
    1335          (code-length (length code)))
    1336     (declare (type vector code))
    1337     (dotimes (i code-length)
    1338       (declare (type (unsigned-byte 16) i))
    1339       (let* ((instruction (aref code i))
    1340              (opcode (instruction-opcode instruction)))
    1341         (when (eql opcode 202) ; LABEL
    1342           (let ((label (car (instruction-args instruction))))
    1343             (set label i)))
    1344         (if (instruction-stack instruction)
    1345             (when (opcode-stack-effect opcode)
    1346               (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode))
    1347                 (sys::%format t "instruction-stack = ~S opcode-stack-effect = ~S~%"
    1348                          (instruction-stack instruction)
    1349                          (opcode-stack-effect opcode))
    1350                 (sys::%format t "index = ~D instruction = ~A~%" i (print-instruction instruction))))
    1351             (setf (instruction-stack instruction) (opcode-stack-effect opcode)))
    1352         (unless (instruction-stack instruction)
    1353           (sys::%format t "no stack information for instruction ~D~%" (instruction-opcode instruction))
    1354           (aver nil))))
    1355     (walk-code code 0 0)
    1356     (dolist (handler *handlers*)
    1357       ;; Stack depth is always 1 when handler is called.
    1358       (walk-code code (symbol-value (handler-code handler)) 1))
    1359     (let ((max-stack 0))
    1360       (declare (type fixnum max-stack))
    1361       (dotimes (i code-length)
    1362         (declare (type (unsigned-byte 16) i))
    1363         (let* ((instruction (aref code i))
    1364                (instruction-depth (instruction-depth instruction)))
    1365           (when instruction-depth
    1366             (setf max-stack (max max-stack (the fixnum instruction-depth))))))
    1367       max-stack)))
    1368 
    1369 
    1370 (defun finalize-code ()
    1371   (setf *code* (nreverse (coerce *code* 'vector))))
    1372 
    1373 (defun print-code ()
    1374   (dotimes (i (length *code*))
    1375     (let ((instruction (elt *code* i)))
    1376       (sys::%format t "~D ~A ~S ~S ~S~%"
    1377                     i
    1378                     (opcode-name (instruction-opcode instruction))
    1379                     (instruction-args instruction)
    1380                     (instruction-stack instruction)
    1381                     (instruction-depth instruction)))))
    1382 
    1383 (defun print-code2 (code)
    1384   (dotimes (i (length code))
    1385     (let ((instruction (elt code i)))
    1386       (case (instruction-opcode instruction)
    1387         (202 ; LABEL
    1388          (format t "~A:~%" (car (instruction-args instruction))))
    1389         (t
    1390          (format t "~8D:   ~A ~S~%"
    1391                  i
    1392                  (opcode-name (instruction-opcode instruction))
    1393                  (instruction-args instruction)))))))
    1394 
    1395 (declaim (ftype (function (t) boolean) label-p))
    1396 (defun label-p (instruction)
    1397   (and instruction
    1398        (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
    1399 
    1400 (declaim (ftype (function (t) t) instruction-label))
    1401 (defun instruction-label (instruction)
    1402   (and instruction
    1403        (= (instruction-opcode (the instruction instruction)) 202)
    1404        (car (instruction-args instruction))))
    1405 
    1406 ;; Remove unused labels.
    1407 (defun optimize-1 ()
    1408   (let ((code (coerce *code* 'vector))
    1409         (changed nil)
    1410         (marker (gensym)))
    1411     ;; Mark the labels that are actually branched to.
    1412     (dotimes (i (length code))
    1413       (declare (type (unsigned-byte 16) i))
    1414       (let ((instruction (aref code i)))
    1415         (when (branch-opcode-p (instruction-opcode instruction))
    1416           (let ((label (car (instruction-args instruction))))
    1417             (set label marker)))))
    1418     ;; Add labels used for exception handlers.
    1419     (dolist (handler *handlers*)
    1420       (set (handler-from handler) marker)
    1421       (set (handler-to handler) marker)
    1422       (set (handler-code handler) marker))
    1423     ;; Remove labels that are not used as branch targets.
    1424     (dotimes (i (length code))
    1425       (declare (type (unsigned-byte 16) i))
    1426       (let ((instruction (aref code i)))
    1427         (when (= (instruction-opcode instruction) 202) ; LABEL
    1428           (let ((label (car (instruction-args instruction))))
    1429             (declare (type symbol label))
    1430             (unless (eq (symbol-value label) marker)
    1431               (setf (aref code i) nil)
    1432               (setf changed t))))))
    1433     (when changed
    1434       (setf *code* (delete nil code))
    1435       t)))
    1436 
    1437 (defun optimize-2 ()
    1438   (let* ((code (coerce *code* 'vector))
    1439          (length (length code))
    1440          (changed nil))
    1441     (declare (type (unsigned-byte 16) length))
    1442     ;; Since we're looking at this instruction and the next one, we can stop
    1443     ;; one before the end.
    1444     (dotimes (i (1- length))
    1445       (declare (type (unsigned-byte 16) i))
    1446       (let ((instruction (aref code i)))
    1447         (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
    1448           (do* ((j (1+ i) (1+ j))
    1449                 (next-instruction (aref code j) (aref code j)))
    1450                ((>= j length))
    1451             (declare (type (unsigned-byte 16) j))
    1452             (when next-instruction
    1453               (cond ((= (instruction-opcode next-instruction) 167) ; GOTO
    1454                      (cond ((= j (1+ i))
    1455                             ;; Two GOTOs in a row: the second instruction is
    1456                             ;; unreachable.
    1457                             (setf (aref code j) nil)
    1458                             (setf changed t))
    1459                            ((eq (car (instruction-args next-instruction))
    1460                                 (car (instruction-args instruction)))
    1461                             ;; We've reached another GOTO to the same destination.
    1462                             ;; We don't need the first GOTO; we can just fall
    1463                             ;; through to the second one.
    1464                             (setf (aref code i) nil)
    1465                             (setf changed t)))
    1466                      (return))
    1467                     ((= (instruction-opcode next-instruction) 202) ; LABEL
    1468                      (when (eq (car (instruction-args instruction))
    1469                                (car (instruction-args next-instruction)))
    1470                        ;; GOTO next instruction; we don't need this one.
    1471                        (setf (aref code i) nil)
    1472                        (setf changed t)
    1473                        (return)))
    1474                     (t
    1475                      ;; Not a GOTO or a label.
    1476                      (return))))))))
    1477     (when changed
    1478       (setf *code* (delete nil code))
    1479       t)))
    1480 
    1481 (declaim (ftype (function (t) hash-table) hash-labels))
    1482 (defun hash-labels (code)
    1483   (let ((ht (make-hash-table :test 'eq))
    1484         (code (coerce code 'vector))
    1485         (pending-labels '()))
    1486     (dotimes (i (length code))
    1487       (declare (type (unsigned-byte 16) i))
    1488       (let ((instruction (aref code i)))
    1489         (cond ((label-p instruction)
    1490                (push (instruction-label instruction) pending-labels))
    1491               (t
    1492                ;; Not a label.
    1493                (when pending-labels
    1494                  (dolist (label pending-labels)
    1495                    (setf (gethash label ht) instruction))
    1496                  (setf pending-labels nil))))))
    1497     ht))
    1498 
    1499 (defun optimize-2b ()
    1500   (let* ((code (coerce *code* 'vector))
    1501          (ht (hash-labels code))
    1502          (changed nil))
    1503     (dotimes (i (length code))
    1504       (declare (type (unsigned-byte 16) i))
    1505       (let ((instruction (aref code i)))
    1506         (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
    1507           (let* ((target-label (car (instruction-args instruction)))
    1508                  (next-instruction (gethash1 target-label ht)))
    1509             (when next-instruction
    1510               (case (instruction-opcode next-instruction)
    1511                 (167 ; GOTO
    1512                  (setf (instruction-args instruction)
    1513                        (instruction-args next-instruction)
    1514                        changed t))
    1515                 (176 ; ARETURN
    1516                  (setf (instruction-opcode instruction) 176
    1517                        (instruction-args instruction) nil
    1518                        changed t))))))))
    1519     (when changed
    1520       (setf *code* code)
    1521       t)))
    1522 
    1523 ;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
    1524 ;; GETSTATIC POP => nothing
    1525 (defun optimize-3 ()
    1526   (let* ((code (coerce *code* 'vector))
    1527          (changed nil))
    1528     (dotimes (i (1- (length code)))
    1529       (declare (type (unsigned-byte 16) i))
    1530       (let* ((this-instruction (aref code i))
    1531              (this-opcode (and this-instruction (instruction-opcode this-instruction)))
    1532              (next-instruction (aref code (1+ i)))
    1533              (next-opcode (and next-instruction (instruction-opcode next-instruction))))
    1534         (case this-opcode
    1535           (205 ; CLEAR-VALUES
    1536            (when (eql next-opcode 205) ; CLEAR-VALUES
    1537              (setf (aref code i) nil)
    1538              (setf changed t)))
    1539           (178 ; GETSTATIC
    1540            (when (eql next-opcode 87) ; POP
    1541              (setf (aref code i) nil)
    1542              (setf (aref code (1+ i)) nil)
    1543              (setf changed t))))))
    1544     (when changed
    1545       (setf *code* (delete nil code))
    1546       t)))
    1547 
    1548 (defun delete-unreachable-code ()
    1549   ;; Look for unreachable code after GOTO.
    1550   (let* ((code (coerce *code* 'vector))
    1551          (changed nil)
    1552          (after-goto/areturn nil))
    1553     (dotimes (i (length code))
    1554       (declare (type (unsigned-byte 16) i))
    1555       (let* ((instruction (aref code i))
    1556              (opcode (instruction-opcode instruction)))
    1557         (cond (after-goto/areturn
    1558                (if (= opcode 202) ; LABEL
    1559                    (setf after-goto/areturn nil)
    1560                    ;; Unreachable.
    1561                    (progn
    1562                      (setf (aref code i) nil)
    1563                      (setf changed t))))
    1564               ((= opcode 176) ; ARETURN
    1565                (setf after-goto/areturn t))
    1566               ((= opcode 167) ; GOTO
    1567                (setf after-goto/areturn t)))))
    1568     (when changed
    1569       (setf *code* (delete nil code))
    1570       t)))
    1571 
    1572 (defvar *enable-optimization* t)
    1573 
    1574 (defknown optimize-code () t)
    1575 (defun optimize-code ()
    1576   (unless *enable-optimization*
    1577     (format t "optimizations are disabled~%"))
    1578   (when *enable-optimization*
    1579     (when *compiler-debug*
    1580       (format t "----- before optimization -----~%")
    1581       (print-code))
    1582     (loop
    1583       (let ((changed-p nil))
    1584         (setf changed-p (or (optimize-1) changed-p))
    1585         (setf changed-p (or (optimize-2) changed-p))
    1586         (setf changed-p (or (optimize-2b) changed-p))
    1587         (setf changed-p (or (optimize-3) changed-p))
    1588         (setf changed-p (or (delete-unreachable-code) changed-p))
    1589         (unless changed-p
    1590           (return))))
    1591     (unless (vectorp *code*)
    1592       (setf *code* (coerce *code* 'vector)))
    1593     (when *compiler-debug*
    1594       (sys::%format t "----- after optimization -----~%")
    1595       (print-code)))
    1596   t)
    1597 
    1598 (defun code-bytes (code)
    1599   (let ((length 0))
    1600     (declare (type (unsigned-byte 16) length))
    1601     ;; Pass 1: calculate label offsets and overall length.
    1602     (dotimes (i (length code))
    1603       (declare (type (unsigned-byte 16) i))
    1604       (let* ((instruction (aref code i))
    1605              (opcode (instruction-opcode instruction)))
    1606         (if (= opcode 202) ; LABEL
    1607             (let ((label (car (instruction-args instruction))))
    1608               (set label length))
    1609             (incf length (opcode-size opcode)))))
    1610     ;; Pass 2: replace labels with calculated offsets.
    1611     (let ((index 0))
    1612       (declare (type (unsigned-byte 16) index))
    1613       (dotimes (i (length code))
    1614         (declare (type (unsigned-byte 16) i))
    1615         (let ((instruction (aref code i)))
    1616           (when (branch-opcode-p (instruction-opcode instruction))
    1617             (let* ((label (car (instruction-args instruction)))
    1618                    (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
    1619               (setf (instruction-args instruction) (s2 offset))))
    1620           (unless (= (instruction-opcode instruction) 202) ; LABEL
    1621             (incf index (opcode-size (instruction-opcode instruction)))))))
    1622     ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
    1623     (let ((bytes (make-array length))
    1624           (index 0))
    1625       (declare (type (unsigned-byte 16) index))
    1626       (dotimes (i (length code))
    1627         (declare (type (unsigned-byte 16) i))
    1628         (let ((instruction (aref code i)))
    1629           (unless (= (instruction-opcode instruction) 202) ; LABEL
    1630             (setf (svref bytes index) (instruction-opcode instruction))
    1631             (incf index)
    1632             (dolist (byte (instruction-args instruction))
    1633               (setf (svref bytes index) byte)
    1634               (incf index)))))
    1635       bytes)))
    1636 
    1637 (declaim (inline write-u1))
    1638 (defun write-u1 (n stream)
    1639   (declare (optimize speed))
    1640   (declare (type (unsigned-byte 8) n))
    1641   (declare (type stream stream))
    1642   (write-8-bits n stream))
    1643 
    1644 (defknown write-u2 (t t) t)
    1645 (defun write-u2 (n stream)
    1646   (declare (optimize speed))
    1647   (declare (type (unsigned-byte 16) n))
    1648   (declare (type stream stream))
    1649   (write-8-bits (logand (ash n -8) #xFF) stream)
    1650   (write-8-bits (logand n #xFF) stream))
    1651 
    1652 (defknown write-u4 (integer stream) t)
    1653 (defun write-u4 (n stream)
    1654   (declare (optimize speed))
    1655   (declare (type (unsigned-byte 32) n))
    1656   (write-u2 (logand (ash n -16) #xFFFF) stream)
    1657   (write-u2 (logand n #xFFFF) stream))
    1658 
    1659 (declaim (ftype (function (t t) t) write-s4))
    1660 (defun write-s4 (n stream)
    1661   (declare (optimize speed))
    1662   (cond ((minusp n)
    1663          (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
    1664         (t
    1665          (write-u4 n stream))))
    1666 
    1667 (declaim (ftype (function (t t t) t) write-ascii))
    1668 (defun write-ascii (string length stream)
    1669   (declare (type string string))
    1670   (declare (type (unsigned-byte 16) length))
    1671   (declare (type stream stream))
    1672   (write-u2 length stream)
    1673   (dotimes (i length)
    1674     (declare (type (unsigned-byte 16) i))
    1675     (write-8-bits (char-code (char string i)) stream)))
    1676 
    1677 (declaim (ftype (function (t t) t) write-utf8))
    1678 (defun write-utf8 (string stream)
    1679   (declare (optimize speed))
    1680   (declare (type string string))
    1681   (declare (type stream stream))
    1682   (let ((length (length string))
    1683         (must-convert nil))
    1684     (declare (type fixnum length))
    1685     (dotimes (i length)
    1686       (declare (type fixnum i))
    1687       (unless (< 0 (char-code (char string i)) #x80)
    1688         (setf must-convert t)
    1689         (return)))
    1690     (if must-convert
    1691         (let ((octets (make-array (* length 2)
    1692                                   :element-type '(unsigned-byte 8)
    1693                                   :adjustable t
    1694                                   :fill-pointer 0)))
    1695           (declare (type (vector (unsigned-byte 8)) octets))
    1696           (dotimes (i length)
    1697             (declare (type fixnum i))
    1698             (let* ((c (char string i))
    1699                    (n (char-code c)))
    1700               (cond ((zerop n)
    1701                      (vector-push-extend #xC0 octets)
    1702                      (vector-push-extend #x80 octets))
    1703                     ((< 0 n #x80)
    1704                      (vector-push-extend n octets))
    1705                     (t
    1706                      (let ((char-octets (char-to-utf8 c)))
    1707                        (dotimes (j (length char-octets))
    1708                          (declare (type fixnum j))
    1709                          (vector-push-extend (svref char-octets j) octets)))))))
    1710           (write-u2 (length octets) stream)
    1711           (dotimes (i (length octets))
    1712             (declare (type fixnum i))
    1713             (write-8-bits (aref octets i) stream)))
    1714         (write-ascii string length stream))))
    1715 
    1716 (defknown write-constant-pool-entry (t t) t)
    1717 (defun write-constant-pool-entry (entry stream)
    1718   (declare (optimize speed))
    1719   (declare (type stream stream))
    1720   (let ((tag (first entry)))
    1721     (declare (type (integer 1 12) tag))
    1722     (write-u1 tag stream)
    1723     (case tag
    1724       (1 ; UTF8
    1725        (write-utf8 (third entry) stream))
    1726       ((3 4) ; int
    1727        (write-u4 (second entry) stream))
    1728       ((5 6) ; long double
    1729        (write-u4 (second entry) stream)
    1730        (write-u4 (third entry) stream))
    1731       ((9 10 11 12) ; fieldref methodref InterfaceMethodref nameAndType
    1732        (write-u2 (second entry) stream)
    1733        (write-u2 (third entry) stream))
    1734       ((7 8) ; class string
    1735        (write-u2 (second entry) stream))
    1736       (t
    1737        (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))
    1738 
    1739 (defun write-constant-pool (stream)
    1740   (declare (optimize speed))
    1741   (write-u2 *pool-count* stream)
    1742   (dolist (entry (reverse *pool*))
    1743     (write-constant-pool-entry entry stream)))
    1744 
    1745 (defstruct (field (:constructor make-field (name descriptor)))
    1746   access-flags
    1747   name
    1748   descriptor
    1749   name-index
    1750   descriptor-index)
    1751 
    1752 (defstruct (java-method (:conc-name method-) (:constructor %make-method))
    1753   access-flags
    1754   name
    1755   descriptor
    1756   name-index
    1757   descriptor-index
    1758   max-stack
    1759   max-locals
    1760   code
    1761   handlers)
    1762 
    1763 (defun make-method (&rest args &key descriptor name
    1764                                     descriptor-index name-index
    1765                                &allow-other-keys)
    1766   (apply #'%make-method
    1767          (list* :descriptor-index (or descriptor-index (pool-name descriptor))
    1768                 :name-index (or name-index (pool-name name))
    1769                 args)))
     770
    1770771
    1771772(defun emit-constructor-lambda-name (lambda-name)
     
    1773774         (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name))))
    1774775         (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name)))))
    1775          (emit-invokestatic +lisp-class+ "internInPackage"
    1776                             (list +java-string+ +java-string+) +lisp-symbol+))
     776         (emit-invokestatic +lisp+ "internInPackage"
     777                            (list +java-string+ +java-string+)
     778                            +lisp-symbol+))
    1777779        (t
    1778780         ;; No name.
     
    1785787             (s (sys::%format nil "~S" lambda-list)))
    1786788        (emit 'ldc (pool-string s))
    1787         (emit-invokestatic +lisp-class+ "readObjectFromString"
     789        (emit-invokestatic +lisp+ "readObjectFromString"
    1788790                           (list +java-string+) +lisp-object+))
    1789791      (emit-push-nil)))
     
    1795797  (let* ((*compiler-debug* nil)
    1796798         ;; We don't normally need to see debugging output for constructors.
    1797          (constructor (make-method :name "<init>"
    1798                                    :descriptor "()V"))
     799         (method (make-method :constructor :void nil
     800                              :flags '(:public)))
     801         (code (method-add-code method))
    1799802         req-params-register
    1800803         opt-params-register
     
    1804807         more-keys-p
    1805808         (*code* ())
    1806          (*handlers* nil))
    1807     (setf (method-max-locals constructor) 1)
    1808     (unless (equal super +lisp-primitive-class+)
     809         (*current-code-attribute* code))
     810    (setf (code-max-locals code) 1)
     811    (unless (eq super +lisp-primitive+)
    1809812      (multiple-value-bind
    1810813            (req opt key key-p rest
     
    1819822                 `(progn
    1820823                    (emit-push-constant-int (length ,params))
    1821                     (emit 'anewarray +lisp-closure-parameter-class+)
    1822                     (astore (setf ,register (method-max-locals constructor)))
    1823                     (incf (method-max-locals constructor))
     824                    (emit-anewarray +lisp-closure-parameter+)
     825                    (astore (setf ,register (code-max-locals code)))
     826                    (incf (code-max-locals code))
    1824827                    (do* ((,count-sym 0 (1+ ,count-sym))
    1825828                          (,params ,params (cdr ,params))
     
    1829832                      (aload ,register)
    1830833                      (emit-push-constant-int ,count-sym)
    1831                       (emit 'new +lisp-closure-parameter-class+)
     834                      (emit-new +lisp-closure-parameter+)
    1832835                      (emit 'dup)
    1833836                      ,@body
     
    1836839          (parameters-to-array (ignore req req-params-register)
    1837840             (emit-push-t) ;; we don't need the actual symbol
    1838              (emit-invokespecial-init +lisp-closure-parameter-class+
     841             (emit-invokespecial-init +lisp-closure-parameter+
    1839842                                      (list +lisp-symbol+)))
    1840843
     
    1845848                 (emit-push-nil)
    1846849                 (emit-push-t)) ;; we don't need the actual supplied-p symbol
    1847              (emit-getstatic +lisp-closure-class+ "OPTIONAL" "I")
    1848              (emit-invokespecial-init +lisp-closure-parameter-class+
     850             (emit-getstatic +lisp-closure+ "OPTIONAL" :int)
     851             (emit-invokespecial-init +lisp-closure-parameter+
    1849852                                      (list +lisp-symbol+ +lisp-object+
    1850                                             +lisp-object+ "I")))
     853                                            +lisp-object+ :int)))
    1851854
    1852855          (parameters-to-array (param key key-params-register)
     
    1855858                   (progn
    1856859                     (emit 'ldc (pool-string (symbol-name keyword)))
    1857                      (emit-invokestatic +lisp-class+ "internKeyword"
     860                     (emit-invokestatic +lisp+ "internKeyword"
    1858861                                        (list +java-string+) +lisp-symbol+))
    1859862                   ;; symbol is not really a keyword; yes, that's allowed!
     
    1862865                     (emit 'ldc (pool-string
    1863866                                 (package-name (symbol-package keyword))))
    1864                      (emit-invokestatic +lisp-class+ "internInPackage"
     867                     (emit-invokestatic +lisp+ "internInPackage"
    1865868                                        (list +java-string+ +java-string+)
    1866869                                        +lisp-symbol+))))
     
    1870873                 (emit-push-nil)
    1871874                 (emit-push-t)) ;; we don't need the actual supplied-p symbol
    1872              (emit-invokespecial-init +lisp-closure-parameter-class+
     875             (emit-invokespecial-init +lisp-closure-parameter+
    1873876                                      (list +lisp-symbol+ +lisp-symbol+
    1874877                                            +lisp-object+ +lisp-object+))))))
    1875878    (aload 0) ;; this
    1876     (cond ((equal super +lisp-primitive-class+)
     879    (cond ((eq super +lisp-primitive+)
    1877880           (emit-constructor-lambda-name lambda-name)
    1878881           (emit-constructor-lambda-list args)
    1879882           (emit-invokespecial-init super (lisp-object-arg-types 2)))
    1880           ((equal super +lisp-compiled-closure-class+)
     883          ((equal super +lisp-compiled-closure+) ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
    1881884           (aload req-params-register)
    1882885           (aload opt-params-register)
     
    1901904    (setf *code* (append *static-code* *code*))
    1902905    (emit 'return)
    1903     (finalize-code)
    1904     (setf *code* (resolve-instructions *code*))
    1905     (setf (method-max-stack constructor) (analyze-stack))
    1906     (setf (method-code constructor) (code-bytes *code*))
    1907     (setf (method-handlers constructor) (nreverse *handlers*))
    1908     constructor))
    1909 
    1910 (defun write-exception-table (method stream)
    1911   (let ((handlers (method-handlers method)))
    1912     (write-u2 (length handlers) stream) ; number of entries
    1913     (dolist (handler handlers)
    1914       (write-u2 (symbol-value (handler-from handler)) stream)
    1915       (write-u2 (symbol-value (handler-to handler)) stream)
    1916       (write-u2 (symbol-value (handler-code handler)) stream)
    1917       (write-u2 (handler-catch-type handler) stream))))
    1918 
    1919 (defun write-source-file-attr (source-file stream)
    1920   (let* ((name-index (pool-name "SourceFile"))
    1921          (source-file-index (pool-name source-file)))
    1922     (write-u2 name-index stream)
    1923     ;; "The value of the attribute_length item of a SourceFile_attribute
    1924     ;; structure must be 2."
    1925     (write-u4 2 stream)
    1926     (write-u2 source-file-index stream)))
     906    (setf (code-code code) *code*)
     907    method))
     908
    1927909
    1928910(defvar *source-line-number* nil)
    1929911
    1930 (defun write-line-number-table (stream)
    1931   (let* ((name-index (pool-name "LineNumberTable")))
    1932     (write-u2 name-index stream)
    1933     (write-u4 6 stream) ; "the length of the attribute, excluding the initial six bytes"
    1934     (write-u2 1 stream) ; number of entries
    1935     (write-u2 0 stream) ; start_pc
    1936     (write-u2 *source-line-number* stream)))
    1937 
    1938 (defun write-code-attr (method stream)
    1939   (declare (optimize speed))
    1940   (declare (type stream stream))
    1941   (let* ((name-index (pool-name "Code"))
    1942          (code (method-code method))
    1943          (code-length (length code))
    1944          (line-number-available-p (and (fixnump *source-line-number*)
    1945                                        (plusp *source-line-number*)))
    1946          (length (+ code-length 12
    1947                     (* (length (method-handlers method)) 8)
    1948                     (if line-number-available-p 12 0)))
    1949          (max-stack (or (method-max-stack method) 20))
    1950          (max-locals (or (method-max-locals method) 1)))
    1951     (write-u2 name-index stream)
    1952     (write-u4 length stream)
    1953     (write-u2 max-stack stream)
    1954     (write-u2 max-locals stream)
    1955     (write-u4 code-length stream)
    1956     (dotimes (i code-length)
    1957       (declare (type index i))
    1958       (write-u1 (the (unsigned-byte 8) (svref code i)) stream))
    1959     (write-exception-table method stream)
    1960     (cond (line-number-available-p
    1961            ; attributes count
    1962            (write-u2 1 stream)
    1963            (write-line-number-table stream))
    1964           (t
    1965            ; attributes count
    1966            (write-u2 0 stream)))))
    1967 
    1968 (defun write-method (method stream)
    1969   (declare (optimize speed))
    1970   (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
    1971   (write-u2 (method-name-index method) stream)
    1972   (write-u2 (method-descriptor-index method) stream)
    1973   (write-u2 1 stream) ; attributes count
    1974   (write-code-attr method stream))
    1975 
    1976 (defun write-field (field stream)
    1977   (declare (optimize speed))
    1978   (write-u2 (or (field-access-flags field) #x1) stream) ; access flags
    1979   (write-u2 (field-name-index field) stream)
    1980   (write-u2 (field-descriptor-index field) stream)
    1981   (write-u2 0 stream)) ; attributes count
    1982 
    1983 (defconst +field-flag-final+       #x10) ;; final field
    1984 (defconst +field-flag-static+      #x08) ;; static field
    1985 (defconst +field-access-protected+ #x04) ;; subclass accessible
    1986 (defconst +field-access-private+   #x02) ;; class-only accessible
    1987 (defconst +field-access-public+    #x01) ;; generally accessible
    1988 (defconst +field-access-default+   #x00) ;; package accessible, used for LABELS
     912
     913(defun finish-class (class stream)
     914  "Finalizes the `class' and writes the result to `stream'.
     915
     916The compiler calls this function to indicate it doesn't want to
     917extend the class any further."
     918  (class-add-method class (make-constructor (class-file-superclass class)
     919                                            (abcl-class-file-lambda-name class)
     920                                            (abcl-class-file-lambda-list class)))
     921  (finalize-class-file class)
     922  (write-class-file class stream))
     923
    1989924
    1990925(defknown declare-field (t t t) t)
    1991 (defun declare-field (name descriptor access-flags)
    1992   (let ((field (make-field name descriptor)))
    1993     ;; final static <access-flags>
    1994     (setf (field-access-flags field)
    1995           (logior +field-flag-final+ +field-flag-static+ access-flags))
    1996     (setf (field-name-index field) (pool-name (field-name field)))
    1997     (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
    1998     (push field *fields*)))
     926(defun declare-field (name descriptor)
     927  (let ((field (make-field name descriptor
     928                           :flags '(:final :static :private))))
     929    (class-add-field *class-file* field)))
    1999930
    2000931(defknown sanitize (symbol) string)
     
    2043974  "Generates code to restore a serialized integer."
    2044975  (cond((<= 0 n 255)
    2045         (emit-getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
     976        (emit-getstatic +lisp-fixnum+ "constants" +lisp-fixnum-array+)
    2046977        (emit-push-constant-int n)
    2047978        (emit 'aaload))
    2048979       ((<= most-negative-fixnum n most-positive-fixnum)
    2049980        (emit-push-constant-int n)
    2050         (emit-invokestatic +lisp-fixnum-class+ "getInstance"
    2051                            '("I") +lisp-fixnum+))
     981        (emit-invokestatic +lisp-fixnum+ "getInstance"
     982                           '(:int) +lisp-fixnum+))
    2052983       ((<= most-negative-java-long n most-positive-java-long)
    2053984        (emit-push-constant-long n)
    2054         (emit-invokestatic +lisp-bignum-class+ "getInstance"
    2055                            '("J") +lisp-integer+))
     985        (emit-invokestatic +lisp-bignum+ "getInstance"
     986                           '(:long) +lisp-integer+))
    2056987       (t
    2057988        (let* ((*print-base* 10)
     
    2059990          (emit 'ldc (pool-string s))
    2060991          (emit-push-constant-int 10)
    2061           (emit-invokestatic +lisp-bignum-class+ "getInstance"
    2062                              (list +java-string+ "I") +lisp-integer+)))))
     992          (emit-invokestatic +lisp-bignum+ "getInstance"
     993                             (list +java-string+ :int) +lisp-integer+)))))
    2063994
    2064995(defun serialize-character (c)
    2065996  "Generates code to restore a serialized character."
    2066997  (emit-push-constant-int (char-code c))
    2067   (emit-invokestatic +lisp-character-class+ "getInstance" '("C")
     998  (emit-invokestatic +lisp-character+ "getInstance" '(:char)
    2068999                     +lisp-character+))
    20691000
    20701001(defun serialize-float (s)
    20711002  "Generates code to restore a serialized single-float."
    2072   (emit 'new +lisp-single-float-class+)
     1003  (emit-new +lisp-single-float+)
    20731004  (emit 'dup)
    20741005  (emit 'ldc (pool-float s))
    2075   (emit-invokespecial-init +lisp-single-float-class+ '("F")))
     1006  (emit-invokespecial-init +lisp-single-float+ '(:float)))
    20761007
    20771008(defun serialize-double (d)
    20781009  "Generates code to restore a serialized double-float."
    2079   (emit 'new +lisp-double-float-class+)
     1010  (emit-new +lisp-double-float+)
    20801011  (emit 'dup)
    20811012  (emit 'ldc2_w (pool-double d))
    2082   (emit-invokespecial-init +lisp-double-float-class+ '("D")))
     1013  (emit-invokespecial-init +lisp-double-float+ '(:double)))
    20831014
    20841015(defun serialize-string (string)
    20851016  "Generate code to restore a serialized string."
    2086   (emit 'new +lisp-simple-string-class+)
     1017  (emit-new +lisp-simple-string+)
    20871018  (emit 'dup)
    20881019  (emit 'ldc (pool-string string))
    2089   (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+)))
     1020  (emit-invokespecial-init +lisp-simple-string+ (list +java-string+)))
    20901021
    20911022(defun serialize-package (pkg)
     
    20931024  (emit 'ldc (pool-string (concatenate 'string "#.(FIND-PACKAGE \""
    20941025                                       (package-name pkg) "\")")))
    2095   (emit-invokestatic +lisp-class+ "readObjectFromString"
     1026  (emit-invokestatic +lisp+ "readObjectFromString"
    20961027                     (list +java-string+) +lisp-object+))
    20971028
     
    21021033             (dump-form object stream))))
    21031034    (emit 'ldc (pool-string s))
    2104     (emit-invokestatic +lisp-class+ "readObjectFromString"
     1035    (emit-invokestatic +lisp+ "readObjectFromString"
    21051036                       (list +java-string+) +lisp-object+)))
    21061037
     
    21151046      ((null (symbol-package symbol))
    21161047       (emit-push-constant-int (dump-uninterned-symbol-index symbol))
    2117        (emit-invokestatic +lisp-load-class+ "getUninternedSymbol" '("I")
     1048       (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int)
    21181049                          +lisp-object+)
    2119        (emit 'checkcast +lisp-symbol-class+))
     1050       (emit-checkcast +lisp-symbol+))
    21201051      ((keywordp symbol)
    21211052       (emit 'ldc (pool-string (symbol-name symbol)))
    2122        (emit-invokestatic +lisp-class+ "internKeyword"
     1053       (emit-invokestatic +lisp+ "internKeyword"
    21231054                          (list +java-string+) +lisp-symbol+))
    21241055      (t
    21251056       (emit 'ldc (pool-string (symbol-name symbol)))
    21261057       (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    2127        (emit-invokestatic +lisp-class+ "internInPackage"
     1058       (emit-invokestatic +lisp+ "internInPackage"
    21281059                          (list +java-string+ +java-string+)
    21291060                          +lisp-symbol+)))))
     
    214710785. The type of the field to save the serialized result to")
    21481079
    2149 (defknown emit-load-externalized-object (t) string)
     1080(defknown emit-load-externalized-object (t &optional t) string)
    21501081(defun emit-load-externalized-object (object &optional cast)
    21511082  "Externalizes `object' for use in a FASL.
     
    21761107        (emit-getstatic *this-class* (cdr existing) field-type)
    21771108        (when cast
    2178           (emit 'checkcast cast))
     1109          (emit-checkcast cast))
    21791110        (return-from emit-load-externalized-object field-type)))
    21801111
    21811112    ;; We need to set up the serialized value
    21821113    (let ((field-name (symbol-name (gensym prefix))))
    2183       (declare-field field-name field-type +field-access-private+)
     1114      (declare-field field-name field-type)
    21841115      (push (cons object field-name) *externalized-objects*)
    21851116
     
    21891120           (remember field-name object)
    21901121           (emit 'ldc (pool-string field-name))
    2191            (emit-invokestatic +lisp-class+ "recall"
     1122           (emit-invokestatic +lisp+ "recall"
    21921123                              (list +java-string+) +lisp-object+)
    2193            (when (string/= field-type +lisp-object+)
    2194              (emit 'checkcast (subseq field-type 1 (1- (length field-type)))))
     1124           (when (not (eq field-type +lisp-object+))
     1125             (emit-checkcast field-type))
    21951126           (emit-putstatic *this-class* field-name field-type)
    21961127           (setf *static-code* *code*)))
     
    22061137      (emit-getstatic *this-class* field-name field-type)
    22071138      (when cast
    2208         (emit 'checkcast cast))
     1139        (emit-checkcast cast))
    22091140      field-type)))
    22101141
     
    22181149     (when s
    22191150       (setf f (concatenate 'string f "_" s))))
    2220    (declare-field f +lisp-object+ +field-access-private+)
     1151   (declare-field f +lisp-object+)
    22211152   (multiple-value-bind
    22221153         (name class)
     
    22371168             (progn ;; generated by the DECLARE-OBJECT*'s above
    22381169               (emit-getstatic class name +lisp-object+)
    2239                (emit 'checkcast +lisp-symbol-class+))
     1170               (emit-checkcast +lisp-symbol+))
    22401171             (emit-getstatic class name +lisp-symbol+))
    2241          (emit-invokevirtual +lisp-symbol-class+
     1172         (emit-invokevirtual +lisp-symbol+
    22421173                             (if setf
    22431174                                 "getSymbolSetfFunctionOrDie"
     
    22461177         ;; make sure we're not cacheing a proxied function
    22471178         ;; (AutoloadedFunctionProxy) by allowing it to resolve itself
    2248          (emit-invokevirtual +lisp-object-class+
     1179         (emit-invokevirtual +lisp-object+
    22491180                             "resolve" nil +lisp-object+)
    22501181         (emit-putstatic *this-class* f +lisp-object+)
     
    22671198   local-function *declared-functions* ht g
    22681199   (setf g (symbol-name (gensym "LFUN")))
    2269    (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function)))
    2270     (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname)))
    2271     (*code* *static-code*))
     1200   (let* ((class-name (abcl-class-file-class-name
     1201                       (local-function-class-file local-function)))
     1202          (*code* *static-code*))
    22721203     ;; fixme *declare-inline*
    2273      (declare-field g +lisp-object+ +field-access-private+)
    2274      (emit 'new class-name)
     1204     (declare-field g +lisp-object+)
     1205     (emit-new class-name)
    22751206     (emit 'dup)
    22761207     (emit-invokespecial-init class-name '())
    2277 
    2278      ;(emit 'ldc (pool-string (pathname-name pathname)))
    2279      ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction"
    2280      ;(list +java-string+) +lisp-object+)
    2281 
    2282 ;     (emit 'ldc (pool-string (file-namestring pathname)))
    2283      
    2284 ;     (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction"
    2285 ;     (list +java-string+) +lisp-object+)
    22861208     (emit-putstatic *this-class* g +lisp-object+)
    22871209     (setf *static-code* *code*)
     
    23051227      ;; strings may contain evaluated bits which may depend on
    23061228      ;; previous statements
    2307       (declare-field g +lisp-object+ +field-access-private+)
     1229      (declare-field g +lisp-object+)
    23081230      (emit 'ldc (pool-string s))
    2309       (emit-invokestatic +lisp-class+ "readObjectFromString"
     1231      (emit-invokestatic +lisp+ "readObjectFromString"
    23101232                         (list +java-string+) +lisp-object+)
    23111233      (emit-putstatic *this-class* g +lisp-object+)
     
    23251247      ;; lisp code in the string (think #.() syntax), of which the outcome
    23261248      ;; may depend on something which was declared inline
    2327       (declare-field g +lisp-object+ +field-access-private+)
     1249      (declare-field g +lisp-object+)
    23281250      (emit 'ldc (pool-string s))
    2329       (emit-invokestatic +lisp-class+ "readObjectFromString"
     1251      (emit-invokestatic +lisp+ "readObjectFromString"
    23301252                         (list +java-string+) +lisp-object+)
    2331       (emit-invokestatic +lisp-class+ "loadTimeValue"
     1253      (emit-invokestatic +lisp+ "loadTimeValue"
    23321254                         (lisp-object-arg-types 1) +lisp-object+)
    23331255      (emit-putstatic *this-class* g +lisp-object+)
     
    23391261    g))
    23401262
    2341 (declaim (ftype (function (t &optional t) string) declare-object))
    2342 (defun declare-object (obj &optional (obj-ref +lisp-object+)
    2343                            obj-class)
     1263(declaim (ftype (function (t) string) declare-object))
     1264(defun declare-object (obj)
    23441265  "Stores the object OBJ in the object-lookup-table,
    23451266loading the object value into a field upon class-creation time.
     
    23501271    (remember g obj)
    23511272    (let* ((*code* *static-code*))
    2352       (declare-field g obj-ref +field-access-private+)
     1273      (declare-field g +lisp-object+)
    23531274      (emit 'ldc (pool-string g))
    2354       (emit-invokestatic +lisp-class+ "recall"
     1275      (emit-invokestatic +lisp+ "recall"
    23551276                         (list +java-string+) +lisp-object+)
    2356       (when (and obj-class (string/= obj-class +lisp-object-class+))
    2357         (emit 'checkcast obj-class))
    2358       (emit-putstatic *this-class* g obj-ref)
     1277      (emit-putstatic *this-class* g +lisp-object+)
    23591278      (setf *static-code* *code*)
    23601279      g)))
     
    23701289           ((integerp form)
    23711290            (emit-load-externalized-object form)
    2372             (emit-invokevirtual +lisp-object-class+ "intValue" nil "I"))
     1291            (emit-invokevirtual +lisp-object+ "intValue" nil :int))
    23731292           (t
    23741293            (sys::%format t "compile-constant int representation~%")
     
    23811300           ((integerp form)
    23821301            (emit-load-externalized-object form)
    2383             (emit-invokevirtual +lisp-object-class+ "longValue" nil "J"))
     1302            (emit-invokevirtual +lisp-object+ "longValue" nil :long))
    23841303           (t
    23851304            (sys::%format t "compile-constant long representation~%")
     
    25071426             (ecase representation
    25081427               (:boolean
    2509                 (emit-invokevirtual +lisp-object-class+
     1428                (emit-invokevirtual +lisp-object+
    25101429                                    unboxed-method-name
    2511                                     nil "Z"))
     1430                                    nil :boolean))
    25121431               ((NIL)
    2513                 (emit-invokevirtual +lisp-object-class+
     1432                (emit-invokevirtual +lisp-object+
    25141433                                    boxed-method-name
    25151434                                    nil +lisp-object+)))
     
    25791498    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    25801499                 arg2 'stack nil)
    2581     (emit-invokevirtual +lisp-object-class+ op
     1500    (emit-invokevirtual +lisp-object+ op
    25821501      (lisp-object-arg-types 1) +lisp-object+)
    25831502    (fix-boxing representation nil)
     
    26441563
    26451564(defun emit-ifne-for-eql (representation instruction-type)
    2646   (emit-invokevirtual +lisp-object-class+ "eql" instruction-type "Z")
     1565  (emit-invokevirtual +lisp-object+ "eql" instruction-type :boolean)
    26471566  (convert-representation :boolean representation))
    26481567
     
    26701589     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    26711590                  arg2 'stack :int)
    2672      (emit-ifne-for-eql representation '("I")))
     1591     (emit-ifne-for-eql representation '(:int)))
    26731592          ((fixnum-type-p type1)
    26741593     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    26751594                  arg2 'stack nil)
    26761595           (emit 'swap)
    2677      (emit-ifne-for-eql representation '("I")))
     1596     (emit-ifne-for-eql representation '(:int)))
    26781597          ((eq type2 'CHARACTER)
    26791598     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    26801599                  arg2 'stack :char)
    2681      (emit-ifne-for-eql representation '("C")))
     1600     (emit-ifne-for-eql representation '(:char)))
    26821601          ((eq type1 'CHARACTER)
    26831602     (compile-forms-and-maybe-emit-clear-values arg1 'stack :char
    26841603                  arg2 'stack nil)
    26851604           (emit 'swap)
    2686      (emit-ifne-for-eql representation '("C")))
     1605     (emit-ifne-for-eql representation '(:char)))
    26871606          (t
    26881607     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
     
    26901609           (ecase representation
    26911610             (:boolean
    2692               (emit-invokevirtual +lisp-object-class+ "eql"
    2693                                   (lisp-object-arg-types 1) "Z"))
     1611              (emit-invokevirtual +lisp-object+ "eql"
     1612                                  (lisp-object-arg-types 1) :boolean))
    26941613             ((NIL)
    2695               (emit-invokevirtual +lisp-object-class+ "EQL"
     1614              (emit-invokevirtual +lisp-object+ "EQL"
    26961615                                  (lisp-object-arg-types 1) +lisp-object+)))))
    26971616    (emit-move-from-stack target representation)))
     
    27061625           (compile-form arg1 'stack nil)
    27071626           (compile-form arg2 'stack nil)
    2708            (emit-invokestatic +lisp-class+ "memq"
    2709                               (lisp-object-arg-types 2) "Z")
     1627           (emit-invokestatic +lisp+ "memq"
     1628                              (lisp-object-arg-types 2) :boolean)
    27101629           (emit-move-from-stack target representation)))
    27111630        (t
     
    27231642           (compile-form arg2 'stack nil)
    27241643           (cond ((eq type1 'SYMBOL) ; FIXME
    2725                   (emit-invokestatic +lisp-class+ "memq"
    2726                                      (lisp-object-arg-types 2) "Z"))
     1644                  (emit-invokestatic +lisp+ "memq"
     1645                                     (lisp-object-arg-types 2) :boolean))
    27271646                 (t
    2728                   (emit-invokestatic +lisp-class+ "memql"
    2729                                      (lisp-object-arg-types 2) "Z")))
     1647                  (emit-invokestatic +lisp+ "memql"
     1648                                     (lisp-object-arg-types 2) :boolean)))
    27301649           (emit-move-from-stack target representation)))
    27311650        (t
     
    27351654  (cond ((and (null representation) (null (cdr form)))
    27361655         (emit-push-current-thread)
    2737          (emit-invokestatic +lisp-class+ "gensym"
     1656         (emit-invokestatic +lisp+ "gensym"
    27381657                            (list +lisp-thread+) +lisp-symbol+)
    27391658         (emit-move-from-stack target))
     
    27561675              (compile-form arg3 'stack nil)
    27571676              (maybe-emit-clear-values arg1 arg2 arg3)))
    2758        (emit-invokestatic +lisp-class+ "get"
     1677       (emit-invokestatic +lisp+ "get"
    27591678                          (lisp-object-arg-types (if arg3 3 2))
    27601679                          +lisp-object+)
     
    27781697                arg2 'stack nil
    27791698                arg3 'stack nil)
    2780          (emit-invokestatic +lisp-class+ "getf"
     1699         (emit-invokestatic +lisp+ "getf"
    27811700                            (lisp-object-arg-types 3) +lisp-object+)
    27821701         (fix-boxing representation nil)
     
    27931712               (ht-form (%caddr form)))
    27941713           (compile-form ht-form 'stack nil)
    2795            (emit 'checkcast +lisp-hash-table-class+)
     1714           (emit-checkcast +lisp-hash-table+)
    27961715           (compile-form key-form 'stack nil)
    27971716           (maybe-emit-clear-values ht-form key-form)
    2798            (emit-invokevirtual +lisp-hash-table-class+ "gethash1"
     1717           (emit-invokevirtual +lisp-hash-table+ "gethash1"
    27991718                               (lisp-object-arg-types 1) +lisp-object+)
    28001719           (fix-boxing representation nil)
     
    28111730               (value-form (fourth form)))
    28121731           (compile-form ht-form 'stack nil)
    2813            (emit 'checkcast +lisp-hash-table-class+)
     1732           (emit-checkcast +lisp-hash-table+)
    28141733           (compile-form key-form 'stack nil)
    28151734           (compile-form value-form 'stack nil)
    28161735           (maybe-emit-clear-values ht-form key-form value-form)
    28171736           (cond (target
    2818                   (emit-invokevirtual +lisp-hash-table-class+ "puthash"
     1737                  (emit-invokevirtual +lisp-hash-table+ "puthash"
    28191738                                      (lisp-object-arg-types 2) +lisp-object+)
    28201739                  (fix-boxing representation nil)
    28211740                  (emit-move-from-stack target representation))
    28221741                 (t
    2823                   (emit-invokevirtual +lisp-hash-table-class+ "put"
     1742                  (emit-invokevirtual +lisp-hash-table+ "put"
    28241743                                      (lisp-object-arg-types 2) nil)))))
    28251744        (t
     
    28581777              (t
    28591778               (emit-push-constant-int numargs)
    2860                (emit 'anewarray +lisp-object-class+)
     1779               (emit-anewarray +lisp-object+)
    28611780               (let ((i 0))
    28621781                 (dolist (arg args)
     
    28911810                       (list +lisp-object-array+)))
    28921811        (return-type +lisp-object+))
    2893     (emit-invokevirtual +lisp-object-class+ "execute" arg-types return-type)))
     1812    (emit-invokevirtual +lisp-object+ "execute" arg-types return-type)))
    28941813
    28951814(declaim (ftype (function (t) t) emit-call-thread-execute))
     
    28991818                       (list +lisp-object+ +lisp-object-array+)))
    29001819        (return-type +lisp-object+))
    2901     (emit-invokevirtual +lisp-thread-class+ "execute" arg-types return-type)))
     1820    (emit-invokevirtual +lisp-thread+ "execute" arg-types return-type)))
    29021821
    29031822(defknown compile-function-call (t t t) t)
     
    30331952    (emit-push-constant-int 0)                            ;; srcPos
    30341953    (emit-push-constant-int (length *closure-variables*))
    3035     (emit 'anewarray +closure-binding-class+)             ;; dest
     1954    (emit-anewarray +lisp-closure-binding+)             ;; dest
    30361955    (emit 'dup)
    30371956    (astore register)  ;; save dest value
    30381957    (emit-push-constant-int 0)                            ;; destPos
    30391958    (emit-push-constant-int (length *closure-variables*)) ;; length
    3040     (emit-invokestatic "java/lang/System" "arraycopy"
    3041                        (list +java-object+ "I"
    3042                              +java-object+ "I" "I") nil)
     1959    (emit-invokestatic +java-system+ "arraycopy"
     1960                       (list +java-object+ :int
     1961                             +java-object+ :int :int) nil)
    30431962    (aload register))) ;; reload dest value
    30441963
     
    30681987           (emit-load-externalized-object
    30691988            (local-function-environment local-function)
    3070             +lisp-environment-class+)
     1989            +lisp-environment+)
    30711990           (emit-load-externalized-object (local-function-name local-function))
    3072            (emit-invokevirtual +lisp-environment-class+ "lookupFunction"
     1991           (emit-invokevirtual +lisp-environment+ "lookupFunction"
    30731992                               (list +lisp-object+)
    30741993                               +lisp-object+))
     
    30822001                                        ; Stack: template-function
    30832002             (when *closure-variables*
    3084                (emit 'checkcast +lisp-compiled-closure-class+)
     2003               (emit-checkcast +lisp-compiled-closure+)
    30852004               (duplicate-closure-array compiland)
    3086                (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     2005               (emit-invokestatic +lisp+ "makeCompiledClosure"
    30872006                                  (list +lisp-object+ +closure-binding-array+)
    30882007                                  +lisp-object+)))))
     
    31562075    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    31572076                (emit-push-constant-int arg2)
    3158                 (emit-invokevirtual +lisp-object-class+
     2077                (emit-invokevirtual +lisp-object+
    31592078                                    (case op
    31602079                                      (<  "isLessThan")
     
    31632082                                      (>= "isGreaterThanOrEqualTo")
    31642083                                      (=  "isEqualTo"))
    3165                                     '("I")
    3166                                     "Z")
     2084                                    '(:int)
     2085                                    :boolean)
    31672086                ;; Java boolean on stack here
    31682087                (convert-representation :boolean representation)
     
    32892208    (let ((arg (%cadr form)))
    32902209      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    3291       (emit-invokevirtual +lisp-object-class+ java-predicate nil "Z")
     2210      (emit-invokevirtual +lisp-object+ java-predicate nil :boolean)
    32922211      'ifeq)))
    32932212
     
    32972216    (let ((arg (%cadr form)))
    32982217      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    3299       (emit 'instanceof java-class)
     2218      (emit-instanceof java-class)
    33002219      'ifeq)))
    33012220
    33022221(defun p2-test-bit-vector-p (form)
    3303   (p2-test-instanceof-predicate form +lisp-abstract-bit-vector-class+))
     2222  (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+))
    33042223
    33052224(defun p2-test-characterp (form)
    3306   (p2-test-instanceof-predicate form +lisp-character-class+))
     2225  (p2-test-instanceof-predicate form +lisp-character+))
    33072226
    33082227;; constantp form &optional environment => generalized-boolean
     
    33112230    (let ((arg (%cadr form)))
    33122231      (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    3313       (emit-invokevirtual +lisp-object-class+ "constantp" nil "Z")
     2232      (emit-invokevirtual +lisp-object+ "constantp" nil :boolean)
    33142233      'ifeq)))
    33152234
     
    33722291
    33732292(defun p2-test-packagep (form)
    3374   (p2-test-instanceof-predicate form +lisp-package-class+))
     2293  (p2-test-instanceof-predicate form +lisp-package+))
    33752294
    33762295(defun p2-test-rationalp (form)
     
    33872306
    33882307(defun p2-test-symbolp (form)
    3389   (p2-test-instanceof-predicate form +lisp-symbol-class+))
     2308  (p2-test-instanceof-predicate form +lisp-symbol+))
    33902309
    33912310(defun p2-test-consp (form)
    3392   (p2-test-instanceof-predicate form +lisp-cons-class+))
     2311  (p2-test-instanceof-predicate form +lisp-cons+))
    33932312
    33942313(defun p2-test-atom (form)
    3395   (p2-test-instanceof-predicate form +lisp-cons-class+)
     2314  (p2-test-instanceof-predicate form +lisp-cons+)
    33962315  'ifne)
    33972316
    33982317(defun p2-test-fixnump (form)
    3399   (p2-test-instanceof-predicate form +lisp-fixnum-class+))
     2318  (p2-test-instanceof-predicate form +lisp-fixnum+))
    34002319
    34012320(defun p2-test-stringp (form)
    3402   (p2-test-instanceof-predicate form +lisp-abstract-string-class+))
     2321  (p2-test-instanceof-predicate form +lisp-abstract-string+))
    34032322
    34042323(defun p2-test-vectorp (form)
    3405   (p2-test-instanceof-predicate form +lisp-abstract-vector-class+))
     2324  (p2-test-instanceof-predicate form +lisp-abstract-vector+))
    34062325
    34072326(defun p2-test-simple-vector-p (form)
    3408   (p2-test-instanceof-predicate form +lisp-simple-vector-class+))
     2327  (p2-test-instanceof-predicate form +lisp-simple-vector+))
    34092328
    34102329(defknown compile-test-form (t) t)
     
    35022421       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35032422              arg2 'stack :char)
    3504              (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z")
     2423             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    35052424             'ifeq)
    35062425            ((eq type1 'CHARACTER)
     
    35082427              arg2 'stack nil)
    35092428             (emit 'swap)
    3510              (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z")
     2429             (emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
    35112430             'ifeq)
    35122431            ((fixnum-type-p type2)
    35132432       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35142433              arg2 'stack :int)
    3515              (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
     2434             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    35162435             'ifeq)
    35172436            ((fixnum-type-p type1)
     
    35192438              arg2 'stack nil)
    35202439             (emit 'swap)
    3521              (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
     2440             (emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
    35222441             'ifeq)
    35232442            (t
    35242443       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35252444              arg2 'stack nil)
    3526              (emit-invokevirtual +lisp-object-class+ "eql"
    3527                                  (lisp-object-arg-types 1) "Z")
     2445             (emit-invokevirtual +lisp-object+ "eql"
     2446                                 (lisp-object-arg-types 1) :boolean)
    35282447             'ifeq)))))
    35292448
     
    35392458       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35402459              arg2 'stack :int)
    3541              (emit-invokevirtual +lisp-object-class+
     2460             (emit-invokevirtual +lisp-object+
    35422461                                 translated-op
    3543                                  '("I") "Z"))
     2462                                 '(:int) :boolean))
    35442463            (t
    35452464       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35462465              arg2 'stack nil)
    3547              (emit-invokevirtual +lisp-object-class+
     2466             (emit-invokevirtual +lisp-object+
    35482467                                 translated-op
    3549                                  (lisp-object-arg-types 1) "Z")))
     2468                                 (lisp-object-arg-types 1) :boolean)))
    35502469      'ifeq)))
    35512470
     
    35562475      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35572476             arg2 'stack nil)
    3558       (emit-invokevirtual +lisp-object-class+ "typep"
     2477      (emit-invokevirtual +lisp-object+ "typep"
    35592478                          (lisp-object-arg-types 1) +lisp-object+)
    35602479      (emit-push-nil)
     
    35672486      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35682487             arg2 'stack nil)
    3569       (emit-invokestatic +lisp-class+ "memq"
    3570                          (lisp-object-arg-types 2) "Z")
     2488      (emit-invokestatic +lisp+ "memq"
     2489                         (lisp-object-arg-types 2) :boolean)
    35712490      'ifeq)))
    35722491
     
    35772496      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35782497             arg2 'stack nil)
    3579       (emit-invokestatic +lisp-class+ "memql"
    3580                          (lisp-object-arg-types 2) "Z")
     2498      (emit-invokestatic +lisp+ "memql"
     2499                         (lisp-object-arg-types 2) :boolean)
    35812500      'ifeq)))
    35822501
     
    35972516       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    35982517              arg2 'stack :int)
    3599              (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z")
     2518             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    36002519             'ifeq)
    36012520            ((fixnum-type-p type1)
     
    36052524              arg2 'stack nil)
    36062525             (emit 'swap)
    3607              (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z")
     2526             (emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
    36082527             'ifeq)
    36092528            (t
    36102529       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    36112530              arg2 'stack nil)
    3612              (emit-invokevirtual +lisp-object-class+ "isNotEqualTo"
    3613                                  (lisp-object-arg-types 1) "Z")
     2531             (emit-invokevirtual +lisp-object+ "isNotEqualTo"
     2532                                 (lisp-object-arg-types 1) :boolean)
    36142533             'ifeq)))))
    36152534
     
    36472566         (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    36482567                arg2 'stack :int)
    3649                (emit-invokevirtual +lisp-object-class+
     2568               (emit-invokevirtual +lisp-object+
    36502569                                   (ecase op
    36512570                                     (<  "isLessThan")
     
    36542573                                     (>= "isGreaterThanOrEqualTo")
    36552574                                     (=  "isEqualTo"))
    3656                                    '("I") "Z")
     2575                                   '(:int) :boolean)
    36572576               'ifeq)
    36582577              ((fixnum-type-p type1)
     
    36622581                arg2 'stack nil)
    36632582               (emit 'swap)
    3664                (emit-invokevirtual +lisp-object-class+
     2583               (emit-invokevirtual +lisp-object+
    36652584                                   (ecase op
    36662585                                     (<  "isGreaterThan")
     
    36692588                                     (>= "isLessThanOrEqualTo")
    36702589                                     (=  "isEqualTo"))
    3671                                    '("I") "Z")
     2590                                   '(:int) :boolean)
    36722591               'ifeq)
    36732592              (t
    36742593         (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    36752594                arg2 'stack nil)
    3676                (emit-invokevirtual +lisp-object-class+
     2595               (emit-invokevirtual +lisp-object+
    36772596                                   (ecase op
    36782597                                     (<  "isLessThan")
     
    36812600                                     (>= "isGreaterThanOrEqualTo")
    36822601                                     (=  "isEqualTo"))
    3683                                    (lisp-object-arg-types 1) "Z")
     2602                                   (lisp-object-arg-types 1) :boolean)
    36842603               'ifeq))))))
    36852604
     
    38172736  (emit-clear-values)
    38182737  (compile-form (second form) 'stack nil)
    3819   (emit-invokestatic +lisp-class+ "multipleValueList"
     2738  (emit-invokestatic +lisp+ "multipleValueList"
    38202739                     (lisp-object-arg-types 1) +lisp-object+)
    38212740  (fix-boxing representation nil)
     
    38322751    ;; Save multiple values returned by first subform.
    38332752    (emit-push-current-thread)
    3834     (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+)
     2753    (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
    38352754    (astore values-register)
    38362755    (dolist (subform subforms)
     
    38392758    (emit-push-current-thread)
    38402759    (aload values-register)
    3841     (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+)
     2760    (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)
    38422761    ;; Result.
    38432762    (aload result-register)
     
    38532772    (2
    38542773     (compile-form (second form) 'stack nil)
    3855      (emit-invokestatic +lisp-class+ "coerceToFunction"
     2774     (emit-invokestatic +lisp+ "coerceToFunction"
    38562775                        (lisp-object-arg-types 1) +lisp-object+)
    3857      (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+))
     2776     (emit-invokevirtual +lisp-object+ "execute" nil +lisp-object+))
    38582777    (3
    38592778     (let* ((*register* *register*)
     
    38632782       (aload function-register)
    38642783       (emit-push-current-thread)
    3865        (emit-invokestatic +lisp-class+ "multipleValueCall1"
     2784       (emit-invokestatic +lisp+ "multipleValueCall1"
    38662785                          (list +lisp-object+ +lisp-object+ +lisp-thread+)
    38672786                          +lisp-object+)))
     
    38722791            (values-register (allocate-register)))
    38732792       (compile-form (second form) 'stack nil)
    3874        (emit-invokestatic +lisp-class+ "coerceToFunction"
     2793       (emit-invokestatic +lisp+ "coerceToFunction"
    38752794                          (lisp-object-arg-types 1) +lisp-object+)
    38762795       (emit-move-from-stack function-register)
     
    38822801         (emit 'swap)
    38832802         (aload values-register)
    3884          (emit-invokevirtual +lisp-thread-class+ "accumulateValues"
     2803         (emit-invokevirtual +lisp-thread+ "accumulateValues"
    38852804                             (list +lisp-object+ +lisp-object-array+)
    38862805                             +lisp-object-array+)
     
    38892808       (aload function-register)
    38902809       (aload values-register)
    3891        (emit-invokevirtual +lisp-object-class+ "dispatch"
     2810       (emit-invokevirtual +lisp-object+ "dispatch"
    38922811                           (list +lisp-object-array+) +lisp-object+))))
    38932812  (fix-boxing representation nil)
     
    39122831(defun emit-new-closure-binding (variable)
    39132832  ""
    3914   (emit 'new +closure-binding-class+)            ;; value c-b
     2833  (emit-new +lisp-closure-binding+)            ;; value c-b
    39152834  (emit 'dup_x1)                                 ;; c-b value c-b
    39162835  (emit 'swap)                                   ;; c-b c-b value
    3917   (emit-invokespecial-init +closure-binding-class+
     2836  (emit-invokespecial-init +lisp-closure-binding+
    39182837                           (list +lisp-object+)) ;; c-b
    39192838  (aload (compiland-closure-register *current-compiland*))
     
    39352854         (emit-push-variable-name variable)
    39362855         (emit 'swap)
    3937          (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     2856         (emit-invokevirtual +lisp-thread+ "bindSpecial"
    39382857                             (list +lisp-symbol+ +lisp-object+)
    39392858                             +lisp-special-binding+)
     
    39762895   (emit-push-current-thread)
    39772896   (aload register)
    3978    (emit-invokevirtual +lisp-thread-class+ "resetSpecialBindings"
     2897   (emit-invokevirtual +lisp-thread+ "resetSpecialBindings"
    39792898                       (list +lisp-special-bindings-mark+) nil)
    39802899  )
     
    39822901(defun save-dynamic-environment (register)
    39832902   (emit-push-current-thread)
    3984    (emit-invokevirtual +lisp-thread-class+ "markSpecialBindings"
     2903   (emit-invokevirtual +lisp-thread+ "markSpecialBindings"
    39852904                       nil +lisp-special-bindings-mark+)
    39862905   (astore register)
     
    39972916    (label label-EXIT)
    39982917    (restore-dynamic-environment register)
    3999     (push (make-handler :from label-START
    4000       :to label-END
    4001       :code label-END
    4002       :catch-type 0) *handlers*)))
     2918    (add-exception-handler label-START label-END label-END nil)))
    40032919
    40042920(defun p2-m-v-b-node (block target)
     
    40412957             ;; Store values from values form in values register.
    40422958             (emit-push-current-thread)
    4043              (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+)
     2959             (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
    40442960             (emit-move-from-stack values-register)
    40452961             ;; Did we get just one value?
     
    40602976             (aload result-register)
    40612977             (emit-push-constant-int (length vars))
    4062              (emit-invokevirtual +lisp-thread-class+ "getValues"
    4063                                  (list +lisp-object+ "I") +lisp-object-array+)
     2978             (emit-invokevirtual +lisp-thread+ "getValues"
     2979                                 (list +lisp-object+ :int) +lisp-object-array+)
    40642980             ;; Values array is now on the stack at runtime.
    40652981             (label LABEL2)
     
    42163132           (emit 'aaload)
    42173133           (emit-swap representation nil)
    4218            (emit 'putfield +closure-binding-class+ "value" +lisp-object+))
     3134           (emit-putfield +lisp-closure-binding+ "value" +lisp-object+))
    42193135          ((variable-environment variable)
    42203136           (assert (not *file-compilation*))
    42213137           (emit-load-externalized-object (variable-environment variable)
    4222                                           +lisp-environment-class+)
     3138                                          +lisp-environment+)
    42233139           (emit 'swap)
    42243140           (emit-push-variable-name variable)
    42253141           (emit 'swap)
    4226            (emit-invokevirtual +lisp-environment-class+ "rebind"
     3142           (emit-invokevirtual +lisp-environment+ "rebind"
    42273143                               (list +lisp-symbol+ +lisp-object+)
    42283144                               nil))
     
    42483164         (emit-push-constant-int (variable-closure-index variable))
    42493165         (emit 'aaload)
    4250          (emit 'getfield +closure-binding-class+ "value" +lisp-object+))
     3166         (emit-getfield +lisp-closure-binding+ "value" +lisp-object+))
    42513167        ((variable-environment variable)
    42523168         (assert (not *file-compilation*))
    42533169         (emit-load-externalized-object (variable-environment variable)
    4254                                         +lisp-environment-class+)
     3170                                        +lisp-environment+)
    42553171         (emit-push-variable-name variable)
    4256          (emit-invokevirtual +lisp-environment-class+ "lookup"
     3172         (emit-invokevirtual +lisp-environment+ "lookup"
    42573173                             (list +lisp-object+)
    42583174                             +lisp-object+))
     
    43473263                 (emit-push-current-thread)
    43483264                 (emit-push-variable-name variable)
    4349                  (emit-invokevirtual +lisp-thread-class+
     3265                 (emit-invokevirtual +lisp-thread+
    43503266                                     "bindSpecialToCurrentValue"
    43513267                                     (list +lisp-symbol+)
     
    44733389      ;; we have a block variable; that should be a closure variable
    44743390      (assert (not (null (variable-closure-index (tagbody-id-variable block)))))
    4475       (emit 'new +lisp-object-class+)
     3391      (emit-new +lisp-object+)
    44763392      (emit 'dup)
    4477       (emit-invokespecial-init +lisp-object-class+ '())
     3393      (emit-invokespecial-init +lisp-object+ '())
    44783394      (emit-new-closure-binding (tagbody-id-variable block)))
    44793395    (label BEGIN-BLOCK)
     
    45073423        (astore go-register)
    45083424        ;; Get the tag.
    4509         (emit 'getfield +lisp-go-class+ "tagbody" +lisp-object+) ; Stack depth is still 1.
     3425        (emit-getfield +lisp-go+ "tagbody" +lisp-object+) ; Stack depth is still 1.
    45103426        (emit-push-variable (tagbody-id-variable block))
    45113427        (emit 'if_acmpne RETHROW) ;; Not this TAGBODY
    45123428        (aload go-register)
    4513         (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
     3429        (emit-getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1.
    45143430        (astore tag-register)
    45153431        ;; Don't actually generate comparisons for tags
     
    45323448        (emit 'athrow)
    45333449        ;; Finally...
    4534         (push (make-handler :from BEGIN-BLOCK
    4535                             :to END-BLOCK
    4536                             :code HANDLER
    4537                             :catch-type (pool-class +lisp-go-class+))
    4538               *handlers*)
    4539         (push (make-handler :from BEGIN-BLOCK
    4540                             :to END-BLOCK
    4541                             :code EXTENT-EXIT-HANDLER
    4542                             :catch-type 0)
    4543               *handlers*)))
     3450        (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-go+)
     3451        (add-exception-handler BEGIN-BLOCK END-BLOCK EXTENT-EXIT-HANDLER nil)))
    45443452    (label EXIT)
    45453453    (when (tagbody-non-local-go-p block)
     
    45773485    (emit-push-variable (tagbody-id-variable tag-block))
    45783486    (emit-load-externalized-object (tag-label tag)) ; Tag.
    4579     (emit-invokestatic +lisp-class+ "nonLocalGo" (lisp-object-arg-types 2)
     3487    (emit-invokestatic +lisp+ "nonLocalGo" (lisp-object-arg-types 2)
    45803488                       +lisp-object+)
    45813489    ;; Following code will not be reached, but is needed for JVM stack
     
    45883496   (check-arg-count form 1))
    45893497  (compile-forms-and-maybe-emit-clear-values (cadr form) 'stack nil)
    4590   (emit 'instanceof +lisp-cons-class+)
     3498  (emit-instanceof +lisp-cons+)
    45913499  (let ((LABEL1 (gensym))
    45923500        (LABEL2 (gensym)))
     
    46173525          (t
    46183526     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    4619            (emit 'instanceof java-class)
     3527           (emit-instanceof java-class)
    46203528           (convert-representation :boolean representation)
    46213529           (emit-move-from-stack target representation)))))
    46223530
    46233531(defun p2-bit-vector-p (form target representation)
    4624   (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector-class+))
     3532  (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector+))
    46253533
    46263534(defun p2-characterp (form target representation)
    4627   (p2-instanceof-predicate form target representation +lisp-character-class+))
     3535  (p2-instanceof-predicate form target representation +lisp-character+))
    46283536
    46293537(defun p2-consp (form target representation)
    4630   (p2-instanceof-predicate form target representation +lisp-cons-class+))
     3538  (p2-instanceof-predicate form target representation +lisp-cons+))
    46313539
    46323540(defun p2-fixnump (form target representation)
    4633   (p2-instanceof-predicate form target representation +lisp-fixnum-class+))
     3541  (p2-instanceof-predicate form target representation +lisp-fixnum+))
    46343542
    46353543(defun p2-packagep (form target representation)
    4636   (p2-instanceof-predicate form target representation +lisp-package-class+))
     3544  (p2-instanceof-predicate form target representation +lisp-package+))
    46373545
    46383546(defun p2-readtablep (form target representation)
    4639   (p2-instanceof-predicate form target representation +lisp-readtable-class+))
     3547  (p2-instanceof-predicate form target representation +lisp-readtable+))
    46403548
    46413549(defun p2-simple-vector-p (form target representation)
    4642   (p2-instanceof-predicate form target representation +lisp-simple-vector-class+))
     3550  (p2-instanceof-predicate form target representation +lisp-simple-vector+))
    46433551
    46443552(defun p2-stringp (form target representation)
    4645   (p2-instanceof-predicate form target representation +lisp-abstract-string-class+))
     3553  (p2-instanceof-predicate form target representation +lisp-abstract-string+))
    46463554
    46473555(defun p2-symbolp (form target representation)
    4648   (p2-instanceof-predicate form target representation +lisp-symbol-class+))
     3556  (p2-instanceof-predicate form target representation +lisp-symbol+))
    46493557
    46503558(defun p2-vectorp (form target representation)
    4651   (p2-instanceof-predicate form target representation +lisp-abstract-vector-class+))
     3559  (p2-instanceof-predicate form target representation +lisp-abstract-vector+))
    46523560
    46533561(define-inlined-function p2-coerce-to-function (form target representation)
    46543562  ((check-arg-count form 1))
    46553563  (compile-forms-and-maybe-emit-clear-values (%cadr form) 'stack nil)
    4656   (emit-invokestatic +lisp-class+ "coerceToFunction"
     3564  (emit-invokestatic +lisp+ "coerceToFunction"
    46573565                     (lisp-object-arg-types 1) +lisp-object+)
    46583566  (emit-move-from-stack target))
     
    46713579      ;; we have a block variable; that should be a closure variable
    46723580      (assert (not (null (variable-closure-index (block-id-variable block)))))
    4673       (emit 'new +lisp-object-class+)
     3581      (emit-new +lisp-object+)
    46743582      (emit 'dup)
    4675       (emit-invokespecial-init +lisp-object-class+ '())
     3583      (emit-invokespecial-init +lisp-object+ '())
    46763584      (emit-new-closure-binding (block-id-variable block)))
    46773585    (dformat t "*all-variables* = ~S~%"
     
    46903598        ;; The Return object is on the runtime stack. Stack depth is 1.
    46913599        (emit 'dup) ; Stack depth is 2.
    4692         (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
     3600        (emit-getfield +lisp-return+ "tag" +lisp-object+) ; Still 2.
    46933601        (emit-push-variable (block-id-variable block))
    46943602        ;; If it's not the block we're looking for...
     
    47003608        (emit 'athrow)
    47013609        (label THIS-BLOCK)
    4702         (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
     3610        (emit-getfield +lisp-return+ "result" +lisp-object+)
    47033611        (emit-move-from-stack target) ; Stack depth is 0.
    47043612        ;; Finally...
    4705         (push (make-handler :from BEGIN-BLOCK
    4706                             :to END-BLOCK
    4707                             :code HANDLER
    4708                             :catch-type (pool-class +lisp-return-class+))
    4709               *handlers*)
    4710         (push (make-handler :from BEGIN-BLOCK
    4711                             :to END-BLOCK
    4712                             :code EXTENT-EXIT-HANDLER
    4713                             :catch-type 0)
    4714               *handlers*)))
     3613        (add-exception-handler BEGIN-BLOCK END-BLOCK HANDLER +lisp-return+)
     3614        (add-exception-handler BEGIN-BLOCK END-BLOCK EXTENT-EXIT-HANDLER nil)))
    47153615    (label BLOCK-EXIT)
    47163616    (when (block-id-variable block)
     
    47473647    (emit-clear-values)
    47483648    (compile-form result-form 'stack nil)
    4749     (emit-invokestatic +lisp-class+ "nonLocalReturn" (lisp-object-arg-types 3)
     3649    (emit-invokestatic +lisp+ "nonLocalReturn" (lisp-object-arg-types 3)
    47503650                       +lisp-object+)
    47513651    ;; Following code will not be reached, but is needed for JVM stack
     
    47753675(define-inlined-function p2-cons (form target representation)
    47763676  ((check-arg-count form 2))
    4777   (emit 'new +lisp-cons-class+)
     3677  (emit-new +lisp-cons+)
    47783678  (emit 'dup)
    47793679  (let* ((args (%cdr form))
     
    47823682    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    47833683                 arg2 'stack nil))
    4784   (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
     3684  (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
    47853685  (emit-move-from-stack target))
    47863686
     
    48243724    ;; Compile call to Lisp.progvBindVars().
    48253725    (emit-push-current-thread)
    4826     (emit-invokestatic +lisp-class+ "progvBindVars"
     3726    (emit-invokestatic +lisp+ "progvBindVars"
    48273727                       (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
    48283728      ;; Implicit PROGN.
     
    48593759      (emit 'dup))
    48603760    (compile-form (second args) 'stack nil)
    4861     (emit-invokevirtual +lisp-object-class+
     3761    (emit-invokevirtual +lisp-object+
    48623762                        "setCdr"
    48633763                        (lisp-object-arg-types 1)
     
    48753775    (when target
    48763776      (emit-dup nil :past nil))
    4877     (emit-invokevirtual +lisp-object-class+
     3777    (emit-invokevirtual +lisp-object+
    48783778                        (if (eq op 'sys:set-car) "setCar" "setCdr")
    48793779                        (lisp-object-arg-types 1)
     
    48893789    (emit-move-from-stack target)))
    48903790
    4891 (defun compile-and-write-to-stream (class-file compiland stream)
    4892   (with-class-file class-file
    4893     (let ((*current-compiland* compiland))
    4894       (with-saved-compiler-policy
    4895     (p2-compiland compiland)
    4896   (write-class-file (compiland-class-file compiland) stream)))))
    4897 
    4898 (defun set-compiland-and-write-class (class-file compiland stream)
    4899   (setf (compiland-class-file compiland) class-file)
    4900   (compile-and-write-to-stream class-file compiland stream))
    4901 
    4902 
    4903 (defmacro with-temp-class-file (pathname class-file lambda-list &body body)
    4904   `(let* ((,pathname (make-temp-file))
    4905     (,class-file (make-class-file :pathname ,pathname
    4906                :lambda-list ,lambda-list)))
    4907      (unwind-protect
    4908     (progn ,@body)
    4909        (delete-file pathname))))
     3791(defun compile-and-write-to-stream (compiland &optional stream)
     3792  "Creates a class file associated with `compiland`, writing it
     3793either to stream or the pathname of the class file if `stream' is NIL."
     3794  (let* ((pathname (funcall *pathnames-generator*))
     3795         (class-file (make-abcl-class-file
     3796                      :pathname pathname
     3797                      :lambda-list
     3798                      (cadr (compiland-lambda-expression compiland)))))
     3799    (setf (compiland-class-file compiland) class-file)
     3800    (with-open-stream (f (or stream
     3801                             (open pathname :direction :output
     3802                                   :element-type '(unsigned-byte 8)
     3803                                   :if-exists :supersede)))
     3804      (with-class-file class-file
     3805        (let ((*current-compiland* compiland))
     3806          (with-saved-compiler-policy
     3807              (p2-compiland compiland)
     3808            ;;        (finalize-class-file (compiland-class-file compiland))
     3809            (finish-class (compiland-class-file compiland) f)))))))
    49103810
    49113811(defknown p2-flet-process-compiland (t) t)
    49123812(defun p2-flet-process-compiland (local-function)
    4913   (let* ((compiland (local-function-compiland local-function))
    4914          (lambda-list (cadr (compiland-lambda-expression compiland))))
     3813  (let* ((compiland (local-function-compiland local-function)))
    49153814    (cond (*file-compilation*
    4916            (let* ((pathname (funcall *pathnames-generator*))
    4917                   (class-file (make-class-file :pathname pathname
    4918                                                :lambda-list lambda-list)))
    4919              (with-open-class-file (f class-file)
    4920                (set-compiland-and-write-class class-file compiland f))
    4921              (setf (local-function-class-file local-function) class-file)))
     3815           (compile-and-write-to-stream compiland)
     3816           (setf (local-function-class-file local-function)
     3817                 (compiland-class-file compiland)))
    49223818          (t
    4923            (let ((class-file (make-class-file :lambda-list lambda-list)))
    4924              (with-open-stream (stream (sys::%make-byte-array-output-stream))
    4925                (set-compiland-and-write-class class-file compiland stream)
    4926                (setf (local-function-class-file local-function) class-file)
    4927                (setf (local-function-function local-function)
    4928                      (load-compiled-function
    4929                       (sys::%get-output-stream-bytes stream)))))))))
     3819           (with-open-stream (stream (sys::%make-byte-array-output-stream))
     3820             (compile-and-write-to-stream compiland stream)
     3821             (setf (local-function-class-file local-function)
     3822                   (compiland-class-file compiland))
     3823             (setf (local-function-function local-function)
     3824                   (load-compiled-function
     3825                    (sys::%get-output-stream-bytes stream))))))))
    49303826
    49313827(defun emit-make-compiled-closure-for-labels
     
    49363832      (dformat t "(compiland-closure-register parent) = ~S~%"
    49373833         (compiland-closure-register parent))
    4938       (emit 'checkcast +lisp-compiled-closure-class+)
     3834      (emit-checkcast +lisp-compiled-closure+)
    49393835      (duplicate-closure-array parent)
    4940       (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     3836      (emit-invokestatic +lisp+ "makeCompiledClosure"
    49413837       (list +lisp-object+ +closure-binding-array+)
    49423838       +lisp-object+)))
     
    49453841(defknown p2-labels-process-compiland (t) t)
    49463842(defun p2-labels-process-compiland (local-function)
    4947   (let* ((compiland (local-function-compiland local-function))
    4948          (lambda-list (cadr (compiland-lambda-expression compiland))))
     3843  (let* ((compiland (local-function-compiland local-function)))
    49493844    (cond (*file-compilation*
    4950            (let* ((pathname (funcall *pathnames-generator*))
    4951                   (class-file (make-class-file :pathname pathname
    4952                                                :lambda-list lambda-list)))
    4953              (with-open-class-file (f class-file)
    4954                (set-compiland-and-write-class class-file compiland f))
    4955              (setf (local-function-class-file local-function) class-file)
    4956              (let ((g (declare-local-function local-function)))
     3845           (compile-and-write-to-stream compiland)
     3846           (setf (local-function-class-file local-function)
     3847                 (compiland-class-file compiland))
     3848           (let ((g (declare-local-function local-function)))
     3849             (emit-make-compiled-closure-for-labels
     3850              local-function compiland g)))
     3851          (t
     3852           (with-open-stream (stream (sys::%make-byte-array-output-stream))
     3853             (compile-and-write-to-stream compiland stream)
     3854             (setf (local-function-class-file local-function)
     3855                   (compiland-class-file compiland))
     3856             (let ((g (declare-object
     3857                       (load-compiled-function
     3858                        (sys::%get-output-stream-bytes stream)))))
    49573859               (emit-make-compiled-closure-for-labels
    4958                 local-function compiland g))))
    4959           (t
    4960            (let ((class-file (make-class-file :lambda-list lambda-list)))
    4961              (with-open-stream (stream (sys::%make-byte-array-output-stream))
    4962                (set-compiland-and-write-class class-file compiland stream)
    4963                (setf (local-function-class-file local-function) class-file)
    4964                (let ((g (declare-object
    4965                          (load-compiled-function
    4966                           (sys::%get-output-stream-bytes stream)))))
    4967                  (emit-make-compiled-closure-for-labels
    4968                   local-function compiland g))))))))
     3860                local-function compiland g)))))))
    49693861
    49703862(defknown p2-flet-node (t t t) t)
     
    50073899
    50083900(defun p2-lambda (compiland target)
    5009   (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
    5010     (aver (null (compiland-class-file compiland)))
    5011     (cond (*file-compilation*
    5012            (setf (compiland-class-file compiland)
    5013                  (make-class-file :pathname (funcall *pathnames-generator*)
    5014                                   :lambda-list lambda-list))
    5015            (let ((class-file (compiland-class-file compiland)))
    5016        (with-open-class-file (f class-file)
    5017          (compile-and-write-to-stream class-file compiland f))
    5018              (emit-getstatic *this-class*
    5019                    (declare-local-function (make-local-function :class-file
    5020                                                                 class-file))
    5021                    +lisp-object+)))
    5022           (t
    5023            (setf (compiland-class-file compiland)
    5024                  (make-class-file :lambda-list lambda-list))
    5025            (with-open-stream (stream (sys::%make-byte-array-output-stream))
    5026              (compile-and-write-to-stream (compiland-class-file compiland)
    5027                                           compiland stream)
    5028              (emit-load-externalized-object (load-compiled-function
    5029                                     (sys::%get-output-stream-bytes stream))))))
    5030     (cond ((null *closure-variables*))  ; Nothing to do.
    5031           ((compiland-closure-register *current-compiland*)
    5032            (duplicate-closure-array *current-compiland*)
    5033            (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    5034                               (list +lisp-object+ +closure-binding-array+)
    5035                               +lisp-object+))
     3901  (aver (null (compiland-class-file compiland)))
     3902  (cond (*file-compilation*
     3903         (compile-and-write-to-stream compiland)
     3904         (emit-getstatic *this-class*
     3905                         (declare-local-function
     3906                          (make-local-function
     3907                           :class-file (compiland-class-file compiland)))
     3908                         +lisp-object+))
     3909        (t
     3910         (with-open-stream (stream (sys::%make-byte-array-output-stream))
     3911           (compile-and-write-to-stream compiland stream)
     3912           (emit-load-externalized-object (load-compiled-function
     3913                                           (sys::%get-output-stream-bytes stream))))))
     3914  (cond ((null *closure-variables*))    ; Nothing to do.
     3915        ((compiland-closure-register *current-compiland*)
     3916         (duplicate-closure-array *current-compiland*)
     3917         (emit-invokestatic +lisp+ "makeCompiledClosure"
     3918                            (list +lisp-object+ +closure-binding-array+)
     3919                            +lisp-object+))
    50363920                                        ; Stack: compiled-closure
    5037           (t
    5038            (aver nil))) ;; Shouldn't happen.
    5039     (emit-move-from-stack target)))
     3921        (t
     3922         (aver nil))) ;; Shouldn't happen.
     3923
     3924  (emit-move-from-stack target))
    50403925
    50413926(defknown p2-function (t t t) t)
     
    50663951
    50673952               (when (compiland-closure-register *current-compiland*)
    5068                  (emit 'checkcast +lisp-compiled-closure-class+)
     3953                 (emit-checkcast +lisp-compiled-closure+)
    50693954                 (duplicate-closure-array *current-compiland*)
    5070                  (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     3955                 (emit-invokestatic +lisp+ "makeCompiledClosure"
    50713956                                    (list +lisp-object+ +closure-binding-array+)
    50723957                                    +lisp-object+)))))
     
    50783963         (t
    50793964          (emit-load-externalized-object name)
    5080           (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie"
     3965          (emit-invokevirtual +lisp-object+ "getSymbolFunctionOrDie"
    50813966                              nil +lisp-object+)
    50823967          (emit-move-from-stack target))))
     
    51174002         (t
    51184003          (emit-load-externalized-object (cadr name))
    5119           (emit-invokevirtual +lisp-symbol-class+
     4004          (emit-invokevirtual +lisp-symbol+
    51204005                              "getSymbolSetfFunctionOrDie"
    51214006                              nil +lisp-object+)
     
    52124097      (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    52134098                   arg2 'stack :int)
    5214                   (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+)
     4099                  (emit-invokevirtual +lisp-object+ "ash" '(:int) +lisp-object+)
    52154100                  (fix-boxing representation result-type)))
    52164101           (emit-move-from-stack target representation))
     
    52764161    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    52774162                 arg2 'stack :int)
    5278                 (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+)
     4163                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
    52794164                (fix-boxing representation result-type)
    52804165                (emit-move-from-stack target representation))
     
    52854170                ;; swap args
    52864171                (emit 'swap)
    5287                 (emit-invokevirtual +lisp-object-class+ "LOGAND" '("I") +lisp-object+)
     4172                (emit-invokevirtual +lisp-object+ "LOGAND" '(:int) +lisp-object+)
    52884173                (fix-boxing representation result-type)
    52894174                (emit-move-from-stack target representation))
     
    52914176    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    52924177                 arg2 'stack nil)
    5293                 (emit-invokevirtual +lisp-object-class+ "LOGAND"
     4178                (emit-invokevirtual +lisp-object+ "LOGAND"
    52944179                                    (lisp-object-arg-types 1) +lisp-object+)
    52954180                (fix-boxing representation result-type)
     
    53484233    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    53494234                 arg2 'stack :int)
    5350                 (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+)
     4235                (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
    53514236                (fix-boxing representation result-type)
    53524237                (emit-move-from-stack target representation))
     
    53574242                ;; swap args
    53584243                (emit 'swap)
    5359                 (emit-invokevirtual +lisp-object-class+ "LOGIOR" '("I") +lisp-object+)
     4244                (emit-invokevirtual +lisp-object+ "LOGIOR" '(:int) +lisp-object+)
    53604245                (fix-boxing representation result-type)
    53614246                (emit-move-from-stack target representation))
     
    53634248    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    53644249                 arg2 'stack nil)
    5365                 (emit-invokevirtual +lisp-object-class+ "LOGIOR"
     4250                (emit-invokevirtual +lisp-object+ "LOGIOR"
    53664251                                    (lisp-object-arg-types 1) +lisp-object+)
    53674252                (fix-boxing representation result-type)
     
    54124297    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    54134298                 arg2 'stack :int)
    5414                 (emit-invokevirtual +lisp-object-class+ "LOGXOR" '("I") +lisp-object+)
     4299                (emit-invokevirtual +lisp-object+ "LOGXOR" '(:int) +lisp-object+)
    54154300                (fix-boxing representation result-type))
    54164301               (t
    54174302    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    54184303                 arg2 'stack nil)
    5419                 (emit-invokevirtual +lisp-object-class+ "LOGXOR"
     4304                (emit-invokevirtual +lisp-object+ "LOGXOR"
    54204305                                    (lisp-object-arg-types 1) +lisp-object+)
    54214306                (fix-boxing representation result-type)))
     
    54394324         (let ((arg (%cadr form)))
    54404325     (compile-forms-and-maybe-emit-clear-values arg 'stack nil))
    5441          (emit-invokevirtual +lisp-object-class+ "LOGNOT" nil +lisp-object+)
     4326         (emit-invokevirtual +lisp-object+ "LOGNOT" nil +lisp-object+)
    54424327         (fix-boxing representation nil)
    54434328         (emit-move-from-stack target representation))))
     
    54964381                  (emit-push-constant-int size)
    54974382                  (emit-push-constant-int position)
    5498                   (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+)
     4383                  (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+)
    54994384                  (fix-boxing representation nil)
    55004385                  (emit-move-from-stack target representation))))
     
    55064391           (emit 'dup_x2) ;; use not supported by emit-dup: 3 values involved
    55074392           (emit 'pop)
    5508            (emit-invokevirtual +lisp-object-class+ "LDB" '("I" "I") +lisp-object+)
     4393           (emit-invokevirtual +lisp-object+ "LDB" '(:int :int) +lisp-object+)
    55094394           (fix-boxing representation nil)
    55104395           (emit-move-from-stack target representation))
     
    55254410     (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
    55264411                  arg2 'stack :int)
    5527            (emit-invokestatic +lisp-class+ "mod" '("I" "I") "I")
     4412           (emit-invokestatic +lisp+ "mod" '(:int :int) :int)
    55284413           (emit-move-from-stack target representation))
    55294414          ((fixnum-type-p type2)
    55304415     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    55314416                  arg2 'stack :int)
    5532            (emit-invokevirtual +lisp-object-class+ "MOD" '("I") +lisp-object+)
     4417           (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+)
    55334418           (fix-boxing representation nil) ; FIXME use derived result type
    55344419           (emit-move-from-stack target representation))
     
    55364421     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    55374422                  arg2 'stack nil)
    5538            (emit-invokevirtual +lisp-object-class+ "MOD"
     4423           (emit-invokevirtual +lisp-object+ "MOD"
    55394424                               (lisp-object-arg-types 1) +lisp-object+)
    55404425           (fix-boxing representation nil) ; FIXME use derived result type
     
    56044489       (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    56054490       (emit-push-constant-int 1) ; errorp
    5606        (emit-invokestatic +lisp-class-class+ "findClass"
    5607                           (list +lisp-object+ "Z") +lisp-object+)
     4491       (emit-invokestatic +lisp-class+ "findClass"
     4492                          (list +lisp-object+ :boolean) +lisp-object+)
    56084493       (fix-boxing representation nil)
    56094494       (emit-move-from-stack target representation))
     
    56124497   (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    56134498                arg2 'stack :boolean)
    5614          (emit-invokestatic +lisp-class-class+ "findClass"
    5615                             (list +lisp-object+ "Z") +lisp-object+)
     4499         (emit-invokestatic +lisp-class+ "findClass"
     4500                            (list +lisp-object+ :boolean) +lisp-object+)
    56164501         (fix-boxing representation nil)
    56174502         (emit-move-from-stack target representation)))
     
    56314516       (emit 'swap)
    56324517       (cond (target
    5633               (emit-invokevirtual +lisp-object-class+ "VECTOR_PUSH_EXTEND"
     4518              (emit-invokevirtual +lisp-object+ "VECTOR_PUSH_EXTEND"
    56344519                                  (lisp-object-arg-types 1) +lisp-object+)
    56354520              (fix-boxing representation nil)
    56364521              (emit-move-from-stack target representation))
    56374522             (t
    5638               (emit-invokevirtual +lisp-object-class+ "vectorPushExtend"
     4523              (emit-invokevirtual +lisp-object+ "vectorPushExtend"
    56394524                                  (lisp-object-arg-types 1) nil))))
    56404525      (t
     
    56494534    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    56504535                 arg2 'stack nil)
    5651     (emit-invokevirtual +lisp-object-class+ "SLOT_VALUE"
     4536    (emit-invokevirtual +lisp-object+ "SLOT_VALUE"
    56524537                        (lisp-object-arg-types 1) +lisp-object+)
    56534538    (fix-boxing representation nil)
     
    56704555      (emit 'dup)
    56714556      (astore value-register))
    5672     (emit-invokevirtual +lisp-object-class+ "setSlotValue"
     4557    (emit-invokevirtual +lisp-object+ "setSlotValue"
    56734558                        (lisp-object-arg-types 2) nil)
    56744559    (when value-register
     
    56854570              (null representation))
    56864571         (let ((arg (second form)))
    5687            (emit 'new +lisp-simple-vector-class+)
     4572           (emit-new +lisp-simple-vector+)
    56884573           (emit 'dup)
    56894574     (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    5690            (emit-invokespecial-init +lisp-simple-vector-class+ '("I"))
     4575           (emit-invokespecial-init +lisp-simple-vector+ '(:int))
    56914576           (emit-move-from-stack target representation)))
    56924577        (t
     
    57104595              (case result-type
    57114596                ((STRING SIMPLE-STRING)
    5712                  (setf class +lisp-simple-string-class+))
     4597                 (setf class +lisp-simple-string+))
    57134598                ((VECTOR SIMPLE-VECTOR)
    5714                  (setf class +lisp-simple-vector-class+)))))
     4599                 (setf class +lisp-simple-vector+)))))
    57154600        (when class
    5716           (emit 'new class)
     4601          (emit-new class)
    57174602          (emit 'dup)
    57184603    (compile-forms-and-maybe-emit-clear-values arg2 'stack :int)
    5719           (emit-invokespecial-init class '("I"))
     4604          (emit-invokespecial-init class '(:int))
    57204605          (emit-move-from-stack target representation)
    57214606          (return-from p2-make-sequence)))))
     
    57294614              (null representation))
    57304615         (let ((arg (second form)))
    5731            (emit 'new +lisp-simple-string-class+)
     4616           (emit-new +lisp-simple-string+)
    57324617           (emit 'dup)
    57334618     (compile-forms-and-maybe-emit-clear-values arg 'stack :int)
    5734            (emit-invokespecial-init +lisp-simple-string-class+ '("I"))
     4619           (emit-invokespecial-init +lisp-simple-string+ '(:int))
    57354620           (emit-move-from-stack target representation)))
    57364621        (t
     
    57404625  (cond ((and (check-arg-count form 2)
    57414626              (eq (derive-type (%cadr form)) 'SYMBOL))
    5742          (emit 'new +lisp-structure-object-class+)
     4627         (emit-new +lisp-structure-object+)
    57434628         (emit 'dup)
    57444629         (compile-form (%cadr form) 'stack nil)
    5745          (emit 'checkcast +lisp-symbol-class+)
     4630         (emit-checkcast +lisp-symbol+)
    57464631         (compile-form (%caddr form) 'stack nil)
    57474632         (maybe-emit-clear-values (%cadr form) (%caddr form))
    5748          (emit-invokevirtual +lisp-object-class+ "copyToArray"
     4633         (emit-invokevirtual +lisp-object+ "copyToArray"
    57494634                             nil +lisp-object-array+)
    5750          (emit-invokespecial-init +lisp-structure-object-class+
     4635         (emit-invokespecial-init +lisp-structure-object+
    57514636                                  (list +lisp-symbol+ +lisp-object-array+))
    57524637         (emit-move-from-stack target representation))
     
    57604645    (cond ((and (<= 1 slot-count 6)
    57614646                (eq (derive-type (%car args)) 'SYMBOL))
    5762            (emit 'new +lisp-structure-object-class+)
     4647           (emit-new +lisp-structure-object+)
    57634648           (emit 'dup)
    57644649           (compile-form (%car args) 'stack nil)
    5765            (emit 'checkcast +lisp-symbol-class+)
     4650           (emit-checkcast +lisp-symbol+)
    57664651           (dolist (slot-form slot-forms)
    57674652             (compile-form slot-form 'stack nil))
    57684653           (apply 'maybe-emit-clear-values args)
    5769            (emit-invokespecial-init +lisp-structure-object-class+
     4654           (emit-invokespecial-init +lisp-structure-object+
    57704655                                    (append (list +lisp-symbol+)
    57714656                                            (make-list slot-count :initial-element +lisp-object+)))
     
    57764661(defun p2-make-hash-table (form target representation)
    57774662  (cond ((= (length form) 1) ; no args
    5778          (emit 'new +lisp-eql-hash-table-class+)
     4663         (emit-new +lisp-eql-hash-table+)
    57794664         (emit 'dup)
    5780          (emit-invokespecial-init +lisp-eql-hash-table-class+ nil)
     4665         (emit-invokespecial-init +lisp-eql-hash-table+ nil)
    57814666         (fix-boxing representation nil)
    57824667         (emit-move-from-stack target representation))
     
    57904675    (cond ((eq (derive-compiler-type arg) 'STREAM)
    57914676     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    5792            (emit 'checkcast +lisp-stream-class+)
    5793            (emit-invokevirtual +lisp-stream-class+ "getElementType"
     4677           (emit-checkcast +lisp-stream+)
     4678           (emit-invokevirtual +lisp-stream+ "getElementType"
    57944679                               nil +lisp-object+)
    57954680           (emit-move-from-stack target representation))
     
    58094694           (compile-form arg1 'stack :int)
    58104695           (compile-form arg2 'stack nil)
    5811            (emit 'checkcast +lisp-stream-class+)
     4696           (emit-checkcast +lisp-stream+)
    58124697           (maybe-emit-clear-values arg1 arg2)
    58134698           (emit 'swap)
    5814            (emit-invokevirtual +lisp-stream-class+ "_writeByte" '("I") nil)
     4699           (emit-invokevirtual +lisp-stream+ "_writeByte" '(:int) nil)
    58154700           (when target
    58164701             (emit-push-nil)
     
    58204705           (compile-form arg2 'stack nil)
    58214706           (maybe-emit-clear-values arg1 arg2)
    5822            (emit-invokestatic +lisp-class+ "writeByte"
    5823                               (list "I" +lisp-object+) nil)
     4707           (emit-invokestatic +lisp+ "writeByte"
     4708                              (list :int +lisp-object+) nil)
    58244709           (when target
    58254710             (emit-push-nil)
     
    58374722         (cond ((compiler-subtypep type1 'stream)
    58384723    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    5839                 (emit 'checkcast +lisp-stream-class+)
     4724                (emit-checkcast +lisp-stream+)
    58404725                (emit-push-constant-int 1)
    58414726                (emit-push-nil)
    5842                 (emit-invokevirtual +lisp-stream-class+ "readLine"
    5843                                     (list "Z" +lisp-object+) +lisp-object+)
     4727                (emit-invokevirtual +lisp-stream+ "readLine"
     4728                                    (list :boolean +lisp-object+) +lisp-object+)
    58444729                (emit-move-from-stack target))
    58454730               (t
     
    58514736         (cond ((and (compiler-subtypep type1 'stream) (null arg2))
    58524737    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    5853                 (emit 'checkcast +lisp-stream-class+)
     4738                (emit-checkcast +lisp-stream+)
    58544739                (emit-push-constant-int 0)
    58554740                (emit-push-nil)
    5856                 (emit-invokevirtual +lisp-stream-class+ "readLine"
    5857                                     (list "Z" +lisp-object+) +lisp-object+)
     4741                (emit-invokevirtual +lisp-stream+ "readLine"
     4742                                    (list :boolean +lisp-object+) +lisp-object+)
    58584743                (emit-move-from-stack target)
    58594744                )
     
    64005285               (compile-form arg1 'stack nil)
    64015286               (compile-form arg2 'stack nil)
    6402                (emit 'checkcast +lisp-abstract-vector-class+)
     5287               (emit-checkcast +lisp-abstract-vector+)
    64035288               (maybe-emit-clear-values arg1 arg2)
    64045289               (emit 'swap)
    6405                (emit-invokevirtual +lisp-abstract-vector-class+
     5290               (emit-invokevirtual +lisp-abstract-vector+
    64065291                                   (if (eq test 'eq) "deleteEq" "deleteEql")
    64075292                                   (lisp-object-arg-types 1) +lisp-object+)
     
    64185303    (ecase representation
    64195304      (:int
    6420        (emit-invokevirtual +lisp-object-class+ "length" nil "I"))
     5305       (emit-invokevirtual +lisp-object+ "length" nil :int))
    64215306      ((:long :float :double)
    6422        (emit-invokevirtual +lisp-object-class+ "length" nil "I")
     5307       (emit-invokevirtual +lisp-object+ "length" nil :int)
    64235308       (convert-representation :int representation))
    64245309      (:boolean
    64255310       ;; FIXME We could optimize this all away in unsafe calls.
    6426        (emit-invokevirtual +lisp-object-class+ "length" nil "I")
     5311       (emit-invokevirtual +lisp-object+ "length" nil :int)
    64275312       (emit 'pop)
    64285313       (emit 'iconst_1))
     
    64315316       (aver nil))
    64325317      ((nil)
    6433        (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+)))
     5318       (emit-invokevirtual +lisp-object+ "LENGTH" nil +lisp-object+)))
    64345319    (emit-move-from-stack target representation)))
    64355320
     
    64425327    (cond ((>= 4 length 1)
    64435328     (dolist (cons-head cons-heads)
    6444        (emit 'new +lisp-cons-class+)
     5329       (emit-new +lisp-cons+)
    64455330       (emit 'dup)
    64465331       (compile-form cons-head 'stack nil))
     
    64495334       (progn
    64505335         (emit-invokespecial-init
    6451     +lisp-cons-class+ (lisp-object-arg-types 1))
     5336    +lisp-cons+ (lisp-object-arg-types 1))
    64525337         (pop cons-heads))) ; we've handled one of the args, so remove it
    64535338     (dolist (cons-head cons-heads)
    64545339       (declare (ignore cons-head))
    64555340       (emit-invokespecial-init
    6456         +lisp-cons-class+ (lisp-object-arg-types 2)))
     5341        +lisp-cons+ (lisp-object-arg-types 2)))
    64575342     (if list-star-p
    64585343         (progn
     
    64815366                 list-form 'stack nil)
    64825367    (emit 'swap)
    6483     (emit-invokevirtual +lisp-object-class+ "NTH" '("I") +lisp-object+)
     5368    (emit-invokevirtual +lisp-object+ "NTH" '(:int) +lisp-object+)
    64845369    (fix-boxing representation nil) ; FIXME use derived result type
    64855370    (emit-move-from-stack target representation)))
     
    65205405        (compile-forms-and-maybe-emit-clear-values arg1 'stack nil)
    65215406              (emit-push-int arg2)
    6522               (emit-invokevirtual +lisp-object-class+ "multiplyBy" '("I") +lisp-object+)
     5407              (emit-invokevirtual +lisp-object+ "multiplyBy" '(:int) +lisp-object+)
    65235408              (fix-boxing representation result-type)
    65245409              (emit-move-from-stack target representation))
     
    65705455                  (compile-form arg2 'stack nil)
    65715456                  (emit-dup nil :past nil)
    6572                   (emit-invokevirtual +lisp-object-class+
     5457                  (emit-invokevirtual +lisp-object+
    65735458                                      (if (eq op 'max)
    65745459                                          "isLessThanOrEqualTo"
    65755460                                          "isGreaterThanOrEqualTo")
    6576                                       (lisp-object-arg-types 1) "Z")
     5461                                      (lisp-object-arg-types 1) :boolean)
    65775462                  (let ((LABEL1 (gensym)))
    65785463                    (emit 'ifeq LABEL1)
     
    66385523              (when (fixnum-type-p type1)
    66395524                (emit 'swap))
    6640               (emit-invokevirtual +lisp-object-class+ "add"
    6641                                   '("I") +lisp-object+)
     5525              (emit-invokevirtual +lisp-object+ "add"
     5526                                  '(:int) +lisp-object+)
    66425527              (fix-boxing representation result-type)
    66435528              (emit-move-from-stack target representation))
     
    66775562             (t
    66785563        (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    6679               (emit-invokevirtual +lisp-object-class+ "negate"
     5564              (emit-invokevirtual +lisp-object+ "negate"
    66805565                                  nil +lisp-object+)
    66815566              (fix-boxing representation nil)
     
    67095594                    arg1 'stack nil
    67105595                    arg2 'stack :int)
    6711               (emit-invokevirtual +lisp-object-class+
     5596              (emit-invokevirtual +lisp-object+
    67125597                                  "subtract"
    6713                                   '("I") +lisp-object+)
     5598                                  '(:int) +lisp-object+)
    67145599              (fix-boxing representation result-type)
    67155600              (emit-move-from-stack target representation))
     
    67335618                (zerop *safety*))
    67345619           (compile-form arg1 'stack nil)
    6735            (emit 'checkcast +lisp-abstract-string-class+)
     5620           (emit-checkcast +lisp-abstract-string+)
    67365621           (compile-form arg2 'stack :int)
    67375622           (maybe-emit-clear-values arg1 arg2)
    6738            (emit-invokevirtual +lisp-abstract-string-class+ "charAt"
    6739                                '("I") "C")
     5623           (emit-invokevirtual +lisp-abstract-string+ "charAt"
     5624                               '(:int) :char)
    67405625           (emit-move-from-stack target representation))
    67415626          ((and (eq representation :char)
     
    67445629                (fixnum-type-p type2))
    67455630           (compile-form arg1 'stack nil)
    6746            (emit 'checkcast +lisp-abstract-string-class+)
     5631           (emit-checkcast +lisp-abstract-string+)
    67475632           (compile-form arg2 'stack :int)
    67485633           (maybe-emit-clear-values arg1 arg2)
    6749            (emit-invokevirtual +lisp-abstract-string-class+ "charAt"
    6750                                '("I") "C")
     5634           (emit-invokevirtual +lisp-abstract-string+ "charAt"
     5635                               '(:int) :char)
    67515636           (emit-move-from-stack target representation))
    67525637          ((fixnum-type-p type2)
    67535638     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    67545639                  arg2 'stack :int)
    6755            (emit-invokevirtual +lisp-object-class+
     5640           (emit-invokevirtual +lisp-object+
    67565641                               (symbol-name op) ;; "CHAR" or "SCHAR"
    6757                                '("I") +lisp-object+)
     5642                               '(:int) +lisp-object+)
    67585643           (when (eq representation :char)
    67595644             (emit-unbox-character))
     
    67825667                  (value-register (when target (allocate-register)))
    67835668                  (class (if (eq op 'SCHAR)
    6784                              +lisp-simple-string-class+
    6785                              +lisp-abstract-string-class+)))
     5669                             +lisp-simple-string+
     5670                             +lisp-abstract-string+)))
    67865671             (compile-form arg1 'stack nil)
    6787              (emit 'checkcast class)
     5672             (emit-checkcast class)
    67885673             (compile-form arg2 'stack :int)
    67895674             (compile-form arg3 'stack :char)
     
    67925677               (emit-move-from-stack value-register :char))
    67935678             (maybe-emit-clear-values arg1 arg2 arg3)
    6794              (emit-invokevirtual class "setCharAt" '("I" "C") nil)
     5679             (emit-invokevirtual class "setCharAt" '(:int :char) nil)
    67955680             (when target
    67965681               (emit 'iload value-register)
     
    68085693     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    68095694                  arg2 'stack :int)
    6810            (emit-invokevirtual +lisp-object-class+ "SVREF" '("I") +lisp-object+)
     5695           (emit-invokevirtual +lisp-object+ "SVREF" '(:int) +lisp-object+)
    68115696           (fix-boxing representation nil)
    68125697           (emit-move-from-stack target representation)))
     
    68285713             (emit-move-from-stack value-register nil))
    68295714           (maybe-emit-clear-values arg1 arg2 arg3)
    6830            (emit-invokevirtual +lisp-object-class+ "svset" (list "I" +lisp-object+) nil)
     5715           (emit-invokevirtual +lisp-object+ "svset" (list :int +lisp-object+) nil)
    68315716           (when value-register
    68325717             (aload value-register)
     
    68535738    (compile-form arg1 'stack nil)
    68545739    (compile-form arg2 'stack nil)
    6855     (emit-invokevirtual +lisp-object-class+ "truncate" (lisp-object-arg-types 1) +lisp-object+)
     5740    (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+)
    68565741    (fix-boxing representation nil) ; FIXME use derived result type
    68575742    (emit-move-from-stack target representation)))
     
    68635748         (compile-form (second form) 'stack nil)
    68645749         (compile-form (third form) 'stack :int)
    6865          (emit-invokevirtual +lisp-object-class+ "elt" '("I") +lisp-object+)
     5750         (emit-invokevirtual +lisp-object+ "elt" '(:int) +lisp-object+)
    68665751         (fix-boxing representation nil) ; FIXME use derived result type
    68675752         (emit-move-from-stack target representation))
     
    68805765    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    68815766                 arg2 'stack :int)
    6882           (emit-invokevirtual +lisp-object-class+ "aref" '("I") "I"))
     5767          (emit-invokevirtual +lisp-object+ "aref" '(:int) :int))
    68835768         (:long
    68845769    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    68855770                 arg2 'stack :int)
    6886           (emit-invokevirtual +lisp-object-class+ "aref_long" '("I") "J"))
     5771          (emit-invokevirtual +lisp-object+ "aref_long" '(:int) :long))
    68875772         (:char
    68885773          (cond ((compiler-subtypep type1 'string)
    68895774                 (compile-form arg1 'stack nil) ; array
    6890                  (emit 'checkcast +lisp-abstract-string-class+)
     5775                 (emit-checkcast +lisp-abstract-string+)
    68915776                 (compile-form arg2 'stack :int) ; index
    68925777                 (maybe-emit-clear-values arg1 arg2)
    6893                  (emit-invokevirtual +lisp-abstract-string-class+
    6894                                      "charAt" '("I") "C"))
     5778                 (emit-invokevirtual +lisp-abstract-string+
     5779                                     "charAt" '(:int) :char))
    68955780                (t
    68965781     (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    68975782                  arg2 'stack :int)
    6898                  (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+)
     5783                 (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    68995784                 (emit-unbox-character))))
    69005785         ((nil :float :double :boolean)
     
    69035788    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
    69045789                 arg2 'stack :int)
    6905           (emit-invokevirtual +lisp-object-class+ "AREF" '("I") +lisp-object+)
     5790          (emit-invokevirtual +lisp-object+ "AREF" '(:int) +lisp-object+)
    69065791          (convert-representation nil representation)))
    69075792       (emit-move-from-stack target representation)))
     
    69365821           (maybe-emit-clear-values arg1 arg2 arg3)
    69375822           (cond ((fixnum-type-p type3)
    6938                   (emit-invokevirtual +lisp-object-class+ "aset" '("I" "I") nil))
     5823                  (emit-invokevirtual +lisp-object+ "aset" '(:int :int) nil))
    69395824                 (t
    6940                   (emit-invokevirtual +lisp-object-class+ "aset" (list "I" +lisp-object+) nil)))
     5825                  (emit-invokevirtual +lisp-object+ "aset" (list :int +lisp-object+) nil)))
    69415826           (when value-register
    69425827             (cond ((fixnum-type-p type3)
     
    69615846           (case arg2
    69625847             (0
    6963               (emit-invokevirtual +lisp-object-class+ "getSlotValue_0"
     5848              (emit-invokevirtual +lisp-object+ "getSlotValue_0"
    69645849                                  nil +lisp-object+))
    69655850             (1
    6966               (emit-invokevirtual +lisp-object-class+ "getSlotValue_1"
     5851              (emit-invokevirtual +lisp-object+ "getSlotValue_1"
    69675852                                  nil +lisp-object+))
    69685853             (2
    6969               (emit-invokevirtual +lisp-object-class+ "getSlotValue_2"
     5854              (emit-invokevirtual +lisp-object+ "getSlotValue_2"
    69705855                                  nil +lisp-object+))
    69715856             (3
    6972               (emit-invokevirtual +lisp-object-class+ "getSlotValue_3"
     5857              (emit-invokevirtual +lisp-object+ "getSlotValue_3"
    69735858                                  nil +lisp-object+))
    69745859             (t
    69755860              (emit-push-constant-int arg2)
    6976               (emit-invokevirtual +lisp-object-class+ "getSlotValue"
    6977                                   '("I") +lisp-object+)))
     5861              (emit-invokevirtual +lisp-object+ "getSlotValue"
     5862                                  '(:int) +lisp-object+)))
    69785863           (emit-move-from-stack target representation))
    69795864          ((fixnump arg2)
     
    69825867           (ecase representation
    69835868             (:int
    6984               (emit-invokevirtual +lisp-object-class+ "getFixnumSlotValue"
    6985                                   '("I") "I"))
     5869              (emit-invokevirtual +lisp-object+ "getFixnumSlotValue"
     5870                                  '(:int) :int))
    69865871             ((nil :char :long :float :double)
    6987               (emit-invokevirtual +lisp-object-class+ "getSlotValue"
    6988                                   '("I") +lisp-object+)
     5872              (emit-invokevirtual +lisp-object+ "getSlotValue"
     5873                                  '(:int) +lisp-object+)
    69895874              ;; (convert-representation NIL NIL) is a no-op
    69905875              (convert-representation nil representation))
    69915876             (:boolean
    6992               (emit-invokevirtual +lisp-object-class+ "getSlotValueAsBoolean"
    6993                                   '("I") "Z")))
     5877              (emit-invokevirtual +lisp-object+ "getSlotValueAsBoolean"
     5878                                  '(:int) :boolean)))
    69945879           (emit-move-from-stack target representation))
    69955880          (t
     
    70125897              (emit 'dup)
    70135898              (astore value-register))
    7014             (emit-invokevirtual +lisp-object-class+
     5899            (emit-invokevirtual +lisp-object+
    70155900                                (format nil "setSlotValue_~D" arg2)
    70165901                                (lisp-object-arg-types 1) nil)
     
    70295914              (emit 'dup)
    70305915              (astore value-register))
    7031             (emit-invokevirtual +lisp-object-class+ "setSlotValue"
    7032                                 (list "I" +lisp-object+) nil)
     5916            (emit-invokevirtual +lisp-object+ "setSlotValue"
     5917                                (list :int +lisp-object+) nil)
    70335918            (when value-register
    70345919              (aload value-register)
     
    70955980                  arg2 'stack nil)
    70965981           (emit 'swap)
    7097            (emit-invokevirtual +lisp-object-class+ "nthcdr" '("I") +lisp-object+)
     5982           (emit-invokevirtual +lisp-object+ "nthcdr" '(:int) +lisp-object+)
    70985983           (fix-boxing representation nil)
    70995984           (emit-move-from-stack target representation))
     
    71716056      (0
    71726057       (emit-push-current-thread)
    7173        (emit-invokevirtual +lisp-thread-class+ "setValues" nil +lisp-object+)
     6058       (emit-invokevirtual +lisp-thread+ "setValues" nil +lisp-object+)
    71746059       (emit-move-from-stack target))
    71756060      (1
     
    71916076                (compile-form arg1 'stack nil)
    71926077                (compile-form arg2 'stack nil))))
    7193        (emit-invokevirtual +lisp-thread-class+
     6078       (emit-invokevirtual +lisp-thread+
    71946079                           "setValues"
    71956080                           (lisp-object-arg-types len)
     
    72016086       (dolist (arg args)
    72026087         (compile-form arg 'stack nil))
    7203        (emit-invokevirtual +lisp-thread-class+
     6088       (emit-invokevirtual +lisp-thread+
    72046089                           "setValues"
    72056090                           (lisp-object-arg-types len)
     
    72286113           ;; "... a reference to a symbol declared with DEFCONSTANT always
    72296114           ;; refers to its global value."
    7230            (emit-invokevirtual +lisp-symbol-class+ "getSymbolValue"
     6115           (emit-invokevirtual +lisp-symbol+ "getSymbolValue"
    72316116                               nil +lisp-object+))
    72326117          ((and (variable-binding-register variable)
     
    72356120                      (variable-block variable))))
    72366121           (aload (variable-binding-register variable))
    7237            (emit 'getfield +lisp-special-binding-class+ "value"
     6122           (emit-getfield +lisp-special-binding+ "value"
    72386123                 +lisp-object+))
    72396124          (t
    72406125           (emit-push-current-thread)
    7241            (emit-invokevirtual +lisp-symbol-class+ "symbolValue"
     6126           (emit-invokevirtual +lisp-symbol+ "symbolValue"
    72426127                               (list +lisp-thread+) +lisp-object+)))
    72436128    (fix-boxing representation nil)
     
    72706155         (emit-push-current-thread)
    72716156         (compile-form (%cadr form) 'stack nil)
    7272          (emit 'checkcast +lisp-symbol-class+)
     6157         (emit-checkcast +lisp-symbol+)
    72736158         (compile-form (%caddr form) 'stack nil)
    72746159         (maybe-emit-clear-values (%cadr form) (%caddr form))
    7275          (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable"
     6160         (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
    72766161                             (list +lisp-symbol+ +lisp-object+) +lisp-object+)
    72776162         (fix-boxing representation nil)
     
    73156200             (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    73166201             (emit 'dup_x1) ;; copy past th
    7317              (emit 'putfield +lisp-special-binding-class+ "value"
     6202             (emit-putfield +lisp-special-binding+ "value"
    73186203                   +lisp-object+))
    73196204            ((and (consp value-form)
     
    73256210             (emit-load-externalized-object name)
    73266211       (compile-forms-and-maybe-emit-clear-values (second value-form) 'stack nil)
    7327              (emit-invokevirtual +lisp-thread-class+ "pushSpecial"
     6212             (emit-invokevirtual +lisp-thread+ "pushSpecial"
    73286213                                 (list +lisp-symbol+ +lisp-object+) +lisp-object+))
    73296214            (t
     
    73316216             (emit-load-externalized-object name)
    73326217       (compile-forms-and-maybe-emit-clear-values value-form 'stack nil)
    7333              (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable"
     6218             (emit-invokevirtual +lisp-thread+ "setSpecialVariable"
    73346219                                 (list +lisp-symbol+ +lisp-object+) +lisp-object+)))
    73356220      (fix-boxing representation nil)
     
    74106295         (let ((arg (%cadr form)))
    74116296     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    7412            (emit-invokevirtual +lisp-object-class+ "sxhash" nil "I")
     6297           (emit-invokevirtual +lisp-object+ "sxhash" nil :int)
    74136298           (convert-representation :int representation)
    74146299           (emit-move-from-stack target representation)))
     
    74226307    (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
    74236308     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    7424            (emit 'checkcast +lisp-symbol-class+)
    7425            (emit 'getfield  +lisp-symbol-class+ "name" +lisp-simple-string+)
     6309           (emit-checkcast +lisp-symbol+)
     6310           (emit-getfield  +lisp-symbol+ "name" +lisp-simple-string+)
    74266311           (emit-move-from-stack target representation))
    74276312          (t
     
    74346319    (cond ((and (eq (derive-compiler-type arg) 'SYMBOL) (< *safety* 3))
    74356320     (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    7436            (emit 'checkcast +lisp-symbol-class+)
    7437            (emit-invokevirtual +lisp-symbol-class+ "getPackage"
     6321           (emit-checkcast +lisp-symbol+)
     6322           (emit-invokevirtual +lisp-symbol+ "getPackage"
    74386323                               nil +lisp-object+)
    74396324           (fix-boxing representation nil)
     
    74486333      (when (eq (derive-compiler-type arg) 'SYMBOL)
    74496334  (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
    7450         (emit 'checkcast +lisp-symbol-class+)
     6335        (emit-checkcast +lisp-symbol+)
    74516336        (emit-push-current-thread)
    7452         (emit-invokevirtual +lisp-symbol-class+ "symbolValue"
     6337        (emit-invokevirtual +lisp-symbol+ "symbolValue"
    74536338                            (list +lisp-thread+) +lisp-object+)
    74546339        (fix-boxing representation nil)
     
    74636348  (declare (type symbol expected-type))
    74646349  (let ((instanceof-class (ecase expected-type
    7465                             (SYMBOL     +lisp-symbol-class+)
    7466                             (CHARACTER  +lisp-character-class+)
    7467                             (CONS       +lisp-cons-class+)
    7468                             (HASH-TABLE +lisp-hash-table-class+)
    7469                             (FIXNUM     +lisp-fixnum-class+)
    7470           (STREAM     +lisp-stream-class+)
    7471                             (STRING     +lisp-abstract-string-class+)
    7472                             (VECTOR     +lisp-abstract-vector-class+)))
     6350                            (SYMBOL     +lisp-symbol+)
     6351                            (CHARACTER  +lisp-character+)
     6352                            (CONS       +lisp-cons+)
     6353                            (HASH-TABLE +lisp-hash-table+)
     6354                            (FIXNUM     +lisp-fixnum+)
     6355          (STREAM     +lisp-stream+)
     6356                            (STRING     +lisp-abstract-string+)
     6357                            (VECTOR     +lisp-abstract-vector+)))
    74736358        (expected-type-java-symbol-name (case expected-type
    74746359                                          (HASH-TABLE "HASH_TABLE")
     
    74776362        (LABEL1 (gensym)))
    74786363    (emit 'dup)
    7479     (emit 'instanceof instanceof-class)
     6364    (emit-instanceof instanceof-class)
    74806365    (emit 'ifne LABEL1)
    7481     (emit-getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+)
    7482     (emit-invokestatic +lisp-class+ "type_error"
     6366    (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name +lisp-symbol+)
     6367    (emit-invokestatic +lisp+ "type_error"
    74836368                       (lisp-object-arg-types 2) +lisp-object+)
    74846369    (label LABEL1))
     
    76316516         (EXIT (gensym)))
    76326517    (compile-form (cadr form) 'stack nil)
    7633     (emit-invokevirtual +lisp-object-class+ "lockableInstance" nil
     6518    (emit-invokevirtual +lisp-object+ "lockableInstance" nil
    76346519                        +java-object+) ; value to synchronize
    76356520    (emit 'dup)
     
    76486533    (aload object-register)
    76496534    (emit 'monitorexit)
    7650     (push (make-handler :from BEGIN-PROTECTED-RANGE
    7651                         :to END-PROTECTED-RANGE
    7652                         :code END-PROTECTED-RANGE
    7653                         :catch-type 0) *handlers*)))
     6535    (add-exception-handler BEGIN-PROTECTED-RANGE
     6536                           END-PROTECTED-RANGE
     6537                           END-PROTECTED-RANGE nil)))
    76546538
    76556539
     
    76726556      (emit-push-current-thread)
    76736557      (aload tag-register)
    7674       (emit-invokevirtual +lisp-thread-class+ "pushCatchTag"
     6558      (emit-invokevirtual +lisp-thread+ "pushCatchTag"
    76756559                          (lisp-object-arg-types 1) nil)
    76766560      (let ((*blocks* (cons block *blocks*)))
     
    76836567      ;; The Throw object is on the runtime stack. Stack depth is 1.
    76846568      (emit 'dup) ; Stack depth is 2.
    7685       (emit 'getfield +lisp-throw-class+ "tag" +lisp-object+) ; Still 2.
     6569      (emit-getfield +lisp-throw+ "tag" +lisp-object+) ; Still 2.
    76866570      (aload tag-register) ; Stack depth is 3.
    76876571      ;; If it's not the tag we're looking for, we branch to the start of the
     
    76896573      (emit 'if_acmpne DEFAULT-HANDLER) ; Stack depth is 1.
    76906574      (emit-push-current-thread)
    7691       (emit-invokevirtual +lisp-throw-class+ "getResult"
     6575      (emit-invokevirtual +lisp-throw+ "getResult"
    76926576                          (list +lisp-thread+) +lisp-object+)
    76936577      (emit-move-from-stack target) ; Stack depth is 0.
     
    76966580      ;; A Throwable object is on the runtime stack here. Stack depth is 1.
    76976581      (emit-push-current-thread)
    7698       (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil)
     6582      (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil)
    76996583      (emit 'athrow) ; Re-throw.
    77006584      (label EXIT)
    77016585      ;; Finally...
    77026586      (emit-push-current-thread)
    7703       (emit-invokevirtual +lisp-thread-class+ "popCatchTag" nil nil)
    7704       (let ((handler1 (make-handler :from BEGIN-PROTECTED-RANGE
    7705                                     :to END-PROTECTED-RANGE
    7706                                     :code THROW-HANDLER
    7707                                     :catch-type (pool-class +lisp-throw-class+)))
    7708             (handler2 (make-handler :from BEGIN-PROTECTED-RANGE
    7709                                     :to END-PROTECTED-RANGE
    7710                                     :code DEFAULT-HANDLER
    7711                                     :catch-type 0)))
    7712         (push handler1 *handlers*)
    7713         (push handler2 *handlers*))))
     6587      (emit-invokevirtual +lisp-thread+ "popCatchTag" nil nil)
     6588      (add-exception-handler BEGIN-PROTECTED-RANGE
     6589                             END-PROTECTED-RANGE
     6590                             THROW-HANDLER +lisp-throw+)
     6591      (add-exception-handler BEGIN-PROTECTED-RANGE
     6592                             END-PROTECTED-RANGE
     6593                             DEFAULT-HANDLER nil)))
    77146594  t)
    77156595
     
    77216601  (emit-clear-values) ; Do this unconditionally! (MISC.503)
    77226602  (compile-form (third form) 'stack nil) ; Result.
    7723   (emit-invokevirtual +lisp-thread-class+ "throwToTag"
     6603  (emit-invokevirtual +lisp-thread+ "throwToTag"
    77246604                      (lisp-object-arg-types 2) nil)
    77256605  ;; Following code will not be reached.
     
    77646644        (unless (single-valued-p protected-form)
    77656645          (emit-push-current-thread)
    7766           (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+)
     6646          (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
    77676647          (astore values-register))
    77686648        (label END-PROTECTED-RANGE))
     
    77776657      (astore exception-register)
    77786658      (emit-push-current-thread)
    7779       (emit 'getfield +lisp-thread-class+ "_values" +lisp-object-array+)
     6659      (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
    77806660      (astore values-register)
    77816661      (let ((*register* *register*))
     
    77856665      (emit-push-current-thread)
    77866666      (aload values-register)
    7787       (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+)
     6667      (emit-putfield +lisp-thread+ "_values" +lisp-object-array+)
    77886668      (aload exception-register)
    77896669      (emit 'athrow) ; Re-throw exception.
     
    77936673        (emit-push-current-thread)
    77946674        (aload values-register)
    7795         (emit 'putfield +lisp-thread-class+ "_values" +lisp-object-array+))
     6675        (emit-putfield +lisp-thread+ "_values" +lisp-object-array+))
    77966676      ;; Result.
    77976677      (aload result-register)
    77986678      (emit-move-from-stack target)
    7799       (let ((handler (make-handler :from BEGIN-PROTECTED-RANGE
    7800                                    :to END-PROTECTED-RANGE
    7801                                    :code HANDLER
    7802                                    :catch-type 0)))
    7803         (push handler *handlers*)))))
     6679      (add-exception-handler BEGIN-PROTECTED-RANGE
     6680                             END-PROTECTED-RANGE HANDLER nil))))
    78046681
    78056682(defknown compile-form (t t t) t)
     
    78856762
    78866763
    7887 ;; Returns descriptor.
     6764;; Returns a list with the types of the arguments
    78886765(defun analyze-args (compiland)
    78896766  (let* ((args (cadr (compiland-p1-result compiland)))
     
    78926769    (aver (not (memq '&AUX args)))
    78936770
    7894     (when *child-p*
    7895       (when (or (memq '&KEY args)
    7896                 (memq '&OPTIONAL args)
    7897                 (memq '&REST args))
    7898         (setf *using-arg-array* t)
    7899         (setf *hairy-arglist-p* t)
    7900         (return-from analyze-args
    7901           (get-descriptor (list +lisp-object-array+) +lisp-object+)))
    7902       (return-from analyze-args
    7903         (cond ((<= arg-count call-registers-limit)
    7904                (get-descriptor (lisp-object-arg-types arg-count) +lisp-object+))
    7905               (t (setf *using-arg-array* t)
    7906                  (setf (compiland-arity compiland) arg-count)
    7907                  (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
    79086771    (when (or (memq '&KEY args)
    79096772              (memq '&OPTIONAL args)
    79106773              (memq '&REST args))
    7911       (setf *using-arg-array* t)
    7912       (setf *hairy-arglist-p* t)
    7913       (return-from analyze-args
    7914                    (get-descriptor (list +lisp-object-array+) +lisp-object+)))
     6774      (setf *using-arg-array* t
     6775            *hairy-arglist-p* t)
     6776      (return-from analyze-args (list +lisp-object-array+)))
     6777
    79156778    (cond ((<= arg-count call-registers-limit)
    7916            (get-descriptor (lisp-object-arg-types (length args))
    7917                             +lisp-object+))
    7918           (t
    7919            (setf *using-arg-array* t)
    7920            (setf (compiland-arity compiland) arg-count)
    7921            (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
     6779           (lisp-object-arg-types arg-count))
     6780          (t (setf *using-arg-array* t)
     6781             (setf (compiland-arity compiland) arg-count)
     6782             (list +lisp-object-array+)))))
    79226783
    79236784(defmacro with-open-class-file ((var class-file) &body body)
    79246785  `(with-open-file (,var (abcl-class-file-pathname ,class-file)
    7925       :direction :output
    7926       :element-type '(unsigned-byte 8)
    7927       :if-exists :supersede)
     6786                        :direction :output
     6787                        :element-type '(unsigned-byte 8)
     6788                        :if-exists :supersede)
    79286789     ,@body))
    79296790
    7930 (defun write-class-file (class-file stream)
    7931   (let* ((super (abcl-class-file-superclass class-file))
    7932          (this-index (pool-class (abcl-class-file-class class-file)))
    7933          (super-index (pool-class super))
    7934          (constructor (make-constructor super
    7935                                         (abcl-class-file-lambda-name class-file)
    7936                                         (abcl-class-file-lambda-list class-file))))
    7937     (pool-name "Code") ; Must be in pool!
    7938 
    7939     (when *file-compilation*
    7940       (pool-name "SourceFile") ; Must be in pool!
    7941       (pool-name (file-namestring *compile-file-truename*)))
    7942     (when (and (boundp '*source-line-number*)
    7943                (fixnump *source-line-number*))
    7944       (pool-name "LineNumberTable")) ; Must be in pool!
    7945    
    7946     (write-u4 #xCAFEBABE stream)
    7947     (write-u2 3 stream)
    7948     (write-u2 45 stream)
    7949     (write-constant-pool stream)
    7950     ;; access flags
    7951     (write-u2 #x21 stream)
    7952     (write-u2 this-index stream)
    7953     (write-u2 super-index stream)
    7954     ;; interfaces count
    7955     (write-u2 0 stream)
    7956     ;; fields count
    7957     (write-u2 (length *fields*) stream)
    7958     ;; fields
    7959     (dolist (field *fields*)
    7960       (write-field field stream))
    7961     ;; methods count
    7962     (write-u2 (1+ (length (abcl-class-file-methods class-file))) stream)
    7963     ;; methods
    7964     (dolist (method (abcl-class-file-methods class-file))
    7965       (write-method method stream))
    7966     (write-method constructor stream)
    7967     ;; attributes count
    7968     (cond (*file-compilation*
    7969      ;; attributes count
    7970      (write-u2 1 stream)
    7971      ;; attributes table
    7972      (write-source-file-attr (file-namestring *compile-file-truename*)
    7973            stream))
    7974     (t
    7975      ;; attributes count
    7976      (write-u2 0 stream)))
    7977     stream))
    79786791
    79796792(defknown p2-compiland-process-type-declarations (list) t)
     
    80386851         (*child-p* (not (null (compiland-parent compiland))))
    80396852
    8040          (descriptor (analyze-args compiland))
    8041          (execute-method (make-method :name "execute"
    8042                                       :descriptor descriptor))
     6853         (arg-types (analyze-args compiland))
     6854         (method (make-method "execute" +lisp-object+ arg-types
     6855                               :flags '(:final :public)))
     6856         (code (method-add-code method))
     6857         (*current-code-attribute* code)
    80436858         (*code* ())
    80446859         (*register* 1) ;; register 0: "this" pointer
    80456860         (*registers-allocated* 1)
    8046          (*handlers* ())
    80476861         (*visible-variables* *visible-variables*)
    80486862
     
    80506864         (*initialize-thread-var* nil)
    80516865         (label-START (gensym)))
     6866
     6867    (class-add-method class-file method)
     6868    (when (fixnump *source-line-number*)
     6869      (let ((table (make-line-numbers-attribute)))
     6870        (method-add-attribute method table)
     6871        (line-numbers-add-line table 0 *source-line-number*)))
    80526872
    80536873    (dolist (var (compiland-arg-vars compiland))
     
    80836903            ;; if we're the ultimate parent: create the closure array
    80846904            (emit-push-constant-int (length *closure-variables*))
    8085             (emit 'anewarray +closure-binding-class+))
     6905            (emit-anewarray +lisp-closure-binding+))
    80866906        (progn
    80876907          (aload 0)
    8088           (emit 'getfield +lisp-compiled-closure-class+ "ctx"
     6908          (emit-getfield +lisp-compiled-closure+ "ctx"
    80896909                +closure-binding-array+)
    80906910          (when local-closure-vars
     
    81106930            (emit 'dup) ; array
    81116931            (emit-push-constant-int i)
    8112             (emit 'new +closure-binding-class+)
     6932            (emit-new +lisp-closure-binding+)
    81136933            (emit 'dup)
    81146934            (cond
     
    81286948              (t
    81296949               (assert (not "Can't happen!!"))))
    8130             (emit-invokespecial-init +closure-binding-class+
     6950            (emit-invokespecial-init +lisp-closure-binding+
    81316951                                     (list +lisp-object+))
    81326952            (emit 'aastore)))))
     
    81807000                 (emit 'aaload)
    81817001                 (setf (variable-index variable) nil)))
    8182           (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     7002          (emit-invokevirtual +lisp-thread+ "bindSpecial"
    81837003                              (list +lisp-symbol+ +lisp-object+)
    81847004                              +lisp-special-binding+)
     
    82227042        (astore (compiland-argument-register compiland)))
    82237043
    8224       (maybe-initialize-thread-var)
     7044      (unless (and *hairy-arglist-p*
     7045                   (or (memq '&OPTIONAL args) (memq '&KEY args)))
     7046        (maybe-initialize-thread-var))
    82257047      (setf *code* (nconc code *code*)))
    82267048
     
    82287050          (if (or *hairy-arglist-p*
    82297051      (and *child-p* *closure-variables*))
    8230         +lisp-compiled-closure-class+
    8231       +lisp-primitive-class+))
     7052        +lisp-compiled-closure+
     7053      +lisp-primitive+))
    82327054
    82337055    (setf (abcl-class-file-lambda-list class-file) args)
    8234     (setf (method-max-locals execute-method) *registers-allocated*)
    8235     (push execute-method (abcl-class-file-methods class-file))
    8236 
    8237 
    8238     ;;;  Move here
    8239     (finalize-code)
    8240     (optimize-code)
    8241 
    8242     (setf *code* (resolve-instructions *code*))
    8243     (setf (method-max-stack execute-method) (analyze-stack))
    8244     (setf (method-code execute-method) (code-bytes *code*))
    8245 
    8246     ;; Remove handler if its protected range is empty.
    8247     (setf *handlers*
    8248           (delete-if (lambda (handler)
    8249                        (eql (symbol-value (handler-from handler))
    8250                             (symbol-value (handler-to handler))))
    8251                      *handlers*))
    8252     ;;; to here
    8253     ;;; To a separate function which is part of class file finalization
    8254     ;;;  when we have a section of class-file-generation centered code
    8255 
    8256 
    8257     (setf (method-handlers execute-method) (nreverse *handlers*)))
     7056    (setf (code-max-locals code) *registers-allocated*)
     7057    (setf (code-code code) *code*))
     7058
     7059
    82587060  t)
    82597061
     
    82727074        (*current-compiland* compiland))
    82737075    (with-saved-compiler-policy
    8274       ;; Pass 1.
    8275       (p1-compiland compiland)
    8276       ;; *all-variables* doesn't contain variables which
    8277       ;; are in an enclosing lexical environment (variable-environment)
    8278       ;; so we don't need to filter them out
    8279       (setf *closure-variables*
    8280             (remove-if #'variable-special-p
    8281                        (remove-if-not #'variable-used-non-locally-p
    8282                                                  *all-variables*)))
    8283       (let ((i 0))
    8284         (dolist (var (reverse *closure-variables*))
    8285           (setf (variable-closure-index var) i)
    8286           (dformat t "var = ~S closure index = ~S~%" (variable-name var)
    8287                    (variable-closure-index var))
    8288           (incf i)))
     7076        ;; Pass 1.
     7077        (p1-compiland compiland))
     7078
     7079    ;; *all-variables* doesn't contain variables which
     7080    ;; are in an enclosing lexical environment (variable-environment)
     7081    ;; so we don't need to filter them out
     7082    (setf *closure-variables*
     7083          (remove-if #'variable-special-p
     7084                     (remove-if-not #'variable-used-non-locally-p
     7085                                    *all-variables*)))
     7086    (let ((i 0))
     7087      (dolist (var (reverse *closure-variables*))
     7088        (setf (variable-closure-index var) i)
     7089        (dformat t "var = ~S closure index = ~S~%" (variable-name var)
     7090                 (variable-closure-index var))
     7091        (incf i)))
    82897092
    82907093      ;; Assert that we're not refering to any variables
    82917094      ;; we're not allowed to use
    8292       (assert (= 0
    8293                  (length (remove-if (complement #'variable-references)
    8294                                     (remove-if #'variable-references-allowed-p
    8295                                                *visible-variables*)))))
     7095
     7096    (assert (= 0
     7097               (length (remove-if (complement #'variable-references)
     7098                                  (remove-if #'variable-references-allowed-p
     7099                                             *visible-variables*)))))
    82967100
    82977101      ;; Pass 2.
    8298       (with-class-file (compiland-class-file compiland)
     7102
     7103    (with-class-file (compiland-class-file compiland)
     7104      (with-saved-compiler-policy
    82997105        (p2-compiland compiland)
    8300         (write-class-file (compiland-class-file compiland) stream)))))
     7106        ;;        (finalize-class-file (compiland-class-file compiland))
     7107        (finish-class (compiland-class-file compiland) stream)))))
    83017108
    83027109(defvar *compiler-error-bailout*)
     
    83127119  (aver (eq (car form) 'LAMBDA))
    83137120  (catch 'compile-defun-abort
    8314     (let* ((class-file (make-class-file :pathname filespec
    8315                                         :lambda-name name
    8316                                         :lambda-list (cadr form)))
     7121    (let* ((class-file (make-abcl-class-file :pathname filespec
     7122                                             :lambda-name name
     7123                                             :lambda-list (cadr form)))
    83177124           (*compiler-error-bailout*
    83187125            `(lambda ()
    8319                (compile-1 (make-compiland :name ',name
    8320                                           :lambda-expression (make-compiler-error-form ',form)
    8321                                           :class-file
    8322                                           (make-class-file :pathname ,filespec
    8323                                                            :lambda-name ',name
    8324                                                            :lambda-list (cadr ',form)))
    8325         ,stream)))
     7126               (compile-1
     7127                (make-compiland :name ',name
     7128                                :lambda-expression (make-compiler-error-form ',form)
     7129                                :class-file
     7130                                (make-abcl-class-file :pathname ,filespec
     7131                                                      :lambda-name ',name
     7132                                                      :lambda-list (cadr ',form)))
     7133                ,stream)))
    83267134           (*compile-file-environment* environment))
    8327         (compile-1 (make-compiland :name name
    8328                                    :lambda-expression
    8329                                    (precompiler:precompile-form form t
    8330                                                                 environment)
    8331                                    :class-file class-file)
    8332        stream))))
     7135      (compile-1 (make-compiland :name name
     7136                                 :lambda-expression
     7137                                 (precompiler:precompile-form form t
     7138                                                              environment)
     7139                                 :class-file class-file)
     7140                 stream))))
    83337141
    83347142(defvar *catch-errors* t)
  • trunk/abcl/src/org/armedbear/lisp/jvm.lisp

    r12690 r12918  
    4343  (require "COMPILER-ERROR")
    4444  (require "KNOWN-FUNCTIONS")
     45  (require "DUMP-FORM")
     46  (require "JVM-INSTRUCTIONS")
     47  (require "JVM-CLASS-FILE")
    4548  (require "KNOWN-SYMBOLS")
    46   (require "DUMP-FORM")
    47   (require "OPCODES")
    4849  (require "JAVA")
    4950  (require "COMPILER-PASS1")
     
    6162(defmacro dformat (&rest ignored)
    6263  (declare (ignore ignored)))
     64
     65(declaim (inline u2 s1 s2))
     66
     67(defknown u2 (fixnum) cons)
     68(defun u2 (n)
     69  (declare (optimize speed))
     70  (declare (type (unsigned-byte 16) n))
     71  (when (not (<= 0 n 65535))
     72    (error "u2 argument ~A out of 65k range." n))
     73  (list (logand (ash n -8) #xff)
     74        (logand n #xff)))
     75
     76(defknown s1 (fixnum) fixnum)
     77(defun s1 (n)
     78  (declare (optimize speed))
     79  (declare (type (signed-byte 8) n))
     80  (when (not (<= -128 n 127))
     81    (error "s2 argument ~A out of 16-bit signed range." n))
     82  (if (< n 0)
     83      (1+ (logxor (- n) #xFF))
     84      n))
     85
     86
     87(defknown s2 (fixnum) cons)
     88(defun s2 (n)
     89  (declare (optimize speed))
     90  (declare (type (signed-byte 16) n))
     91  (when (not (<= -32768 n 32767))
     92    (error "s2 argument ~A out of 16-bit signed range." n))
     93  (u2 (if (< n 0) (1+ (logxor (- n) #xFFFF))
     94          n)))
     95
     96
     97
    6398
    6499
     
    78113
    79114(defvar *pool* nil)
    80 (defvar *pool-count* 1)
    81 (defvar *pool-entries* nil)
    82 (defvar *fields* ())
    83115(defvar *static-code* ())
     116(defvar *class-file* nil)
    84117
    85118(defvar *externalized-objects* nil)
    86119(defvar *declared-functions* nil)
    87120
    88 (defstruct (abcl-class-file (:constructor %make-abcl-class-file))
     121(defstruct (abcl-class-file (:include class-file)
     122                            (:constructor %make-abcl-class-file))
    89123  pathname ; pathname of output file
     124  class-name
    90125  lambda-name
    91   class
    92   superclass
    93126  lambda-list ; as advertised
    94   pool
    95   (pool-count 1)
    96   (pool-entries (make-hash-table :test #'equal))
    97   fields
    98   methods
    99127  static-code
    100128  objects ;; an alist of externalized objects and their field names
     
    108136      (declare (type fixnum i))
    109137      (when (or (char= (char name i) #\-)
    110     (char= (char name i) #\Space))
     138                (char= (char name i) #\Space))
    111139        (setf (char name i) #\_)))
    112     (concatenate 'string "org/armedbear/lisp/" name)))
     140    (make-class-name
     141     (concatenate 'string "org.armedbear.lisp." name))))
    113142
    114143(defun make-unique-class-name ()
    115144  "Creates a random class name for use with a `class-file' structure's
    116145`class' slot."
    117   (concatenate 'string "abcl_"
    118           (java:jcall (java:jmethod "java.lang.String" "replace" "char" "char")
    119                       (java:jcall (java:jmethod "java.util.UUID" "toString")
    120                              (java:jstatic "randomUUID" "java.util.UUID"))
    121                       #\- #\_)))
    122 
    123 (defun make-class-file (&key pathname lambda-name lambda-list)
     146  (make-class-name
     147   (concatenate 'string "abcl_"
     148                (substitute #\_ #\-
     149                            (java:jcall (java:jmethod "java.util.UUID"
     150                                                      "toString")
     151                                        (java:jstatic "randomUUID"
     152                                                      "java.util.UUID"))))))
     153
     154(defun make-abcl-class-file (&key pathname lambda-name lambda-list)
    124155  "Creates a `class-file' structure. If `pathname' is non-NIL, it's
    125156used to derive a class name. If it is NIL, a random one created
     
    129160                         (make-unique-class-name)))
    130161         (class-file (%make-abcl-class-file :pathname pathname
    131                                             :class class-name
     162                                            :class class-name ; to be finalized
     163                                            :class-name class-name
    132164                                            :lambda-name lambda-name
    133                                             :lambda-list lambda-list)))
     165                                            :lambda-list lambda-list
     166                                            :access-flags '(:public :final))))
     167    (when *file-compilation*
     168      (let ((source-attribute
     169             (make-source-file-attribute
     170              :filename (file-namestring *compile-file-truename*))))
     171        (class-add-attribute class-file source-attribute)))
    134172    class-file))
    135173
    136174(defmacro with-class-file (class-file &body body)
    137175  (let ((var (gensym)))
    138     `(let* ((,var ,class-file)
    139             (*pool*                 (abcl-class-file-pool ,var))
    140             (*pool-count*           (abcl-class-file-pool-count ,var))
    141             (*pool-entries*         (abcl-class-file-pool-entries ,var))
    142             (*fields*               (abcl-class-file-fields ,var))
     176    `(let* ((,var                   ,class-file)
     177            (*class-file*           ,var)
     178            (*pool*                 (abcl-class-file-constants ,var))
    143179            (*static-code*          (abcl-class-file-static-code ,var))
    144180            (*externalized-objects* (abcl-class-file-objects ,var))
    145181            (*declared-functions*   (abcl-class-file-functions ,var)))
    146182       (progn ,@body)
    147        (setf (abcl-class-file-pool ,var)         *pool*
    148              (abcl-class-file-pool-count ,var)   *pool-count*
    149              (abcl-class-file-pool-entries ,var) *pool-entries*
    150              (abcl-class-file-fields ,var)       *fields*
    151              (abcl-class-file-static-code ,var)  *static-code*
     183       (setf (abcl-class-file-static-code ,var)  *static-code*
    152184             (abcl-class-file-objects ,var)      *externalized-objects*
    153185             (abcl-class-file-functions ,var)    *declared-functions*))))
     
    196228(defvar *this-class* nil)
    197229
    198 (defvar *code* ())
    199 
    200230;; All tags visible at the current point of compilation, some of which may not
    201231;; be in the current compiland.
     
    207237;; Total number of registers allocated.
    208238(defvar *registers-allocated* 0)
    209 
    210 (defvar *handlers* ())
    211 
    212 (defstruct handler
    213   from       ;; label indicating the start of the protected block
    214   to         ;; label indicating the end of the protected block
    215   code       ;; label to jump to if the specified exception occurs
    216   catch-type ;; pool index of the class name of the exception, or 0 (zero)
    217              ;; for 'all'
    218   )
    219239
    220240;; Variables visible at the current point of compilation.
  • trunk/abcl/src/org/armedbear/lisp/known-symbols.lisp

    r12583 r12918  
    3939  (defun initialize-known-symbols (source ht)
    4040    (let* ((source-class (java:jclass source))
    41            (class-designator (substitute #\/ #\. source))
     41           (class-designator (jvm::make-class-name source))
    4242           (symbol-class (java:jclass "org.armedbear.lisp.Symbol"))
    4343           (fields (java:jclass-fields source-class :declared t :public t)))
  • trunk/abcl/test/lisp/ansi/parse-ansi-errors.lisp

    r12888 r12918  
    7777  (if (find :asdf2 *features*)
    7878      (asdf:system-relative-pathname :ansi-compiled "test/lisp/ansi/ansi-test-failures")
    79       (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*))))
     79      (merge-pathnames "ansi-test-failures" (directory-namestring *load-truename*)))
    8080
    8181(defun parse (&optional (file *default-database-file*))
Note: See TracChangeset for help on using the changeset viewer.