[armedbear-cvs] r11782 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Apr 25 01:56:46 2009
New Revision: 11782

Log:
Remove code duplication.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Apr 25 01:56:46 2009
@@ -2065,12 +2065,12 @@
      (setf *static-code* *code*)
      (setf (gethash symbol ht) g))))
 
-(defknown declare-function (symbol) string)
-(defun declare-function (symbol)
+(defknown declare-function (symbol &optional setf) string)
+(defun declare-function (symbol &optional setf)
   (declare (type symbol symbol))
   (declare-with-hashtable
    symbol *declared-functions* ht f
-   (setf f (symbol-name (gensym "FUN")))
+   (setf f (symbol-name (if setf (gensym "SETF") (gensym "FUN"))))
    (let ((s (sanitize symbol)))
      (when s
        (setf f (concatenate 'string f "_" s))))
@@ -2080,7 +2080,10 @@
        (lookup-or-declare-symbol symbol)
      (let ((*code* *static-code*))
        (emit 'getstatic class name +lisp-symbol+)
-       (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
+       (emit-invokevirtual +lisp-symbol-class+
+                           (if setf
+                               "getSymbolSetfFunctionOrDie"
+                               "getSymbolFunctionOrDie")
                            nil +lisp-object+)
        (emit 'putstatic *this-class* f +lisp-object+)
        (setf *static-code* *code*)
@@ -2088,25 +2091,7 @@
 
 (defknown declare-setf-function (name) string)
 (defun declare-setf-function (name)
-  (declare-with-hashtable
-   name *declared-functions* ht f
-   (let ((symbol (cadr name)))
-     (declare (type symbol symbol))
-     (setf f (symbol-name (gensym)))
-     (let ((s (sanitize symbol)))
-       (when s
-	 (setf f (concatenate 'string f "_SETF_" s))))
-     (multiple-value-bind
-           (name class)
-         (lookup-or-declare-symbol symbol)
-       (let ((*code* *static-code*))
-         (emit 'getstatic class name +lisp-symbol+)
-         (declare-field f +lisp-object+)
-         (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
-                             nil +lisp-object+)
-         (emit 'putstatic *this-class* f +lisp-object+)
-         (setf *static-code* *code*)
-         (setf (gethash name ht) f))))))
+  (declare-function (cadr name) t))
 
 
 (defknown declare-local-function (local-function) string)