Return to other.fs CVS log

Up to [gforth] / gforth / test

updated copyright notices for GPL v3

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