Annotation of gforth/test/gforth.fs, revision 1.20
1.1 anton 1: \ test some gforth extension words
2:
1.20 ! anton 3: \ Copyright (C) 2003,2004,2005,2006,2007,2009,2011 Free Software Foundation, Inc.
1.1 anton 4:
5: \ This file is part of Gforth.
6:
7: \ Gforth is free software; you can redistribute it and/or
8: \ modify it under the terms of the GNU General Public License
1.15 anton 9: \ as published by the Free Software Foundation, either version 3
1.1 anton 10: \ of the License, or (at your option) any later version.
11:
12: \ This program is distributed in the hope that it will be useful,
13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15: \ GNU General Public License for more details.
16:
17: \ You should have received a copy of the GNU General Public License
1.15 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 anton 19:
20: require ./tester.fs
1.9 anton 21: decimal
1.1 anton 22:
23: \ f>str-rdp (then f.rdp and f>buf-rdb should also be ok)
24:
25: { 12.3456789e 7 3 1 f>str-rdp s" 12.346" str= -> true }
26: { 12.3456789e 7 4 1 f>str-rdp s" 12.3457" str= -> true }
27: { -12.3456789e 7 4 1 f>str-rdp s" -1.23E1" str= -> true }
28: { 0.0996e 7 3 1 f>str-rdp s" 0.100" str= -> true }
29: { 0.0996e 7 3 3 f>str-rdp s" 9.96E-2" str= -> true }
30: { 999.9994e 7 3 1 f>str-rdp s" 999.999" str= -> true }
31: { 999.9996e 7 3 1 f>str-rdp s" 1.000E3" str= -> true }
1.2 anton 32: { -1e-20 5 2 1 f>str-rdp s" *****" str= -> true }
1.3 anton 33:
34: \ 0x hex number conversion, or not
35:
36: decimal
37: { 0x10 -> 16 }
38: { 0X10 -> 16 }
39: 36 base !
40: { 0x10 -> x10 }
41: decimal
1.4 anton 42: { 'a' -> 97 }
43: { 'A -> 65 }
1.7 anton 44: { 1. '1 -> 1. 49 }
1.6 anton 45:
1.13 anton 46: \ REPRESENT has no trailing 0s even for inf and nan
1.6 anton 47:
48: { 1e 0e f/ pad 16 represent drop 2drop pad 15 + c@ '0 = -> false }
49: { 0e 0e f/ pad 16 represent drop 2drop pad 15 + c@ '0 = -> false }
50: { -1e 0e f/ pad 16 represent drop 2drop pad 15 + c@ '0 = -> false }
1.13 anton 51:
52: \ TRY and friends
53:
54: : 0<-throw ( n -- )
55: 0< throw ;
56:
57: : try-test1 ( n1 -- n2 )
58: try
59: dup 0<-throw
60: iferror
61: 2drop 25
62: then
63: 1+
64: endtry ;
65:
66: { -5 try-test1 -> 26 }
67: { 5 try-test1 -> 6 }
68:
69: : try-test2 ( n1 -- n2 )
70: try
71: 0
72: restore
73: drop 1+ dup 0<-throw
74: endtry ;
75:
76: { -5 try-test2 -> 0 }
77: { 5 try-test2 -> 6 }
78:
79: : try-test3 ( n1 -- n2 )
80: try
81: dup 0<-throw
82: endtry-iferror
83: 2drop 10
84: else
85: 1+
86: then ;
87:
88: { -5 try-test3 -> 10 }
89: { 5 try-test3 -> 6 }
1.16 anton 90:
91: \ fcopysign
92:
93: t{ 5e 1e fcopysign -> 5e }t
94: t{ -5e 1e fcopysign -> 5e }t
95: t{ 5e -1e fcopysign -> -5e }t
96: t{ -5e -1e fcopysign -> -5e }t
97: \ tests involving -0e?
1.18 anton 98:
1.19 anton 99: \ ?of nextcase contof
1.18 anton 100:
1.19 anton 101: : mysgn ( n1 -- n2 )
1.18 anton 102: case
103: dup 0< ?of drop -1 endof
104: dup 0> ?of drop 1 endof
105: dup
106: endcase ;
107:
1.19 anton 108: t{ 5 mysgn -> 1 }
109: t{ -3 mysgn -> -1 }
110: t{ 0 mysgn -> 0 }
111:
112: : myscan ( addr1 n1 char -- addr2 n2 )
113: >r case
114: dup 0= ?of endof
115: over c@ r@ = ?of endof
116: 1 /string
117: dup nextcase
118: rdrop ;
119:
120: t{ s" dhfa;jfsdk" 2dup ';' myscan 2swap 4 /string d= -> true }
121: t{ s" abcdef" 2dup 'g' myscan 2swap 6 /string d= -> true }
122:
123:
124: : gcd ( n1 n2 -- n )
125: case
126: 2dup > ?of tuck - contof
127: 2dup < ?of over - contof
128: endcase ;
129:
130: t{ 48 42 gcd -> 6 }
131: t{ 42 48 gcd -> 6 }
132:
133:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>