Return to other.fs CVS log

Up to [gforth] / gforth / test

Annotation of gforth/test/other.fs, revision 1.24

1.1       anton       1: \ various tests, especially for bugs that have been fixed
                      2: 
1.24    ! anton       3: \ Copyright (C) 1997,1998,2000,2003,2007 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: (