--- gforth/test/gforth.fs 2009/09/25 18:52:29 1.16 +++ gforth/test/gforth.fs 2011/08/12 16:53:19 1.19 @@ -1,6 +1,6 @@ \ test some gforth extension words -\ Copyright (C) 2003,2004,2005,2006,2007 Free Software Foundation, Inc. +\ Copyright (C) 2003,2004,2005,2006,2007,2009 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -95,3 +95,39 @@ t{ -5e 1e fcopysign -> 5e }t t{ 5e -1e fcopysign -> -5e }t t{ -5e -1e fcopysign -> -5e }t \ tests involving -0e? + +\ ?of nextcase contof + +: mysgn ( n1 -- n2 ) + case + dup 0< ?of drop -1 endof + dup 0> ?of drop 1 endof + dup + endcase ; + +t{ 5 mysgn -> 1 } +t{ -3 mysgn -> -1 } +t{ 0 mysgn -> 0 } + +: myscan ( addr1 n1 char -- addr2 n2 ) + >r case + dup 0= ?of endof + over c@ r@ = ?of endof + 1 /string + dup nextcase + rdrop ; + +t{ s" dhfa;jfsdk" 2dup ';' myscan 2swap 4 /string d= -> true } +t{ s" abcdef" 2dup 'g' myscan 2swap 6 /string d= -> true } + + +: gcd ( n1 n2 -- n ) + case + 2dup > ?of tuck - contof + 2dup < ?of over - contof + endcase ; + +t{ 48 42 gcd -> 6 } +t{ 42 48 gcd -> 6 } + + \ No newline at end of file