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

[Ville Voutilainen]

Author: vvoutilainen
Date: Mon Dec 29 15:26:20 2008
New Revision: 11503

Log:
Small refactoring combining common bits in p2-car/p2-cdr.
This is in preparation for combining both the Cons special
case and the function call case. After that it's much easier
to remove the Cons special case, if profiling so suggests.


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	Mon Dec 29 15:26:20 2008
@@ -4586,6 +4586,13 @@
       (emit-push-nil)
       (emit-move-from-stack target))))
 
+(defun emit-cast/getfield-for-car/cdr (arg target representation field)
+  (compile-form arg 'stack nil)
+  (emit 'checkcast +lisp-cons-class+)
+  (emit 'getfield +lisp-cons-class+ field +lisp-object+)
+  (fix-boxing representation nil)
+  (emit-move-from-stack target representation))
+
 (defun p2-car (form target representation)
   (unless (check-arg-count form 1)
     (compile-function-call form target representation)
@@ -4597,11 +4604,7 @@
 	   (compile-forms-and-maybe-emit-clear-values (second arg) 'stack nil)
            (emit-invoke-method "cadr" target representation))
           ((eq (derive-type arg) 'CONS)
-           (compile-form arg 'stack nil)
-           (emit 'checkcast +lisp-cons-class+)
-           (emit 'getfield +lisp-cons-class+ "car" +lisp-object+)
-           (fix-boxing representation nil)
-           (emit-move-from-stack target representation))
+	   (emit-cast/getfield-for-car/cdr arg target representation "car"))
           (t
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
            (emit-invoke-method "car" target representation)))))
@@ -4612,11 +4615,7 @@
     (return-from p2-cdr))
   (let ((arg (%cadr form)))
     (cond ((eq (derive-type arg) 'CONS)
-           (compile-form arg 'stack nil)
-           (emit 'checkcast +lisp-cons-class+)
-           (emit 'getfield +lisp-cons-class+ "cdr" +lisp-object+)
-           (fix-boxing representation nil)
-           (emit-move-from-stack target representation))
+	   (emit-cast/getfield-for-car/cdr arg target representation "cdr"))
           (t
 	   (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
            (emit-invoke-method "cdr" target representation)))))