home *** CD-ROM | disk | FTP | other *** search
/ High Voltage Shareware / high1.zip / high1 / DIR24 / FORTH037.ZIP / FORTH.ASM < prev    next >
Assembly Source File  |  1993-11-14  |  102KB  |  3,664 lines
  1.            Title   _FORTH_32 '32 BIT FORTH FOR OS/2'
  2. ;
  3. ; FORTH/2 -- Copyright(C) 1992, BLUE STAR SYSTEMS, all rights reserved
  4. ; Produced in the United States of America
  5. ;
  6. ;   This software is furnished under a license agreement or nondisclosure
  7. ; agreement.  The software may be used or copied only in accordance with
  8. ; the terms of the agreement. No part of this program may be reproduced
  9. ; or transmitted in any form or by any means, electronic or mechanical,
  10. ; including photo-copying and recording, for any purpose without the
  11. ; express written permission of the author.
  12. ;
  13. ;   The following paragraph does not apply in the United Kingdom or any
  14. ; country where such provisions are inconsistent with local law:
  15. ;   BLUE STAR SYSTEMS OFFERS THIS PROGRAM "AS IS" WITHOUT WARRANTY OF
  16. ; ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
  17. ; IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
  18. ; Some states do not allow disclaimer of express or implied warranties in
  19. ; certain transactions, therefore, this statement may not apply to you.
  20. ;
  21. ; BLUE STAR SYSTEMS may have patents or pending patent applications covering
  22. ; the subject matter in this program. The furnishing of this program does
  23. ; not give you any license to these patents. You can send license inquiries,
  24. ; in writing, to BLUE STAR SYSTEMS, PO BOX 4043, Hammond, Indiana 46324
  25. ;
  26. ; Note: 16 Bit calls EAT STACK PARAMS
  27. ;       32 Bit calls LEAVE stack params
  28. ;
  29. ; Thanks to Larry Bank for his sample code in VIO32.ASM
  30. ; Thanks to Brian Mathewson for his $$$ and suggestions, and CODE
  31. ; Thanks to Michael Thompson (tommy@msc.cornell.edu) for PORTIO.ASM
  32. ;
  33.           .386
  34.           .model   flat,syscall,os_os2
  35.  
  36.           .code
  37.  
  38. Reserve_Size   =       010000h ; Reserve 64k Of Memory for Dictionary
  39.  
  40. STACK_SIZE       = 1000h   ; Memory reserved for stack
  41. STACK_UNDERFLOW  = 1000h
  42. RSTACK_SIZE      = 1000h   ; Return stack size for threads
  43.  
  44.            EXTRN   Dos32AllocMem:Near,Dos32Read:Near
  45.            EXTRN   Dos32Beep:Near,Dos32SetFilePtr:Near
  46.            EXTRN   Dos32CallNPipe:Near,Dos32ConnectNPipe:Near
  47.            EXTRN   Dos32CreateNPipe:Near
  48.            EXTRN   Dos32CreateThread:Near
  49.            EXTRN   Dos32DevIOCtl:Near
  50.            EXTRN   Dos32DisConnectNPipe:Near
  51.            EXTRN   Dos32ExecPgm:Near
  52.            EXTRN   Dos32Exit:Near
  53.            EXTRN   Dos32GetDateTime:Near
  54.            EXTRN   Dos32KillProcess:Near
  55.            EXTRN   Dos32KillThread:Near
  56.            EXTRN   Dos32LoadModule:Near,Dos32FreeModule:Near
  57.            EXTRN   Dos32Open:Near,Dos32Close:Near
  58.            EXTRN   Dos32PeekNPipe:Near
  59.            EXTRN   Dos32QueryModuleHandle:Near
  60.            EXTRN   Dos32QueryModuleName:Near
  61.            EXTRN   Dos32QueryNPHState:Near,Dos32QueryNPipeInfo:Near
  62.            EXTRN   Dos32QueryProcAddr:Near
  63.            EXTRN   Dos32QueryProcType:Near
  64.            EXTRN   Dos32ResumeThread:Near
  65.            EXTRN   Dos32SetNPHState:Near
  66.            EXTRN   Dos32Sleep:Near,Dos32StartSession:Near
  67.            EXTRN   Dos32SuspendThread:Near
  68.            EXTRN   Dos32TransactNPipe:Near
  69.            EXTRN   Dos32WaitChild:Near
  70.            EXTRN   Dos32WaitNPipe:Near
  71.            EXTRN   Dos32WaitThread:Near
  72.            EXTRN   Dos32Write:Near
  73.  
  74.  
  75.            EXTRN   DosFlatToSel:near,DosSelToFlat:near
  76.            EXTRN   KbdCharIn:far16,VIOwrtTTY:far16
  77.            EXTRN   Dos32Shutdown:Near
  78.  
  79.            EXTRN   @inp:far16,@outp:far16
  80.  
  81. PULLFORTH      MACRO
  82.            mov     eax,[ebx]
  83.            add     ebx,4
  84.            ENDM
  85.  
  86. PUSHFORTH      MACRO
  87.            sub     ebx,4
  88.            mov     [ebx],eax
  89.            ENDM
  90.  
  91. COMPILES       MACRO   varg:VARARG
  92.          FOR     arg, <varg>
  93.            mov     al,arg
  94.            stosb
  95.          ENDM
  96.            ENDM
  97.  
  98. VocLinkOffset  =       4        ; Offset from vocabulary of link
  99. ContextSize    =       16       ; Size of Context buffer
  100.  
  101.           .stack   8192
  102.           .data
  103.  
  104. ;
  105. ; Data returned from getkey...
  106. ;
  107. ascii         db     0
  108. scancode      db     0
  109. status        db     0
  110. reserved      db     0
  111. shift_state   dw     0
  112. time_stamp    dd     0
  113. ;
  114.  
  115. ;---------------- I/O DOS Calls Only---------------
  116. stdin          equ   0
  117. stdout         equ   1
  118. stderr         equ   2
  119.  
  120. ;---------------- Useful ---------------
  121. cr             equ   0dh
  122. lf             equ   0ah
  123. crlf           equ   0dh,0ah   ;cr+lf
  124. BEL            equ   07h
  125. NULL           equ   0000h
  126.  
  127. SavedESP       dd    ?
  128.  
  129. Environment    dd    ?
  130. CommandLine    dd    ?
  131. FooBar         dd    ?
  132.  
  133.  
  134. ;********* Forth REGISTER USE:
  135. ;
  136. ;  EBX - Numeric Stack pointer, growing downward from FStackBase
  137. ;
  138. ;  EDI - Current CODE generating address
  139. ;
  140. ;  All other variables my be used, and trashed, at ANY time....!
  141. ;
  142.  
  143. Message        MACRO  name:REQ,string:VARARG
  144.  
  145. &name&msg      dd     @f-($+4)  ;; define a DWORD which gives size
  146.  
  147.            FOR arg, <string>
  148.          DB    arg             ;; Store the byte(s)
  149.            ENDM
  150. @@:
  151. ENDM
  152.  
  153.  
  154. MESSAGE Welcome,   "FORTH/2 -- Version 0.37 ßeta ("
  155.  
  156. MESSAGE CopyRight, "Copyright(C) 1992, 1993 - BLUE STAR SYSTEMS, all rights reserved",CrLf,"Produced in the United States of America",CrLf,CrLf
  157.  
  158. MESSAGE Greet,     "Type BYE to exit, WORDS to see word list.",CrLf
  159.  
  160. MESSAGE Break,     "Breakpoint Encountered! ",CrLf
  161.  
  162. MESSAGE StackOver, "Stack Overflow!",07h,CrLf
  163.  
  164. MESSAGE StackUnder,"Stack Underflow!",07h,CrLf
  165.  
  166. MESSAGE IOerror,   "I/O Error #"
  167.  
  168. MESSAGE StackLoad, "FORTH.INI should not change the stack",CrLf
  169.  
  170. MESSAGE Prompt,    "Ok: "
  171.  
  172. MESSAGE CompileOnly "Not in compile mode!",CrLf
  173.  
  174. MESSAGE Semicolon  "ERROR: Semicolon was expected",CrLf
  175.  
  176. MESSAGE LineNum    "at line number: "
  177.  
  178. MESSAGE WHAT1      "What does ",022h
  179. MESSAGE WHAT2      022h," mean? (type BYE to exit to OS/2) ",CrLf
  180.  
  181. MESSAGE DivByZero  "DIVISION BY ZERO ATTEMPTED!",CrLf
  182.  
  183. MESSAGE NotCompiling "Only in compile mode!",CrLf
  184.  
  185. MESSAGE Huh        " ?",CrLf
  186.  
  187. MESSAGE NotCreateWord "not a CREATE'd word!",CrLf
  188.  
  189. MESSAGE Register   "   EDI      ESI      EBP      ESP      EBX      EDX      ECX      EAX",CrLf
  190.  
  191. MESSAGE Pause      "--PRESS ANY KEY--",Cr
  192.  
  193. MESSAGE PauseClear "                 ",Cr
  194.  
  195. CrLfStr        dd     2
  196.            db     0dh,0ah
  197.  
  198. CrStr          dd     1
  199.            db     0dh
  200.  
  201. SpStr          dd     1
  202.            db     20h
  203.  
  204. UpperCaseTable db     000h,001h,002h,003h,004h,005h,006h,007h
  205.            db     008h,009h,00ah,00bh,00ch,00dh,00eh,00fh
  206.            db     010h,011h,012h,013h,014h,015h,016h,017h
  207.            db     018h,019h,01ah,01bh,01ch,01dh,01eh,01fh
  208.            db     020h,021h,022h,023h,024h,025h,026h,027h
  209.            db     028h,029h,02ah,02bh,02ch,02dh,02eh,02fh
  210.            db     030h,031h,032h,033h,034h,035h,036h,037h
  211.            db     038h,039h,03ah,03bh,03ch,03dh,03eh,03fh
  212.            db     040h,041h,042h,043h,044h,045h,046h,047h
  213.            db     048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
  214.            db     050h,051h,052h,053h,054h,055h,056h,057h
  215.            db     058h,059h,05ah,05bh,05ch,05dh,05eh,05fh
  216.            db     060h,041h,042h,043h,044h,045h,046h,047h
  217.            db     048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
  218.            db     050h,051h,052h,053h,054h,055h,056h,057h
  219.            db     058h,059h,05ah,07bh,07ch,07dh,07eh,07fh
  220.            db     080h,081h,082h,083h,084h,085h,086h,087h
  221.            db     088h,089h,08ah,08bh,08ch,08dh,08eh,08fh
  222.            db     090h,091h,092h,093h,094h,095h,096h,097h
  223.            db     098h,099h,09ah,09bh,09ch,09dh,09eh,09fh
  224.            db     0a0h,0a1h,0a2h,0a3h,0a4h,0a5h,0a6h,0a7h
  225.            db     0a8h,0a9h,0aah,0abh,0ach,0adh,0aeh,0afh
  226.            db     0b0h,0b1h,0b2h,0b3h,0b4h,0b5h,0b6h,0b7h
  227.            db     0b8h,0b9h,0bah,0bbh,0bch,0bdh,0beh,0bfh
  228.            db     0c0h,0c1h,0c2h,0c3h,0c4h,0c5h,0c6h,0c7h
  229.            db     0c8h,0c9h,0cah,0cbh,0cch,0cdh,0ceh,0cfh
  230.            db     0d0h,0d1h,0d2h,0d3h,0d4h,0d5h,0d6h,0d7h
  231.            db     0d8h,0d9h,0dah,0dbh,0dch,0ddh,0deh,0dfh
  232.            db     0e0h,0e1h,0e2h,0e3h,0e4h,0e5h,0e6h,0e7h
  233.            db     0e8h,0e9h,0eah,0ebh,0ech,0edh,0eeh,0efh
  234.            db     0f0h,0f1h,0f2h,0f3h,0f4h,0f5h,0f6h,0f7h
  235.            db     0f8h,0f9h,0fah,0fbh,0fch,0fdh,0feh,0ffh
  236.  
  237. WordScanTable  db     020h,020h,020h,020h,020h,020h,020h,020h
  238.            db     020h,020h,020h,020h,020h,020h,020h,020h
  239.            db     020h,020h,020h,020h,020h,020h,020h,020h
  240.            db     020h,020h,020h,020h,020h,020h,020h,020h
  241.            db     020h,021h,022h,023h,024h,025h,026h,027h
  242.            db     028h,029h,02ah,02bh,02ch,02dh,02eh,02fh
  243.            db     030h,031h,032h,033h,034h,035h,036h,037h
  244.            db     038h,039h,03ah,03bh,03ch,03dh,03eh,03fh
  245.            db     040h,041h,042h,043h,044h,045h,046h,047h
  246.            db     048h,049h,04ah,04bh,04ch,04dh,04eh,04fh
  247.            db     050h,051h,052h,053h,054h,055h,056h,057h
  248.            db     058h,059h,05ah,05bh,05ch,05dh,05eh,05fh
  249.            db     060h,061h,062h,063h,064h,065h,066h,067h
  250.            db     068h,069h,06ah,06bh,06ch,06dh,06eh,06fh
  251.            db     070h,071h,072h,073h,074h,075h,076h,077h
  252.            db     078h,079h,07ah,07bh,07ch,07dh,07eh,07fh
  253.            db     080h,081h,082h,083h,084h,085h,086h,087h
  254.            db     088h,089h,08ah,08bh,08ch,08dh,08eh,08fh
  255.            db     090h,091h,092h,093h,094h,095h,096h,097h
  256.            db     098h,099h,09ah,09bh,09ch,09dh,09eh,09fh
  257.            db     0a0h,0a1h,0a2h,0a3h,0a4h,0a5h,0a6h,0a7h
  258.            db     0a8h,0a9h,0aah,0abh,0ach,0adh,0aeh,0afh
  259.            db     0b0h,0b1h,0b2h,0b3h,0b4h,0b5h,0b6h,0b7h
  260.            db     0b8h,0b9h,0bah,0bbh,0bch,0bdh,0beh,0bfh
  261.            db     0c0h,0c1h,0c2h,0c3h,0c4h,0c5h,0c6h,0c7h
  262.            db     0c8h,0c9h,0cah,0cbh,0cch,0cdh,0ceh,0cfh
  263.            db     0d0h,0d1h,0d2h,0d3h,0d4h,0d5h,0d6h,0d7h
  264.            db     0d8h,0d9h,0dah,0dbh,0dch,0ddh,0deh,0dfh
  265.            db     0e0h,0e1h,0e2h,0e3h,0e4h,0e5h,0e6h,0e7h
  266.            db     0e8h,0e9h,0eah,0ebh,0ech,0edh,0eeh,0efh
  267.            db     0f0h,0f1h,0f2h,0f3h,0f4h,0f5h,0f6h,0f7h
  268.            db     0f8h,0f9h,0fah,0fbh,0fch,0fdh,0feh,0ffh
  269. ;
  270. ; Modified 4/21/93 to handle up to base 36!
  271. ;
  272. ValueTable     db     02ch    dup(0ffh)
  273.            db     0feh,0fdh,0feh,0ffh        ; skip , and .
  274.            db     0,1,2,3,4,5,6,7,8,9
  275.            db     007h    dup(0ffh)
  276.            db     10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
  277.            db     27,28,29,30,31,32,33,34,35
  278.            db     006h    dup(0ffh)
  279.            db     10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26
  280.            db     27,28,29,30,31,32,33,34,35
  281.            db     085h    dup(0ffh)
  282.  
  283.  
  284. strbuffer      db     104h dup(?)   ; temporary string buffer
  285. numbuffer      db     104h dup(?)   ; for number strings for debugging
  286.  
  287. number_fill    db     30h           ; '0'
  288. table          db     '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  289. Debug          dd     0             ; True if debugging
  290.  
  291. ExitCode       dd     0             ; Exit code passed to OS/2 after BYE
  292.  
  293. CommandStr     db     100h dup(?)
  294. CommandLen     EQU    $-CommandStr
  295.  
  296. OurStack       dd     STACK_SIZE dup(?)  ; should be big enough for a start
  297. FStackBase     dd     STACK_UNDERFLOW dup(?)   ; provide room for underflow
  298.  
  299. StackBase      dd      FStackBase    ; Holds base address of stack
  300. TickAbort      dd      VecAbort      ; Pointer to code for ABORT
  301.  
  302. CodeSpace      dd      0             ; Ptr to next avail. dictionary location
  303. NewWord        dd      ?             ; Header of very last word defined
  304.  
  305. CompileMode    dd      0             ; Non-zero if compiling
  306. LineNumber     dd      0             ; Line number of file being loaded
  307.  
  308. number_base    dd      10            ; Decimal
  309. OkVal          dd      0
  310. Value          dd      0
  311. Negative       dd      0
  312. DPL            dd      0
  313.  
  314. SysTo          dd      0          ; TO variables: 0=fetch; 1=store; -1=add
  315. OutPos         dd      0          ; Output position
  316. OutLine        dd      0          ; counts UP
  317. CharPerLine    dd      80
  318. MoreLength     dd      22
  319. MoreVector     dd      Pause
  320.  
  321. TickExecute    dd      _DoExecute
  322.  
  323. FoundAddr      dd      0
  324. Current        dd      ForthLink   ; Vocabulary where definitions are created
  325. Context        dd      ForthLink,SysLink, ContextSize dup (0)
  326.                ; Context is where searching dictionary starts
  327.  
  328. ForthLink      dd      0,LastForthWord,0       ; FORTH vocabulary pointer
  329. SysLink        dd      0,LastHeader,ForthLink  ; SYSTEM vocabulary pointer
  330. Voc_link       dd      SysLink           ; Pointer to last vocabulary created
  331.  
  332. FopenAction    dd      0
  333. FopenHandle    dd      0
  334. FopenName      db     "FORTH.INI",0
  335.            db      80 dup (?)
  336.  
  337. FileBufferSize =      16384
  338. FileBuffer     db     FileBufferSize dup (?)
  339.  
  340. Date1          equ    <>
  341. Date1          CatStr <">, @Date, <">
  342.  
  343. Paren1         equ    <>
  344. Paren1         CatStr <(>
  345.  
  346. MESSAGE        Version,"Compiled: ",Date1,")",CrLf
  347.  
  348.  
  349. InputBufferSize =      1024
  350. InputSpace     db      InputBufferSize dup (?)
  351. InputBuffer    dd      Offset InputSpace
  352. InputCount     dd      0
  353. InputOffset    dd      0
  354.  
  355. LastWordEnd    dd      0
  356.  
  357. ;
  358. ; END OF FORTH SOURCE.....
  359. ;
  360.  
  361.            .CODE
  362.  
  363. BREAK          MACRO
  364.            Call   Do_Breakpoint
  365.            ENDM
  366.  
  367. IMMEDIATE      EQU     1
  368. COMPILEONLY    EQU     2
  369. HIDDEN         EQU     4
  370.  
  371.  
  372. _HEADER        STRUC
  373.   Prev           DWORD  ?
  374.   Flags          DWORD  ?     ; Not immediate, function call
  375.   CodePointer    DWORD  ?
  376.   NameSize       DWORD  ?
  377.   ThisName       BYTE   20h dup (?)
  378. _HEADER        ENDS
  379.  
  380.  
  381. LASTHEADER     =       0
  382.  
  383. CodeDef        MACRO   ThisName:Req,Flg := <0>
  384.            LOCAL   ThisOne,ThisCode
  385.  
  386.   ThisOne      _HEADER { LastHeader, (Flg), ThisCode,@SIZESTR(ThisName)-2,ThisName }
  387.   LASTHEADER   =       ThisOne
  388.  
  389.   ThisCode:
  390.            ENDM
  391.  
  392.            .code
  393. ;*****************************************
  394. ;*                                       *
  395. ;*            CORE VOCABULARY            *
  396. ;*                                       *
  397. ;*****************************************
  398.  
  399.                CodeDef 'NOP'
  400. DoNothing:     ret
  401.  
  402.            CodeDef '!'
  403. Store:         mov     edx,[ebx  ] ; value addr .... poke
  404.            mov     eax,[ebx+4]
  405.            mov     [edx],eax
  406.            add     ebx,8       ; pop both values
  407.            ret
  408.  
  409.            CodeDef "'"              ; Tick, return address of next word
  410. Tick:          mov     eax,' '
  411.            PushForth
  412.            Call    _Word
  413.            Call    _Find
  414.            PullForth
  415.            and     eax,eax
  416.            jz      @f
  417.            ret
  418.  
  419. @@:            lea     edx,What1Msg
  420.            call    WriteStr
  421.            call    _Count
  422.            call    _Type
  423.            lea     edx,What2Msg
  424.            call    WriteStr
  425.            jmp     Abort
  426.  
  427.  
  428. _Comment       _Header { LastHeader, Immediate, Do_Comment, 1, '(' }
  429. LastHeader     =       _Comment
  430.  
  431.  
  432. Do_Comment:    mov     esi,InputBuffer
  433.            add     esi,InputOffset
  434.            mov     ecx,InputCount
  435.            sub     ecx,InputOffset
  436.            jbe     CommentDone
  437.  
  438. @@:            lodsb
  439.            cmp     al,')'
  440.            loopne  @b
  441.  
  442. CommentDone:   sub     esi,Inputbuffer
  443.            mov     inputoffset,esi
  444.            ret
  445.  
  446.  
  447.  
  448.            CodeDef '*'
  449.            PULLFORTH
  450.            imul    eax,[ebx]
  451.            mov     [ebx],eax
  452.            ret
  453.  
  454.            CodeDef '*/'           ; ( a b c -- a*b/c )
  455.                mov     eax,[ebx+8]
  456.                mov     edx,[ebx+4]
  457.                mov     ecx,[ebx+0]
  458.                or      ecx,ecx
  459.                jz      DivByZero
  460.                add     ebx,8          ; we eat 2 more than we make
  461.                imul    edx
  462.                idiv    ecx
  463.                mov     [ebx+0],eax
  464.            ret
  465.  
  466.            CodeDef '*/MOD'        ; ( a b c -- a*b/c a*b mod c )
  467.                mov     eax,[ebx+8]
  468.                mov     edx,[ebx+4]
  469.                mov     ecx,[ebx+0]
  470.                or      ecx,ecx
  471.                jz      DivByZero
  472.                add     ebx,4          ; we eat 2 more than we make
  473.                imul    edx
  474.                idiv    ecx
  475.                mov     [ebx+4],edx    ; remainder
  476.                mov     [ebx+0],eax    ; quotient  on "TOP"
  477.            ret
  478.  
  479.            CodeDef '+'
  480.            PULLFORTH
  481.            add     [ebx],eax
  482.            ret
  483.  
  484.            CodeDef '+!'          ; ( n addr -- ) adds n to addr
  485. PlusStore:     mov     edx,[ebx  ]
  486.            mov     eax,[ebx+4]
  487.            add     [edx],eax
  488.            add     ebx,8
  489.            ret
  490.  
  491.            CodeDef ','           ; ( Compiles a CELL )
  492. Comma:         cld
  493.            PULLFORTH
  494.            stosd
  495.            mov     CodeSpace,EDI
  496.            ret
  497.  
  498.            CodeDef '-'           ; ( n1 n2 -- n1-n2 )
  499.            PULLFORTH
  500.            sub     [ebx],eax
  501.            ret
  502.  
  503.            CodeDef '."',3           ; Immediate, Compile Only
  504.            Call    S_Quote
  505.            lea     eax,_Type
  506.            PushForth
  507.            call    Do_CompileCall
  508.            ret
  509.  
  510.            CodeDef '/'
  511.            PULLFORTH
  512.            or      eax,eax
  513.            jz      DivByZero
  514.            xchg    eax,[ebx]
  515.            CDQ                     ; convert AX to DX:AX
  516.            idiv    DWORD PTR[ebx]
  517.            mov     [ebx],eax
  518.            ret
  519.  
  520.            CodeDef '/MOD'          ; ( a b -- {a mod b}  {a div b} )
  521.            mov     eax,[ebx]       ; one up on the stack
  522.            or      eax,eax
  523.            jz      DivByZero
  524.            xchg    eax,[ebx+4]
  525.            CDQ                     ; convert AX to DX:AX
  526.            idiv    DWORD PTR[ebx+4]
  527.            mov     [ebx],eax       ; Store quotient
  528.            mov     [ebx+4],edx     ; Store remainder
  529.            ret
  530.  
  531.            CodeDef 'SM/REM'        ; ( D n -- {D mod n}  {D div n} )
  532.                push    ecx
  533.                push    edx
  534.                PullForth
  535.                mov     ecx,eax         ; ecx <-- n
  536.                PullForth
  537.                mov     edx,eax         ; Top half in edx
  538.                PullForth               ; bottom in eax
  539.                idiv    ecx
  540.                xchg    eax,edx         ; swap the result order
  541.                PushForth
  542.                mov     eax,edx
  543.                PushForth               ; push the other answer
  544.                pop     edx
  545.                pop     ecx
  546.                ret
  547.  
  548.            CodeDef 'UM/MOD'        ; ( D n -- {D mod n}  {D div n} )
  549.                push    ecx
  550.                push    edx
  551.                PullForth
  552.                mov     ecx,eax         ; ecx <-- n
  553.                PullForth
  554.                mov     edx,eax         ; Top half in edx
  555.                PullForth               ; bottom in eax
  556.                div     ecx
  557.                xchg    eax,edx         ; swap the result order
  558.                PushForth
  559.                mov     eax,edx
  560.                PushForth               ; push the other answer
  561.                pop     edx
  562.                pop     ecx
  563.                ret
  564.  
  565.                CodeDef 'FM/MOD'        ; ( D n -- {D mov n}  {D div n} )
  566.                push    ecx
  567.                push    edx
  568.                mov     ecx,[ebx+0]     ; n is on "top"
  569.                mov     edx,[ebx+4]     ; D msw
  570.                mov     eax,[ebx+8]     ; D lsw
  571.                add     ebx,4           ; we will consume 1 more than we make
  572.  
  573.                or      ecx,ecx
  574.                jz      DivByZero       ; don't even attempt it if = 0
  575.                js      @f
  576.                or      edx,edx
  577.                jns     DivQ1           ; +/+
  578.                jmp     DivQ2           ; -/+
  579.  
  580. @@:            or      edx,edx
  581.                jns     DivQ3           ; +/-
  582.                jmp     DivQ4           ; -/-
  583.  
  584.  
  585. DivQ1:         div     ecx             ; +/+, simple math
  586. DivDone:       mov     [ebx+0],eax
  587.                mov     [ebx+4],edx
  588.                pop     edx
  589.                pop     ecx
  590.                ret
  591.  
  592.  
  593. DivQ2:         not     eax             ; -/+   Negate EDX:EAX
  594.                not     edx
  595.                add     eax,1
  596.                adc     edx,0
  597.                div     ecx
  598.                neg     eax             ; neg quotient
  599.                or      edx,edx
  600.                jz      @f
  601.                sub     edx,ecx         ; dec remainder my divisor
  602.                dec     eax             ; dec quotient by 1
  603.                neg     edx             ; negate divisor
  604. @@:            jmp     DivDone
  605.  
  606. DivQ3:         neg     ecx             ; +/-   Negate cx
  607.                div     ecx
  608.                neg     eax             ; neg quotient
  609.                or      edx,edx
  610.                jz      @f
  611.                sub     edx,ecx         ; dec remainder my divisor
  612.                dec     eax             ; dec quotient by 1
  613. @@:            jmp     DivDone
  614.  
  615. DivQ4:         neg     ecx             ; -/-   Negate cx
  616.                not     eax             ; negate dx:ax, 1's comp
  617.                not     edx
  618.                add     eax,1           ; and add +1
  619.                adc     edx,0
  620.                div     ecx             ; do the division
  621.                neg     edx             ; negate remainder
  622.                jmp     DivDone         ; whew!
  623.  
  624.  
  625.  
  626.  
  627.  
  628.            CodeDef '0<'
  629.            xor     eax,eax
  630.            jmp     LessThan
  631.  
  632.            CodeDef '0='            ; returns true if A = 0
  633.            xor     eax,eax
  634.            cmp     eax,[ebx]
  635.            jnz     @f
  636.            not     eax
  637. @@:            mov     [ebx],eax
  638.            ret
  639.  
  640.            CodeDef '1+'
  641.            mov     eax,1
  642.            add     [ebx],eax
  643.            ret
  644.  
  645.            CodeDef '1-'
  646.            mov     eax,1
  647.            sub     [ebx],eax
  648.            ret
  649.  
  650.            CodeDef '2!'    ; ( x1 x2 a-addr -- )
  651.            mov     edx,[ebx]            ; MAW - ANSforth Fix 10/23/93
  652.            mov     eax,[ebx+4]
  653.            mov     [edx],eax
  654.            mov     eax,[ebx+8]
  655.            mov     [edx+4],eax
  656.            add     ebx,12
  657.            ret
  658.  
  659.            CodeDef '2*'
  660.            shl     DWORD PTR[ebx],1
  661.            ret
  662.  
  663.            CodeDef '2/'
  664.            sar     DWORD PTR[ebx],1     ; MAW - ANSforth Fix 6/8/93
  665.            ret
  666.  
  667.            CodeDef '2@'
  668.                PullForth                    ; MAW - ANSforth Fix 10/23/93
  669.                mov     edx,eax
  670.                mov     eax,[edx+4]
  671.                PushForth
  672.                mov     eax,[edx]
  673.                PushForth
  674.            ret
  675.  
  676.            CodeDef '2DROP'
  677.            add     ebx,8
  678.            ret
  679.  
  680.            CodeDef '2DUP'
  681.            mov     eax,[ebx+4]
  682.            mov     edx,[ebx]
  683.            PushForth
  684.            sub     ebx,4
  685.            mov     [ebx],edx
  686.            ret
  687.  
  688.            CodeDef '2OVER'
  689.            mov     eax,[ebx+12]
  690.            mov     ecx,[ebx+8]
  691.            sub     ebx,8
  692.            mov     [ebx],ecx
  693.            mov     [ebx+4],eax
  694.            ret
  695.  
  696.            CodeDef '2SWAP'
  697.            mov     ecx,[ebx]
  698.            mov     edx,[ebx+4]
  699.            mov     eax,[ebx+8]
  700.            mov     [ebx],eax
  701.            mov     eax,[ebx+12]
  702.            mov     [ebx+4],eax
  703.            mov     [ebx+8],ecx
  704.            mov     [ebx+12],edx
  705.            ret
  706.  
  707.            CodeDef ':'
  708. Do_Colon:      mov     eax,CompileMode
  709.            or      eax,eax
  710.            jnz     NoSemicolon
  711.            mov     EDI,CodeSpace
  712.            mov     NewWord,EDI
  713.            cld
  714.            mov     eax,Current
  715.            mov     eax,[eax+VocLinkOffset]
  716.            stosd                    ; Store the pointer to previous
  717.            mov     eax,0            ; Flags to store
  718.            stosd                    ; Store the Words flags
  719.            mov     eax,0            ; Execution Address (0 for now)
  720.            push    edi              ; save this address for a while
  721.            stosd                    ; Store the code address
  722.            mov     edx,edi
  723.            mov     eax,' '
  724.            PushForth
  725.            Call    _Word            ; Get string, stored at EDI!
  726.            mov     edi,LastWordEnd  ; Get the end of the string
  727.            Call    ToUpper          ; (Uses address from forth stack)
  728.            pop     eax              ; Get the place to stuff code address
  729.  
  730.            mov     edi,eax          ; Fix so headers are always
  731.            add     edi,024h         ; the same size
  732.  
  733.            mov     [eax],edi        ; Update the code address
  734.            mov     CompileMode,1    ; We are now in compile mode
  735.            ret                      ; done for now
  736.  
  737.                CodeDef ':NONAME'
  738. Colon_NoName:  mov     eax,CompileMode
  739.            or      eax,eax
  740.            jnz     NoSemicolon
  741.            mov     EDI,CodeSpace
  742.                mov     eax,edi          ; Get adress of start in eax
  743.                PushForth
  744.                mov     CompileMode,1
  745.                ret
  746.  
  747. NoSemicolon:   lea     edx,SemicolonMsg
  748.            call    WriteStr
  749.            call    WriteLineNum
  750.            jmp     Abort
  751.  
  752.            CodeDef ';',3
  753. Do_SemiColon:
  754.            call    CompileCheck     ; finish a definition
  755.            call    Do_CompileRet    ; update codespace
  756.            mov     CodeSpace,EDI
  757.            mov     eax,NewWord      ; update the dictionary
  758.            mov     edx,Current
  759.            mov     [edx+VocLinkOffset],eax ; update Current vocab ptr
  760.            mov     CompileMode,0    ; back out of compile mode
  761.            ret
  762.  
  763. Do_CompileRet:                         ; compiles a RET instruction
  764.            mov     al,0C3h
  765.            stosb
  766.            ret
  767.  
  768.            CodeDef '<'             ; i.e. 0 0 <
  769.            pullforth               ; eax = stack top 0
  770. LessThan:      cmp     eax,[ebx]       ; subtract 0 --> -1 (carry set)
  771.            mov     eax,0           ; eax = 0
  772.            jle     @f
  773.            dec     eax
  774. @@:            mov     [ebx],eax
  775.            ret
  776.  
  777.            CodeDef '='             ; returns true if A = B
  778.            pullforth
  779.            cmp     eax,[ebx]
  780.            mov     eax,0
  781.            jnz     @f
  782.            not     eax
  783. @@:            mov     [ebx],eax
  784.            ret
  785.  
  786.            CodeDef '>'             ; i.e. 9 4 >
  787.            pullforth               ; eax = stack top 4
  788. GreaterThan:   cmp     eax,[ebx]       ; subtract 9 --> -5 (carry set)
  789.            mov     eax,0           ; eax = 0
  790.            jge     @f
  791.            dec     eax
  792. @@:            mov     [ebx],eax
  793.            ret
  794.  
  795.            CodeDef '>BODY'         ; ( xt -- a-addr )
  796.            PullForth               ; do an execute
  797.            cmp     byte ptr[eax],0E8h
  798.            jnz     @f
  799.                add     eax,5
  800.                PushForth
  801.                ret
  802.  
  803. @@:            lea     edx,NotCreateWordMsg
  804.            call    WriteStr
  805.            jmp     Abort
  806.  
  807.            CodeDef '>IN'           ; Address of offset into buffer
  808.            lea     eax,InputOffset
  809.            pushForth
  810.            ret
  811.  
  812.            CodeDef '>R'       ; moves top of stack to return stack
  813.            pop     edx        ; our return address
  814.            PULLFORTH
  815.            push    eax        ; push number onto return stack
  816.            push    edx        ; restore return address and push on stack
  817.            ret
  818.  
  819.            CodeDef '?DUP'      ; Duplicates if true
  820.            mov     eax,[ebx]
  821.            or      eax,eax
  822.            jz      @f
  823.            PushForth
  824. @@:            ret
  825.  
  826.            CodeDef '@'
  827. Fetch:         mov     eax,[ebx  ]
  828.            mov     eax,[eax  ]
  829.            mov     [ebx  ],eax
  830.            ret
  831.  
  832.            CodeDef 'ABS'          ; ( a -- |a| )
  833.            mov     eax,[ebx]
  834.            and     eax,eax
  835.            jns     @f
  836.            neg     eax
  837.            mov     [ebx],eax
  838. @@:            ret
  839.  
  840.            CodeDef 'ACCEPT'     ; ( c-addr n1 -- n2 ) Get a string from
  841.                     ; standard input, using READ
  842. _Accept:       mov     edx,[ebx+4]  ; Buffer address in EDX
  843.            mov     eax,[ebx]    ; Buffer size in eax
  844.            add     ebx,4        ; consume 1 param, replace second
  845.            pushad               ; save all the registers
  846.            push    ebx          ; Return parameter is bytes read
  847.            push    eax          ; Size of buffer
  848.            push    edx          ; Buffer area
  849.            pushd   STDIN
  850.            call    Dos32Read
  851.            add     esp,16
  852.            or      eax,eax
  853.            jnz     IOerror
  854.            popad
  855.            ret
  856.  
  857.            CodeDef 'ALIGN'      ; ( -- )
  858.            sub     ebx,4
  859.            mov     [ebx],edi
  860.            call    Aligned
  861.            mov     edi,[ebx]
  862.            add     ebx,4
  863.            mov     CodeSpace,edi
  864.            ret
  865.  
  866.            CodeDef 'ALIGNED'    ; ( addr -- a-addr )
  867. Aligned:       mov     eax,[ebx]
  868.            and     eax,3
  869.            sub     eax,4
  870.            neg     eax
  871.            and     eax,3
  872.            add     [ebx],eax
  873.            ret
  874.  
  875.            CodeDef 'ALLOT'          ; add N bytes to the latest entry
  876. Allot:         PULLFORTH
  877.            add     EDI,EAX
  878.            mov     CodeSpace,EDI
  879.            ret
  880.  
  881.            CodeDef 'AND'
  882.            PULLFORTH
  883.            AND     [ebx],eax
  884.            ret
  885.  
  886.            CodeDef 'BASE'
  887.            lea     eax,Number_Base
  888.            PUSHFORTH
  889.            ret
  890.  
  891.            CodeDef 'BL'
  892.            mov     eax,' '
  893.            PUSHFORTH
  894.            ret
  895.  
  896.            CodeDef 'C!'
  897.            mov     edx,[ebx  ]      ; value addr .... poke
  898.            mov     eax,[ebx+4]
  899.            mov     [edx],al
  900.            add     ebx,8            ; pop both values
  901.            ret
  902.  
  903.            CodeDef 'C,'
  904.            cld
  905.            PULLFORTH
  906.            stosb
  907.            mov     CodeSpace,EDI
  908.            ret
  909.  
  910.            CodeDef 'C@'
  911.            mov     eax,[ebx  ]
  912.            mov     eax,[eax  ]
  913.            and     eax,00ffh
  914.            mov     [ebx  ],eax
  915.            ret
  916.  
  917.            CodeDef 'CELL+'
  918.            mov     eax,[ebx]
  919.            add     eax,4
  920.            mov     [ebx],eax
  921.            ret
  922.  
  923.            CodeDef 'CELLS'       ; multiplies by word size, 4
  924. WTimes:        shl     DWORD PTR [ebx],2
  925.            ret
  926.  
  927.            CodeDef 'CHAR'        ; ( "name" -- char )
  928. DoChar:        mov     eax,' '
  929.            PushForth
  930.            call    _Word
  931.                mov     edx,[ebx]
  932.                xor     eax,eax
  933.                mov     al,[edx+4]
  934.                mov     [ebx],eax
  935.            ret
  936.  
  937.            CodeDef 'CHAR+'
  938.            inc     dword ptr[ebx]
  939.            ret
  940.  
  941.            CodeDef 'CHARS'
  942.            ret
  943.  
  944.            CodeDef 'CONSTANT'       ; Declare a constant
  945. Do_Constant:   mov     EDI,CodeSpace
  946.            mov     NewWord,EDI      ; Save start of word
  947.            cld
  948.            mov     eax,Current
  949.            mov     eax,[eax+VocLinkOffset]
  950.            stosd                    ; Store the pointer to previous
  951.            mov     eax,0            ; Flags to store
  952.            stosd                    ; Store the Words flags
  953.            mov     eax,0            ; Execution Address (0 for now)
  954.            push    edi              ; save this address for a while
  955.            stosd                    ; Store the code address
  956.            mov     edx,edi
  957.            mov     eax,' '
  958.            PushForth
  959.            Call    _Word            ; Get string, stored at EDI!
  960.            mov     edi,LastWordEnd  ; Get the end of the string
  961.            Call    ToUpper          ; (Uses address from forth stack)
  962.            pop     eax              ; Get the place to stuff code address
  963.            mov     [eax],edi        ; Update the code address
  964.  
  965.            mov     al,0E8h          ; Call ABSOLUTE
  966.            stosb
  967.            lea     eax,DoesConstant ; Address of DoesConst routine
  968.            sub     eax,EDI          ; subtract current EIP
  969.            sub     eax,4            ; subtract 4 for upcoming offset
  970.            STOSD
  971.  
  972.            PULLFORTH                ; Store the constant
  973.            STOSD
  974.  
  975.            mov     eax,NewWord      ; update the dictionary
  976.            mov     edx,Current
  977.            mov     [edx+VocLinkOffset],eax
  978.            mov     CodeSpace,EDI
  979.            ret                      ; done for now
  980.  
  981. DoesConstant:  pop     eax
  982.            mov     eax,[eax]
  983.            PUSHFORTH
  984.            ret
  985.  
  986.            CodeDef 'CR'
  987. DoCr:          lea     edx,CrLfStr       ; Write a CR/LF pair
  988.            call    WriteStr
  989.            xor     eax,eax
  990.            mov     DWORD PTR OutPos,eax
  991.                inc     DWORD PTR OutLine
  992.            ret
  993.  
  994.            CodeDef 'CREATE'         ; Creates a 0 byte variable
  995. Create:        mov     EDI,CodeSpace
  996.            mov     NewWord,EDI      ; Save start of word
  997.            cld
  998.            mov     eax,Current
  999.            mov     eax,[eax+VocLinkOffset]
  1000.            stosd                    ; Store the pointer to previous
  1001.            mov     eax,0            ; Flags to store
  1002.            stosd                    ; Store the Words flags
  1003.            mov     eax,0            ; Execution Address (0 for now)
  1004.            push    edi              ; save this address for a while
  1005.            stosd                    ; Store the code address
  1006.            mov     edx,edi
  1007.            mov     eax,' '
  1008.            PushForth
  1009.            Call    _Word            ; Get string, stored at EDI!
  1010.            mov     edi,LastWordEnd  ; Get the end of the string
  1011.            Call    ToUpper          ; (Uses address from forth stack)
  1012.            pop     eax              ; Get the place to stuff code address
  1013.            mov     [eax],edi        ; Update the code address
  1014.  
  1015.            mov     al,0E8h          ; Call ABSOLUTE
  1016.            stosb
  1017.            lea     eax,DoesVariable ; Address of DoesConst routine
  1018.            sub     eax,EDI          ; subtract current EIP
  1019.            sub     eax,4            ; subtract 4 for upcoming offset
  1020.            stosd
  1021.  
  1022.            mov     CodeSpace,EDI
  1023.            mov     eax,NewWord      ; update the dictionary
  1024.            mov     edx,Current
  1025.            mov     [edx+VocLinkOffset],eax
  1026.            ret                      ; done for now
  1027.  
  1028.  
  1029.  
  1030.            CodeDef 'COUNT'     ; ( addr -- addr+4 [addr] )
  1031. _Count:        mov     edx,[ebx]
  1032.            xor     eax,eax
  1033.            mov     eax,[edx]
  1034.            add     DWORD PTR [ebx],4
  1035.            PushForth
  1036.            ret
  1037.  
  1038.            CodeDef 'DECIMAL'
  1039.            mov     eax,10
  1040.            mov     Number_Base,eax
  1041.            ret
  1042.  
  1043.            CodeDef 'DEPTH'
  1044.            mov     eax,StackBase
  1045.            sub     eax,ebx         ; Forth Stack depth in EAX
  1046.            clc
  1047.            shr     eax,2           ; divide by entry size
  1048.            PUSHFORTH
  1049.            ret
  1050.  
  1051.            CodeDef 'DROP'
  1052. Drop:          add     ebx,4           ; Drop Stack top
  1053.            ret
  1054.  
  1055.            CodeDef 'DUP'
  1056.            mov     eax,[ebx]
  1057.            PUSHFORTH
  1058.            ret
  1059.  
  1060.            CodeDef 'EMIT'           ; Quite large, isn't it?
  1061. Do_Emit:       push    ebp
  1062.            push    edi
  1063.            push    esi
  1064.            push    edx
  1065.            push    ecx
  1066.            mov     eax,esp          ; save current ss, esp
  1067.            push    ss               ; for return from 16-bit land
  1068.            push    eax
  1069.  
  1070.            mov     ecx,OutPos
  1071.            inc     ecx
  1072.            mov     OutPos,ecx
  1073.  
  1074.            PULLFORTH
  1075.  
  1076.            push    eax
  1077.            mov     eax,esp          ; character stored at [EAX]
  1078.            call    DosFlatToSel
  1079.            push    eax              ; address of string
  1080.            pushw   1                ; length of string
  1081.            pushw   0                ; vio handle (0 = default)
  1082.  
  1083.            mov     eax,esp          ; convert stack so 16-bit can use it
  1084.            ror     eax,16
  1085.            shl     eax,3
  1086.            or      al,7             ; convert to ring-3 tiled segment
  1087.            mov     ss,eax
  1088.  
  1089.            jmp     far ptr Do_Emit16
  1090.  
  1091. Do_Emit2       label   far
  1092.            movzx   eax,ax           ; convert return code to 32-bit
  1093.  
  1094. ; Restore 32-bit SS:ESP - it is on top of stack.
  1095.            movzx   esp,sp           ; make sure that esp is correct
  1096.            lss     esp,[esp]
  1097.            pop     ecx
  1098.            pop     edx
  1099.            pop     esi
  1100.            pop     edi
  1101.            pop     ebp
  1102.            ret
  1103.  
  1104.            CodeDef '<EXECUTE>'      ; The REAL execute
  1105. _DoExecute:    PullForth
  1106.            jmp     eax
  1107.  
  1108.            CodeDef "'EXECUTE"       ; Gives address of vector
  1109.            lea     eax,TickExecute
  1110.            PushForth
  1111.            ret
  1112.  
  1113.            CodeDef 'EXECUTE'        ; ( addr -- )
  1114. _Execute:      mov     eax,TickExecute
  1115.            jmp     eax              ; Jump to address specified
  1116.  
  1117.            CodeDef 'FIND'           ; ( c-addr -- c-addr 0 | xt 1 | xt -1 )
  1118. _Find:         mov     edx,[ebx]        ; copy out of the stack, don't destroy
  1119.            call    LookFor
  1120.            mov     eax,FoundAddr
  1121.            or      eax,eax
  1122.            jz      FindDone
  1123.                mov     ecx,eax
  1124.            mov     edx,[ecx].CodePointer
  1125.                mov     [ebx],edx        ; overwrite with execution address
  1126.            mov     edx,[ecx].Flags
  1127.            and     edx,IMMEDIATE
  1128.            jnz     FindImm
  1129.            mov     eax,-1
  1130.            jmp     FindDone
  1131. FindImm:       mov     eax,1
  1132. FindDone:      PushForth
  1133.            ret
  1134.  
  1135.  
  1136.            CodeDef 'FILL'    ; ( addr n b -- ) fills n bytes at addr with b
  1137.            mov     eax,[ebx+4]
  1138.            cmp     eax,1      ; not defined for n < 1
  1139.            jl      @f
  1140.            push    edi
  1141.            mov     ecx,eax
  1142.            mov     eax,[ebx]
  1143.            mov     edi,[ebx+8]
  1144.            rep stosb
  1145.            pop     edi
  1146. @@:            add     ebx,12
  1147.            ret
  1148.  
  1149.            CodeDef 'HERE'
  1150.            mov     eax,EDI
  1151.            PushForth
  1152.            ret
  1153.  
  1154.            CodeDef 'I'         ; copies number from return stack to top of stack
  1155.            mov     eax,[esp+4] ; Get the data
  1156.            PUSHFORTH
  1157.            ret
  1158.  
  1159.            CodeDef 'IMMEDIATE'
  1160.            mov     eax,Current
  1161.            mov     eax,[eax+VocLinkOffset]
  1162.            or      [EAX].Flags,Immediate
  1163.            ret
  1164.  
  1165.            CodeDef 'INVERT'       ; 1s complement
  1166.            not     dword ptr[ebx]
  1167.            ret
  1168.  
  1169.            CodeDef 'J'         ; 1 loop up
  1170.            mov     eax,[esp+12] ; return, index, limit, index
  1171.            PushForth
  1172.            ret
  1173.  
  1174.            CodeDef 'KEY'
  1175. GetKey:           mov     eax,0
  1176.            PushForth
  1177.            call    Do_Getkey
  1178.            ret
  1179.  
  1180.            CodeDef 'KEYNOWAIT'
  1181.            mov     eax,1
  1182.            PushForth
  1183.            call    Do_Getkey
  1184.            ret
  1185.  
  1186. ;               CodeDef '(KEY)'           ; New version of KEY
  1187. Do_GetKey:     PUSHAD
  1188.            mov     eax,esp          ; save current ss, esp
  1189.            push    ss               ; for return from 16-bit land
  1190.            push    eax
  1191.  
  1192.            lea     eax,ascii
  1193.            mov     word ptr [eax],0
  1194.            call    DosFlatToSel
  1195.            push    eax              ; 8 bytes of parameters
  1196.            PullForth
  1197.            and     eax,1
  1198.            push    ax               ; Wait flag, etc.
  1199.            mov     eax,0
  1200.            push    ax               ; Handle 0
  1201.  
  1202.            mov     eax,esp          ; convert stack so 16-bit can use it
  1203.            ror     eax,16
  1204.            shl     eax,3
  1205.            or      al,7             ; convert to ring-3 tiled segment
  1206.            mov     ss,eax
  1207.            jmp     far ptr Do_GetKey16
  1208.  
  1209. Do_GetKey2     label   far              ; Restore 32-bit SS:ESP - it is on top of stack.
  1210.            movzx   esp,sp           ; make sure that esp is correct
  1211.            lss     esp,[esp]
  1212.            POPAD
  1213.            xor     eax,eax
  1214.            mov     ax,word ptr[ascii]
  1215.            mov     [ebx],eax        ; Replace stack contents
  1216.            ret
  1217.  
  1218.            CodeDef 'LITERAL',3
  1219. _Literal:      cld                      ; mov eax,literal
  1220.            mov     al,0b8h
  1221.            stosb
  1222.            PULLFORTH
  1223.            stosd
  1224.  
  1225.            mov     al,083h          ; sub ebx,4
  1226.            stosb
  1227.            mov     al,0ebh
  1228.            stosb
  1229.            mov     al,004h
  1230.            stosb
  1231.  
  1232.            mov     al,089h          ; mov [ebx],eax
  1233.            stosb
  1234.            mov     al,003h
  1235.            stosb
  1236.            ret
  1237.  
  1238.            CodeDef 'LSHIFT'     ; ( n1 n2 -- n3 ) Shift n1 left n2 times
  1239.            mov     ecx,[ebx]
  1240.            add     ebx,4
  1241.            shl     DWORD PTR [ebx],cl
  1242.            ret
  1243.  
  1244.            CodeDef 'M*'        ; ( n1 n2 -- d )
  1245.            mov     eax,[ebx+4]
  1246.            imul    DWORD PTR[ebx]
  1247.            mov     [ebx],edx
  1248.            mov     [ebx+4],eax
  1249.            ret
  1250.  
  1251.            CodeDef 'MAX'          ; ( a b -- max )
  1252.            PullForth
  1253.            cmp     eax,[ebx]
  1254.            jl      @f
  1255.            mov     [ebx],eax
  1256. @@:            ret
  1257.  
  1258.            CodeDef 'MIN'          ; ( a b -- min )
  1259.            PullForth
  1260.            cmp     eax,[ebx]
  1261.            jg      @f
  1262.            mov     [ebx],eax
  1263. @@:            ret
  1264.  
  1265.            CodeDef 'MOD'
  1266.            PULLFORTH
  1267.            or      eax,eax
  1268.            jz      DivByZero
  1269.            xchg    eax,[ebx]
  1270.            CDQ                     ; convert AX to DX:AX
  1271.            idiv    DWORD PTR[ebx]
  1272.            mov     [ebx],edx       ; put MODULUS on stack
  1273.            ret
  1274.  
  1275.            CodeDef 'MOVE'      ; ( addr1 addr2 u -- )
  1276.            mov     eax,[ebx+8]
  1277.            cmp     eax,[ebx+4]
  1278.            ja      Cmove
  1279.            add     eax,[ebx]
  1280.            cmp     eax,[ebx+4] ; cmp  addr1+u,addr2
  1281.            jg      CmoveBack
  1282.            jmp     Cmove
  1283.  
  1284.            CodeDef 'NEGATE'       ; ( a -- -a )
  1285.            neg     DWORD PTR[ebx]
  1286.            ret
  1287.  
  1288.            CodeDef 'OR'
  1289.            PULLFORTH
  1290.            OR      [ebx],eax
  1291.            ret
  1292.  
  1293.            CodeDef 'OVER'
  1294.            mov     eax,[ebx+4]     ; duplicate one entry down...
  1295.            PUSHFORTH
  1296.            ret
  1297.  
  1298.            CodeDef 'QUIT'
  1299. Quit:          mov     esp,SavedESP
  1300.            call    StackCheck
  1301.            call    Prompt
  1302.            Call    Query
  1303.            call    Interpret
  1304.            jmp     Quit
  1305.  
  1306.            CodeDef 'R>'       ; moves number from return stack to top of stack
  1307.            pop     edx        ; our return address
  1308.            pop     eax        ; number we want
  1309.            push    edx        ; restore return address and push on stack
  1310.            PUSHFORTH
  1311.            ret
  1312.  
  1313.            CodeDef 'R@'       ; Copies contents of return stack
  1314.            mov     eax,[esp+4]
  1315.            PushForth
  1316.            ret
  1317.  
  1318.            CodeDef 'RECURSE',3      ; Call the NEW word
  1319.            Call    CompileCheck
  1320.            mov     eax,NewWord
  1321.            mov     eax,[eax].codepointer
  1322.            PushForth
  1323.            Call    Do_CompileCall
  1324.            ret
  1325.  
  1326.            CodeDef 'ROT'
  1327.            mov     eax,[ebx]       ; take top, move it down 2 levels
  1328.            xchg    eax,[ebx+4]
  1329.            xchg    eax,[ebx+8]
  1330.            mov     [ebx],eax
  1331.            ret
  1332.  
  1333.            CodeDef 'RSHIFT'     ; ( n1 n2 -- n3 ) Shift n1 left n2 times
  1334.            mov     ecx,[ebx]
  1335.            add     ebx,4
  1336.            shr     DWORD PTR[ebx],cl
  1337.            ret
  1338.  
  1339.  
  1340.            CodeDef 'S"',3           ; Generates an INLINE string
  1341. S_Quote:       Call    CompileCheck
  1342.            lea     eax,Inline_String
  1343.            PushForth
  1344.            Call    Do_CompileCall
  1345.  
  1346.            mov     eax,'"'          ; get string, stored HERE!
  1347.            PushForth
  1348.            Call    _Word            ; Get string, stored at EDI!
  1349.            mov     edi,LastWordEnd  ; Get the end of the string
  1350.            PullForth
  1351.            ret
  1352.  
  1353.            CodeDef 'S>D'       ; ( n -- d )
  1354.            xor     eax,eax
  1355.            mov     edx,[ebx]
  1356.            or      edx,edx
  1357.            js      S2D1
  1358.            PUSHFORTH
  1359.            ret
  1360. S2D1:          dec     eax
  1361.            PUSHFORTH
  1362.            ret
  1363.  
  1364.            CodeDef 'SOURCE'     ; Returns input buffer address and count
  1365.            mov     eax,InputBuffer
  1366.            PushForth
  1367.            mov     eax,InputCount
  1368.            PushForth
  1369.            ret
  1370.  
  1371.            CodeDef 'STATE'
  1372.            lea     eax,CompileMode
  1373.            PUSHFORTH
  1374.            ret
  1375.  
  1376.            CodeDef 'SPACE'
  1377.            mov     eax,' '
  1378.            PushForth
  1379.            Call    Do_Emit
  1380.            ret
  1381.  
  1382.            CodeDef 'SPACES'
  1383.            PullForth
  1384.            mov     ecx,eax
  1385. @@:            mov     eax,' '
  1386.            PushForth
  1387.            Call    Do_Emit
  1388.            Loop    @b
  1389.            ret
  1390.  
  1391.            CodeDef 'SWAP'
  1392.            mov     eax,[ebx  ]
  1393.            mov     edx,[ebx+4]
  1394.            mov     [ebx  ],edx
  1395.            mov     [ebx+4],eax
  1396.            ret
  1397.  
  1398.            CodeDef 'TYPE'         ; ( addr +n -- )
  1399. _Type:         pushad
  1400.            xor     eax,eax      ; used as "actual count" storage
  1401.            push    eax
  1402.            mov     eax,esp      ; push the address of the previous push
  1403.            push    eax
  1404.            mov     eax,[ebx]    ; push the string length
  1405.            add     OutPos,eax   ; update output position
  1406.            push    eax
  1407.            mov     eax,[ebx+4]  ; push the string address
  1408.            push    eax
  1409.            pushd   stdout       ; push the handle to write to
  1410.            call    Dos32Write   ; do the write.
  1411.            add     esp,20       ; set the stack back to semi-normal
  1412.            popad
  1413.            add     ebx,8        ; Drop the 2 forth stack entries
  1414.            ret
  1415.  
  1416.            CodeDef 'U<'      ; unsigned comparison
  1417.            PullForth
  1418.            cmp     eax,[ebx]
  1419.            mov     eax,0
  1420.            jbe     @f
  1421.            dec     eax
  1422. @@:            mov     [ebx],eax
  1423.            ret
  1424.  
  1425.            CodeDef 'UM*'       ; ( u1 u2 -- ud )
  1426.            mov     eax,[ebx+4]
  1427.            mul     DWORD PTR[ebx]
  1428.            mov     [ebx],edx
  1429.            mov     [ebx+4],eax
  1430.            ret
  1431.  
  1432.            CodeDef 'VARIABLE'       ; Declare a variable
  1433.            call    Create
  1434.            xor     eax,eax
  1435.            mov     [edi],eax        ; initialize to 0
  1436.            mov     eax,4
  1437.            PUSHFORTH
  1438.            call    Allot
  1439.            ret
  1440.  
  1441.            CodeDef 'WORD'          ; (char -- c-addr)
  1442.                        ; Pull a string from between delimiters
  1443.                        ; in InputBuffer
  1444.  
  1445. _Word:         cld                     ; Count UP
  1446.            push    edi             ; Push destination, we'll need it
  1447.            xor     eax,eax
  1448.            stosd                   ; Put a 0 in the count
  1449.  
  1450.            PullForth
  1451.            Push    EBX
  1452.            lea     EBX,WordScanTable
  1453.            mov     edx,eax         ; Delimiter in dl
  1454.            mov     esi,InputOffset
  1455.            mov     ecx,InputCount
  1456.            sub     ecx,esi         ; bump down count
  1457.            jle     _WordDone
  1458.  
  1459.            add     esi,InputBuffer
  1460. @@:            or      ecx,ecx         ; If we are out of characters, exit
  1461.            jz      _WordDone
  1462.            lodsb                   ; skip leading matches
  1463.            xlat
  1464.            dec     ecx
  1465.            cmp     dl,al
  1466.            jz      @b
  1467.  
  1468. @@:            stosb                   ; process non-matches
  1469.            or      ecx,ecx
  1470.            jz      _WordDone
  1471.            lodsb
  1472.            xlat
  1473.            dec     ecx
  1474.            cmp     dl,al
  1475.            jnz     @b
  1476.  
  1477. _WordDone:     mov     eax,esi
  1478.            mov     esi,InputBuffer
  1479.            sub     eax,esi         ; eax now has the NEW offset
  1480.            mov     InputOffset,eax ; update value
  1481.  
  1482.            mov     ecx,edi         ; stuff a non-counted space after text
  1483.            xor     eax,eax
  1484.            stosd
  1485.            mov     eax,ecx
  1486.  
  1487.            mov     LastWordEnd,edi
  1488.            pop     ebx
  1489.            pop     edi             ; original value of EDI
  1490.            sub     eax,edi         ; how many bytes did we use?
  1491.            sub     eax,4           ; adjust for count bytes
  1492.            mov     [edi],eax
  1493.            mov     eax,edi         ; address of string now in eax
  1494.            PushForth
  1495.            ret
  1496.  
  1497.  
  1498.            CodeDef 'XOR'
  1499.            PULLFORTH
  1500.            XOR     [ebx],eax
  1501.            ret
  1502.  
  1503.            CodeDef '[',Immediate   ; This must be an IMMEDIATE word
  1504.            mov     CompileMode,0
  1505.            ret
  1506.  
  1507.            CodeDef "[']",Immediate
  1508.            call    CompileCheck
  1509.            call    Tick
  1510.            call    _Literal
  1511.            ret
  1512.  
  1513.            CodeDef '[CHAR]',Immediate
  1514.            call    CompileCheck
  1515.            call    DoChar
  1516.            call    _Literal
  1517.            ret
  1518.  
  1519.            CodeDef ']'
  1520.            mov     CompileMode,1
  1521.            ret
  1522.  
  1523.  
  1524. ;*****************************************
  1525. ;*                                       *
  1526. ;*            CORE EXTENSIONS            *
  1527. ;*                                       *
  1528. ;*****************************************
  1529.  
  1530.  
  1531.            CodeDef '#TIB'
  1532.            lea     eax,InputCount
  1533.            PushForth
  1534.            ret
  1535.  
  1536.            CodeDef 'SPAN'
  1537.            lea     eax,InputCount
  1538.            PushForth
  1539.            ret
  1540.  
  1541.            CodeDef 'TIB'
  1542.            lea     eax,InputBuffer
  1543.            PushForth
  1544.            ret
  1545.  
  1546.            CodeDef '\',IMMEDIATE   ; Single line comment
  1547.            cld                     ; Count UP
  1548.            mov     esi,InputOffset
  1549.            mov     ecx,InputCount
  1550.            sub     ecx,esi         ; bump down count
  1551.            jle     _CommentDone
  1552.  
  1553.            add     esi,InputBuffer
  1554. @@:            lodsb
  1555.            cmp     al,CR
  1556.            loopne  @b
  1557.  
  1558. _CommentDone:  mov     eax,esi
  1559.            sub     eax,InputBuffer
  1560.            mov     InputOffset,eax ; update value
  1561.            ret
  1562.  
  1563.            CodeDef 'QUERY'      ; ( -- ) Get a line of text
  1564. Query:         lea     eax,InputSpace
  1565.            mov     InputBuffer,eax
  1566.            PushForth
  1567.            mov     eax,InputBufferSize
  1568.            PushForth
  1569.            call    _Accept
  1570.            PullForth
  1571.            mov     InputCount,eax
  1572.            xor     eax,eax
  1573.            mov     InputOffset,eax
  1574.            ret
  1575.  
  1576.  
  1577. ;*****************************************
  1578. ;*                                       *
  1579. ;*            UTILITY ROUTINES           *
  1580. ;*                                       *
  1581. ;*****************************************
  1582.  
  1583.            CodeDef '="'        ; ( addr1 addr2 -- f )
  1584. EqualStr:      push    esi
  1585.            push    edx
  1586.            push    ecx
  1587.            mov     esi,[ebx]
  1588.            add     ebx,4
  1589.            mov     edx,[ebx]
  1590.            push    ebx         ; Save STACK, we're using EBX
  1591.            lea     ebx,UpperCaseTable
  1592.            cld
  1593.            lodsd               ; Length of string1 in eax
  1594.            cmp     eax,[edx]   ; compare string lengths
  1595.            jnz     NotEqual
  1596.            add     edx,4       ; bump String2 pointer
  1597.            mov     ecx,eax     ; put the counter in ECX, for LOOP
  1598.  
  1599. EqualStr1:     lodsb
  1600.            xlat
  1601.            xchg    ah,al
  1602.            mov     al,[edx]
  1603.            xlat
  1604.            inc     edx
  1605.            cmp     al,ah
  1606.            jnz     NotEqual
  1607.            loop    EqualStr1
  1608.  
  1609.            mov     eax,0ffffffffh  ; strings match, return true
  1610.            jmp     @f
  1611. NotEqual:      mov     eax,0
  1612. @@:            pop     ebx
  1613.            mov     [ebx],eax
  1614.            pop     ecx
  1615.            pop     edx
  1616.            pop     esi
  1617.            ret
  1618.  
  1619. LookFor:       pushad
  1620.            lea     ecx,Context           ; look for [EDX]
  1621.            mov     FoundAddr,0
  1622.  
  1623. LookFor1:      mov     esi,[ecx]
  1624.            or      esi,esi
  1625.            jz      LookFor_Done
  1626.            add     esi,VocLinkOffset
  1627.  
  1628. LookFor2:      mov     esi,[esi].Prev         ; go backwards in the chain
  1629.            or      esi,esi
  1630.            jz      LookFor3
  1631.            mov     eax,[esi].NameSize
  1632.            and     eax,eax
  1633.            jz      LookFor3
  1634.  
  1635.            push    esi                    ; save edx
  1636.            lea     esi,[esi].NameSize
  1637.  
  1638.            mov     eax,edx
  1639.            PushForth
  1640.            mov     eax,esi
  1641.            PushForth
  1642.            call    EqualStr
  1643.            PullForth
  1644.  
  1645.            pop     esi
  1646.            and     eax,eax
  1647.            jz      LookFor2
  1648.            mov     FoundAddr,esi          ; put the address in the output
  1649. LookFor_Done:  popad
  1650.            ret
  1651.  
  1652. LookFor3:      add     ecx,4
  1653.            jmp     LookFor1
  1654.  
  1655. ToUpper:       PullForth               ; (c-addr -- )
  1656.            pushad                  ; Converts to upper in place
  1657.            cld
  1658.            mov     esi,eax
  1659.            lodsd
  1660.            mov     ecx,eax
  1661.            or      ecx,ecx
  1662.            jz      ToUpper9
  1663.            lea     ebx,uppercaseTable
  1664.            mov     edi,esi
  1665.  
  1666. @@:            lodsb
  1667.            xlat
  1668.            stosb
  1669.            loop    @b
  1670. ToUpper9:      popad
  1671.            ret
  1672.  
  1673. DoesVariable:  pop     eax
  1674.            PUSHFORTH
  1675.            ret
  1676.  
  1677.            CodeDef 'NUMBER?'        ; ( addr --
  1678.                     ;      value TRUE  (ok value)
  1679.                     ;      addr  FALSE ( bad value )
  1680. _NumberQ:      PullForth
  1681.            pushad                   ; save ALL registers
  1682.            xor      edx,edx
  1683.            mov      Value,edx
  1684.            mov      DPL,edx
  1685.            inc      edx
  1686.            mov      Negative,edx    ; NOT negative
  1687.            lea      ebx,ValueTable
  1688.            xor      edi,edi         ; edi will hold result
  1689.            mov      esi,eax
  1690.            lodsd
  1691.            mov      ecx,eax         ; ecx is number of bytes left
  1692.            or       ecx,ecx
  1693.            jz       _NumberQ9
  1694. _NumberQ1:     xor      eax,eax
  1695.            lodsb
  1696.            xlat
  1697.            cmp      al,0ffh         ; test for bogus number
  1698.            jz       _NumberQ9
  1699.            cmp      al,0feh         ; test for , and .
  1700.            jnz      @f
  1701.            mov      DPL,esi
  1702.            jmp      _NumberQ2
  1703.  
  1704. @@:            cmp      al,0fdh         ; test for -
  1705.            jnz      @f
  1706.            cmp      edi,0
  1707.            jnz      _NumberQ9       ;  '-' in the middle of a number!
  1708.            mov      Negative,-1
  1709.            jmp      _NumberQ2
  1710.  
  1711. @@:            cmp      eax,Number_Base ; test for TOO BIG digit
  1712.            jae      _NumberQ9
  1713.            xchg     eax,edi      ; swap value with eax
  1714.            mul      Number_Base  ; multiply old value by Number Base
  1715.            add      edi,eax      ; add to new in EDI
  1716. _NumberQ2:     loop     _NumberQ1    ; result in EDI, loop until out of chars
  1717.  
  1718.            mov      Value,edi
  1719.            cmp      DPL,0
  1720.            jz       _NumberQOk
  1721.            sub      esi,DPL
  1722.            mov      DPL,esi      ; store the # of digits since in DPL!
  1723.  
  1724. _NumberQOk:    popad
  1725.            mov      eax,Value
  1726.            mul      Negative     ; Multiply by 1 or -1!
  1727.            PushForth
  1728.            mov      eax,-1
  1729.            PushForth
  1730.            ret
  1731.  
  1732. _NumberQ9:     popad                 ; Not a number
  1733.            PushForth             ;  Restore the Address
  1734.            xor      eax,eax
  1735.            PushForth             ; and then a FALSE
  1736.            ret
  1737.  
  1738.            CodeDef '<S">'           ; Puts Address and Count on stack
  1739. Inline_String: pop     ecx              ; (Counted string stored in-line)
  1740.            mov     eax,ecx
  1741.            add     eax,4            ; Push the Address
  1742.            PushForth
  1743.            mov     eax,[ecx]
  1744.            PushForth                ; Push the count
  1745.            add     eax,ecx          ; Add Count+8 to Return address
  1746.            add     eax,8
  1747.            jmp     eax
  1748.  
  1749.            CodeDef '0"',3
  1750.            Call    S_Quote
  1751.            lea     eax,DROP
  1752.            PushForth
  1753.            call    Do_CompileCall
  1754.            ret
  1755.  
  1756.            CodeDef 'SYScall'        ; ( addr --- APIreturnCode )
  1757.            PullForth
  1758.            push    ebx
  1759.            push    ecx
  1760.            push    edx
  1761.            push    esi
  1762.            push    edi
  1763.            push    ebp
  1764.            mov     ebp,esp
  1765.            mov     esp,ebx
  1766.            Call    EAX
  1767.            mov     esp,ebp
  1768.            pop     ebp
  1769.            pop     edi
  1770.            pop     esi
  1771.            pop     edx
  1772.            pop     ecx
  1773.            pop     ebx
  1774.            PushForth
  1775.            ret
  1776.  
  1777.  
  1778.  
  1779.  
  1780.  
  1781.  
  1782.  
  1783.  
  1784.  
  1785.  
  1786.  
  1787.  
  1788. AutoLoad:      pushad                    ; put C:\FLAT32\FORTH.INI into fOpenName
  1789.            mov     esi,Environment   ; on my machine
  1790.            cld
  1791. @@:            lodsb
  1792.            cmp     al,0
  1793.            jnz     @b
  1794.            lodsb
  1795.            cmp     al,0
  1796.            jnz     @b         ; look for a double 0
  1797.  
  1798.            mov     FooBar,ESI
  1799.  
  1800.            lea     edi,FOpenName     ; copy the path, up to the .
  1801. @@:            lodsb
  1802.            stosb
  1803.            cmp     al,'.'
  1804.            jnz     @b
  1805.  
  1806.            mov     al,'I'
  1807.            stosb
  1808.            mov     al,'N'
  1809.            stosb
  1810.            mov     al,'I'
  1811.            stosb
  1812.            xor     eax,eax
  1813.            stosd
  1814.            popad
  1815.  
  1816. ;               CodeDef 'AUTOLOAD'
  1817. ;AutoLoad:
  1818.            call    FOpen
  1819. @@:            PULLFORTH
  1820.            push    eax        ; push handle
  1821.            push    ebx        ; push stack
  1822.            cmp     eax,0
  1823.            jle     Abort
  1824.            PushForth
  1825.            mov     eax,FileBufferSize
  1826.            PushForth
  1827.            call    FRead
  1828.            PullForth
  1829.            or      eax,eax
  1830.            jz      @f
  1831.            mov     InputCount,eax
  1832.            lea     eax,FileBuffer
  1833.            mov     InputBuffer,eax
  1834.            xor     eax,eax
  1835.            mov     InputOffset,eax
  1836.            call    Interpret
  1837.  
  1838. @@:            pop     eax
  1839.            cmp     eax,ebx     ; check if stack changed
  1840.            jne     StackProblem
  1841.            pop     eax
  1842.            PUSHFORTH
  1843.            call    FClose
  1844.            ret
  1845.  
  1846. StackProblem:  lea     edx,StackLoadMsg
  1847.            call    WriteStr
  1848.            jmp     Abort
  1849.  
  1850.  
  1851.  
  1852.  
  1853.  
  1854.  
  1855.  
  1856.  
  1857.  
  1858.  
  1859. MAIN:          mov     SavedESP,ESP
  1860.            mov     ebp,esp
  1861.            mov     EAX,[EBP+12]
  1862.            mov     Environment,EAX
  1863.            mov     EAX,[EBP+16]
  1864.            mov     CommandLine,EAX
  1865.            pushd   012h            ; Write Un-committed
  1866.            pushd   Reserve_Size
  1867.            pushd   offset CodeSpace
  1868.            call    Dos32AllocMem
  1869.            and     eax,eax
  1870.            jnz     Bye
  1871.            mov     esp,SavedESP
  1872.  
  1873.            call    ErrorHandler
  1874.  
  1875.            lea     edx,CopyRightMsg
  1876.            call    WriteStr
  1877.  
  1878.            lea     edx,WelcomeMsg
  1879.            call    WriteStr
  1880.  
  1881.            lea     edx,VersionMsg
  1882.            call    WriteStr
  1883.  
  1884.            lea     edx,GreetMsg
  1885.            call    WriteStr
  1886.  
  1887.            Call    AutoLoad
  1888.            jmp     quit
  1889.  
  1890. VecAbort:      mov     esp,SavedESP
  1891.            call    ErrorHandler
  1892.            jmp     Quit
  1893.  
  1894. ErrorHandler:  xor     eax,eax
  1895.            mov     CompileMode,eax
  1896.            mov     SysTo,eax
  1897.            mov     ebx,StackBase
  1898.            mov     EDI,CodeSpace        ; CS:EDI = compile pointer
  1899.            cld                          ; count UP
  1900.            call    ForthVoc
  1901.            ret
  1902.  
  1903. IOerror:       mov     edx,offset IOerrorMsg
  1904.            call    WriteStr
  1905.            mov     edx,offset StrBuffer
  1906.            call    Int_Str
  1907.            call    WriteStr
  1908.            call    DoCr
  1909.            jmp     Abort
  1910.  
  1911.            CodeDef 'DumpRegisters'
  1912. DumpRegisters:      pushad
  1913.            push    Number_Base
  1914.            mov     Number_Base,10h
  1915.            pushad
  1916.            lea     edx,RegisterMsg
  1917.            call    WriteStr
  1918.            popad
  1919.  
  1920.            pushad
  1921.            mov     ecx,8
  1922. @@:            lea     edx,Numbuffer
  1923.            mov     ebx,8
  1924.            pop     eax
  1925.            call    Int_StrLen
  1926.            call    WriteStr
  1927.            lea     edx,SpStr
  1928.            call    WriteStr
  1929.            loop    @b
  1930.            call    DoCr
  1931.            pop     Number_Base
  1932.            popad
  1933.            ret
  1934.  
  1935. WriteEAX:
  1936.            pushad
  1937.            lea     edx,NumBuffer
  1938.            call    Int_Str
  1939.            call    WriteStr
  1940.            call    DoCr
  1941.            popad
  1942.            ret
  1943.  
  1944.  
  1945. WriteStr:                           ; writes string at [EDX]
  1946.            pushad
  1947.            xor     eax,eax      ; used as "actual count" storage
  1948.            push    eax
  1949.            mov     eax,esp      ; push the address of the previous push
  1950.            push    eax
  1951.            mov     eax,[edx]    ; push the string length
  1952.  
  1953.            add     OutPos,eax   ; update output position
  1954.  
  1955.            push    eax
  1956.            add     edx,4        ; push the string address
  1957.            push    edx
  1958.            pushd   stdout       ; push the handle to write to
  1959.            call    Dos32Write   ; do the write.
  1960.            add     esp,20       ; set the stack back to semi-normal
  1961.            popad
  1962.            ret
  1963.  
  1964.  
  1965. Int_Str:       pushad               ; No length required...
  1966.            mov     ebx,0
  1967.            jmp     Int_Str0
  1968.  
  1969. Int_StrLen:    pushad
  1970. Int_Str0:                           ; eax-value to print
  1971.                     ; ebx-number of digits..
  1972.                     ; edx-address of buffer to put it in.....
  1973.            pushd   0            ;
  1974.            mov     edi,ebx      ; edi now has count
  1975.            mov     ebx,edx      ; buffer address now in ebx
  1976.            mov     ecx,number_base
  1977.            lea     esi,table
  1978. Int_Str1:
  1979.            mov     edx,0
  1980.            div     ecx
  1981.            mov     edx,[edx+esi]
  1982.            push    edx
  1983.            dec     edi          ; bump counter
  1984.            and     eax,eax
  1985.            jnz     Int_Str1
  1986.            mov     edx,ebx      ; ebx --> count
  1987.            add     edx,4        ; edx --> string data
  1988.            mov     ecx,0        ; ecx = counter
  1989. Int_Str1a:
  1990.            or      edi,edi
  1991.            jle     Int_Str2
  1992.            xor     eax,eax
  1993.            mov     al,Number_Fill
  1994.            push    eax
  1995.            dec     edi
  1996.            jmp     Int_Str1a
  1997. Int_Str2:
  1998.            pop     eax
  1999.            or      al,al
  2000.            jz      Int_Str3
  2001.            mov     [edx],al
  2002.            inc     edx
  2003.            inc     ecx
  2004.            jmp     Int_Str2
  2005. Int_Str3:
  2006.            mov     [ebx],ecx
  2007.            popad
  2008.            ret
  2009.  
  2010. Do_Breakpoint: push    edx
  2011.            lea     edx,BreakMsg
  2012.            call    WriteStr
  2013.            pop     edx
  2014.            ret
  2015.  
  2016. ;
  2017. ; Preliminary routines to build a foundation word list from
  2018. ;
  2019.  
  2020.            CodeDef '?STACK'
  2021. StackCheck:    mov     eax,StackBase
  2022.            cmp     ebx,eax
  2023.            ja      StackUnderflow
  2024.            sub     eax,STACK_SIZE*4
  2025.            cmp     ebx,eax
  2026.            jbe     StackOverflow
  2027.            ret
  2028.  
  2029. StackOverFlow: lea     edx,StackOverMsg
  2030.            call    WriteStr
  2031.            jmp     Abort           ; RESET everything
  2032.  
  2033. StackUnderFlow:
  2034.            lea     edx,StackUnderMsg
  2035.            call    WriteStr
  2036.            jmp     Abort           ; RESET everything
  2037.  
  2038. DivByZero:     call    DumpRegisters
  2039.                lea     EDX,DivByZeroMsg
  2040.            call    WriteStr
  2041.            xor     eax,eax
  2042.            mov     [ebx],eax
  2043.            ret
  2044.  
  2045.            CodeDef 'COMPILE,'
  2046. Do_CompileCall:                         ; Compiles a call to address given
  2047.            mov     al,0E8h
  2048.            stosb
  2049.            PULLFORTH
  2050.  
  2051.            sub     eax,EDI          ; subtract current EIP
  2052.            sub     eax,4            ; subtract 4 for upcoming offset
  2053.            stosd
  2054.            ret
  2055.  
  2056. WriteLineNum:  mov     eax,LineNumber
  2057.            or      eax,eax
  2058.            jz      WriteLineNum9
  2059.            lea     edx,LineNumMsg
  2060.            call    WriteStr
  2061.            mov     eax,10
  2062.            mov     number_base,eax
  2063.            mov     eax,LineNumber
  2064.            call    WriteEAX
  2065.            call    DoCr
  2066.            xor     eax,eax
  2067.            mov     LineNumber,eax
  2068. WriteLineNum9: ret
  2069.  
  2070.            CodeDef 'WORDS'
  2071. Do_Words:      pushad
  2072.                xor     eax,eax               ; Mod 11/14/93 MAW
  2073.                mov     OutLine,eax
  2074.  
  2075.            mov     ecx,offset Context
  2076.  
  2077. Do_Words1:     mov     edx,[ecx]
  2078.            or      edx,edx
  2079.            jz      Do_Words_Done         ; if last CURRENT vocabulary
  2080.            add     edx,VocLinkOffset
  2081. Do_Words2:     mov     edx,[edx].Prev        ; go backwards in the chain
  2082.            or      edx,edx
  2083.            jz      Do_Words3
  2084.            mov     eax,[edx].NameSize
  2085.            or      eax,eax
  2086.            jz      Do_Words3
  2087.  
  2088.            mov     eax,[edx].Flags
  2089.            test    eax,HIDDEN
  2090.            jnz     Do_Words2             ; Skip if marked HIDDEN
  2091.            push    edx
  2092.            lea     edx,[edx].NameSize
  2093.            call    WriteStr
  2094.            lea     edx,SpStr
  2095.            call    WriteStr
  2096.            call    WriteStr
  2097. ;               call    QueryCR
  2098.            call    QueryMore             ; Modified 11/14/93 MAW
  2099.            pop     edx
  2100.            jmp     Do_Words2
  2101.  
  2102. Do_Words3:     add     ecx,4                 ; Finished 1 vocabulary
  2103.            call    DoCr
  2104.            call    DoCr
  2105.            jmp     Do_Words1
  2106.  
  2107. Do_Words_Done: popad
  2108.            ret
  2109.  
  2110.            CodeDef '?CR'
  2111. QueryCr:       mov     edx,OutPos
  2112.            add     edx,16
  2113.            cmp     edx,CharPerLine
  2114.            jg      DoCr
  2115.            ret
  2116.  
  2117.                CodeDef '?CR-MORE'
  2118. QueryMore:     Call    QueryCR
  2119.                mov     edx,OutLine
  2120.                cmp     edx,MoreLength
  2121.                jng     @f
  2122.                mov     edx,MoreVector
  2123.                call    edx
  2124. @@:            ret
  2125.  
  2126.                CodeDef 'PAUSE'
  2127. Pause:         lea     edx,PauseMsg
  2128.                call    WriteStr
  2129.                call    GetKey
  2130.                PullForth               ; drop it
  2131.                lea     edx,PauseClearMsg
  2132.                call    WriteStr
  2133.                xor     eax,eax
  2134.                mov     OutLine,eax
  2135.                mov     OutPos,eax
  2136.                ret
  2137.  
  2138.            CodeDef 'U*'
  2139.            PULLFORTH
  2140.            mul     DWORD PTR [ebx]
  2141.            mov     [ebx],eax
  2142.            ret
  2143.  
  2144.            CodeDef 'U/'
  2145.            PULLFORTH
  2146.            or      eax,eax
  2147.            jz      DivByZero
  2148.            xchg    eax,[ebx]
  2149.            xor     edx,edx
  2150.            div     DWORD PTR[ebx]
  2151.            mov     [ebx],eax
  2152.            ret
  2153.  
  2154.            CodeDef 'W@'
  2155.            mov     eax,[ebx  ]
  2156.            mov     eax,[eax  ]
  2157.            and     eax,00ffffh
  2158.            mov     [ebx  ],eax
  2159.            ret
  2160.  
  2161.            CodeDef 'W!'
  2162.            mov     edx,[ebx  ]      ; value addr .... poke
  2163.            mov     eax,[ebx+4]
  2164.            mov     [edx],ax
  2165.            add     ebx,8            ; pop both values
  2166.            ret
  2167.  
  2168.            CodeDef 'DEBUG'
  2169.            lea     eax,Debug
  2170.            PUSHFORTH
  2171.            ret
  2172.  
  2173.            CodeDef 'ABORT'          ; Vectored ABORT
  2174. Abort:         mov     eax,TickAbort
  2175.            jmp     eax
  2176.  
  2177.            CodeDef "'ABORT"         ; Address of ABORT
  2178.            lea     eax,TickAbort
  2179.            PUSHFORTH
  2180.            ret
  2181.  
  2182.            CodeDef 'EXITCODE'       ; Result code in BYE
  2183.            lea     eax,ExitCode
  2184.            PUSHFORTH
  2185.            ret
  2186.  
  2187.            CodeDef 'HEX'
  2188.            mov     eax,10h
  2189.            mov     Number_Base,eax
  2190.            ret
  2191.  
  2192.            CodeDef '.'             ; Prints number in the current BASE
  2193. Do_Dot:        PullForth
  2194.            cmp     eax,0
  2195.            jge     @f
  2196.            push    eax
  2197.            mov     al,'-'
  2198.            PushForth
  2199.            Call    Do_Emit
  2200.            pop     eax
  2201.            neg     eax
  2202.            jmp     @f
  2203.  
  2204.            CodeDef 'U.'            ; Unsigned PRINT
  2205.            PullForth
  2206.  
  2207. @@:            Push    ESI
  2208.            Push    ECX
  2209.            Push    EDX
  2210.            push    0
  2211.            mov     ecx,Number_Base
  2212.            lea     ESI,Table
  2213. @@:            xor     edx,edx
  2214.            div     ecx             ; AX = Quotient DX = Remainder
  2215.            mov     edx,[edx+esi]
  2216.            push    edx             ; Put the char on the stack
  2217.            or      eax,eax
  2218.            jnz     @b
  2219.  
  2220. @@:            pop     eax
  2221.            or      eax,eax
  2222.            jz      @f
  2223.            PushForth
  2224.            Call    Do_emit
  2225.            jmp     @b
  2226.  
  2227. @@:            pop     EDX
  2228.            pop     ECX
  2229.            pop     ESI
  2230.            ret
  2231.  
  2232.            CodeDef '.S'            ; Non-Destructive stack print
  2233.            mov     ecx,StackBase
  2234. @@:            sub     ecx,4
  2235.            cmp     ecx,ebx
  2236.            jb      @f
  2237.            mov     eax,[ecx]
  2238.            PushForth
  2239.            call    Do_Dot
  2240.            lea     edx,SpStr
  2241.            call    WriteStr
  2242.            jmp     @b
  2243.  
  2244. @@:            call    DoCr
  2245.            ret
  2246.  
  2247.            CodeDef 'SP0'
  2248.            mov     eax,StackBase  ; Base of stack
  2249.            PUSHFORTH
  2250.            ret
  2251.  
  2252.            CodeDef 'SP!'           ; Resets user stack pointer
  2253.            mov     ebx,[ebx]
  2254.            ret
  2255.  
  2256.            CodeDef 'SP@'
  2257.            mov     eax,ebx         ; Forth Stack pointer in EAX
  2258.            PUSHFORTH
  2259.            ret
  2260.  
  2261.            CodeDef 'RP0'           ; Get initial return pointer
  2262.            mov     eax,SavedESP
  2263.            PushForth
  2264.            ret
  2265.  
  2266.            CodeDef 'RP@'           ; Get the current return pointer
  2267.            mov     eax,ESP
  2268.            add     eax,4
  2269.            PushForth
  2270.            ret
  2271.  
  2272.            CodeDef 'RP!'           ; Get our return address....
  2273.            pop     edx
  2274.            PullForth
  2275.            mov     esp,eax
  2276.            push    edx
  2277.            ret
  2278.  
  2279.            CodeDef 'CELL'
  2280.            mov     eax,4           ; Word Size in bytes
  2281.            PUSHFORTH
  2282.            ret
  2283.  
  2284.            CodeDef 'COMPILE',CompileOnly
  2285.                        ; a REALLY SNEAKY forth word
  2286.            pop     eax             ; get return address
  2287.            mov     edx,eax
  2288.            add     eax,5           ; Modify return address, to skip
  2289.            push    eax             ; the next call instruction
  2290.            inc     edx             ; [edx] is call offset
  2291.            add     eax,[edx]       ; eax now has absolute address of call
  2292.  
  2293.            mov     edx,eax
  2294.            mov     al,0E8h         ; put the CALL instruction
  2295.            stosb
  2296.            mov     eax,edx
  2297.  
  2298.            sub     eax,EDI         ; subtract current EIP
  2299.            sub     eax,4           ; subtract 4 for upcoming offset
  2300.            stosd
  2301.            ret                     ; return with the address changed
  2302.  
  2303. ; Some useful words let you temporarily store things on the return stack
  2304. ; Always use >R and R> in pairs
  2305.  
  2306. ;
  2307. ;  CREATE       makes a 0 byte variable
  2308. ;  ALLOT        adds N bytes to the length of the last word created
  2309. ;  ,            takes N, and adds in into the last word compiled
  2310. ;  C,           adds C to the last word compiled
  2311. ;  VARIABLE     makes a 4 byte variable
  2312. ;  DoesVariable Puts the Return address on the stack
  2313. ;  DoesConstant Puts the CONTENTS of the Return address on the stack
  2314. ;
  2315.  
  2316.  
  2317.  
  2318. ;
  2319. ; Conditional Branching Logic
  2320. ;
  2321. ; IF   - Marks code to be executed ONLY on a TRUE
  2322. ; ELSE - Marks code to be executed ONLY of false
  2323. ; THEN - Marks the end of the conditional
  2324. ;
  2325.            CodeDef 'IF',3           ; ONLY in compile mode
  2326.            Call    CompileCheck
  2327.            cld
  2328.            COMPILES 08Bh,003h,083h,0C3h,004h
  2329.            COMPILES 023h,0C0h,00fh,084h
  2330.            xor     eax,eax
  2331.            stosd                   ; set to 0, for safety
  2332.            mov     eax,edi         ; calc offset of DWORD
  2333.            sub     eax,4
  2334.            PUSHFORTH
  2335.            ret
  2336.  
  2337. ; Code generated....
  2338. ; 8B 03            mov      eax,[ebx]
  2339. ; 83 C3 04         add      ebx,4
  2340. ; 23 C0            and      eax,eax
  2341. ; 0F 84 00000000   jz       Next Instruction + Offset....
  2342. ;
  2343.  
  2344.            CodeDef  'THEN',3       ; ONLY in compile mode
  2345.            Call     CompileCheck
  2346.            push     edi
  2347.            PULLFORTH
  2348.            xchg     EDI,EAX        ; Fixup in EDI, current in EAX
  2349.            sub      eax,edi        ; determine offset of this instruction
  2350.            sub      eax,4          ;   from the patches NEXT instruction
  2351.            stosd                   ; Do the patch
  2352.            pop      edi
  2353.            ret
  2354.  
  2355. ; for an ELSE
  2356. ; 1256  E9 00000000      jmp      Next Instruction + Offset....
  2357.  
  2358.            CodeDef  'ELSE',3       ; ONLY in compile mode
  2359.            Call    CompileCheck
  2360.            mov      eax,0E9h
  2361.            stosb                   ; Jump relative 32
  2362.            xor      eax,eax
  2363.            stosd
  2364.            mov      eax,[ebx]      ; get address from IF  (ebx goes back up later)
  2365.            push     edi
  2366.            xchg     edi,eax
  2367.            sub      eax,edi
  2368.            sub      eax,4
  2369.            stosd                   ; Patch IF address
  2370.            pop      edi
  2371.            mov      eax,edi
  2372.            sub      eax,4
  2373.            mov      [ebx],eax      ; replace address with ELSE patch
  2374.            ret
  2375. ;
  2376. ; DO ... LOOP logic
  2377. ;
  2378. ;
  2379. ; DO - Takes 2 values from Forth Stack, puts them on the return stack
  2380. ;      COMPILE: Puts LABEL on stack
  2381. ;
  2382. ; LOOP - Increments loop counter, tests for end of loop, if ok, jums to LABEL
  2383. ;
  2384.  
  2385.            CodeDef 'DO',3          ; COMPILED ONLY, IMMEDIATE
  2386.  
  2387.            Call    CompileCheck
  2388.          COMPILES  08Bh,043h,004h  ; mov   eax,[ebx+4]
  2389.          COMPILES  050h            ; push  eax
  2390.          COMPILES  08Bh,003h       ; mov   eax,[ebx]
  2391.          COMPILES  050h            ; push  eax
  2392.          COMPILES  083h,0C3h,008h  ; add   ebx,8
  2393.  
  2394.            mov     eax,EDI         ; LABEL1:
  2395.            PUSHFORTH
  2396.            ret
  2397.  
  2398.  
  2399.            CodeDef 'LOOP',3             ; CompileOnly, Immediate
  2400.            Call    CompileCheck
  2401.  
  2402.          COMPILES 08bh,004h,024h        ; mov  eax,[esp]
  2403.          COMPILES 040h                  ; inc  eax
  2404.          COMPILES 089h,004h,024h        ; mov  [esp],eax
  2405.          COMPILES 03bh,044h,024h,004h   ; cmp  eax,[esp+4]
  2406.          COMPILES 00fh,08ch             ; jl   RELATIVE32
  2407.            PULLFORTH
  2408.            sub     eax,EDI
  2409.            sub     eax,4                ; calculate from next instruction
  2410.            STOSD
  2411.          COMPILES 083h,0c4h,008h        ; add  esp,8
  2412.            ret
  2413.  
  2414.  
  2415.  
  2416.            CodeDef '<+LOOP>',HIDDEN  ; Smart +LOOP can count down or up
  2417. PlusLoop1:     pop     edx
  2418.            PULLFORTH
  2419.            add     [esp],eax
  2420.            mov     ecx,[esp]
  2421.            or      eax,eax
  2422.            jge     PlusLoop2
  2423.            cmp     4 [esp],ecx
  2424.            jmp     PlusLoop3
  2425. PlusLoop2:     cmp     ecx,4 [esp]
  2426. PlusLoop3:     jge     PlusLoop9
  2427.            add     edx,[edx]
  2428.            add     edx,4
  2429.            jmp     edx         ; loop back
  2430. PlusLoop9:     add     edx,4       ; skip loop-back offset
  2431.            add     esp,8       ; drop loop variables
  2432.            jmp     edx
  2433.  
  2434.            CodeDef '+LOOP',3            ; CompileOnly, Immediate
  2435.            Call    CompileCheck
  2436.            lea     eax,PlusLoop1
  2437.            PUSHFORTH
  2438.            call    Do_CompileCall
  2439.            PULLFORTH
  2440.            sub     eax,EDI
  2441.            sub     eax,4                ; calculate from next instruction
  2442.            STOSD
  2443.            ret
  2444.  
  2445.  
  2446. ; A word which goes along with these will copy the value pushed onto
  2447. ;  the return stack with R> onto the parameter stack.
  2448.  
  2449.            CodeDef 'K'         ; 1 loop up
  2450.            mov     eax,[esp+20] ; return, index, limit, index, limit, index
  2451.            PushForth
  2452.            ret
  2453.  
  2454.            CodeDef 'LEAVE'     ; leave a DO...LOOP
  2455.            mov     eax,[esp+8]
  2456.            mov     [esp+4],eax
  2457.            ret
  2458.  
  2459.            CodeDef 'UNLOOP'    ; remove loop variables from stack
  2460.            mov     eax,[esp]
  2461.            add     esp,8
  2462.            mov     [esp],eax
  2463.            ret
  2464.  
  2465. ;
  2466. ; FOR ... NEXT logic
  2467. ;
  2468. ;
  2469. ; FOR - Takes 2 values from Forth Stack, puts them on the return stack
  2470. ;      MARKER - Take values from stack, if past bound PATCHUP, skip body
  2471. ;
  2472. ; NEXT- Does Patchup, Compiles Jump to MARKER
  2473. ;
  2474. ; DESIRED RESULT:
  2475. ;
  2476. ; 1302  8B 43 04                               mov     eax,[ebx+4]     ; MOVE values to return stack
  2477. ; 1305  50                                     push    eax
  2478. ; 1306  8B 03                                  mov     eax,[ebx]
  2479. ; 1308  50                                     push    eax
  2480. ; 1309  83 C3 08                               add     ebx,8           ; bump counter appropriately
  2481. ; 130C  58                      LABEL1:        pop     eax
  2482. ; 130D  5A                                     pop     edx
  2483. ; 130E  3B C2                                  cmp     eax,edx
  2484. ; 1310  73 11                                  jae     LABEL2
  2485. ; 1312  52                                     push    edx
  2486. ; 1313  50                                     push    eax
  2487. ;
  2488. ; 1314  BA 000000B0 R                          lea     edx,GreetMsg
  2489. ; 1319  E8 FFFFEF91                            call    WriteStr
  2490. ;
  2491. ; 131E  58                                     pop     eax
  2492. ; 131F  40                                     inc     eax
  2493. ; 1320  50                                     push    eax
  2494. ; 1321  EB E9                                  jmp     LABEL1
  2495. ;
  2496. ; 1323                          LABEL2:
  2497. ; 1323  C3                                     ret
  2498.            CodeDef 'FOR',3         ; COMPILED ONLY, IMMEDIATE
  2499.            Call    CompileCheck
  2500.  
  2501.            COMPILES 08Bh,043h,004h ; mov   eax,[ebx+4]
  2502.            COMPILES 050h           ; push  eax
  2503.            COMPILES 08Bh,003h      ; mov   eax,[ebx]
  2504.            COMPILES 050h           ; push  eax
  2505.            COMPILES 083h,0C3h,008h ; add   eax,8
  2506.  
  2507.            mov     eax,EDI         ; LABEL1: Jump back point
  2508.            PUSHFORTH
  2509.  
  2510.            COMPILES 058h           ; pop   eax
  2511.            COMPILES 05Ah           ; pop   edx
  2512.            COMPILES 03Bh,0C2h      ; cmp   eax,edx
  2513.            COMPILES 00fh,083h      ; jea   relative 32
  2514.  
  2515.            mov     eax,EDI         ;       patch point to LABEL2
  2516.            PUSHFORTH
  2517.            xor     eax,eax
  2518.            stosd
  2519.  
  2520.            COMPILES 052h           ; push  edx
  2521.            COMPILES 050h           ; push  eax
  2522.            ret
  2523.  
  2524.  
  2525. ; 131E  58                                     pop     eax
  2526. ; 131F  40                                     inc     eax
  2527. ; 1320  50                                     push    eax
  2528. ; 1321  EB E9                                  jmp     LABEL1
  2529. ;
  2530. ; 1323                          LABEL2:
  2531.  
  2532.            CodeDef 'NEXT',3        ; Compile ONLY, Immediate
  2533.            Call    CompileCheck
  2534.  
  2535.            mov     al,058h         ; pop   eax
  2536.            stosb
  2537.            mov     al,040h         ; inc   eax
  2538.            stosb
  2539.            mov     al,050h         ; push  eax
  2540.            stosb
  2541.            mov     al,0E9h         ; jmp   Relative 32
  2542.            stosb
  2543.            mov     eax,[ebx+4]     ; EAX = LABEL1
  2544.            sub     eax,edi         ; DELTA = LABEL1 - NEXT INSTRUCTION
  2545.            sub     eax,4
  2546.            stosd                   ; Do the backward jump....
  2547.  
  2548.            mov     eax,edi         ;
  2549.            sub     eax,[ebx]       ; Offset = Current - (Patch+4)
  2550.            sub     eax,4
  2551.            push    edi
  2552.            mov     edi,[ebx]
  2553.            STOSD
  2554.            pop     edi
  2555.            add     ebx,8           ; drop 2 stack entries
  2556.            ret
  2557.  
  2558.            CodeDef '>='            ; i.e. 5 5 >=
  2559.            pullforth               ; eax = stack top 5
  2560.            cmp     eax,[ebx]
  2561.            mov     eax,0
  2562.            jg      @f
  2563.            dec     eax
  2564. @@:            mov     [ebx],eax
  2565.            ret
  2566.  
  2567.            CodeDef '<='
  2568.            pullforth
  2569.            cmp      eax,[ebx]
  2570.            mov      eax,0
  2571.            jl       @f
  2572.            dec      eax
  2573. @@:            mov     [ebx],eax
  2574.            ret
  2575.  
  2576.            CodeDef '<>'            ; True if A <> B
  2577.            pullforth
  2578.            cmp     eax,[ebx]
  2579.            mov     eax,0
  2580.            jz      @f
  2581.            not     eax
  2582. @@:            mov     [ebx],eax
  2583.            ret
  2584.  
  2585.            CodeDef 'NOT'          ; 1s complement
  2586.            not     dword ptr[ebx]
  2587.            ret
  2588.  
  2589.            CodeDef 'U*/MOD'       ; ( a b c -- remainder quotient )
  2590.            mov     eax,[ebx+8]
  2591.            mul     DWORD PTR[ebx+4]
  2592.            cmp     edx,[ebx]
  2593.            jg      DivByZero
  2594.            div     DWORD PTR[ebx]
  2595.            add     ebx,4
  2596.            mov     [ebx],eax      ; Store Quotient
  2597.            mov     [ebx+4],edx    ; Store Remainder
  2598.            ret
  2599.  
  2600.            CodeDef 'FOPEN'      ; ( -- handle )
  2601. Fopen:         mov     eax,0ffffffffh
  2602.            mov     FopenHandle,eax
  2603.            pushad
  2604.            pushd   0            ; PEAOP2 (not used, must be 0 )
  2605.            mov     eax,esp
  2606.            push    eax
  2607.            pushd   020h         ; Readonly, deny write
  2608.            pushd   001h         ; Open, fail if non-existant
  2609.            pushd   000h         ; Normal attributes
  2610.            pushd   0            ; Don't change file size
  2611.            lea     eax,FopenAction
  2612.            push    eax
  2613.            lea     eax,FopenHandle
  2614.            push    eax
  2615.            lea     eax,FopenName
  2616.            push    eax
  2617.            call    Dos32Open
  2618.            add     esp,36       ; Drop all of the stuff from the stack
  2619.            popad
  2620.            mov     eax,FopenHandle
  2621.            PushForth            ; put the handle on the stack
  2622.            ret
  2623.  
  2624.            CodeDef 'CLOSE'     ; ( handle -- )
  2625. FClose:        PullForth
  2626.            pushad
  2627.            push    eax
  2628.            call    Dos32Close
  2629.            add     esp,4
  2630.            popad
  2631.            ret
  2632.  
  2633.            CodeDef 'FREAD'      ; ( handle size -- bytes_read )
  2634. FRead:         PullForth            ; eax is size
  2635.            mov     edx,eax
  2636.            pushad
  2637.            push    ebx          ; point at parameter on stack
  2638.            push    edx          ; number of bytes to read
  2639.            lea     eax,FileBuffer
  2640.            push    eax
  2641.            mov     eax,[ebx]    ; handle
  2642.            push    eax
  2643.            call    Dos32Read
  2644.            add     esp,16
  2645.            popad
  2646.            ret
  2647.  
  2648.            CodeDef 'FBUFFER'
  2649.            lea     eax,FileBuffer
  2650.            pushforth
  2651.            ret
  2652.  
  2653.            CodeDef 'LINE#'
  2654.            lea     eax,LineNumber
  2655.            PUSHFORTH
  2656.            ret
  2657.  
  2658.  
  2659.            CodeDef 'BYE'           ; Exit Forth Environment
  2660. BYE:           pushd   1
  2661.            mov     eax,ExitCode
  2662.            push    eax
  2663.            call    Dos32Exit
  2664.  
  2665.  
  2666.            CodeDef 'INTERPRET'
  2667. Interpret:
  2668.            mov     eax,' '
  2669.            PushForth
  2670.            call    _Word
  2671.            mov     eax,[ebx]       ; address of string
  2672.            mov     eax,[eax]       ; count
  2673.            jz      Interpret8      ; (Null string, bail out)
  2674.  
  2675.            call    _Find           ; 0 = Not found
  2676.            PullForth               ; 1 = Immediate
  2677.            or      eax,eax         ;-1 = Normal
  2678.            jz      InterpretNumber
  2679. ;
  2680. ; We have an address, decide if it should be compiled or called.
  2681. ;
  2682.            test    CompileMode,1
  2683.            jz      @f
  2684. ;
  2685. ; This is the "compile mode" branch of things
  2686. ;
  2687.            cmp     eax,1                   ; is it immediate?
  2688.            jz      @f
  2689.            call    Do_CompileCall          ; No, compile it
  2690.            jmp     Interpret
  2691. ;
  2692. ; This is the interpretive branch
  2693. ;
  2694. @@:            call    _Execute                ; Execute a function
  2695.            jmp     Interpret
  2696.  
  2697. Interpret8:    pullforth
  2698. Interpret9:
  2699.            ret
  2700.  
  2701. ;
  2702. ; Handle a possible number, counted string on stack
  2703. ;
  2704. InterpretNumber:
  2705.            call    _NumberQ
  2706.            pullForth
  2707.            or      eax,eax
  2708.            jz      Interpret_NonNumber
  2709.  
  2710.            test    CompileMode,1
  2711.            jz      @f
  2712.            call    _Literal
  2713. @@:            jmp     Interpret
  2714.  
  2715. Interpret_NonNumber:
  2716.            mov     eax,[ebx]                 ; Peek at stack top
  2717.            mov     eax,[eax]                 ; get string length
  2718.            or      eax,eax                   ; Don't warn if it's 0 chars
  2719.            jz      Interpret8
  2720.  
  2721.            lea     edx,What1Msg
  2722.            call    WriteStr
  2723.  
  2724.            Call    _Count
  2725.            Call    _Type
  2726.            lea     edx,What2Msg
  2727.            call    WriteStr
  2728.            call    WriteLineNum
  2729.            jmp     Abort
  2730.  
  2731.            CodeDef 'PROMPT'
  2732. Prompt:        call    DoCr
  2733.            lea     edx,PromptMsg
  2734.            call    WriteStr
  2735.            ret
  2736.  
  2737.            CodeDef 'DP!'
  2738.            PullForth
  2739.            mov     edi,eax
  2740.            mov     CodeSpace,EDI
  2741.            ret
  2742.  
  2743.            CodeDef '?COMPILE'       ; Only works if we're compiling
  2744. CompileCheck:  test    CompileMode,1
  2745.            jz      @f
  2746.            ret
  2747. @@:            lea     edx,CompileOnlyMsg
  2748.            call    WriteStr
  2749.            call    WriteLineNum
  2750.            jmp     Abort            ; RESET everything
  2751.  
  2752.  
  2753.            CodeDef '[COMPILE]',3    ; Compiles the next word, regardless
  2754.            Call    CompileCheck
  2755.            call    Tick
  2756.            PullForth
  2757.            mov     eax,[eax].CodePointer
  2758.            PushForth
  2759.            call    Do_CompileCall
  2760.            ret
  2761.  
  2762.            CodeDef 'POSTPONE',IMMEDIATE ; Compiles the next word
  2763.            CLD
  2764.            Call    CompileCheck
  2765.            call    Tick
  2766.            lea     edx,PostponeImmediate
  2767.            cmp     eax,1               ;  1 = Immediate
  2768.            jz      @f
  2769.            lea     edx,PostponeNormal  ; -1 = Normal
  2770. @@:            mov     eax,edx
  2771.                PushForth                   ; compile call to postpone routine
  2772.                call    Do_CompileCall      ; eats param
  2773.                PullForth                   ; eats other param
  2774.            stosd
  2775.            mov     CodeSpace,edi
  2776.            ret
  2777.  
  2778.  
  2779. PostponeImmediate:
  2780.            pop     edx
  2781.            mov     eax,[edx]
  2782.            add     edx,4
  2783.            push    edx
  2784.            jmp     eax
  2785.  
  2786. PostPoneNormal:
  2787.            pop     edx
  2788.            mov     eax,[edx]
  2789.            add     edx,4
  2790.            push    edx
  2791.            pushforth
  2792.            call    Do_CompileCall
  2793.            ret
  2794.  
  2795. ;
  2796. ; New version 11/14/93 MAW
  2797. ; old version relied on a fixed header size.
  2798. ;
  2799. DoDoes:        mov     edx,NewWord      ; Address of the latest word...
  2800.            mov     edx,[edx].CodePointer  ; get address of code
  2801.                inc     edx              ; skip CALL opcode
  2802.            Pop     EAX              ; Address to jump to....
  2803.                     ; Note: We never return to it!
  2804.            sub     eax,EDX          ; subtract current EIP
  2805.            sub     eax,4            ; subtract 4 for upcoming offset
  2806.            mov     [edx],eax
  2807.  
  2808.            mov     CodeSpace,EDI
  2809.            ret
  2810.  
  2811.  
  2812.            CodeDef 'DOES>',3        ; Compile Only, Immediate
  2813. Does:          Call    CompileCheck
  2814.            lea     eax,DoDoes
  2815.            PushForth
  2816.            Call    Do_CompileCall   ; Put the call to DoDoes in the
  2817.                     ; def that uses DOES>
  2818.            Compiles 058h            ; pop     eax
  2819.            Compiles 083h,0ebh,004h  ; sub     ebx,4
  2820.            Compiles 089h,003h       ; mov     [ebx],eax
  2821.            ret
  2822.  
  2823.            CodeDef 'LAST'           ; The LAST word defined
  2824.            mov     eax,Current
  2825.            mov     eax,[eax+VocLinkOffset]
  2826.            PushForth
  2827.            ret
  2828.  
  2829.            CodeDef '%TO'
  2830.            lea     eax,SysTo
  2831.            PUSHFORTH
  2832.            ret
  2833.  
  2834.            CodeDef 'TO'
  2835.            mov     eax,1
  2836.            mov     SysTo,eax
  2837.            ret
  2838.  
  2839.            CodeDef '+TO'
  2840.            mov     eax,-1
  2841.            mov     SysTo,eax
  2842.            ret
  2843.  
  2844.            CodeDef '<TODOES>'    ; For TO variables
  2845.            mov     eax,SysTo
  2846.            or      eax,eax
  2847.            jz      Fetch
  2848.            xor     ecx,ecx
  2849.            mov     SysTo,ecx     ; reset TO state
  2850.            or      eax,eax
  2851.            jg      Store
  2852.            ja      PlusStore
  2853.  
  2854.            CodeDef 'DROPS'         ; DROPS n items off the stack
  2855. Drops:         inc     DWORD PTR [ebx]
  2856.            shl     DWORD PTR [ebx],1
  2857.            shl     DWORD PTR [ebx],1
  2858.            add     ebx,[ebx]
  2859.            ret
  2860.  
  2861.            CodeDef 'DPL'  ; variable holding decimal point position
  2862.            lea     eax,DPL
  2863.            PUSHFORTH
  2864.            ret
  2865.  
  2866.            CodeDef 'ROLL'     ; ( n -- ) moves n'th word on stack to top
  2867.            PullForth
  2868.            cmp     eax,1      ; not defined for n <= 1
  2869.            jle     @f
  2870.            push    edi
  2871.            push    esi
  2872.            dec     eax
  2873.            mov     ecx,eax
  2874.            dec     eax
  2875.            shl     eax,1
  2876.            shl     eax,1
  2877.            mov     esi,ebx
  2878.            add     esi,eax    ; start from n'th element
  2879.            mov     edi,ebx
  2880.            add     edi,eax
  2881.            add     edi,4
  2882.            add     eax,ebx
  2883.            mov     eax,[eax+4] ; copy ROLL'd value
  2884.            std                 ; move words up
  2885.            rep movsd           ; move stack up
  2886.            cld
  2887.            mov     [ebx],eax  ; store ROLL'd value
  2888.            pop     esi
  2889.            pop     edi
  2890. @@:            ret
  2891.  
  2892.            CodeDef 'CMOVE>'   ; ( src dest n -- ) moves n bytes up
  2893. CmoveBack:     PullForth
  2894.            cmp     eax,1      ; not defined for n < 1
  2895.            jl      @f
  2896.            push    edi
  2897.            push    esi
  2898.            mov     ecx,eax
  2899.            dec     eax
  2900.            mov     esi,[ebx+4]
  2901.            add     esi,eax    ; start from n'th byte
  2902.            mov     edi,[ebx]
  2903.            add     edi,eax
  2904.            std
  2905.            rep movsb          ; move bytes up
  2906.            cld
  2907.            pop     esi
  2908.            pop     edi
  2909. @@:            add     ebx,8
  2910.            ret
  2911.  
  2912.            CodeDef 'CMOVE'    ; ( src dest n -- ) moves n bytes
  2913. Cmove:         PullForth
  2914.            cmp     eax,1      ; not defined for n < 1
  2915.            jl      @f
  2916.            push    edi
  2917.            push    esi
  2918.            mov     ecx,eax
  2919.            mov     esi,[ebx+4]
  2920.            mov     edi,[ebx]
  2921.            rep movsb
  2922.            pop     esi
  2923.            pop     edi
  2924. @@:            add     ebx,8
  2925.            ret
  2926.  
  2927.            CodeDef  "=STRING"  ; ( addr len "string" -- f )
  2928. EqualString:   push    esi
  2929.            push    edx
  2930.            push    ecx
  2931.            mov     esi,[ebx]   ; esi=string
  2932.            mov     ecx,[ebx+4] ; ecx=len    for LOOP
  2933.            add     ebx,8
  2934.            mov     edx,[ebx]
  2935.            push    ebx         ; Save STACK, we're using EBX
  2936.            lea     ebx,UpperCaseTable
  2937.            cld
  2938.            lodsd               ; Length of string1 in eax
  2939.            cmp     eax,ecx     ; compare string lengths
  2940.            jnz     NotEqual
  2941.            jmp     EqualStr1
  2942.  
  2943.            CodeDef '@+'        ; ( addr -- addr+4 [addr] )
  2944.            mov     edx,[ebx]
  2945.            mov     eax,[edx]
  2946.            add     edx,4
  2947.            mov     [ebx],edx
  2948.            PushForth
  2949.            ret
  2950.  
  2951.            CodeDef 'NIP'       ; ( n1 n2 -- n2 )
  2952.            PullForth
  2953.            mov     [ebx],eax
  2954.            ret
  2955.  
  2956.            CodeDef 'PICK'      ; Copies n'th item to top
  2957.            mov     eax,[ebx]
  2958.            cmp     eax,1      ; not defined for n <= 1
  2959.            jl      @f
  2960.            shl     eax,1
  2961.            shl     eax,1
  2962.            add     eax,ebx
  2963.            mov     eax,[eax]
  2964.            mov     [ebx],eax
  2965. @@:            ret
  2966.  
  2967.            CodeDef '#OUT'       ; Output position
  2968.            lea     eax,DWORD PTR OutPos
  2969.            PushForth
  2970.            ret
  2971.  
  2972.            CodeDef 'WITHIN'     ; ( n1 n2 n3 -- f ) True if n1<=n2<=n3
  2973.            xor     edx,edx
  2974.            mov     eax,[ebx+8]
  2975.            cmp     eax,[ebx]    ; cmp n1,n3
  2976.            jg      @f
  2977.            cmp     eax,[ebx+4]  ; cmp n1,n2
  2978.            jl      @f
  2979.            dec     edx
  2980. @@:            add     ebx,8
  2981.            mov     [ebx],edx
  2982.            ret
  2983.  
  2984.            CodeDef 'CURRENT'    ; Vocabulary where definitions are added
  2985.            lea     eax,WORD PTR Current
  2986.            PushForth
  2987.            ret
  2988.  
  2989.            CodeDef 'CONTEXT'    ; Vocabulary where words are searched for
  2990.            lea     eax,WORD PTR Context
  2991.            PushForth
  2992.            ret
  2993.  
  2994.            CodeDef 'CONTEXTSIZE'  ; Size in words of CONTEXT
  2995.            mov     eax,ContextSize
  2996.            PushForth
  2997.            ret
  2998.  
  2999.            CodeDef 'VOC-LINK'   ; Location of most recent vocabulary
  3000.            lea     eax,WORD PTR Voc_link
  3001.            PushForth
  3002.            ret
  3003.  
  3004.            CodeDef '<VOCABULARY>' ; ( vocabulary -- ) Adds voc to CONTEXT
  3005. DoVocabulary:  push    esi
  3006.            push    edi
  3007.            mov     edi,offset Context  ; list of search vocabularies
  3008.            mov     eax,[ebx]           ; check if vocab already listed
  3009.            mov     ecx,ContextSize-1   ; max # of vocabularies
  3010.            cld
  3011.            repne scasd                 ; Look for the vocabulary
  3012.            or      ecx,ecx
  3013.            jnz     RollVocab           ; If already listed, roll to top
  3014.  
  3015.            mov     edx,[ebx]
  3016.            jmp     ShiftVocab
  3017.  
  3018. ;              mov     edi,offset Context
  3019. ;              xor     eax,eax
  3020. ;              mov     ecx,ContextSize-1
  3021. ;              repne scasd                 ; Look for the first 0
  3022. ;              mov     eax,[ebx]
  3023. ;              mov     [edi-4],eax         ; Vocabulary to add to Context
  3024.  
  3025. RollVocab:     mov     eax,edi
  3026.            cmp     eax,offset Context+4
  3027.            je      DoVocab9            ; If vocab is already first
  3028.            mov     edx,[edi-4]         ; vocab to roll to top
  3029.  
  3030. ShiftVocab:    sub     edi,4
  3031.            mov     esi,edi
  3032.            sub     esi,4
  3033.            neg     ecx
  3034.            add     ecx,ContextSize-2
  3035.            std
  3036.            rep movsd                   ; move vocabs down
  3037.            cld
  3038.            mov     Context,edx         ; store vocabulary at top
  3039.  
  3040. DoVocab9:      pop     edi
  3041.            pop     esi
  3042.            add     ebx,4
  3043.            ret
  3044.  
  3045. SetVocabulary: pop     eax           ; Expects a vocab record after it
  3046.            PUSHFORTH
  3047.            call    DoVocabulary
  3048.            ret
  3049.  
  3050.          CodeDef 'FORTH',IMMEDIATE
  3051. ForthVoc:        lea     eax,ForthLink
  3052.          PUSHFORTH
  3053.          call    DoVocabulary
  3054.          ret
  3055. ; ForthVoc:      call    SetVocabulary
  3056. ; ForthLink      dd      0,LastForthWord,0       ; FORTH vocabulary pointer
  3057.  
  3058.  
  3059.          CodeDef 'SYSTEM',1       ; SYSTEM vocabulary
  3060. SysVoc:          lea     eax,SysLink
  3061.          PUSHFORTH
  3062.          call    DoVocabulary
  3063.          ret
  3064. ; SysVoc:        call    SetVocabulary
  3065. ; SysLink        dd      0,LastHeader,ForthLink  ; SYSTEM vocabulary pointer
  3066.  
  3067.  
  3068.            CodeDef 'FALSE'                 ; Core extension
  3069.            xor     eax,eax
  3070.            PUSHFORTH
  3071.            ret
  3072.  
  3073.            CodeDef 'TRUE'                  ; Core extension
  3074.            xor     eax,eax
  3075.            dec     eax
  3076.            PUSHFORTH
  3077.            ret
  3078.  
  3079. LastForthWord  =       LastHeader
  3080. LastHeader     =       0
  3081.  
  3082.            CodeDef 'MS'
  3083.            PullForth
  3084.            Push    EAX
  3085.            Call    Dos32Sleep
  3086.            Add     ESP,4
  3087.            ret
  3088.  
  3089.            CodeDef 'SYS$BEEP'
  3090.            lea     eax,Dos32Beep
  3091.            PushForth
  3092.            ret
  3093.  
  3094.            CodeDef 'SYS$CALLNPIPE'
  3095.            lea     eax,Dos32CallNPipe
  3096.            PushForth
  3097.            ret
  3098.  
  3099.            CodeDef 'SYS$CLOSE'
  3100.            lea     eax,Dos32Close
  3101.            PushForth
  3102.            ret
  3103.  
  3104.            CodeDef 'SYS$CONNECTNPIPE'
  3105.            lea     eax,Dos32ConnectNPipe
  3106.            PushForth
  3107.            ret
  3108.  
  3109.            CodeDef 'SYS$CREATENPIPE'
  3110.            lea     eax,Dos32CreateNPipe
  3111.            PushForth
  3112.            ret
  3113.  
  3114.            CodeDef 'SYS$CREATETHREAD'
  3115.            lea     eax,Dos32CreateThread
  3116.            PushForth
  3117.            ret
  3118.  
  3119.            CodeDef 'SYS$DEVIOCTL'
  3120.            lea     eax,Dos32DevIOCtl
  3121.            PushForth
  3122.            ret
  3123.  
  3124.            CodeDef 'SYS$DISCONNECTNPIPE'
  3125.            lea     eax,Dos32ExecPgm
  3126.            PushForth
  3127.            ret
  3128.  
  3129.            CodeDef 'SYS$EXECPGM'
  3130.            lea     eax,Dos32ExecPgm
  3131.            PushForth
  3132.            ret
  3133.  
  3134.            CodeDef 'SYS$EXIT'
  3135.            lea     eax,Dos32Exit
  3136.            PushForth
  3137.            ret
  3138.  
  3139.            CodeDef 'SYS$FREEMODULE'
  3140.            lea     eax,Dos32FreeModule
  3141.            PushForth
  3142.            ret
  3143.  
  3144.                CodeDef 'Sys$GetDateTime'
  3145.                lea     eax,Dos32GetDateTime
  3146.                PushForth
  3147.                ret
  3148.  
  3149.            CodeDef 'SYS$KILLPROCESS'
  3150.            lea     eax,Dos32KillProcess
  3151.            PushForth
  3152.            ret
  3153.  
  3154.            CodeDef 'SYS$KILLTHREAD'
  3155.            lea     eax,Dos32KillThread
  3156.            PushForth
  3157.            ret
  3158.  
  3159.            CodeDef 'SYS$LOADMODULE'
  3160.            lea     eax,Dos32LoadModule
  3161.            PushForth
  3162.            ret
  3163.  
  3164.            CodeDef 'SYS$OPEN'
  3165.            lea     eax,Dos32Open
  3166.            PushForth
  3167.            ret
  3168.  
  3169.            CodeDef 'SYS$PEEKNPIPE'
  3170.            lea     eax,Dos32PeekNPipe
  3171.            PushForth
  3172.            ret
  3173.  
  3174.            CodeDef 'SYS$QUERYMODULEHANDLE'
  3175.            lea     eax,Dos32QueryModuleHandle
  3176.            PushForth
  3177.            ret
  3178.  
  3179.            CodeDef 'SYS$QUERYMODULENAME'
  3180.            lea     eax,Dos32QueryModuleName
  3181.            PushForth
  3182.            ret
  3183.  
  3184.            CodeDef 'SYS$QUERYNPHSTATE'
  3185.            lea     eax,Dos32QueryNPHState
  3186.            PushForth
  3187.            ret
  3188.  
  3189.            CodeDef 'SYS$QUERYNPIPEINFO'
  3190.            lea     eax,Dos32QueryNPipeInfo
  3191.            PushForth
  3192.            ret
  3193.  
  3194.            CodeDef 'SYS$QUERYPROCADDR'
  3195.            lea     eax,Dos32QueryProcAddr
  3196.            PushForth
  3197.            ret
  3198.  
  3199.            CodeDef 'SYS$QUERYPROCTYPE'
  3200.            lea     eax,Dos32QueryProcType
  3201.            PushForth
  3202.            ret
  3203.  
  3204.            CodeDef 'SYS$READ'
  3205.            lea     eax,Dos32Read
  3206.            PushForth
  3207.            ret
  3208.  
  3209.            CodeDef 'SYS$RESUMETHREAD'
  3210.            lea     eax,Dos32ResumeThread
  3211.            PushForth
  3212.            ret
  3213.  
  3214.            CodeDef 'SYS$SEEK'
  3215.            lea     eax,Dos32SetFilePtr
  3216.            PushForth
  3217.            ret
  3218.  
  3219.            CodeDef 'SYS$SETNPHSTATE'
  3220.            lea     eax,Dos32SetNPHState
  3221.            PushForth
  3222.            ret
  3223.  
  3224.            CodeDef 'SYS$SLEEP'
  3225.            lea     eax,Dos32Sleep
  3226.            PushForth
  3227.            ret
  3228.  
  3229.            CodeDef 'SYS$STARTSESSION'
  3230.            lea     eax,Dos32StartSession
  3231.            PushForth
  3232.            ret
  3233.  
  3234.            CodeDef 'SYS$SUSPENDTHREAD'
  3235.            lea     eax,Dos32SuspendThread
  3236.            PushForth
  3237.            ret
  3238.  
  3239.            CodeDef 'SYS$TRANSACTNPIPE'
  3240.            lea     eax,Dos32TransactNPipe
  3241.            PushForth
  3242.            ret
  3243.  
  3244.            CodeDef 'SYS$WAITCHILD'
  3245.            lea     eax,Dos32WaitChild
  3246.            PushForth
  3247.            ret
  3248.  
  3249.            CodeDef 'SYS$WAITNPIPE'
  3250.            lea     eax,Dos32WaitNPipe
  3251.            PushForth
  3252.            ret
  3253.  
  3254.            CodeDef 'SYS$WAITTHREAD'
  3255.            lea     eax,Dos32WaitThread
  3256.            PushForth
  3257.            ret
  3258.  
  3259.            CodeDef 'SYS$WRITE'
  3260.            lea     eax,Dos32Write
  3261.            PushForth
  3262.            ret
  3263.  
  3264.  
  3265.            CodeDef 'SYS$SHUTDOWN'
  3266.            lea     eax,Dos32ShutDown
  3267.            PushForth
  3268.            ret
  3269.  
  3270.            CodeDef 'ENVIRONMENT'
  3271.            mov     EAX,Environment
  3272.            PUSHFORTH
  3273.            ret
  3274.  
  3275.            CodeDef 'COMMANDLINE'
  3276.            mov     EAX,CommandLine
  3277.            PUSHFORTH
  3278.            ret
  3279.  
  3280. ;
  3281. ;*********** FLOATING POINT WORDS
  3282. ;
  3283.            CodeDef 'FCLEAR'  ; Initializes everything
  3284.            FINIT
  3285.            PUSHD   037fh
  3286.            FLDCW   [ESP]     ; Double Precision, round towards nearest
  3287.            ADD     ESP,4
  3288.            ret
  3289.  
  3290.            CodeDef 'D>F'     ; Convert an Integer to the real stack
  3291.            FILD    Dword Ptr[EBX]
  3292.            add     EBX,4
  3293.            ret
  3294.  
  3295.            CodeDef 'F>D'     ; Truncate to forth stack
  3296.            sub     EBX,4
  3297.  
  3298.            PUSHD   0f7fh     ; Modify control value
  3299.            FLDCW   [ESP]
  3300.            ADD     ESP,4
  3301.  
  3302.            FISTP   DWord Ptr[EBX]
  3303.  
  3304.            PUSHD   037fh     ; Set it back
  3305.            FLDCW   [ESP]
  3306.            ADD     ESP,4
  3307.            ret
  3308.  
  3309.  
  3310.            CodeDef 'F@'
  3311.            PullForth
  3312.            FLD     QWORD PTR [EAX]
  3313.            ret
  3314.  
  3315.            CodeDef 'F!'
  3316.            PullForth
  3317.            FSTP    QWORD PTR [EAX]
  3318.            ret
  3319.  
  3320.            CodeDef 'F+'
  3321.            FADDP   ST(1),ST
  3322.            ret
  3323.  
  3324.            CodeDef 'F-'
  3325.            FSUBP   ST(1),ST
  3326.            ret
  3327.  
  3328.            CodeDef 'F*'
  3329.            FMULP   ST(1),ST
  3330.            ret
  3331.  
  3332.            CodeDef 'F/'
  3333.            FDIV
  3334.            ret
  3335.  
  3336.            CodeDef 'F0<'
  3337.            FTST
  3338.            FSTSW   AX
  3339.            SAHF
  3340.            MOV     EAX,0
  3341.            SBB     EAX,0
  3342.            PushForth
  3343.            ret
  3344.  
  3345.            CodeDef 'F0='
  3346.            FTST
  3347.            FSTSW   AX
  3348.            SAHF
  3349.            MOV     EAX,0
  3350.            JNZ     @F
  3351.            MOV     EAX,-1
  3352. @@:            RET
  3353.  
  3354.            CodeDef 'F<'
  3355.            FCOMPP
  3356.            FSTSW   AX
  3357.            SAHF
  3358.            MOV     EAX,0
  3359.            SBB     EAX,0
  3360.            PushForth
  3361.            ret
  3362.  
  3363.            CodeDef 'FDROP'
  3364.            FFREE   ST         ; free the register
  3365.            FINCSTP            ; bump the stack counter
  3366.            ret
  3367.  
  3368.            CodeDef 'FDUP'
  3369.            FLD     ST
  3370.            ret
  3371.  
  3372.  
  3373.            CodeDef 'FSWAP'
  3374.            FXCH    ST(1)
  3375.            ret
  3376.  
  3377.            CodeDef 'FVARIABLE'
  3378.            call    Create
  3379.            mov     eax,8
  3380.            PUSHFORTH
  3381.            call    Allot
  3382.            ret
  3383.  
  3384.            CodeDef 'FLOOR'
  3385.            PUSHD   0f7fh      ; Modify control value
  3386.            FLDCW   [ESP]
  3387.            ADD     ESP,4
  3388.  
  3389.            FRNDINT
  3390.  
  3391.            PUSHD   037fh      ; Set it back
  3392.            FLDCW   [ESP]
  3393.            ADD     ESP,4
  3394.            RET
  3395.  
  3396.            CodeDef 'FROUND'   ; Round to nearest
  3397.            FRNDINT
  3398.            RET
  3399.  
  3400.            CodeDef 'FDEPTH'   ; Depth of Stack...
  3401.            FSTSW   AX
  3402.            AND     EAX,00003c00h
  3403.            SHR     EAX,11
  3404.            XOR     EAX,7
  3405.            INC     EAX
  3406.            AND     EAX,7
  3407.            PUSHForth
  3408.            Ret
  3409.  
  3410.            CodeDef 'FALIGN'
  3411.            ret
  3412.  
  3413.            CodeDef 'FALIGNED'
  3414.            ret
  3415.  
  3416. DoesFConstant: pop     eax
  3417.            FLD     Qword Ptr[eax]
  3418.            ret
  3419.  
  3420.  
  3421. ;
  3422. ;***** Floating Point EXTENSION words *****
  3423. ;
  3424.            CodeDef 'FABS'
  3425.            FABS
  3426.            ret
  3427.  
  3428.            CodeDef 'FCOS'
  3429.            FCOS
  3430.            ret
  3431.  
  3432.            CodeDef 'FSIN'
  3433.            FSIN
  3434.            ret
  3435.  
  3436.            CodeDef 'FSINCOS'
  3437.            FSINCOS
  3438.            ret
  3439.  
  3440.            CodeDef 'FSQRT'
  3441.            FSQRT
  3442.            ret
  3443.  
  3444. ;
  3445. ; Code FOR F. - What a pig!
  3446. ;
  3447. CvtDigit:      cmp     eax,Number_Base
  3448.            jae     BadDigit
  3449.  
  3450.            cmp     eax,0
  3451.            jb      BadDigit
  3452.  
  3453.            lea     ESI,Table
  3454.            mov     al,[esi+eax]
  3455.            ret
  3456.  
  3457. BadDigit:      mov     eax,'?'
  3458.            ret
  3459.  
  3460.  
  3461.            CodeDef 'F.'
  3462.  
  3463.            PUSHAD
  3464.  
  3465.            XOR     EAX,EAX    ; Push a 0 to the stack
  3466.            Push    EAX
  3467.            MOV     EDI,0      ; EDI is EXPONENT in this app!
  3468.  
  3469.            FTST
  3470.            FSTSW   AX
  3471.            SAHF
  3472.            JAE     @f
  3473.            MOV     EAX,'-'
  3474.            PushForth
  3475.            Call    Do_Emit
  3476.  
  3477. @@:            FABS               ; FStack top >= 0
  3478.            Push    07fffffffh
  3479.            FICOM   Dword Ptr[ESP]
  3480.            ADD     ESP,4      ; Compare to maxint
  3481.            FSTSW   AX
  3482.            SAHF
  3483.            JB      ShowFloat
  3484.  
  3485. @@:            FIDIV   Number_Base
  3486.            INC     EDI
  3487.            FICOM   Number_Base
  3488.            FSTSW   AX
  3489.            SAHF
  3490.            JAE     @b
  3491.  
  3492. ShowFloat:     PUSHD   0f7fh      ; Modify control value
  3493.            FLDCW   [ESP]      ; FLOOR mode
  3494.            ADD     ESP,4
  3495.  
  3496.            PUSH    EAX
  3497.            FLD     ST         ; Dup Stack Top -- X,X
  3498.            FRNDINT            ;                  Trunc(X),X
  3499.            FIST    Dword Ptr[ESP] ;              Trunc(X),X
  3500.            FSUBP   ST(1),ST   ;                  Frac(X)
  3501.            POP     EAX        ; Whole in EAX
  3502.  
  3503.            mov     ecx,Number_Base
  3504.            lea     ESI,Table
  3505. @@:            xor     edx,edx
  3506.            div     ecx             ; AX = Quotient DX = Remainder
  3507.  
  3508.            xchg    edx,eax
  3509.            call    CvtDigit
  3510.            xchg    edx,eax
  3511.  
  3512.            push    edx             ; Put the char on the stack
  3513.            or      eax,eax
  3514.            jnz     @b
  3515.  
  3516. @@:            pop     eax
  3517.            or      eax,eax
  3518.            jz      FPrintFrac
  3519.            PushForth
  3520.            Call    Do_emit
  3521.            jmp     @b
  3522.  
  3523. ;
  3524. ; Print The Fraction in ST
  3525. ;
  3526. FprintFrac:    mov     eax,'.'         ; Put the decimal point
  3527.            PushForth
  3528.            Call    Do_Emit         ; FRAC(X)
  3529.  
  3530. @@:            FIMUL   Number_Base     ; FRAC(X)*10?
  3531.            Push    EAX
  3532.            FIST    Dword Ptr[ESP]
  3533.            Pop     EAX
  3534.            Call    CvtDigit
  3535.            PushForth
  3536.            call    Do_Emit
  3537.  
  3538.            FTST
  3539.            FSTSW   AX
  3540.            SAHF
  3541.            JZ      @f
  3542.            FLD     ST         ; Dup Stack Top -- X,X
  3543.            FRNDINT
  3544.            FSUBP   ST(1),ST
  3545.            JMP     @b
  3546.  
  3547. @@:            FFREE   ST         ; free the register
  3548.            FINCSTP            ; bump the stack counter
  3549.  
  3550.            CMP     EDI,0
  3551.            JZ      FPrintDone
  3552.            MOV     EAX,'E'
  3553.            PushForth
  3554.            Call    Do_Emit
  3555.  
  3556.            MOV     EAX,'+'
  3557.            CMP     EDI,0
  3558.            JA      @F
  3559.            MOV     EAX,'-'
  3560.            NEG     EBP
  3561. @@:            PushForth
  3562.            Call    Do_Emit
  3563.            MOV     EAX,EDI
  3564.  
  3565.            push    0
  3566.            mov     ecx,Number_Base
  3567.            lea     ESI,Table
  3568. @@:            xor     edx,edx
  3569.            div     ecx             ; AX = Quotient DX = Remainder
  3570.  
  3571.            xchg    edx,eax
  3572.            call    CvtDigit
  3573.            xchg    edx,eax
  3574.  
  3575.            push    edx             ; Put the char on the stack
  3576.            or      eax,eax
  3577.            jnz     @b
  3578.  
  3579. @@:            pop     eax
  3580.            or      eax,eax
  3581.            jz      FPrintDone
  3582.            PushForth
  3583.            Call    Do_emit
  3584.            jmp     @b
  3585.  
  3586. FprintDone:    PUSHD   037fh      ; Set round mode
  3587.            FLDCW   [ESP]
  3588.            ADD     ESP,4
  3589.  
  3590.            POPAD
  3591.            RET
  3592.  
  3593.  
  3594.            CodeDef 'NOP'
  3595.            ret
  3596.  
  3597.            CodeDef 'PI'
  3598.            FLDPI
  3599.            ret
  3600.  
  3601.            CodeDef 'CIN'            ; ( addr -- data )
  3602.            mov     eax,esp          ; save current ss, esp
  3603.            push    ss               ; for return from 16-bit land
  3604.            push    eax
  3605.            mov     eax,esp          ; convert stack so 16-bit can use it
  3606.            ror     eax,16
  3607.            shl     eax,3
  3608.            or      al,7             ; convert to ring-3 tiled segment
  3609.            mov     ss,eax
  3610.  
  3611.            mov     edx,[ebx]
  3612.            xor     eax,eax
  3613.            jmp     far ptr Do_inp16
  3614.  
  3615. Do_inp2        label   far
  3616.            movzx   esp,sp           ; make sure that esp is correct
  3617.            lss     esp,[esp]
  3618.            mov     [ebx],eax
  3619.            ret
  3620.  
  3621.            CodeDef 'COUT'           ; ( data addr -- )
  3622.            mov     eax,esp          ; save current ss, esp
  3623.            push    ss               ; for return from 16-bit land
  3624.            push    eax
  3625.            mov     eax,esp          ; convert stack so 16-bit can use it
  3626.            ror     eax,16
  3627.            shl     eax,3
  3628.            or      al,7             ; convert to ring-3 tiled segment
  3629.            mov     ss,eax
  3630.  
  3631.            PullForth
  3632.            mov     edx,eax
  3633.            PullForth
  3634.            jmp     far ptr Do_out16
  3635.  
  3636. Do_out2        label   far
  3637.            movzx   esp,sp           ; make sure that esp is correct
  3638.            lss     esp,[esp]
  3639.            ret
  3640.  
  3641. MYCODE         SEGMENT PARA USE16 PUBLIC 'CODE'
  3642. Do_Emit16      LABEL   FAR16
  3643.            call    VIOwrtTTY
  3644.            add     sp,4             ; toss the parameters for the DOS16 call
  3645.            jmp     FLAT:Do_Emit2
  3646.  
  3647. Do_GetKey16    LABEL   FAR16
  3648.            call    KbdCharIn
  3649.            jmp     FLAT:Do_GetKey2
  3650.  
  3651. Do_inp16       LABEL   FAR16
  3652.            call    @inp
  3653.            jmp     FLAT:DO_inp2
  3654.  
  3655. Do_Out16       LABEL   FAR16
  3656.            call    @outp
  3657.            jmp     FLAT:DO_out2
  3658.  
  3659. MYCODE         ends
  3660.  
  3661.            .code
  3662.  
  3663.            end     main
  3664.