Changeset 12413


Ignore:
Timestamp:
02/01/10 22:16:11 (12 years ago)
Author:
ehuelsmann
Message:

Use MACROLET to prevent code repetition.

File:
1 edited

Legend:

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

    r12399 r12413  
    340340(defun emit-push-nil ()
    341341  (emit 'getstatic +lisp-class+ "NIL" +lisp-object+))
     342
     343(defknown emit-push-nil-symbol () t)
     344(declaim (inline emit-push-nil-symbol))
     345(defun emit-push-nil-symbol ()
     346  (emit 'getstatic +lisp-nil-class+ "NIL" +lisp-symbol+))
    342347
    343348(defknown emit-push-t () t)
     
    18451850              more-keys-p allow-other-keys-p
    18461851              keys-p key-p)
    1847         ;; process required args
    1848         (emit-push-constant-int (length req))
    1849         (emit 'anewarray +lisp-closure-parameter-class+)
    1850         (astore (setf req-params-register (method-max-locals constructor)))
    1851         (incf (method-max-locals constructor))
    1852         (do ((i 0 (1+ i))
    1853              (req req (cdr req)))
    1854             ((endp req))
    1855           (aload req-params-register)
    1856           (emit-push-constant-int i)
    1857           (emit 'new +lisp-closure-parameter-class+)
    1858           (emit 'dup)
    1859           (emit-push-t) ;; we don't need the actual symbol
    1860           (emit-invokespecial-init +lisp-closure-parameter-class+
    1861                                    (list +lisp-symbol+))
    1862           (emit 'aastore))
    1863 
    1864         ;; process optional args
    1865         (emit-push-constant-int (length opt))
    1866         (emit 'anewarray +lisp-closure-parameter-class+)
    1867         (astore (setf opt-params-register (method-max-locals constructor)))
    1868         (incf (method-max-locals constructor))
    1869         (do ((i 0 (1+ i))
    1870              (opt opt (cdr opt)))
    1871             ((endp opt))
    1872           (aload opt-params-register)
    1873           (emit-push-constant-int i)
    1874           (emit 'new +lisp-closure-parameter-class+)
    1875           (emit 'dup)
    1876           (emit-push-t) ;; we don't need the actual variable-symbol
    1877           (emit-read-from-string (second (car opt))) ;; initform
    1878           (if (null (third (car opt)))               ;;
    1879               (emit-push-nil)
    1880               (emit-push-t)) ;; we don't need the actual supplied-p symbol
    1881           (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I")
    1882           (emit-invokespecial-init +lisp-closure-parameter-class+
    1883                                    (list +lisp-symbol+ +lisp-object+
    1884                                          +lisp-object+ "I"))
    1885           (emit 'aastore))
    1886 
    1887         ;; process key args
    1888         (emit-push-constant-int (length key))
    1889         (emit 'anewarray +lisp-closure-parameter-class+)
    1890         (astore (setf key-params-register (method-max-locals constructor)))
    1891         (incf (method-max-locals constructor))
    1892         (do ((i 0 (1+ i))
    1893              (key key (cdr key)))
    1894             ((endp key))
    1895           (aload key-params-register)
    1896           (emit-push-constant-int i)
    1897           (emit 'new +lisp-closure-parameter-class+)
    1898           (emit 'dup)
    1899           (let ((keyword (fourth (car key))))
    1900             (if (keywordp keyword)
    1901                 (progn
    1902                   (emit 'ldc (pool-string (symbol-name keyword)))
    1903                   (emit-invokestatic +lisp-class+ "internKeyword"
    1904                                      (list +java-string+) +lisp-symbol+))
    1905                 ;; symbol is not really a keyword; yes, that's allowed!
    1906                 (progn
    1907                   (emit 'ldc (pool-string (symbol-name keyword)))
    1908                   (emit 'ldc (pool-string
    1909                               (package-name (symbol-package keyword))))
    1910                   (emit-invokestatic +lisp-class+ "internInPackage"
    1911                                      (list +java-string+ +java-string+)
    1912                                      +lisp-symbol+))))
    1913           (emit-push-t) ;; we don't need the actual variable-symbol
    1914           (emit-read-from-string (second (car key)))
    1915           (if (null (third (car key)))
    1916               (emit-push-nil)
    1917               (emit-push-t)) ;; we don't need the actual supplied-p symbol
    1918           (emit-invokespecial-init +lisp-closure-parameter-class+
    1919                                    (list +lisp-symbol+ +lisp-symbol+
    1920                                          +lisp-object+ +lisp-object+))
    1921           (emit 'aastore))
    1922 
    1923         ))
     1852        (macrolet
     1853            ((parameters-to-array ((param params register) &body body)
     1854               (let ((count-sym (gensym)))
     1855                 `(progn
     1856                    (emit-push-constant-int (length ,params))
     1857                    (emit 'anewarray +lisp-closure-parameter-class+)
     1858                    (astore (setf ,register (method-max-locals constructor)))
     1859                    (incf (method-max-locals constructor))
     1860                    (do* ((,count-sym 0 (1+ ,count-sym))
     1861                          (,params ,params (cdr ,params))
     1862                          (,param (car ,params) (car ,params)))
     1863                        ((endp ,params))
     1864                      (declare (ignorable ,param))
     1865                      (aload ,register)
     1866                      (emit-push-constant-int ,count-sym)
     1867                      (emit 'new +lisp-closure-parameter-class+)
     1868                      (emit 'dup)
     1869                      ,@body
     1870                      (emit 'aastore))))))
     1871          ;; process required args
     1872          (parameters-to-array (ignore req req-params-register)
     1873             (emit-push-t) ;; we don't need the actual symbol
     1874             (emit-invokespecial-init +lisp-closure-parameter-class+
     1875                                      (list +lisp-symbol+)))
     1876
     1877          (parameters-to-array (param opt opt-params-register)
     1878             (emit-push-t) ;; we don't need the actual variable-symbol
     1879             (emit-read-from-string (second param)) ;; initform
     1880             (if (null (third param))               ;; supplied-p
     1881                 (emit-push-nil)
     1882                 (emit-push-t)) ;; we don't need the actual supplied-p symbol
     1883             (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I")
     1884             (emit-invokespecial-init +lisp-closure-parameter-class+
     1885                                      (list +lisp-symbol+ +lisp-object+
     1886                                            +lisp-object+ "I")))
     1887
     1888          (parameters-to-array (param key key-params-register)
     1889             (let ((keyword (fourth param)))
     1890               (if (keywordp keyword)
     1891                   (progn
     1892                     (emit 'ldc (pool-string (symbol-name keyword)))
     1893                     (emit-invokestatic +lisp-class+ "internKeyword"
     1894                                        (list +java-string+) +lisp-symbol+))
     1895                   ;; symbol is not really a keyword; yes, that's allowed!
     1896                   (progn
     1897                     (emit 'ldc (pool-string (symbol-name keyword)))
     1898                     (emit 'ldc (pool-string
     1899                                 (package-name (symbol-package keyword))))
     1900                     (emit-invokestatic +lisp-class+ "internInPackage"
     1901                                        (list +java-string+ +java-string+)
     1902                                        +lisp-symbol+))))
     1903             (emit-push-t) ;; we don't need the actual variable-symbol
     1904             (emit-read-from-string (second (car key)))
     1905             (if (null (third param))
     1906                 (emit-push-nil)
     1907                 (emit-push-t)) ;; we don't need the actual supplied-p symbol
     1908             (emit-invokespecial-init +lisp-closure-parameter-class+
     1909                                      (list +lisp-symbol+ +lisp-symbol+
     1910                                            +lisp-object+ +lisp-object+))))))
    19241911    (aload 0) ;; this
    19251912    (cond ((equal super +lisp-primitive-class+)
     
    19271914           (emit-constructor-lambda-list args)
    19281915           (emit-invokespecial-init super (lisp-object-arg-types 2)))
    1929           ((and (null req-params-register)
    1930                 (equal super +lisp-compiled-closure-class+))
    1931            (emit-constructor-lambda-list args)
    1932            (emit-invokespecial-init super (lisp-object-arg-types 1)))
    1933           ((and
    1934                 (equal super +lisp-compiled-closure-class+))
     1916          ((equal super +lisp-compiled-closure-class+)
    19351917           (aload req-params-register)
    19361918           (aload opt-params-register)
     
    19381920           (if keys-p
    19391921               (emit-push-t)
    1940                (progn
    1941                  (emit-push-nil)
    1942                  (emit 'checkcast +lisp-symbol-class+)))
     1922               (emit-push-nil-symbol))
    19431923           (if rest-p
    19441924               (emit-push-t)
    1945                (progn
    1946                  (emit-push-nil)
    1947                  (emit 'checkcast +lisp-symbol-class+)))
     1925               (emit-push-nil-symbol))
    19481926           (if more-keys-p
    19491927               (emit-push-t)
    1950                (progn
    1951                  (emit-push-nil)
    1952                  (emit 'checkcast +lisp-symbol-class+)))
     1928               (emit-push-nil-symbol))
    19531929           (emit-invokespecial-init super
    19541930                                    (list +lisp-closure-parameter-array+
Note: See TracChangeset for help on using the changeset viewer.