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

[Erik Huelsmann]

Author: ehuelsmann
Date: Wed May 20 16:50:27 2009
New Revision: 11903

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

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/precompiler.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	Wed May 20 16:50:27 2009
@@ -8350,6 +8350,17 @@
                   (format *error-output* ";     ~S~%" name))))
             (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
          (tempfile (make-temp-file)))
@@ -8361,17 +8372,7 @@
                     (compile-defun name expr env tempfile))))
         (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)))
 
 (defun jvm-compile (name &optional definition)

Modified: trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/precompiler.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/precompiler.lisp	Wed May 20 16:50:27 2009
@@ -1043,16 +1043,7 @@
            (return-from precompile (values nil t t))))
     (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)))
 
 (defun precompile-package (pkg &key verbose)