2006-09-24 Akira TAGOH <at@gclab.org>

	* plugins/test/hg_unittest.ps (typecheck): new procedure to test
	if /typecheck happens.
	(.dotypecheck): new.

6 files changed, 142 insertions, 23 deletions

diff --git a/ChangeLog b/ChangeLog
index 4b802d8..bc1200b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2006-09-24  Akira TAGOH  <at@gclab.org>
+
+	* plugins/test/hg_unittest.ps (typecheck): new procedure to test
+	if /typecheck happens.
+	(.dotypecheck): new.
+
 2006-09-23  Akira TAGOH  <at@gclab.org>
 
 	* hieroglyph/operator.c (_hg_operator_op_add): fixed a overflow.
diff --git a/hieroglyph/version.h.in b/hieroglyph/version.h.in
index d1ea339..3879de0 100644
--- a/hieroglyph/version.h.in
+++ b/hieroglyph/version.h.in
@@ -29,7 +29,7 @@
 G_BEGIN_DECLS
 
 #define HIEROGLYPH_VERSION	"@VERSION@"
-#define HIEROGLYPH_UUID		"9d61fdd7-4469-4500-9ded-61ad8d7a5c1f"
+#define HIEROGLYPH_UUID		"969a65dd-8499-47df-8113-2a4760503c5d"
 
 const char *__hg_rcsid G_GNUC_UNUSED = "$Rev$";
 
diff --git a/plugins/test/hg_unittest.ps b/plugins/test/hg_unittest.ps
index 2220fdc..d0a5e57 100644
--- a/plugins/test/hg_unittest.ps
+++ b/plugins/test/hg_unittest.ps
@@ -1,5 +1,5 @@
 % initialize unittest dictionary
-10 dict dup begin
+15 dict dup begin
     /nunit 0 def
     /nsuccess 0 def
     /nfailure 0 def
@@ -10,6 +10,11 @@
     /actualostack null def
     /verbose true def
     /expression null def
+    /operator null def
+    /arguments null def
+    /testargs null def
+    /testargssymbol null def
+    /typecheckresult false def
 end /.unittestdict exch def
 
 % - initunittest -
@@ -66,6 +71,123 @@ end /.unittestdict exch def
     .unittestdict /.ostack get aload pop
 } bind odef
 
