[armedbear-cvs] r13241 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu Mar 10 20:30:07 UTC 2011
Author: ehuelsmann
Date: Thu Mar 10 15:30:06 2011
New Revision: 13241
Log:
Reduce the amount of code in our compiler by changing the way
COMPILE-TEST-FORM works. Instead of returning a conditional jump,
pass the labels around for the conditional jump.
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 Thu Mar 10 15:30:06 2011
@@ -2379,6 +2379,7 @@
(> p2-test-numeric-comparison)
(>= p2-test-numeric-comparison)
(AND p2-test-and)
+ (OR p2-test-or)
(ATOM p2-test-atom)
(BIT-VECTOR-P p2-test-bit-vector-p)
(CHAR= p2-test-char=)
@@ -2421,40 +2422,74 @@
(initialize-p2-test-handlers)
+(defknown negate-jump-condition (t) t)
+(defun negate-jump-condition (jump-instruction)
+ (ecase jump-instruction
+ ('if_acmpeq 'if_acmpne)
+ ('if_acmpne 'if_acmpeq)
+ ('ifeq 'ifne)
+ ('ifne 'ifeq)
+ ('iflt 'ifge)
+ ('ifge 'iflt)
+ ('ifgt 'ifle)
+ ('ifle 'ifgt)
+ ('if_icmpeq 'if_icmpne)
+ ('if_icmpne 'if_icmpeq)
+ ('if_icmplt 'if_icmpge)
+ ('if_icmpge 'if_icmplt)
+ ('if_icmpgt 'if_icmple)
+ ('if_icmple 'if_icmpgt)))
+
+(defknown emit-test-jump (t t t) t)
+(defun emit-test-jump (jump success-label failure-label)
+ (cond
+ (failure-label
+ (emit jump failure-label)
+ (when success-label
+ (emit 'goto success-label)))
+ (t
+ (emit (negate-jump-condition jump) success-label)))
+ t)
+
(defknown p2-test-predicate (t t) t)
-(defun p2-test-predicate (form java-predicate)
+(defun p2-test-predicate (form java-predicate success-label failure-label)
(when (check-arg-count form 1)
(let ((arg (%cadr form)))
(compile-forms-and-maybe-emit-clear-values arg 'stack nil)
(emit-invokevirtual +lisp-object+ java-predicate nil :boolean)
- 'ifeq)))
+ (emit-test-jump 'ifeq success-label failure-label))))
-(declaim (ftype (function (t t) t) p2-test-instanceof-predicate))
-(defun p2-test-instanceof-predicate (form java-class)
+(declaim (ftype (function (t t t t) t) p2-test-instanceof-predicate))
+(defun p2-test-instanceof-predicate (form java-class
+ success-label failure-label)
(when (check-arg-count form 1)
(let ((arg (%cadr form)))
(compile-forms-and-maybe-emit-clear-values arg 'stack nil)
(emit-instanceof java-class)
- 'ifeq)))
-
-(defun p2-test-bit-vector-p (form)
- (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+))
+ (emit-test-jump 'ifeq success-label failure-label))))
-(defun p2-test-characterp (form)
- (p2-test-instanceof-predicate form +lisp-character+))
+(defun p2-test-bit-vector-p (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-abstract-bit-vector+
+ success-label failure-label))
+
+(defun p2-test-characterp (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-character+
+ success-label failure-label))
;; constantp form &optional environment => generalized-boolean
-(defun p2-test-constantp (form)
+(defun p2-test-constantp (form success-label failure-label)
(when (= (length form) 2)
(let ((arg (%cadr form)))
(compile-forms-and-maybe-emit-clear-values arg 'stack nil)
(emit-invokevirtual +lisp-object+ "constantp" nil :boolean)
- 'ifeq)))
+ (emit-test-jump 'ifeq success-label failure-label))))
-(defun p2-test-endp (form)
- (p2-test-predicate form "endp"))
+(defun p2-test-endp (form success-label failure-label)
+ (p2-test-predicate form "endp" success-label failure-label))
-(defmacro p2-test-integer-predicate (form predicate &body instructions)
+(defmacro p2-test-integer-predicate ((form predicate
+ success-label failure-label)
+ &body instructions)
(let ((tmpform (gensym)))
`(let ((,tmpform ,form))
(when (check-arg-count ,tmpform 1)
@@ -2463,27 +2498,28 @@
(compile-forms-and-maybe-emit-clear-values arg 'stack :int)
, at instructions)
(t
- (p2-test-predicate ,tmpform ,predicate))))))))
+ (p2-test-predicate ,tmpform ,predicate
+ ,success-label ,failure-label))))))))
-(defun p2-test-evenp (form)
- (p2-test-integer-predicate form "evenp"
- (emit-push-constant-int 1)
- (emit 'iand)
- 'ifne))
-
-(defun p2-test-oddp (form)
- (p2-test-integer-predicate form "oddp"
- (emit-push-constant-int 1)
- (emit 'iand)
- 'ifeq))
+(defun p2-test-evenp (form success-label failure-label)
+ (p2-test-integer-predicate (form "evenp" success-label failure-label)
+ (emit-push-constant-int 1)
+ (emit 'iand)
+ (emit-test-jump 'ifne success-label failure-label)))
+
+(defun p2-test-oddp (form success-label failure-label)
+ (p2-test-integer-predicate (form "oddp" success-label failure-label)
+ (emit-push-constant-int 1)
+ (emit 'iand)
+ (emit-test-jump 'ifeq success-label failure-label)))
-(defun p2-test-floatp (form)
- (p2-test-predicate form "floatp"))
+(defun p2-test-floatp (form success-label failure-label)
+ (p2-test-predicate form "floatp" success-label failure-label))
-(defun p2-test-integerp (form)
- (p2-test-predicate form "integerp"))
+(defun p2-test-integerp (form success-label failure-label)
+ (p2-test-predicate form "integerp" success-label failure-label))
-(defun p2-test-listp (form)
+(defun p2-test-listp (form success-label failure-label)
(when (check-arg-count form 1)
(let* ((arg (%cadr form))
(arg-type (derive-compiler-type arg)))
@@ -2494,100 +2530,93 @@
(compile-forms-and-maybe-emit-clear-values arg nil nil)
:alternate)
(t
- (p2-test-predicate form "listp"))))))
+ (p2-test-predicate form "listp" success-label failure-label))))))
-(defun p2-test-minusp (form)
- (p2-test-integer-predicate form "minusp" 'ifge))
+(defun p2-test-minusp (form success-label failure-label)
+ (p2-test-integer-predicate (form "minusp" success-label failure-label)
+ (emit-test-jump 'ifge success-label failure-label)))
-(defun p2-test-plusp (form)
- (p2-test-integer-predicate form "plusp" 'ifle))
+(defun p2-test-plusp (form success-label failure-label)
+ (p2-test-integer-predicate (form "plusp" success-label failure-label)
+ (emit-test-jump 'ifle success-label failure-label)))
-(defun p2-test-zerop (form)
- (p2-test-integer-predicate form "zerop" 'ifne))
+(defun p2-test-zerop (form success-label failure-label)
+ (p2-test-integer-predicate (form "zerop" success-label failure-label)
+ (emit-test-jump 'ifne success-label failure-label)))
-(defun p2-test-numberp (form)
- (p2-test-predicate form "numberp"))
+(defun p2-test-numberp (form success-label failure-label)
+ (p2-test-predicate form "numberp" success-label failure-label))
-(defun p2-test-packagep (form)
- (p2-test-instanceof-predicate form +lisp-package+))
+(defun p2-test-packagep (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-package+
+ success-label failure-label))
-(defun p2-test-rationalp (form)
- (p2-test-predicate form "rationalp"))
+(defun p2-test-rationalp (form success-label failure-label)
+ (p2-test-predicate form "rationalp" success-label failure-label))
-(defun p2-test-realp (form)
- (p2-test-predicate form "realp"))
+(defun p2-test-realp (form success-label failure-label)
+ (p2-test-predicate form "realp" success-label failure-label))
-(defun p2-test-special-operator-p (form)
- (p2-test-predicate form "isSpecialOperator"))
+(defun p2-test-special-operator-p (form success-label failure-label)
+ (p2-test-predicate form "isSpecialOperator" success-label failure-label))
-(defun p2-test-special-variable-p (form)
- (p2-test-predicate form "isSpecialVariable"))
+(defun p2-test-special-variable-p (form success-label failure-label)
+ (p2-test-predicate form "isSpecialVariable" success-label failure-label))
-(defun p2-test-symbolp (form)
- (p2-test-instanceof-predicate form +lisp-symbol+))
+(defun p2-test-symbolp (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-symbol+ success-label failure-label))
-(defun p2-test-consp (form)
- (p2-test-instanceof-predicate form +lisp-cons+))
+(defun p2-test-consp (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-cons+ success-label failure-label))
-(defun p2-test-atom (form)
- (p2-test-instanceof-predicate form +lisp-cons+)
- 'ifne)
+(defun p2-test-atom (form success-label failure-label)
+ ;; The test below is a negative test, so, reverse the labels for failure and success
+ (p2-test-instanceof-predicate form +lisp-cons+ failure-label success-label))
-(defun p2-test-fixnump (form)
- (p2-test-instanceof-predicate form +lisp-fixnum+))
+(defun p2-test-fixnump (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-fixnum+ success-label failure-label))
-(defun p2-test-stringp (form)
- (p2-test-instanceof-predicate form +lisp-abstract-string+))
+(defun p2-test-stringp (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-abstract-string+
+ success-label failure-label))
-(defun p2-test-vectorp (form)
- (p2-test-instanceof-predicate form +lisp-abstract-vector+))
+(defun p2-test-vectorp (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-abstract-vector+
+ success-label failure-label))
-(defun p2-test-simple-vector-p (form)
- (p2-test-instanceof-predicate form +lisp-simple-vector+))
+(defun p2-test-simple-vector-p (form success-label failure-label)
+ (p2-test-instanceof-predicate form +lisp-simple-vector+
+ success-label failure-label))
(defknown compile-test-form (t) t)
-(defun compile-test-form (test-form)
+(defun compile-test-form (test-form success-label failure-label)
(when (consp test-form)
(let* ((op (%car test-form))
(handler (p2-test-handler op))
- (result (and handler (funcall handler test-form))))
+ (result (and handler (funcall handler test-form success-label
+ failure-label))))
(when result
(return-from compile-test-form result))))
(cond ((eq test-form t)
:consequent)
- ((null test-form)
- :alternate)
((eq (derive-compiler-type test-form) 'BOOLEAN)
(compile-forms-and-maybe-emit-clear-values test-form 'stack :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
(t
(compile-forms-and-maybe-emit-clear-values test-form 'stack nil)
(emit-push-nil)
- 'if_acmpeq)))
+ (emit-test-jump 'if_acmpeq success-label failure-label))))
-(defun p2-test-not/null (form)
+(defun p2-test-not/null (form success-label failure-label)
(when (check-arg-count form 1)
(let* ((arg (%cadr form))
- (result (compile-test-form arg)))
- (ecase result
- ('if_acmpeq 'if_acmpne)
- ('if_acmpne 'if_acmpeq)
- ('ifeq 'ifne)
- ('ifne 'ifeq)
- ('iflt 'ifge)
- ('ifge 'iflt)
- ('ifgt 'ifle)
- ('ifle 'ifgt)
- ('if_icmpeq 'if_icmpne)
- ('if_icmpne 'if_icmpeq)
- ('if_icmplt 'if_icmpge)
- ('if_icmpge 'if_icmplt)
- ('if_icmpgt 'if_icmple)
- ('if_icmple 'if_icmpgt)
- (:alternate :consequent)
- (:consequent :alternate)))))
+ (result (compile-test-form arg failure-label success-label)))
+ (case result
+ (:consequent :alternate)
+ (:alternate :consequent)
+ (t result)))))
-(defun p2-test-char= (form)
+(defun p2-test-char= (form success-label failure-label)
(when (check-arg-count form 2)
(let* ((arg1 (%cadr form))
(arg2 (%caddr form)))
@@ -2595,9 +2624,9 @@
((compile-operand arg1 :char)
(compile-operand arg2 :char)
(maybe-emit-clear-values arg1 arg2)))
- 'if_icmpne)))
+ (emit-test-jump 'if_icmpne success-label failure-label))))
-(defun p2-test-eq (form)
+(defun p2-test-eq (form success-label failure-label)
(when (check-arg-count form 2)
(let ((arg1 (%cadr form))
(arg2 (%caddr form)))
@@ -2605,28 +2634,58 @@
((compile-operand arg1 nil)
(compile-operand arg2 nil)
(maybe-emit-clear-values arg1 arg2)))
- 'if_acmpne)))
+ (emit-test-jump 'if_acmpne success-label failure-label))))
+
+(defun p2-test-or (form success-label failure-label)
+ (let ((args (cdr form)))
+ (case (length args)
+ (0
+ :alternate)
+ (1
+ (compile-test-form (%car args) success-label failure-label))
+ (t
+ (loop
+ with local-success-label = (or success-label (gensym))
+ for arg in args
+ for result = (compile-test-form arg local-success-label nil)
+ when (eq :consequent result)
+ do (progn
+ (emit 'goto local-success-label)
+ (loop-finish))
+ finally (progn
+ (when failure-label
+ (emit 'goto failure-label))
+ (unless (eq success-label local-success-label)
+ (label local-success-label))
+ (return t)))))))
-(defun p2-test-and (form)
+(defun p2-test-and (form success-label failure-label)
(let ((args (cdr form)))
(case (length args)
(0
:consequent)
(1
- (compile-test-form (%car args)))
- (2
- (compile-form form 'stack :boolean)
- 'ifeq)
+ (compile-test-form (%car args) success-label failure-label))
(t
- (compile-forms-and-maybe-emit-clear-values form 'stack nil)
- (emit-push-nil)
- 'if_acmpeq))))
-
-(defun p2-test-neq (form)
- (p2-test-eq form)
- 'if_acmpeq)
+ (loop
+ with local-fail-label = (or failure-label (gensym))
+ for arg in args
+ for result = (compile-test-form arg nil local-fail-label)
+ when (eq :alternate result)
+ do (progn
+ (emit 'goto local-fail-label)
+ (loop-finish))
+ finally (progn
+ (when success-label
+ (emit 'goto success-label))
+ (unless (eq failure-label local-fail-label)
+ (label local-fail-label))
+ (return t)))))))
-(defun p2-test-eql (form)
+(defun p2-test-neq (form success-label failure-label)
+ (p2-test-eq form failure-label success-label))
+
+(defun p2-test-eql (form success-label failure-label)
(when (check-arg-count form 2)
(let* ((arg1 (%cadr form))
(arg2 (%caddr form))
@@ -2637,20 +2696,20 @@
((compile-operand arg1 :int)
(compile-operand arg2 :int)
(maybe-emit-clear-values arg1 arg2)))
- 'if_icmpne)
+ (emit-test-jump 'if_icmpne success-label failure-label))
((and (eq type1 'CHARACTER) (eq type2 'CHARACTER))
(with-operand-accumulation
((compile-operand arg1 :char)
(compile-operand arg2 :char)
(maybe-emit-clear-values arg1 arg2)))
- 'if_icmpne)
+ (emit-test-jump 'if_icmpne success-label failure-label))
((eq type2 'CHARACTER)
(with-operand-accumulation
((compile-operand arg1 nil)
(compile-operand arg2 :char)
(maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
((eq type1 'CHARACTER)
(with-operand-accumulation
((compile-operand arg1 :char)
@@ -2658,14 +2717,14 @@
(maybe-emit-clear-values arg1 arg2)))
(emit 'swap)
(emit-invokevirtual +lisp-object+ "eql" '(:char) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
((fixnum-type-p type2)
(with-operand-accumulation
((compile-operand arg1 nil)
(compile-operand arg2 :int)
(maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
((fixnum-type-p type1)
(with-operand-accumulation
((compile-operand arg1 :int)
@@ -2673,7 +2732,7 @@
(maybe-emit-clear-values arg1 arg2)))
(emit 'swap)
(emit-invokevirtual +lisp-object+ "eql" '(:int) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
(t
(with-operand-accumulation
((compile-operand arg1 nil)
@@ -2681,9 +2740,9 @@
(maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "eql"
(lisp-object-arg-types 1) :boolean)
- 'ifeq)))))
+ (emit-test-jump 'ifeq success-label failure-label))))))
-(defun p2-test-equality (form)
+(defun p2-test-equality (form success-label failure-label)
(when (check-arg-count form 2)
(let* ((op (%car form))
(translated-op (ecase op
@@ -2707,9 +2766,9 @@
(emit-invokevirtual +lisp-object+
translated-op
(lisp-object-arg-types 1) :boolean)))
- 'ifeq)))
+ (emit-test-jump 'ifeq success-label failure-label))))
-(defun p2-test-simple-typep (form)
+(defun p2-test-simple-typep (form success-label failure-label)
(when (check-arg-count form 2)
(let ((arg1 (%cadr form))
(arg2 (%caddr form)))
@@ -2720,9 +2779,9 @@
(emit-invokevirtual +lisp-object+ "typep"
(lisp-object-arg-types 1) +lisp-object+)
(emit-push-nil)
- 'if_acmpeq)))
+ (emit-test-jump 'if_acmpeq success-label failure-label))))
-(defun p2-test-memq (form)
+(defun p2-test-memq (form success-label failure-label)
(when (check-arg-count form 2)
(let ((arg1 (%cadr form))
(arg2 (%caddr form)))
@@ -2732,9 +2791,9 @@
(maybe-emit-clear-values arg1 arg2)))
(emit-invokestatic +lisp+ "memq"
(lisp-object-arg-types 2) :boolean)
- 'ifeq)))
+ (emit-test-jump 'ifeq success-label failure-label))))
-(defun p2-test-memql (form)
+(defun p2-test-memql (form success-label failure-label)
(when (check-arg-count form 2)
(let ((arg1 (%cadr form))
(arg2 (%caddr form)))
@@ -2744,9 +2803,9 @@
(maybe-emit-clear-values arg1 arg2)))
(emit-invokestatic +lisp+ "memql"
(lisp-object-arg-types 2) :boolean)
- 'ifeq)))
+ (emit-test-jump 'ifeq success-label failure-label))))
-(defun p2-test-/= (form)
+(defun p2-test-/= (form success-label failure-label)
(when (= (length form) 3)
(let* ((arg1 (%cadr form))
(arg2 (%caddr form))
@@ -2760,14 +2819,14 @@
((compile-operand arg1 :int)
(compile-operand arg2 :int)
(maybe-emit-clear-values arg1 arg2)))
- 'if_icmpeq)
+ (emit-test-jump 'if_icmpeq success-label failure-label))
((fixnum-type-p type2)
(with-operand-accumulation
((compile-operand arg1 nil)
(compile-operand arg2 :int)
(maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
((fixnum-type-p type1)
;; FIXME Compile the args in reverse order and avoid the swap if
;; either arg is a fixnum or a lexical variable.
@@ -2777,7 +2836,7 @@
(maybe-emit-clear-values arg1 arg2)))
(emit 'swap)
(emit-invokevirtual +lisp-object+ "isNotEqualTo" '(:int) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
(t
(with-operand-accumulation
((compile-operand arg1 nil)
@@ -2785,9 +2844,9 @@
(maybe-emit-clear-values arg1 arg2)))
(emit-invokevirtual +lisp-object+ "isNotEqualTo"
(lisp-object-arg-types 1) :boolean)
- 'ifeq)))))
+ (emit-test-jump 'ifeq success-label failure-label))))))
-(defun p2-test-numeric-comparison (form)
+(defun p2-test-numeric-comparison (form success-label failure-label)
(when (check-min-args form 1)
(when (= (length form) 3)
(let* ((op (%car form))
@@ -2803,24 +2862,26 @@
((compile-operand arg1 :int)
(compile-operand arg2 :int)
(maybe-emit-clear-values arg1 arg2)))
- (ecase op
- (< 'if_icmpge)
- (<= 'if_icmpgt)
- (> 'if_icmple)
- (>= 'if_icmplt)
- (= 'if_icmpne)))
+ (emit-test-jump (ecase op
+ (< 'if_icmpge)
+ (<= 'if_icmpgt)
+ (> 'if_icmple)
+ (>= 'if_icmplt)
+ (= 'if_icmpne))
+ success-label failure-label))
((and (java-long-type-p type1) (java-long-type-p type2))
(with-operand-accumulation
((compile-operand arg1 :long)
(compile-operand arg2 :long)
(maybe-emit-clear-values arg1 arg2)))
(emit 'lcmp)
- (ecase op
- (< 'ifge)
- (<= 'ifgt)
- (> 'ifle)
- (>= 'iflt)
- (= 'ifne)))
+ (emit-test-jump (ecase op
+ (< 'ifge)
+ (<= 'ifgt)
+ (> 'ifle)
+ (>= 'iflt)
+ (= 'ifne))
+ success-label failure-label))
((fixnum-type-p type2)
(with-operand-accumulation
((compile-operand arg1 nil)
@@ -2834,7 +2895,7 @@
(>= "isGreaterThanOrEqualTo")
(= "isEqualTo"))
'(:int) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
((fixnum-type-p type1)
;; FIXME We can compile the args in reverse order and avoid
;; the swap if either arg is a fixnum or a lexical variable.
@@ -2851,7 +2912,7 @@
(>= "isLessThanOrEqualTo")
(= "isEqualTo"))
'(:int) :boolean)
- 'ifeq)
+ (emit-test-jump 'ifeq success-label failure-label))
(t
(with-operand-accumulation
((compile-operand arg1 nil)
@@ -2865,139 +2926,28 @@
(>= "isGreaterThanOrEqualTo")
(= "isEqualTo"))
(lisp-object-arg-types 1) :boolean)
- 'ifeq))))))
+ (emit-test-jump 'ifeq success-label failure-label)))))))
-(defknown p2-if-or (t t t) t)
-(defun p2-if-or (form target representation)
- (let* ((test (second form))
- (consequent (third form))
- (alternate (fourth form))
- (LABEL1 (gensym))
- (LABEL2 (gensym)))
- (aver (and (consp test) (eq (car test) 'OR)))
- (let* ((args (cdr test)))
- (case (length args)
- (0
- (compile-form alternate target representation))
- (1
- (p2-if (list 'IF (%car args) consequent alternate) target representation))
- (t
- (dolist (arg args)
- (cond ((and (consp arg) (eq (first arg) 'EQ))
- ;; ERROR CHECKING HERE!
- (let ((arg1 (second arg))
- (arg2 (third arg)))
- (with-operand-accumulation
- ((compile-operand arg1 nil)
- (compile-operand arg2 nil)
- (maybe-emit-clear-values arg1 arg2)))
- (emit 'if_acmpeq LABEL1)))
- ((eq (derive-compiler-type arg) 'BOOLEAN)
- (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
- (emit 'ifne LABEL1))
- (t
- (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
- (emit-push-nil)
- (emit 'if_acmpne LABEL1))))
- (compile-form alternate target representation)
- (emit 'goto LABEL2)
- (label LABEL1)
- (compile-form consequent target representation)
- (label LABEL2))))))
-
-(defknown p2-if-and (t t t) t)
-(defun p2-if-and (form target representation)
+(defknown p2-if (t t t) t)
+(defun p2-if (form target representation)
(let* ((test (second form))
(consequent (third form))
(alternate (fourth form))
(LABEL1 (gensym))
(LABEL2 (gensym)))
- (aver (and (consp test) (eq (car test) 'AND)))
- (let* ((args (cdr test)))
- (case (length args)
- (0
+ (let ((result (compile-test-form test nil LABEL1)))
+ (case result
+ (:consequent
(compile-form consequent target representation))
- (1
- (p2-if (list 'IF (%car args) consequent alternate) target representation))
+ (:alternate
+ (compile-form alternate target representation))
(t
- (dolist (arg args)
- (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
- (emit 'ifeq LABEL1))
(compile-form consequent target representation)
(emit 'goto LABEL2)
(label LABEL1)
(compile-form alternate target representation)
(label LABEL2))))))
-(defknown p2-if-not-and (t t t) t)
-(defun p2-if-not-and (form target representation)
- (let* ((inverted-test (second (second form)))
- (consequent (third form))
- (alternate (fourth form))
- (LABEL1 (gensym))
- (LABEL2 (gensym)))
- (let* ((args (cdr inverted-test)))
- (case (length args)
- (0
- (compile-form alternate target representation))
- (1
- (p2-if (list 'IF (%car args) alternate consequent) target representation))
- (t
- (dolist (arg args)
- (let ((type (derive-compiler-type arg)))
- (cond ((eq type 'BOOLEAN)
- (compile-forms-and-maybe-emit-clear-values arg 'stack :boolean)
- (emit 'ifeq LABEL1))
- (t
- (compile-forms-and-maybe-emit-clear-values arg 'stack nil)
- (emit-push-nil)
- (emit 'if_acmpeq LABEL1)))))
- (compile-form alternate target representation)
- (emit 'goto LABEL2)
- (label LABEL1)
- (compile-form consequent target representation)
- (label LABEL2))))))
-
-(defknown p2-if (t t t) t)
-(defun p2-if (form target representation)
- (let* ((test (second form))
- (consequent (third form))
- (alternate (fourth form))
- (LABEL1 (gensym))
- (LABEL2 (gensym)))
- (cond ((eq test t)
- (compile-form consequent target representation))
- ((null test)
- (compile-form alternate target representation))
- ((numberp test)
- (compile-form consequent target representation))
- ((equal (derive-compiler-type test) +true-type+)
- (compile-forms-and-maybe-emit-clear-values test nil nil)
- (compile-form consequent target representation))
- ((and (consp test) (eq (car test) 'OR))
- (p2-if-or form target representation))
- ((and (consp test) (eq (car test) 'AND))
- (p2-if-and form target representation))
- ((and (consp test)
- (memq (first test) '(NOT NULL))
- (consp (second test))
- (eq (first (second test)) 'AND))
- (p2-if-not-and form target representation))
- (t
- (let ((result (compile-test-form test)))
- (case result
- (:consequent
- (compile-form consequent target representation))
- (:alternate
- (compile-form alternate target representation))
- (t
- (emit result LABEL1)
- (compile-form consequent target representation)
- (emit 'goto LABEL2)
- (label LABEL1)
- (compile-form alternate target representation)
- (label LABEL2))))))))
-
(defun compile-multiple-value-list (form target representation)
(emit-clear-values)
(compile-form (second form) 'stack nil)
More information about the armedbear-cvs
mailing list