version 1.2, 2003/11/06 21:59:49
|
version 1.3, 2003/11/08 20:29:03
|
Line 90 AConstant image-header
|
Line 90 AConstant image-header
|
: emit ( c -- ) |
: emit ( c -- ) |
stdout emit-file drop ; |
stdout emit-file drop ; |
|
|
: cr ( -- ) |
|
10 emit ; |
|
|
|
: type ( addr u -- ) |
: type ( addr u -- ) |
stdout write-file drop ; |
stdout write-file drop ; |
|
|
|
: cr ( -- ) |
|
newline type ; |
|
|
char j constant char-j |
char j constant char-j |
|
|
variable var-k |
variable var-k |
Line 104 defer my-emit
|
Line 104 defer my-emit
|
' emit is my-emit |
' emit is my-emit |
cell% 2* 0 0 field >body |
cell% 2* 0 0 field >body |
|
|
|
create cbuf 100 allot |
|
|
|
create cellbuf 5 , 6 , 7 , 8 , 20 cells allot |
|
|
|
|
|
4 constant w/o |
|
0 constant r/o |
|
|
variable s0 |
variable s0 |
: depth s0 @ sp@ cell+ - ; |
: depth s0 @ sp@ cell+ - ; |
|
|
Line 112 variable s0
|
Line 120 variable s0
|
\ does> ( -- n ) |
\ does> ( -- n ) |
\ @ ; |
\ @ ; |
\ char m myconst char-m |
\ char m myconst char-m |
|
create myconst char m , |
|
does> @ ; |
|
|
: unloop-test ( -- ) |
: unloop-test ( -- ) |
0 >r 0 >r unloop ; |
0 >r 0 >r unloop ; |
|
|
|
: deeper-rp@ |
|
rp@ ; |
|
|
|
: rp!-test2 |
|
rp! ; |
|
|
|
: rp!-test1 |
|
rp@ rp!-test2 ." should not be executed" ; |
|
|
|
: rdrop-test |
|
0 >r rdrop ; |
|
|
: boot ( -- ) |
: boot ( -- ) |
sp@ s0 ! |
sp@ s0 ! |
[char] a stdout emit-file drop |
[char] a stdout emit-file drop |
[char] b emit |
[char] b emit |
s" cde" type |
s" cd" type |
." fgh" |
." fg" |
[char] i ['] emit execute |
[char] i ['] emit execute |
['] char-j execute emit |
['] char-j execute emit |
['] var-k execute @ emit |
['] var-k execute @ emit |
\ !!douser |
\ !!douser |
[char] l ['] my-emit execute |
[char] l ['] my-emit execute |
[char] l ['] my-emit ['] >body execute perform |
[char] l ['] my-emit ['] >body execute perform |
\ !!dodoes ['] char-m execute emit |
['] myconst execute emit |
noop |
noop |
[char] m ['] my-emit ['] execute dup execute |
[char] m ['] my-emit ['] execute dup execute |
[char] m ['] 1+ execute emit |
[char] m ['] 1+ execute emit |
[char] o ['] my-emit >body perform |
[char] o ['] my-emit >body perform |
unloop-test ." p" |
unloop-test ." p" |
[char] q my-emit |
[char] q my-emit |
\ !!does-exec |
myconst emit |
\ !! branch-lp+!# |
\ !! branch-lp+!# |
ahead ." wrong" then ." r" |
ahead ." wrong" then ." r" |
0 if ." wrong" else ." s" then |
0 if ." wrong" else ." s" then |
Line 143 variable s0
|
Line 165 variable s0
|
\ !! ?dup-?branch ?dup-0=-?branch |
\ !! ?dup-?branch ?dup-0=-?branch |
\ 0 ?dup-if ." wrong" drop else ." u" then |
\ 0 ?dup-if ." wrong" drop else ." u" then |
\ [char] v ?dup-if emit else ." wrong" then |
\ [char] v ?dup-if emit else ." wrong" then |
|
1 for [char] x i - emit next |
|
[char] z 1+ [char] y do i emit loop |
|
[char] D [char] A do i emit 2 +loop |
|
[char] A [char] E do i emit -2 +loop |
|
\ [char] A [char] D do i emit 2 -loop \ !! -loop undefined |
|
\ [char] A [char] E do i emit -2 s+loop \ !! s+loop undefined |
|
[char] X [char] X ?do i emit loop |
|
[char] G [char] F ?do i emit loop |
|
\ [char] X [char] Y +do i emit loop \ !! +do undefined |
|
\ [char] H [char] G +do i emit loop |
|
\ !! (u+do) (-do) (u-do) |
|
[char] I >r 0 >r i' emit 2rdrop |
|
[char] J >r 1 0 ?do j emit loop rdrop |
|
[char] K >r 0 >r 0 >r 1 0 ?do k emit loop 2rdrop rdrop |
|
s" LMN" cbuf swap move cbuf 3 type |
|
cbuf cbuf 2 + 5 cmove cbuf 6 type |
|
cbuf 1+ cbuf 6 cmove> cbuf 2 type |
|
cbuf 10 [char] N fill cbuf 2 type |
|
cbuf 10 s" NNNN" compare [char] N + emit |
|
cbuf 4 s" NNNN" compare [char] P + emit |
|
cbuf 3 s" NNNN" compare [char] R + emit |
|
[char] r toupper emit |
|
s" abcST" 3 /string type |
|
[char] S 2 + emit |
|
[char] V ['] my-emit >body perform |
|
[char] V [char] W 2 under+ emit emit |
|
'Z 1 - emit |
|
'X 2 negate - emit |
|
'` 1+ emit |
|
'c 1- emit |
|
'a 'd max emit |
|
'g 'e min emit |
|
'e -1 abs + emit |
|
'a 2 3 * + emit |
|
'a 700 99 / + emit |
|
'g 8 3 mod + emit |
|
8 3 /mod + 'f + emit |
|
'a 5 2* + emit |
|
'n -3 2/ + emit |
|
7. -3 fm/mod drop 'o + emit |
|
7. -3 sm/rem drop 'm + emit |
|
-1 1 m* + 'q + emit |
|
-1 -1 um* + 'q + emit |
|
7. 3 um/mod + 'n + emit |
|
0 2 -1 m+ -1 1 d= 's + emit |
|
-1 1 1 1 d+ 0 3 d= 't + emit |
|
1 3 2 1 d- -1 1 d= 'u + emit |
|
1 0 dnegate -1 -1 d= 'v + emit |
|
cr |
|
-1 0 d2* -2 1 d= 'b + emit |
|
-4 3 d2/ -2 1 d= 'c + emit |
|
5 3 and 1 = 'd + emit |
|
5 3 or 7 = 'e + emit |
|
5 3 xor 6 = 'f + emit |
|
5 invert -6 = 'g + emit |
|
$f0f0f0f0 12 rshift $f0f0f = 'h + emit |
|
5 2 lshift 20 = 'i + emit |
|
0 0= 1 0= -1 0 d= 'j + emit |
|
-1 0< 0 0< -1 0 d= 'k + emit |
|
1 0> 0 0> -1 0 d= 'l + emit |
|
0 0<= 1 0<= -1 0 d= 'm + emit |
|
0 0<= 1 0<= -1 0 d= 'm + emit \ just to repeat the "l" |
|
0 0>= -1 0>= -1 0 d= 'n + emit |
|
5 0<> 0 0<> -1 0 d= 'o + emit |
|
1 1 = 2 3 = -1 0 d= 'p + emit |
|
-1 0 < 1 1 < -1 0 d= 'q + emit |
|
2 -1 > 1 1 > -1 0 d= 'r + emit |
|
1 1 <= 2 -1 <= -1 0 d= 's + emit |
|
1 1 >= -1 2 >= -1 0 d= 't + emit |
|
2 3 <> 1 1 <> -1 0 d= 'u + emit |
|
1 1 u= 2 3 u= -1 0 d= 'v + emit |
|
0 -2 u< 0 0 u< -1 0 d= 'w + emit |
|
-3 5 u> 0 0 u> -1 0 d= 'x + emit |
|
0 0 u<= -1 0 u<= -1 0 d= 'y + emit |
|
0 0 u>= 0 -1 u>= -1 0 d= 'z + emit |
|
2 3 u<> 0 0 u<> -1 0 d= '{ + emit |
|
\ dcomparisons |
|
0. d0= 1. d0= -1 0 d= 'j + emit |
|
-1. d0< 0. d0< -1 0 d= 'k + emit |
|
1. d0> 0. d0> -1 0 d= 'l + emit |
|
0. d0<= 1. d0<= -1 0 d= 'm + emit |
|
0. d0<= 1. d0<= -1 0 d= 'm + emit \ just to repeat the "l" |
|
0. d0>= -1. d0>= -1 0 d= 'n + emit |
|
5. d0<> 0. d0<> -1 0 d= 'o + emit |
|
1. 1. d= 2. 3. d= -1 0 d= 'p + emit |
|
-1. 0. d< 1. 1. d< -1 0 d= 'q + emit |
|
2. -1. d> 1. 1. d> -1 0 d= 'r + emit |
|
1. 1. d<= 2. -1. d<= -1 0 d= 's + emit |
|
1. 1. d>= -1. 2. d>= -1 0 d= 't + emit |
|
2. 3. d<> 1. 1. d<> -1 0 d= 'u + emit |
|
1. 1. du= 2. 3. du= -1 0 d= 'v + emit |
|
0. -2. du< 0. 0. du< -1 0 d= 'w + emit |
|
-3. 5. du> 0. 0. du> -1 0 d= 'x + emit |
|
0. 0. du<= -1. 0. du<= -1 0 d= 'y + emit |
|
0. 0. du>= 0. -1. du>= -1 0 d= 'z + emit |
|
2. 3. du<> 0. 0. du<> -1 0 d= '{ + emit |
|
0 0 1 within 0 0 0 within -1 0 d= 'B + emit |
|
\ !! useraddr |
|
\ !! up! |
|
sp@ s0 @ = 'C + emit |
|
sp@ -3 cells + sp! drop drop drop sp@ s0 @ = 'D + emit |
|
rp@ deeper-rp@ cell+ = 'E + emit |
|
rp!-test1 'E emit |
|
\ fp@ 1e fp@ float+ = 'G + emit \ !! fp@ |
|
0 1 >r 0 = r> 1 = -1 -1 d= 'G + emit |
|
rdrop-test 'G emit |
|
0 1 2>r 'I 2r> 0 1 d= + emit |
|
3 4 2>r 2r@ 2r> d= 'J + emit |
|
5 6 2>r 7 8 2>r 2rdrop 2r> 5 6 d= 'K + emit |
|
1 2 over 2 1 d= 1 -1 d= 'L + emit |
|
1 2 3 drop 1 2 d= 'M + emit |
|
1 2 swap 2 1 d= 'N + emit |
|
1 dup 1 1 d= 'O + emit |
|
1 2 3 rot 3 1 d= 2 -1 d= 'P + emit |
|
1 2 3 -rot 1 2 d= 3 -1 d= 'Q + emit |
|
1 2 3 nip 1 3 d= 'R + emit |
|
1 2 tuck 1 2 d= 2 -1 d= 'S + emit |
|
4 0 ?dup 4 0 d= 'T + emit |
|
5 1 ?dup 1 1 d= 5 -1 d= 'U + emit |
|
6 0 pick 6 6 d= 'V + emit |
|
1 2 3 4 2drop 1 2 d= 'W + emit |
|
7 1 2 2dup d= 7 -1 d= 'X + emit |
|
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 |
|
1 2 3 4 2swap 1 2 d= >r 3 4 d= r> -1 -1 d= 'Z + emit |
|
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 |
|
7 1 2 3 4 2nip 3 4 d= 7 -1 d= 'b + emit |
|
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 |
|
cr |
|
cellbuf @ 5 = 'b + emit |
|
9 cellbuf ! 5 cellbuf @ 5 9 d= 'c + emit |
|
-1 cellbuf +! cellbuf @ 8 = 'd + emit |
|
-1 cellbuf ! cellbuf c@ $ff = 'e + emit |
|
1 cellbuf c! cellbuf @ 1 <> 'f + emit |
|
3 4 cellbuf 2! cellbuf @ 4 = 'g + emit |
|
2 cellbuf ! cellbuf 2@ 3 2 d= 'h + emit |
|
9 cellbuf cell+ ! cellbuf 2@ 9 2 d= 'i + emit |
|
cellbuf 3 cells + @ 8 = 'j + emit |
|
s" ijk" drop char+ c@ emit |
|
s" ijk" drop 2 (chars) + c@ emit |
|
c" ijkl" count 3 /string type |
|
\ s" abc" 0 (f83find) 0= 'm + emit \ not in gforth-0.6.2 |
|
s" abc" 0 (listlfind) 0= 'n + emit |
|
s" abc" 0 (hashlfind) 0= 'o + emit |
|
s" abc" 0 (tablelfind) 0= 'p + emit |
|
s" dfskdfjsdl" 5 (hashkey1) 32 u< 'n + emit |
|
s" bcde " (parse-white) s" bcde" compare 'n + emit |
|
1 aligned 0 cell+ = 'p + emit |
|
1 faligned 0 float+ = 'q + emit |
|
threading-method 2 u< 'r + emit |
|
\ stdin key-file emit |
|
stdin key-file emit |
|
stdin key?-file 't + emit |
|
stderr drop 't emit |
|
form 2drop 'u emit |
|
cbuf 20 flush-icache |
|
\ (bye) |
|
s" true" (system) 0 0 d= 'w + emit |
|
s" ENVVAR" getenv s" bla" compare 'w + emit |
|
s" grep -q bla" w/o open-pipe 0= 'y + emit >r |
|
s" blabla" i write-file 0= 'z + emit r> close-pipe d0= 'B + emit |
|
777 time&date 2drop 2drop 2drop 777 = 'C + emit |
|
1 ms 'C emit |
|
100 allocate 0= 'E + emit ( addr) |
|
200 resize 0= 'F + emit ( addr2) |
|
free 0= 'G + emit |
|
1 strerror 2drop 'G emit |
|
1 strsignal 2drop 'H emit |
|
\ call-c |
|
s" prim" r/o open-file 0= 'J + emit >r |
|
cbuf 100 i (read-line) 0= 'K + emit drop 'L + emit drop |
|
i file-position 0= 'M + emit cellbuf 2! |
|
cbuf 10 i read-file 0= 'N + emit 10 = 'O + emit |
|
cellbuf 2@ i reposition-file 0= 'P + emit |
|
cbuf 10 + dup 10 i read-file 0= 'Q + emit cbuf 10 compare 'Q + emit |
|
i file-size 0= 'S + emit 2drop |
|
i file-eof? 'a + emit |
|
r> close-file 0= 'T + emit |
|
s" /tmp/gforth')(|&;test" w/o create-file 0= 'U + emit >r |
|
s" bla" i write-file 0= 'V + emit |
|
i flush-file 0= 'W + emit |
|
100. i resize-file 0= 'V + emit |
|
r> close-file 0= 'W + emit |
|
s" /tmp/gforth')(|&;test" s" /tmp/gforth'|&;test" rename-file 0= 'X + emit |
|
s" /tmp/gforth'|&;test" delete-file 0= 'Y + emit |
|
\ !! open-dir |
|
\ !! read-dir |
|
\ !! close-dir |
|
\ !! filename-match |
|
utime 2drop 'Y emit |
|
cputime 2drop 2drop 'Z emit |
|
\ !! all the FP stuff |
|
\ !! all the locals stuff |
|
\ !! syslib stuff |
|
\ !! ffcall stuff |
|
\ !! oldcall stuff |
|
\ compiler stuff |
|
['] emit @ cellbuf ! |
|
['] ;s threading-method 0= if @ then cellbuf >body ! |
|
cellbuf >body compile-prim1 'Y emit |
|
finish-code 'Z emit |
|
cellbuf execute 'a emit |
|
\ !! forget-dyncode |
|
cellbuf >body @ decompile-prim ['] ;s @ = 'c + emit |
cr |
cr |
depth (bye) ; |
depth (bye) ; |
|
|