home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
High Voltage Shareware
/
high1.zip
/
high1
/
DIR24
/
FORTH035.ZIP
/
FORTH.ASM
< prev
next >
Wrap
Assembly Source File
|
1993-08-07
|
96KB
|
3,523 lines
Title _FORTH_32 '32 BIT FORTH FOR OS/2'
;
; FORTH/2 -- Copyright(C) 1992, BLUE STAR SYSTEMS, all rights reserved
; Produced in the United States of America
;
; This software is furnished under a license agreement or nondisclosure
; agreement. The software may be used or copied only in accordance with
; the terms of the agreement. No part of this program may be reproduced
; or transmitted in any form or by any means, electronic or mechanical,
; including photo-copying and recording, for any purpose without the
; express written permission of the author.
;
; The following paragraph does not apply in the United Kingdom or any
; country where such provisions are inconsistent with local law:
; BLUE STAR SYSTEMS OFFERS THIS PROGRAM "AS IS" WITHOUT WARRANTY OF
; ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
; IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
; Some states do not allow disclaimer of express or implied warranties in
; certain transactions, therefore, this statement may not apply to you.
;
; BLUE STAR SYSTEMS may have patents or pending patent applications covering
; the subject matter in this program. The furnishing of this program does
; not give you any license to these patents. You can send license inquiries,
; in writing, to BLUE STAR SYSTEMS, PO BOX 4043, Hammond, Indiana 46324
;
; Note: 16 Bit calls EAT STACK PARAMS
; 32 Bit calls LEAVE stack params
;
; Thanks to Larry Bank for his sample code in VIO32.ASM
; Thanks to Brian Mathewson for his $$$ and suggestions, and CODE
; Thanks to Michael Thompson (tommy@msc.cornell.edu) for PORTIO.ASM
;
.386
.model flat,syscall,os_os2
.code
Reserve_Size = 010000h ; Reserve 64k Of Memory for Dictionary
STACK_SIZE = 1000h ; Memory reserved for stack
STACK_UNDERFLOW = 1000h
RSTACK_SIZE = 1000h ; Return stack size for threads
EXTRN Dos32AllocMem:Near,Dos32Read:Near
EXTRN Dos32Beep:Near,Dos32SetFilePtr:Near
EXTRN Dos32CallNPipe:Near,Dos32ConnectNPipe:Near
EXTRN Dos32CreateNPipe:Near
EXTRN Dos32CreateThread:Near
EXTRN Dos32DevIOCtl:Near
EXTRN Dos32DisConnectNPipe:Near
EXTRN Dos32ExecPgm:Near
EXTRN Dos32Exit:Near
EXTRN Dos32GetDateTime:Near
EXTRN Dos32KillProcess:Near
EXTRN Dos32KillThread:Near
EXTRN Dos32LoadModule:Near,Dos32FreeModule:Near
EXTRN Dos32Open:Near,Dos32Close:Near
EXTRN Dos32PeekNPipe:Near
EXTRN Dos32QueryModuleHandle:Near
EXTRN Dos32QueryNPHState:Near,Dos32QueryNPipeInfo:Near
EXTRN Dos32QueryProcAddr:Near
EXTRN Dos32QueryProcType:Near
EXTRN Dos32ResumeThread:Near
EXTRN Dos32SetNPHState:Near
EXTRN Dos32Sleep:Near,Dos32StartSession:Near
EXTRN Dos32SuspendThread:Near
EXTRN Dos32TransactNPipe:Near
EXTRN Dos32WaitChild:Near
EXTRN Dos32WaitNPipe:Near
EXTRN Dos32WaitThread:Near
EXTRN Dos32Write:Near
EXTRN DosFlatToSel:near,DosSelToFlat:near
EXTRN KbdCharIn:far16,VIOwrtTTY:far16
EXTRN Dos32Shutdown:Near
EXTRN @inp:far16,@outp:far16
PULLFORTH MACRO
mov eax,[ebx]
add ebx,4
ENDM
PUSHFORTH MACRO
sub ebx,4
mov [ebx],eax
ENDM
COMPILES MACRO varg:VARARG
FOR arg, <varg>
mov al,arg
stosb
ENDM
ENDM
VocLinkOffset = 4 ; Offset from vocabulary of link
ContextSize = 16 ; Size of Context buffer
.stack 8192
.data
;
; Data returned from getkey...
;
ascii db 0
scancode db 0
status db 0
reserved db 0
shift_state dw 0
time_stamp dd 0
;
;---------------- I/O DOS Calls Only---------------
stdin equ 0
stdout equ 1
stderr equ 2
;---------------- Useful ---------------
cr equ 0dh
lf equ 0ah
crlf equ 0dh,0ah ;cr+lf
BEL equ 07h
NULL equ 0000h
SavedESP dd ?
Environment dd ?
CommandLine dd ?
FooBar dd ?
;********* Forth REGISTER USE:
;
; EBX - Numeric Stack pointer, growing downward from FStackBase
;
; EDI - Current CODE generating address
;
; All other variables my be used, and trashed, at ANY time....!
;
Message MACRO name:REQ,string:VARARG
&name&msg dd @f-($+4) ;; define a DWORD which gives size
FOR arg, <string>
DB arg ;; Store the byte(s)
ENDM
@@:
ENDM
MESSAGE Welcome, "FORTH/2 -- Version 0.35 ßeta ("
MESSAGE CopyRight, "Copyright(C) 1992, 1993 - BLUE STAR SYSTEMS, all rights reserved",CrLf,"Produced in the United States of America",CrLf,CrLf
MESSAGE Greet, "Type BYE to exit, WORDS to see word list.",CrLf
MESSAGE Break, "Breakpoint Encountered! ",CrLf
MESSAGE StackOver, "Stack Overflow!",07h,CrLf
MESSAGE StackUnder,"Stack Underflow!",07h,CrLf
MESSAGE IOerror, "I/O Error #"
MESSAGE StackLoad, "FORTH.INI should not change the stack",CrLf
MESSAGE Prompt, "Ok: "
MESSAGE CompileOnly "Not in compile mode!",CrLf
MESSAGE Semicolon "ERROR: Semicolon was expected",CrLf
MESSAGE LineNum "at line number: "
MESSAGE WHAT1 "What does ",022h
MESSAGE WHAT2 022h," mean? (type BYE to exit to OS/2) ",CrLf
MESSAGE DivByZero "DIVISION BY ZERO ATTEMPTED!",CrLf
MESSAGE NotCompiling "Only in compile mode!",CrLf
MESSAGE Huh " ?",CrLf
MESSAGE NotCreateWord "not a CREATE'd word!",CrLf
MESSAGE Register " EDI ESI EBP ESP EBX EDX ECX EAX",CrLf
CrLfStr dd 2
db 0dh,0ah
CrStr dd 1
db 0dh
SpStr dd 1
db 20h
UpperCaseTable db 000h,001h,002h,003h,004h,005h,006h,007h
db 008h,009h,00ah,00bh,00ch,00dh,00eh,00fh
db 010h,011h,012h,013h,014h,015h,016h,017h
db 018h,019h,01ah,01bh,01ch,01dh,01eh,01fh
db 020h,021h,022h,023h,024h,025h,026h,027h
db 028h,029h,02ah,02bh,02ch,02dh,02eh,02fh
db 030h,031h,032h,033h,034h,035h,036h,037h
db 038h,039h,03ah,03bh,03ch,03dh,03eh,03fh
db 040h,041h,042h,043h,044h,045h,046h,047h
db 048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
db 050h,051h,052h,053h,054h,055h,056h,057h
db 058h,059h,05ah,05bh,05ch,05dh,05eh,05fh
db 060h,041h,042h,043h,044h,045h,046h,047h
db 048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
db 050h,051h,052h,053h,054h,055h,056h,057h
db 058h,059h,05ah,07bh,07ch,07dh,07eh,07fh
db 080h,081h,082h,083h,084h,085h,086h,087h
db 088h,089h,08ah,08bh,08ch,08dh,08eh,08fh
db 090h,091h,092h,093h,094h,095h,096h,097h
db 098h,099h,09ah,09bh,09ch,09dh,09eh,09fh
db 0a0h,0a1h,0a2h,0a3h,0a4h,0a5h,0a6h,0a7h
db 0a8h,0a9h,0aah,0abh,0ach,0adh,0aeh,0afh
db 0b0h,0b1h,0b2h,0b3h,0b4h,0b5h,0b6h,0b7h
db 0b8h,0b9h,0bah,0bbh,0bch,0bdh,0beh,0bfh
db 0c0h,0c1h,0c2h,0c3h,0c4h,0c5h,0c6h,0c7h
db 0c8h,0c9h,0cah,0cbh,0cch,0cdh,0ceh,0cfh
db 0d0h,0d1h,0d2h,0d3h,0d4h,0d5h,0d6h,0d7h
db 0d8h,0d9h,0dah,0dbh,0dch,0ddh,0deh,0dfh
db 0e0h,0e1h,0e2h,0e3h,0e4h,0e5h,0e6h,0e7h
db 0e8h,0e9h,0eah,0ebh,0ech,0edh,0eeh,0efh
db 0f0h,0f1h,0f2h,0f3h,0f4h,0f5h,0f6h,0f7h
db 0f8h,0f9h,0fah,0fbh,0fch,0fdh,0feh,0ffh
WordScanTable db 020h,020h,020h,020h,020h,020h,020h,020h
db 020h,020h,020h,020h,020h,020h,020h,020h
db 020h,020h,020h,020h,020h,020h,020h,020h
db 020h,020h,020h,020h,020h,020h,020h,020h
db 020h,021h,022h,023h,024h,025h,026h,027h
db 028h,029h,02ah,02bh,02ch,02dh,02eh,02fh
db 030h,031h,032h,033h,034h,035h,036h,037h
db 038h,039h,03ah,03bh,03ch,03dh,03eh,03fh
db 040h,041h,042h,043h,044h,045h,046h,047h
db 048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
db 050h,051h,052h,053h,054h,055h,056h,057h
db 058h,059h,05ah,05bh,05ch,05dh,05eh,05fh
db 060h,061h,062h,063h,064h,065h,066h,067h
db 068h,069h,06ah,06bh,06ch,06dh,06eh,06fh
db 070h,071h,072h,073h,074h,075h,076h,077h
db 078h,079h,07ah,07bh,07ch,07dh,07eh,07fh
db 080h,081h,082h,083h,084h,085h,086h,087h
db 088h,089h,08ah,08bh,08ch,08dh,08eh,08fh
db 090h,091h,092h,093h,094h,095h,096h,097h
db 098h,099h,09ah,09bh,09ch,09dh,09eh,09fh
db 0a0h,0a1h,0a2h,0a3h,0a4h,0a5h,0a6h,0a7h
db 0a8h,0a9h,0aah,0abh,0ach,0adh,0aeh,0afh
db 0b0h,0b1h,0b2h,0b3h,0b4h,0b5h,0b6h,0b7h
db 0b8h,0b9h,0bah,0bbh,0bch,0bdh,0beh,0bfh
db 0c0h,0c1h,0c2h,0c3h,0c4h,0c5h,0c6h,0c7h
db 0c8h,0c9h,0cah,0cbh,0cch,0cdh,0ceh,0cfh
db 0d0h,0d1h,0d2h,0d3h,0d4h,0d5h,0d6h,0d7h
db 0d8h,0d9h,0dah,0dbh,0dch,0ddh,0deh,0dfh
db 0e0h,0e1h,0e2h,0e3h,0e4h,0e5h,0e6h,0e7h
db 0e8h,0e9h,0eah,0ebh,0ech,0edh,0eeh,0efh
db 0f0h,0f1h,0f2h,0f3h,0f4h,0f5h,0f6h,0f7h
db 0f8h,0f9h,0fah,0fbh,0fch,0fdh,0feh,0ffh
;
; Modified 4/21/93 to handle up to base 36!
;
ValueTable db 02ch dup(0ffh)
db 0feh,0fdh,0feh,0ffh ; skip , and .
db 0,1,2,3,4,5,6,7,8,9
db 007h dup(0ffh)
db 10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
db 27,28,29,30,31,32,33,34,35
db 006h dup(0ffh)
db 10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
db 27,28,29,30,31,32,33,34,35
db 085h dup(0ffh)
strbuffer db 104h dup(?) ; temporary string buffer
numbuffer db 104h dup(?) ; for number strings for debugging
number_fill db 30h ; '0'
table db '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
Debug dd 0 ; True if debugging
ExitCode dd 0 ; Exit code passed to OS/2 after BYE
CommandStr db 100h dup(?)
CommandLen EQU $-CommandStr
OurStack dd STACK_SIZE dup(?) ; should be big enough for a start
FStackBase dd STACK_UNDERFLOW dup(?) ; provide room for underflow
StackBase dd FStackBase ; Holds base address of stack
TickAbort dd VecAbort ; Pointer to code for ABORT
CodeSpace dd 0 ; Ptr to next avail. dictionary location
NewWord dd ? ; Header of very last word defined
CompileMode dd 0 ; Non-zero if compiling
LineNumber dd 0 ; Line number of file being loaded
number_base dd 10 ; Decimal
OkVal dd 0
Value dd 0
Negative dd 0
DPL dd 0
SysTo dd 0 ; TO variables: 0=fetch; 1=store; -1=add
OutPos dd 0 ; Output position
CharPerLine dd 80
TickExecute dd _DoExecute
FoundAddr dd 0
Current dd ForthLink ; Vocabulary where definitions are created
Context dd ForthLink,SysLink, ContextSize dup (0)
; Context is where searching dictionary starts
ForthLink dd 0,LastForthWord,0 ; FORTH vocabulary pointer
SysLink dd 0,LastHeader,ForthLink ; SYSTEM vocabulary pointer
Voc_link dd SysLink ; Pointer to last vocabulary created
FopenAction dd 0
FopenHandle dd 0
FopenName db "FORTH.INI",0
db 80 dup (?)
FileBufferSize = 16384
FileBuffer db FileBufferSize dup (?)
Date1 equ <>
Date1 CatStr <">, @Date, <">
Paren1 equ <>
Paren1 CatStr <(>
MESSAGE Version,"Compiled: ",Date1,")",CrLf
InputBufferSize = 1024
InputSpace db InputBufferSize dup (?)
InputBuffer dd Offset InputSpace
InputCount dd 0
InputOffset dd 0
LastWordEnd dd 0
;
; END OF FORTH SOURCE.....
;
.CODE
BREAK MACRO
Call Do_Breakpoint
ENDM
IMMEDIATE EQU 1
COMPILEONLY EQU 2
HIDDEN EQU 4
_HEADER STRUC
Prev DWORD ?
Flags DWORD ? ; Not immediate, function call
CodePointer DWORD ?
NameSize DWORD ?
ThisName BYTE 20h dup (?)
_HEADER ENDS
LASTHEADER = 0
CodeDef MACRO ThisName:Req,Flg := <0>
LOCAL ThisOne,ThisCode
ThisOne _HEADER { LastHeader, (Flg), ThisCode,@SIZESTR(ThisName)-2,ThisName }
LASTHEADER = ThisOne
ThisCode:
ENDM
.code
;*****************************************
;* *
;* CORE VOCABULARY *
;* *
;*****************************************
CodeDef '!'
Store: mov edx,[ebx ] ; value addr .... poke
mov eax,[ebx+4]
mov [edx],eax
add ebx,8 ; pop both values
ret
CodeDef "'" ; Tick, return address of next word
Tick: mov eax,' '
PushForth
Call _Word
Call _Find
PullForth
and eax,eax
jz @f
ret
@@: lea edx,What1Msg
call WriteStr
call _Count
call _Type
lea edx,What2Msg
call WriteStr
jmp Abort
_Comment _Header { LastHeader, Immediate, Do_Comment, 1, '(' }
LastHeader = _Comment
Do_Comment: mov esi,InputBuffer
add esi,InputOffset
mov ecx,InputCount
sub ecx,InputOffset
jbe CommentDone
@@: lodsb
cmp al,')'
loopne @b
CommentDone: sub esi,Inputbuffer
mov inputoffset,esi
ret
CodeDef '*'
PULLFORTH
imul eax,[ebx]
mov [ebx],eax
ret
CodeDef '*/' ; ( a b c -- a*b/c )
mov eax,[ebx+8]
imul DWORD PTR[ebx+4]
cmp edx,[ebx]
jg DivByZero
div DWORD PTR[ebx]
add ebx,8
mov [ebx],eax
ret
CodeDef '*/MOD' ; ( a b c -- remainder quotient )
mov eax,[ebx+8]
imul DWORD PTR[ebx+4]
cmp edx,[ebx]
jg DivByZero
idiv DWORD PTR[ebx]
add ebx,4
mov [ebx],eax ; Store Quotient
mov [ebx+4],edx ; Store Remainder
ret
CodeDef '+'
PULLFORTH
add [ebx],eax
ret
CodeDef '+!' ; ( n addr -- ) adds n to addr
PlusStore: mov edx,[ebx ]
mov eax,[ebx+4]
add [edx],eax
add ebx,8
ret
CodeDef ',' ; ( Compiles a CELL )
Comma: cld
PULLFORTH
stosd
mov CodeSpace,EDI
ret
CodeDef '-' ; ( n1 n2 -- n1-n2 )
PULLFORTH
sub [ebx],eax
ret
CodeDef '."',3 ; Immediate, Compile Only
Call S_Quote
lea eax,_Type
PushForth
call Do_CompileCall
ret
CodeDef '/'
PULLFORTH
or eax,eax
jz DivByZero
xchg eax,[ebx]
CDQ ; convert AX to DX:AX
idiv DWORD PTR[ebx]
mov [ebx],eax
ret
CodeDef '/MOD' ; ( a b -- {a mod b} {a div b} )
mov eax,[ebx] ; one up on the stack
or eax,eax
jz DivByZero
xchg eax,[ebx+4]
CDQ ; convert AX to DX:AX
idiv DWORD PTR[ebx+4]
mov [ebx],eax ; Store quotient
mov [ebx+4],edx ; Store remainder
ret
CodeDef '0<'
xor eax,eax
jmp LessThan
CodeDef '0=' ; returns true if A = 0
xor eax,eax
cmp eax,[ebx]
jnz @f
not eax
@@: mov [ebx],eax
ret
CodeDef '1+'
mov eax,1
add [ebx],eax
ret
CodeDef '1-'
mov eax,1
sub [ebx],eax
ret
CodeDef '2!' ; ( x1 x2 a-addr -- )
mov edx,[ebx]
mov eax,[ebx+4]
mov [edx+4],eax
mov eax,[ebx+8]
mov [edx],eax
add ebx,12
ret
CodeDef '2*'
shl DWORD PTR[ebx],1
ret
CodeDef '2/'
sar DWORD PTR[ebx],1 ; MAW - ANSforth Fix 6/8/93
ret
CodeDef '2@'
mov esi,[ebx]
lodsd
mov [ebx],eax
lodsd
PUSHFORTH
ret
CodeDef '2DROP'
add ebx,8
ret
CodeDef '2DUP'
mov eax,[ebx+4]
mov edx,[ebx]
PushForth
sub ebx,4
mov [ebx],edx
ret
CodeDef '2OVER'
mov eax,[ebx+12]
mov ecx,[ebx+8]
sub ebx,8
mov [ebx],ecx
mov [ebx+4],eax
ret
CodeDef '2SWAP'
mov ecx,[ebx]
mov edx,[ebx+4]
mov eax,[ebx+8]
mov [ebx],eax
mov eax,[ebx+12]
mov [ebx+4],eax
mov [ebx+8],ecx
mov [ebx+12],edx
ret
CodeDef ':'
Do_Colon: mov eax,CompileMode
or eax,eax
jnz NoSemicolon
mov EDI,CodeSpace
mov NewWord,EDI
cld
mov eax,Current
mov eax,[eax+VocLinkOffset]
stosd ; Store the pointer to previous
mov eax,0 ; Flags to store
stosd ; Store the Words flags
mov eax,0 ; Execution Address (0 for now)
push edi ; save this address for a while
stosd ; Store the code address
mov edx,edi
mov eax,' '
PushForth
Call _Word ; Get string, stored at EDI!
mov edi,LastWordEnd ; Get the end of the string
Call ToUpper ; (Uses address from forth stack)
pop eax ; Get the place to stuff code address
mov edi,eax ; Fix so headers are always
add edi,024h ; the same size
mov [eax],edi ; Update the code address
mov CompileMode,1 ; We are now in compile mode
ret ; done for now
NoSemicolon: lea edx,SemicolonMsg
call WriteStr
call WriteLineNum
jmp Abort
CodeDef ';',3
Do_SemiColon:
call CompileCheck ; finish a definition
call Do_CompileRet ; update codespace
mov CodeSpace,EDI
mov eax,NewWord ; update the dictionary
mov edx,Current
mov [edx+VocLinkOffset],eax ; update Current vocab ptr
mov CompileMode,0 ; back out of compile mode
ret
Do_CompileRet: ; compiles a RET instruction
mov al,0C3h
stosb
ret
CodeDef '<' ; i.e. 0 0 <
pullforth ; eax = stack top 0
LessThan: cmp eax,[ebx] ; subtract 0 --> -1 (carry set)
mov eax,0 ; eax = 0
jle @f
dec eax
@@: mov [ebx],eax
ret
CodeDef '=' ; returns true if A = B
pullforth
cmp eax,[ebx]
mov eax,0
jnz @f
not eax
@@: mov [ebx],eax
ret
CodeDef '>' ; i.e. 9 4 >
pullforth ; eax = stack top 4
GreaterThan: cmp eax,[ebx] ; subtract 9 --> -5 (carry set)
mov eax,0 ; eax = 0
jge @f
dec eax
@@: mov [ebx],eax
ret
CodeDef '>BODY' ; ( xt -- a-addr )
PullForth ; do an execute
cmp dword ptr[eax],0F8EF60E8h
jnz @f
jmp eax ; Jump to address specified
@@: lea edx,NotCreateWordMsg
call WriteStr
jmp Abort
CodeDef '>IN' ; Address of offset into buffer
lea eax,InputOffset
pushForth
ret
CodeDef '>R' ; moves top of stack to return stack
pop edx ; our return address
PULLFORTH
push eax ; push number onto return stack
push edx ; restore return address and push on stack
ret
CodeDef '?DUP' ; Duplicates if true
mov eax,[ebx]
or eax,eax
jz @f
PushForth
@@: ret
CodeDef '@'
Fetch: mov eax,[ebx ]
mov eax,[eax ]
mov [ebx ],eax
ret
CodeDef 'ABS' ; ( a -- |a| )
mov eax,[ebx]
and eax,eax
jns @f
neg eax
mov [ebx],eax
@@: ret
CodeDef 'ACCEPT' ; ( c-addr n1 -- n2 ) Get a string from
; standard input, using READ
_Accept: mov edx,[ebx+4] ; Buffer address in EDX
mov eax,[ebx] ; Buffer size in eax
add ebx,4 ; consume 1 param, replace second
pushad ; save all the registers
push ebx ; Return parameter is bytes read
push eax ; Size of buffer
push edx ; Buffer area
pushd STDIN
call Dos32Read
add esp,16
or eax,eax
jnz IOerror
popad
ret
CodeDef 'ALIGN' ; ( -- )
sub ebx,4
mov [ebx],edi
call Aligned
mov edi,[ebx]
add ebx,4
mov CodeSpace,edi
ret
CodeDef 'ALIGNED' ; ( addr -- a-addr )
Aligned: mov eax,[ebx]
and eax,3
sub eax,4
neg eax
and eax,3
add [ebx],eax
ret
CodeDef 'ALLOT' ; add N bytes to the latest entry
Allot: PULLFORTH
add EDI,EAX
mov CodeSpace,EDI
ret
CodeDef 'AND'
PULLFORTH
AND [ebx],eax
ret
CodeDef 'BASE'
lea eax,Number_Base
PUSHFORTH
ret
CodeDef 'BL'
mov eax,' '
PUSHFORTH
ret
CodeDef 'C!'
mov edx,[ebx ] ; value addr .... poke
mov eax,[ebx+4]
mov [edx],al
add ebx,8 ; pop both values
ret
CodeDef 'C,'
cld
PULLFORTH
stosb
mov CodeSpace,EDI
ret
CodeDef 'C@'
mov eax,[ebx ]
mov eax,[eax ]
and eax,00ffh
mov [ebx ],eax
ret
CodeDef 'CELL+'
mov eax,[ebx]
add eax,4
mov [ebx],eax
ret
CodeDef 'CELLS' ; multiplies by word size, 4
WTimes: shl DWORD PTR [ebx],2
ret
CodeDef 'CHAR' ; ( "name" -- char )
DoChar: mov eax,' '
PushForth
call _Word
mov eax,[ebx]
xor ecx,ecx
mov cl,[eax+4]
mov [ebx],ecx
ret
CodeDef 'CHAR+'
inc dword ptr[ebx]
ret
CodeDef 'CHARS'
ret
CodeDef 'CONSTANT' ; Declare a constant
Do_Constant: mov EDI,CodeSpace
mov NewWord,EDI ; Save start of word
cld
mov eax,Current
mov eax,[eax+VocLinkOffset]
stosd ; Store the pointer to previous
mov eax,0 ; Flags to store
stosd ; Store the Words flags
mov eax,0 ; Execution Address (0 for now)
push edi ; save this address for a while
stosd ; Store the code address
mov edx,edi
mov eax,' '
PushForth
Call _Word ; Get string, stored at EDI!
mov edi,LastWordEnd ; Get the end of the string
Call ToUpper ; (Uses address from forth stack)
pop eax ; Get the place to stuff code address
mov [eax],edi ; Update the code address
mov al,0E8h ; Call ABSOLUTE
stosb
lea eax,DoesConstant ; Address of DoesConst routine
sub eax,EDI ; subtract current EIP
sub eax,4 ; subtract 4 for upcoming offset
STOSD
PULLFORTH ; Store the constant
STOSD
mov eax,NewWord ; update the dictionary
mov edx,Current
mov [edx+VocLinkOffset],eax
mov CodeSpace,EDI
ret ; done for now
DoesConstant: pop eax
mov eax,[eax]
PUSHFORTH
ret
CodeDef 'CR'
DoCr: lea edx,CrLfStr ; Write a CR/LF pair
call WriteStr
xor eax,eax
mov DWORD PTR OutPos,eax
ret
CodeDef 'CREATE' ; Creates a 0 byte variable
Create: mov EDI,CodeSpace
mov NewWord,EDI ; Save start of word
cld
mov eax,Current
mov eax,[eax+VocLinkOffset]
stosd ; Store the pointer to previous
mov eax,0 ; Flags to store
stosd ; Store the Words flags
mov eax,0 ; Execution Address (0 for now)
push edi ; save this address for a while
stosd ; Store the code address
mov edx,edi
mov eax,' '
PushForth
Call _Word ; Get string, stored at EDI!
mov edi,LastWordEnd ; Get the end of the string
Call ToUpper ; (Uses address from forth stack)
pop eax ; Get the place to stuff code address
mov [eax],edi ; Update the code address
mov al,0E8h ; Call ABSOLUTE
stosb
lea eax,DoesVariable ; Address of DoesConst routine
sub eax,EDI ; subtract current EIP
sub eax,4 ; subtract 4 for upcoming offset
stosd
mov CodeSpace,EDI
mov eax,NewWord ; update the dictionary
mov edx,Current
mov [edx+VocLinkOffset],eax
ret ; done for now
CodeDef 'COUNT' ; ( addr -- addr+4 [addr] )
_Count: mov edx,[ebx]
xor eax,eax
mov eax,[edx]
add DWORD PTR [ebx],4
PushForth
ret
CodeDef 'DECIMAL'
mov eax,10
mov Number_Base,eax
ret
CodeDef 'DEPTH'
mov eax,StackBase
sub eax,ebx ; Forth Stack depth in EAX
clc
shr eax,2 ; divide by entry size
PUSHFORTH
ret
CodeDef 'DROP'
Drop: add ebx,4 ; Drop Stack top
ret
CodeDef 'DUP'
mov eax,[ebx]
PUSHFORTH
ret
CodeDef 'EMIT' ; Quite large, isn't it?
Do_Emit: push ebp
push edi
push esi
push edx
push ecx
mov eax,esp ; save current ss, esp
push ss ; for return from 16-bit land
push eax
mov ecx,OutPos
inc ecx
mov OutPos,ecx
PULLFORTH
push eax
mov eax,esp ; character stored at [EAX]
call DosFlatToSel
push eax ; address of string
pushw 1 ; length of string
pushw 0 ; vio handle (0 = default)
mov eax,esp ; convert stack so 16-bit can use it
ror eax,16
shl eax,3
or al,7 ; convert to ring-3 tiled segment
mov ss,eax
jmp far ptr Do_Emit16
Do_Emit2 label far
movzx eax,ax ; convert return code to 32-bit
; Restore 32-bit SS:ESP - it is on top of stack.
movzx esp,sp ; make sure that esp is correct
lss esp,[esp]
pop ecx
pop edx
pop esi
pop edi
pop ebp
ret
CodeDef '<EXECUTE>' ; The REAL execute
_DoExecute: PullForth
jmp eax
CodeDef "'EXECUTE" ; Gives address of vector
lea eax,TickExecute
PushForth
ret
CodeDef 'EXECUTE' ; ( addr -- )
_Execute: mov eax,TickExecute
jmp eax ; Jump to address specified
CodeDef 'FIND' ; ( c-addr -- c-addr 0 | xt 1 )
_Find: mov edx,[ebx]
call LookFor
mov eax,FoundAddr
or eax,eax
jz FindDone
mov edx,[eax].CodePointer
mov [ebx],edx
mov edx,[eax].Flags
and edx,IMMEDIATE
jnz FindImm
mov eax,-1
jmp FindDone
FindImm: mov eax,1
FindDone: PushForth
ret
CodeDef 'FILL' ; ( addr n b -- ) fills n bytes at addr with b
mov eax,[ebx+4]
cmp eax,1 ; not defined for n < 1
jl @f
push edi
mov ecx,eax
mov eax,[ebx]
mov edi,[ebx+8]
rep stosb
pop edi
@@: add ebx,12
ret
CodeDef 'HERE'
mov eax,EDI
PushForth
ret
CodeDef 'I' ; copies number from return stack to top of stack
mov eax,[esp+4] ; Get the data
PUSHFORTH
ret
CodeDef 'IMMEDIATE'
mov eax,Current
mov eax,[eax+VocLinkOffset]
or [EAX].Flags,Immediate
ret
CodeDef 'INVERT' ; 1s complement
not dword ptr[ebx]
ret
CodeDef 'J' ; 1 loop up
mov eax,[esp+12] ; return, index, limit, index
PushForth
ret
CodeDef 'KEY'
mov eax,0
PushForth
call Do_Getkey
ret
CodeDef 'KEYNOWAIT'
mov eax,1
PushForth
call Do_Getkey
ret
; CodeDef '(KEY)' ; New version of KEY
Do_GetKey: PUSHAD
mov eax,esp ; save current ss, esp
push ss ; for return from 16-bit land
push eax
lea eax,ascii
mov word ptr [eax],0
call DosFlatToSel
push eax ; 8 bytes of parameters
PullForth
and eax,1
push ax ; Wait flag, etc.
mov eax,0
push ax ; Handle 0
mov eax,esp ; convert stack so 16-bit can use it
ror eax,16
shl eax,3
or al,7 ; convert to ring-3 tiled segment
mov ss,eax
jmp far ptr Do_GetKey16
Do_GetKey2 label far ; Restore 32-bit SS:ESP - it is on top of stack.
movzx esp,sp ; make sure that esp is correct
lss esp,[esp]
POPAD
xor eax,eax
mov ax,word ptr[ascii]
mov [ebx],eax ; Replace stack contents
ret
CodeDef 'LITERAL',3
_Literal: cld ; mov eax,literal
mov al,0b8h
stosb
PULLFORTH
stosd
mov al,083h ; sub ebx,4
stosb
mov al,0ebh
stosb
mov al,004h
stosb
mov al,089h ; mov [ebx],eax
stosb
mov al,003h
stosb
ret
CodeDef 'LSHIFT' ; ( n1 n2 -- n3 ) Shift n1 left n2 times
mov ecx,[ebx]
add ebx,4
shl DWORD PTR [ebx],cl
ret
CodeDef 'M*' ; ( n1 n2 -- d )
mov eax,[ebx+4]
imul DWORD PTR[ebx]
mov [ebx],edx
mov [ebx+4],eax
ret
CodeDef 'MAX' ; ( a b -- max )
PullForth
cmp eax,[ebx]
jl @f
mov [ebx],eax
@@: ret
CodeDef 'MIN' ; ( a b -- min )
PullForth
cmp eax,[ebx]
jg @f
mov [ebx],eax
@@: ret
CodeDef 'MOD'
PULLFORTH
or eax,eax
jz DivByZero
xchg eax,[ebx]
CDQ ; convert AX to DX:AX
idiv DWORD PTR[ebx]
mov [ebx],edx ; put MODULUS on stack
ret
CodeDef 'MOVE' ; ( addr1 addr2 u -- )
mov eax,[ebx+8]
cmp eax,[ebx+4]
ja Cmove
add eax,[ebx]
cmp eax,[ebx+4] ; cmp addr1+u,addr2
jg CmoveBack
jmp Cmove
CodeDef 'NEGATE' ; ( a -- -a )
neg DWORD PTR[ebx]
ret
CodeDef 'OR'
PULLFORTH
OR [ebx],eax
ret
CodeDef 'OVER'
mov eax,[ebx+4] ; duplicate one entry down...
PUSHFORTH
ret
CodeDef 'QUIT'
Quit: mov esp,SavedESP
call StackCheck
call Prompt
Call Query
call Interpret
jmp Quit
CodeDef 'R>' ; moves number from return stack to top of stack
pop edx ; our return address
pop eax ; number we want
push edx ; restore return address and push on stack
PUSHFORTH
ret
CodeDef 'R@' ; Copies contents of return stack
mov eax,[esp+4]
PushForth
ret
CodeDef 'RECURSE',3 ; Call the NEW word
Call CompileCheck
mov eax,NewWord
mov eax,[eax].codepointer
PushForth
Call Do_CompileCall
ret
CodeDef 'ROT'
mov eax,[ebx] ; take top, move it down 2 levels
xchg eax,[ebx+4]
xchg eax,[ebx+8]
mov [ebx],eax
ret
CodeDef 'RSHIFT' ; ( n1 n2 -- n3 ) Shift n1 left n2 times
mov ecx,[ebx]
add ebx,4
shr DWORD PTR[ebx],cl
ret
CodeDef 'S"',3 ; Generates an INLINE string
S_Quote: Call CompileCheck
lea eax,Inline_String
PushForth
Call Do_CompileCall
mov eax,'"' ; get string, stored HERE!
PushForth
Call _Word ; Get string, stored at EDI!
mov edi,LastWordEnd ; Get the end of the string
PullForth
ret
CodeDef 'S>D' ; ( n -- d )
xor eax,eax
mov edx,[ebx]
or edx,edx
js S2D1
PUSHFORTH
ret
S2D1: dec eax
PUSHFORTH
ret
CodeDef 'SOURCE' ; Returns input buffer address and count
mov eax,InputBuffer
PushForth
mov eax,InputCount
PushForth
ret
CodeDef 'STATE'
lea eax,CompileMode
PUSHFORTH
ret
CodeDef 'SPACE'
mov eax,' '
PushForth
Call Do_Emit
ret
CodeDef 'SPACES'
PullForth
mov ecx,eax
@@: mov eax,' '
PushForth
Call Do_Emit
Loop @b
ret
CodeDef 'SWAP'
mov eax,[ebx ]
mov edx,[ebx+4]
mov [ebx ],edx
mov [ebx+4],eax
ret
CodeDef 'TYPE' ; ( addr +n -- )
_Type: pushad
xor eax,eax ; used as "actual count" storage
push eax
mov eax,esp ; push the address of the previous push
push eax
mov eax,[ebx] ; push the string length
add OutPos,eax ; update output position
push eax
mov eax,[ebx+4] ; push the string address
push eax
pushd stdout ; push the handle to write to
call Dos32Write ; do the write.
add esp,20 ; set the stack back to semi-normal
popad
add ebx,8 ; Drop the 2 forth stack entries
ret
CodeDef 'U<' ; unsigned comparison
PullForth
cmp eax,[ebx]
mov eax,0
jbe @f
dec eax
@@: mov [ebx],eax
ret
CodeDef 'UM*' ; ( u1 u2 -- ud )
mov eax,[ebx+4]
mul DWORD PTR[ebx]
mov [ebx],edx
mov [ebx+4],eax
ret
CodeDef 'UM/MOD' ; ( ud u1 -- u2 u3 )
mov ecx,[ebx]
sub ebx,4
mov edx,[ebx]
mov eax,[ebx+4]
cmp edx,ecx
jae ummod1
div ecx
jmp ummod9
ummod1: xor eax,eax
mov edx,eax
ummod9: mov [ebx+4],edx
mov [ebx],eax
ret
CodeDef 'VARIABLE' ; Declare a variable
call Create
xor eax,eax
mov [edi],eax ; initialize to 0
mov eax,4
PUSHFORTH
call Allot
ret
CodeDef 'WORD' ; (char -- c-addr)
; Pull a string from between delimiters
; in InputBuffer
_Word: cld ; Count UP
push edi ; Push destination, we'll need it
xor eax,eax
stosd ; Put a 0 in the count
PullForth
Push EBX
lea EBX,WordScanTable
mov edx,eax ; Delimiter in dl
mov esi,InputOffset
mov ecx,InputCount
sub ecx,esi ; bump down count
jle _WordDone
add esi,InputBuffer
@@: or ecx,ecx ; If we are out of characters, exit
jz _WordDone
lodsb ; skip leading matches
xlat
dec ecx
cmp dl,al
jz @b
@@: stosb ; process non-matches
or ecx,ecx
jz _WordDone
lodsb
xlat
dec ecx
cmp dl,al
jnz @b
_WordDone: mov eax,esi
mov esi,InputBuffer
sub eax,esi ; eax now has the NEW offset
mov InputOffset,eax ; update value
mov ecx,edi ; stuff a non-counted space after text
xor eax,eax
stosd
mov eax,ecx
mov LastWordEnd,edi
pop ebx
pop edi ; original value of EDI
sub eax,edi ; how many bytes did we use?
sub eax,4 ; adjust for count bytes
mov [edi],eax
mov eax,edi ; address of string now in eax
PushForth
ret
CodeDef 'XOR'
PULLFORTH
XOR [ebx],eax
ret
CodeDef '[',Immediate ; This must be an IMMEDIATE word
mov CompileMode,0
ret
CodeDef "[']",Immediate
call CompileCheck
call Tick
call _Literal
ret
CodeDef '[CHAR]',Immediate
call CompileCheck
call DoChar
call _Literal
ret
CodeDef ']'
mov CompileMode,1
ret
;*****************************************
;* *
;* CORE EXTENSIONS *
;* *
;*****************************************
CodeDef '#TIB'
lea eax,InputCount
PushForth
ret
CodeDef 'SPAN'
lea eax,InputCount
PushForth
ret
CodeDef 'TIB'
lea eax,InputBuffer
PushForth
ret
CodeDef '\',IMMEDIATE ; Single line comment
cld ; Count UP
mov esi,InputOffset
mov ecx,InputCount
sub ecx,esi ; bump down count
jle _CommentDone
add esi,InputBuffer
@@: lodsb
cmp al,CR
loopne @b
_CommentDone: mov eax,esi
sub eax,InputBuffer
mov InputOffset,eax ; update value
ret
CodeDef 'QUERY' ; ( -- ) Get a line of text
Query: lea eax,InputSpace
mov InputBuffer,eax
PushForth
mov eax,InputBufferSize
PushForth
call _Accept
PullForth
mov InputCount,eax
xor eax,eax
mov InputOffset,eax
ret
;*****************************************
;* *
;* UTILITY ROUTINES *
;* *
;*****************************************
CodeDef '="' ; ( addr1 addr2 -- f )
EqualStr: push esi
push edx
push ecx
mov esi,[ebx]
add ebx,4
mov edx,[ebx]
push ebx ; Save STACK, we're using EBX
lea ebx,UpperCaseTable
cld
lodsd ; Length of string1 in eax
cmp eax,[edx] ; compare string lengths
jnz NotEqual
add edx,4 ; bump String2 pointer
mov ecx,eax ; put the counter in ECX, for LOOP
EqualStr1: lodsb
xlat
xchg ah,al
mov al,[edx]
xlat
inc edx
cmp al,ah
jnz NotEqual
loop EqualStr1
mov eax,0ffffffffh ; strings match, return true
jmp @f
NotEqual: mov eax,0
@@: pop ebx
mov [ebx],eax
pop ecx
pop edx
pop esi
ret
LookFor: pushad
lea ecx,Context ; look for [EDX]
mov FoundAddr,0
LookFor1: mov esi,[ecx]
or esi,esi
jz LookFor_Done
add esi,VocLinkOffset
LookFor2: mov esi,[esi].Prev ; go backwards in the chain
or esi,esi
jz LookFor3
mov eax,[esi].NameSize
and eax,eax
jz LookFor3
push esi ; save edx
lea esi,[esi].NameSize
mov eax,edx
PushForth
mov eax,esi
PushForth
call EqualStr
PullForth
pop esi
and eax,eax
jz LookFor2
mov FoundAddr,esi ; put the address in the output
LookFor_Done: popad
ret
LookFor3: add ecx,4
jmp LookFor1
ToUpper: PullForth ; (c-addr -- )
pushad ; Converts to upper in place
cld
mov esi,eax
lodsd
mov ecx,eax
or ecx,ecx
jz ToUpper9
lea ebx,uppercaseTable
mov edi,esi
@@: lodsb
xlat
stosb
loop @b
ToUpper9: popad
ret
DoesVariable: pop eax
PUSHFORTH
ret
CodeDef 'NUMBER?' ; ( addr --
; value TRUE (ok value)
; addr FALSE ( bad value )
_NumberQ: PullForth
pushad ; save ALL registers
xor edx,edx
mov Value,edx
mov DPL,edx
inc edx
mov Negative,edx ; NOT negative
lea ebx,ValueTable
xor edi,edi ; edi will hold result
mov esi,eax
lodsd
mov ecx,eax ; ecx is number of bytes left
or ecx,ecx
jz _NumberQ9
_NumberQ1: xor eax,eax
lodsb
xlat
cmp al,0ffh ; test for bogus number
jz _NumberQ9
cmp al,0feh ; test for , and .
jnz @f
mov DPL,esi
jmp _NumberQ2
@@: cmp al,0fdh ; test for -
jnz @f
cmp edi,0
jnz _NumberQ9 ; '-' in the middle of a number!
mov Negative,-1
jmp _NumberQ2
@@: cmp eax,Number_Base ; test for TOO BIG digit
jae _NumberQ9
xchg eax,edi ; swap value with eax
mul Number_Base ; multiply old value by Number Base
add edi,eax ; add to new in EDI
_NumberQ2: loop _NumberQ1 ; result in EDI, loop until out of chars
mov Value,edi
cmp DPL,0
jz _NumberQOk
sub esi,DPL
mov DPL,esi ; store the # of digits since in DPL!
_NumberQOk: popad
mov eax,Value
mul Negative ; Multiply by 1 or -1!
PushForth
mov eax,-1
PushForth
ret
_NumberQ9: popad ; Not a number
PushForth ; Restore the Address
xor eax,eax
PushForth ; and then a FALSE
ret
CodeDef '<S">' ; Puts Address and Count on stack
Inline_String: pop ecx ; (Counted string stored in-line)
mov eax,ecx
add eax,4 ; Push the Address
PushForth
mov eax,[ecx]
PushForth ; Push the count
add eax,ecx ; Add Count+8 to Return address
add eax,8
jmp eax
CodeDef '0"',3
Call S_Quote
lea eax,DROP
PushForth
call Do_CompileCall
ret
CodeDef 'SYScall' ; ( addr --- APIreturnCode )
PullForth
push ebx
push ecx
push edx
push esi
push edi
push ebp
mov ebp,esp
mov esp,ebx
Call EAX
mov esp,ebp
pop ebp
pop edi
pop esi
pop edx
pop ecx
pop ebx
PushForth
ret
AutoLoad: pushad ; put C:\FLAT32\FORTH.INI into fOpenName
mov esi,Environment ; on my machine
cld
@@: lodsb
cmp al,0
jnz @b
lodsb
cmp al,0
jnz @b ; look for a double 0
mov FooBar,ESI
lea edi,FOpenName ; copy the path, up to the .
@@: lodsb
stosb
cmp al,'.'
jnz @b
mov al,'I'
stosb
mov al,'N'
stosb
mov al,'I'
stosb
xor eax,eax
stosd
popad
; CodeDef 'AUTOLOAD'
;AutoLoad:
call FOpen
@@: PULLFORTH
push eax ; push handle
push ebx ; push stack
cmp eax,0
jle Abort
PushForth
mov eax,FileBufferSize
PushForth
call FRead
PullForth
or eax,eax
jz @f
mov InputCount,eax
lea eax,FileBuffer
mov InputBuffer,eax
xor eax,eax
mov InputOffset,eax
call Interpret
@@: pop eax
cmp eax,ebx ; check if stack changed
jne StackProblem
pop eax
PUSHFORTH
call FClose
ret
StackProblem: lea edx,StackLoadMsg
call WriteStr
jmp Abort
MAIN: mov SavedESP,ESP
mov ebp,esp
mov EAX,[EBP+12]
mov Environment,EAX
mov EAX,[EBP+16]
mov CommandLine,EAX
pushd 012h ; Write Un-committed
pushd Reserve_Size
pushd offset CodeSpace
call Dos32AllocMem
and eax,eax
jnz Bye
mov esp,SavedESP
call ErrorHandler
lea edx,CopyRightMsg
call WriteStr
lea edx,WelcomeMsg
call WriteStr
lea edx,VersionMsg
call WriteStr
lea edx,GreetMsg
call WriteStr
Call AutoLoad
jmp quit
VecAbort: mov esp,SavedESP
call ErrorHandler
jmp Quit
ErrorHandler: xor eax,eax
mov CompileMode,eax
mov SysTo,eax
mov ebx,StackBase
mov EDI,CodeSpace ; CS:EDI = compile pointer
cld ; count UP
call ForthVoc
ret
IOerror: mov edx,offset IOerrorMsg
call WriteStr
mov edx,offset StrBuffer
call Int_Str
call WriteStr
call DoCr
jmp Abort
CodeDef 'DumpRegisters'
DumpRegs: pushad
push Number_Base
mov Number_Base,10h
pushad
lea edx,RegisterMsg
call WriteStr
popad
pushad
mov ecx,8
@@: lea edx,Numbuffer
mov ebx,8
pop eax
call Int_StrLen
call WriteStr
lea edx,SpStr
call WriteStr
loop @b
call DoCr
pop Number_Base
popad
ret
WriteEAX:
pushad
lea edx,NumBuffer
call Int_Str
call WriteStr
call DoCr
popad
ret
WriteStr: ; writes string at [EDX]
pushad
xor eax,eax ; used as "actual count" storage
push eax
mov eax,esp ; push the address of the previous push
push eax
mov eax,[edx] ; push the string length
add OutPos,eax ; update output position
push eax
add edx,4 ; push the string address
push edx
pushd stdout ; push the handle to write to
call Dos32Write ; do the write.
add esp,20 ; set the stack back to semi-normal
popad
ret
Int_Str: pushad ; No length required...
mov ebx,0
jmp Int_Str0
Int_StrLen: pushad
Int_Str0: ; eax-value to print
; ebx-number of digits..
; edx-address of buffer to put it in.....
pushd 0 ;
mov edi,ebx ; edi now has count
mov ebx,edx ; buffer address now in ebx
mov ecx,number_base
lea esi,table
Int_Str1:
mov edx,0
div ecx
mov edx,[edx+esi]
push edx
dec edi ; bump counter
and eax,eax
jnz Int_Str1
mov edx,ebx ; ebx --> count
add edx,4 ; edx --> string data
mov ecx,0 ; ecx = counter
Int_Str1a:
or edi,edi
jle Int_Str2
xor eax,eax
mov al,Number_Fill
push eax
dec edi
jmp Int_Str1a
Int_Str2:
pop eax
or al,al
jz Int_Str3
mov [edx],al
inc edx
inc ecx
jmp Int_Str2
Int_Str3:
mov [ebx],ecx
popad
ret
Do_Breakpoint: push edx
lea edx,BreakMsg
call WriteStr
pop edx
ret
;
; Preliminary routines to build a foundation word list from
;
CodeDef '?STACK'
StackCheck: mov eax,StackBase
cmp ebx,eax
ja StackUnderflow
sub eax,STACK_SIZE*4
cmp ebx,eax
jbe StackOverflow
ret
StackOverFlow: lea edx,StackOverMsg
call WriteStr
jmp Abort ; RESET everything
StackUnderFlow:
lea edx,StackUnderMsg
call WriteStr
jmp Abort ; RESET everything
DivByZero: lea EDX,DivByZeroMsg
call WriteStr
xor eax,eax
mov [ebx],eax
ret
CodeDef 'COMPILECALL'
Do_CompileCall: ; Compiles a call to address given
mov al,0E8h
stosb
PULLFORTH
sub eax,EDI ; subtract current EIP
sub eax,4 ; subtract 4 for upcoming offset
stosd
ret
WriteLineNum: mov eax,LineNumber
or eax,eax
jz WriteLineNum9
lea edx,LineNumMsg
call WriteStr
mov eax,10
mov number_base,eax
mov eax,LineNumber
call WriteEAX
call DoCr
xor eax,eax
mov LineNumber,eax
WriteLineNum9: ret
CodeDef 'WORDS'
Do_Words: pushad
mov ecx,offset Context
Do_Words1: mov edx,[ecx]
or edx,edx
jz Do_Words_Done ; if last CURRENT vocabulary
add edx,VocLinkOffset
Do_Words2: mov edx,[edx].Prev ; go backwards in the chain
or edx,edx
jz Do_Words3
mov eax,[edx].NameSize
or eax,eax
jz Do_Words3
mov eax,[edx].Flags
test eax,HIDDEN
jnz Do_Words2 ; Skip if marked HIDDEN
push edx
lea edx,[edx].NameSize
call WriteStr
lea edx,SpStr
call WriteStr
call WriteStr
call QueryCr
pop edx
jmp Do_Words2
Do_Words3: add ecx,4 ; Finished 1 vocabulary
call DoCr
call DoCr
jmp Do_Words1
Do_Words_Done: popad
ret
CodeDef '?CR'
QueryCr: mov edx,OutPos
add edx,16
cmp edx,CharPerLine
jg DoCr
ret
CodeDef 'U*'
PULLFORTH
mul DWORD PTR [ebx]
mov [ebx],eax
ret
CodeDef 'U/'
PULLFORTH
or eax,eax
jz DivByZero
xchg eax,[ebx]
xor edx,edx
div DWORD PTR[ebx]
mov [ebx],eax
ret
CodeDef 'W@'
mov eax,[ebx ]
mov eax,[eax ]
and eax,00ffffh
mov [ebx ],eax
ret
CodeDef 'W!'
mov edx,[ebx ] ; value addr .... poke
mov eax,[ebx+4]
mov [edx],ax
add ebx,8 ; pop both values
ret
CodeDef 'DEBUG'
lea eax,Debug
PUSHFORTH
ret
CodeDef 'ABORT' ; Vectored ABORT
Abort: mov eax,TickAbort
jmp eax
CodeDef "'ABORT" ; Address of ABORT
lea eax,TickAbort
PUSHFORTH
ret
CodeDef 'EXITCODE' ; Result code in BYE
lea eax,ExitCode
PUSHFORTH
ret
CodeDef 'HEX'
mov eax,10h
mov Number_Base,eax
ret
CodeDef '.' ; Prints number in the current BASE
Do_Dot: PullForth
cmp eax,0
jge @f
push eax
mov al,'-'
PushForth
Call Do_Emit
pop eax
neg eax
jmp @f
CodeDef 'U.' ; Unsigned PRINT
PullForth
@@: Push ESI
Push ECX
Push EDX
push 0
mov ecx,Number_Base
lea ESI,Table
@@: xor edx,edx
div ecx ; AX = Quotient DX = Remainder
mov edx,[edx+esi]
push edx ; Put the char on the stack
or eax,eax
jnz @b
@@: pop eax
or eax,eax
jz @f
PushForth
Call Do_emit
jmp @b
@@: pop EDX
pop ECX
pop ESI
ret
CodeDef '.S' ; Non-Destructive stack print
mov ecx,StackBase
@@: sub ecx,4
cmp ecx,ebx
jb @f
mov eax,[ecx]
PushForth
call Do_Dot
lea edx,SpStr
call WriteStr
jmp @b
@@: call DoCr
ret
CodeDef 'SP0'
mov eax,StackBase ; Base of stack
PUSHFORTH
ret
CodeDef 'SP!' ; Resets user stack pointer
mov ebx,[ebx]
ret
CodeDef 'SP@'
mov eax,ebx ; Forth Stack pointer in EAX
PUSHFORTH
ret
CodeDef 'RP0' ; Get initial return pointer
mov eax,SavedESP
PushForth
ret
CodeDef 'RP@' ; Get the current return pointer
mov eax,ESP
add eax,4
PushForth
ret
CodeDef 'RP!' ; Get our return address....
pop edx
PullForth
mov esp,eax
push edx
ret
CodeDef 'CELL'
mov eax,4 ; Word Size in bytes
PUSHFORTH
ret
CodeDef 'COMPILE',CompileOnly
; a REALLY SNEAKY forth word
pop eax ; get return address
mov edx,eax
add eax,5 ; Modify return address, to skip
push eax ; the next call instruction
inc edx ; [edx] is call offset
add eax,[edx] ; eax now has absolute address of call
mov edx,eax
mov al,0E8h ; put the CALL instruction
stosb
mov eax,edx
sub eax,EDI ; subtract current EIP
sub eax,4 ; subtract 4 for upcoming offset
stosd
ret ; return with the address changed
; Some useful words let you temporarily store things on the return stack
; Always use >R and R> in pairs
;
; CREATE makes a 0 byte variable
; ALLOT adds N bytes to the length of the last word created
; , takes N, and adds in into the last word compiled
; C, adds C to the last word compiled
; VARIABLE makes a 4 byte variable
; DoesVariable Puts the Return address on the stack
; DoesConstant Puts the CONTENTS of the Return address on the stack
;
;
; Conditional Branching Logic
;
; IF - Marks code to be executed ONLY on a TRUE
; ELSE - Marks code to be executed ONLY of false
; THEN - Marks the end of the conditional
;
CodeDef 'IF',3 ; ONLY in compile mode
Call CompileCheck
cld
COMPILES 08Bh,003h,083h,0C3h,004h
COMPILES 023h,0C0h,00fh,084h
xor eax,eax
stosd ; set to 0, for safety
mov eax,edi ; calc offset of DWORD
sub eax,4
PUSHFORTH
ret
; Code generated....
; 8B 03 mov eax,[ebx]
; 83 C3 04 add ebx,4
; 23 C0 and eax,eax
; 0F 84 00000000 jz Next Instruction + Offset....
;
CodeDef 'THEN',3 ; ONLY in compile mode
Call CompileCheck
push edi
PULLFORTH
xchg EDI,EAX ; Fixup in EDI, current in EAX
sub eax,edi ; determine offset of this instruction
sub eax,4 ; from the patches NEXT instruction
stosd ; Do the patch
pop edi
ret
; for an ELSE
; 1256 E9 00000000 jmp Next Instruction + Offset....
CodeDef 'ELSE',3 ; ONLY in compile mode
Call CompileCheck
mov eax,0E9h
stosb ; Jump relative 32
xor eax,eax
stosd
mov eax,[ebx] ; get address from IF (ebx goes back up later)
push edi
xchg edi,eax
sub eax,edi
sub eax,4
stosd ; Patch IF address
pop edi
mov eax,edi
sub eax,4
mov [ebx],eax ; replace address with ELSE patch
ret
;
; DO ... LOOP logic
;
;
; DO - Takes 2 values from Forth Stack, puts them on the return stack
; COMPILE: Puts LABEL on stack
;
; LOOP - Increments loop counter, tests for end of loop, if ok, jums to LABEL
;
CodeDef 'DO',3 ; COMPILED ONLY, IMMEDIATE
Call CompileCheck
COMPILES 08Bh,043h,004h ; mov eax,[ebx+4]
COMPILES 050h ; push eax
COMPILES 08Bh,003h ; mov eax,[ebx]
COMPILES 050h ; push eax
COMPILES 083h,0C3h,008h ; add ebx,8
mov eax,EDI ; LABEL1:
PUSHFORTH
ret
CodeDef 'LOOP',3 ; CompileOnly, Immediate
Call CompileCheck
COMPILES 08bh,004h,024h ; mov eax,[esp]
COMPILES 040h ; inc eax
COMPILES 089h,004h,024h ; mov [esp],eax
COMPILES 03bh,044h,024h,004h ; cmp eax,[esp+4]
COMPILES 00fh,08ch ; jl RELATIVE32
PULLFORTH
sub eax,EDI
sub eax,4 ; calculate from next instruction
STOSD
COMPILES 083h,0c4h,008h ; add esp,8
ret
CodeDef '<+LOOP>',HIDDEN ; Smart +LOOP can count down or up
PlusLoop1: pop edx
PULLFORTH
add [esp],eax
mov ecx,[esp]
or eax,eax
jge PlusLoop2
cmp 4 [esp],ecx
jmp PlusLoop3
PlusLoop2: cmp ecx,4 [esp]
PlusLoop3: jge PlusLoop9
add edx,[edx]
add edx,4
jmp edx ; loop back
PlusLoop9: add edx,4 ; skip loop-back offset
add esp,8 ; drop loop variables
jmp edx
CodeDef '+LOOP',3 ; CompileOnly, Immediate
Call CompileCheck
lea eax,PlusLoop1
PUSHFORTH
call Do_CompileCall
PULLFORTH
sub eax,EDI
sub eax,4 ; calculate from next instruction
STOSD
ret
; A word which goes along with these will copy the value pushed onto
; the return stack with R> onto the parameter stack.
CodeDef 'K' ; 1 loop up
mov eax,[esp+20] ; return, index, limit, index, limit, index
PushForth
ret
CodeDef 'LEAVE' ; leave a DO...LOOP
mov eax,[esp+8]
mov [esp+4],eax
ret
CodeDef 'UNLOOP' ; remove loop variables from stack
mov eax,[esp]
add esp,8
mov [esp],eax
ret
;
; FOR ... NEXT logic
;
;
; FOR - Takes 2 values from Forth Stack, puts them on the return stack
; MARKER - Take values from stack, if past bound PATCHUP, skip body
;
; NEXT- Does Patchup, Compiles Jump to MARKER
;
; DESIRED RESULT:
;
; 1302 8B 43 04 mov eax,[ebx+4] ; MOVE values to return stack
; 1305 50 push eax
; 1306 8B 03 mov eax,[ebx]
; 1308 50 push eax
; 1309 83 C3 08 add ebx,8 ; bump counter appropriately
; 130C 58 LABEL1: pop eax
; 130D 5A pop edx
; 130E 3B C2 cmp eax,edx
; 1310 73 11 jae LABEL2
; 1312 52 push edx
; 1313 50 push eax
;
; 1314 BA 000000B0 R lea edx,GreetMsg
; 1319 E8 FFFFEF91 call WriteStr
;
; 131E 58 pop eax
; 131F 40 inc eax
; 1320 50 push eax
; 1321 EB E9 jmp LABEL1
;
; 1323 LABEL2:
; 1323 C3 ret
CodeDef 'FOR',3 ; COMPILED ONLY, IMMEDIATE
Call CompileCheck
COMPILES 08Bh,043h,004h ; mov eax,[ebx+4]
COMPILES 050h ; push eax
COMPILES 08Bh,003h ; mov eax,[ebx]
COMPILES 050h ; push eax
COMPILES 083h,0C3h,008h ; add eax,8
mov eax,EDI ; LABEL1: Jump back point
PUSHFORTH
COMPILES 058h ; pop eax
COMPILES 05Ah ; pop edx
COMPILES 03Bh,0C2h ; cmp eax,edx
COMPILES 00fh,083h ; jea relative 32
mov eax,EDI ; patch point to LABEL2
PUSHFORTH
xor eax,eax
stosd
COMPILES 052h ; push edx
COMPILES 050h ; push eax
ret
; 131E 58 pop eax
; 131F 40 inc eax
; 1320 50 push eax
; 1321 EB E9 jmp LABEL1
;
; 1323 LABEL2:
CodeDef 'NEXT',3 ; Compile ONLY, Immediate
Call CompileCheck
mov al,058h ; pop eax
stosb
mov al,040h ; inc eax
stosb
mov al,050h ; push eax
stosb
mov al,0E9h ; jmp Relative 32
stosb
mov eax,[ebx+4] ; EAX = LABEL1
sub eax,edi ; DELTA = LABEL1 - NEXT INSTRUCTION
sub eax,4
stosd ; Do the backward jump....
mov eax,edi ;
sub eax,[ebx] ; Offset = Current - (Patch+4)
sub eax,4
push edi
mov edi,[ebx]
STOSD
pop edi
add ebx,8 ; drop 2 stack entries
ret
CodeDef '>=' ; i.e. 5 5 >=
pullforth ; eax = stack top 5
cmp eax,[ebx]
mov eax,0
jg @f
dec eax
@@: mov [ebx],eax
ret
CodeDef '<='
pullforth
cmp eax,[ebx]
mov eax,0
jl @f
dec eax
@@: mov [ebx],eax
ret
CodeDef '<>' ; True if A <> B
pullforth
cmp eax,[ebx]
mov eax,0
jz @f
not eax
@@: mov [ebx],eax
ret
CodeDef 'NOT' ; 1s complement
not dword ptr[ebx]
ret
CodeDef 'U*/MOD' ; ( a b c -- remainder quotient )
mov eax,[ebx+8]
mul DWORD PTR[ebx+4]
cmp edx,[ebx]
jg DivByZero
div DWORD PTR[ebx]
add ebx,4
mov [ebx],eax ; Store Quotient
mov [ebx+4],edx ; Store Remainder
ret
CodeDef 'FOPEN' ; ( -- handle )
Fopen: mov eax,0ffffffffh
mov FopenHandle,eax
pushad
pushd 0 ; PEAOP2 (not used, must be 0 )
mov eax,esp
push eax
pushd 020h ; Readonly, deny write
pushd 001h ; Open, fail if non-existant
pushd 000h ; Normal attributes
pushd 0 ; Don't change file size
lea eax,FopenAction
push eax
lea eax,FopenHandle
push eax
lea eax,FopenName
push eax
call Dos32Open
add esp,36 ; Drop all of the stuff from the stack
popad
mov eax,FopenHandle
PushForth ; put the handle on the stack
ret
CodeDef 'CLOSE' ; ( handle -- )
FClose: PullForth
pushad
push eax
call Dos32Close
add esp,4
popad
ret
CodeDef 'FREAD' ; ( handle size -- bytes_read )
FRead: PullForth ; eax is size
mov edx,eax
pushad
push ebx ; point at parameter on stack
push edx ; number of bytes to read
lea eax,FileBuffer
push eax
mov eax,[ebx] ; handle
push eax
call Dos32Read
add esp,16
popad
ret
CodeDef 'FBUFFER'
lea eax,FileBuffer
pushforth
ret
CodeDef 'LINE#'
lea eax,LineNumber
PUSHFORTH
ret
CodeDef 'BYE' ; Exit Forth Environment
BYE: pushd 1
mov eax,ExitCode
push eax
call Dos32Exit
CodeDef 'INTERPRET'
Interpret:
mov eax,' '
PushForth
call _Word
mov eax,[ebx] ; address of string
mov eax,[eax] ; count
jz Interpret8 ; (Null string, bail out)
call _Find ; 0 = Not found
PullForth ; 1 = Immediate
or eax,eax ;-1 = Normal
jz InterpretNumber
;
; We have an address, decide if it should be compiled or called.
;
test CompileMode,1
jz @f
;
; This is the "compile mode" branch of things
;
cmp eax,1 ; is it immediate?
jz @f
call Do_CompileCall ; No, compile it
jmp Interpret
;
; This is the interpretive branch
;
@@: call _Execute ; Execute a function
jmp Interpret
Interpret8: pullforth
Interpret9:
ret
;
; Handle a possible number, counted string on stack
;
InterpretNumber:
call _NumberQ
pullForth
or eax,eax
jz Interpret_NonNumber
test CompileMode,1
jz @f
call _Literal
@@: jmp Interpret
Interpret_NonNumber:
mov eax,[ebx] ; Peek at stack top
mov eax,[eax] ; get string length
or eax,eax ; Don't warn if it's 0 chars
jz Interpret8
lea edx,What1Msg
call WriteStr
Call _Count
Call _Type
lea edx,What2Msg
call WriteStr
call WriteLineNum
jmp Abort
CodeDef 'PROMPT'
Prompt: call DoCr
lea edx,PromptMsg
call WriteStr
ret
CodeDef 'DP!'
PullForth
mov edi,eax
mov CodeSpace,EDI
ret
CodeDef '?COMPILE' ; Only works if we're compiling
CompileCheck: test CompileMode,1
jz @f
ret
@@: lea edx,CompileOnlyMsg
call WriteStr
call WriteLineNum
jmp Abort ; RESET everything
CodeDef '[COMPILE]',3 ; Compiles the next word, regardless
Call CompileCheck
call Tick
PullForth
mov eax,[eax].CodePointer
PushForth
call Do_CompileCall
ret
CodeDef 'POSTPONE',IMMEDIATE ; Compiles the next word
CLD
Call CompileCheck
call Tick
lea edx,PostponeImmediate
cmp eax,1 ; 1 = Immediate
jz @f
lea edx,PostponeNormal ; -1 = Normal
@@: mov eax,edx
PushForth
call Do_CompileCall
PullForth
stosd
mov CodeSpace,edi
ret
PostponeImmediate:
pop edx
mov eax,[edx]
add edx,4
push edx
jmp eax
PostPoneNormal:
pop edx
mov eax,[edx]
add edx,4
push edx
pushforth
call Do_CompileCall
ret
DoDoes: mov edx,NewWord ; Address of the latest word...
add edx,031h ; Offset to CALL offset
Pop EAX ; Address to jump to....
; Note: We never return to it!
sub eax,EDX ; subtract current EIP
sub eax,4 ; subtract 4 for upcoming offset
mov [edx],eax
mov CodeSpace,EDI
ret
CodeDef 'DOES>',3 ; Compile Only, Immediate
Does: Call CompileCheck
lea eax,DoDoes
PushForth
Call Do_CompileCall ; Put the call to DoDoes in the
; def that uses DOES>
Compiles 058h ; pop eax
Compiles 083h,0ebh,004h ; sub ebx,4
Compiles 089h,003h ; mov [ebx],eax
ret
CodeDef 'LAST' ; The LAST word defined
mov eax,Current
mov eax,[eax+VocLinkOffset]
PushForth
ret
CodeDef '%TO'
lea eax,SysTo
PUSHFORTH
ret
CodeDef 'TO'
mov eax,1
mov SysTo,eax
ret
CodeDef '+TO'
mov eax,-1
mov SysTo,eax
ret
CodeDef '<TODOES>' ; For TO variables
mov eax,SysTo
or eax,eax
jz Fetch
xor ecx,ecx
mov SysTo,ecx ; reset TO state
or eax,eax
jg Store
ja PlusStore
CodeDef 'DROPS' ; DROPS n items off the stack
Drops: inc DWORD PTR [ebx]
shl DWORD PTR [ebx],1
shl DWORD PTR [ebx],1
add ebx,[ebx]
ret
CodeDef 'DPL' ; variable holding decimal point position
lea eax,DPL
PUSHFORTH
ret
CodeDef 'ROLL' ; ( n -- ) moves n'th word on stack to top
PullForth
cmp eax,1 ; not defined for n <= 1
jle @f
push edi
push esi
dec eax
mov ecx,eax
dec eax
shl eax,1
shl eax,1
mov esi,ebx
add esi,eax ; start from n'th element
mov edi,ebx
add edi,eax
add edi,4
add eax,ebx
mov eax,[eax+4] ; copy ROLL'd value
std ; move words up
rep movsd ; move stack up
cld
mov [ebx],eax ; store ROLL'd value
pop esi
pop edi
@@: ret
CodeDef 'CMOVE>' ; ( src dest n -- ) moves n bytes up
CmoveBack: PullForth
cmp eax,1 ; not defined for n < 1
jl @f
push edi
push esi
mov ecx,eax
dec eax
mov esi,[ebx+4]
add esi,eax ; start from n'th byte
mov edi,[ebx]
add edi,eax
std
rep movsb ; move bytes up
cld
pop esi
pop edi
@@: add ebx,8
ret
CodeDef 'CMOVE' ; ( src dest n -- ) moves n bytes
Cmove: PullForth
cmp eax,1 ; not defined for n < 1
jl @f
push edi
push esi
mov ecx,eax
mov esi,[ebx+4]
mov edi,[ebx]
rep movsb
pop esi
pop edi
@@: add ebx,8
ret
CodeDef "=STRING" ; ( addr len "string" -- f )
EqualString: push esi
push edx
push ecx
mov esi,[ebx] ; esi=string
mov ecx,[ebx+4] ; ecx=len for LOOP
add ebx,8
mov edx,[ebx]
push ebx ; Save STACK, we're using EBX
lea ebx,UpperCaseTable
cld
lodsd ; Length of string1 in eax
cmp eax,ecx ; compare string lengths
jnz NotEqual
jmp EqualStr1
CodeDef '@+' ; ( addr -- addr+4 [addr] )
mov edx,[ebx]
mov eax,[edx]
add edx,4
mov [ebx],edx
PushForth
ret
CodeDef 'NIP' ; ( n1 n2 -- n2 )
PullForth
mov [ebx],eax
ret
CodeDef 'PICK' ; Copies n'th item to top
mov eax,[ebx]
cmp eax,1 ; not defined for n <= 1
jl @f
shl eax,1
shl eax,1
add eax,ebx
mov eax,[eax]
mov [ebx],eax
@@: ret
CodeDef '#OUT' ; Output position
lea eax,DWORD PTR OutPos
PushForth
ret
CodeDef 'WITHIN' ; ( n1 n2 n3 -- f ) True if n1<=n2<=n3
xor edx,edx
mov eax,[ebx+8]
cmp eax,[ebx] ; cmp n1,n3
jg @f
cmp eax,[ebx+4] ; cmp n1,n2
jl @f
dec edx
@@: add ebx,8
mov [ebx],edx
ret
CodeDef 'CURRENT' ; Vocabulary where definitions are added
lea eax,WORD PTR Current
PushForth
ret
CodeDef 'CONTEXT' ; Vocabulary where words are searched for
lea eax,WORD PTR Context
PushForth
ret
CodeDef 'CONTEXTSIZE' ; Size in words of CONTEXT
mov eax,ContextSize
PushForth
ret
CodeDef 'VOC-LINK' ; Location of most recent vocabulary
lea eax,WORD PTR Voc_link
PushForth
ret
CodeDef '<VOCABULARY>' ; ( vocabulary -- ) Adds voc to CONTEXT
DoVocabulary: push esi
push edi
mov edi,offset Context ; list of search vocabularies
mov eax,[ebx] ; check if vocab already listed
mov ecx,ContextSize-1 ; max # of vocabularies
cld
repne scasd ; Look for the vocabulary
or ecx,ecx
jnz RollVocab ; If already listed, roll to top
mov edx,[ebx]
jmp ShiftVocab
; mov edi,offset Context
; xor eax,eax
; mov ecx,ContextSize-1
; repne scasd ; Look for the first 0
; mov eax,[ebx]
; mov [edi-4],eax ; Vocabulary to add to Context
RollVocab: mov eax,edi
cmp eax,offset Context+4
je DoVocab9 ; If vocab is already first
mov edx,[edi-4] ; vocab to roll to top
ShiftVocab: sub edi,4
mov esi,edi
sub esi,4
neg ecx
add ecx,ContextSize-2
std
rep movsd ; move vocabs down
cld
mov Context,edx ; store vocabulary at top
DoVocab9: pop edi
pop esi
add ebx,4
ret
SetVocabulary: pop eax ; Expects a vocab record after it
PUSHFORTH
call DoVocabulary
ret
CodeDef 'FORTH',IMMEDIATE
ForthVoc: lea eax,ForthLink
PUSHFORTH
call DoVocabulary
ret
; ForthVoc: call SetVocabulary
; ForthLink dd 0,LastForthWord,0 ; FORTH vocabulary pointer
CodeDef 'SYSTEM',1 ; SYSTEM vocabulary
SysVoc: lea eax,SysLink
PUSHFORTH
call DoVocabulary
ret
; SysVoc: call SetVocabulary
; SysLink dd 0,LastHeader,ForthLink ; SYSTEM vocabulary pointer
CodeDef 'FALSE' ; Core extension
xor eax,eax
PUSHFORTH
ret
CodeDef 'TRUE' ; Core extension
xor eax,eax
dec eax
PUSHFORTH
ret
LastForthWord = LastHeader
LastHeader = 0
CodeDef 'MS'
PullForth
Push EAX
Call Dos32Sleep
Add ESP,4
ret
CodeDef 'SYS$BEEP'
lea eax,Dos32Beep
PushForth
ret
CodeDef 'SYS$CALLNPIPE'
lea eax,Dos32CallNPipe
PushForth
ret
CodeDef 'SYS$CLOSE'
lea eax,Dos32Close
PushForth
ret
CodeDef 'SYS$CONNECTNPIPE'
lea eax,Dos32ConnectNPipe
PushForth
ret
CodeDef 'SYS$CREATENPIPE'
lea eax,Dos32CreateNPipe
PushForth
ret
CodeDef 'SYS$CREATETHREAD'
lea eax,Dos32CreateThread
PushForth
ret
CodeDef 'SYS$DEVIOCTL'
lea eax,Dos32DevIOCtl
PushForth
ret
CodeDef 'SYS$DISCONNECTNPIPE'
lea eax,Dos32ExecPgm
PushForth
ret
CodeDef 'SYS$EXECPGM'
lea eax,Dos32ExecPgm
PushForth
ret
CodeDef 'SYS$EXIT'
lea eax,Dos32Exit
PushForth
ret
CodeDef 'SYS$FREEMODULE'
lea eax,Dos32FreeModule
PushForth
ret
CodeDef 'SYS$KILLPROCESS'
lea eax,Dos32KillProcess
PushForth
ret
CodeDef 'SYS$KILLTHREAD'
lea eax,Dos32KillThread
PushForth
ret
CodeDef 'SYS$LOADMODULE'
lea eax,Dos32LoadModule
PushForth
ret
CodeDef 'SYS$OPEN'
lea eax,Dos32Open
PushForth
ret
CodeDef 'SYS$FREEMODULE'
lea eax,Dos32FreeModule
PushForth
ret
CodeDef 'SYS$GETDATETIME'
lea eax,Dos32GetDateTime
PushForth
ret
CodeDef 'SYS$PEEKNPIPE'
lea eax,Dos32PeekNPipe
PushForth
ret
CodeDef 'SYS$QUERYMODULEHANDLE'
lea eax,Dos32QueryModuleHandle
PushForth
ret
CodeDef 'SYS$QUERYNPHSTATE'
lea eax,Dos32QueryNPHState
PushForth
ret
CodeDef 'SYS$QUERYNPIPEINFO'
lea eax,Dos32QueryNPipeInfo
PushForth
ret
CodeDef 'SYS$QUERYPROCADDR'
lea eax,Dos32QueryProcAddr
PushForth
ret
CodeDef 'SYS$QUERYPROCTYPE'
lea eax,Dos32QueryProcType
PushForth
ret
CodeDef 'SYS$READ'
lea eax,Dos32Read
PushForth
ret
CodeDef 'SYS$RESUMETHREAD'
lea eax,Dos32ResumeThread
PushForth
ret
CodeDef 'SYS$SEEK'
lea eax,Dos32SetFilePtr
PushForth
ret
CodeDef 'SYS$SETNPHSTATE'
lea eax,Dos32SetNPHState
PushForth
ret
CodeDef 'SYS$SLEEP'
lea eax,Dos32Sleep
PushForth
ret
CodeDef 'SYS$STARTSESSION'
lea eax,Dos32StartSession
PushForth
ret
CodeDef 'SYS$SUSPENDTHREAD'
lea eax,Dos32SuspendThread
PushForth
ret
CodeDef 'SYS$TRANSACTNPIPE'
lea eax,Dos32TransactNPipe
PushForth
ret
CodeDef 'SYS$WAITCHILD'
lea eax,Dos32WaitChild
PushForth
ret
CodeDef 'SYS$WAITNPIPE'
lea eax,Dos32WaitNPipe
PushForth
ret
CodeDef 'SYS$WAITTHREAD'
lea eax,Dos32WaitThread
PushForth
ret
CodeDef 'SYS$WRITE'
lea eax,Dos32Write
PushForth
ret
CodeDef 'SYS$SHUTDOWN'
lea eax,Dos32ShutDown
PushForth
ret
CodeDef 'ENVIRONMENT'
mov EAX,Environment
PUSHFORTH
ret
CodeDef 'COMMANDLINE'
mov EAX,CommandLine
PUSHFORTH
ret
;
;*********** FLOATING POINT WORDS
;
CodeDef 'FCLEAR' ; Initializes everything
FINIT
PUSHD 037fh
FLDCW [ESP] ; Double Precision, round towards nearest
ADD ESP,4
ret
CodeDef 'D>F' ; Convert an Integer to the real stack
FILD Dword Ptr[EBX]
add EBX,4
ret
CodeDef 'F>D' ; Truncate to forth stack
sub EBX,4
PUSHD 0f7fh ; Modify control value
FLDCW [ESP]
ADD ESP,4
FISTP DWord Ptr[EBX]
PUSHD 037fh ; Set it back
FLDCW [ESP]
ADD ESP,4
ret
CodeDef 'F@'
PullForth
FLD QWORD PTR [EAX]
ret
CodeDef 'F!'
PullForth
FSTP QWORD PTR [EAX]
ret
CodeDef 'F+'
FADDP ST(1),ST
ret
CodeDef 'F-'
FSUBP ST(1),ST
ret
CodeDef 'F*'
FMULP ST(1),ST
ret
CodeDef 'F/'
FDIV
ret
CodeDef 'F0<'
FTST
FSTSW AX
SAHF
MOV EAX,0
SBB EAX,0
PushForth
ret
CodeDef 'F0='
FTST
FSTSW AX
SAHF
MOV EAX,0
JNZ @F
MOV EAX,-1
@@: RET
CodeDef 'F<'
FCOMPP
FSTSW AX
SAHF
MOV EAX,0
SBB EAX,0
PushForth
ret
CodeDef 'FDROP'
FFREE ST ; free the register
FINCSTP ; bump the stack counter
ret
CodeDef 'FDUP'
FLD ST
ret
CodeDef 'FSWAP'
FXCH ST(1)
ret
CodeDef 'FVARIABLE'
call Create
mov eax,8
PUSHFORTH
call Allot
ret
CodeDef 'FLOOR'
PUSHD 0f7fh ; Modify control value
FLDCW [ESP]
ADD ESP,4
FRNDINT
PUSHD 037fh ; Set it back
FLDCW [ESP]
ADD ESP,4
RET
CodeDef 'FROUND' ; Round to nearest
FRNDINT
RET
CodeDef 'FDEPTH' ; Depth of Stack...
FSTSW AX
AND EAX,00003c00h
SHR EAX,11
XOR EAX,7
INC EAX
AND EAX,7
PUSHForth
Ret
CodeDef 'FALIGN'
ret
CodeDef 'FALIGNED'
ret
DoesFConstant: pop eax
FLD Qword Ptr[eax]
ret
;
;***** Floating Point EXTENSION words *****
;
CodeDef 'FABS'
FABS
ret
CodeDef 'FCOS'
FCOS
ret
CodeDef 'FSIN'
FSIN
ret
CodeDef 'FSINCOS'
FSINCOS
ret
CodeDef 'FSQRT'
FSQRT
ret
;
; Code FOR F. - What a pig!
;
CvtDigit: cmp eax,Number_Base
jae BadDigit
cmp eax,0
jb BadDigit
lea ESI,Table
mov al,[esi+eax]
ret
BadDigit: mov eax,'?'
ret
CodeDef 'F.'
PUSHAD
XOR EAX,EAX ; Push a 0 to the stack
Push EAX
MOV EDI,0 ; EDI is EXPONENT in this app!
FTST
FSTSW AX
SAHF
JAE @f
MOV EAX,'-'
PushForth
Call Do_Emit
@@: FABS ; FStack top >= 0
Push 07fffffffh
FICOM Dword Ptr[ESP]
ADD ESP,4 ; Compare to maxint
FSTSW AX
SAHF
JB ShowFloat
@@: FIDIV Number_Base
INC EDI
FICOM Number_Base
FSTSW AX
SAHF
JAE @b
ShowFloat: PUSHD 0f7fh ; Modify control value
FLDCW [ESP] ; FLOOR mode
ADD ESP,4
PUSH EAX
FLD ST ; Dup Stack Top -- X,X
FRNDINT ; Trunc(X),X
FIST Dword Ptr[ESP] ; Trunc(X),X
FSUBP ST(1),ST ; Frac(X)
POP EAX ; Whole in EAX
mov ecx,Number_Base
lea ESI,Table
@@: xor edx,edx
div ecx ; AX = Quotient DX = Remainder
xchg edx,eax
call CvtDigit
xchg edx,eax
push edx ; Put the char on the stack
or eax,eax
jnz @b
@@: pop eax
or eax,eax
jz FPrintFrac
PushForth
Call Do_emit
jmp @b
;
; Print The Fraction in ST
;
FprintFrac: mov eax,'.' ; Put the decimal point
PushForth
Call Do_Emit ; FRAC(X)
@@: FIMUL Number_Base ; FRAC(X)*10?
Push EAX
FIST Dword Ptr[ESP]
Pop EAX
Call CvtDigit
PushForth
call Do_Emit
FTST
FSTSW AX
SAHF
JZ @f
FLD ST ; Dup Stack Top -- X,X
FRNDINT
FSUBP ST(1),ST
JMP @b
@@: FFREE ST ; free the register
FINCSTP ; bump the stack counter
CMP EDI,0
JZ FPrintDone
MOV EAX,'E'
PushForth
Call Do_Emit
MOV EAX,'+'
CMP EDI,0
JA @F
MOV EAX,'-'
NEG EBP
@@: PushForth
Call Do_Emit
MOV EAX,EDI
push 0
mov ecx,Number_Base
lea ESI,Table
@@: xor edx,edx
div ecx ; AX = Quotient DX = Remainder
xchg edx,eax
call CvtDigit
xchg edx,eax
push edx ; Put the char on the stack
or eax,eax
jnz @b
@@: pop eax
or eax,eax
jz FPrintDone
PushForth
Call Do_emit
jmp @b
FprintDone: PUSHD 037fh ; Set round mode
FLDCW [ESP]
ADD ESP,4
POPAD
RET
CodeDef 'NOP'
ret
CodeDef 'PI'
FLDPI
ret
CodeDef 'CIN' ; ( addr -- data )
mov eax,esp ; save current ss, esp
push ss ; for return from 16-bit land
push eax
mov eax,esp ; convert stack so 16-bit can use it
ror eax,16
shl eax,3
or al,7 ; convert to ring-3 tiled segment
mov ss,eax
mov edx,[ebx]
xor eax,eax
jmp far ptr Do_inp16
Do_inp2 label far
movzx esp,sp ; make sure that esp is correct
lss esp,[esp]
mov [ebx],eax
ret
CodeDef 'COUT' ; ( data addr -- )
mov eax,esp ; save current ss, esp
push ss ; for return from 16-bit land
push eax
mov eax,esp ; convert stack so 16-bit can use it
ror eax,16
shl eax,3
or al,7 ; convert to ring-3 tiled segment
mov ss,eax
PullForth
mov edx,eax
PullForth
jmp far ptr Do_out16
Do_out2 label far
movzx esp,sp ; make sure that esp is correct
lss esp,[esp]
ret
MYCODE SEGMENT PARA USE16 PUBLIC 'CODE'
Do_Emit16 LABEL FAR16
call VIOwrtTTY
add sp,4 ; toss the parameters for the DOS16 call
jmp FLAT:Do_Emit2
Do_GetKey16 LABEL FAR16
call KbdCharIn
jmp FLAT:Do_GetKey2
Do_inp16 LABEL FAR16
call @inp
jmp FLAT:DO_inp2
Do_Out16 LABEL FAR16
call @outp
jmp FLAT:DO_out2
MYCODE ends
.code
end main