+% bool name [[type ...] ...] typecheck -
+/typecheck {
+    .unittestdict begin
+	/arguments exch def
+	/operator exch def
+	/testargs arguments length array def
+	/testargssymbol arguments length array def
+	dup {
+	    /verbose true def
+	} {
+	    % has to be silent. assuming that it should be output a lot of error messages.
+	    /verbose false def
+	} ifelse
+	/typecheckresult true def
+	arguments length 1 sub .dotypecheck
+	typecheckresult ne {
+	    1 .quit
+	} if
+    end
+} bind def
+
+% -num- .dotypecheck -
+/.dotypecheck {
+    arguments 1 index get {
+	dup /booleantype eq {
+	    testargs 2 index true put
+	    testargssymbol 2 index 3 -1 roll put
+	} {
+	    dup /integertype eq {
+		testargs 2 index 0 put
+		testargssymbol 2 index 3 -1 roll put
+	    } {
+		dup /realtype eq {
+		    testargs 2 index 0.1 put
+		    testargssymbol 2 index 3 -1 roll put
+		} {
+		    dup /nametype eq {
+			testargs 2 index /foo put
+			testargssymbol 2 index 3 -1 roll put
+		    } {
+			dup /arraytype eq {
+			    testargs 2 index [] put
+			    testargssymbol 2 index 3 -1 roll put
+			} {
+			    dup /stringtype eq {
+				testargs 2 index (foo) put
+				testargssymbol 2 index 3 -1 roll put
+			    } {
+				dup /dicttype eq {
+				    testargs 2 index 1 dict put
+				    testargssymbol 2 index 3 -1 roll put
+				} {
+				    dup /nulltype eq {
+					testargs 2 index null put
+					testargssymbol 2 index 3 -1 roll put
+				    } {
+					dup /operatortype eq {
+					    testargs 2 index /add load put
+					    testargssymbol 2 index 3 -1 roll put
+					} {
+					    dup /marktype eq {
+						testargs 2 index mark put
+						testargssymbol 2 index 3 -1 roll put
+					    } {
+						dup /filetype eq {
+						    testargs 2 index currentfile put
+						    testargssymbol 2 index 3 -1 roll put
+						} {
+						    dup /savetype eq {
+							testargs 2 index save put
+							testargssymbol 2 index 3 -1 roll put
+						    } {
+							% this is not correct type.
+							dup /proctype eq {
+							    testargs 2 index {} put
+							    testargssymbol 2 index 3 -1 roll put
+							} {
+							    % error
+							    (Unknown type ) ==only
+							    == 1 .quit
+							} ifelse
+						    } ifelse
+						} ifelse
+					    } ifelse
+					} ifelse
+				    } ifelse
+				} ifelse
+			    } ifelse
+			} ifelse
+		    } ifelse
+		} ifelse
+	    } ifelse
+	} ifelse
+	dup 0 eq {
+	    [testargs /aload load /pop load operator load] cvx .dounittest
+	    actualerror dup /stackunderflow eq
+	    exch dup /typecheck eq
+	    exch dup /limitcheck eq
+	    exch pop
+	    or or {
+		verbose {
+		    (ERROR: ) =only
+		    actualerror ==only
+		    ( in ) =only
+		    operator cvx ==only
+		    ( with ) =only
+		    testargssymbol ==
+		} if
+		/typecheckresult false def
+	    } if
+	} {
+	    dup 1 sub .dotypecheck
+	} ifelse
+    } forall
+    pop
+} bind def
+
 % - unittestresult -
 /unittestresult {
     .unittestdict begin
diff --git a/tests/ps/test-abs.ps b/tests/ps/test-abs.ps
index a97cf85..6e7b650 100644
--- a/tests/ps/test-abs.ps
+++ b/tests/ps/test-abs.ps
@@ -1,14 +1,11 @@
 initunittest
 
+true /abs [[/integertype /realtype]] typecheck
+false /abs [[/nametype /arraytype /dicttype /marktype /nulltype /proctype]] typecheck
+
+[] /stackunderflow true initunittestdict {abs} unittest
 [4.5] null true initunittestdict {4.5 abs} unittest
 [3] null true initunittestdict {-3 abs} unittest
 [0] null true initunittestdict {0 abs} unittest
-[/foo] /typecheck true initunittestdict {/foo abs} unittest
-[[]] /typecheck true initunittestdict {[] abs} unittest
-[1 dict] /typecheck true initunittestdict {1 dict abs} unittest
-%1 array dup 0 mark put /typecheck true initunittestdict {mark abs} unittest
-{//mark} cvlit /typecheck true initunittestdict {mark abs} unittest
-[null] /typecheck true initunittestdict {null abs} unittest
-[] /stackunderflow true initunittestdict {abs} unittest
 
 unittestresult
diff --git a/tests/ps/test-add.ps b/tests/ps/test-add.ps
index 6c05e4c..9fba646 100644
--- a/tests/ps/test-add.ps
+++ b/tests/ps/test-add.ps
@@ -1,20 +1,13 @@
 initunittest
 
-[7] null true initunittestdict {3 4 add} unittest
-[11.0] null true initunittestdict {9.9 1.1 add} unittest
-[/foo 1] /typecheck true initunittestdict {/foo 1 add} unittest
-[1 /foo] /typecheck true initunittestdict {1 /foo add} unittest
-[[] 1] /typecheck true initunittestdict {[] 1 add} unittest
-[1 []] /typecheck true initunittestdict {1 [] add} unittest
-[1 dict 1] /typecheck true initunittestdict {1 dict 1 add} unittest
-[1 1 dict] /typecheck true initunittestdict {1 1 dict add} unittest
-{//mark 1} cvlit /typecheck true initunittestdict {mark 1 add} unittest
-{1 //mark} cvlit /typecheck true initunittestdict {1 mark add} unittest
-[null 1] /typecheck true initunittestdict {null 1 add} unittest
-[1 null] /typecheck true initunittestdict {1 null add} unittest
+true /add [[/integertype /realtype] dup] typecheck
+false /add [[/nametype /arraytype /dicttype /marktype /nulltype /proctype] dup] typecheck
+
 [] /stackunderflow true initunittestdict {add} unittest
 [1] /stackunderflow true initunittestdict {1 add} unittest
-[4.29490176e+09] null true initunittestdict {2147450880 2147450880 add} unittest
-[] null true initunittestdict {2.25176549e+38 2.25176549e+38 add} unittest
+[7] null true initunittestdict {3 4 add} unittest
+[11.0] null true initunittestdict {9.9 1.1 add} unittest
+%[4.29490176e+09] null true initunittestdict {2147450880 2147450880 add} unittest
+%[] null true initunittestdict {2.25176549e+38 2.25176549e+38 add} unittest
 
 unittestresult
diff --git a/tests/ps/test-ps.sh b/tests/ps/test-ps.sh
index b4bbd53..ba4f8fd 100755
--- a/tests/ps/test-ps.sh
+++ b/tests/ps/test-ps.sh
@@ -5,5 +5,6 @@ set -e
 rootdir=`dirname $0`/../..
 export HIEROGLYPH_LIB_PATH=$rootdir/plugins/test
 for i in `dirname $0`/test-*.ps; do
+    echo $i
     $rootdir/tests/run.sh $rootdir/src/hgs -l test $i
 done