Changeset 11903

Timestamp:

05/20/09 20:50:27 (14 years ago)

Author:

ehuelsmann

Message:

Factor out common function definition replacement
from PRE::PRECOMPILE and JVM::%JVM-COMPILE.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass2.lisp (modified) (2 diffs)
• precompiler.lisp (modified) (1 diff)

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

@@ -8351 +8351 @@
             (terpri *error-output*))))))
 
+(defun set-function-definition (name new old)
+  (let ((*warn-on-redefinition* nil))
+    (sys::%set-lambda-name new name)
+    (sys:set-call-count new (sys:call-count old))
+    (sys::%set-arglist new (sys::arglist old))
+    (when (macro-function name)
+      (setf new (make-macro name new)))
+    (if (typep old 'standard-generic-function)
+        (mop:set-funcallable-instance-function old new)
+        (setf (fdefinition name) new))))
+
 (defun %jvm-compile (name definition expr env)
   (let* (compiled-function
@@ -8362 +8373 @@
         (delete-file tempfile)))
     (when (and name (functionp compiled-function))
-      (sys::%set-lambda-name compiled-function name)
-      (sys:set-call-count compiled-function (sys:call-count definition))
-      (sys::%set-arglist compiled-function (sys::arglist definition))
-      (let ((*warn-on-redefinition* nil))
-        (cond ((typep definition 'standard-generic-function)
-               (mop:set-funcallable-instance-function definition compiled-function))
-              (t
-               (setf (fdefinition name)
-                     (if (macro-function name)
-                         (make-macro name compiled-function)
-                         compiled-function))))))
+      (set-function-definition name compiled-function definition))
     (or name compiled-function)))
 

trunk/abcl/src/org/armedbear/lisp/precompiler.lisp

@@ -1044 +1044 @@
     (setf result (coerce-to-function (precompile-form expr nil)))
     (when (and name (functionp result))
-      (%set-lambda-name result name)
-      (set-call-count result (call-count definition))
-      (let ((*warn-on-redefinition* nil))
-        (if (and (symbolp name) (macro-function name))
-            (let ((mac (make-macro name result)))
-              (%set-arglist mac (arglist (symbol-function name)))
-              (setf (fdefinition name) mac))
-            (progn
-              (setf (fdefinition name) result)
-              (%set-arglist result (arglist definition))))))
+      (sys::set-function-definition name result definition))
     (values (or name result) nil nil)))