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