Tcl Source Code

Artifact 51c0379b676d0e59754340420915aa5211d06e28:

Attachment "expr27.tcl" to ticket [761471ffff] added by kennykb 2004-11-06 03:21:51.

---

# Big test for correct ordering of data in [expr]

proc testIEEE {} {
    variable ieeeValues
    binary scan [binary format dd -1.0 1.0] c* c
    switch -exact $c {
	{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
		ieeeValues(-Infinity)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
		ieeeValues(-Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
		ieeeValues(-Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x00\x00\x00\x00\x00\080\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
		ieeeValues(+Normal)
	    binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
		ieeeValues(+Infinity)
	    binary scan \x00\x00\x00\x00\0xx\0xx\xf8\x7f d \
		ieeeValues(NaN)
	    return 1
	}
	{-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
	    binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Infinity)
	    binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Normal)
	    binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-Subnormal)
	    binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(-0)
	    binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+0)
	    binary scan \x00\x80\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Subnormal)
	    binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Normal)
	    binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(+Infinity)
	    binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
		ieeeValues(NaN)
	    return 1
	}
	default {
	    return 0
	}
    }
}
::tcltest::testConstraint ieeeFloatingPoint [testIEEE]

foreach op {< <= == != > >=} {
    proc test$op {a b} [list expr "\$a $op \$b"]

}

test expr-27.1 {expr - correct ordering - not compiled} ieeeFloatingPoint {
    set problems {}
    # Ordering should be: -Infinity < -Normal < Subnormal < -0
    #                     < +0 < +Subnormal < +Normal < +Infinity
    # with equality within each class.
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity
    }
    set weights {
	-3 -2 -1 0 0 1 2 3
    }
    foreach name1 $names weight1 $weights {
	foreach name2 $names weight2 $weights {
	    foreach op {< <= == != >= >} {
		set shouldBe [expr "$weight1 $op $weight2"]
		set is [expr "\$ieeeValues($name1) $op \$ieeeValues($name2)"]
		if { $is != $shouldBe } {
		    append problems $name1 { } $op { } $name2 \
			":result is " $is ", should be $shouldBe" \n
		}
	    }
	}
    }
    set problems
} {}

test expr-27.2 {expr - correct ordering - compiled} ieeeFloatingPoint {
    set problems {}
    # Ordering should be: -Infinity < -Normal < Subnormal < -0
    #                     < +0 < +Subnormal < +Normal < +Infinity
    # with equality within each class.
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity
    }
    set weights {
	-3 -2 -1 0 0 1 2 3
    }
    foreach name1 $names weight1 $weights {
	foreach name2 $names weight2 $weights {
	    foreach op {< <= == != >= >} {
		set shouldBe [expr "$weight1 $op $weight2"]
		set is [test$op $ieeeValues($name1) $ieeeValues($name2)]
		if { $is != $shouldBe } {
		    append problems $name1 { } $op { } $name2 \
			":result is " $is ", should be $shouldBe" \n
		}
	    }
	}
    }
    set problems
} {}

test expr-27.3 {expr - NaN is unordered - not compiled} {
    set problems {}
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN
    }
    foreach name1 $names {
	foreach op {< <= == != >= >} {
	    puts "$ieeeValues($name1) $op $ieeeValues(NaN)"
	    if "\$ieeeValues($name1) $op \$ieeeValues(NaN)" {
		append problems $name1 { } $op { } NaN \
		    ": result is 1, should be 0" \n
	    }
	    if "\$ieeeValues(NaN) $op \$ieeeValues($name1)" {
		append problems NaN { } $op { } $name1 \
		    ": result is 1, should be 0" \n
	    }
	}
    }
    set problems
} {}

test expr-27.4 {expr - NaN is unordered - compiled} {
    set problems {}
    set names {
	-Infinity -Normal -Subnormal -0 +0 +Subnormal +Normal +Infinity NaN
    }
    foreach name1 $names {
	foreach op {< <= == != >= >} {
	    puts "$ieeeValues($name1) $op $ieeeValues(NaN)"
	    if { [test$op $ieeeValues($name1) $ieeeValues(NaN)] } {
		append problems $name1 { } $op { } NaN \
		    ": result is 1, should be 0" \n
	    }
	    if { [test$op $ieeeValues(NaN) $ieeeValues($name1)] } {
		append problems NaN { } $op { } $name1 \
		    ": result is 1, should be 0" \n
	    }
	}
    }
    set problems
} {}