Annotation of gforth/test/primtest.fs, revision 1.3
1.1 anton 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:
1.3 ! anton 96: : cr ( -- )
! 97: newline type ;
! 98:
1.2 anton 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:
1.3 ! anton 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:
1.2 anton 115: variable s0
116: : depth s0 @ sp@ cell+ - ;
117:
118: \ : myconst ( n -- )
119: \ create ,
120: \ does> ( -- n )
121: \ @ ;
122: \ char m myconst char-m
1.3 ! anton 123: create myconst char m ,
! 124: does> @ ;
1.2 anton 125:
126: : unloop-test ( -- )
127: 0 >r 0 >r unloop ;
128:
1.3 ! anton 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:
1.1 anton 141: : boot ( -- )
1.2 anton 142: sp@ s0 !
1.1 anton 143: [char] a stdout emit-file drop
144: [char] b emit
1.3 ! anton 145: s" cd" type
! 146: ." fg"
1.2 anton 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
1.3 ! anton 153: ['] myconst execute emit
1.2 anton 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
1.3 ! anton 160: myconst emit
1.2 anton 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
1.3 ! anton 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
1.1 anton 371: cr
1.2 anton 372: depth (bye) ;
1.1 anton 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>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to primtest.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / test