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