MASTER LOAD BLOCK
1 22 thru Load basic system
|
MAIN ENTRY POINT execute-forth 55h b, push ebp 8Bh b, ECh b, mov ebp,esp 60h b, pusha 8Bh b, 7Dh b, 08h b, mov edi,[ebp+8] 8Bh b, 6Fh b, 00h b, mov ebp,[edi+0] (dstack_ptr) 83h b, EDh b, 08h b, sub ebp,8 8Bh b, 5Dh b, 04h b, mov ebx,[ebp+4] 8Bh b, 45h b, 08h b, mov eax,[ebp+8] FFh b, D0h b, call eax 83h b, C5h b, 04h b, add ebp,4 89h b, 5Dh b, 00h b, mov [ebp],ebx 89h b, 6Fh b, 00h b, mov [edi+0],ebp (dstack_ptr) 61h b, popa 5Dh b, pop ebp C3h b, ret |
IMPLEMENT compile, DIRECTLY
8Bh b, 47h b, 04h b, mov eax,[edi+4] ( here )
C6h b, 00h b, E8h b, mov [eax],E8h ( call xxxx )
2Bh b, D8h b, sub ebx,eax
83h b, EBh b, 05h b, sub ebx,5
89h b, 58h b, 01h b, mov [eax+1],ebx
8Dh b, 40h b, 05h b, lea eax,[eax+5]
89h b, 47h b, 04h b, mov [edi+4],eax ( here )
8Bh b, 5Dh b, 00h b, mov ebx,[ebp]
83h b, EDh b, 04h b, sub ebp,4
C3h b, ret
|
IMPLEMENT literal DIRECTLY
8Bh b, 47h b, 04h b, mov eax,[edi+4] ( here )
C7h b, 00h b, mov [eax],dword x
83h b, C5h b, 04h b, 89h b, | add ebp,4
C7h b, 40h b, 04h b, mov [eax+4],dword x | mov [ebp],ebx
5Dh b, 00h b, BBh b, 00h b, | mov ebx,x
89h b, 58h b, 07h b, mov [eax+7],ebx
8Dh b, 40h b, 0Bh b, lea eax,[eax+11]
89h b, 47h b, 04h b, mov [edi+4],eax
8Bh b, 5Dh b, 00h b, mov ebx,[ebp]
83h b, EDh b, 04h b, sub ebp,4
C3h b, ret
|
WORDS TO COMPILE BYTES AND CELLS
b, smudge 8Bh b, 47h b, 04h b, mov eax,[edi+4]
88h b, 18h b, mov [eax],bl
FFh b, 47h b, 04h b, inc [edi+4]
8Bh b, 5Dh b, 00h b, mov ebx,[ebp]
83h b, EDh b, 04h b, sub ebp,4
C3h b, ret
unsmudge
d, 8Bh b, 47h b, 04h b, mov eax,[edi+4]
89h b, 18h b, mov [eax],ebx
83h b, 47h b, 04h b, 04h b, add [edi+4],04h
8Bh b, 5Dh b, 00h b, mov ebx,[ebp]
83h b, EDh b, 04h b, sub ebp,4
C3h b, ret
|
CALL HANDLING macro DEFINITIONS
; C3h b, C3h b, ret
forth
|
STACK MANIPULATION macro DEFINITIONS
nip 83h b, EDh b, 04h b, ; sub ebp,4
swap 8Bh b, 45h b, 00h b, mov eax,[ebp]
89h b, 5Dh b, 00h b, mov [ebp],ebx
8Bh b, D8h b, ; mov ebx,eax
drop 8Bh b, 5Dh b, 00h b, mov ebx,[ebp]
nip ;
dup 83h b, C5h b, 04h b, add ebp,4
89h b, 5Dh b, 00h b, ; mov [ebp],ebx
over 8Bh b, 45h b, 00h b, mov eax,[ebp]
dup 8Bh b, D8h b, ; mov ebx,eax
forth
|
IN-PLACE ARITHMETIC macro DEFINITIONS
1+ 43h b, ; inc ebx
1- 4Bh b, ; dec ebx
2+ 83h b, C3h b, 02h b, ; add ebx,2
2- 83h b, EBh b, 02h b, ; sub ebx,2
4+ 83h b, C3h b, 04h b, ; add ebx,4
4- 83h b, EBh b, 04h b, ; sub ebx,4
2* D1h b, E3h b, ; sal ebx,1
2/ D1h b, FBh b, ; sar ebx,1
4* C1h b, E3h b, 02h b, ; sal ebx,2
4/ C1h b, FBh b, 02h b, ; sar ebx,2
negate F7h b, DBh b, ; neg ebx
forth
|
ADDITION AND SUBTRACTION macro DEFINITIONS
+ 03h b, 5Dh b, 00h b, add ebx,[ebp]
83h b, EDh b, 04h b, ; sub ebp,4
- 29h b, 5Dh b, 00h b, sub [ebp],ebx
drop ;
forth
|
MULTIPLY AND DIVIDE macro DEFINITIONS
* 0Fh b, AFh b, 5Dh b, 00h b, imul ebx,[ebp]
83h b, EDh b, 04h b, ; sub ebp,4
/mod 33h b, D2h b, xor edx,edx
8Bh b, 45h b, 00h b, mov eax,[ebp]
F7h b, FBh b, idiv ebx
8Bh b, D8h b, mov ebx,eax
89h b, 55h b, 00h b, ; mov [ebp],edx
*/ 83h b, EDh b, 08h b, sub ebp,8
8Bh b, 45h b, 04h b, mov eax,[ebp+4]
F7h b, 6Dh b, 08h b, imul [ebp+8]
F7h b, FBh b, idiv ebx
8Bh b, D8h b, ; mov ebx,eax forth
|
BITWISE macro DEFINITIONS
and 23h b, 5Dh b, 00h b, and ebx,[ebp]
83h b, EDh b, 04h b, ; sub ebp,4
or 0Bh b, 5Dh b, 00h b, or ebx,[ebp]
83h b, EDh b, 04h b, ; sub ebp,4
xor 33h b, 5Dh b, 00h b, xor ebx,[ebp]
83h b, EDh b, 04h b, ; sub ebp,4
invert F7h b, D3h b, ; not ebx
>ecx 89h b, D9h b, ; mov ecx,ebx
shl >ecx drop D3h b, E3h b, ; shl ebx,cl
shr >ecx drop D3h b, EBh b, ; shr ebx,cl
sar >ecx drop D3h b, FBh b, ; sar ebx,cl
forth
|
RETURN STACK RELATED macro DEFINITIONS
push 53h b, drop ; push ebx
pop dup 5Bh b, ; pop ebx
rdrop 59h b, ; pop ecx
rdrop-many 4* 03h b, E3h b, drop ; add esp,ebx
push-many 83h b, FBh b, 00h b, start: cmp ebx,0
7Eh b, 09h b, jle done
FFh b, 75h b, 00h b, push dword [ebp]
4Bh b, dec ebx
83h b, EDh b, 04h b, sub ebp,4
EBh b, F2h b, jmp start
drop ; done:
forth
|
MEMORY ACCESS macro DEFINITIONS
@ 8Bh b, 1Bh b, ; mov ebx,[ebx]
c@ 8Ah b, 1Bh b, mov bl,[ebx]
0Fh b, B6h b, DBh b, ; movzx ebx,bl
! 8Bh b, 45h b, 00h b, mov eax,[ebp]
89h b, 03h b, mov [ebx],eax
83h b, EDh b, 08h b, sub ebp,8
8Bh b, 5Dh b, 04h b, ; mov ebx,[ebp+4]
c! 8Ah b, 45h b, 00h b, mov al,[ebp]
88h b, 03h b, mov [ebx],al
83h b, EDh b, 08h b, sub ebp,8
8Bh b, 5Dh b, 04h b, ; mov ebx,[ebp+4] forth
|
COMPARISON TO ZERO macro DEFINITIONS
_compare1 83h b, FBh b, 00h b, cmp ebx,0
0Fh b, ; (first of of set?)
_compare2 b, FBh b, (second half of set?)
0Fh b, B6h b, DBh b, ; movzx ebx,bl
0= _compare1 94h _compare2 ;
0<> _compare1 95h _compare2 ;
0< _compare1 9Ch _compare2 ;
0> _compare1 9Fh _compare2 ;
0<= _compare1 9Eh _compare2 ;
0>= _compare1 9Dh _compare2 ;
forth
|
COMPARISON macro DEFINITIONS
_compare1 3Bh b, 5Dh b, 00h b, cmp [ebp],ebx
0Fh b, ; (first half of set?)
_compare2 b, FBh b, (second half of set?)
0Fh b, B6h b, DBh b, movzx ebx,bl
nip ;
= _compare1 94h _compare2 ;
<> _compare1 95h _compare2 ;
< _compare1 9Fh _compare2 ;
> _compare1 9Ch _compare2 ;
<= _compare1 9Dh _compare2 ;
>= _compare1 9Eh _compare2 ;
forth
|
CONTEXT RELATED
context-base dup 8Bh b, DFh b, ; mov ebx,edi
code-here context-base 4 + @ ;
data-here-ptr context-base 20 + ;
here data-here-ptr @ ;
dictionary-last context-base 16 + @ ;
last-code dictionary-last 4 + @ ;
last-data dictionary-last 8 + @ ;
last-name dictionary-last 24 + ;
|
CALLING EXTERNAL ROUTINES
function-table context-base 12 + @ ;
external-raw 4 * function-table + @ compile, ;
return-value dup 8Bh b, D8h b, ; mov ebx,eax
external over literal push-many external-raw
literal rdrop-many ;
Table of external entry points
load 1 0 external ;
. 1 1 external ;
key 0 2 external return-value ;
emit 1 3 external ;
library last-name 1 4 external ;
symbol last-name 1 5 external return-value ;
|
DEFINE NON-MACRO VERSIONS OF BASIC WORDS
nip nip ; swap swap ; drop drop ; dup dup ; over over ;
+ + ; - - ; * * ; /mod /mod ; */ */ ;
1+ 1+ ; 1- 1- ; 2+ 2+ ; 2- 2- ; 4+ 4+ ; 4- 4- ;
2* 2* ; 2/ 2/ ; 4* 4* ; 4/ 4/ ;
negate negate ;
and and ; or or ; xor xor ; invert invert ;
shl shl ; shr shr ; sar sar ;
@ @ ; c@ c@ ; ! ! ; c! c! ;
0= 0= ; 0<> 0<> ; 0< 0< ; 0> 0> ; 0<= 0<= ; 0>= 0>= ;
= = ; <> <> ; < < ; > > ; <= <= ; >= >= ;
|
FLOW CONTROL macro DEFINITIONS
if 8Bh b, CBh b, mov ecx,ebx drop
83h b, F9h b, 00h b, cmp ecx,0
0Fh b, 84h b, code-here 0 d, ; je +0
then code-here over 4+ - swap ! ; backpatch
else E9h b, code-here 0 d, jmp +0
swap then ;
begin code-here ;
until 8Bh b, CBh b, mov ecx,ebx drop
83h b, F9h b, 00h b, cmp ecx,0
0Fh b, 84h b, code-here 4+ - d, ; je +0
recurse; E9h b, last-code code-here 4+ - d, ; jmp +last-code
forth
|
MORE FLOW CONTROL macro DEFINITIONS
i dup 8Bh b, 1Ch b, 24h b, ; mov ebx,[esp]
i-limit dup 8Bh b, 5Ch b, 24h b, 04h b, ; mov ebx,[esp+4]
i+! 01h b, 1Ch b, 24h b, drop ; add [esp],ebx
while 8Bh b, CBh b, mov ecx,ebx drop
83h b, F9h b, 00h b, cmp ecx,0
0Fh b, 84h b, code-here 0 d, ; je +0
repeat E9h b, swap code-here 4+ - d, jmp +begining
dup push 4+ code-here swap - pop ! ; patch up
do swap push push begin i i-limit < while ;
+loop i+! repeat rdrop rdrop ;
loop 1 literal +loop ;
forth
|
CONVIENCE SHORTCUTS
+! dup push @ + pop ! ; NULL 0 ;
/ /mod nip ;
mod /mod drop ;
2dup over over ;
cr 10 emit ; bl 32 ; space bl emit ; spaces 0 do space loop ;
min 2dup < if drop else nip then ;
max 2dup < if nip else drop then ;
bit 1 swap shl ; mask bit or ;
import symbol compile, ;
cimport dup literal push-many symbol compile,
literal rdrop-many ;
CELL SIZE WORDS
cells 4* ; cell+ 4+ ; cell 4 ;
|
VARIABLES
goto, E9h b, code-here 4+ - d, ; jmp x
does>-hookup last-data literal ;
macro does> does>-hookup literal compile, code-here literal
code-here 17 + literal (HACK 17 instruction bytes)
goto, literal compile, ; ; forth
allot data-here-ptr +! ;
, here ! cell allot ;
variable 0 , does> ;
:constant , does> @ ;
|
RANDOM NUMBER GENERATOR (Knuth V2 pg 185)
seed 1 seed !
MM 2147483647 ; AA 48271 ; QQ 44488 ; RR 3399 ;
random-next seed @ QQ mod AA * seed @ RR QQ */ -
dup 0< if MM + then seed ! ;
random random-next seed @ MM */ ;
|
empty
|
empty
|
Linux SYSTEM CALL TESTS
libncurses.so library
flash 0 cimport ;
usleep 1 cimport ;
test1 3 begin 1- flash 50000 usleep
dup 0= until drop ;
test1
|
WINDOWS SYSTEM CALL TEST
USER32.DLL library
beep MessageBeep 0 push import ;
beep
|
X-WINDOWS CALLS libX11.so library
XOpenDisplay 1 cimport return-value ;
XCreateSimpleWindow 9 cimport return-value ;
XSelectInput 3 cimport ;
XCreateGC 4 cimport return-value ;
XMapWindow 2 cimport ;
XNextEvent 2 cimport ;
XCheckTypedEvent 3 cimport return-value ;
XAllocColor 3 cimport ;
XSetForeground 3 cimport ;
XFillRectangle 7 cimport ;
XFreeGC 2 cimport ;
XCloseDisplay 1 cimport ;
|
MORE X-WINDOWS CALLS libX11.so library
XDefaultScreen 1 cimport return-value ;
XRootWindow 2 cimport return-value ;
XBlackPixel 2 cimport return-value ;
XWhitePixel 2 cimport return-value ;
XDefaultColormap 2 cimport return-value ;
STRUCTURE ACCESS
event-type @ ;
xconfig-width 8 cells + @ ;
xconfig-height 9 cells + @ ;
|
X-WINDOWS MASKS
KeyPressMask 0 mask ;
KeyReleaseMask 1 mask ;
ButtonPressMask 2 mask ;
ButtonReleaseMask 3 mask ;
ExposureMask 15 mask ;
StructureNotifyMask 17 mask ;
X-WINDOWS EVENT TYPES
KeyPress 2 ;
KeyRelease 3 ;
ButtonPress 4 ;
ButtonRelease 5 ;
Expose 12 ;
ConfigureNotify 22 ;
|
X-WINDOWS INITIZATION
display screen root-window window black white gc
create-window
NULL XOpenDisplay display !
display @ XDefaultScreen screen !
display @ screen @ XRootWindow root-window !
display @ screen @ XBlackPixel black !
display @ screen @ XWhitePixel white !
display @ root-window @ 100 100 500 500 4 black @ white @
XCreateSimpleWindow window !
display @ window @ 0 ExposureMask KeyPressMask
ButtonPressMask StructureNotifyMask literal XSelectInput
display @ window @ 0 0 XCreateGC gc !
display @ window @ XMapWindow ;
close-window display @ gc @ XFreeGC
display @ XCloseDisplay ;
|
X-Windows Drawing pixel red-green blue-flags box push push push push display @ window @ gc @ pop pop pop pop XFillRectangle ; rgb 8 shl blue-flags ! 24 shl swap 8 shl or red-green ! display @ display @ screen @ XDefaultColormap pixel XAllocColor display @ gc @ pixel @ XSetForeground ; black 0 0 0 rgb ; white 255 255 255 rgb ; red 255 0 0 rgb ; orange 255 192 0 rgb ; yellow 255 255 0 rgb ; green 0 255 0 rgb ; cyan 0 255 255 rgb ; blue 0 0 255 rgb ; magenta 255 0 255 rgb ; |
X-WINDOWS event type handlers
event here literal ; 200 allot This is just a size guess
width height
handle-config event xconfig-width width !
event xconfig-height height ! 0 ;
handle-button 0 ;
handle-key 1 ; square 100 100 box ;
handle-expose
1000 0 do 256 random 256 random 256 random rgb
width @ 20 - random height @ 20 - random 20 20 box loop
0 0 width @ 2/ height @ 2/ black box
10 10 red square 20 20 orange square
30 30 yellow square 40 40 green square
50 50 cyan square 60 60 blue square
70 70 magenta square 80 80 white square
0 ;
|
X-WINDOWS EVENT LOOP
handle-event
dup KeyPress = if drop handle-key else
dup ButtonPress = if drop handle-button else
dup ConfigureNotify = if drop handle-config else
dup Expose = if drop handle-expose else
drop 0 then then then then ;
window-loop begin
display @ event XNextEvent
event event-type handle-event until ;
window-test create-window window-loop close-window ;
|
X-WINDOWS START BLOCK
27 33 thru
window-test
|
LOOP TEST BLOCK
row 10 0 do dup . i . 3 spaces loop cr ;
test 10 0 do i row loop ;
test
|
FACTORIAL
factorial2 dup 1 <= if ; then dup push * pop 1- recurse;
factorial 1 swap factorial2 drop ;
5 factorial .
EMIT TEST
one-key begin key dup emit 27 = until ;
|
PRIME NUMBER TEST
indivisible mod 0<> ;
part-prime dup 1 = if drop drop 1 else 2dup 1- part-prime
push indivisible pop and then ;
prime dup 1- part-prime ;
print-if-prime dup prime if . else drop then ;
primes 2 do i print-if-prime loop ;
1000 primes cr
|
VARIABLE TEST
x y
1 x ! 2 y ! x @ . y @ . cr
314159 pi :constant
pi . pi . cr
:pair , , does> dup cell+ @ swap @ ;
10 11 p :pair
p . . p . . cr
|
RANDOM TEST
test 400 0 do 10 random . loop ;
test
|