version 1.1, 1997/05/21 20:40:20
|
version 1.14, 2000/02/04 14:52:30
|
Line 1
|
Line 1
|
\ various tests, especially for bugs that have been fixed |
\ various tests, especially for bugs that have been fixed |
|
|
\ Copyright (C) 1997 Free Software Foundation, Inc. |
\ Copyright (C) 1997,1998 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 52 foo1
|
Line 52 foo1
|
|
|
5 fac 120 <> throw |
5 fac 120 <> throw |
|
|
|
\ TO and locals |
|
|
|
: locals-test2 ( -- ) |
|
true dup dup dup { addr1 u1 addr2 u2 -- n } |
|
false TO addr1 |
|
addr1 false <> abort" TO does not work on locals" ; |
|
locals-test2 |
|
|
|
: locals-test3 ( -- ) |
|
\ this should compile, but gives "invalid name argument" on gforth-0.3.0 |
|
0 { a b } 0 to a ; |
|
|
|
\ multiple reveals (recursive) |
|
|
|
0 |
|
: xxx recursive ; |
|
throw \ if the TOS is not 0, throw an error |
|
|
\ look for primitives |
\ look for primitives |
|
|
' + look 0= throw ( nt ) |
' + look 0= throw ( nt ) |
Line 61 s" +" find-name <> throw
|
Line 79 s" +" find-name <> throw
|
|
|
1e pad 5 represent -1 <> swap 0 <> or swap 1 <> or throw |
1e pad 5 represent -1 <> swap 0 <> or swap 1 <> or throw |
|
|
|
\ -trailing |
|
|
|
s" a " 2 /string -trailing throw drop |
|
|
|
\ convert (has to skip first char) |
|
|
|
0. s" 123 " drop convert drop 23. d<> throw |
|
|
|
\ search |
|
|
|
name abc 2dup name xyza search throw d<> throw |
|
name b 2dup name abc search throw d<> throw |
|
|
|
\ only |
|
|
|
: test-only ( -- ) |
|
get-order get-current |
|
0 set-current |
|
only |
|
get-current >r |
|
set-current set-order |
|
r> abort" ONLY sets current" ; |
|
test-only |
|
|
|
\ create-interpret/compile |
|
|
|
: my-constant ( n "name" -- ) |
|
create-interpret/compile |
|
, |
|
interpretation> |
|
@ |
|
<interpretation |
|
compilation> |
|
@ postpone literal |
|
<compilation ; |
|
|
|
5 my-constant five |
|
five 5 <> throw |
|
: five' five ; |
|
five' 5 <> throw |
|
|
|
\ structs and alignment |
|
|
|
struct |
|
char% field field1 |
|
float% field field2 |
|
end-struct my-struct% |
|
|
|
0 field2 float% %alignment <> throw |
|
|
|
\ filenames with "//" |
|
|
|
s" //jkfklfggfld/fjsjfk/hjfdjs" open-fpath-file 2drop |
|
|
|
\ allotting negative space |
|
|
|
1 allot |
|
-1 allot |
|
|
|
\ unaligned input for head? |
|
|
|
here 1+ head? throw |
|
|
|
\ [compile] exit = exit |
|
|
|
: foo [compile] exit abort" '[compile] exit' broken" ; |
|
foo |
|
|
\ comments across several lines |
\ comments across several lines |
|
|
Line 68 s" +" find-name <> throw
|
Line 153 s" +" find-name <> throw
|
abort" ( does not work across lines" |
abort" ( does not work across lines" |
) |
) |
|
|
s" ( testing ( without delimited by newline in non-files" evaluate |
s" ( testing ( without being delimited by newline in non-files" evaluate |
|
|
\ last test! |
\ last test! |
\ testing '(' without ')' at end-of-file |
\ testing '(' without ')' at end-of-file |