1: \ various tests, especially for bugs that have been fixed
2:
3: \ Copyright (C) 1997,1998,2000,2003,2007 Free Software Foundation, Inc.
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
9: \ as published by the Free Software Foundation, either version 3
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
18: \ along with this program. If not, see http://www.gnu.org/licenses/.
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:
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:
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:
66: \ multiple reveals (recursive)
67:
68: 0
69: : xxx recursive ;
70: throw \ if the TOS is not 0, throw an error
71:
72: \ look for primitives
73:
74: ' + xt>threaded threaded>name dup 0= throw ( nt )
75: s" +" find-name <> throw
76:
77: \ represent
78:
79: 1e pad 5 represent -1 <> swap 0 <> or swap 1 <> or throw
80:
81: \ -trailing
82:
83: s" a " 2 /string -trailing throw drop
84:
85: \ convert (has to skip first char)
86:
87: 0. s" 123 " drop convert drop 23. d<> throw
88:
89: \ search
90:
91: name abc 2dup name xyza search throw d<> throw
92: name b 2dup name abc search throw d<> throw
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
104:
105: \ create-interpret/compile
106:
107: : my-constant ( n "name" -- )
108: create-interpret/compile
109: ,
110: interpretation>
111: @
112: <interpretation
113: compilation>
114: @ postpone literal
115: <compilation ;
116:
117: 5 my-constant five
118: five 5 <> throw
119: : five' five ;
120: five' 5 <> throw
121:
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:
131: \ filenames with "//"
132:
133: s" //jkfklfggfld/fjsjfk/hjfdjs" open-fpath-file 2drop
134:
135: \ allotting negative space
136:
137: 1 allot
138: -1 allot
139:
140: \ unaligned input for head?
141:
142: here 1+ head? throw
143:
144: \ [compile] exit = exit
145:
146: : foo [compile] exit abort" '[compile] exit' broken" ;
147: foo
148:
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:
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:
176: \ comments across several lines
177:
178: ( fjklfjlas;d
179: abort" ( does not work across lines"
180: )
181:
182: s" ( testing ( without being delimited by newline in non-files" evaluate
183:
184: \ last test!
185: \ testing '(' without ')' at end-of-file
186: ." expect ``warning: ')' missing''" cr
187: (
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>