Annotation of gforth/test/other.fs, revision 1.23
1.1 anton 1: \ various tests, especially for bugs that have been fixed
2:
1.22 anton 3: \ Copyright (C) 1997,1998,2000,2003 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.23 ! 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.23 ! anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 anton 19:
20: \ combination of marker and locals
21: marker foo1
22: marker foo2
23: foo2
24:
25: : bar { xxx yyy } ;
26:
27: foo1
28:
29: \ locals in an if structure
30: : locals-test1
31: lp@ swap
32: if
33: { a } a
34: else
35: endif
36: lp@ <> abort" locals in if error 1" ;
37:
38: 0 locals-test1
39: 1 locals-test1
40:
41:
42: \ recurse and locals
43:
44: : fac { n -- n! }
45: n 0>
46: if
47: n 1- recurse n *
48: else
49: 1
50: endif ;
51:
52: 5 fac 120 <> throw
53:
1.5 anton 54: \ TO and locals
55:
56: : locals-test2 ( -- )
57: true dup dup dup { addr1 u1 addr2 u2 -- n }
58: false TO addr1
59: addr1 false <> abort" TO does not work on locals" ;
60: locals-test2
61:
1.7 anton 62: : locals-test3 ( -- )
63: \ this should compile, but gives "invalid name argument" on gforth-0.3.0
64: 0 { a b } 0 to a ;
65:
1.5 anton 66: \ multiple reveals (recursive)
67:
68: 0
1.10 anton 69: : xxx recursive ;
1.5 anton 70: throw \ if the TOS is not 0, throw an error
71:
1.1 anton 72: \ look for primitives
73:
1.21 anton 74: ' + xt>threaded threaded>name dup 0= throw ( nt )
1.1 anton 75: s" +" find-name <> throw
76:
77: \ represent
78:
79: 1e pad 5 represent -1 <> swap 0 <> or swap 1 <> or throw
80:
1.2 anton 81: \ -trailing
82:
83: s" a " 2 /string -trailing throw drop
1.1 anton 84:
1.3 anton 85: \ convert (has to skip first char)
86:
87: 0. s" 123 " drop convert drop 23. d<> throw
88:
1.4 anton 89: \ search
90:
91: name abc 2dup name xyza search throw d<> throw
92: name b 2dup name abc search throw d<> throw
1.5 anton 93:
94: \ only
95:
96: : test-only ( -- )
97: get-order get-current
98: 0 set-current
99: only
100: get-current >r
101: set-current set-order
102: r> abort" ONLY sets current" ;
103: test-only
1.4 anton 104:
1.6 anton 105: \ create-interpret/compile
106:
1.7 anton 107: : my-constant ( n "name" -- )
1.6 anton 108: create-interpret/compile
109: ,
110: interpretation>
111: @
112: <interpretation
113: compilation>
114: @ postpone literal
115: <compilation ;
116:
1.7 anton 117: 5 my-constant five
1.6 anton 118: five 5 <> throw
119: : five' five ;
120: five' 5 <> throw
121:
1.7 anton 122: \ structs and alignment
123:
124: struct
125: char% field field1
126: float% field field2
127: end-struct my-struct%
128:
129: 0 field2 float% %alignment <> throw
130:
1.11 anton 131: \ filenames with "//"
132:
133: s" //jkfklfggfld/fjsjfk/hjfdjs" open-fpath-file 2drop
134:
1.12 anton 135: \ allotting negative space
136:
137: 1 allot
138: -1 allot
139:
1.13 anton 140: \ unaligned input for head?
141:
142: here 1+ head? throw
143:
1.14 anton 144: \ [compile] exit = exit
145:
146: : foo [compile] exit abort" '[compile] exit' broken" ;
147: foo
148:
1.15 anton 149: \ restore-input
150:
151: : test-restore-input[ ( -- )
152: refill 0= abort" refill failed"
153: bl word drop
154: save-input
155: refill 0= abort" refill failed"
156: -1 ;
157:
158: : ]test-restore-input ( -- )
159: drop restore-input abort" restore-input failed" 0 ;
160:
161: \ First input is skipped until the "]test-restore-input", then it is
162: \ reset to just before "0 [if]"
163: test-restore-input[ abort \ these aborts are skipped
164: abort 0 [if]
165: s" oops" 2drop ]test-restore-input abort
166: [then]
167: ( 0 ) throw
168:
1.16 anton 169: \ the same test with CRLF newlines
170: test-restore-input[ abort \ these aborts are skipped
171: abort 0 [if]
172: s" oops" 2drop ]test-restore-input abort
173: [then]
174: ( 0 ) throw
175:
1.1 anton 176: \ comments across several lines
177:
178: ( fjklfjlas;d
179: abort" ( does not work across lines"
180: )
181:
1.7 anton 182: s" ( testing ( without being delimited by newline in non-files" evaluate
1.1 anton 183:
184: \ last test!
185: \ testing '(' without ')' at end-of-file
186: ." expect ``warning: ')' missing''" cr
187: (
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>