Changeset 11782

Timestamp:

04/25/09 05:56:46 (14 years ago)

Author:

ehuelsmann

Message:

Remove code duplication.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (3 diffs)

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

@@ -2066 +2066 @@
      (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
@@ -2081 +2081 @@
      (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+)
@@ -2089 +2092 @@
 (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))