File:  [gforth] / gforth / test / primtest.fs
Revision 1.3: download - view: text, annotated - select for diffs
Sat Nov 8 20:29:03 2003 UTC (15 years, 11 months ago) by anton
Branches: MAIN
CVS tags: HEAD
added make target primtest
more primtests
fixed some gforth-native bugs
workaround for finish-code problem

    1: \ test for Gforth primitives
    2: 
    3: \ Copyright (C) 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 2
   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, write to the Free Software
   19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   20: 
   21: Create mach-file here over 1+ allot place
   22: 
   23: 0 [IF]
   24: \ debugging: produce a relocation and a symbol table
   25: s" rel-table" r/w create-file throw
   26: Constant fd-relocation-table
   27: 
   28: \ debuggging: produce a symbol table
   29: s" sym-table" r/w create-file throw
   30: Constant fd-symbol-table
   31: [THEN]
   32: 
   33: 
   34: bl word vocabulary find nip 0= [IF]
   35:     \ if search order stuff is missing assume we are compiling on a gforth
   36:     \ system and include it.
   37:     \ We want the files taken from our current gforth installation
   38:     \ so we don't include relatively to this file
   39:     require startup.fs
   40: [THEN]
   41: 
   42: \ include etags.fs
   43: 
   44: include ./../cross.fs              \ cross-compiler
   45: 
   46: decimal
   47: 
   48: has? kernel-start has? kernel-size makekernel
   49: \ create image-header
   50: has? header [IF]
   51: here 1802 over 
   52:     A,                  \ base address
   53:     0 ,                 \ checksum
   54:     0 ,                 \ image size (without tags)
   55: has? kernel-size
   56:     ,                   \ dict size
   57:     has? stack-size ,   \ data stack size
   58:     has? fstack-size ,  \ FP stack size
   59:     has? rstack-size ,  \ return stack size
   60:     has? lstack-size ,  \ locals stack size
   61:     0 A,                \ code entry point
   62:     0 A,                \ throw entry point
   63:     has? stack-size ,   \ unused (possibly tib stack size)
   64:     0 ,                 \ unused
   65:     0 ,                 \ data stack base
   66:     0 ,                 \ fp stack base
   67:     0 ,                 \ return stack base
   68:     0 ,                 \ locals stack base
   69: [THEN]
   70: 
   71: doc-off
   72: has? prims [IF]
   73:     include ./../kernel/aliases.fs             \ primitive aliases
   74: [ELSE]
   75:     prims-include
   76:     undef-words
   77:     include prim.fs
   78:     all-words  
   79: [THEN]
   80: doc-on
   81: 
   82: has? header [IF]
   83: 1802 <> [IF] .s cr .( header start address expected!) cr uffz [THEN]
   84: AConstant image-header
   85: : forthstart image-header @ ;
   86: [THEN]
   87: 
   88: \ 0 AConstant forthstart
   89: 
   90: : emit ( c -- )
   91:     stdout emit-file drop ;
   92: 
   93: : type ( addr u -- )
   94:     stdout write-file drop ;
   95: 
   96: : cr ( -- )
   97:     newline type ;
   98: 
   99: char j constant char-j
  100: 
  101: variable var-k
  102: char k var-k !
  103: defer my-emit
  104: ' emit is my-emit
  105: cell% 2* 0 0 field >body
  106: 
  107: create cbuf 100 allot
  108: 
  109: create cellbuf 5 , 6 , 7 , 8 , 20 cells allot
  110: 
  111: 
  112: 4 constant w/o
  113: 0 constant r/o
  114: 
  115: variable s0
  116: : depth s0 @ sp@ cell+ - ;
  117: 
  118: \  : myconst ( n -- )
  119: \      create ,
  120: \    does> ( -- n )
  121: \      @ ;
  122: \  char m myconst char-m
  123: create myconst char m ,
  124: does> @ ;
  125: 
  126: : unloop-test ( -- )
  127:     0 >r 0 >r unloop ;
  128: 
  129: : deeper-rp@
  130:     rp@ ;
  131: 
  132: : rp!-test2
  133:     rp! ;
  134: 
  135: : rp!-test1
  136:     rp@ rp!-test2 ." should not be executed" ;
  137: 
  138: : rdrop-test
  139:     0 >r rdrop ;
  140: 
  141: : boot ( -- )
  142:     sp@ s0 !
  143:     [char] a stdout emit-file drop
  144:     [char] b emit
  145:     s" cd" type
  146:     ." fg"
  147:     [char] i ['] emit execute
  148:     ['] char-j execute emit
  149:     ['] var-k execute @ emit
  150:     \ !!douser
  151:     [char] l ['] my-emit execute
  152:     [char] l ['] my-emit ['] >body execute perform
  153:     ['] myconst execute emit
  154:     noop
  155:     [char] m ['] my-emit ['] execute dup execute
  156:     [char] m ['] 1+ execute emit
  157:     [char] o ['] my-emit >body perform
  158:     unloop-test ." p"
  159:     [char] q my-emit
  160:     myconst emit
  161:     \ !! branch-lp+!#
  162:     ahead ." wrong" then ." r"
  163:     0 if ." wrong" else ." s" then
  164:     1 if ." t" else ." wrong" then
  165:     \ !! ?dup-?branch ?dup-0=-?branch
  166:     \ 0 ?dup-if ." wrong" drop else ." u" then
  167:     \ [char] v ?dup-if emit else ." wrong" then
  168:     1 for [char] x i - emit next
  169:     [char] z 1+ [char] y do i emit loop
  170:     [char] D [char] A do i emit 2 +loop
  171:     [char] A [char] E do i emit -2 +loop
  172: \    [char] A [char] D do i emit 2 -loop \ !! -loop undefined
  173: \    [char] A [char] E do i emit -2 s+loop \ !! s+loop undefined
  174:     [char] X [char] X ?do i emit loop
  175:     [char] G [char] F ?do i emit loop
  176:     \    [char] X [char] Y +do i emit loop \ !! +do undefined
  177:     \    [char] H [char] G +do i emit loop
  178:     \ !! (u+do) (-do) (u-do)
  179:     [char] I >r 0 >r i' emit 2rdrop
  180:     [char] J >r 1 0 ?do j emit loop rdrop
  181:     [char] K >r 0 >r 0 >r 1 0 ?do k emit loop 2rdrop rdrop
  182:     s" LMN" cbuf swap move cbuf 3 type
  183:     cbuf cbuf 2 + 5 cmove cbuf 6 type
  184:     cbuf 1+ cbuf 6 cmove> cbuf 2 type
  185:     cbuf 10 [char] N fill cbuf 2 type
  186:     cbuf 10 s" NNNN" compare [char] N + emit
  187:     cbuf 4 s" NNNN" compare [char] P + emit
  188:     cbuf 3 s" NNNN" compare [char] R + emit
  189:     [char] r toupper emit
  190:     s" abcST" 3 /string type
  191:     [char] S 2 + emit
  192:     [char] V ['] my-emit >body perform
  193:     [char] V [char] W 2 under+ emit emit
  194:     'Z 1 - emit
  195:     'X 2 negate - emit
  196:     '` 1+ emit
  197:     'c 1- emit
  198:     'a 'd max emit
  199:     'g 'e min emit
  200:     'e -1 abs + emit
  201:     'a 2 3 * + emit
  202:     'a 700 99 / + emit
  203:     'g 8 3 mod + emit
  204:     8 3 /mod + 'f + emit
  205:     'a 5 2* + emit
  206:     'n -3 2/ + emit
  207:     7. -3 fm/mod drop 'o + emit
  208:     7. -3 sm/rem drop 'm + emit
  209:     -1 1 m* + 'q + emit
  210:     -1 -1 um* + 'q + emit
  211:     7. 3 um/mod + 'n + emit
  212:     0 2 -1 m+ -1 1 d= 's + emit
  213:     -1 1 1 1 d+ 0 3 d= 't + emit
  214:     1 3 2 1 d- -1 1 d= 'u + emit
  215:     1 0 dnegate -1 -1 d= 'v + emit
  216:     cr
  217:     -1 0 d2* -2 1 d= 'b + emit
  218:     -4 3 d2/ -2 1 d= 'c + emit
  219:     5 3 and 1 = 'd + emit
  220:     5 3 or 7 = 'e + emit
  221:     5 3 xor 6 = 'f + emit
  222:     5 invert -6 = 'g + emit
  223:     $f0f0f0f0 12 rshift $f0f0f = 'h + emit
  224:     5 2 lshift 20 = 'i + emit
  225:     0 0= 1 0= -1 0 d= 'j + emit
  226:     -1 0< 0 0< -1 0 d= 'k + emit
  227:     1 0> 0 0> -1 0 d= 'l + emit
  228:     0 0<= 1 0<= -1 0 d= 'm + emit
  229:     0 0<= 1 0<= -1 0 d= 'm + emit \ just to repeat the "l"
  230:     0 0>= -1 0>= -1 0 d= 'n + emit
  231:     5 0<> 0 0<> -1 0 d= 'o + emit
  232:     1 1 = 2 3 = -1 0 d= 'p + emit
  233:     -1 0 < 1 1 < -1 0 d= 'q + emit
  234:     2 -1 > 1 1 > -1 0 d= 'r + emit
  235:     1 1 <= 2 -1 <= -1 0 d= 's + emit
  236:     1 1 >= -1 2 >= -1 0 d= 't + emit
  237:     2 3 <> 1 1 <> -1 0 d= 'u + emit
  238:     1 1 u= 2 3 u= -1 0 d= 'v + emit
  239:     0 -2 u< 0 0 u< -1 0 d= 'w + emit
  240:     -3 5 u> 0 0 u> -1 0 d= 'x + emit
  241:     0 0 u<= -1 0 u<= -1 0 d= 'y + emit
  242:     0 0 u>= 0 -1 u>= -1 0 d= 'z + emit
  243:     2 3 u<> 0 0 u<> -1 0 d= '{ + emit
  244:     \ dcomparisons
  245:     0. d0= 1. d0= -1 0 d= 'j + emit
  246:     -1. d0< 0. d0< -1 0 d= 'k + emit
  247:     1. d0> 0. d0> -1 0 d= 'l + emit
  248:     0. d0<= 1. d0<= -1 0 d= 'm + emit
  249:     0. d0<= 1. d0<= -1 0 d= 'm + emit \ just to repeat the "l"
  250:     0. d0>= -1. d0>= -1 0 d= 'n + emit
  251:     5. d0<> 0. d0<> -1 0 d= 'o + emit
  252:     1. 1. d= 2. 3. d= -1 0 d= 'p + emit
  253:     -1. 0. d< 1. 1. d< -1 0 d= 'q + emit
  254:     2. -1. d> 1. 1. d> -1 0 d= 'r + emit
  255:     1. 1. d<= 2. -1. d<= -1 0 d= 's + emit
  256:     1. 1. d>= -1. 2. d>= -1 0 d= 't + emit
  257:     2. 3. d<> 1. 1. d<> -1 0 d= 'u + emit
  258:     1. 1. du= 2. 3. du= -1 0 d= 'v + emit
  259:     0. -2. du< 0. 0. du< -1 0 d= 'w + emit
  260:     -3. 5. du> 0. 0. du> -1 0 d= 'x + emit
  261:     0. 0. du<= -1. 0. du<= -1 0 d= 'y + emit
  262:     0. 0. du>= 0. -1. du>= -1 0 d= 'z + emit
  263:     2. 3. du<> 0. 0. du<> -1 0 d= '{ + emit
  264:     0 0 1 within 0 0 0 within -1 0 d= 'B + emit
  265:     \ !! useraddr
  266:     \ !! up!
  267:     sp@ s0 @ = 'C + emit
  268:     sp@ -3 cells + sp! drop drop drop sp@ s0 @ = 'D + emit
  269:     rp@ deeper-rp@ cell+ = 'E + emit
  270:     rp!-test1 'E emit
  271:     \ fp@ 1e fp@ float+ = 'G + emit \ !! fp@
  272:     0 1 >r 0 = r> 1 = -1 -1 d= 'G + emit
  273:     rdrop-test 'G emit
  274:     0 1 2>r 'I 2r> 0 1 d= + emit
  275:     3 4 2>r 2r@ 2r> d= 'J + emit
  276:     5 6 2>r 7 8 2>r 2rdrop 2r> 5 6 d= 'K + emit
  277:     1 2 over 2 1 d= 1 -1 d= 'L + emit
  278:     1 2 3 drop 1 2 d= 'M + emit
  279:     1 2 swap 2 1 d= 'N + emit
  280:     1 dup 1 1 d= 'O + emit
  281:     1 2 3 rot 3 1 d= 2 -1 d= 'P + emit
  282:     1 2 3 -rot 1 2 d= 3 -1 d= 'Q + emit
  283:     1 2 3 nip 1 3 d= 'R + emit
  284:     1 2 tuck 1 2 d= 2 -1 d= 'S + emit
  285:     4 0 ?dup 4 0 d= 'T + emit
  286:     5 1 ?dup 1 1 d= 5 -1 d= 'U + emit
  287:     6 0 pick 6 6 d= 'V + emit
  288:     1 2 3 4 2drop 1 2 d= 'W + emit
  289:     7 1 2 2dup d= 7 -1 d= 'X + emit
  290:     8 1 2 3 4 2over 1 2 d= >r 3 4 d= >r 1 2 d= r> and r> and 8 -1 d= 'Y + emit
  291:     1 2 3 4 2swap 1 2 d= >r 3 4 d= r> -1 -1 d= 'Z + emit
  292:     9 1 2 3 4 5 6 2rot 1 2 d= >r 5 6 d= >r 3 4 d= r> and r> and 9 -1 d= '[ + emit
  293:     7 1 2 3 4 2nip 3 4 d= 7 -1 d= 'b + emit
  294:     8 1 2 3 4 2tuck 3 4 d= >r 1 2 d= >r 3 4 d= r> and r> and 8 -1 d= 'c + emit
  295:     cr
  296:     cellbuf @ 5 = 'b + emit
  297:     9 cellbuf ! 5 cellbuf @ 5 9 d= 'c + emit
  298:     -1 cellbuf +! cellbuf @ 8 = 'd + emit
  299:     -1 cellbuf ! cellbuf c@ $ff = 'e + emit
  300:     1 cellbuf c! cellbuf @ 1 <> 'f + emit
  301:     3 4 cellbuf 2! cellbuf @ 4 = 'g + emit
  302:     2 cellbuf ! cellbuf 2@ 3 2 d= 'h + emit
  303:     9 cellbuf cell+ ! cellbuf 2@ 9 2 d= 'i + emit
  304:     cellbuf 3 cells + @ 8 = 'j + emit
  305:     s" ijk" drop char+ c@ emit
  306:     s" ijk" drop 2 (chars) + c@ emit
  307:     c" ijkl" count 3 /string type
  308:     \ s" abc" 0 (f83find) 0= 'm + emit \ not in gforth-0.6.2
  309:     s" abc" 0 (listlfind) 0= 'n + emit
  310:     s" abc" 0 (hashlfind) 0= 'o + emit
  311:     s" abc" 0 (tablelfind) 0= 'p + emit
  312:     s" dfskdfjsdl" 5 (hashkey1) 32 u< 'n + emit
  313:     s"    bcde   " (parse-white) s" bcde" compare 'n + emit
  314:     1 aligned 0 cell+ = 'p + emit
  315:     1 faligned 0 float+ = 'q + emit
  316:     threading-method 2 u< 'r + emit
  317:     \ stdin key-file emit
  318:     stdin key-file emit
  319:     stdin key?-file 't + emit
  320:     stderr drop 't emit
  321:     form 2drop 'u emit
  322:     cbuf 20 flush-icache
  323:     \ (bye)
  324:     s" true" (system) 0 0 d= 'w + emit
  325:     s" ENVVAR" getenv s" bla" compare 'w + emit
  326:     s" grep -q bla" w/o open-pipe 0= 'y + emit >r
  327:     s" blabla" i write-file 0= 'z + emit r> close-pipe d0= 'B + emit
  328:     777 time&date 2drop 2drop 2drop 777 = 'C + emit
  329:     1 ms 'C emit
  330:     100 allocate 0= 'E + emit ( addr)
  331:     200 resize 0= 'F + emit  ( addr2)
  332:     free 0= 'G + emit
  333:     1 strerror 2drop 'G emit
  334:     1 strsignal 2drop 'H emit
  335:     \ call-c
  336:     s" prim" r/o open-file 0= 'J + emit >r
  337:     cbuf 100 i (read-line) 0= 'K + emit drop 'L + emit drop
  338:     i file-position 0= 'M + emit cellbuf 2!
  339:     cbuf 10 i read-file 0= 'N + emit 10 = 'O + emit
  340:     cellbuf 2@ i reposition-file 0= 'P + emit
  341:     cbuf 10 + dup 10 i read-file 0= 'Q + emit cbuf 10 compare 'Q + emit
  342:     i file-size 0= 'S + emit 2drop
  343:     i file-eof? 'a + emit
  344:     r> close-file 0= 'T + emit
  345:     s" /tmp/gforth')(|&;test" w/o create-file 0= 'U + emit >r
  346:     s" bla" i write-file 0= 'V + emit
  347:     i flush-file 0= 'W + emit
  348:     100. i resize-file 0= 'V + emit
  349:     r> close-file 0= 'W + emit
  350:     s" /tmp/gforth')(|&;test" s" /tmp/gforth'|&;test" rename-file 0= 'X + emit
  351:     s" /tmp/gforth'|&;test" delete-file 0= 'Y + emit
  352:     \ !! open-dir
  353:     \ !! read-dir
  354:     \ !! close-dir
  355:     \ !! filename-match
  356:     utime 2drop 'Y emit
  357:     cputime 2drop 2drop 'Z emit
  358:     \ !! all the FP stuff
  359:     \ !! all the locals stuff
  360:     \ !! syslib stuff
  361:     \ !! ffcall stuff
  362:     \ !! oldcall stuff
  363:     \ compiler stuff
  364:     ['] emit @ cellbuf !
  365:     ['] ;s threading-method 0= if @ then cellbuf >body !
  366:     cellbuf >body compile-prim1 'Y emit
  367:     finish-code 'Z emit
  368:     cellbuf execute 'a emit
  369:     \ !! forget-dyncode
  370:     cellbuf >body @ decompile-prim ['] ;s @ = 'c + emit
  371:     cr
  372:     depth (bye) ;
  373: 
  374: \ Setup                                                13feb93py
  375: 
  376: has? header [IF]
  377:     \ set image size
  378:     here image-header 2 cells + !         
  379:     \ set image entry point
  380:     ' boot >body  image-header 8 cells + A!         
  381: [ELSE]
  382:     >boot
  383: [THEN]
  384: 
  385: \ include ./../kernel/pass.fs                    \ pass pointers from cross to target
  386: 
  387: .unresolved                          \ how did we do?
  388: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>