fix type and arithmetic-type intrinsics

library/compiler/intrinsics.factor

@@ -137,6 +137,7 @@ words ;
     in-1
     0 %arithmetic-type ,
     0 %tag-fixnum ,
+    1 %inc-d ,
     out-1
 ] "linearizer" set-word-prop
 

library/compiler/vops.factor

@@ -135,12 +135,10 @@ VOP: %type
 : %type ( vreg ) <vreg> dest-vop <%type> ;
 
 VOP: %arithmetic-type
-: %arithmetic-type empty-vop <%arithmetic-type> ;
+: %arithmetic-type <vreg> dest-vop <%arithmetic-type> ;
 
 VOP: %tag-fixnum
 : %tag-fixnum <vreg> dest-vop <%tag-fixnum> ;
 
 : check-dest ( vop reg -- )
-    swap vop-dest v>operand = [
+    swap vop-dest = [ "invalid VOP destination" throw ] unless ;
-        "invalid VOP destination" throw
-    ] unless ;

library/compiler/x86/generator.factor

@@ -125,7 +125,7 @@ M: %type generate-node ( vop -- )
 M: %arithmetic-type generate-node ( vop -- )
     #! This one works directly with the stack. It outputs an
     #! UNBOXED value in vop-dest.
-    EAX check-dest
+    0 <vreg> check-dest
     <label> "end" set
     ! Load top two stack values
     EAX [ ESI -4 ] MOV
@@ -138,5 +138,5 @@ M: %arithmetic-type generate-node ( vop -- )
     "end" get JE
     ! No, they are not equal. Call a runtime function to
     ! coerce the integers to a higher type.
-    "arithmetic_type" compile-c-call
+    "arithmetic_type" f compile-c-call
     "end" get save-xt ;

library/test/compiler/intrinsics.factor

@@ -122,3 +122,11 @@ math-internals test words ;
 [ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-1 ] unit-test
 
 [ 3 1 ] [ 10 3 [ fixnum/mod ] compile-1 ] unit-test
+
+[ t ] [ 3 type 3 [ type ] compile-1 eq? ] unit-test
+[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-1 eq? ] unit-test
+[ t ] [ "hey" type "hey" [ type ] compile-1 eq? ] unit-test
+[ t ] [ f type f [ type ] compile-1 eq? ] unit-test
+
+[ 1 1 0 ] [ 1 1 [ arithmetic-type ] compile-1 ] unit-test
+[ 1.0 1.0 5 ] [ 1.0 1 [ arithmetic-type ] compile-1 ] unit-test

library/test/test.factor

@@ -4,8 +4,14 @@ IN: test
 USING: errors kernel lists math memory namespaces parser
 prettyprint sequences stdio strings unparser vectors words ;
 
-: assert ( t -- )
+TUPLE: assert expect got ;
-    [ "Assertion failed!" throw ] unless ;
+M: assert error.
+    "Assertion failed" print
+    "Expected: " write dup assert-expect .
+    "Got: " write assert-got . ;
+
+: assert= ( a b -- )
+    2dup = [ <assert> throw ] unless ;
 
 : print-test ( input output -- )
     "--> " write 2list . flush ;
@@ -25,7 +31,7 @@ prettyprint sequences stdio strings unparser vectors words ;
         [
             2dup print-test
             swap >r >r clear r> call
-            datastack >list r> = assert
+            datastack >list r> assert=
         ] keep-datastack 2drop
     ] time ;
 
@@ -34,9 +40,7 @@ prettyprint sequences stdio strings unparser vectors words ;
     [ [ not ] catch ] cons [ f ] swap unit-test ;
 
 : assert-depth ( quot -- )
-    depth slip depth = [
+    depth slip depth assert= ;
-        "Unequal before/after depth" throw
-    ] unless ;
 
 SYMBOL: failures
 

native/arithmetic.c

@@ -66,5 +66,5 @@ F_FIXNUM arithmetic_type(void)
 
 void primitive_arithmetic_type(void)
 {
-	dpush(arithmetic_type());
+	dpush(tag_fixnum(arithmetic_type()));
 }