Changeset 11542


Ignore:
Timestamp:
01/04/09 20:04:17 (12 years ago)
Author:
vvoutilainen
Message:

Helper macro for declare-* functions that use hashtables.

File:
1 edited

Legend:

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

    r11541 r11542  
    18061806      output)))
    18071807
     1808(defmacro declare-with-hashtable (declared-item hashtable hashtable-var
     1809          item-var &body body)
     1810  `(let* ((,hashtable-var ,hashtable)
     1811    (,item-var (gethash1 ,declared-item ,hashtable-var)))
     1812     (declare (type hash-table ,hashtable-var))
     1813     (unless ,item-var
     1814       ,@body)
     1815     ,item-var))
     1816
     1817
    18081818(defknown declare-symbol (symbol) string)
    18091819(defun declare-symbol (symbol)
    18101820  (declare (type symbol symbol))
    1811   (let* ((ht *declared-symbols*)
    1812          (g (gethash1 symbol ht)))
    1813     (declare (type hash-table ht))
    1814     (unless g
    1815       (cond ((null (symbol-package symbol))
    1816              (setf g (if *compile-file-truename*
    1817                          (declare-object-as-string symbol)
    1818                          (declare-object symbol))))
    1819             (t
    1820              (let ((*code* *static-code*)
    1821                    (s (sanitize symbol)))
    1822                (setf g (symbol-name (gensym)))
    1823                (when s
    1824                  (setf g (concatenate 'string g "_" s)))
    1825                (declare-field g +lisp-symbol+)
    1826                (emit 'ldc (pool-string (symbol-name symbol)))
    1827                (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    1828                (emit-invokestatic +lisp-class+ "internInPackage"
    1829                                   (list +java-string+ +java-string+) +lisp-symbol+)
    1830                (emit 'putstatic *this-class* g +lisp-symbol+)
    1831                (setf *static-code* *code*)
    1832                (setf (gethash symbol ht) g)))))
    1833     g))
     1821  (declare-with-hashtable
     1822   symbol *declared-symbols* ht g
     1823   (cond ((null (symbol-package symbol))
     1824    (setf g (if *compile-file-truename*
     1825          (declare-object-as-string symbol)
     1826          (declare-object symbol))))
     1827   (t
     1828    (let ((*code* *static-code*)
     1829    (s (sanitize symbol)))
     1830      (setf g (symbol-name (gensym)))
     1831      (when s
     1832        (setf g (concatenate 'string g "_" s)))
     1833      (declare-field g +lisp-symbol+)
     1834      (emit 'ldc (pool-string (symbol-name symbol)))
     1835      (emit 'ldc (pool-string (package-name (symbol-package symbol))))
     1836      (emit-invokestatic +lisp-class+ "internInPackage"
     1837             (list +java-string+ +java-string+) +lisp-symbol+)
     1838      (emit 'putstatic *this-class* g +lisp-symbol+)
     1839      (setf *static-code* *code*)
     1840      (setf (gethash symbol ht) g))))))
    18341841
    18351842(defknown declare-keyword (symbol) string)
    18361843(defun declare-keyword (symbol)
    18371844  (declare (type symbol symbol))
    1838   (let* ((ht *declared-symbols*)
    1839          (g (gethash1 symbol ht)))
    1840     (declare (type hash-table ht))
    1841     (unless g
    1842       (let ((*code* *static-code*))
    1843         (setf g (symbol-name (gensym)))
    1844         (declare-field g +lisp-symbol+)
    1845         (emit 'ldc (pool-string (symbol-name symbol)))
    1846         (emit-invokestatic +lisp-class+ "internKeyword"
    1847                            (list +java-string+) +lisp-symbol+)
    1848         (emit 'putstatic *this-class* g +lisp-symbol+)
    1849         (setf *static-code* *code*)
    1850         (setf (gethash symbol ht) g)))
    1851     g))
     1845  (declare-with-hashtable
     1846   symbol *declared-symbols* ht g
     1847   (let ((*code* *static-code*))
     1848     (setf g (symbol-name (gensym)))
     1849     (declare-field g +lisp-symbol+)
     1850     (emit 'ldc (pool-string (symbol-name symbol)))
     1851     (emit-invokestatic +lisp-class+ "internKeyword"
     1852      (list +java-string+) +lisp-symbol+)
     1853     (emit 'putstatic *this-class* g +lisp-symbol+)
     1854     (setf *static-code* *code*)
     1855     (setf (gethash symbol ht) g))))
    18521856
    18531857(defknown declare-function (symbol) string)
    18541858(defun declare-function (symbol)
    18551859  (declare (type symbol symbol))
    1856   (let* ((ht *declared-functions*)
    1857          (f (gethash1 symbol ht)))
    1858     (declare (type hash-table ht))
    1859     (unless f
    1860       (setf f (symbol-name (gensym)))
    1861       (let ((s (sanitize symbol)))
    1862         (when s
    1863           (setf f (concatenate 'string f "_" s))))
    1864       (let ((*code* *static-code*)
    1865             (g (gethash1 symbol (the hash-table *declared-symbols*))))
    1866         (cond (g
    1867                (emit 'getstatic *this-class* g +lisp-symbol+))
    1868               (t
    1869                (emit 'ldc (pool-string (symbol-name symbol)))
    1870                (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    1871                (emit-invokestatic +lisp-class+ "internInPackage"
    1872                                   (list +java-string+ +java-string+)
    1873                                   +lisp-symbol+)))
    1874         (declare-field f +lisp-object+)
    1875         (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
    1876                             nil +lisp-object+)
    1877         (emit 'putstatic *this-class* f +lisp-object+)
    1878         (setf *static-code* *code*)
    1879         (setf (gethash symbol ht) f)))
    1880     f))
     1860  (declare-with-hashtable
     1861   symbol *declared-functions* ht f
     1862   (setf f (symbol-name (gensym)))
     1863   (let ((s (sanitize symbol)))
     1864     (when s
     1865       (setf f (concatenate 'string f "_" s))))
     1866   (let ((*code* *static-code*)
     1867   (g (gethash1 symbol (the hash-table *declared-symbols*))))
     1868     (cond (g
     1869      (emit 'getstatic *this-class* g +lisp-symbol+))
     1870     (t
     1871      (emit 'ldc (pool-string (symbol-name symbol)))
     1872      (emit 'ldc (pool-string (package-name (symbol-package symbol))))
     1873      (emit-invokestatic +lisp-class+ "internInPackage"
     1874             (list +java-string+ +java-string+)
     1875             +lisp-symbol+)))
     1876     (declare-field f +lisp-object+)
     1877     (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
     1878       nil +lisp-object+)
     1879     (emit 'putstatic *this-class* f +lisp-object+)
     1880     (setf *static-code* *code*)
     1881     (setf (gethash symbol ht) f))))
    18811882
    18821883(defknown declare-setf-function (name) string)
    18831884(defun declare-setf-function (name)
    1884   (let* ((ht *declared-functions*)
    1885          (f (gethash1 name ht)))
    1886     (declare (type hash-table ht))
    1887     (unless f
    1888       (let ((symbol (cadr name)))
    1889         (declare (type symbol symbol))
    1890         (setf f (symbol-name (gensym)))
    1891         (let ((s (sanitize symbol)))
    1892           (when s
    1893             (setf f (concatenate 'string f "_SETF_" s))))
    1894         (let ((*code* *static-code*)
    1895               (g (gethash1 symbol (the hash-table *declared-symbols*))))
    1896           (cond (g
    1897                  (emit 'getstatic *this-class* g +lisp-symbol+))
    1898                 (t
    1899                  (emit 'ldc (pool-string (symbol-name symbol)))
    1900                  (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    1901                  (emit-invokestatic +lisp-class+ "internInPackage"
    1902                                     (list +java-string+ +java-string+)
    1903                                     +lisp-symbol+)))
    1904           (declare-field f +lisp-object+)
    1905           (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
    1906                               nil +lisp-object+)
    1907           (emit 'putstatic *this-class* f +lisp-object+)
    1908           (setf *static-code* *code*)
    1909           (setf (gethash name ht) f))))
    1910     f))
     1885  (declare-with-hashtable
     1886   name *declared-functions* ht f
     1887   (let ((symbol (cadr name)))
     1888     (declare (type symbol symbol))
     1889     (setf f (symbol-name (gensym)))
     1890     (let ((s (sanitize symbol)))
     1891       (when s
     1892   (setf f (concatenate 'string f "_SETF_" s))))
     1893     (let ((*code* *static-code*)
     1894     (g (gethash1 symbol (the hash-table *declared-symbols*))))
     1895       (cond (g
     1896        (emit 'getstatic *this-class* g +lisp-symbol+))
     1897       (t
     1898        (emit 'ldc (pool-string (symbol-name symbol)))
     1899        (emit 'ldc (pool-string (package-name (symbol-package symbol))))
     1900        (emit-invokestatic +lisp-class+ "internInPackage"
     1901         (list +java-string+ +java-string+)
     1902         +lisp-symbol+)))
     1903       (declare-field f +lisp-object+)
     1904       (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
     1905         nil +lisp-object+)
     1906       (emit 'putstatic *this-class* f +lisp-object+)
     1907       (setf *static-code* *code*)
     1908       (setf (gethash name ht) f)))))
     1909
    19111910
    19121911(defknown declare-local-function (local-function) string)
    19131912(defun declare-local-function (local-function)
    1914   (let* ((ht *declared-functions*)
    1915          (g (gethash1 local-function ht)))
    1916     (declare (type hash-table ht))
    1917     (unless g
    1918       (setf g (symbol-name (gensym)))
    1919       (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
    1920              (*code* *static-code*))
    1921         (declare-field g +lisp-object+)
    1922         (emit 'ldc (pool-string (file-namestring pathname)))
    1923         (emit-invokestatic +lisp-class+ "loadCompiledFunction"
    1924                            (list +java-string+) +lisp-object+)
    1925         (emit 'putstatic *this-class* g +lisp-object+)
    1926         (setf *static-code* *code*)
    1927         (setf (gethash local-function ht) g)))
    1928     g))
     1913  (declare-with-hashtable
     1914   local-function *declared-functions* ht g
     1915   (setf g (symbol-name (gensym)))
     1916   (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
     1917    (*code* *static-code*))
     1918     (declare-field g +lisp-object+)
     1919     (emit 'ldc (pool-string (file-namestring pathname)))
     1920     (emit-invokestatic +lisp-class+ "loadCompiledFunction"
     1921      (list +java-string+) +lisp-object+)
     1922     (emit 'putstatic *this-class* g +lisp-object+)
     1923     (setf *static-code* *code*)
     1924     (setf (gethash local-function ht) g))))
    19291925
    19301926(defun new-fixnum (&optional (test-val t))
     
    19361932(defun declare-fixnum (n)
    19371933  (declare (type fixnum n))
    1938   (let* ((ht *declared-integers*)
    1939          (g (gethash1 n ht)))
    1940     (declare (type hash-table ht))
    1941     (unless g
    1942       (let ((*code* *static-code*))
    1943         (setf g (format nil "FIXNUM_~A~D"
    1944                         (if (minusp n) "MINUS_" "")
    1945                         (abs n)))
    1946         (declare-field g +lisp-fixnum+)
    1947         (cond ((<= 0 n 255)
    1948                (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
    1949                (emit-push-constant-int n)
    1950                (emit 'aaload))
    1951               (t
    1952          (new-fixnum)
    1953                (emit-push-constant-int n)
    1954                (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
    1955         (emit 'putstatic *this-class* g +lisp-fixnum+)
    1956         (setf *static-code* *code*)
    1957         (setf (gethash n ht) g)))
    1958     g))
     1934  (declare-with-hashtable
     1935   n *declared-integers* ht g
     1936   (let ((*code* *static-code*))
     1937     (setf g (format nil "FIXNUM_~A~D"
     1938         (if (minusp n) "MINUS_" "")
     1939         (abs n)))
     1940     (declare-field g +lisp-fixnum+)
     1941     (cond ((<= 0 n 255)
     1942      (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
     1943      (emit-push-constant-int n)
     1944      (emit 'aaload))
     1945     (t
     1946      (new-fixnum)
     1947      (emit-push-constant-int n)
     1948      (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
     1949     (emit 'putstatic *this-class* g +lisp-fixnum+)
     1950     (setf *static-code* *code*)
     1951     (setf (gethash n ht) g))))
    19591952
    19601953(defknown declare-bignum (integer) string)
    19611954(defun declare-bignum (n)
    1962   (let* ((ht *declared-integers*)
    1963          (g (gethash1 n ht)))
    1964     (declare (type hash-table ht))
    1965     (unless g
    1966       (cond ((<= most-negative-java-long n most-positive-java-long)
    1967              (let ((*code* *static-code*))
    1968                (setf g (format nil "BIGNUM_~A~D"
    1969                                (if (minusp n) "MINUS_" "")
    1970                                (abs n)))
    1971                (declare-field g +lisp-bignum+)
    1972                (emit 'new +lisp-bignum-class+)
    1973                (emit 'dup)
    1974                (emit 'ldc2_w (pool-long n))
    1975                (emit-invokespecial-init +lisp-bignum-class+ '("J"))
    1976                (emit 'putstatic *this-class* g +lisp-bignum+)
    1977                (setf *static-code* *code*)))
    1978             (t
    1979              (let* ((*print-base* 10)
    1980                     (s (with-output-to-string (stream) (dump-form n stream)))
    1981                     (*code* *static-code*))
    1982                (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
    1983                (declare-field g +lisp-bignum+)
    1984                (emit 'new +lisp-bignum-class+)
    1985                (emit 'dup)
    1986                (emit 'ldc (pool-string s))
    1987                (emit-push-constant-int 10)
    1988                (emit-invokespecial-init +lisp-bignum-class+ (list +java-string+ "I"))
    1989                (emit 'putstatic *this-class* g +lisp-bignum+)
    1990                (setf *static-code* *code*))))
    1991       (setf (gethash n ht) g))
    1992     g))
     1955  (declare-with-hashtable
     1956   n *declared-integers* ht g
     1957   (cond ((<= most-negative-java-long n most-positive-java-long)
     1958    (let ((*code* *static-code*))
     1959      (setf g (format nil "BIGNUM_~A~D"
     1960          (if (minusp n) "MINUS_" "")
     1961          (abs n)))
     1962      (declare-field g +lisp-bignum+)
     1963      (emit 'new +lisp-bignum-class+)
     1964      (emit 'dup)
     1965      (emit 'ldc2_w (pool-long n))
     1966      (emit-invokespecial-init +lisp-bignum-class+ '("J"))
     1967      (emit 'putstatic *this-class* g +lisp-bignum+)
     1968      (setf *static-code* *code*)))
     1969   (t
     1970    (let* ((*print-base* 10)
     1971     (s (with-output-to-string (stream) (dump-form n stream)))
     1972     (*code* *static-code*))
     1973      (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
     1974      (declare-field g +lisp-bignum+)
     1975      (emit 'new +lisp-bignum-class+)
     1976      (emit 'dup)
     1977      (emit 'ldc (pool-string s))
     1978      (emit-push-constant-int 10)
     1979      (emit-invokespecial-init +lisp-bignum-class+ (list +java-string+ "I"))
     1980      (emit 'putstatic *this-class* g +lisp-bignum+)
     1981      (setf *static-code* *code*))))
     1982   (setf (gethash n ht) g)))
    19931983
    19941984(defknown declare-character (t) string)
     
    21032093
    21042094(defun declare-string (string)
    2105   (let* ((ht *declared-strings*)
    2106          (g (gethash1 string ht)))
    2107     (declare (type hash-table ht))
    2108     (unless g
    2109       (let ((*code* *static-code*))
     2095  (declare-with-hashtable
     2096   string *declared-strings* ht g
     2097   (let ((*code* *static-code*))
    21102098        (setf g (symbol-name (gensym)))
    21112099        (declare-field g +lisp-simple-string+)
     
    21162104        (emit 'putstatic *this-class* g +lisp-simple-string+)
    21172105        (setf *static-code* *code*)
    2118         (setf (gethash string ht) g)))
    2119     g))
    2120 
     2106        (setf (gethash string ht) g))))
    21212107     
    21222108(defknown compile-constant (t t t) t)
Note: See TracChangeset for help on using the changeset viewer.