Annotation of gforth/test/primtest.fs, revision 1.5

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

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