Changeset 8387


Ignore:
Timestamp:
01/23/05 03:23:35 (17 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r8386 r8387  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.363 2005-01-22 19:00:37 piso Exp $
     4;;; $Id: jvm.lisp,v 1.364 2005-01-23 03:23:35 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
    … …  
    863863(defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
    864864(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
     865(defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;")
    865866(defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
    866867(defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
    … …  
    901902                (princ (or return-type "V") s))))))
    902903
    903 (defun descriptor (designator)
    904   (cond ((stringp designator)
    905          designator)
    906         ((listp designator)
    907          (unless (= (length designator) 2)
    908            (error "Bad method type descriptor ~S." designator))
    909          (make-descriptor (car designator) (cadr designator)))
    910         (t
    911          (error "Bad method type descriptor ~S." designator))))
    912 
    913 (defun emit-invokestatic (class-name method-name descriptor stack)
    914   (aver stack)
    915   (let ((instruction (emit 'invokestatic
    916                            class-name method-name (descriptor descriptor))))
    917     (setf (instruction-stack instruction) stack)
    918     (aver (eql (instruction-stack instruction) stack))))
    919 
    920 (defun emit-invokespecial (class-name method-name descriptor stack)
    921   (let ((instruction (emit 'invokespecial
    922                            class-name method-name (descriptor descriptor))))
     904(defun %emit-invokestatic (class-name method-name descriptor stack)
     905  (let ((instruction (emit 'invokestatic class-name method-name descriptor)))
    923906    (setf (instruction-stack instruction) stack)))
    924907
     908;; FIXME
     909;; The way we calculate the stack effect here assumes that each argument
     910;; occupies one slot. This is NOT CORRECT for Java longs ("J")!
     911(defun emit-invokestatic (class-name method-name arg-types return-type)
     912  (let* ((descriptor (make-descriptor arg-types return-type))
     913         (stack (- (if return-type 1 0) (length arg-types)))
     914         (instruction (emit 'invokestatic
     915                           class-name method-name descriptor)))
     916    (setf (instruction-stack instruction) stack)))
     917
     918;; FIXME
     919;; The way we calculate the stack effect here assumes that each argument
     920;; occupies one slot. This is NOT CORRECT for Java longs ("J")!
    925921(defun emit-invokevirtual (class-name method-name arg-types return-type)
    926922  (let* ((descriptor (make-descriptor arg-types return-type))
    … …  
    929925    (setf (instruction-stack instruction) stack)))
    930926
     927(defun emit-invokespecial-init (class-name arg-types)
     928  (let* ((descriptor (make-descriptor arg-types nil))
     929         (stack (- (1+ (length arg-types))))
     930         (instruction (emit 'invokespecial class-name "<init>" descriptor)))
     931    (setf (instruction-stack instruction) stack)))
     932
    931933;; Index of local variable used to hold the current thread.
    932934(defvar *thread* nil)
    … …  
    936938(defun maybe-initialize-thread-var ()
    937939  (when *initialize-thread-var*
    938     (emit-invokestatic +lisp-thread-class+
    939                        "currentThread"
    940                        (make-descriptor () +lisp-thread+)
    941                        1)
     940    (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+)
    942941    (emit 'astore *thread*)))
    943942
    … …  
    969968      (emit 'getstatic +lisp-class+ "interrupted" "Z")
    970969      (emit 'ifeq `,label1)
    971       (emit-invokestatic +lisp-class+
    972                          "handleInterrupt"
    973                          "()V"
    974                          0)
     970      (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil)
    975971      (emit 'label `,label1))))
    976972
    … …  
    11241120  (declare (optimize speed))
    11251121  (cond ((= *safety* 3)
    1126          (emit-invokestatic +lisp-fixnum-class+
    1127                             "getValue"
    1128                             "(Lorg/armedbear/lisp/LispObject;)I"
    1129                             0))
     1122         (emit-invokestatic +lisp-fixnum-class+ "getValue"
     1123                            (list +lisp-object+) "I"))
    11301124        (t
    11311125         (emit 'checkcast +lisp-fixnum-class+)
    … …  
    11341128(defun emit-box-long ()
    11351129  (declare (optimize speed))
    1136   (emit-invokestatic +lisp-class+
    1137                     "number"
    1138                      "(J)Lorg/armedbear/lisp/LispObject;"
    1139                      -1))
     1130;;   (emit-invokestatic +lisp-class+ "number" (list "J") +lisp-object+)
     1131  (%emit-invokestatic +lisp-class+ "number"
     1132                      (make-descriptor (list "J") +lisp-object+)
     1133                      -1))
    11401134
    11411135;; Expects value on stack.
    … …  
    18281822  handlers)
    18291823
    1830 (defun make-constructor (super name args body)
     1824(defun make-constructor (super name args)
    18311825  (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors.
    18321826         (constructor (make-method :name "<init>"
    … …  
    18381832    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
    18391833    (setf (method-max-locals constructor) 1)
    1840     (cond
    1841      (*hairy-arglist-p*
    1842       (emit 'aload_0) ;; this
    1843       (emit 'aconst_null) ;; name
    1844       (let* ((*print-level* nil)
    1845              (*print-length* nil)
    1846              (s (%format nil "~S" args)))
    1847         (emit 'ldc
    1848               (pool-string s))
    1849         (emit-invokestatic +lisp-class+
    1850                            "readObjectFromString"
    1851                            "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    1852                            0))
    1853       (emit-push-nil) ;; body
    1854       (emit 'aconst_null) ;; environment
    1855       (emit-invokespecial super
    1856                           "<init>"
    1857                           ;;                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
    1858 ;;                           `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil)
    1859                           (make-descriptor (list +lisp-symbol+ +lisp-object+ +lisp-object+ +lisp-environment+)
    1860                                            nil)
    1861                           -5))
    1862      (*child-p*
    1863       (cond
    1864        ((null *closure-variables*)
    1865         (emit 'aload_0)
    1866         (emit-invokespecial super
    1867                             "<init>"
    1868                             "()V"
    1869                             -1))
    1870         (t
    1871          (emit 'aload_0) ;; this
    1872          (let* ((*print-level* nil)
    1873                 (*print-length* nil)
    1874                 (s (%format nil "~S" args)))
    1875            (emit 'ldc
    1876                  (pool-string s))
    1877            (emit-invokestatic +lisp-class+
    1878                               "readObjectFromString"
    1879                               "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    1880                               0))
    1881          (emit-invokespecial super
    1882                              "<init>"
    1883                              "(Lorg/armedbear/lisp/LispObject;)V"
    1884                              -2))))
    1885      (t
    1886       (emit 'aload_0)
    1887       (emit-invokespecial super
    1888                           "<init>"
    1889                           "()V"
    1890                           -1)))
     1834    (cond (*hairy-arglist-p*
     1835           (emit 'aload_0) ;; this
     1836           (emit 'aconst_null) ;; name
     1837           (let* ((*print-level* nil)
     1838                  (*print-length* nil)
     1839                  (s (%format nil "~S" args)))
     1840             (emit 'ldc (pool-string s))
     1841             (emit-invokestatic +lisp-class+ "readObjectFromString"
     1842                                (list +java-string+) +lisp-object+))
     1843           (emit-push-nil) ;; body
     1844           (emit 'aconst_null) ;; environment
     1845           (emit-invokespecial-init super
     1846                                    (list +lisp-symbol+ +lisp-object+
     1847                                          +lisp-object+ +lisp-environment+)))
     1848          (*child-p*
     1849           (cond ((null *closure-variables*)
     1850                  (emit 'aload_0)
     1851                  (emit-invokespecial-init super nil))
     1852                 (t (emit 'aload_0) ;; this
     1853                    (let* ((*print-level* nil)
     1854                           (*print-length* nil)
     1855                           (s (%format nil "~S" args)))
     1856                      (emit 'ldc (pool-string s))
     1857                      (emit-invokestatic +lisp-class+ "readObjectFromString"
     1858                                         (list +java-string+) +lisp-object+))
     1859                    (emit-invokespecial-init super (list +lisp-object+)))))
     1860          (t (emit 'aload_0)
     1861             (emit-invokespecial-init super nil)))
    18911862    (setf *code* (append *static-code* *code*))
    18921863    (emit 'return)
    18931864    (finalize-code)
    1894 ;;     (optimize-code)
     1865    ;;(optimize-code)
    18951866    (setf *code* (resolve-instructions *code*))
    18961867    (setf (method-max-stack constructor) (analyze-stack))
    … …  
    19811952        (emit 'ldc (pool-string (symbol-name symbol)))
    19821953        (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    1983         (emit-invokestatic +lisp-class+
    1984                            "internInPackage"
    1985                            "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
    1986                            -1)
    1987         (emit 'putstatic
    1988               *this-class*
    1989               g
    1990               +lisp-symbol+)
     1954        (emit-invokestatic +lisp-class+ "internInPackage"
     1955                           (list +java-string+ +java-string+) +lisp-symbol+)
     1956        (emit 'putstatic *this-class* g +lisp-symbol+)
    19911957        (setf *static-code* *code*)
    19921958        (setf (gethash symbol *declared-symbols*) g)))
    … …  
    20001966        (declare-field g +lisp-symbol+)
    20011967        (emit 'ldc (pool-string (symbol-name symbol)))
    2002         (emit-invokestatic "org/armedbear/lisp/Keyword"
    2003                            "internKeyword"
    2004                            "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
    2005                            0)
    2006         (emit 'putstatic
    2007               *this-class*
    2008               g
    2009               +lisp-symbol+)
     1968        (emit-invokestatic "org/armedbear/lisp/Keyword" "internKeyword"
     1969                           (list +java-string+) +lisp-symbol+)
     1970        (emit 'putstatic *this-class* g +lisp-symbol+)
    20101971        (setf *static-code* *code*)
    20111972        (setf (gethash symbol *declared-symbols*) g)))
    … …  
    20221983            (g (gethash symbol *declared-symbols*)))
    20231984        (cond (g
    2024                (emit 'getstatic
    2025                      *this-class*
    2026                      g
    2027                      +lisp-symbol+))
     1985               (emit 'getstatic *this-class* g +lisp-symbol+))
    20281986              (t
    20291987               (emit 'ldc (pool-string (symbol-name symbol)))
    20301988               (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    2031                (emit-invokestatic +lisp-class+
    2032                                   "internInPackage"
    2033                                   "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
    2034                                   -1)))
     1989               (emit-invokestatic +lisp-class+ "internInPackage"
     1990                                  (list +java-string+ +java-string+)
     1991                                  +lisp-symbol+)))
    20351992        (declare-field f +lisp-object+)
    2036         (emit-invokevirtual +lisp-symbol-class+
    2037                             "getSymbolFunctionOrDie"
    2038                             nil
    2039                             +lisp-object+)
    2040         (emit 'putstatic
    2041               *this-class*
    2042               f
    2043               +lisp-object+)
     1993        (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
     1994                            nil +lisp-object+)
     1995        (emit 'putstatic *this-class* f +lisp-object+)
    20441996        (setq *static-code* *code*)
    20451997        (setf (gethash symbol *declared-functions*) f)))
    … …  
    20642016                 (emit 'ldc (pool-string (symbol-name symbol)))
    20652017                 (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    2066                  (emit-invokestatic +lisp-class+
    2067                                     "internInPackage"
    2068                                     "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
    2069                                     -1)))
     2018                 (emit-invokestatic +lisp-class+ "internInPackage"
     2019                                    (list +java-string+ +java-string+)
     2020                                    +lisp-symbol+)))
    20702021          (declare-field f +lisp-object+)
    2071           (emit-invokevirtual +lisp-symbol-class+
    2072                               "getSymbolSetfFunctionOrDie"
    2073                               nil
    2074                               +lisp-object+)
    2075           (emit 'putstatic
    2076                 *this-class*
    2077                 f
    2078                 +lisp-object+)
     2022          (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
     2023                              nil +lisp-object+)
     2024          (emit 'putstatic *this-class* f +lisp-object+)
    20792025          (setq *static-code* *code*)
    20802026          (setf (gethash name *declared-functions*) f))))
    … …  
    21092055          (t
    21102056           (emit 'ldc (pool-int n))))
    2111         (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
     2057        (emit-invokespecial-init +lisp-fixnum-class+ '("I"))
    21122058        (emit 'putstatic *this-class* g +lisp-fixnum+)
    21132059        (setf *static-code* *code*)
    … …  
    21222068         (*code* *static-code*))
    21232069    (declare-field g +lisp-object+)
    2124     (emit 'ldc
    2125           (pool-string s))
    2126     (emit-invokestatic +lisp-class+
    2127                        "readObjectFromString"
    2128                        "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    2129                        0)
    2130     (emit 'putstatic
    2131           *this-class*
    2132           g
    2133           +lisp-object+)
     2070    (emit 'ldc (pool-string s))
     2071    (emit-invokestatic +lisp-class+ "readObjectFromString"
     2072                       (list +java-string+) +lisp-object+)
     2073    (emit 'putstatic *this-class* g +lisp-object+)
    21342074    (setf *static-code* *code*)
    21352075    g))
    … …  
    21422082         (*code* *static-code*))
    21432083    (declare-field g +lisp-object+)
    2144     (emit 'ldc
    2145           (pool-string s))
    2146     (emit-invokestatic +lisp-class+
    2147                        "readObjectFromString"
    2148                        "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    2149                        0)
    2150     (emit 'putstatic
    2151           *this-class*
    2152           g
    2153           +lisp-object+)
     2084    (emit 'ldc (pool-string s))
     2085    (emit-invokestatic +lisp-class+ "readObjectFromString"
     2086                       (list +java-string+) +lisp-object+)
     2087    (emit 'putstatic *this-class* g +lisp-object+)
    21542088    (setf *static-code* *code*)
    21552089    g))
    … …  
    21622096           (*code* *static-code*))
    21632097      (declare-field g2 +lisp-object+)
    2164       (emit 'getstatic
    2165             *this-class*
    2166             g1
    2167             +lisp-string+)
    2168       (emit-invokestatic +lisp-class+
    2169                          "recall"
    2170                          "(Lorg/armedbear/lisp/SimpleString;)Lorg/armedbear/lisp/LispObject;"
    2171                          0)
    2172       (emit 'putstatic
    2173             *this-class*
    2174             g2
    2175             +lisp-object+)
     2098      (emit 'getstatic *this-class* g1 +lisp-string+)
     2099      (emit-invokestatic +lisp-class+ "recall"
     2100                         (list +lisp-simple-string+) +lisp-object+)
     2101      (emit 'putstatic *this-class* g2 +lisp-object+)
    21762102      (setf *static-code* *code*)
    21772103      g2)))
    … …  
    21862112    (emit 'ldc
    21872113          (pool-string s))
    2188     (emit-invokestatic +lisp-class+
    2189                        "readObjectFromString"
    2190                        "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    2191                        0)
    2192     (emit-invokestatic +lisp-class+
    2193                        "coerceToFunction"
    2194                        "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    2195                        0)
    2196     (emit 'putstatic
    2197           *this-class*
    2198           g
    2199           +lisp-object+)
     2114    (emit-invokestatic +lisp-class+ "readObjectFromString"
     2115                       (list +java-string+) +lisp-object+)
     2116    (emit-invokestatic +lisp-class+ "coerceToFunction"
     2117                       (list +lisp-object+) +lisp-object+)
     2118    (emit 'putstatic *this-class* g +lisp-object+)
    22002119    (setf *static-code* *code*)
    22012120    g))
    … …  
    22062125         (*code* *static-code*))
    22072126    (declare-field g +lisp-object+)
    2208     (emit 'ldc
    2209           (pool-string (file-namestring classfile)))
    2210     (emit-invokestatic +lisp-class+
    2211                        "loadCompiledFunction"
    2212                        "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    2213                        0)
    2214     (emit 'putstatic
    2215           *this-class*
    2216           g
    2217           +lisp-object+)
     2127    (emit 'ldc (pool-string (file-namestring classfile)))
     2128    (emit-invokestatic +lisp-class+ "loadCompiledFunction"
     2129                       (list +java-string+) +lisp-object+)
     2130    (emit 'putstatic *this-class* g +lisp-object+)
    22182131    (setf *static-code* *code*)
    22192132    g))
    … …  
    22282141        (emit 'dup)
    22292142        (emit 'ldc (pool-string string))
    2230         (emit-invokespecial +lisp-simple-string-class+
    2231                             "<init>"
    2232                             "(Ljava/lang/String;)V"
    2233                             -2)
    2234         (emit 'putstatic
    2235               *this-class*
    2236               g
    2237               +lisp-simple-string+)
     2143        (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
     2144        (emit 'putstatic *this-class* g +lisp-simple-string+)
    22382145        (setf *static-code* *code*)
    22392146        (setf (gethash string *declared-strings*) g)))
    … …  
    22442151    (return-from compile-constant))
    22452152  (when (eq representation :unboxed-fixnum)
    2246     (cond
    2247      ((fixnump form)
    2248       (emit-push-constant-int form)
    2249       (emit-move-from-stack target)
    2250       (return-from compile-constant))
    2251      (t
    2252       (assert nil))))
     2153    (cond ((fixnump form)
     2154           (emit-push-constant-int form)
     2155           (emit-move-from-stack target)
     2156           (return-from compile-constant))
     2157          (t
     2158           (assert nil))))
    22532159  (cond ((numberp form)
    22542160         (if (fixnump form)
    … …  
    22612167                    (translation (cdr (assoc n translations))))
    22622168               (if translation
    2263                    (emit 'getstatic
    2264                          +lisp-fixnum-class+
    2265                          translation
    2266                          +lisp-fixnum+)
    2267                    (emit 'getstatic
    2268                          *this-class*
    2269                          (declare-fixnum n)
    2270                          +lisp-fixnum+)))
    2271              (emit 'getstatic
    2272                    *this-class*
    2273                    (declare-object-as-string form)
    2274                    +lisp-object+)))
     2169                   (emit 'getstatic +lisp-fixnum-class+ translation +lisp-fixnum+)
     2170                   (emit 'getstatic *this-class* (declare-fixnum n) +lisp-fixnum+)))
     2171             (emit 'getstatic *this-class*
     2172                   (declare-object-as-string form) +lisp-object+)))
    22752173        ((stringp form)
    22762174         (if *compile-file-truename*
    2277              (emit 'getstatic
    2278                    *this-class*
    2279                    (declare-string form)
    2280                    +lisp-simple-string+)
    2281              (emit 'getstatic
    2282                    *this-class*
    2283                    (declare-object form)
    2284                    +lisp-object+)))
     2175             (emit 'getstatic *this-class*
     2176                   (declare-string form) +lisp-simple-string+)
     2177             (emit 'getstatic *this-class*
     2178                   (declare-object form) +lisp-object+)))
    22852179        ((vectorp form)
    22862180         (if *compile-file-truename*
    2287              (emit 'getstatic
    2288                    *this-class*
    2289                    (declare-object-as-string form)
    2290                    +lisp-object+)
    2291              (emit 'getstatic
    2292                    *this-class*
    2293                    (declare-object form)
    2294                    +lisp-object+)))
     2181             (emit 'getstatic *this-class*
     2182                   (declare-object-as-string form) +lisp-object+)
     2183             (emit 'getstatic *this-class*
     2184                   (declare-object form) +lisp-object+)))
    22952185        ((characterp form)
    2296          (emit 'getstatic
    2297                *this-class*
    2298                (declare-object-as-string form)
    2299                +lisp-object+))
     2186         (emit 'getstatic *this-class*
     2187               (declare-object-as-string form) +lisp-object+))
    23002188        ((or (classp form) (hash-table-p form) (typep form 'generic-function))
    2301          (emit 'getstatic
    2302                *this-class*
    2303                (declare-object form)
    2304                +lisp-object+))
     2189         (emit 'getstatic *this-class*
     2190               (declare-object form) +lisp-object+))
    23052191        ((pathnamep form)
    23062192         (let ((g (if *compile-file-truename*
    23072193                      (declare-object-as-string form)
    23082194                      (declare-object form))))
    2309            (emit 'getstatic
    2310                  *this-class*
    2311                  g
    2312                  +lisp-object+)))
     2195           (emit 'getstatic *this-class* g +lisp-object+)))
    23132196        ((packagep form)
    23142197         (let ((g (if *compile-file-truename*
    23152198                      (declare-package form)
    23162199                      (declare-object form))))
    2317            (emit 'getstatic
    2318                  *this-class*
    2319                  g
    2320                  +lisp-object+)))
     2200           (emit 'getstatic *this-class* g +lisp-object+)))
    23212201        (t
    23222202         (if *compile-file-truename*
    23232203             (error "COMPILE-CONSTANT unhandled case ~S" form)
    2324              (emit 'getstatic
    2325                    *this-class*
    2326                    (declare-object form)
    2327                    +lisp-object+))))
     2204             (emit 'getstatic *this-class*
     2205                   (declare-object form) +lisp-object+))))
    23282206  (emit-move-from-stack target))
    23292207
    … …  
    23882266             (compile-form arg :target :stack)
    23892267             (maybe-emit-clear-values arg)
    2390              (emit-invokespecial +lisp-cons-class+
    2391                                  "<init>"
    2392                                  "(Lorg/armedbear/lisp/LispObject;)V"
    2393                                  -2)
     2268             (emit-invokespecial-init +lisp-cons-class+ (list +lisp-object+))
    23942269             (emit-move-from-stack target)
    23952270             t)
    2396             (t
    2397              nil)))))
     2271            (t nil)))))
    23982272
    23992273(defparameter binary-operators (make-hash-table :test 'eq))
    … …  
    24642338                        (single-valued-p second))
    24652339             (emit-clear-values))
    2466            (emit-invokestatic +lisp-class+
    2467                               "list2"
    2468                               "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
    2469                               -1)
     2340           (emit-invokestatic +lisp-class+ "list2"
     2341                              (list +lisp-object+ +lisp-object+) +lisp-cons+)
    24702342           (emit-move-from-stack target)
    24712343           t)
    … …  
    24752347             (maybe-emit-clear-values first)
    24762348             (emit 'sipush second)
    2477              (emit-invokevirtual +lisp-object-class+
    2478                                  "getSlotValue"
    2479                                  '("I")
    2480                                  +lisp-object+)
     2349             (emit-invokevirtual +lisp-object-class+ "getSlotValue"
     2350                                 '("I") +lisp-object+)
    24812351             (when (eq representation :unboxed-fixnum)
    24822352               (emit-unbox-fixnum))
    … …  
    25632433     (unless (every 'single-valued-p args)
    25642434       (emit-clear-values))
    2565      (emit-invokestatic +lisp-class+
    2566                         "list3"
    2567                         "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
    2568                         -2)
     2435     (emit-invokestatic +lisp-class+ "list3"
     2436                        (list +lisp-object+ +lisp-object+ +lisp-object+)
     2437                        +lisp-cons+)
    25692438     (emit-move-from-stack target)
    25702439     t)
    … …  
    25762445       (compile-form (third args) :target :stack)
    25772446       (maybe-emit-clear-values (third args))
    2578        (emit-invokevirtual +lisp-object-class+
    2579                            "setSlotValue"
    2580                            (list "I" +lisp-object+)
    2581                            +lisp-object+)
     2447       (emit-invokevirtual +lisp-object-class+ "setSlotValue"
     2448                           (list "I" +lisp-object+) +lisp-object+)
    25822449       (emit-move-from-stack target)
    25832450       t))
    … …  
    31463013
    31473014(defun compile-multiple-value-list (form &key (target *val*) representation)
    3148   ;; Added Dec 9 2004 7:52 PM
    31493015  (emit-clear-values)
    3150 
    31513016  (compile-form (second form) :target :stack)
    3152   (emit-invokestatic +lisp-class+
    3153                      "multipleValueList"
    3154                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    3155                      0)
     3017  (emit-invokestatic +lisp-class+ "multipleValueList"
     3018                     (list +lisp-object+) +lisp-object+)
    31563019  (emit-move-from-stack target))
    31573020
    … …  
    31613024        (result-register (allocate-register))
    31623025        (values-register (allocate-register)))
    3163 
    3164     ;; Added Dec 9 2004 3:46 AM
    31653026    ;; Make sure there are no leftover values from previous calls.
    31663027    (emit-clear-values)
    3167 
    31683028    (compile-form first-subform :target result-register)
    31693029    ;; Save multiple values returned by first subform.
    … …  
    31873047    (2
    31883048     (compile-form (second form) :target :stack)
    3189      (emit-invokestatic +lisp-class+
    3190                         "coerceToFunction"
    3191                         "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    3192                         0)
     3049     (emit-invokestatic +lisp-class+ "coerceToFunction"
     3050                        (list +lisp-object+) +lisp-object+)
    31933051     (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+)
    31943052     (emit-move-from-stack target))
    … …  
    32003058       (emit 'aload function-register)
    32013059       (emit-push-current-thread)
    3202        (emit-invokestatic +lisp-class+
    3203                           "multipleValueCall1"
    3204                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;"
    3205                           -2)
     3060       (emit-invokestatic +lisp-class+ "multipleValueCall1"
     3061                          (list +lisp-object+ +lisp-object+ +lisp-thread+)
     3062                          +lisp-object+)
    32063063       (emit-move-from-stack target)))
    32073064    (t
    … …  
    32113068            (values-register (allocate-register)))
    32123069       (compile-form (second form) :target :stack)
    3213        (emit-invokestatic +lisp-class+
    3214                           "coerceToFunction"
    3215                           "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    3216                           0)
     3070       (emit-invokestatic +lisp-class+ "coerceToFunction"
     3071                          (list +lisp-object+) +lisp-object+)
    32173072       (emit-move-from-stack function-register)
    32183073       (emit 'aconst_null)
    … …  
    32233078         (emit 'swap)
    32243079         (emit 'aload values-register)
    3225          (emit-invokevirtual +lisp-thread-class+
    3226                              "accumulateValues"
     3080         (emit-invokevirtual +lisp-thread-class+ "accumulateValues"
    32273081                             (list +lisp-object+ +lisp-object-array+)
    32283082                             +lisp-object-array+)
    … …  
    32313085       (emit 'aload function-register)
    32323086       (emit 'aload values-register)
    3233        (emit-invokevirtual +lisp-object-class+
    3234                            "execute"
    3235                            (list +lisp-object-array+)
    3236                            +lisp-object+)
     3087       (emit-invokevirtual +lisp-object-class+ "execute"
     3088                           (list +lisp-object-array+) +lisp-object+)
    32373089       (emit-move-from-stack target)))))
    32383090
    … …  
    32443096         (emit-push-current-thread)
    32453097         (emit 'swap)
    3246          (emit 'getstatic
    3247                *this-class*
    3248                (declare-symbol (variable-name variable))
    3249                +lisp-symbol+)
     3098         (emit 'getstatic *this-class*
     3099               (declare-symbol (variable-name variable)) +lisp-symbol+)
    32503100         (emit 'swap)
    3251          (emit-invokevirtual +lisp-thread-class+
    3252                              "bindSpecial"
    3253                              (list +lisp-symbol+ +lisp-object+)
    3254                              nil))
     3101         (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
     3102                             (list +lisp-symbol+ +lisp-object+) nil))
    32553103        ((variable-closure-index variable)
    32563104         (emit 'aload (compiland-closure-register *current-compiland*))
    … …  
    32763124               (setf bind-special-p t))
    32773125              (t
    3278 ;;                (setf (variable-index variable) (length (context-vars *context*)))
    32793126               (unless (variable-closure-index variable)
    3280                  (setf (variable-register variable) (allocate-register)))
    3281 ;;                (add-variable-to-context variable)
    3282                ))))
     3127                 (setf (variable-register variable) (allocate-register)))))))
    32833128    ;; If we're going to bind any special variables...
    32843129    (when bind-special-p
    … …  
    32883133      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
    32893134      (emit 'astore (block-environment-register block)))
    3290 
    3291     ;; Added Dec 9 2004 3:46 AM
    32923135    ;; Make sure there are no leftover values from previous calls.
    32933136    (emit-clear-values)
    3294 
    32953137    ;; Bind the variables.
    32963138    (aver (= (length vars) (length variables)))
    … …  
    33283170             (emit 'aload result-register)
    33293171             (emit 'bipush (length vars))
    3330              (emit-invokevirtual +lisp-thread-class+
    3331                                  "getValues"
    3332                                  (list +lisp-object+ "I")
    3333                                  +lisp-object-array+)
     3172             (emit-invokevirtual +lisp-thread-class+ "getValues"
     3173                                 (list +lisp-object+ "I") +lisp-object-array+)
    33343174             ;; Values array is now on the stack at runtime.
    33353175             (label LABEL2)
    … …  
    36743514    (emit 'dup)
    36753515    (compile-form `',(tag-label tag) :target :stack) ; Tag.
    3676     (emit-invokespecial +lisp-go-class+
    3677                         "<init>"
    3678                         "(Lorg/armedbear/lisp/LispObject;)V"
    3679                         -2)
     3516    (emit-invokespecial-init +lisp-go-class+ (list +lisp-object+))
    36803517    (emit 'athrow)
    36813518    ;; Following code will not be reached, but is needed for JVM stack
    … …  
    38223659             (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
    38233660             (emit 'aload temp-register))))
    3824     (emit-invokespecial +lisp-return-class+
    3825                         "<init>"
    3826                         "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
    3827                         -3)
     3661    (emit-invokespecial-init +lisp-return-class+ (list +lisp-object+ +lisp-object+))
    38283662    (emit 'athrow)
    38293663    ;; Following code will not be reached, but is needed for JVM stack
    … …  
    38403674  (emit 'dup)
    38413675  (process-args (cdr form))
    3842   (emit-invokespecial "org/armedbear/lisp/Cons"
    3843                       "<init>"
    3844                       "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
    3845                       -3)
     3676  (emit-invokespecial-init +lisp-cons-class+ (list +lisp-object+ +lisp-object+))
    38463677  (emit-move-from-stack target))
    38473678
    … …  
    40823913     ((compiland-closure-register *current-compiland*)
    40833914      (emit 'aload (compiland-closure-register *current-compiland*))
    4084       (emit-invokestatic +lisp-class+
    4085                          "makeCompiledClosure"
    4086 ;;                          "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    4087                          (make-descriptor (list +lisp-object+ +lisp-object-array+)
    4088                                           +lisp-object+)
    4089                          -1)
    4090       (emit 'checkcast "org/armedbear/lisp/CompiledClosure")
    4091       ) ; Stack: compiled-closure
     3915      (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     3916                         (list +lisp-object+ +lisp-object-array+) +lisp-object+)
     3917      (emit 'checkcast "org/armedbear/lisp/CompiledClosure")) ; Stack: compiled-closure
    40923918     (t
    40933919      ;; Shouldn't happen.
    40943920      (aver (progn 'unexpected nil))
    40953921      (emit-push-constant-int 0)
    4096       (emit 'anewarray "org/armedbear/lisp/LispObject")))
     3922      (emit 'anewarray +lisp-object-class+)))
    40973923    (emit-move-from-stack target)))
    40983924
    … …  
    41143940                                      (declare-local-function local-function)
    41153941                                      (declare-object (local-function-function local-function)))))
    4116                            (emit 'getstatic
    4117                                  *this-class*
    4118                                  g
    4119                                  +lisp-object+)))) ; Stack: template-function
     3942                           (emit 'getstatic *this-class*
     3943                                 g +lisp-object+)))) ; Stack: template-function
    41203944                  (cond ((null *closure-variables*)) ; Nothing to do.
    41213945                        ((compiland-closure-register *current-compiland*)
    41223946                         (dformat t "p2-function 3~%")
    41233947                         (emit 'aload (compiland-closure-register *current-compiland*))
    4124                          (emit-invokestatic +lisp-class+
    4125                                             "makeCompiledClosure"
    4126                                             "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    4127                                             -1)) ; Stack: compiled-closure
     3948                         (emit-invokestatic +lisp-class+ "makeCompiledClosure"
     3949                                            (list +lisp-object+ +lisp-object-array+)
     3950                                            +lisp-object+)) ; Stack: compiled-closure
    41283951                        (t
    41293952                         (aver (progn 'unexpected nil))))
    41303953                  (emit-move-from-stack target))
    41313954                 ((inline-ok name)
    4132                   (emit 'getstatic
    4133                         *this-class*
    4134                         (declare-function name)
    4135                         +lisp-object+)
     3955                  (emit 'getstatic *this-class*
     3956                        (declare-function name) +lisp-object+)
    41363957                  (emit-move-from-stack target))
    41373958                 (t
    4138                   (emit 'getstatic
    4139                         *this-class*
    4140                         (declare-symbol name)
    4141                         +lisp-symbol+)
    4142                   (emit-invokevirtual +lisp-object-class+
    4143                                       "getSymbolFunctionOrDie"
    4144                                       nil
    4145                                       +lisp-object+)
     3959                  (emit 'getstatic *this-class*
     3960                        (declare-symbol name) +lisp-symbol+)
     3961                  (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie"
     3962                                      nil +lisp-object+)
    41463963                  (emit-move-from-stack target))))
    41473964          ((and (consp name) (eq (car name) 'SETF))
    41483965           ; FIXME Need to check for NOTINLINE declaration!
    41493966           (cond ((member name *toplevel-defuns* :test #'equal)
    4150                   (emit 'getstatic
    4151                         *this-class*
    4152                         (declare-setf-function name)
    4153                         +lisp-object+)
     3967                  (emit 'getstatic *this-class*
     3968                        (declare-setf-function name) +lisp-object+)
    41543969                  (emit-move-from-stack target))
    41553970                 ((and (null *compile-file-truename*)
    41563971                       (fdefinition name))
    4157                   (emit 'getstatic
    4158                         *this-class*
    4159                         (declare-object (fdefinition name))
    4160                         +lisp-object+)
     3972                  (emit 'getstatic *this-class*
     3973                        (declare-object (fdefinition name)) +lisp-object+)
    41613974                  (emit-move-from-stack target))
    41623975                 (t
    4163                   (emit 'getstatic
    4164                         *this-class*
    4165                         (declare-symbol (cadr name))
    4166                         +lisp-symbol+)
     3976                  (emit 'getstatic *this-class*
     3977                        (declare-symbol (cadr name)) +lisp-symbol+)
    41673978                  (emit-invokevirtual +lisp-symbol-class+
    41683979                                      "getSymbolSetfFunctionOrDie"
    4169                                       nil
    4170                                       +lisp-object+)
     3980                                      nil +lisp-object+)
    41713981                  (emit-move-from-stack target))))
    41723982          ((compiland-p name)
    … …  
    41863996         (var1 (unboxed-fixnum-variable arg1))
    41873997         (var2 (unboxed-fixnum-variable arg2)))
    4188     (cond
    4189      ((and (numberp arg1) (numberp arg2))
    4190       (dformat t "p2-ash case 1~%")
    4191       (compile-constant (ash arg1 arg2)
    4192                         :target target
    4193                         :representation representation))
    4194      ((and var1 (fixnump arg2) (< 0 arg2 32))
    4195       (dformat t "p2-ash case 2~%")
    4196       (case representation
    4197         (:unboxed-fixnum
    4198          (emit-push-int var1)
    4199          (emit-push-constant-int arg2)
    4200          (emit 'ishl))
    4201         (t
    4202          (emit-push-int var1)
    4203          (emit 'i2l)
    4204          (emit-push-constant-int arg2)
    4205          (emit 'lshl)
    4206          (emit-box-long)))
    4207       (emit-move-from-stack target representation))
    4208      ((and var1 (fixnump arg2) (< -32 arg2 0))
    4209       (dformat t "p2-ash case 3~%")
    4210       (unless (eq representation :unboxed-fixnum)
    4211         (emit 'new +lisp-fixnum-class+)
    4212         (emit 'dup))
    4213       (emit-push-int var1)
    4214       (emit-push-constant-int (- arg2))
    4215       (emit 'ishr)
    4216       (unless (eq representation :unboxed-fixnum)
    4217         (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
    4218       (emit-move-from-stack target representation))
    4219      (var2
    4220       (dformat t "p2-ash case 4~%")
    4221       (compile-form arg1 :target :stack)
    4222       (maybe-emit-clear-values arg1)
    4223       (emit 'iload (variable-register var2))
    4224       (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+)
    4225       (when (eq representation :unboxed-fixnum)
    4226         (emit-unbox-fixnum))
    4227       (emit-move-from-stack target representation))
    4228      ((fixnump arg2)
    4229       (dformat t "p2-ash case 5~%")
    4230       (compile-form arg1 :target :stack)
    4231       (maybe-emit-clear-values arg1)
    4232       (emit-push-constant-int arg2)
    4233       (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+)
    4234       (when (eq representation :unboxed-fixnum)
    4235         (emit-unbox-fixnum))
    4236       (emit-move-from-stack target representation))
    4237      (t
    4238       (dformat t "p2-ash case 6~%")
    4239       (compile-function-call form target representation)))))
     3998    (cond ((and (numberp arg1) (numberp arg2))
     3999           (dformat t "p2-ash case 1~%")
     4000           (compile-constant (ash arg1 arg2)
     4001                             :target target
     4002                             :representation representation))
     4003          ((and var1 (fixnump arg2) (< 0 arg2 32))
     4004           (dformat t "p2-ash case 2~%")
     4005           (case representation
     4006             (:unboxed-fixnum
     4007              (emit-push-int var1)
     4008              (emit-push-constant-int arg2)
     4009              (emit 'ishl))
     4010             (t
     4011              (emit-push-int var1)
     4012              (emit 'i2l)
     4013              (emit-push-constant-int arg2)
     4014              (emit 'lshl)
     4015              (emit-box-long)))
     4016           (emit-move-from-stack target representation))
     4017          ((and var1 (fixnump arg2) (< -32 arg2 0))
     4018           (dformat t "p2-ash case 3~%")
     4019           (unless (eq representation :unboxed-fixnum)
     4020             (emit 'new +lisp-fixnum-class+)
     4021             (emit 'dup))
     4022           (emit-push-int var1)
     4023           (emit-push-constant-int (- arg2))
     4024           (emit 'ishr)
     4025           (unless (eq representation :unboxed-fixnum)
     4026             (emit-invokespecial-init +lisp-fixnum-class+ '("I")))
     4027           (emit-move-from-stack target representation))
     4028          (var2
     4029           (dformat t "p2-ash case 4~%")
     4030           (compile-form arg1 :target :stack)
     4031           (maybe-emit-clear-values arg1)
     4032           (emit 'iload (variable-register var2))
     4033           (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+)
     4034           (when (eq representation :unboxed-fixnum)
     4035             (emit-unbox-fixnum))
     4036           (emit-move-from-stack target representation))
     4037          ((fixnump arg2)
     4038           (dformat t "p2-ash case 5~%")
     4039           (compile-form arg1 :target :stack)
     4040           (maybe-emit-clear-values arg1)
     4041           (emit-push-constant-int arg2)
     4042           (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+)
     4043           (when (eq representation :unboxed-fixnum)
     4044             (emit-unbox-fixnum))
     4045           (emit-move-from-stack target representation))
     4046          (t (dformat t "p2-ash case 6~%")
     4047             (compile-function-call form target representation)))))
    42404048
    42414049(defun p2-logand (form &key (target *val*) representation)
    … …  
    42484056        (dformat t "p2-logand var1 = ~S~%" var1)
    42494057        (dformat t "p2-logand type-of arg2 is ~S~%" (type-of arg2))
    4250         (cond
    4251          ((and (integerp arg1) (integerp arg2))
    4252           (dformat t "p2-logand case 1~%")
    4253           (compile-constant (logand arg1 arg2) :target target :representation representation)
    4254           (return-from p2-logand t))
    4255          ((and (fixnump arg2) (zerop arg2))
    4256           (dformat t "p2-logand case 2~%")
    4257           (compile-constant 0 :target target :representation representation)
    4258           (return-from p2-logand t))
    4259          ((and var1 (fixnump arg2))
    4260           (dformat t "p2-logand case 3~%")
    4261           (unless (eq representation :unboxed-fixnum)
    4262             (emit 'new +lisp-fixnum-class+)
    4263             (emit 'dup))
    4264           (emit 'iload (variable-register var1))
    4265           (emit-push-constant-int arg2)
    4266           (emit 'iand)
    4267           (unless (eq representation :unboxed-fixnum)
    4268             (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
    4269           (emit-move-from-stack target representation)
    4270           (return-from p2-logand t))
    4271          ((fixnump arg2)
    4272           (dformat t "p2-logand case 4~%")
    4273           (let ((type (derive-type arg1)))
    4274             (dformat t "p2-logand arg1 derived type = ~S~%" type)
    4275             (cond
    4276              ((subtypep type 'fixnum)
    4277               (dformat t "p2-logand case 4a~%")
    4278               (unless (eq representation :unboxed-fixnum)
    4279                 (emit 'new +lisp-fixnum-class+)
    4280                 (emit 'dup))
    4281               (compile-form arg1 :target :stack :representation :unboxed-fixnum)
    4282               (maybe-emit-clear-values arg1)
    4283               (emit-push-constant-int arg2)
    4284               (emit 'iand)
    4285               (unless (eq representation :unboxed-fixnum)
    4286                 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
    4287               (emit-move-from-stack target representation))
    4288              (t
    4289               (dformat t "p2-logand case 4b~%")
    4290               (compile-form arg1 :target :stack)
    4291               (maybe-emit-clear-values arg1)
    4292               (emit-push-constant-int arg2)
    4293               (emit-invokevirtual +lisp-object-class+ "logand" '("I") +lisp-object+)
    4294               (when (eq representation :unboxed-fixnum)
    4295                 (emit-unbox-fixnum))
    4296               (emit-move-from-stack target representation))))
    4297           (return-from p2-logand t))))))
     4058        (cond ((and (integerp arg1) (integerp arg2))
     4059               (dformat t "p2-logand case 1~%")
     4060               (compile-constant (logand arg1 arg2) :target target :representation representation)
     4061               (return-from p2-logand t))
     4062              ((and (fixnump arg2) (zerop arg2))
     4063               (dformat t "p2-logand case 2~%")
     4064               (compile-constant 0 :target target :representation representation)
     4065               (return-from p2-logand t))
     4066              ((and var1 (fixnump arg2))
     4067               (dformat t "p2-logand case 3~%")
     4068               (unless (eq representation :unboxed-fixnum)
     4069                 (emit 'new +lisp-fixnum-class+)
     4070                 (emit 'dup))
     4071               (emit 'iload (variable-register var1))
     4072               (emit-push-constant-int arg2)
     4073               (emit 'iand)
     4074               (unless (eq representation :unboxed-fixnum)
     4075                 (emit-invokespecial-init +lisp-fixnum-class+ '("I")))
     4076               (emit-move-from-stack target representation)
     4077               (return-from p2-logand t))
     4078              ((fixnump arg2)
     4079               (dformat t "p2-logand case 4~%")
     4080               (let ((type (derive-type arg1)))
     4081                 (dformat t "p2-logand arg1 derived type = ~S~%" type)
     4082                 (cond ((subtypep type 'fixnum)
     4083                        (dformat t "p2-logand case 4a~%")
     4084                        (unless (eq representation :unboxed-fixnum)
     4085                          (emit 'new +lisp-fixnum-class+)
     4086                          (emit 'dup))
     4087                        (compile-form arg1 :target :stack :representation :unboxed-fixnum)
     4088                        (maybe-emit-clear-values arg1)
     4089                        (emit-push-constant-int arg2)
     4090                        (emit 'iand)
     4091                        (unless (eq representation :unboxed-fixnum)
     4092                          (emit-invokespecial-init +lisp-fixnum-class+ '("I")))
     4093                        (emit-move-from-stack target representation))
     4094                       (t (dformat t "p2-logand case 4b~%")
     4095                          (compile-form arg1 :target :stack)
     4096                          (maybe-emit-clear-values arg1)
     4097                          (emit-push-constant-int arg2)
     4098                          (emit-invokevirtual +lisp-object-class+ "logand" '("I") +lisp-object+)
     4099                          (when (eq representation :unboxed-fixnum)
     4100                            (emit-unbox-fixnum))
     4101                          (emit-move-from-stack target representation))))
     4102               (return-from p2-logand t))))))
    42984103  (dformat t "p2-logand default case~%")
    42994104  (compile-function-call form target representation))
    43004105
    43014106(defun derive-type (form)
    4302   (cond
    4303    ((fixnump form)
    4304     (return-from derive-type 'fixnum))
    4305    ((unboxed-fixnum-variable form)
    4306     (return-from derive-type 'fixnum))
    4307    ((consp form)
    4308     (let ((op (first form)))
    4309       (case op
    4310         (ASH
    4311          (dformat t "derive-type ASH case form = ~S~%" form)
    4312          (let* ((arg1 (second form))
    4313                 (var1 (unboxed-fixnum-variable arg1))
    4314                 (arg2 (third form)))
    4315            (dformat t "derive-type ASH case var1 = ~S~%" var1)
    4316            (when (and var1 (fixnump arg2) (minusp arg2))
    4317              (return-from derive-type 'FIXNUM))))
    4318         (THE
    4319          (dformat t "derive-type THE case form = ~S~%" form)
    4320          (when (subtypep (second form) 'FIXNUM)
    4321            (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form)
    4322            (return-from derive-type 'FIXNUM)))))))
     4107  (cond ((fixnump form)
     4108         (return-from derive-type 'fixnum))
     4109        ((unboxed-fixnum-variable form)
     4110         (return-from derive-type 'fixnum))
     4111        ((consp form)
     4112         (let ((op (first form)))
     4113           (case op
     4114             (ASH
     4115              (dformat t "derive-type ASH case form = ~S~%" form)
     4116              (let* ((arg1 (second form))
     4117                     (var1 (unboxed-fixnum-variable arg1))
     4118                     (arg2 (third form)))
     4119                (dformat t "derive-type ASH case var1 = ~S~%" var1)
     4120                (when (and var1 (fixnump arg2) (minusp arg2))
     4121                  (return-from derive-type 'FIXNUM))))
     4122             (THE
     4123              (dformat t "derive-type THE case form = ~S~%" form)
     4124              (when (subtypep (second form) 'FIXNUM)
     4125                (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form)
     4126                (return-from derive-type 'FIXNUM)))))))
    43234127  t)
    43244128
    … …  
    43284132    (compile-form arg :target :stack)
    43294133    (maybe-emit-clear-values arg)
    4330     (cond
    4331      ((eq representation :unboxed-fixnum)
    4332       (emit-invokevirtual +lisp-object-class+ "length" nil "I"))
    4333      (t
    4334       (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+)))
     4134    (cond ((eq representation :unboxed-fixnum)
     4135           (emit-invokevirtual +lisp-object-class+ "length" nil "I"))
     4136          (t
     4137           (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+)))
    43354138    (emit-move-from-stack target representation)))
    43364139
    … …  
    46684471  (dformat t "compile-variable-reference ~S~%" name)
    46694472  (let ((variable (find-visible-variable name)))
    4670     (cond
    4671      ((null variable)
    4672       (when (and (special-variable-p name)
    4673                  (constantp name))
    4674         (let ((value (symbol-value name)))
    4675           (when (or (null *compile-file-truename*)
    4676                     ;; FIXME File compilation doesn't support all constant
    4677                     ;; types yet.
    4678                     (stringp value)
    4679                     (numberp value)
    4680                     (packagep value))
    4681             (compile-constant value :target target :representation representation)
    4682             (return-from compile-variable-reference))))
    4683       (unless (special-variable-p name)
    4684         (unless (memq name *undefined-variables*)
    4685           (compiler-warn "Undefined variable ~S" name)
    4686           (push name *undefined-variables*)))
    4687       (compile-special-reference name target representation))
    4688      ((eq (variable-representation variable) :unboxed-fixnum)
    4689       (dformat t "compile-variable-reference unboxed-fixnum case~%")
    4690       (cond
    4691        ((eq representation :unboxed-fixnum)
    4692         (aver (variable-register variable))
    4693         (emit 'iload (variable-register variable)))
    4694        (t
    4695         (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%"
    4696                  name)
    4697         (emit 'new +lisp-fixnum-class+)
    4698         (emit 'dup)
    4699         (aver (variable-register variable))
    4700         (emit 'iload (variable-register variable))
    4701         (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)))
    4702       (emit-move-from-stack target representation))
    4703      (t
    4704 ;;       (dformat t "compile-variable-reference name = ~S representation = ~S~%"
    4705 ;;                name representation)
    4706       (dformat t "compile-variable-reference ~S closure index = ~S~%"
    4707                name (variable-closure-index variable))
    4708       (emit 'var-ref variable target representation)))))
     4473    (cond ((null variable)
     4474           (when (and (special-variable-p name)
     4475                      (constantp name))
     4476             (let ((value (symbol-value name)))
     4477               (when (or (null *compile-file-truename*)
     4478                         ;; FIXME File compilation doesn't support all constant
     4479                         ;; types yet.
     4480                         (stringp value)
     4481                         (numberp value)
     4482                         (packagep value))
     4483                 (compile-constant value :target target :representation representation)
     4484                 (return-from compile-variable-reference))))
     4485           (unless (special-variable-p name)
     4486             (unless (memq name *undefined-variables*)
     4487               (compiler-warn "Undefined variable ~S" name)
     4488               (push name *undefined-variables*)))
     4489           (compile-special-reference name target representation))
     4490          ((eq (variable-representation variable) :unboxed-fixnum)
     4491           (dformat t "compile-variable-reference unboxed-fixnum case~%")
     4492           (cond ((eq representation :unboxed-fixnum)
     4493                  (aver (variable-register variable))
     4494                  (emit 'iload (variable-register variable)))
     4495                 (t (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%"
     4496                             name)
     4497                    (emit 'new +lisp-fixnum-class+)
     4498                    (emit 'dup)
     4499                    (aver (variable-register variable))
     4500                    (emit 'iload (variable-register variable))
     4501                    (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
     4502           (emit-move-from-stack target representation))
     4503          (t (dformat t "compile-variable-reference ~S closure index = ~S~%"
     4504                      name (variable-closure-index variable))
     4505             (emit 'var-ref variable target representation)))))
    47094506
    47104507(defun rewrite-setq (form)
    … …  
    47324529           (let ((new-form (rewrite-setq form)))
    47334530             (when (neq new-form form)
    4734                (return-from compile-setq (compile-form (p1 new-form) :target target))))
     4531               (return-from compile-setq
     4532                            (compile-form (p1 new-form) :target target))))
    47354533           (emit-push-current-thread)
    4736            (emit 'getstatic
    4737                  *this-class*
    4738                  (declare-symbol name)
    4739                  +lisp-symbol+)
     4534           (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+)
    47404535           (compile-form value-form :target :stack)
    47414536           (maybe-emit-clear-values value-form)
    4742            (emit-invokevirtual +lisp-thread-class+
    4743                                "setSpecialVariable"
    4744                                (list +lisp-symbol+ +lisp-object+)
    4745                                +lisp-object+)
     4537           (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable"
     4538                               (list +lisp-symbol+ +lisp-object+) +lisp-object+)
    47464539           (emit-move-from-stack target))
    47474540          ((and (eq (variable-representation variable) :unboxed-fixnum)
    … …  
    47584551             (aver (variable-register variable))
    47594552             (emit 'iload (variable-register variable))
    4760              (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
     4553             (emit-invokespecial-init +lisp-fixnum-class+ '("I"))
    47614554             (emit-move-from-stack target)))
    47624555          ((eq (variable-representation variable) :unboxed-fixnum)
    4763            (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form)
     4556           (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%"
     4557                    value-form)
    47644558           (compile-form value-form :target :stack)
    47654559           (maybe-emit-clear-values value-form)
    … …  
    47694563           (emit 'istore (variable-register variable))
    47704564           (when target
    4771              (emit-move-from-stack target))
    4772            )
    4773           (t
    4774            (compile-form value-form :target :stack)
    4775            (maybe-emit-clear-values value-form)
    4776            (when target
    4777              (emit 'dup))
    4778            (emit 'var-set variable)
    4779            (when target
    4780              (when (eq representation :unboxed-fixnum)
    4781                (emit-unbox-fixnum))
    4782              (emit-move-from-stack target))))))
     4565             (emit-move-from-stack target)))
     4566          (t (compile-form value-form :target :stack)
     4567             (maybe-emit-clear-values value-form)
     4568             (when target
     4569               (emit 'dup))
     4570             (emit 'var-set variable)
     4571             (when target
     4572               (when (eq representation :unboxed-fixnum)
     4573                 (emit-unbox-fixnum))
     4574               (emit-move-from-stack target))))))
    47834575
    47844576(defun p2-the (form &key (target *val*) representation)
    … …  
    48204612    (emit 'if_acmpne label4) ; Stack depth is 1.
    48214613    (emit 'aload *thread*)
    4822     (emit-invokevirtual +lisp-throw-class+
    4823                         "getResult"
    4824                         (list +lisp-thread+)
    4825                         +lisp-object+)
     4614    (emit-invokevirtual +lisp-throw-class+ "getResult"
     4615                        (list +lisp-thread+) +lisp-object+)
    48264616    (emit-move-from-stack target) ; Stack depth is 0.
    48274617    (emit 'goto label5)
    … …  
    48794669  (emit-clear-values) ; Do this unconditionally! (MISC.503)
    48804670  (compile-form (third form) :target :stack) ; Result.
    4881   (emit-invokevirtual +lisp-thread-class+
    4882                       "throwToTag"
    4883                       (list +lisp-object+ +lisp-object+)
    4884                       nil)
     4671  (emit-invokevirtual +lisp-thread-class+ "throwToTag"
     4672                      (list +lisp-object+ +lisp-object+) nil)
    48854673  ;; Following code will not be reached.
    48864674  (when target
    … …  
    49804768           (emit-move-from-stack target))
    49814769          ((keywordp form)
    4982            (emit 'getstatic
    4983                  *this-class*
    4984                  (declare-keyword form)
    4985                  +lisp-symbol+)
     4770           (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+)
    49864771           (emit-move-from-stack target))
    49874772          (t
    … …  
    50034788                (p2-block-node form target))))
    50044789        ((constantp form)
    5005 ;;          (dformat t "compile-form constantp case~%")
    50064790         (compile-constant form :target target :representation representation))
    50074791        (t
    … …  
    50604844           (make-descriptor (list +lisp-object-array+) +lisp-object+)))))
    50614845
    5062 (defun write-class-file (args body execute-method classfile)
     4846(defun write-class-file (args execute-method classfile)
    50634847  (dformat t "write-class-file ~S~%" classfile)
    50644848  (let* ((super (cond (*child-p*
    50654849                       (if *closure-variables*
    5066                            "org/armedbear/lisp/ClosureTemplateFunction"
     4850                           +lisp-ctf-class+
    50674851                           (if *hairy-arglist-p*
    50684852                               +lisp-compiled-function-class+
    50694853                               +lisp-primitive-class+)))
    5070                       (*hairy-arglist-p* +lisp-compiled-function-class+)
    5071                       (t +lisp-primitive-class+)))
     4854                      (*hairy-arglist-p*
     4855                       +lisp-compiled-function-class+)
     4856                      (t
     4857                       +lisp-primitive-class+)))
    50724858         (this-index (pool-class *this-class*))
    50734859         (super-index (pool-class super))
    50744860         (constructor (make-constructor super
    50754861                                        (compiland-name *current-compiland*)
    5076                                         args
    5077                                         body)))
     4862                                        args)))
    50784863    (pool-name "Code") ; Must be in pool!
    50794864
    … …  
    54195204        (cond ((or (memq '&OPTIONAL args) (memq '&KEY args))
    54205205               (emit 'iconst_0)
    5421                (emit-invokevirtual *this-class*
    5422                                    "processArgs"
     5206               (emit-invokevirtual *this-class* "processArgs"
    54235207                                   (list +lisp-object-array+ "I")
    54245208                                   +lisp-object-array+))
    54255209              (t
    5426                (emit-invokevirtual *this-class*
    5427                                    "fastProcessArgs"
     5210               (emit-invokevirtual *this-class* "fastProcessArgs"
    54285211                                   (list +lisp-object-array+)
    54295212                                   +lisp-object-array+)))
    … …  
    54565239    (setf (method-max-locals execute-method) *registers-allocated*)
    54575240    (setf (method-handlers execute-method) (nreverse *handlers*))
    5458     (write-class-file args body execute-method classfile)
     5241    (write-class-file args execute-method classfile)
    54595242    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))
    54605243    classfile))
    … …  
    54965279  (unless (or (null environment) (sys::empty-environment-p environment))
    54975280    (error "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
    5498 ;;   (setf *child-count* 0)
    54995281  (aver (null *current-compiland*))
    55005282  (handler-bind ((warning #'handle-warning))
    5501 ;;     (let ((precompiled-form (if *current-compiland*
    5502 ;;                                form
    5503 ;;                                (precompile-form form t))))
    55045283      (compile-1 (make-compiland :name name
    5505 ;;                                  :lambda-expression precompiled-form
    55065284                                 :lambda-expression (precompile-form form t)
    55075285                                 :classfile classfile
Note: See TracChangeset for help on using the changeset viewer.