diff --git a/Artek Ada v125/ADA.ALB b/Artek Ada v125/ADA.ALB index 6040a94..3634900 100644 Binary files a/Artek Ada v125/ADA.ALB and b/Artek Ada v125/ADA.ALB differ diff --git a/Artek Ada v125/e.EXE b/Artek Ada v125/e.EXE new file mode 100644 index 0000000..224a9b5 Binary files /dev/null and b/Artek Ada v125/e.EXE differ diff --git a/Artek Ada v125/e.axe b/Artek Ada v125/e.axe new file mode 100644 index 0000000..d907fc0 Binary files /dev/null and b/Artek Ada v125/e.axe differ diff --git a/DX-FORTH v430/ASM.SCR b/DX-FORTH v430/ASM.SCR new file mode 100644 index 0000000..7218414 --- /dev/null +++ b/DX-FORTH v430/ASM.SCR @@ -0,0 +1 @@ +\ 8086 assembler - information An 8086 Forth assembler for DX-FORTH Based on F83 assembler \ load block forth definitions hex sys @ system warning @ warning off marker -ASM cr .( loading 8086 Assembler ) 2 #screens 1- thru forth definitions decimal warning ! sys ! \ vocabularies vocabulary ASSEMBLER assembler definitions vocabulary HIDDEN hidden definitions chain assembler 2variable avoc : big? ( n -- flag ) 80 -80 within ; : rel ( a1 a2 -- offs ) 1+ - dup big? abort" branch out of range" ; \ labels #20 constant ml \ max labels #25 constant mf \ max forward references \ arrays :noname ( n -- adr ) count rot * + ; ( xt) dup build lt 1 cells dup c, ml * allot \ labels build ft 2 cells dup c, mf * allot \ fwd refs \ reset labels : !lb ( -- ) 0 lt [ ml cells ] literal erase 0 ft [ mf cells 2* ] literal erase ; !lb \ labels \ resolve all forward references : ?lb ( -- ) mf 0 do i ft 2@ dup if ( fwd ref ) swap lt @ dup 0= abort" unresolved reference" ( target label ) over dup 1- c@ ( opc ) dup 70 80 within over E0 E4 within or over EB = or if ( short ) drop rel swap c! else dup E8 EA within ( call/jmp ) if drop 2+ - swap ! else dup C0 B8 within swap A4 A0 within and ( handle 3/4 byte instr) - ! drop then then else 2drop then loop ; \ labels \ add address to forward ref table : fwd ( a -- ) here 1+ ( skip opcode ) mf 1+ 0 do i mf = abort" too many references" i ft dup @ if drop else tuck ! cell+ ! 0 0 leave then loop 2drop ; \ check label number : ?l ( n -- n ) 1- dup ml 0 within abort" invalid label" ; \ labels assembler definitions hidden \ declare label : $: ( n -- ) ?l lt dup @ abort" duplicate label" here swap ! ; \ get label address : $ ( n -- a ) ?l dup lt @ ( n adr ) dup if nip else swap fwd ( dummy adr ) then ; \ addressing modes 800 constant # 809 constant ) 812 constant [] 80 constant [BX+SI] 89 constant [BX+DI] 92 constant [BP+SI] 9B constant [BP+DI] A4 constant [SI] AD constant [DI] B6 constant [BP] BF constant [BX] aka [BX+SI] [SI+BX] aka [BX+DI] [DI+BX] aka [BP+SI] [SI+BP] aka [BP+DI] [DI+BP] \ registers 00 constant AL 09 constant CL 12 constant DL 1B constant BL 24 constant AH 2D constant CH 36 constant DH 3F constant BH 40 constant AX 49 constant CX 52 constant DX 5B constant BX 64 constant SP 6D constant BP 76 constant SI 7F constant DI C0 constant ES C9 constant CS D2 constant SS DB constant DS \ operators hidden definitions : reg constant does> c@ swap FFC0 and = 1 and ; ( 00 reg 8? ) 40 reg 16? 80 reg m? C0 reg s? 0 value siz ( byte/word ) 0 value isf ( far on/off ) : !siz ( -- ) 1 to siz ; \ default is WORD : !seg ( -- ) 0 to isf ; \ default is FAR off \ operators : r? ( n -- flag ) 0FFC0 and 80 < ; : low ( n -- mask ) 7 and ; : mid ( n -- mask ) 38 and ; : op, ( n op -- ) or c, ; : w, ( op mr -- ) 16? op, ; : siz, ( op -- op' ) siz op, ; : ,c, ( n f -- ) if , else c, then ; : r, ( mr1 mr2 -- ) mid swap low or C0 op, ; : esc, ( m -- ) D8 op, ; \ operators : m, ( disp mr m -- ) mid over ) = if 6 op, drop , else over low or -rot [BP] = over 0= and if swap 40 op, c, else tuck big? if 80 op, , else over if 40 op, c, else op, then then then then ; : ow, ( mr op -- mr ) over w, ; : wm, ( disp mem reg op -- ) ow, m, ; : rm, ( mr reg -- ) over r? if r, else m, then ; : wr, ( r/m r op -- ) 2 pick dup r? if w, r, else drop siz, m, then !siz ; : far? ( n1 -- n2 ) isf or !seg ; \ instruction class : m1 constant does> c@ c, ; : m2 constant does> c@ c, 0A c, ; : m3 constant does> c@ c, dup if here rel then c, ; : m4 constant does> c@ c, m, ; : m5 constant does> c@ siz, !siz ; : m7 constant does> c@ F6 wr, ; : m8 constant does> c@ >r dup r? if dup DX = if swap then else rot then 16? r> or swap # = if c, c, else 08 op, then ; : m9 constant does> c@ over 16? if 40 or swap low op, else FE wr, then ; : ma constant does> c@ over CL = if nip D2 else over 1 = if nip then D0 then wr, ; \ instruction class : mb constant does> c@ dup far? c, 1 and 0= if , then ; : mc constant does> over ) = if nip c@ isf if 1 and if EA else 9A then c, swap , , !seg else swap here - 2- swap 2dup 1 and swap big? 0= and if 2 op, c, else c, 1- , then then else over [] = if nip ) swap then 0FF c, 1+ c@ far? rm, then ; : md constant , does> over r? if c@ swap low op, else 1+ over s? if c@ low swap mid op, else count swap c@ c, m, then then ; \ instruction class : me constant does> c@ >r dup r? if over r? if r> ow, swap r, else over dup m? swap ) = or if r> 2 or wm, else ( #) nip dup low 0= ( acc?) if r> 4 or ow, 16? ,c, else over big? over 16? 2dup and -rot swap invert 2 and or 80 op, swap low C0 or r> op, ,c, then then then else ( mem) rot dup r? if r> wm, else ( #) drop 2 pick big? dup invert 2 and 80 or siz, -rot r> m, siz and ,c, !siz then then ; \ mnemonics assembler definitions hidden : TEST ( src dst -- ) dup r? if over r? if 84 ow, swap r, else over dup m? swap ) = or if 84 wm, else ( #) nip dup low 0= ( acc?) if A8 ow, else F6 ow, dup low C0 op, then 16? ,c, then then else ( mem) rot dup r? if 84 wm, else ( #) drop F6 siz, 0 m, siz ,c, !siz then then ; \ mnemonics : MOV ( src dst -- ) dup s? if 8E c, rm, else dup r? if over ) = over low 0= and if A0 swap w, drop , else over s? if swap 8C c, r, else over # = if nip dup 16? 8 * swap low over or B0 op, ,c, else 8A ow, rm, then then then else ( mem) rot dup s? if 8C c, m, else dup # = if drop C6 siz, 0 m, siz ,c, !siz else over ) = over low 0= and if A2 swap w, drop , else 88 ow, rm, then then then then then ; \ mnemonics : XCHG ( mr1 mr2 -- ) dup r? if over r? if over AX = if swap then dup AX = if drop low 90 op, end then else rot then dup 16? to siz 86 wr, ; : ESC ( src ext-opc -- ) low D8 op, rm, ; : INT ( n -- ) CD over 3 = if nip 1- else c, then c, ; \ : SEG ( seg -- ) mid 26 op, ; \ mnemonics 26 m1 ES: 27 m1 DAA 2E m1 CS: 2F m1 DAS 36 m1 SS: 37 m1 AAA 3E m1 DS: 3F m1 AAS 90 m1 NOP 98 m1 CBW 99 m1 CWD 9B m1 WAIT 9C m1 PUSHF 9D m1 POPF 9E m1 SAHF 9F m1 LAHF CE m1 INTO CF m1 IRET D7 m1 XLAT F0 m1 LOCK F2 m1 REPNZ F3 m1 REPZ aka REPZ REP F4 m1 HLT F5 m1 CMC F8 m1 CLC F9 m1 STC FA m1 CLI FB m1 STI FC m1 CLD FD m1 STD D4 m2 AAM D5 m2 AAD \ mnemonics 70 m3 JO 71 m3 JNO 72 m3 JC aka JC JB 73 m3 JNC aka JNC JNB 74 m3 JZ 75 m3 JNZ 76 m3 JNA 77 m3 JA 78 m3 JS 79 m3 JNS 7A m3 JPE 7B m3 JPO 7C m3 JL 7D m3 JNL 7E m3 JNG 7F m3 JG E0 m3 LOOPNZ E1 m3 LOOPZ E2 m3 LOOP E3 m3 JCXZ EB m3 JU 8D m4 LEA C4 m4 LES C5 m4 LDS A4 m5 MOVS A6 m5 CMPS AA m5 STOS AC m5 LODS AE m5 SCAS \ mnemonics 10 m7 NOT 18 m7 NEG 20 m7 MUL 28 m7 IMUL 30 m7 DIV 38 m7 IDIV E4 m8 IN E6 m8 OUT 00 m9 INC 08 m9 DEC 00 ma ROL 08 ma ROR 10 ma RCL 18 ma RCR 20 ma SHL 28 ma SHR 38 ma SAR C2 mb +RET C3 mb RET 10E8 mc CALL 20E9 mc JMP 8F07 58 md POP FF36 50 md PUSH 00 me ADD 08 me OR 10 me ADC 18 me SBB 20 me AND 28 me SUB 30 me XOR 38 me CMP \ interface \ modifiers : BYTE ( -- ) 0 to siz ; \ BYTE operation : FAR ( -- ) 8 to isf ; \ FAR operation \ macros etc : NEXT !siz lods ax jmp ; \ in-line NEXT : 1PUSH 'next 1- ) jmp ; \ push AX jmp NEXT : 2PUSH 'next 2- ) jmp ; \ push DX then AX jmp NEXT : USER# ( user -- offs ) up @ - ; \ USER offset number : [UP] up ) di mov user# # di add 0 [di] ; \ USER addr \ interface \ kernel address ' next 1+ dup @ + 2+ constant DOCOL ( -- adr ) ' exit 9 + constant EXIT1 ( -- adr ) ' ticks 1+ dup @ + 2+ constant TOD ( -- adr ) ' wait-tick 1+ dup @ + 2+ constant TSYNC ( -- adr ) ' upcase 2+ dup @ + 2+ constant UPC ( -- adr ) \ interface \ reset/check labels and stack point : READY ( -- sp ) csp @ !lb !csp ; : CHECK ( sp -- ) ?csp ?lb csp ! ; : ASM] avoc @ context ! ; : END-CODE ( -- ) ?exec check asm] smudge ; \ end macro definition : ENDM ( sys -- ) postpone ; avoc 2@ context 2! sys ! ; immediate \ interface \ enter high-level forth, saving SI : C: ( -- ) docol ) call asm] ] ; forth definitions assembler hidden : [ASM ( -- ) context @ avoc ! assembler !siz !seg postpone [ ; immediate : LABEL ( -- ) ?exec create smudge postpone [asm ready ; immediate : CODE ( -- ) postpone label 3 -allot ; immediate \ interface : ;CODE ( -- ) postpone (;code) postpone [asm ready ; immediate \ begin macro definition : MACRO ( -- sys ) sys @ context 2@ avoc 2! assembler definitions system : ; \ exit high-level forth, restoring SI : ;C ( -- ) exit1 compile, postpone [asm ; immediate \ No newline at end of file diff --git a/DX-FORTH v430/ASM.TXT b/DX-FORTH v430/ASM.TXT new file mode 100644 index 0000000..2e614af --- /dev/null +++ b/DX-FORTH v430/ASM.TXT @@ -0,0 +1,609 @@ +DX-Forth 8086/87 Assembler +-------------------------- + +Contents: + + 1. Assembler interface + 2. Instruction format + 3. Operands + 4. Data sizes + 5. Instruction aliases + 6. Register usage + 7. Local labels + 8. Structured conditionals + 9. Mixing code and high-level forth +10. No-name code definitions +11. Forth addresses +12. Predefined macros +13. Compiler security +14. Miscellaneous tools +15. 8087 support +16. Error messages +17. F83 differences + + +1. Assembler interface + +Main words: + + CODE Begin a code definition + + LABEL As for CODE but instead of executing the code + sequence, it returns the execution address (xt). + + ;CODE The code equivalent of DOES>. Ends a high-level forth + defining sequence and begins a code sequence that will + be performed when a child word is executed. Used in + the form: + + : CREATE ... ;CODE ... END-CODE + + At run-time the child's parameter field address is + placed on the stack. + + END-CODE End a CODE LABEL or ;CODE definition + +Macro support: + + MACRO name Begin an assembler macro definition + + ENDM End a macro assembler definition + +Mixing code and high-level forth: + + C: Switch from code to begin a forth sequence. Register + SI is pushed to the return stack. + + ;C Switch from forth to begin a code sequence. Register + SI popped from the return stack. + +Miscellaneous: + + [ASM Add ASSEMBLER to the search order. Initialize the + assembler and enter interpret state. Note: does + not clear local labels or initialize stack check. + + ASM] Remove ASSEMBLER from the top of the search order. + Note: does not exit interpret state. + + READY Clear local labels and initialize stack check. + + CHECK Check stack level and resolve labels since READY was + last issued. + + -ASM Discard the assembler and all subsequent words. + + +2. Instruction format + +As with most forth assemblers, operands precede the instruction. +The following examples show DX-Forth assembler syntax as compared +with conventional Intel notation. + + Intel DX-Forth + ----- -------- + CLI CLI + IRET IRET + REP REP + REPNZ REPNZ + CS: CS: + POP AX AX POP + PUSH AX AX PUSH + INT 37 37 INT + IN AX,23 23 # AX IN + IN AX,DX DX AX IN + OUT 23,AL AL 23 # OUT + OUT DX,AL AL DX OUT + MOV AX,BX BX AX MOV + CMP AL,DL DL AL CMP + ROL AX,1 AX ROL + ROL AX,1 AX 1 ROL + ROL AX,CL AX CL ROL + ROL CL,1 CL 1 ROL + XCHG [BX],AX AX 0 [BX] XCHG + XCHG AX,[BX] 0 [BX] AX XCHG + MOV AL,9 9 # AL MOV + MOV AX,1234 1234 # AX MOV + MOV AX,-1 -1 # AX MOV + MOV BX,AX AX BX MOV + MOV [2344],AL AL 2344 ) MOV + MOV AX,[1234] 1234 ) AX MOV + MOV [BX],AL AL 0 [BX] MOV + POP [BX] 0 [BX] POP + MOV [BX+9],AX AX 9 [BX] MOV + MOV [BX+SI+9],AX AX 9 [BX+SI] MOV + JMP 1234 1234 ) JMP + JMP [1122] 1122 [] JMP + JMP FAR [4455] 4455 [] FAR JMP + JMP 5678:1234 1234 5678 ) FAR JMP + JNZ HERE+5 HERE 5 + JNZ + JMP SHORT HERE+5 HERE 5 + JU + RET RET + RETF FAR RET + RET 14 14 +RET + + CMPSB BYTE CMPS + CMPSW CMPS + MOVSB BYTE MOVS + MOVSW MOVS + SCASB BYTE SCAS + SCASW SCAS + LODSB BYTE LODS + LODSW LODS + STOSB BYTE STOS + STOSW STOS + + +3. Operands + +Operands to instructions may be registers, memory locations or +immediate values. When an operand is not a register, it must be +followed by a symbol to indicate its type: + + # operand is an immediate number + ) operand is a memory location + [] operand is an indirect memory location for CALL/JMP + +Exceptions are the loop and short jump instructions - these do not +use ) after the memory address. + + +4. Data sizes + +When the syntax of the instruction does not make it clear, then +the memory operand data size is assumed to be: + +- 16 bit integer for 8086 instructions +- 64 bit real for 8087 instructions + +Valid overides are: + +BYTE ( -- ) 8 bit integer +WORD ( -- ) 16 bit integer +DWORD ( -- ) 32 bit integer or real +QWORD ( -- ) 64 bit integer or real +TBYTE ( -- ) 80 bit real + +Notes: + +- WORD DWORD QWORD TBYTE are present only when the 8087 assembler + extension is loaded. + +- BYTE must only be applied to instructions that require it. + Attempting to use BYTE on instructions which are implicitly 8-bit + e.g. BYTE AL DL MOV may adversely affect subsequent instructions. + + +5. Instruction aliases + +Several Intel 8086 instructions have alias names. The table below +lists the preferred DX-Forth name and the corresponding Intel alias. + + DX-Forth Intel DX-Forth Intel + + JO - JPO JNP + JNO - JL JNGE + JC JB JNAE JNL JGE + JNC JNB JAE JG JNLE + JA JNBE JNG JLE + JNA JBE JU * JMP SHORT + JZ JE LOOPZ LOOPE + JNZ JNE LOOPNZ LOOPNE + JS - REPZ REP REPE + JNS - REPNZ REPNE + JPE JP SHL SAL + +* "Jump Unconditional" + + +6. Register usage + +Code words may use any 8086 cpu register except: + + SI forth interpretive pointer + BP return stack pointer + CS DS SS + +Segment registers CS DS SS are initialised to the forth code +segment CSEG. + +If any of these registers are to be used in a code definition for +other purposes, their contents must be saved beforehand and restored +afterwards. Register ES is free for use as a scratch register. + + +7. Local labels + +The DX-Forth assembler uses local labels to mark addresses for flow +control. Labels are assigned and referenced as follows: + +$: ( n -- ) assign the address of the current dictionary + location HERE to label n + +$ ( n -- addr ) return the address assigned to label n + +The maximum number of labels per definition is 20 and are numbered 1 +to 20. The maximum number of forward references is 25. These limits +should be sufficient for most applications but can be increased by +altering the assembler source and re-compiling. + +8086 instructions that may use forward references as operands includes +jumps, calls and other instructions as determined empirically. + +The following demonstrates the use of labels to define the word 0= . +It uses one label and one forward reference. + + CODE 0= ( n -- flag ) + AX AX SUB \ load AX with false flag (0) + DX POP \ pop n to DX + DX DX OR \ test DX + 1 $ JNZ \ jump to label 1 if DX <> 0 + AX DEC \ change flag to true ($FFFF) + 1 $: \ define label 1 + AX PUSH \ push flag onto stack + 'NEXT ) JMP \ return to forth + END-CODE + +It can be simplified by the use of macros e.g. + + CODE 0= ( n -- flag ) + AX AX SUB + DX POP + DX DX OR + 1 $ JNZ + AX DEC + 1 $: + 1PUSH \ return to forth pushing AX onto stack + END-CODE + + +8. Structured conditionals + +Structured conditionals are an alternative or adjunct to local labels. +They include: + +IF ELSE THEN BEGIN WHILE REPEAT UNTIL AGAIN AHEAD + +Conditionals that perform a test i.e. IF WHILE UNTIL must be +preceeded by one of the following condition flags: + +U>= U< 0<> 0= U> U<= 0>= 0< >= < > <= CY NC OV NO +PO PE CXNZ NEVER + +NEVER is used before a conditional test to create an unconditional +jump. E.g. AHEAD and AGAIN are macros for NEVER IF and NEVER UNTIL +respectively. N.B. Structured conditionals are restricted to short +relative branches. + +Structured conditionals are restricted to short relative branches. + +Example + + CODE 0= ( n -- flag ) + AX AX SUB + DX POP + DX DX OR + 0= IF + AX DEC + THEN + 1PUSH + END-CODE + +Structured conditionals are not included by default and must be loaded +before they can be used e.g. 1 FLOAD ASMCOND.SCR . N.B. If using the +8087 assembler extensions ensure these are loaded before the structured +conditionals. + + +9. Mixing code and high-level forth + +The assembler allows free mixing of machine-code and high-level forth. + +It is sometimes convenient to execute high-level forth words from +within a code definition. + +Example - display a message within a code definition + + CODE TEST ( -- ) + C: \ begin forth + ." Hi There!" + ;C \ end forth + NEXT + END-CODE + +Note: SI register is automatically pushed to the return stack before +the forth sequence executes and restored afterwards. + +The reverse is also possible i.e execute machine code within high- +level forth: + + : TEST ( -- ) + 5 0 DO + I + ;C \ begin code + AX POP 23 # AX ADD AX PUSH + C: \ end code + . + LOOP ; + +See "Register usage" for a list of registers that must be preserved. + + +10. No-name code definitions + +[ASM ASM] READY CHECK allow the user to assemble code sequences for +any imaginable situation. Here is 0= coded as a nameless definition +in the style of :NONAME . + + HERE ( start address of code routine ) + [ASM READY + ( x -- flag ) + AX AX SUB + DX POP + DX DX OR + 1 $ JNZ + AX DEC + 1 $: + 1PUSH \ return to forth pushing AX onto stack + CHECK ASM] + + ( -- xt ) \ leaves xt address + +If local labels are not used or compiler security is not required +then READY CHECK could be omitted. + + +11. Forth addresses + +The following functions return addresses in the forth kernel which +may be useful when writing code definitions. See also 'Predefined +macros'. + +'NEXT ( -- adr ) address of centralized NEXT +UP ( -- adr ) pointer to forth USER area +FSP ( -- adr ) pointer to separate floating-point stack +DOCOL ( -- adr ) enter colon routine +EXIT1 ( -- adr ) exit colon routine +TOD ( -- adr ) routine read BIOS tick timer AX:DX +TSYNC ( -- adr ) routine wait for timer tick, exit AX:DX = TOD +UPC ( -- adr ) routine make AL uppercase + + +12. Predefined macros + +The assembler defines several useful macros - + + NEXT compile in-line NEXT + 1PUSH push AX then jump to NEXT + 2PUSH push DX AX then jump to NEXT + USER# calculate USER variable offset + [UP] USER addressing mode + +1PUSH and 2PUSH make use of the centralized NEXT. Users wanting +maximum performance (at the expense of code size) may replace 1PUSH +and 2PUSH with their in-line equivalents e.g. + + AX PUSH NEXT ... instead of ... 1PUSH + DX PUSH AX PUSH NEXT ... instead of ... 2PUSH + +USER# converts a USER variable address to its offset. Equivalent +to: UP @ - + +[UP] works like an assembler addressing mode taking a USER variable +as an argument. After the operation register DI holds the address +of the specified user variable (unless DI was used as a destination). + +Examples: + + BASE [UP] AX MOV load AX with contents of BASE, DI = addr BASE + 10 # BASE [UP] MOV set BASE to decimal, DI = addr BASE + BASE [UP] PUSH push BASE contents to stack, DI = addr BASE + BASE [UP] DI MOV load DI with contents of BASE + +Note: The [UP] macro can be expensive since it generates three machine +instructions each time it is invoked. If your code routine requires +access to several user variables it may be more efficient to load BX +or DI with the USER base address and use USER# to supply the various +offsets e.g. + + UP ) DI MOV point DI to the USER area + 10 # BASE USER# [DI] MOV set BASE to decimal + >IN USER# [DI] INC increment >IN + + +13. Compiler security + +As with colon definitions, the assembler employs stack checking to +verify statements have been correctly written. Normally very useful +there may be occasions when one needs to turn off stack checking, +albeit temporarily e.g. + + CHECKING OFF + + CODE TEST + ... + HERE ( adr ) \ push location onto the stack + ... + NEXT + END-CODE + + CHECKING ON + + ( adr ) + + +14. Miscellaneous tools + +When machine language is used extensively there can be a need for +tools found in conventional assemblers. Below are several the author +has found useful. They are not resident in the forth assembler but +defined as needed. + + SYSTEM + + \ Adjust HERE to an even address padding with a NOP instruction + : EVEN ( -- ) HERE 1 AND IF $90 C, THEN ; + + \ Name value x + : EQU ( x "name" -- ) SYS @ TUCK 0= SYS ! VALUE SYS ! ; + + \ Name address at HERE and compile a 16-bit value + : DW ( 16b "name" -- ) HERE EQU , ; + + \ Name address at HERE and compile a 8-bit value + : DB ( 8b "name" -- ) HERE EQU C, ; + + APPLICATION + + +15. 8087 support + +ASM87.SCR contain extensions to allow the assembly of 8087 floating +point instructions. Once loaded, the following instructions become +available: + +Intel Forth +----- ----- +F2XM1 F2XM1 +FABS FABS +FADD m/r m/r FADD +FADD ST,ST(n) ST(n) ST FADD +FADD ST(n),ST ST ST(n) FADD +FADDP ST(n),ST ST(n) FADDP +FBLD m/r m/r FBLD +FBSTP m/r m/r FBSTP +FCHS FCHS +FCLEX FCLEX +FCOM m/r m/r FCOM +FCOM ST(n) ST(n) FCOM +FCOMP m/r m/r FCOMP +FCOMP ST(n) ST(n) FCOMP +FCOMPP FCOMPP +FCOS FCOS ** +FDECSTP FDECSTP +FDISI FDISI +FDIV m/r m/r FDIV +FDIV ST,ST(n) ST(n) ST FDIV +FDIV ST(n),ST ST ST(n) FDIV +FDIVP ST(n),ST ST(n) FDIVP +FDIVR m/r m/r FDIVR +FDIVR ST(n),ST ST(n) FDIVR +FDIVRP ST(n),ST ST(n) FDIVRP +FENI FENI +FFREE ST(n) ST(n) FFREE +FIADD m/r m/r FIADD +FICOM m/r m/r FICOM +FICOMP m/r m/r FICOMP +FIDIV m/r m/r FIDIV +FIDIVR m/r m/r FIDIVR +FILD m/r m/r FILD +FIMUL m/r m/r FIMUL +FINCSTP FINCSTP +FINIT FINIT +FIST m/r FIST +FISTP m/r m/r FISTP +FISUB m/r m/r FISUB +FISUBR m/r m/r FISUBR +FLD m/r m/r FLD +FLD ST(n) ST(n) FLD +FLD1 FLD1 +FLDCW m/r m/r FLDCW +FLDENV m/r m/r FLDENV +FLDL2E FLDL2E +FLDL2T FLDL2T +FLDLG2 FLDLG2 +FLDLN2 FLDLN2 +FLDPI FLDPI +FLDZ FLDZ +FMUL m/r m/r FMUL +FMUL ST,ST(n) ST(n) ST FMUL +FMUL ST(n),ST ST ST(n) FMUL +FMULP ST(n),ST ST(n) FMULP +FNOP FNOP +FPATAN FPATAN +FPREM FPREM +FPREM1 FPREM1 ** +FPTAN FPTAN +FRNDINT FRNDINT +FRSTOR m/r m/r FRSTOR +FSAVE m/r m/r FSAVE +FSCALE FSCALE +FSIN FSIN ** +FSINCOS FSINCOS ** +FSQRT FSQRT +FST m/r m/r FST +FST ST(n) ST(n) FST +FSTCW m/r m/r FSTCW +FSTENV m/r m/r FSTENV +FSTP m/r m/r FSTP +FSTP ST(n) ST(n) FSTP +FSTSW AX AX FSTSW * +FSTSW m/r m/r FSTSW +FSUB m/r m/r FSUB +FSUB ST,ST(n) ST(n) ST FSUB +FSUB ST(n),ST ST ST(n) FSUB +FSUBP ST(n),ST ST(n) FSUBP +FSUBR m/r m/r FSUBR +FSUBR ST,ST(n) ST(n) FSUBR +FSUBRP ST(n),ST ST(n) FSUBRP +FTST FTST +FXAM FXAM +FXCH ST(n) ST(n) FXCH +FXTRACT FXTRACT +FYL2X FYL2X +FYL2XP1 FYL2XP1 + +* 80287/80387 only +** 80387 only + +Notes: + +WAIT instructions are not automatically encoded. A WAIT should be +inserted: + + - before each floating point instruction (8087 only) + - after any floating point instruction that writes to memory + +Several Forth and Unix-derived 8087 assemblers are known to have +bugs associated with the following instructions: + + FSUBP + FSUBRP + FDIVP + FDIVRP + FSUB/FSUBR/FDIV/FDIVR ST(i),ST + +Programmers should therefore exercise care when using 8087 source +code taken from third party or public domain sources. + + +16. Error messages + +"definition incomplete" Definition was not properly formed. +"duplicate label" Label number was previously used. +"execution only" Word may be used only during execution. +"invalid label" Incorrect label number or too many + labels used. +"branch out of range" Exceeded the range of a short relative + branch. +"too many references" Exceeded the maximum number of forward + references to labels. +"unresolved reference" A label was referenced but never defined. + +Note: the assembler has limited error checking and it is possible to +compile code using incorrect modes or operands without any warning +given. Take care! + + +17. F83 differences + +The DX-Forth assembler is based on the 8086 assembler included with +Laxen/Perry F83 Forth. Differences from the F83 assembler are: + + - Uses local labels rather than structured conditionals + - REP behaviour changed (in F83, REP functioned as REPNZ !) + - Alternate Intel names used for some conditional jump instructions + - ) and [] replaces #) and S#) + - Additional syntax forms for OUT, XCHG, rotate/shift instructions + - In DX-Forth ;CODE places the child's parameter field address + on top of the stack; in F83 the address was held at BX+2. diff --git a/DX-FORTH v430/ASM87.SCR b/DX-FORTH v430/ASM87.SCR new file mode 100644 index 0000000..a9f6d3e --- /dev/null +++ b/DX-FORTH v430/ASM87.SCR @@ -0,0 +1 @@ +\ 8087 support - information 8087 extensions for DX-FORTH assembler Based on Pollack 8087 assembler \ 8087 support - load block [undefined] ASSEMBLER [if] 1 fload ASM [then] forth definitions hex sys @ system warning @ warning off cr .( loading 8087 Assembler ) 2 #screens 1- thru forth definitions decimal warning ! sys ! \ 8087 support assembler hidden definitions forth 0 value fm \ 0=real32 1=int64 2=int32 3=bcd \ 4=real64 5=tmp80 6=int16 assembler definitions hidden : WORD 6 to fm ; : DWORD 0 to fm ; : QWORD 4 to fm ; : TBYTE 5 to fm ; \ 8087 support A00 constant ST aka ST ST(0) A01 constant ST(1) A02 constant ST(2) A03 constant ST(3) A04 constant ST(4) A05 constant ST(5) A06 constant ST(6) A07 constant ST(7) assembler hidden definitions forth : fst? ( r -- r f ) dup ST and ST = ; : st? ( r -- r f ) dup ST = ; \ 8087 support create fmap \ translation table 0 c, 1 c, 0 c, 3 c, 4 c, 5 c, 4 c, \ real 2 c, 1 c, 2 c, 3 c, 1 c, 5 c, 6 c, \ integer : i/r ( -- ) \ map int/real fm dup 0< if 0FF and 7 + then fmap + c@ to fm ; : fr, ( r m1 m2 -- ) esc, swap low op, ; : esm, ( disp mr m1 m2 ) esc, m, qword ; : fm, ( disp mr m -- ) fm esm, ; : fm1, ( disp mr m -- ) fm 1 or esm, ; \ 8087 support : mf value does> @ , ; : mg constant does> c@ 6 fr, ; : mh value does> dup c@ swap 1+ c@ esm, ; : mi value does> >r fst? if r> c@ 0 fr, else r> 1+ c@ i/r fm, then ; : mj value does> >r fst? if st? if swap 0 esc, low 0 else 4 esc, low r@ 1+ c@ then r> c@ xor op, drop else r> c@ 3F and i/r fm, then ; \ 8087 support : mk value , does> >r fst? if r@ 1+ c@ r@ c@ fr, else r@ 2+ c@ i/r fm case 1 of 8 or 7 esm, endof \ I64 3 of 7 esm, endof \ BCD 5 of 8 or 3 esm, endof \ T80 2drop r@ 3 + c@ fm1, 0 endcase then r> drop ; : ml value does> fm 8000 or to fm @ execute ; : mm 2constant does> 2@ to fm execute ; assembler definitions hidden \ 8087 support D0D9 mf FNOP E0D9 mf FCHS E1D9 mf FABS E4D9 mf FTST E5D9 mf FXAM E8D9 mf FLD1 E9D9 mf FLDL2T EAD9 mf FLDL2E EBD9 mf FLDPI ECD9 mf FLDLG2 EDD9 mf FLDLN2 EED9 mf FLDZ F0D9 mf F2XM1 F1D9 mf FYL2X F2D9 mf FPTAN F3D9 mf FPATAN F4D9 mf FXTRACT F5D9 mf FPREM1 F6D9 mf FDECSTP F7D9 mf FINCSTP F8D9 mf FPREM F9D9 mf FYL2XP1 FAD9 mf FSQRT FBD9 mf FSINCOS FCD9 mf FRNDINT FDD9 mf FSCALE FED9 mf FSIN FFD9 mf FCOS E0DB mf FENI E1DB mf FDISI E2DB mf FCLEX E3DB mf FINIT D9DE mf FCOMPP C0 mg FADDP C8 mg FMULP E0 mg FSUBRP E8 mg FSUBP F0 mg FDIVRP F8 mg FDIVP \ 8087 support 120 mh FLDENV 128 mh FLDCW 130 mh FSTENV 138 mh FSTCW 520 mh FRSTOR 530 mh FSAVE 10D0 mi FCOM 18D8 mi FCOMP 0C0 mj FADD 0C8 mj FMUL 8E8 mj FSUBR 8E0 mj FSUB 8F0 mj FDIV 8F8 mj FDIVR 0020 C001 mk FLD 1830 D805 mk FSTP : FFREE C0 5 fr, ; : FXCH C8 1 fr, ; : FST fst? if D0 5 fr, else i/r 10 fm1, then ; \ 8087 support : FSTSW dup AX = if drop E0DF , else 38 5 esm, then ; ' fadd ml FIADD ' fcom ml FICOM ' fcomp ml FICOMP ' fdiv ml FIDIV ' fdivr ml FIDIVR ' fld ml FILD ' fmul ml FIMUL ' fst ml FIST ' fstp ml FISTP ' fsub ml FISUB ' fsubr ml FISUBR ' fld 3 mm FBLD ' fstp 3 mm FBSTP \ ' fld 5 mm FTLD ' fstp 5 mm FTSTP ( use TBYTE) \ No newline at end of file diff --git a/DX-FORTH v430/ASMCOND.SCR b/DX-FORTH v430/ASMCOND.SCR new file mode 100644 index 0000000..158b211 --- /dev/null +++ b/DX-FORTH v430/ASMCOND.SCR @@ -0,0 +1 @@ +\ 8086 structured conditionals .( 8086 structured conditionals ) assembler definitions hidden hex system warning off 70 constant NO 71 constant OV 72 constant U>= 73 constant U< 74 constant 0<> 75 constant 0= 76 constant U> 77 constant U<= 78 constant 0>= 79 constant 0< 7A constant PO 7B constant PE 7C constant >= 7D constant < 7E constant > 7F constant <= 0E3 constant CXNZ 0EB constant NEVER aka U>= NC aka U< CY : THEN here over rel swap c! ; aka HERE BEGIN : UNTIL c, here rel c, ; : IF c, begin 0 c, ; : AHEAD never if ; : ELSE ahead swap then ; : WHILE if swap ; : AGAIN never until ; : REPEAT again then ; ( : TIMES # CX MOV begin ; ) forth definitions decimal application warning on \ No newline at end of file diff --git a/DX-FORTH v430/ASMTEST.SCR b/DX-FORTH v430/ASMTEST.SCR new file mode 100644 index 0000000..c9b2be5 --- /dev/null +++ b/DX-FORTH v430/ASMTEST.SCR @@ -0,0 +1 @@ +\ Assembler test suite 8086/8087 assembler test suite \ Assembler test suite empty forth definitions decimal application 1 fload ASM87 ( load assemblers if not present ) marker ASMTEST cr .( testing assembler: ) 2 #screens 1- thru cr .( passed) /stack forth forget asmtest decimal application \ Assembler test suite system variable org : /stack ( i*x -- ) begin depth 0> while drop repeat ; : init ( -- ) /stack s" [ASM READY" evaluate here org ! ; \ Assembler test suite \ Test compiled code : { ( -- ) [ assembler ] LODS [ forth ] \ should compile LODSW s" CHECK ASM]" evaluate [char] } parse evaluate $AD \ opcode for LODSW here begin dup org @ u> while 1- dup c@ rot <> if org @ 16 dump -1 abort" failed" then repeat drop here org @ - -allot ( freemem) init ; application \ Assembler test suite hex : adr ( -- l h ) here 1- 0 100 um/mod ; 1234 constant BVAR 1235 constant WVAR 1237 constant LVAR 123B constant SUBR 54329876. 2constant FARSUB init .( 8086 ) AAA { 37 } AAD { D5 0A } AAM { D4 0A } AAS { 3F } DX BX ADC { 11 D3 } 0 [BX+SI] CX ADC { 13 08 } CX 0 [BX+SI] ADC { 11 08 } 3456 # wvar ) ADC { 81 16 35 12 56 34 } FF80 # wvar ) ADC { 83 16 35 12 80 } 5 # AX ADC { 15 05 00 } \ 8086 BX SP ADD { 01 DC } ES: 967 [BX+DI] BP ADD { 26 03 A9 67 09 } AX 967 [BX+DI] ADD { 01 81 67 09 } 6789 # SI ADD { 81 C6 89 67 } 5432 # wvar ) ADD { 81 06 35 12 32 54 } FF80 # wvar ) ADD { 83 06 35 12 80 } 5 # AX ADD { 05 05 00 } SP DI AND { 21 E7 } DS: 1234 [BP+SI] BL AND { 3E 22 9A 34 12 } BP CS: 4567 [BP+SI] AND { 2E 21 AA 67 45 } 6789 # BX AND { 81 E3 89 67 } 1234 # wvar ) AND { 81 26 35 12 34 12 } FF80 # wvar ) AND { 83 26 35 12 80 } 5 # AL AND { 24 05 } \ 8086 here 48 - ) CALL { E8 B5 FF } farsub ) FAR CALL { 9A 76 98 32 54 } wvar [BP+DI] CALL { FF 93 35 12 } CX CALL { FF D1 } lvar [] FAR CALL { FF 1E 37 12 } CBW { 98 } CLC { F8 } CLD { FC } CLI { FA } CMC { F5 } \ 8086 67 # CH CMP { 82 FD 67 } AH BH CMP { 38 E7 } 0 [SI] CL CMP { 3A 0C } SS: AL 0 [SI] CMP { 36 38 04 } 9678 # wvar ) CMP { 81 3E 35 12 78 96 } FF80 # wvar ) CMP { 83 3E 35 12 80 } 5432 # AX CMP { 3D 32 54 } BYTE CMPS { A6 } CMPS { A7 } CS: { 2E } CWD { 99 } DAA { 27 } DAS { 2F } \ 8086 BX DEC { 4B } BL DEC { FE CB } bvar [SI] BYTE DEC { FE 8C 34 12 } wvar [DI] DEC { FF 8D 35 12 } CL DIV { F6 F1 } BX DIV { F7 F3 } bvar ) BYTE DIV { F6 36 34 12 } DS: { 3E } ES: { 26 } HLT { F4 } CL IDIV { F6 F9 } BX IDIV { F7 FB } bvar ) BYTE IDIV { F6 3E 34 12 } \ 8086 CL IMUL { F6 E9 } BX IMUL { F7 EB } bvar ) BYTE IMUL { F6 2E 34 12 } AL 7B # IN { E4 7B } 7B # AL IN ( deprecated) { E4 7B } AX 7B # IN { E5 7B } 7B # AX IN ( deprecated) { E5 7B } DX AL IN { EC } DX AX IN { ED } AX INC { 40 } AL INC { FE C0 } 5 [SI] BYTE INC { FE 44 05 } 0 [BP] INC { FF 46 00 } \ 8086 17 INT { CD 17 } 3 INT { CC } INTO { CE } IRET { CF } here 3 + JA { 77 01 } here 4 - JA { 77 FA } here 3 + JNC { 73 01 } here 4 - JNC { 73 FA } here 3 + JC { 72 01 } here 4 - JC { 72 FA } here 3 + JNA { 76 01 } here 4 - JNA { 76 FA } \ 8086 here 3 + JCXZ { E3 01 } here 3 + JZ { 74 01 } here 4 - JZ { 74 FA } here 3 + JG { 7F 01 } here 4 - JG { 7F FA } here 3 + JNL { 7D 01 } here 4 - JNL { 7D FA } here 3 + JL { 7C 01 } here 4 - JL { 7C FA } here 3 + JNG { 7E 01 } here 4 - JNG { 7E FA } here 3 + JNZ { 75 01 } here 4 - JNZ { 75 FA } here 3 + JNO { 71 01 } \ 8086 here 3 + JNS { 79 01 } here 3 + JPO { 7B 01 } here 4 - JPO { 7B FA } here 3 + JO { 70 01 } here 3 + JPE { 7A 01 } here 4 - JPE { 7A FA } here 3 + JS { 78 01 } here 4 - JU { EB FA } here 3 + JU { EB 01 } here 1234 + ) JMP { E9 31 12 } farsub ) FAR JMP { EA 76 98 32 54 } wvar [] JMP { FF 26 35 12 } BX JMP { FF E3 } lvar [SI] FAR JMP { FF AC 37 12 } \ 8086 LAHF { 9F } LOCK { F0 } lvar [BX] AX LDS { C5 87 37 12 } lvar [BX] BX LEA { 8D 9F 37 12 } lvar [BX] BX LES { C4 9F 37 12 } BYTE LODS { AC } LODS { AD } here 8 - LOOP { E2 F6 } here 9 - LOOPZ { E1 F5 } here 3 + LOOPNZ { E0 01 } \ 8086 DS: AL bvar [BP] MOV { 3E 88 86 34 12 } AX wvar [BX] MOV { 89 87 35 12 } DS: bvar [BP] AL MOV { 3E 8A 86 34 12 } wvar [BX] AX MOV { 8B 87 35 12 } DX CX MOV { 8B CA } DX AX MOV { 8B C2 } bvar ) AL MOV { A0 34 12 } wvar ) AX MOV { A1 35 12 } AL bvar ) MOV { A2 34 12 } AX wvar ) MOV { A3 35 12 } wvar ) BP MOV { 8B 2E 35 12 } BP wvar ) MOV { 89 2E 35 12 } 9876 # DX MOV { BA 76 98 } 1 # DX MOV { BA 01 00 } 1 # DL MOV { B2 01 } \ 8086 lvar # wvar ) MOV { C7 06 35 12 37 12 } 67 # bvar ) byte MOV { C6 06 34 12 67 } CX SS MOV { 8E D1 } DS CX MOV { 8C D9 } wvar ) ES MOV { 8E 06 35 12 } CS wvar ) MOV { 8C 0E 35 12 } BYTE MOVS { A4 } MOVS { A5 } CL MUL { F6 E1 } BX MUL { F7 E3 } bvar ) BYTE MUL { F6 26 34 12 } \ 8086 BL NEG { F6 DB } BX NEG { F7 DB } wvar [BX] NEG { F7 9F 35 12 } BL NOT { F6 D3 } BX NOT { F7 D3 } wvar [BX] NOT { F7 97 35 12 } BH DL OR { 08 FA } 0 [SI] DH OR { 0A 34 } BL 0 [SI] OR { 08 1C } 6789 # BX OR { 81 CB 89 67 } 7698 # wvar ) OR { 81 0E 35 12 98 76 } FF80 # wvar ) OR { 83 0E 35 12 80 } 5 # AX OR { 0D 05 00 } \ 8086 AX 44 # OUT { E7 44 } 44 # AX OUT ( deprecated) { E7 44 } AL 45 # OUT { E6 45 } AX DX OUT { EF } AL DX OUT { EE } AX POP { 58 } ES POP { 07 } wvar [BX] POP { 8F 87 35 12 } POPF { 9D } AX PUSH { 50 } CS PUSH { 0E } wvar [BX] PUSH { FF B7 35 12 } \ 8086 PUSHF { 9C } CX RCL { D1 D1 } AX CL RCL { D3 D0 } wvar ) RCL { D1 16 35 12 } wvar ) CL RCL { D3 16 35 12 } CL 1 RCR { D0 D9 } AL CL RCR { D2 D8 } bvar ) BYTE RCR { D0 1E 34 12 } bvar ) CL BYTE RCR { D2 1E 34 12 } REP BYTE LODS { F3 AC } REPZ BYTE LODS { F3 AC } REPNZ BYTE LODS { F2 AC } \ 8086 RET { C3 } 5 +RET { C2 05 00 } FAR RET { CB } 1234 FAR +RET { CA 34 12 } CL 1 ROR { D0 C9 } AL CL ROR { D2 C8 } bvar ) BYTE ROR { D0 0E 34 12 } bvar ) CL BYTE ROR { D2 0E 34 12 } CL 1 ROL { D0 C1 } AL CL ROL { D2 C0 } bvar ) BYTE ROL { D0 06 34 12 } bvar ) CL BYTE ROL { D2 06 34 12 } \ 8086 SAHF { 9E } CL 1 SHL { D0 E1 } AL CL SHL { D2 E0 } bvar ) BYTE SHL { D0 26 34 12 } bvar ) CL BYTE SHL { D2 26 34 12 } CL 1 SAR { D0 F9 } AL CL SAR { D2 F8 } bvar ) BYTE SAR { D0 3E 34 12 } bvar ) CL BYTE SAR { D2 3E 34 12 } \ 8086 CH BH SBB { 18 EF } 0 [SI] CX SBB { 1B 0C } CL 0 [SI] SBB { 18 0C } 6789 # BX SBB { 81 DB 89 67 } 9988 # wvar ) SBB { 81 1E 35 12 88 99 } FF80 # wvar ) SBB { 83 1E 35 12 80 } 5 # AX SBB { 1D 05 00 } BYTE SCAS { AE } SCAS { AF } CL 1 SHR { D0 E9 } AL CL SHR { D2 E8 } bvar ) BYTE SHR { D0 2E 34 12 } bvar ) CL BYTE SHR { D2 2E 34 12 } \ 8086 SS: { 36 } STC { F9 } STD { FD } STI { FB } BYTE STOS { AA } STOS { AB } \ 8086 DH DL SUB { 28 F2 } 0 [SI] CX SUB { 2B 0C } DL 0 [SI] SUB { 28 14 } 6789 # BX SUB { 81 EB 89 67 } 1234 # wvar ) SUB { 81 2E 35 12 34 12 } FF80 # wvar ) SUB { 83 2E 35 12 80 } 5 # AX SUB { 2D 05 00 } SI SI TEST { 85 F6 } CX 0 [SI] TEST { 85 0C } 6789 # BX TEST { F7 C3 89 67 } 1239 # wvar ) TEST { F7 06 35 12 39 12 } 5 # AX TEST { A9 05 00 } \ 8086 WAIT { 9B } DI AX XCHG { 97 } BL AL XCHG { 86 C3 } BX CX XCHG { 87 CB } DX wvar ) XCHG { 87 16 35 12 } wvar ) DX XCHG { 87 16 35 12 } DL wvar ) XCHG { 86 16 35 12 } wvar ) DL XCHG { 86 16 35 12 } AX 0 [SI] XCHG { 87 04 } 0 [SI] AX XCHG { 87 04 } 0 [SI] AL XCHG { 86 04 } AL 0 [SI] XCHG { 86 04 } XLAT { D7 } \ 8086 BX SI XOR { 31 DE } 0 [SI] CX XOR { 33 0C } DX 0 [SI] XOR { 31 14 } 6789 # BX XOR { 81 F3 89 67 } 1234 # wvar ) XOR { 81 36 35 12 34 12 } FF80 # wvar ) XOR { 83 36 35 12 80 } 5 # AX XOR { 35 05 00 } \ 8086 1 $: 1 $ JNZ 1 $ ) JMP 1 $ ) CALL { 75 FE EB FC E8 F9 FF } 1 $ JNZ 1 $ ) JMP 1 $ ) CALL 1 $: { 75 06 E9 03 00 E8 00 00 } 1 $ ) AL MOV 1 $ ) AX MOV 1 $: { A0 adr A1 adr } AL 1 $ ) MOV AX 1 $ ) MOV 1 $: { A2 adr A3 adr } \ 8086 1 $ ) BL MOV 1 $ ) BX MOV 1 $: { 8A 1E adr 8B 1E adr } 1 $ # AX MOV 1 $: { B8 adr } 3 $ JNZ 1 $: 2 $ JNZ 2 $: 4 $ JNZ 3 $: 2 $ JNZ 4 $: 1 $ JNZ { 75 04 75 00 75 02 75 FC 75 F8 } .( 8087 ) FABS { D9 E1 } ST(1) ST FADD { D8 C1 } ST ST(1) FADD { DC C1 } 9871 [BX] DWORD FADD { D8 87 71 98 } 9871 [BX] FADD { DC 87 71 98 } ST(2) FADDP { DE C2 } wvar ) FBLD { DF 26 35 12 } 8765 [BX] FBSTP { DF B7 65 87 } \ 8087 FCHS { D9 E0 } FCLEX { DB E2 } ST(3) FCOM { D8 D3 } 0 [BP] DWORD FCOM { D8 56 00 } 0 [SI] FCOM { DC 14 } ST(4) FCOMP { D8 DC } 1234 [BP] DWORD FCOMP { D8 9E 34 12 } 9876 [BX] FCOMP { DC 9F 76 98 } FCOMPP { DE D9 } FCOS ( 387 only ) { D9 FF } \ 8087 FDECSTP { D9 F6 } FDISI { DB E1 } ST(5) ST FDIV { D8 F5 } ST ST(4) FDIV { DC FC } wvar ) DWORD FDIV { D8 36 35 12 } wvar ) FDIV { DC 36 35 12 } ST(5) FDIVP { DE FD } ST(6) ST FDIVR { D8 FE } ST ST(5) FDIVR { DC F5 } wvar ) DWORD FDIVR { D8 3E 35 12 } wvar ) FDIVR { DC 3E 35 12 } \ 8087 ST(7) FDIVRP { DE F7 } FENI { DB E0 } ST(1) FFREE { DD C1 } wvar ) WORD FIADD { DE 06 35 12 } wvar ) DWORD FIADD { DA 06 35 12 } wvar ) WORD FICOM { DE 16 35 12 } wvar ) DWORD FICOM { DA 16 35 12 } wvar ) WORD FICOMP { DE 1E 35 12 } wvar ) DWORD FICOMP { DA 1E 35 12 } \ 8087 wvar ) WORD FIDIV { DE 36 35 12 } wvar ) DWORD FIDIV { DA 36 35 12 } wvar ) WORD FIDIVR { DE 3E 35 12 } wvar ) DWORD FIDIVR { DA 3E 35 12 } wvar ) WORD FILD { DF 06 35 12 } wvar ) DWORD FILD { DB 06 35 12 } wvar ) FILD { DF 2E 35 12 } wvar ) WORD FIMUL { DE 0E 35 12 } wvar ) DWORD FIMUL { DA 0E 35 12 } \ 8087 FINCSTP { D9 F7 } FINIT { DB E3 } wvar ) WORD FIST { DF 16 35 12 } wvar ) DWORD FIST { DB 16 35 12 } wvar ) WORD FISTP { DF 1E 35 12 } wvar ) DWORD FISTP { DB 1E 35 12 } wvar ) FISTP { DF 3E 35 12 } wvar ) WORD FISUB { DE 26 35 12 } wvar ) DWORD FISUB { DA 26 35 12 } \ 8087 wvar ) WORD FISUBR { DE 2E 35 12 } wvar ) DWORD FISUBR { DA 2E 35 12 } ST(0) FLD { D9 C0 } wvar ) DWORD FLD { D9 06 35 12 } wvar ) FLD { DD 06 35 12 } wvar ) FLDCW { D9 2E 35 12 } wvar ) FLDENV { D9 26 35 12 } \ 8087 FLDLG2 { D9 EC } FLDLN2 { D9 ED } FLDL2E { D9 EA } FLDL2T { D9 E9 } FLDPI { D9 EB } FLDZ { D9 EE } FLD1 { D9 E8 } ST(1) ST FMUL { D8 C9 } ST ST(3) FMUL { DC CB } wvar ) DWORD FMUL { D8 0E 35 12 } wvar ) FMUL { DC 0E 35 12 } ST(2) FMULP { DE CA } \ 8087 FNOP { D9 D0 } FPATAN { D9 F3 } FPREM { D9 F8 } FPREM1 ( 387 only ) { D9 F5 } FPTAN { D9 F2 } FRNDINT { D9 FC } 1234 ) FRSTOR { DD 26 34 12 } 1234 [BX] FSAVE { DD B7 34 12 } FSCALE { D9 FD } FSIN ( 387 only ) { D9 FE } FSINCOS ( 387 only ) { D9 FB } FSQRT { D9 FA } \ 8087 ST(5) FST { DD D5 } wvar ) DWORD FST { D9 16 35 12 } wvar ) FST { DD 16 35 12 } wvar ) FSTCW { D9 3E 35 12 } wvar ) FSTENV { D9 36 35 12 } ST(0) FSTP { DD D8 } wvar ) DWORD FSTP { D9 1E 35 12 } wvar ) FSTP { DD 1E 35 12 } wvar ) FSTSW { DD 3E 35 12 } AX FSTSW ( 287/387) { DF E0 } \ 8087 ST(1) ST FSUB { D8 E1 } ST ST(1) FSUB { DC E9 } wvar ) DWORD FSUB { D8 26 35 12 } wvar ) FSUB { DC 26 35 12 } ST(6) FSUBP { DE EE } ST(3) ST FSUBR { D8 EB } ST ST(3) FSUBR { DC E3 } wvar ) DWORD FSUBR { D8 2E 35 12 } wvar ) FSUBR { DC 2E 35 12 } ST(3) FSUBRP { DE E3 } \ 8087 wvar ) TBYTE FLD { DB 2E 35 12 } FTST { D9 E4 } wvar ) TBYTE FSTP { DB 3E 35 12 } FXAM { D9 E5 } ST(3) FXCH { D9 CB } FXTRACT { D9 F4 } FYL2X { D9 F1 } FYL2XP1 { D9 F9 } F2XM1 { D9 F0 } \ No newline at end of file diff --git a/DX-FORTH v430/BLK2TXT.SCR b/DX-FORTH v430/BLK2TXT.SCR new file mode 100644 index 0000000..f478db1 --- /dev/null +++ b/DX-FORTH v430/BLK2TXT.SCR @@ -0,0 +1 @@ +\ BLK2TXT - Information Convert forth screen files to ascii text. \ BLK2TXT - Load screen FORTH DEFINITIONS DECIMAL APPLICATION 2 LOAD \ compile program TURNKEY MAIN BLK2TXT \ create turnkey application \ BLK2TXT - HELP ARGV GETARG \ Show help : HELP ( -- ) ." Usage: BLK2TXT file[.SCR] file[.TXT]" CR ." Convert Forth screen files to ASCII text." CR ; \ Parse blank delimited argument from commandline. : ARGV ( n -- adr u -1 | 0 ) 0 0 ROT 128 COUNT ROT 0 ?DO 2NIP BL SKIP 2DUP BL SCAN ROT OVER - -ROT LOOP 2DROP DUP IF -1 ELSE AND THEN ; \ Get argument, if none show help and exit : GETARG ( n -- adr u ) ARGV 0= IF HELP ABORT THEN ; --> \ BLK2TXT - F1 F2 FERROR H1 H2 \ Filename buffers CREATE F1 80 ALLOT CREATE F2 80 ALLOT \ Display filename and exit : FERROR ( adr -- ) COUNT TYPE ABORT ; \ File handles VARIABLE H1 VARIABLE H2 --> \ BLK2TXT - GETLN PUT COPY-FILE \ Read a line (64 chars max), u = #chars actually read : GETLN ( -- u ) PAD 64 H1 @ READ-FILE ABORT" read error" ; \ Write u chars to output file : PUT ( u -- ) PAD SWAP -TRAILING H2 @ WRITE-LINE ABORT" write error: probably out of disk space" ; \ Copy loop : COPY-FILE ( -- ) BEGIN GETLN ?DUP WHILE ( not end-of-file ) PUT REPEAT ; --> \ BLK2TXT - OPEN-FILES \ Open source and destination files : OPEN-FILES ( -- ) 1 GETARG S" SCR" +EXT 2DUP F1 PLACE R/O OPEN-FILE \ open 1st IF ." can't open: " F1 FERROR THEN H1 ! \ save handle 2 GETARG S" TXT" +EXT 2DUP F2 PLACE 2DUP R/O OPEN-FILE NIP 0= \ create 2nd IF ." file exists: " F2 FERROR THEN R/W CREATE-FILE IF ." can't create: " F2 FERROR THEN H2 ! ; \ save handle --> \ BLK2TXT - CLOSE-FILES MAIN \ Close source and destination files : CLOSE-FILES ( -- ) H1 @ CLOSE-FILE IF ." error closing: " F1 FERROR THEN H2 @ CLOSE-FILE IF ." error closing: " F2 FERROR THEN ; : MAIN ( -- ) CR ." BLK2TXT" CR OPEN-FILES COPY-FILE CLOSE-FILES ." file copied" CR ; \ No newline at end of file diff --git a/DX-FORTH v430/BREAKGO.SCR b/DX-FORTH v430/BREAKGO.SCR new file mode 100644 index 0000000..70434f5 --- /dev/null +++ b/DX-FORTH v430/BREAKGO.SCR @@ -0,0 +1 @@ +\ BREAK GO Breakpoint tool (adapted from Forth Dimensions 5/1) BREAK is inserted into the application source code at the point to be debugged. When BREAK is subsequently executed, the application is temporarily halted and the current stack contentsdisplayed. The user will then be in a special interpret loop (indicated by the '' prompt) during which time the system may be examined. The application can be resumed at any time using GO. Executing QUIT or ABORT while halted (e.g. as a result of mistyping a command) will result in the user dropping back to forth. \ BREAK GO forth definitions system variable bsd create buf 80 allot : bip ( -- ) begin cr ." " buf dup 80 accept space evaluate again ; \ Halt application : BREAK ( i*x -- i*x ) cr ." BREAK stack = " .s depth bsd ! ['] bip catch dup -256 - if throw else drop then ; \ Resume application : GO ( i*x -- i*y ) depth bsd @ - bsd off abort" stack changed" -256 throw ; application behead bsd bip \ No newline at end of file diff --git a/DX-FORTH v430/CHANGES.TXT b/DX-FORTH v430/CHANGES.TXT new file mode 100644 index 0000000..60c7f57 --- /dev/null +++ b/DX-FORTH v430/CHANGES.TXT @@ -0,0 +1,45 @@ + IMPORTANT CHANGES + +This document discusses changes to DX-Forth for DOS that may adversely +affect previously written programs. It is recommended users update their +programs to the latest DX-Forth version. See WHATSNEW.TXT for a summary +of other changes and additions. + + +v4.30 + + Removed immediate EXIT and renamed (EXIT) to EXIT. + +v4.07 + + -TRAILING ZCOUNT now use the SSEG segment. See SSEG in the glossary + for details. + +v4.05 + + EDIT can no longer be used to load the editor from disk. You must use + SED or TED for that. Once the editor is loaded and saved as part of + the system, EDIT can be added as a synonym. + +v4.03 + + ALLOT has been changed (for the better). Unlike Forth-94 ALLOT only + unsigned values may be used. Applications which used negative values + with ALLOT should be changed to use -ALLOT instead. Programs which + require Forth-94 behaviour can be accommodated with the following + redefinition: + + : ALLOT ( n -- ) NEGATE -ALLOT ; + + Note however that memory checking is not performed. + +v4.02 + + Functions '.' and '?' adopt the eForth behaviour i.e. when BASE is + decimal display signed; otherwise display unsigned. Only these + functions and those which use them are affected. Applications + requiring Forth-94 behaviour may redefine: + + : . ( n -- ) S>D D. ; + + diff --git a/DX-FORTH v430/DISCLAIM.TXT b/DX-FORTH v430/DISCLAIM.TXT new file mode 100644 index 0000000..2515865 --- /dev/null +++ b/DX-FORTH v430/DISCLAIM.TXT @@ -0,0 +1,11 @@ +Disclaimer: + +The projects presented here are experimental in nature. They +may be incomplete, not fully tested or contain defects. Being +free software, it is provided 'as is' and without any warranty. +Use of these projects or information is strictly at your own +risk and responsibility. + +Project material written and created by the author is public +domain; any non-original or reference material included may be +subject to copyright by their respective owners. diff --git a/DX-FORTH v430/DOSLIB.SCR b/DX-FORTH v430/DOSLIB.SCR new file mode 100644 index 0000000..d67dd79 --- /dev/null +++ b/DX-FORTH v430/DOSLIB.SCR @@ -0,0 +1 @@ +\ Information NEWAPP is a skeletal program that allows users to quickly develop a DOS application. It provides often needed tasks including error handling, command-line parsing, file operations, buffered I/O, help screen, number and string functions. NEWAPP comprises two parts: NEWAPP.SCR skeletal application program DOSLIB.SCR function support library \ Module loader cr .( DOSLIB 2017-01-18 ) cr base @ sys @ decimal system -? loadfile -path 2constant lib -? : MODULE 2constant does> 2@ lib loaded ; 2 load behead lib module sys ! base ! \ Module directory - NEWAPP support 5 6 module _Errors \ error handler 7 dup module _Inout1 \ number output 8 dup module _Inout2 \ string & number input 9 dup module _Compare1 \ basic compare 10 12 module _String1 \ basic strings 13 dup module _String2 \ extra strings 14 19 module _Parsing1 \ command-line parsing 20 dup module _Parsing2 \ command-line parsing 21 23 module _Fileprims \ file primitives 24 32 module _Files \ default files 33 dup module _Bufinfile \ buffered input file 34 dup module _Bufoutfile \ buffered output file 35 dup module _Dos1 \ dosver dta 36 dup module _Dos2 \ ctl-brk int --> \ Module directory - DOS & misc 37 dup module _Disk \ disk 38 dup module _Memory \ memory allocate 39 40 module _Timedate1 \ time/date 41 dup module _Timedate2 \ time/date 42 dup module _Timepack \ time/date packing 43 dup module _Filematch \ file find first/next 44 dup module _Filestamp \ file stamp/attribute 45 dup module _Diskdir \ directory 46 dup module _Env \ environment 47 49 module _Exec \ exec prog/command 50 51 module _Video1 \ textcolor attrib cursor 52 dup module _Video2 \ mode page --> \ Module directory - DOS & misc 53 dup module _Timing1 \ timer 54 dup module _Timing2 \ delay 55 dup module _Timing3 \ timer0 mode 56 57 module _Device1 \ 8087 cpu keybd \ Errors - +IS ?THROW ?CATCH system \ Add new behaviour to existing deferred word : +IS ( xt -- ) >r :noname r> compile, ' >body dup >r @ compile, postpone ; r> ! ; application \ THROW exception code n if flag is non-zero : ?THROW ( flag n -- ) swap 0<> and throw ; \ Perform CATCH intercepting exception code n only : ?CATCH ( xt n -- n ) >r catch dup r> <> over and throw ; \ Errors - ERROR1 ERROR2 ESC= ESCKEY? (?BREAK) \ Quit to DOS with no msg and return code = 1 : ERROR1 ( -- ) abort ; \ Quit with abort msg : ERROR2 ( -- ) ." ... aborting" error1 ; \ Test char for ESC or Ctrl-C : ESC= ( char -- flag ) dup #27 = swap 3 = or ; \ Check if ESC or Ctrl-C key was pressed : ESCKEY? ( -- flag ) 0 key? if key esc= or then ; \ Check user break : (?BREAK) ( -- ) esckey? if beep cr ." User break - exit program? " y/n if error2 then then ; \ Inout1 - Number output : (UD.) ( ud -- addr u ) <# #s #> ; : UD. ( ud -- ) (ud.) type space ; : UD.R ( ud n -- ) >r (ud.) r> s.r ; : (DH.N) ( ud n -- ) base @ >r hex <# 0 do # loop #> r> base ! ; : (DH.) ( ud -- addr u ) 4 cells (dh.n) ; : (HW.) ( u -- addr u ) 0 4 (dh.n) ; : (HB.) ( u -- addr u ) 0 2 (dh.n) ; : DH. ( ud -- ) (dh.) type space ; : HW. ( u -- ) (hw.) type space ; : HB. ( u -- ) (hb.) type space ; \ Inout2 - INPUT INPUT# BACKSPACES \ Input string n chars max false = empty or blanks : INPUT ( n -- c-addr u true | false ) here dup rot accept -blanks dup if -1 else and then ; \ Input number n chars max false = empty or blanks : INPUT# ( n -- d true | false ) input dup if drop number? then ; \ Display n backspace characters : BACKSPACES ( n -- ) 0 max 0 ?do 8 emit loop ; \ Compare1 - DIGIT? ALPHA? \ Return true if char is decimal digit : DIGIT? ( char -- flag ) [char] 0 - #10 u< ; \ Return true if char is alphabetical : ALPHA? ( char -- flag ) upcase [char] A - #26 u< ; \ String1 - SPLIT /SPLIT STRING/ \ Split string at character leaving first on top : SPLIT ( a u c -- a2 u2 a3 u3 ) >r 2dup r> scan 2swap 2 pick - ; \ Split string at index n leaving first on top: \ >r over r@ 2swap r> /string 2swap code /SPLIT ( a u n -- a2 u2 a3 u3 ) ax pop sp bx mov 2 [bx] push ax 0 [bx] sub ax 2 [bx] add 1push end-code \ Return u right-most characters of string: >r + r@ - r> code STRING/ ( a1 u1 u -- a2 u2 ) ax pop bx pop dx pop bx dx add ax dx sub 2push end-code \ String1 - C+STRING C/STRING STRING/C \ Append character to end of string: 2dup 2>r + c! 2r> 1+ code C+STRING ( c a u -- a2 u2 ) cx pop bx pop ax pop bx push cx bx add cx inc cx push al 0 [bx] mov next end-code \ Extract character from start of string: 1 /string over 1- c@ code C/STRING ( a u -- a2 u2 char ) cx pop ax pop ax bx mov cx dec ax inc ax push cx push 0 # ah mov 0 [bx] al mov 1push end-code \ Extract character from end of string: 1- 2dup + c@ code STRING/C ( a u -- a2 u2 c ) cx pop bx pop cx dec bx push cx push cx bx add 0 # ah mov 0 [bx] al mov 1push end-code \ String1 - S= \ Compare two strings for equality : S= ( a1 u1 a2 u2 -- flag ) compare 0= ; \ String2 - S+ STRING S! #255 ( buffer size ) -? create sb dup , allot \ Concatenate two strings placing result in temp buffer : S+ ( a1 u1 a2 u2 -- a3 u3 ) 2>r sb @ umin sb cell+ 0 +string sb @ over - 2r> rot min 2swap +string ; behead sb sb \ Define string variable with max length u -? : STRING create ( u -- ) #255 min dup c, 0 c, allot does> ( -- sa su ) 1+ count ; \ Store string a u to string variable : S! ( a u sa su -- ) drop 1- dup >r 1- c@ umin r> place ; \ Parsing1 - 'ARG /ARG ARG! ARGV create 'ARG ( -- a ) 3 cells allot \ Reset parser to beginning : /ARG ( -- ) 'arg off ; \ Assign string for parsing : ARG! ( a u -- ) 'arg cell+ 2! /arg ; here 0 arg! \ Parse next blank delimited argument : ARGV ( -- a u -1 | 0 ) 1 'arg +! 'arg cell+ 2@ 0 0 'arg @ 0 ?do 2drop bl skip bl split loop 2nip dup if -1 else and then ; \ Parsing1 - BADOPTION ?BADOPTION /NUM /HEXNUM /NUMRANGE : BADOPTION ( -- ) cr ." Invalid option" error2 ; : ?BADOPTION ( f -- ) 0= if badoption then ; \ Parse number n|u from string : /NUM ( a u -- 0 0 n|u ) number? ?badoption drop 0 0 ( stop parsing) rot ; \ Parse hex number n|u from string : /HEXNUM ( a u -- 0 0 n|u ) base @ >r hex /num r> base ! ; \ /NUM with range check : /NUMRANGE ( a u n|u1 n|u2 -- 0 0 n|u3 ) 2>r /num dup 2r> between ?badoption ; \ Parsing1 - SETOPTION \ Process each character in a switch option string defer SETOPTION ( a u char -- a u ) ' drop is setoption \\ \ Example of use : (SETOPTION) ( a u char -- a u ) upcase [char] A = if A-variable on else badoption then ; ' (setoption) is setoption \ Parsing1 - PARSEOPTION \ Parse multiple switch options from the command-line : PARSEOPTION ( -- ) begin argv while ( not end ) c/string $FD and [char] - = if ( '-' or '/' ) begin dup while c/string setoption repeat 2drop else 2drop -1 'arg +! ( backup ) end repeat ; \ Parsing1 - PARSEFILENAME \ Parse one or more strings/filenames from the command-line defer PARSEFILENAME ( -- ) ' noop is parsefilename \\ \ Example of use : (PARSEFILENAME) ( -- ) argv 0= if ." no filename specified" error1 then infile setname ; ' (parsefilename) is parsefilename \ Parsing1 - PARSECMD \ Parse string setting options and filenames : PARSECMD ( a u -- ) arg! parseoption parsefilename ; \ Parsing2 - /RAWNUM FIRSTNUM NEXTNUM \ Parse raw number n|u from string - stops at non-digit, \ empty string returns n|u=0 : /RAWNUM ( a u -- a' u' n|u ) over c@ [char] - = over 0> and dup >r 1 and /string 0 0 2swap >number 2swap r> if dnegate then drop ; \ Parse first number, return false if string empty : FIRSTNUM ( a u -- a' u' n|u -1 | a' 0 0 ) dup if /rawnum -1 else 0 then ; \ As FIRSTNUM but skip first character : NEXTNUM ( a u -- a' u' n|u -1 | a' 0 0 ) dup 0> abs /string firstnum ; \ Fileprims - ?FERROR \ Display msg and abort on file error : ?FERROR ( ior n -- ) swap if cr ." File " cond 3 of ." read" else 4 of ." write" else 5 of ." position" else 6 of ." size" else . thens ." error" error2 else drop then ; \ Fileprims - FREAD FWRITE FREADLN FWRITELN \ Read binary : FREAD ( a u fid -- a u2 ) ?break 2>r dup 2r> read-file 3 ?ferror ; \ Write binary : FWRITE ( a u fid -- ) ?break write-file 4 ?ferror ; \ Read text flag=0 if end-of-file : FREADLN ( a u fid -- a u2 flag ) ?break 2>r dup 2r> read-line 3 ?ferror ; \ Write text : FWRITELN ( a u fid -- ) ?break write-line 4 ?ferror ; \ Fileprims - FPOS FREPOS FSIZE FRESIZE \ Get file position : FPOS ( fid -- ud ) file-position 5 ?ferror ; \ Reposition file : FREPOS ( ud fid -- ) reposition-file 5 ?ferror ; \ Get file size : FSIZE ( fid -- ud ) file-size 6 ?ferror ; \ Resize file : FRESIZE ( ud fid -- ) resize-file 6 ?ferror ; \ Files - HANDLE SETNAME FILENAME .FILE \ Create file handle -? : HANDLE ( "name" -- ; -- handle ) create 0 , \ FID 0=closed 0 c, #79 chars allot ; \ filename \ Assign filename to a handle : SETNAME ( a u handle -- ) dup off cell+ >r #79 min r> pack count upper ; \ Get filename : FILENAME ( handle -- a u ) cell+ count ; \ Display filename : .FILE ( handle -- ) filename type ; \ Files - FOPEN (FOPEN) : FOPEN ( fam handle -- ior ) dup >r filename rot open-file tuck 0= and r> ! ; : (FOPEN) ( fam handle -- ) tuck fopen ?dup if cr over .file $FF and cond 2 of ." file not found" else 3 of ." path not found" else 4 of ." too many open files" else 5 of ." access denied" else ." open error " . thens error2 then drop ; \ Files - FMAKE (FMAKE) variable WRTCHK wrtchk on \ overwrite check : FMAKE ( fam handle -- ior ) dup >r filename rot create-file tuck 0= and r> ! ; : (FMAKE) ( fam handle -- ) tuck wrtchk @ if ( overwrite check ) dup filename r/o open-file 0= if close-file beep cr over .file ." exists - overwrite? " y/n 0= if error2 then then drop then fmake if cr .file ." make error" error2 then drop ; \ Files - FCLOSE : FCLOSE ( handle -- ior ) dup @ dup if close-file then swap off ; \ Files - default handles handle INFILE \ input file handle handle OUTFILE \ output file handle here value INBUF \ buffer address #512 value /INBUF \ buffer size variable INSIZ variable INPTR here value OUTBUF \ buffer address #512 value /OUTBUF \ buffer size variable OUTSIZ variable OUTPTR : RESETINBUF ( -- ) inbuf inptr ! insiz off ; : RESETOUTBUF ( -- ) outbuf outptr ! outsiz off ; \ Files - OPENINFILE MAKEOUTFILE OPENOUTFILE \ Open file for input using file access mode : OPENINFILE ( fam -- ) infile (fopen) resetinbuf ; \ Create file for output using file access mode : MAKEOUTFILE ( fam -- ) outfile (fmake) resetoutbuf ; \ Open existing file for output using file access mode : OPENOUTFILE ( fam -- ) outfile (fopen) resetoutbuf ; \ Files - CLOSEINFILE CLOSEOUTFILE CLOSEFILES defer (flushwrite) ( -- ior ) ' false is (flushwrite) \ Close input file - errors not reported : CLOSEINFILE ( -- ) infile fclose drop ; \ Close output file - errors not reported : CLOSEOUTFILE ( -- ) outfile dup @ if (flushwrite) drop then fclose drop ; \ Close files - errors not reported defer CLOSEFILES ( -- ) :noname ( -- ) closeinfile closeoutfile ; is closefiles ' closefiles +is onerror \ close files on error \ Files - DELOUTFILE REPOSIN/OUTFILE IN/OUTFILEPOS \ Close and delete output file - errors not reported : DELOUTFILE ( -- ) outfile @ closeoutfile if outfile filename delete-file drop then ; \ Reposition input file : REPOSINFILE ( ud -- ) infile @ frepos resetinbuf ; \ Reposition output file : REPOSOUTFILE ( ud -- ) (flushwrite) 4 ?ferror outfile @ frepos ; \ Get input file position : INFILEPOS ( -- ud ) infile @ fpos insiz @ 0 d- ; \ Get output file position : OUTFILEPOS ( -- ud ) outfile @ fpos outsiz @ 0 d+ ; \ Files - READDATA WRITEDATA READTEXT WRITETEXT FLUSHWRITE \ Read binary from input file : READDATA ( a u1 -- a u2 ) infile @ fread ; \ Write binary to output file : WRITEDATA ( a u -- ) outfile @ fwrite ; \ Read text from input file flag=0 if end-of-file : READTEXT ( a u1 -- a u2 flag ) infile @ freadln ; \ Write text to output file : WRITETEXT ( a u -- ) outfile @ fwriteln ; \ Flush output file to disk : FLUSHWRITE ( -- ) (flushwrite) 4 ?ferror outfile @ flush-file 4 ?ferror ; \ Bufinfile - READCHAR here to inbuf /inbuf allot resetinbuf : refillread ( -- ) \ refill read buffer resetinbuf inbuf /inbuf readdata insiz ! drop ; \ Read char from buffered input \ : READCHAR ( -- char -1 | 0 ) insiz @ 0= if refillread then \ insiz @ if inptr @ c@ 1 inptr +! -1 insiz +! -1 else 0 then ; code READCHAR ( -- char -1 | 0 ) 0 # insiz ) cmp 1 $ jnz c: refillread ;c 1 $: ax ax sub ax insiz ) cmp 2 $ jz inptr ) di mov 0 [di] al mov ax push inptr ) inc insiz ) dec -1 # ax mov 2 $: 1push end-code \ Bufoutfile - WRITECHAR here to outbuf /outbuf allot resetoutbuf :noname ( -- ior ) \ flush write buffer outbuf outsiz @ outfile @ write-file resetoutbuf ?break ; is (flushwrite) \ Write char to buffered output \ : WRITECHAR ( char -- ) outsiz @ /outbuf = if (flushwrite) \ 4 ?ferror then outptr @ c! 1 outptr +! 1 outsiz +! ; code WRITECHAR ( char -- ) addr /outbuf ) ax mov outsiz ) ax cmp 1 $ jnz c: (flushwrite) 4 ?ferror ;c 1 $: ax pop outptr ) di mov al 0 [di] mov outptr ) inc outsiz ) inc next end-code \ Dos1 - DOSVER GETDTA SETDTA \ DOS version \ : DOSVER ( -- minor major ) $30 doscall 'AH c@ 'AX c@ ; \ Get/set DTA address : GETDTA ( -- seg offs ) $2F doscall 'ES @ 'BX @ ; : SETDTA ( seg offs -- ) 'DX ! 'DS ! $1A 'AH c! $21 intcall ; \ Dos2 - GETCBRK SETCBRK GETINT SETINT \ Get/set Ctrl-Brk 0=off 1=on : GETCBRK ( -- n ) 0 'AX c! $33 doscall 'DX c@ ; : SETCBRK ( n -- ) 'DX c! 1 'AX c! $33 doscall ; \ Get/set interrupt : GETINT ( n -- seg offs ) 'AX c! $35 doscall 'ES @ 'BX @ ; : SETINT ( seg offs n -- ) $2500 or 'AX ! 'DX ! 'DS ! $21 intcall ; \ Disk - DISKFREE DISKSIZE GETDISK SELDISK RESETDISK -? : dsk ( n reg -- d ) swap 'DX c! $36 doscall @ 'AX @ um* 'CX @ 1 m*/ ; \ Get freespace/size/path on drive n 0=default 1=A 2=B etc \ Errors not reported : DISKFREE ( n -- d ) 'BX dsk ; : DISKSIZE ( n -- d ) 'DX dsk ; behead dsk dsk \ Get/select current drive 0=A 1=B etc : GETDISK ( -- dsk ) $19 doscall 'AX c@ ; : SELDISK ( dsk -- ) 'DX c! $0E doscall ; \ Reset drives - use before disk change, resets DTA : RESETDISK ( -- ) $0D doscall ; \ Memory - GETMEM RELMEM SETMEM \ Allocate u paragraphs of memory : GETMEM ( par -- seg|maxpar ior ) 'BX ! $48 doscall doserr? dup if 'BX else 'AX then @ swap ; \ Free previously allocated memory : RELMEM ( seg -- ior ) 'ES ! $49 doscall doserr? ; \ Resize previously allocated memory : SETMEM ( seg par -- maxpar ior ) 'BX ! 'ES ! $4A doscall 'BX @ doserr? ; \ Timedate1 - TIME DATE !TIME !DATE \ Get current time/date : TIME ( -- sec min hour ) $2C doscall 'DH c@ 'CX c@ 'CH c@ ; : DATE ( -- day mon year ) $2A doscall 'DX c@ 'DH c@ 'CX @ ; \ Set current time/date : !TIME ( sec min hour -- error ) 'CH c! 'CX c! 'DH c! 0 'DX c! $2D doscall 'AX c@ ; : !DATE ( day mon year -- error ) 'CX ! 'DH c! 'DX c! $2B doscall 'AX c@ ; \ Timedate1 - H:M:S D-M-Y M-D-Y Y-M-D \ Convert time to string : H:M:S ( sec min hour -- addr u ) swap rot <# 2 0 do 0 # # 2drop [char] : hold loop 0 # # #> ; \ Convert date to string : D-M-Y ( day mon year -- addr u ) <# 0 # # # # 2 0 do 2drop [char] - hold 0 # # loop #> ; \ Convert date to string : M-D-Y ( day mon year -- addr u ) rot swap d-m-y ; \ Convert date to string : Y-M-D ( day mon year -- addr u ) swap rot <# 2 0 do 0 # # 2drop [char] - hold loop 0 # # # # #> ; \ Timedate2 - $MONTH D-MMM-Y \ Convert month to string : $MONTH ( n -- a u ) 1- 3 * s" JanFebMarAprMayJunJulAugSepOctNovDec" drop + 3 ; \ Convert date to string : D-MMM-Y ( day mon year -- a u ) <# 0 # # # # 2drop [char] - hold $month shold [char] - hold 0 # # #> ; \ Timepack - PACKDATE PACKTIME UNPACKDATE UNPACKTIME \ Pack date in MSDOS format : PACKDATE ( day mon year -- date ) #1980 - 9 lshift swap #15 and 5 lshift or swap #31 and or ; \ Pack time in MSDOS format : PACKTIME ( sec min hour -- time ) #11 lshift swap #63 and 5 lshift or swap 2/ #31 and or ; \ Unpack MSDOS format date : UNPACKDATE ( date -- day mon year ) dup #31 and swap 5 rshift dup #15 and swap 4 rshift #1980 + ; \ Unpack MSDOS format time : UNPACKTIME ( time -- sec min hour ) dup #31 and 2* swap 5 rshift dup #63 and swap 6 rshift ; \ Filematch - FINDFIRST FINDNEXT DTA.ATTR DTA.TIME DTA.DATE ... \ Find first matching file. Uses default DTA : FINDFIRST ( a u attrib -- ior ) cseg $80 setdta 'CX ! >fname 1+ 'DX ! $4E doscall doserr? ; \ Find next matching file : FINDNEXT ( -- ior ) $4F doscall doserr? ; \ Matched file data. Assume default DTA. : DTA.ATTR ( -- attrib ) [ $80 $15 + ] literal c@ ; : DTA.TIME ( -- time ) [ $80 $16 + ] literal @ ; : DTA.DATE ( -- date ) [ $80 $18 + ] literal @ ; : DTA.SIZE ( -- ud ) [ $80 $1A + ] literal 2@ swap ; : DTA.NAME ( -- addr u ) [ $80 $1E + ] literal zcount ; \ Filestamp - @FILESTAMP !FILESTAMP @FILEATTR !FILEATTR \ Get disk file packed timestamp : @FILESTAMP ( fid -- date time ior ) 'BX ! 0 'AX c! $57 doscall 'DX @ 'CX @ doserr? ; \ Set disk file packed timestamp : !FILESTAMP ( date time fid -- ior ) 'BX ! 'CX ! 'DX ! 1 'AX c! $57 doscall doserr? ; \ Get disk file attributes aka file-status @FILEATTR ( a u -- attrib ior ) \ Set disk file attributes : !FILEATTR ( attrib a u -- ior ) >fname 1+ 'DX ! 'CX ! 1 'AX c! $43 doscall doserr? ; \ Diskdir - CHDIR MKDIR RMDIR -? : dir ( a u fn -- ior ) -rot >fname 1+ 'DX ! doscall doserr? ; \ Directory change/make/remove : CHDIR ( a u -- ior ) $3B dir ; : MKDIR ( a u -- ior ) $39 dir ; : RMDIR ( a u -- ior ) $3A dir ; behead dir dir \ Env - ENVSEG GETENV \ Return DOS environment segment : ENVSEG ( -- seg ) $2C @ ; \ Search DOS environment for string a u. Return null \ terminated remainder. Null not included in count. : GETENV ( a u -- seg zadr len true | false ) 2>r envseg dup sseg ! 0 begin 2dup @l while 1+ repeat 2+ r@ 0 rot 2r> caps search if rot /string drop zcount true else 2drop 2drop 0 then cseg sseg ! ; \ Exec - pb .. !fcb \ requires GETDTA GETENV warning @ warning off create pb 14 allot \ parameter block create ct 128 allot \ command tail create f1 37 allot \ fcb1 create f2 37 allot \ fcb2 : fcb! ( zadr fcb -- zadr' ) 'DI ! 'SI ! cseg 'ES ! 1 'AX c! $29 doscall 'SI @ ; : !fcb ( -- ) ct 1+ f1 fcb! f2 fcb! drop cseg f1 [ pb 6 + ] literal 2! cseg f2 [ pb 10 + ] literal 2! ; \ Exec - (exec) : (exec) ( a u seg zadr flag -- ior ) getdta 2>r >r 2swap pb 14 erase cseg ct [ pb 2+ ] literal 2! ct 1+ 0 2 pick r@ and if s" /C " 2swap +string then +string dup ct c! + $0D swap c! r> 0= if !fcb then 'DX ! 'DS ! pb 'BX ! cseg 'ES ! $4B00 'AX ! $21 intcall doserr? 2r> setdta ; warning ! \ Exec - EXEC SHELL RETCODE \ Execute program : EXEC ( param u prog u -- ior ) >fname 1+ cseg swap false (exec) ; \ Shell to DOS with optional command : SHELL ( a u -- ior ) s" COMSPEC=" getenv and if true (exec) else drop $FEFF then ; \ Get subprocess return code : RETCODE ( -- type code ) $4D doscall 'AH c@ 'AX c@ ; behead pb (exec) \ Video1 - text colors 0 constant BLACK 1 constant BLUE 2 constant GREEN 3 constant CYAN 4 constant RED 5 constant MAGENTA 6 constant BROWN 7 constant LTGRAY 8 constant GRAY 9 constant LTBLUE #10 constant LTGREEN #11 constant LTCYAN #12 constant LTRED #13 constant LTMAGENTA #14 constant YELLOW #15 constant WHITE \ Video1 - BORDER HI -HI BLINK -BLINK SETCUR CURSOR -CURSOR \ Set text border : BORDER ( u -- ) 'BX ! $B00 'AX ! $10 intcall ; -? : attr ( and or -- ) attrib c@ or and attrib c! ; \ Set video attribute : HI ( -- ) $FF $08 attr ; : -HI ( -- ) $F7 0 attr ; : BLINK ( -- ) $FF $80 attr ; : -BLINK ( -- ) $7F $00 attr ; behead attr attr \ Cursor set/normal/off : SETCUR ( x -- ) 'CX ! $100 'AX ! $10 intcall ; : CURSOR ( -- ) $0607 setcur ; : -CURSOR ( -- ) $2000 setcur ; \ Video2 - VMODE VMODE! VPAGE VPAGE! \ Get/set video mode : VMODE ( -- n ) $F00 'AX ! $10 intcall 'AX c@ ; : VMODE! ( n -- ) $FF and 'AX ! $10 intcall ; \ Get/set active video page : VPAGE ( -- n ) $F00 'AX ! $10 intcall 'BX 1+ c@ ; : VPAGE! ( n -- ) dup $106 c! $500 + 'AX ! $10 intcall ; \ Timing1 - /TIMER TIMER TICKS>MS .TIMER \ Get BIOS ticks 1 tick = 54.9254 mS aka ticks /TIMER ( -- d ) \ Reset timer \ Get elapsed time in ticks (24 hours max) : TIMER ( d1 -- d2 ) ticks 2swap d- dup 0< if ( cross midnight) #1573040. d+ then ; \ Convert ticks to milliseconds : TICKS>MS ( d1 -- d2 ) #14006 #255 m*/ ; \ Display elapsed time in milliseconds : .TIMER ( d -- ) timer ticks>ms <# #s #> type ." mS " ; \ Timing2 - (USEC) USEC \ Wait AL * 0.8381uS Uses Timer 2 label (USEC) \ AL = 127 max al ah mov $61 # al in $FC # al and 1 # al or here 2+ ju al $61 # out pushf cli $90 # al mov al $43 # out $61 # al in ah al mov al $42 # out 1 $: $61 # al in $80 # al mov al $43 # out $61 # al in $42 # al in al shl 1 $ jnc popf ret end-code \ Wait u * 0.8381uS Uses Timer 2 code USEC ( u -- ) \ u = 127 max ax pop (usec) ) call next end-code \ Timing3 - TICKMODE@ TICKMODE! \ Note: use /MS to recalibrate MS SOUND BEEP after changing \ system tick timer mode \ Get tick timer mode : TICKMODE@ ( -- 2|3 ) /ms sys-vec #30 + @ ; \ Set tick timer mode 3=IBM-PC, 2=Win31/XP/other : TICKMODE! ( n -- ) dup 2 or 3 = if 2* $30 + $43 wait-tick pc! $FF $40 pc! $FF $40 pc! else drop then ; \ Device1 - 8087? CPU? \ Test/init 80x87 code 8087? ( -- flag ) ax ax sub ax push sp bp xchg $E3DB , ( FINIT ) #100 # cx mov 1 $: 1 $ loop $7ED9 , 0 c, ( FSTCW [BP] ) sp bp xchg bx pop bx bx or 2 $ jz ax dec 2 $: 1push end-code \ Get CPU type code CPU? ( -- n ) \ n= $86, $286, $386 pushf $86 # ax mov sp push bx pop bx sp cmp 1 $ jnz 2 # ah mov pushf bx pop $F0 # bh or bx push popf pushf bx pop $F0 # bh and 1 $ jz ah inc 1 $: popf 1push end-code \ Device1 - EH-KEYBOARD? \ Enhanced keyboard hardware test : EH-KEYBOARD? ( -- flag ) $40 $96 c@l $10 and 0<> ; \ No newline at end of file diff --git a/DX-FORTH v430/DX.EXE b/DX-FORTH v430/DX.EXE new file mode 100644 index 0000000..9565a35 Binary files /dev/null and b/DX-FORTH v430/DX.EXE differ diff --git a/DX-FORTH v430/DXFORTH.GLO b/DX-FORTH v430/DXFORTH.GLO new file mode 100644 index 0000000..186aa35 --- /dev/null +++ b/DX-FORTH v430/DXFORTH.GLO @@ -0,0 +1,2740 @@ + +DX-Forth for MS-DOS Extension Wordset Glossary +---------------------------------------------- + +The DX-Forth Extension Wordset is provided in addition to the FORTH-94 +Standard words. Standard words that are implementation-specific, used +for reference or other purpose may also be described. + + +Attributes: + +I Words that have the immediate flag set +A Words residing in the DX-Forth APPLICATION dictionary +S Words residing in the DX-Forth SYSTEM dictionary +94 Words defined in the Forth-94 Standard +83 Words defined in the Forth-83 Standard +79 Words defined in the Forth-79 Standard +FIG Words defined in the fig-Forth model + + +Stack notation: + +Note: The following naming conventions for addresses are used to +maintain compatibility with the ANS-FORTH document. As DX-Forth does +not currently execute on architectures requiring address alignment, +all address types may be used interchangeably. + +number type stack cells range +----- ---- ----------- ----- +addr address 1 0..65535 +a-addr aligned address 1 0..65535 +c-addr character-aligned address 1 0..65535 +f-addr float-aligned address 1 0..65535 +p-addr CPU port address 1 0..65535 +h-addr heads segment address 1 0..65535 + +true boolean true -1 1 -1 +false boolean false 0 1 0 +flag boolean true or false 1 -1 or 0 +ior input/output result 1 0..255 + +n signed number 1 -32768..32767 ++n positive number 1 0..32767 +u unsigned number 1 0..65535 +x unspecified number 1 -32768..65535 +d signed double number 2 -2147483648.. + 2147483647 ++d positive double number 2 0..2147483647 +ud unsigned double number 2 0..4294697295 +xd unspecified double number 2 -2147483648.. + 4294697295 +r real number 2 +-5E-39..1E38 +c character or byte 1 0..255 + +ccc any arbitrary blank-delimited character string or word name + parsed from the input stream + +"ccc" same as for ccc; typically shown within a stack comment but + represents characters parsed from the input stream. + + +Contents + + 1. Disk File Interface + 2. Screen Files + 3. Tools + 4. DOS Interface + 5. Input/Output + 6. Arithmetic and Stack + 7. Conversion + 8. Strings and Memory + 9. Dictionary +10. Facility +11. Miscellaneous +12. Floating Point +13. Compiler Security +14. Control Flow + + +1. Disk File Interface +---------------------- + +Note: When a file function returns a non-zero ior then an error has +occurred. Refer to DXFORTH.TXT for a list of ior values and their +corresponding DOS error. + + +EXT ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 ) A + + Conditionally append the extension c-addr2 u2 to the filename + string c-addr1 u1 to produce a temporary string c-addr3 u3 in the + filename buffer. If addr1 u1 does not already contain an extension + (the '.' character is not present) then trailing blanks are removed + and c-addr2 u2 is appended. Formerly named +FILENAME . + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + See >FNAME + + -EXT ( c-addr u1 -- c-addr u2 ) A + + Delete any extension from the filename string c-addr u1. The + resulting string is c-addr u2. Formerly named -FILENAME . + + -PATH ( c-addr u1 -- c-addr u2 ) A + + Delete any path from the filename string c-addr u1. The resulting + string is c-addr u2. + + >FNAME ( c-addr1 u -- c-addr2 ) A + + String c-addr1 u is converted to a temporary null-terminated + counted string in the filename buffer. Leading and trailing blanks + are removed. c-addr2 is the address of the counted string and + c-addr2+1 is the address of the null-terminated string. A maximum + of two such filenames can exist in the filename buffer at one time. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + DX-Forth functions that use >FNAME or the filename buffer include: + PATH +EXT OPEN-FILE CREATE-FILE DELETE-FILE RENAME-FILE FILE-STATUS + + See LASTFILE + + BIN ( fam1 -- fam2 ) A I 94 + + Modify the file access method fam1 to additionally select a binary + - i.e. not line oriented - file access method, giving access method + fam2. BIN is a no-operation in this implementation as all access + is binary. + + See READ-LINE + + CLOSE-FILE ( fid -- ior ) A 94 + + Close the disk file associated with file-handle fid. If the file + could not be closed, ior is non-zero. + + Note: Under CP/M files are a multiple of 128 bytes. Partly + written records are padded with end-of-file character (1A hex). + + CREATE-FILE ( c-addr u fam -- fid ior ) A 94 + + Create and open a disk file specified by the filename c-addr u + using file access method fam. Valid fam are R/W (read/write) + R/O (read-only) and W/O (write-only). + + If a file with the same name already exists it will be erased. + The file-pointer is set to the start of the file. If the file + could not be created, ior is non-zero. + + DELETE-FILE ( c-addr u -- ior ) A 94 + + Delete the disk file specified by the string c-addr u. If the + file could not be deleted, ior is non-zero. + + Note: DELETE-FILE must not be performed on an open file. + + FILE-POSITION ( fid -- ud ior ) A 94 + + Return the current position the file-pointer of the disk file + associated with the handle fid. If an error occurs ior is + non-zero and ud is undefined. + + FILE-SIZE ( fid -- ud ior ) A 94 + + Return the current size in bytes of the disk file associated + with handle fid. If an error occurs ior is non-zero and ud is + undefined. + + Note: Under CP/M files are a multiple of 128 bytes. Partly + written records are padded with end-of-file character (1A hex). + + FILE-STATUS ( c-addr u -- x ior ) A 94 + + Return the status of the file identified by c-addr u. In DX-Forth + it is equivalent to MS-DOS function INT 21H AX=4300H. + + FLUSH-FILE ( fid -- ior ) A 94 + + Flush any buffered data written to the disk file associated with + handle fid, updating size information in the directory if changed. + If an error occurs ior is non-zero. + + OPEN-FILE ( c-addr u fam -- fid ior ) A 94 + + Open the existing disk file specified by the filename c-addr u + using file access method fam. Valid fam are R/W (read/write) + R/O (read-only) and W/O (write-only). If the file could not be + opened, ior is non-zero. + + PATH ( u1 -- c-addr u2 ior ) A + + Get the full directory path for disk drive u1. If an error occurs, + ior is non-zero. The returned string c-addr u2 includes the drive + letter and a trailing backslash. For the currently selected drive + u1 = 0, otherwise u1 = 1 for drive A, 2 for drive B etc. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + See >FNAME + + LREAD ( seg offs u1 fid -- u2 ior ) A + + As for READ-FILE but uses the 8086 segment/offset as the + destination address. + + LWRITE ( seg offs u fid -- ior ) A + + As for WRITE-FILE but uses the 8086 segment/offset as the source + address. + + READ-FILE ( c-addr u1 fid -- u2 ior ) A 94 + + Read u1 bytes from the disk file associated with the current file- + handle into memory starting at c-addr. If ior is zero, u2 is the + number of bytes received. If physical end-of-file is reached + before any bytes are read, u2 is zero. + + Note: Under CP/M files are a multiple of 128 bytes. Partly + written records are padded with end-of-file character (1A hex). + + READ-LINE ( c-addr u1 fid -- u2 flag ior ) A 94 + + Read a line of text from the disk file associated with file-handle + fid into memory starting at address c-addr. At most u1 characters + are read. If ior is zero and flag is true, u2 is the number + characters received not including the line terminator. If u2 = u1 + then a line terminator was not yet received. If an end-of-file + character (1A hex) is read or the end of the file is reached + before any other character is read then flag is false. The line + terminator may be CRLF (CP/M and MS-DOS) or LF (UNIX). + + REPOSITION-FILE ( ud fid -- ior ) A 94 + + Reposition the file-pointer of the disk file associated with the + file-handle fid to position ud. If the file is positioned outside + the file boundaries or an error occured, ior is non-zero. If + ud = 0 the file-pointer is positioned at the start of the file. + + RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior ) A 94 + + Rename the disk file specified by c-addr1 u1 to the new name + c-addr2 u2. If the file cannot be found or the new name already + exists then ior is non-zero. Any drive/user prefix attached to + the new name is ignored and is assumed to be the same as the old + name. + + Note: RENAME-FILE must not be performed on an open file. + + WRITE-FILE ( c-addr u fid -- ior ) A 94 + + Write u bytes from memory starting at c-addr to the disk file + associated with the current file-handle. If the disk was full + or an error occured, ior is non-zero. + + WRITE-LINE ( c-addr u fid -- ior ) A 94 + + Write a line of text c-addr u followed by the CP/M line terminator + (CRLF) to the disk file associated with file-handle fid. If the + disk was full or an error occured, ior is non-zero. + + +2. Screen Files +--------------- +In DX-Forth several source files may be open at any one time. The most +recently opened screen-file is termed "the current screen-file". + +Screen/block numbers are valid only in the range 0 to 8191. Only one +block buffer is allocated in memory, thus BLOCK and BUFFER always return +the same physical address. + +DX-Forth also supports text source-files. See the section 'Tools' for +details. + + #SCREENS ( -- +n ) S + + Return the number of screens (blocks) in the current screen-file. + + ?BLOCK ( -- ) S + + If the contents of BLK is non-zero perform BLK @ BLOCK DROP . + + B/BUF ( -- u ) S FIG + + A VALUE returning the number of bytes per block buffer. Default + is 1024. + + Note: Must be a multiple of 128 and a maximum of 1280. + + C/L ( -- u ) S FIG + + A VALUE returning the number of characters per line in a screen + block. Default is 64. + + CLOSE ( -- ) S + + Flush and close the current screen-file. No errors are reported + with this function. + + CLOSE-ALL ( -- ) S + + Perform CLOSE on all open source-files beginning with the current + screen-file. Any open text-files are also closed with this + function. + + SCREEN? ( -- flag ) S + + Return true if the current screen-file is open otherwise return + false. Formerly named FILE? + + FILEBLOCKS ( +n -- ) S + + Resize the current screen-file to +n blocks. If n is less than + the current size, the screen-file is truncated otherwise the file + is extended and the new blocks are filled with blanks. + + FLOAD ( +n "filename[.SCR]" -- ) S + + Save the current screen-file specification then open the specified + file and load block +n. At completion of the load, close the file + and restore the previous file. If the filename does not include + an extension then .SCR is assumed. Screen-files may be nested. + Equivalent to: DUP GETFILENAME LOADED + + Note: Read-only files cannot be opened with this function. + + GETFILENAME ( "filename" -- c-addr u ) S + + Parse a filename string from the input stream returning c-addr u. + An error occurs if the string is empty. + + LOADED ( +n1 +n2 c-addr u -- ) S + + Save the current screen-file specification then open the + screen-file specified by c-addr u and load blocks +n1 thru +n2. + At completion close the file and restore the previous screen-file. + If the filename does not include an extension then .SCR is + assumed. Screen-files may be nested. + + Note: Read-only files cannot be opened with this function. + + See FLOAD + + LOADFILE ( -- c-addr u ) S + + Return a string containing the name of the current source-file. + If no source-file is open or the input source is the console, + c-addr u is ambiguous. Formerly named FNAME FILENAME . + + See SCREEN? LASTFILE + + OPEN ( c-addr u fam -- ior ) S + + Open the specified disk file according to file access method fam + as the current screen-file. If an error occurs, ior is non-zero. + If the filename does not include an extension then .SCR is + assumed. + + Note: The programmer is responsible for closing or maintaining the + previous screen-file. + + See SWAP-FILE CLOSE CLOSE-ALL USING + + SWAP-FILE ( -- ) S + + Switch the current and 'swap' screen-files. SCR is preserved + across swaps. + + Note: SWAP-FILE causes the current block buffer to be unassigned. + The contents of the buffer, however, are not affected. + + See FYI + + USING ( "filename[.SCR]" -- ) S + + Close the current screen-file. Open or conditionally create the + specified disk file for read/write as the current screen-file. If + the filename does not include an extension then .SCR is assumed. + If the file cannot be opened/created then ABORT is performed. + SCR is set to 0. + + Note: Read-only files cannot be opened with this function. + The programmer is responsible for closing or maintaining the + previous current screen-file. + + See SWAP-FILE CLOSE CLOSE-ALL + + +3. Tools +-------- + +Note: Most of these words are available only after the file TOOLS.SCR +has been loaded. + + (* I S + + Begin a block comment. Parse and discard text delimited by the + token *) . If the parse area is exhausted before the delimiter + is found refill the input buffer and resume the process. + + An ambiguous condition exists if the delimiter is not found and + the parse area cannot be refilled. + + Note: (* is primarily intended for text-files. May be relocated + to the kernel if/when it gains greater popularity. + + -TOOLS ( -- a-addr ) S + + A MARKER word used for deleting the tools utilities with FORGET. + + See MARKER CHECKING + + .FREE ( -- ) S + + Display the current dictionary segments and statistics. + + .S ( -- ) S + + Display the values on the data and floating-point stacks. + + ? ( a-addr -- ) A + + Display the single-cell value stored at a-addr. Display as signed + number if BASE is decimal or unsigned otherwise. + + B ( -- ) S + + Decrement variable SCR and list the screen. + + See L N + + DELETE ( "filename" -- ) S + + Erase the specified file from disk. DELETE must not be performed + on an open file. + + DIR ( "filename" -- ) S + + List the current disk directory. Filename is required and may + include path and wildcards. + + DUMP ( addr u -- ) S + + Dump u bytes of memory starting at the address addr. + + EDIT S + + A synonym for the resident editor SED or TED. By default the + resident editor for DX.EXE is SED. See TED.TXT for details + on how to make TED the default editor. + + See SED TED + + FYI ( -- ) S + + "For Your Information". Display information about the current + forth environment including dictionary segments, vocabularies, + logged drive and open screen-files. Formerly named MAP . + + See .FREE VOCS ORDER + + ICLOSE ( -- ) S + + Close the current text-file. + + INCLUDEd text-files are automatically closed after loading. If + an error occurs or loading is interrupted (e.g. QUIT was executed), + nested text-files may remain open preventing external editing or + cause difficulty loading ("too many files" error message). Should + this occur use ICLOSE or CLOSE-ALL to restore proper operation. + + See INCLUDE INCLUDED CLOSE-ALL + + INCLUDE ( "filename[.F]" -- ) S + + Compile the text-file specified by the filename. If a filename + extension is not included then .F is assumed. Text-files may be + nested. + + Note: Uses the default DTA buffer at address $80. + + See INCLUDED ICLOSE + + INCLUDED ( c-addr u -- ) S + + Compile the text-file specified by the filename given by c-addr u. + If a filename extension is not included then .F is assumed. + Text-files may be nested. + + Note: Uses the default DTA buffer at address $80. + + See INCLUDE ICLOSE + + INDEX ( +n1 +n2 -- ) S FIG + + List line 0 of screens +n1 thru +n2 from the screen-file. Line 0 + typically contains a comment indicating the contents of the screen. + + See QX + + L ( -- ) S + + List the screen specified by variable SCR. + + See N B + + LASTFILE ( -- c-addr u ) S + + Return a string containing the last filename processed by >FNAME. + + Note: the string returned by LASTFILE remains valid for two + invocations of >FNAME e.g. + + S" myfile" >FNAME DROP LASTFILE ( c-addr1 u1 ) + S" yourfile" >FNAME DROP LASTFILE ( c-addr2 u2 ) + CR TYPE SPACE TYPE + yourfile myfile ok + + See >FNAME LOADFILE LOADLINE + + LDUMP ( seg offs u -- ) S + + Intersegment DUMP. Dump u bytes of memory starting at the address + specified by the 8086 segment/offset values. + + LISTING ( -- ) S + + List all screens from the screen-file to the printer, formatted 3 + screens to the page. A form-feed character (0C hex) is output at + the end of each page. + + LOADLINE ( -- a-addr ) S + + A VARIABLE containing the current line number of the text-file + being INCLUDEd. Starting line number is 1. + + See LASTFILE + + LS ( -- ) S + + Swap screen-files and list the screen specified by variable SCR. + + See SWAP-FILE L + + N ( -- ) S + + Increment variable SCR and list the screen. + + See L B + + ORDER ( -- ) S + + Display the context and current vocabularies. + + QX ( +n -- ) S + + Quick index. Starting with screen +n, list line 0 of 60 sequential + screens from the screen-file. Line 0 typically contains a comment + indicating the contents of the screen. + + See INDEX + + RENAME ( "oldfile" "newfile" -- ) S + + Rename the specified disk file with a new name. RENAME must not + be performed on an open file. + + SED ( | scr -- ) S + + Invoke the screen-file editor. If SED is not resident then it is + first loaded. If scr is not specified then editing begins at the + position where the last error occured. + + See EDIT TED + + SHOW ( +n1 +n2 -- ) S + + List screens +n1 through +n2 from the screen-file to the printer, + formatted 3 screens to the page. A form-feed character (0C hex) is + output at the end of each page. + + TED ( | "filename[.F]" -- ) S + + Invoke the text-file editor. If TED is not resident then it is + first loaded. If a filename is not specified then editing begins + at the line and file where the last error occured. + + See EDIT SED + + VOCS ( -- ) S + + List all vocabularies beginning with the most recent. + + WORDS ( -- ) S + + Lists the names of forth words in the first search wordlist + beginning with the most recent. The color attribute is the same as + for .ID . fig-Forth equivalent is VLIST. + + WORDS: ( "ccc" -- ) S + + As for WORDS but takes a blank delimited string from the input + stream. Only word names containing the specified string are + listed. If the string is empty the result is the same as WORDS . + Formerly named WORDS-LIKE . + + +4. DOS Interface +---------------- + + BDOS ( DX x -- AL ) A + + Perform MS-DOS INT 21H function call. Register DX holds the input + parameter. Low-order byte of x is the function number and is + passed to AH. The high-order byte of x is passed to AL. BX and CX + are set to zero. After the call the contents of AL is returned. + + Note: This function has been superseded by DOSCALL. + + CMDTAIL ( -- c-addr u ) A + + Return the string representing the command tail entered at the DOS + prompt when the program was first initiated. Leading and trailing + blanks are stripped. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + CSEG ( -- cseg ) A + + Return the 8086 segment containing the DX-Forth code, data and + stacks. + + See HSEG + + DOSCALL ( u -- ) A + + Call MS-DOS Interrupt 21H function u. DOSCALL is used similarly + to INTCALL with the exception that CPU registers AH and DS are + preloaded with function number u and DX-Forth segment CSEG + respectively. Refer to INTCALL for further details. + + Example: retrieve the MS-DOS version + + $30 DOSCALL 'AH C@ 'AX C@ ( minor major ) + + See DOSERR? INTCALL + + DOSERR? ( -- ior ) A + + Typically used following a DOSCALL or INTCALL to interrupt 21H. + MS-DOS generally uses the carry flag to report an error. DOSERR? + interrogates the carry flag and, if set, returns an ior value + corresponding to the MS-DOS error code contained in register AX. + If the carry flag was not set, ior is zero. In DX-Forth DOS + errors are returned as ior values in the range -511 to -257. To + convert these back to the MS-DOS error code use: ( ior) 255 AND + + Note: Not all MS-DOS functions use the carry flag to indicate an + error. Refer to MS-DOS documentation to determine which functions + may use DOSERR? . + + See INTCALL DOSCALL + + DOSVER ( -- minor major ) A + + Return DOS version number. + + INTCALL ( u -- ) A + + Call 8086 interrupt u. CPU register values are loaded into + variables before INTCALL and retrieved afterwards. The variables + used to hold the CPU register values are: + + 'AH 'BH 'CH 'DH 'AX 'BX 'CX 'DX 'BP 'SI 'DI 'DS 'ES 'FLAGS + + Example: display the MS-DOS version + + $30 'AH C! ( load AH = 30h ) + $21 INTCALL ( perform INT 21h ) + 'AX C@ ( get AL ) + . ( display major version ) + + See DOSERR? DOSCALL + + P@ ( p-addr -- x ) A + + Perform the 8086 IN instruction on 16-bit port p-addr returning x. + + P! ( x p-addr -- ) A + + Perform the 8086 OUT instruction sending x to the 16-bit port + p-addr. + + PC@ ( p-addr -- x ) A + + Perform the 8086 IN instruction on the 8-bit port p-addr returning + x. The upper 8 bits of x are set to zero. fig-Forth equivalent + is P@. + + PC! ( x p-addr -- ) A + + Perform the 8086 OUT instruction sending x to the 8-bit port + p-addr. fig-Forth equivalent is P! + + +5. Input/Output +--------------- + + (.) ( n -- c-addr u ) A + + Convert the signed number n to a string c-addr u. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + (D.) ( d -- c-addr u ) A + + Convert the signed double number d to a string c-addr u. + Primitive for D. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + (U.) ( u -- c-addr u ) A + + Convert the unsigned number u to a string c-addr u. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + . ( x -- ) A + + Display single number x in free-field format with a trailing space + as a signed number if BASE is decimal or unsigned otherwise. + + Note: This function adopts eForth behaviour in respect of BASE and + is useful for debugging. Applications requiring Forth-94 behaviour + may redefine: + + : . ( n -- ) S>D D. ; + + CONSOLE ( -- ) A + + Redirect EMIT to the console screen. + + D. ( d -- ) A + + Display signed double number d in free-field format with a trailing + space. + + EOL ( -- c-addr u ) A + + Return the address/length of the string representing the system- + dependent end-of-line terminator. For CP/M and MS-DOS end-of-line + is CRLF ($0D $0A). + + EOL DROP 1- ( -- c-addr ) returns a counted string + EOL DROP ( -- c-addr ) returns a null-terminated string + + SYS-VEC ( -- addr ) A + + Return the address of the system vector & parameter table. + + offset type function parameter default + + 0 vKEY? xt KEY? -- flag ?terminal + 2 vKEY xt KEY -- char conin + 4 vEMIT xt EMIT char -- conout * + 6 vCON xt CONSOLE out char -- conout + 8 vLST xt PRINTER out char -- lstout + 10 aINIT addr INIT patch -- NOOP * + 12 aIDENT addr IDENTIFY patch -- NOOP * + 14 aFNUMB addr FNUMBER patch c-addr u -- ?|0 FALSE * + 16 nFPS u fp-stack size + 18 aNUMB addr NUMBER? patch c-addr u -- ?|0 NUMBER? + 20 nFPM u fp-stack min + 22 nRTS u r-stack size + 24 nUS u USER area size + 26 nPNO u HOLD buffer size + 28 nMSCON u MS timing constant + 30 nTMODE u Timer 0 mode + + * set according to mode or installed option + + Sizes are expressed in bytes unless otherwise noted. + + KEY ( -- char ) A 94 + + Receive the next character from the console. + + Note: IBM-PC two-byte extended keystrokes are translated to a code + having a value of 128 or greater. Refer to DXFORTH.TXT for a + table of key codes. + + KEY? ( -- flag ) A 94 + + Return true if a console key has been pressed. KEY is subsequently + used to retrieve the character. fig-Forth equivalent is ?TERMINAL. + + PRINTER ( -- ) A + + Redirect EMIT to the printer. + + OUT ( -- a-addr ) A FIG + + A USER variable that contains the number of characters output by + EMIT or TYPE since the last CR. + + +6. Arithmetic and Stack +----------------------- + + -ROLL ( xu ... x1 x0 u -- x0 xu ... x1 ) A + + Remove u. Rotate xu ... x1 to the top of the stack pushing x0 to + the position vacated by xu. The reverse of ROLL. + + -ROT ( x1 x2 x3 -- x3 x1 x2 ) A + + Rotate the top stack item to the third position. The reverse of + ROT. + + 2+ ( x1 -- x2 ) A 83 FIG + + Add two (2) to n1|u1 giving the sum n2|u2. + + 2- ( x1 -- x2 ) A 83 + + Subtract two (2) to n1|u1 giving the sum n2|u2. + + 2NIP ( x1 x2 x3 x4 -- x3 x4 ) A + + Drop cell pair x1 x2 from the stack leaving x3 x4. + + >< ( x1 -- x2 ) A + + Swap the high order byte (bits 8-15) with the low order byte + (bits 0-7) of x1. + + FM/MOD ( d n1 -- n2 n3 ) A 94 + + Divide double number d by single n1, giving the floored quotient + n3 and the remainder n2. + + LSHIFT ( x1 u -- x2 ) A 94 + + Perform a logical left shift of u bit-places on x1 giving x2. + Put zero into the least significant bits vacated by the shift. + + M* ( n1 n2 -- d ) A 94 + + Multiply n1 by n2 giving the double result d. + + M*/ ( d1 n1 +n2 -- d2 ) A 94 + + Multiply double number d1 by single n1 producing the triple + length intermediate result t. Divide t by +n2 giving the + double quotient d2. + + M+ ( d1 n -- d2 ) A 94 + + Add single length number n to double d1, giving the sum d2. + + NIP ( x1 x2 -- x2 ) A 94 + + Drop the first item below the top of stack. + + NOT ( x -- flag ) A 79 + + Reverse the boolean value of x. Equivalent to: 0= . + + Note: Do not confuse this function with FORTH-83 NOT which behaved + as INVERT. + + RSHIFT ( x1 u -- x2 ) A 94 + + Perform a logical right shift of u bit-places on x1 giving x2. + Put zero into the most significant bits vacated by the shift. + + SM/REM ( d n1 -- n2 n3 ) A 94 + + Divide d by n1, giving the single-cell remainder n2 and the single- + cell symmetric quotient n3. An ambiguous condition exists if n1 is + zero. + + TUCK ( x1 x2 -- x2 x1 x2 ) A 94 + + Copy the first (top) stack item below the second stack item. + + U2/ ( x1 -- x2 ) A + + x2 is the result of shifting x1 one bit toward the least-significant + bit, leaving the most-significant bit zero. Functionally equivalent + to: 1 RSHIFT. + + UMAX ( u1 u2 -- u1 | u2 ) A + + Return the greater of two unsigned numbers. + + UMIN ( u1 u2 -- u1 | u2 ) A + + Return the lesser of two unsigned numbers. + + +7. Conversion +------------- + + DPL ( -- a-addr ) A 83 + + A USER variable containing the number of places to the right of + the decimal point following number input conversion. + + In DX-Forth DPL is incremented for each character successfully + converted by >NUMBER. Applications may use this feature to create + custom number conversion routines. + + See NUMBER? + + NUMBER? ( c-addr u -- d true | false ) A + + Convert the case-insensitive string c-addr u to a double number + according to the current base. If successful, return double + number d and a true flag. A leading '-' character signifies a + negative number. If a punctuation character '.' occurs at the + end of the string then DPL is 0 otherwise it is -1. If conversion + is unsuccessful or the string was empty or contained blanks then a + false flag is returned and DPL is meaningless. + + See DPL SYS-VEC + + UPCASE ( c1 -- c2 ) A + + Convert the character c1 to its uppercase equivalent c2. + + Note: The name of this function is subject to change. + + UPPER ( c-addr u -- ) A + + Convert the character string c-addr u to uppercase. + + Note: The name of this function is subject to change. + + +8. Strings and Memory +--------------------- + + !L ( x seg offs -- ) A + + Store cell x at the 8086 segment/offset. + + +STRING ( c-addr1 u1 c-addr2 u2 -- c-addr2 u3 ) A + + Append the string c-addr1 u1 to the end of string c-addr2 u2 + returning the resulting string c-addr2 u3. It is the programmer's + responsibility to ensure sufficient room is available at c-addr2 + to hold both strings. + + ," ( "ccc<">" -- ) S + + Parse the character string delimited by '"' and compile as a + counted string at HERE. The delimiter character may be included + in the string by entering it twice. + + Note: In DX-Forth the memory occupied by ," strings is exactly + count+1 characters with no terminating null or alignment. + + See /PARSE S, + + -BLANKS ( c-addr1 u1 -- c-addr2 u2 ) A + + Remove leading and trailing blanks from string c-addr1 u1 in the + SSEG segment leaving c-addr2 u2. Equivalent to: BL SKIP -TRAILING + + See SSEG + + -TRAILING ( c-addr u1 -- c-addr u2 ) A + + Remove trailing blanks from string c-addr u1 in the SSEG segment + leaving c-addr u2. Equivalent to: BL TRIM + + See TRIM SSEG + + /PARSE ( char "ccc" -- c-addr u ) S + + Parse ccc delimited by char and store the string (255 characters + maximum) in a temporary buffer. The delimiter character may be + included in the string by entering it twice. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + /PARSE is used by S" .( and ," . /PARSE and WORD share the same + buffer. Simultaneous use is allowed provided the combined length + of the strings does not exceed 255+31 chars. Formerly named + PARSE$ . + + /STRING ( c-addr1 u1 n -- c-addr2 u2 ) A 94 + + Truncate the string c-addr1 u1 by n characters. The resulting + string c-addr2 u2 begins at c-addr1+n and has a length u1-n. + n may be negative. + + 2!L ( x1 x2 seg offs -- ) A + + Store the cell pair x1 x2 at the 8086 segment/offset. + + 2@L ( seg offs -- x1 x2 ) A + + Fetch the cell pair stored at the 8086 segment/offset. + + @L ( seg offs -- x ) A + + Fetch the cell stored at the 8086 segment/offset. + + C!L ( char seg offs -- ) A + + Store the lower-order 8 bits of char at the 8086 segment/offset. + + C@L ( seg offs -- char ) A + + Fetch the lower-order 8 bits of the character at the 8086 segment/ + offset. + + CAPS ( -- ) A + + Causes the next occurrence of COMPARE or SEARCH to be performed as + if all characters in the source and destination strings were + uppercase. Used in the form: + + ( c-addr1 u1 c-addr2 u2 ) CAPS COMPARE + ( c-addr1 u1 c-addr2 u2 ) CAPS SEARCH + + Note: The effect of CAPS is temporary. It is automatically reset + by COMPARE SEARCH COLD, or when an error occurs and QUIT is + executed. + + CELL- ( a-addr1 -- a-addr2 ) A + + Subtract the size in address units of a cell to a-addr1, giving + a-addr2. + + CMOVEL ( seg1 offs1 seg2 offs2 u -- ) A + + Copy u consecutive characters starting at the 8086 segment/offset + seg1 offs1 to seg2 offs2, proceeding character-by-character from + lower addresses to higher addresses. + + COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) A 94 + + Compare string c-addr1 u1 in the SSEG segment with string c-addr2 + u2. Return 0 if match, -1 if c-addr1 u1 is less than c-addr2 u2 + or 1 if greater. + + See CAPS SSEG + + LFILL ( seg offs u char -- ) A + + Store char in each of u consecutive characters of memory beginning + at the 8086 segment/offset. + + MOVE ( a-addr1 a-addr2 u -- ) A 94 + + Move u bytes from a-addr1 to a-addr2. Overlap allowed. + + OFF ( a-addr -- ) A + + Clear all bits of the cell at a-addr. Functionally equivalent to: + 0 a-addr ! + + ON ( a-addr -- ) A + + Set all bits of the cell at a-addr. Functionally equivalent to: + TRUE a-addr ! + + PACK ( c-addr1 u c-addr2 -- c-addr2 ) A + + Store the string c-addr1 u as a counted string at c-addr2 leaving + the destination address on the stack. The source and destination + strings are permitted to overlap. An ambiguous condition exists + if u is greater than 255 or the buffer at c-addr2 is less than + u+1 characters. Formerly named PACKED . Functionally equivalent + to: 2DUP 2>R CHAR+ SWAP CHARS MOVE 2R> TUCK C! + + See PLACE + + PAD ( -- c-addr ) A + + Return the address of a transient region that can be used to hold + data for intermediate processing. PAD is at least 84 characters. + + Note: In DX-FORTH PAD is located in the APPLICATION data-space + immediately above the pictured numeric output buffer. The maximum + size of PAD is: APPLICATION UNUSED PAD HERE - - U. + + PLACE ( c-addr1 u c-addr2 -- ) A + + Store the string c-addr1 u as a counted string at c-addr2. The + source and destination strings are permitted to overlap. An + ambiguous condition exists if u is greater than 255 or the buffer + at c-addr2 is less than u+1 characters. Equivalent to: PACK DROP + + See PACK + + S" ( "ccc<">" -- ) I S 94 + ( -- c-addr u ) run-time A + + Parse a string (255 characters maximum) from the input stream + delimited by '"' and compile into the current definition. The + delimiter character may be included in the string by entering it + twice. At run-time, leave the string address and count on the + stack. + + S" is state-smart. When interpreting, the string is placed in a + transient region which may be overwritten by subsequent operations. + + See /PARSE + + S, ( c-addr u -- ) S + + Compile string c-addr u (255 characters maximum) as a counted + string at HERE. + + Named STRING, $, in some Forth implementations. + + Note: In DX-Forth the memory occupied by S, strings is exactly + count+1 characters with no terminating null or alignment. + + See ," + + S.R ( c-addr n1 n2 -- ) A + + Display string c-addr n1 right-aligned in a field n2 characters + wide. If the number of characters required to display the string + is greater than n2, all characters are displayed with no leading + spaces in a field as wide as necessary. + Equivalent to: OVER - SPACES TYPE + + SCAN ( c-addr1 u1 char -- c-addr2 u2 ) A + + Scan the string c-addr1 u1 in the SSEG segment for the character + char. Leave match address c-addr2 and length remaining u2. If + no match occurred then u2 is zero and c-addr2 is c-addr1 + u1. + + See SSEG + + SEARCH ( c-addr1 u1 c-addr2 u2 -- A 94 + c-addr3 u3 -1 | c-addr1 u1 0 ) + + Search string c-addr1 u1 in the SSEG segment for the occurrence of + string c-addr2 u2. If found, return -1 and the match address + c-addr3 with u3 characters remaining. + + See CAPS SSEG + + SKIP ( c-addr1 u1 char -- c-addr2 u2 ) A + + Skip leading occurrences of the character char in the string + c-addr1 u1 in the SSEG segment. Leave the address of the first + non-matching character c-addr2 and length remaining u2. If no + characters were skipped leave c-addr1 u1. + + See SSEG + + SLITERAL ( c-addr1 u -- ) compilation I S 94 + ( -- c-addr2 u ) run-time + + Compile the string c-addr u (255 characters maximum) into the + dictionary. When later executed c-addr2 u is left on the stack. + + SSEG ( -- a-addr ) A + + A VARIABLE containing the segment of the first string used by + COMPARE SEARCH SCAN SKIP TRIM -TRAILING and ZCOUNT. By default + SSEG is set to the DX-Forth segment CSEG. + + Note: The above words (and all that use them) will be affected + when SSEG is altered. Programs may temporarily change SSEG + provided it is restored to CSEG immediately afterwards. SSEG + is automatically reset by COLD or when an error occurs. + + See CSEG + + TRIM ( c-addr u1 char -- c-addr u2 -- ) A + + Exclude trailing occurences of the character char in the string + c-addr u1 in the SSEG segment. Leave address c-addr and the + new length u2. If no characters were removed leave c-addr u1. + + See SSEG + + ZCOUNT ( c-addr -- c-addr u ) A + + Return the address and length of the null-terminated string at + c-addr in the SSEG segment. + + See SSEG + + ZPLACE ( c-addr1 u c-addr2 -- ) A + + Store the string c-addr1 u as a null-terminated string placed at + c-addr2. The move proceeds character by character starting with + the lower addresses. + + +9. Dictionary +------------- + + (NAME) ( nfa -- c-addr u ) S + + Return the string c-addr u representing the name of the forth word + whose name field address is nfa. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + -? ( -- ) S + + Suppress redefinition and system compilation warnings for the next + definition only. + + See WARNING + + .ID ( nfa | 0 -- ) S + + Display the name of the forth word whose name field address is + nfa. If the word is nameless (nfa is zero) then "[noname]" is + displayed. Application words are shown with the NORMAL color + attribute while System words are in BOLD. Immediate words have + the brightness bit toggled. fig-FORTH equivalent is ID. + + .NAME ( xt -- ) S + + Display the name of the forth word whose execution token address + is xt. If the word is nameless or xt invalid then "[noname]" is + displayed. If the word is an alias then the primary name is + displayed. The color attribute is the same as for .ID + + .VOC ( wid -- ) S + + Display the name associated with wordlist wid. Wordlists may be + nameless in which case "[noname]" will be displayed. + + See VOCABULARY W>NAME + + APPLICATION ( -- ) A + + Place subsequent definitions into the Application dictionary. The + application dictionary holds words that may be executed by TURNKEY + programs. Equivalent to: FALSE SYS ! + + Note: APPLICATION is the default mode on boot-up or COLD. + + See SYS SYSTEM + + BEHEAD ( "name1" "name2" -- ) S + + Search the first wordlist in the search order and make invisible + the words between name1 and name2 inclusively. Beheaded words + will not be found in a wordlist search or displayed by WORDS. The + behaviour of beheaded words is not affected. An error message is + issued if the names reside in protected dictionary. Formerly named + EXCISE . + + See CHECKING + + CHAIN ( "name" -- ) S + + Append vocabulary "name" to the base of the CURRENT wordlist. An + error message is issued if "name" is not a vocabulary, is the same + as, already chained, or created later than, the CURRENT vocabulary. + + CONTEXT ( -- a-addr ) S + + Returns the address of a 3-cell array which determines the + dictionary search order. The default search order in DX-Forth is + CONTEXT CURRENT FORTH. If wid is zero FIND moves to the next cell + in the array. + + a-addr 1 cell wid CONTEXT + 1 cell wid CURRENT + 1 cell wid FORTH + + See VOCABULARY CHAIN + + DP ( -- a-addr ) A + + A double USER variable containing pointers to the next free + address in the Application and System dictionaries respectively. + e.g. + + DP @ ( -- appDP ) + DP 2@ ( -- sysDP appDP ) + + DPH ( -- a-addr ) S + + A USER variable containing a pointer representing the next free + address in the heads dictionary segment. + + EMPTY ( -- ) S + + Delete all definitions created since the last execution of COLD + or PROTECT. Compilation wordlist is set to FORTH. + + See REMEMBER + + FORGET ( "name" -- ) S 83 FIG + + If word "name" is found in the compilation wordlist, delete it + and all words added to the dictionary after "name" was defined, + regardless of their wordlist. An error message is issued if + "name" is an alias or the word is located in the protected + dictionary. + + See REMEMBER CHECKING PROTECT + + HSEG ( -- hseg ) A + + Return the 8086 segment containing the DX-Forth word headers. + + See CSEG + + HLIMIT ( -- addr ) S + + A CONSTANT that returns the upper limit address of the heads + dictionary segment. + + LAST ( -- a-addr ) S + + A 2VARIABLE containing the name field and execution token address + of the latest definition. + + LAST @ ( nfa ) + LAST 2@ ( xt nfa ) + + LIMIT ( -- addr ) A FIG + + A CONSTANT that returns the upper limit address of the application + dictionary and the start of the System dictionary. + + LIMIT for TURNKEY applications will be the upper memory limit + currently used by the forth compiler (usually $FFF0) unless set + to a user-specified value with SET-LIMIT. + + See SET-LIMIT + + LINK, ( a-addr -- ) S + + Add a node to linked list a-addr. The node is created at HERE + and consists initially of one cell containing the address of the + previous node. Equivalent to: HERE OVER @ , SWAP ! + + MARKER ( "name" -- ) S + + A defining word used in the form: + MARKER name + Typically used to mark the beginning of an application which may + later be removed by executing FORGET name. "name" is placed in + the System dictionary. Executing "name" is a no-operation. + + Note: MARKER differs from the Forth-94 specification. + + N>NAME ( nfa1 -- nfa2 | 0 ) S + + Given the name field address of a word, return the nfa of the + previous word in the wordlist. If the end of the wordlist is + reached then 0 is returned. + + PROTECT ( -- ) S + + Protect the current state of the dictionary. Existing definitions + can no longer be forgotten. Formerly named FREEZE . + + See CHECKING + + REMEMBER ( xt -- ) S + + Append execution token xt to the REMEMBER list. + + When words are discarded or the dictionary is otherwise reduced, + xt's in the REMEMBER list that lie outside the new dictionary + boundary will be executed beginning with the most recent. + + Typically xt represents a function whose purpose is to restore + critical system values to their previous state. Executed xt's + are automatically removed from the REMEMBER list. + + Note: Functions executed from the REMEMBER list are run only after + the new dictionary boundary has been established. Consequently + these functions may be residing in free memory when executed. + + See FORGET EMPTY + + SET-LIMIT ( addr -- ) S + + Set the value of LIMIT for TURNKEY applications to addr. If addr + does not lie on a 16-byte boundary, it is first rounded down. + Typically used prior to executing TURNKEY. + + SET-LIMIT only affects applications saved with TURNKEY. It is + the programmer's responsibility to ensure sufficient memory is + available for the demands of the application. The address passed + to SET-LIMIT remains in effect until a new value is set, or is + cancelled by executing COLD in the forth environment e.g. rebooting + the system. + + See LIMIT UNUSED + + SYS ( -- a-addr ) A + + A VARIABLE that determines the compilation dictionary. Definitions + will be compiled to the system dictionary if SYS is non-zero and to + the application dictionary if zero. + + See APPLICATION SYSTEM + + SYSTEM ( -- ) S + + Place subsequent definitions into the System dictionary. The + System dictionary holds the compiler and other support functions + not generally required for TURNKEY applications. + Equivalent to: TRUE SYS ! + + See SYS APPLICATION + + VOC-LINK ( -- a-addr ) S FIG + + A USER variable containing a pointer to the most recently defined + wordlist. + + VOCABULARY ( "name" -- ) S 83 + + Create a new empty wordlist. When "name" is later executed replace + the first wordlist in the search order with the wordlist associated + with "name". ADDR "name" @ returns the wordlist identifier wid. + + W>NAME ( wid -- nfa | 0 ) S + + Return the name field address of the most recently defined word in + wordlist wid. If the wordlist is empty then zero is returned. + + WARNING ( -- a-addr ) S + + A VARIABLE that controls warning messages. When set to zero, word + redefinition and System compilation warnings are disabled. Users + may set WARNING to TRUE or FALSE (e.g. using ON or OFF ) - other + values must not be used. + + See -? + + +10. Facility +------------ + + /MS ( -- ) A + + Adjust MS for correct operation. + + Note: This function is executed at start-up by COLD and is not + normally required thereafter. It is provided for applications + which switch Timer 0 between modes 2 and 3 thereby affecting + MS SOUND BEEP. SYS-VEC holds the timer mode in use when /MS was + last executed. + + Note: /MS is a DEFERed word. + + See SYS-VEC + + AT-XY ( x y -- ) A 94 + + Move the cursor to the specified coordinates relative to the + current text window. + + Note: No bounds checking of x,y is performed. + + See GET-XY + + ATTRIB ( -- addr ) A + + A byte variable containing the current text mode video attribute. + May be used to determine or modify the current screen colors and + blink mode. Bitfields for the attribute byte are: + + 7 blink/intensity + 6-4 background color 0-7 + 3-0 foreground color 0-15 + + Colors: + + 0 black 8 dark gray + 1 blue 9 light blue + 2 green 10 light green + 3 cyan 11 light cyan + 4 red 12 light red + 5 magenta 13 light magenta + 6 brown 14 yellow + 7 light gray 15 white + + Note: COLD resets ATTRIB to the video attribute in force when + the application was booted. Executing QUIT or entering the forth + development environment causes ATTRIB to be set to the NORMAL + attribute as defined in COLOR-TABLE. + + See RETURN + + BEEP ( -- ) A + + Generate a bell sound. Uses SOUND and MS. + + Note: BEEP is a DEFERed word. + + BACKGROUND ( x -- ) A + + Change the text window background to color x. x = 0-7 + + See ATTRIB + + BOLD ( -- ) A + + Begin 'bold' video mode. + + See NORMAL COLOR-TABLE + + BRIGHT ( -- ) A + + Begin 'bright' video mode. + + See NORMAL COLOR-TABLE + + CLEAR-LINE ( -- ) A + + Delete all characters from the current cursor position to the end + of the line. The cursor position remains unchanged. + + COLOR-TABLE ( -- addr ) A + + Return the address of a 4-byte table containing text mode video + attributes NORMAL INVERSE BOLD BRIGHT. The default values are + $07 $70 $03 $0B respectively. + + Note: Used by the forth system. Modification by applications is + discouraged - use ATTRIB instead. + + See ATTRIB + + DELETE-LINE ( -- ) A + + Delete the line at the current cursor position. All subsequent + lines are moved up one position. An empty line appears at the + bottom of the screen. + + FOREGROUND ( x -- ) A + + Change the text window foreground to color x. x = 0-15 + + See ATTRIB + + GET-WINDOW ( -- x1 y1 x2 y2 ) A + + Return the current text window boundary expressed as co-ordinates + of the default window. Formerly named WINDOW? . + + See SET-WINDOW + + GET-XY ( -- x y ) A + + Return the current cursor position relative to the current text + window. Formerly named AT-XY? . + + See AT-XY + + INSERT-LINE ( -- ) A + + Insert an empty line at the current cursor position. All + subsequent lines in the text window are moved down one position. + The bottom line is lost. + + INVERSE ( -- ) A + + Begin 'inverse' video mode. + + See NORMAL COLOR-TABLE + + MS ( u -- ) A 94 + + Delay u milliseconds. Uses Timer 0 and performs a PAUSE each 4mS. + + Note: MS is a DEFERed word. + + See /MS + + NORMAL ( -- ) A + + Begin 'normal' video mode. Used by QUIT and BYE . + + See BOLD COLOR-TABLE + + PAGE ( -- ) A 94 + + For the console, clear the text screen window and place the cursor + at the upper left; otherwise output a formfeed character (0C hex). + In DX-Forth, PAGE is equivalent to: 12 EMIT + + See CONSOLE PRINTER + + SET-WINDOW ( x1 y1 x2 y2 -- ) A + + Define a text window with an upper-left corner x1 y1 and lower- + right corner x2 y2. Formerly named WINDOW . + + See GET-WINDOW + + SOUND ( u1 u2 -- ) A + + Generate a tone with a frequency of u1 hertz for a duration of + u2 milliseconds. If u1 is less than 19 then only a delay of the + specified duration results. Performs a PAUSE each 4mS. Uses + Timer 2. + + Note: SOUND is a DEFERed word. + + TICKS ( -- d ) A + + Return time-of-day (TOD) i.e. the number of BIOS timer ticks + since midnight (0..1573039). Each tick represents 54.9254 mS. + + WAIT-TICK ( -- ) A + + Wait until the next BIOS timer tick. Typically used to + synchronize program execution to the BIOS tick timer. + + See TICKS + + +11. Miscellaneous +----------------- + + #USER ( -- +n ) S + + A VALUE returning the number of bytes in the USER area reserved by + the forth system. #USER marks the offset at which applications + may begin defining USER variables. + + See USER + + 'NEXT ( -- addr ) A + + Return the address of the centralized NEXT routine - the forth + "address interpreter". + + Note: In DX-Forth for DOS, most code words use an in-line NEXT + for speed. + + 'SOURCE ( -- a-addr ) S + + A double variable containing the current parameters for SOURCE. + 'SOURCE 2@ is the equivalent of SOURCE. + + (EXIT) ( -- ) A + + Note: As of DX-Forth 4.30 this word has been renamed to EXIT. + + --> ( -- ) I S 83 FIG + + Continue interpretation on the next sequential block. May be + used within a colon definition that crosses a block boundary. + + -ALLOT ( u -- ) A + + If u is greater than zero, release u address units of data space. + If u is zero, leave the data-space pointer unchanged. No memory + checking is performed. -ALLOT may be used within turnkey + applications. + + See ALLOT + + @EXECUTE ( i*x a-addr -- i*y ) A + + Execute xt located at address a-addr. If xt is zero then no + action is performed. Other stack effects are due to the word + executed. + + Named PERFORM in some Forth implementations. + + ABORT ( i*x -- ) ( R: j*x -- ) A 94 + + Empty the data stack and perform the function of QUIT which + includes emptying the return stack. No message is displayed. + For turnkey applications perform 1 RETURN . + + In DX-Forth ABORT performs -1 THROW . + + See QUIT + + ABORT" ( "ccc<">" -- ) I S 94 + ( i*x flag -- ) ( R: j*x -- ) run-time A + + If flag is non-zero display the character string delimited by '"' + and perform the function of ABORT. + + In DX-Forth ABORT" performs -2 THROW and is state-smart. + + ADDR ( "name" -- a-addr ) I S + + "address of". Return the data field address of the word "name". + + An ambiguous condition exists if "name" was not created by VALUE + DEFER CREATE VARIABLE 2VARIABLE CONSTANT 2CONSTANT USER VOCABULARY + and other functions as may be specified. + + Named &OF or & in some Forth implementations. + + ADDR is state-smart. + + AKA ( "oldname" "newname" -- ) S + + "Also Known As". Create an alias name "newname" for existing word + "oldname". If oldname was immediate then newname will be + immediate. + + Note: In DX-Forth aliases consume only header space, and the xt of + an alias is the same as the xt of the original word. The function + appears in other Forth implementations albeit with different names + and usage e.g. SYNONYM ALIAS . + + ALLOT ( u -- ) A + + If u is greater than zero, reserve u address units of data space. + space. If u is zero, leave the data-space pointer unchanged. An + error occurs if insufficient data space is available. ALLOT may + be used within turnkey applications. + + Note: Forth-94 permits ALLOT to use signed values. As of DX-Forth + for DOS v4.03 only unsigned values (0 to 65535) may be used with + ALLOT. Releasing data space is now done with -ALLOT. This change + was necessary to permit robust memory checking within ALLOT. + Applications requiring Forth-94 behaviour may redefine: + + : ALLOT ( n -- ) NEGATE -ALLOT ; + + however no memory checking will be performed. + + See -ALLOT UNUSED + + BETWEEN ( n1|u1 n2|u2 n3|u3 -- flag ) A + + Perform a comparison of a test value n1|u1 with a lower limit + n2|u2 and an upper limit n3|u3, returning true if either (n2|u2 + <= n3|u3 and (n2|u2 <= n1|u1 and n1|u1 <= n3|u3)) or (n2|u2 > + n3|u3 and (n2|u2 < n1|u1 or n1|u1 < n3|u3)) is true, returning + false otherwise. An ambiguous condition exists if n1|u1, n2|u2, + and n3|u3 are not all the same type. + + This is similar to WITHIN with the exception that the limits are + inclusive. + + See WITHIN + + BIOS-IO ( -- ) A + + Set console output and keyboard input to use BIOS calls. BIOS-IO + provides color and window support without the need for ANSI.SYS. + BIOS-IO is the default mode and is reset when an error occurs and + QUIT is executed. + + See DOS-IO + + BOUNDS ( addr1 u -- addr1+u addr1 ) A + + Convert the memory specified by addr1 u to start/end addresses + suitable for DO LOOP. + + BUILD ( xt "name" -- ) S + + Skip leading space delimiters. Parse name delimited by a space. + Create a definition for name with the execution semantics specified + by xt. When name is executed name's data field address is placed + on the data stack and execution proceeds according to the semantics + given by xt. + + BUILD provides an alternative to CREATE ... DOES> . Typical use: + + SYSTEM + : CONSTANT ['] @ BUILD , ; + APPLICATION + + BUILD may be used outside a definition e.g. + + \ return string representing end-of-line sequence + + ' COUNT BUILD EOL ( -- c-addr u ) 2 C, $0D C, $0A C, + + \ print a number in alternate radix + \ adapted from a posting by "Bee" on c.l.f. + + :NONAME ( a-addr -- ) + BASE @ >R C@ BASE ! U. R> BASE ! ; ( xt) + + ( xt) DUP BUILD B. ( u -- ) 2 C, + DUP BUILD O. ( u -- ) 8 C, + BUILD H. ( u -- ) 16 C, + + \ interpret a number in an alternate radix + + :NONAME ( "number" -- x ) + BASE @ >R C@ BASE ! TOKEN NUMBER? + R> BASE ! 0= ABORT" bad radix" DROP + STATE @ IF POSTPONE LITERAL THEN ; ( xt) + + ( xt) DUP BUILD D# 10 C, IMMEDIATE + DUP BUILD B# 2 C, IMMEDIATE + BUILD H# 16 C, IMMEDIATE + + BYE ( -- ) S 94 + + Perform CLOSE-ALL CONSOLE NORMAL then return to DOS with 0 RETURN. + + CASE ( C: -- mark ) I S 94 + + Mark the start of a CASE construct. Used in the form: + + CASE x1 + x2 OF ... ENDOF + x3 OF ... ENDOF + ( x1) + ENDCASE + + In DX-Forth CASE is a synonym for COND . + + CATCHER ( -- a-addr ) A + + A USER variable containing the last exception handler. If the + contents is zero no more exception frames (installed by CATCH) + are present. + + CHAR ( -- c ) S 94 + + Parse the next word in the input stream and return the ASCII + value of the first character. + + COLD ( -- ) A FIG + + Cold restart the forth environment or turnkey application. + + COMPILE S 83 + + COMPILE is obsolete and should not be used directly in + applications. COMPILE is a factor of POSTPONE and is present in + the dictionary as a named word for error handling purposes. + + COND ( C: -- mark ) I S + + Mark the start of a COND construct. Used in the form: + + COND x1 + x2 OF ... ELSE + x3 OF ... ELSE + ( x1) + THENS + + COND x1 + x2 EQUAL x3 x4 RANGE WHEN ... ELSE + ( x1) + + See THENS "Miser's CASE" CASE + + CONSTANT ( x "name" -- ) S + + Create a definition for name. When "name" is later executed + the numeric value x is placed on the stack. + + Note: In DX-Forth the parameter field of a CONSTANT may be less + than 16 bits. Applications which read/write directly to the + parameter field of a CONSTANT should be modified to use VALUE + instead e.g. CONSTANT ... DOES> @ should be replaced with + VALUE ... DOES> @ . + + DEFER ( "name" -- ) S + + Creates a deferred word whose action word may be subsequently + altered using the sequence: ' ccc IS name + + Deferred words are used to create forward references that will be + resolved later. A run-time error occurs if an attempt is made to + execute an uninitiated deferred word. + + Note: The current action of a deferred word may be obtained + using + + ' >BODY @ ( "name" -- xt ) or + ADDR @ ( "name" -- xt ) + + See IS + + DOS-IO ( -- ) A + + Set console output and keyboard input to use DOS calls. May be + used to support redirection, screen pausing and control-C/Break in + applications. + + Note: Color and windowing functions do not function in DOS-IO mode. + Control-C/Break keys are not trapped and will cause an immediate + exit to DOS. + + See BIOS-IO + + DXFORTH ( -- minor major ) A + + Return the DX-Forth version number. + + END ( -- ) ( C: orig -- ) I S + + Mark the end of an IF or other conditional that leaves an orig + on the control stack. At run-time exit the current definition. + Equivalent to the sequence EXIT THEN . + + Example: + + IF ... EXIT THEN + + becomes + + IF ... END + + ENDCASE ( x -- ) I S 94 + + Mark the end of a CASE construct. Discard x. In DX-FORTH ENDCASE + is equivalent to DROP THENS . + + See CASE OF ENDOF THENS + + ENDOF ( -- ) I S 94 + + Mark the end of an OF ENDOF pair. In DX-FORTH ENDOF is a synonym + for ELSE . + + See CASE OF ENDCASE + + EVALUATE ( c-addr u -- ) S 94 + + Save the current input source specification. Make the string + described by c-addr u both the input source and input buffer, + set >IN to zero, and interpret. When the parse area is empty, + restore the prior input source specification. + + EXIT ( -- ) A 94 + + Exit the current colon definition and return control to the + calling definition. + + FDB ( -- a-addr ) S + + Get the address of the next free file descriptor block. If no more + free descriptors exist the function aborts with a "too many files" + error message. + + Note: FDB is used by the system to load screen/text source-files + and is not normally an end-user function. + + I' ( -- x ) ( R: loop-sys -- loop-sys ) A + + Copy the current (innermost) loop limit to the data stack. + + INTERPRET ( -- ) S FIG + + Successively interpret forth text from the input stream until + exhausted, compiling or executing depending upon STATE. If an + error occurs the process aborts with a message. + + The interpreter recognizes the numeric prefixes # $ % for decimal, + hexadecimal and binary respectively. + + IS ( xt "name" -- ) I S + + Used in the form: + ' ccc IS name + where "name" is a deferred word and ccc defines the new behaviour. + + See DEFER + + NHOLD ( +n char -- ) A + + Perform HOLD n times. An ambiguous condition exists if n < 0. + + See SHOLD + + NOOP ( -- ) A + + No operation. Typically used to set a null action e.g. + + ' NOOP IS XXX + + where XXX is a DEFERed word. + + OF ( x1 x2 -- ) I S 94 + + If x1 = x2, discard both values and perform the sequence between OF + and ENDOF. Execution then continues after ENDCASE . If x1 <> x2, + discard x2 and continue after the corresponding ENDOF. + + Note: In DX-FORTH OF is functionally equivalent to the sequence + OVER = IF DROP and thus may be used outside a CASE statement e.g. + + : EOL? ( char -- 2|1|0 ) + $0D OF 2 END + $0A OF 1 END + DROP 0 ; + + See CASE ENDOF ENDCASE COND THENS + + PAUSE ( -- ) A + + Provides support for multitasking applications. When the + multitasker is loaded and enabled, PAUSE passes control to the next + task. Refer to the multitasking documentation for further details. + + Note: PAUSE is automatically executed by KEY? KEY EMIT MS + + QUIT ( -- ) ( R: i*x -- ) A 83 + + Empty the return stack, make the user input device the input + source and enter interpretation state. No message is displayed + and the data stacks are not emptied. For turnkey applications + perform the function 0 RETURN . + + Like ABORT, QUIT may be used to terminate an application at any + nesting level. Unlike ABORT, QUIT in DX-Forth is not considered + an error condition and cannot be intercepted with CATCH. + + Note: Prior to DX-Forth 4.2 QUIT was a System word and could not + be used to exit turnkey applications. + + See ABORT + + R0 ( -- a-addr ) A FIG + + A USER variable that contains the address of the top of the return + stack. + + RETURN ( x -- ) A + + Restore initial drive/path then return to DOS with exit code x + where x is a value in the range 0 to 255. Open files are not + closed. + + Note: The MS-DOS version automatically restores the initial DOS + text colors; however to be effective the cursor must be located on + the bottom screen line when RETURN is called. An alternative is + to simply type CLS from the DOS prompt when the application exits. + + See ABORT QUIT BYE + + RP! ( addr -- ) A + + Set the return stack pointer to addr. + + RP@ ( -- addr ) A FIG + + Return the address of the current return stack pointer. + + S0 ( -- a-addr ) A FIG + + A USER variable that contains the address of the top of the + data stack. + + SAVE ( "filename[.EXE]" -- ) S + + Save the current forth system image to disk including any new + definitions created. + + See TURNKEY TURNKEY-SYSTEM + + SHOLD ( c-addr u -- ) A + + Add string c-addr u to the beginning of the pictured numeric + output string. + + See NHOLD + + SP! ( addr -- ) A + + Set the data stack pointer to addr. + + SP@ ( -- addr ) A FIG + + Return the address of the current data stack pointer. + + THENS ( C: mark -- ) I S + + Resolve a COND/CASE construct. + + Similar to ENDCASE but does not expect the case selector to be on + the stack. Named END-CASE in some Forth implementations. + + See COND "Miser's CASE" + + TO ( x "name" -- ) S 94 + + Set the contents of VALUE name to x. + + See VALUE + + TOKEN ( "name" -- c-addr u ) S + + Parse a blank-delimited name token from the input stream. A space, + not included in the length, follows the string. + Equivalent to: BL WORD COUNT + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + See WORD + + TURNKEY ( "bootword" "filename[.EXE]" -- ) S + + Save a standalone application to disk using the specified filename. + When the application is subsequently run, execution begins with + bootword and ends with 0 RETURN if successful, or 1 RETURN if + ABORT ABORT" or an uncaught error was encountered. + + Note: System dictionary and word headers are not saved by TURNKEY + and therefore unavailable to the saved application. + + See SAVE TURNKEY-SYSTEM + + TURNKEY-SYSTEM ( "bootword" "filename[.EXE]" -- ) S + + Save a standalone application including the System dictionary and + heads to disk using the specified filename. When the application + is subsequently run, execution begins with bootword and ends with + 0 RETURN if successful, or 1 RETURN if ABORT ABORT" or an + uncaught error was encountered. + + TURNKEY-SYSTEM is used for applications that require access to + words in the System dictionary. + + See SAVE TURNKEY + + UNNEST ( -- ) ( R: nest-sys -- ) A + + Discard the calling definition specified by nest-sys. Before + exiting the current definition, a program shall remove any + parameters the calling definition had placed on the return stack. + An ambiguous condition exists if the current or calling definition + uses locals. + + UNUSED ( -- u ) A 94 + + Return the amount of data space in bytes remaining in the region + addressed by HERE. The calculation includes a 255 byte safety + margin. + + See APPLICATION SYSTEM + + UP ( -- a-addr ) A + + A VARIABLE that contains the base address of the current USER + area. + + USER ( +n "name" -- ) S FIG + + A defining word used in the form: + +n USER name + which creates a USER variable "name". +n is the offset within + the user area where the value for "name" is stored. Executing + "name" leaves the address of the variable in the user area. + + USER variables with offsets #USER and higher are available for + use by applications. + + Note: Offsets numbers are subject to change. When an offset + is required by an application, it should be determined at + compile-time e.g. [ BASE UP @ - ] LITERAL will return the + offset for BASE . + + See #USER + + VALUE ( x "name" -- ) S 94 + + As for CONSTANT but with the exception the data field of a VALUE + is always 1 cell and the contents may be changed using TO. + + See CONSTANT + + WITHIN ( x1 x2 x3 -- flag ) A 94 + + Return true if x3 lies within the range x1 to x2-1, otherwise + return false. x may be signed or unsigned. + + See BETWEEN + + WORD ( char "ccc" -- c-addr ) S 83 + + Parse a string from the input stream delimited by char leaving a + counted string at c-addr. Leading instances of char are skipped. + A space, not included in the length, follows the string. + + Note: The returned string resides in a transient region which may + be overwritten by subsequent operations. + + See TOKEN + + Y/N ( -- flag ) A + + Display '(y/n) N' and wait for a single console key. Return + true if the 'Y' or 'y' key was pressed or false otherwise. + + [CHAR] ( -- c ) I S 94 + + Parse the next word in the input stream and compile the ASCII + value of the first character as a literal. + + [DEFINED] ( "name" -- flag ) I S + + Parse the next word in the input stream. Return a true flag if + word was defined in the dictionary. + + [IF] [ELSE] [THEN] I S 94 + + These are the equivalents of IF ELSE THEN but may be used outside + a definition. + + [UNDEFINED] ( "name" -- flag ) I S + + Parse the next word in the input stream. Return a true flag if + word was not defined in the dictionary. + + \ ( -- ) I S 94 + + Skip the rest of the line and resume interpretation at the + beginning of the next line. + + \\ ( -- ) I S + + Parse and discard the remainder of the parse area. If the source + is a text-file the remainder of the file is discarded. + + +12. Floating Point +------------------ +By default DX-Forth uses single precision software floating point. +A real number occupies two cells (4 bytes) with a maximum precision +of 7 digits and a dynamic range of 5E-39 to 1E38. + +The forth interpreter recognizes a number as floating point if it is +in decimal mode and contains an exponent identifier 'E' e.g. 1.0E +3.141952E 1e-12 + +DX-Forth for DOS v2 and higher use a separate stack for floating point +operations. If a common stack floating point model is desired (as used +in DX-Forth 1.0), it may be achieved by changing the 'fstack' equate +to 'no' in the DX-Forth source code and re-assembling. If you have +Borland TASM simply execute MAKEF.BAT and it will generate both models +without any need to alter the source. + +Notes: + +- In the common stack model, variables FS0 and FSP are dummies. Their + contents are initialized as for S0 but are otherwise unused. + +- Available output modes + + Compact Formatted String + ------- --------- ------ + F. F.R (F.) Floating + FS. FS.R (FS.) Scientific + FE. FE.R (FE.) Engineering + G. G.R (G.) General + + In compact (floating-point) mode non-essential zeros and signs are + removed and the number of significant digits output is limited to a + maximum of PRECISION digits. In formatted (fixed-point) mode the + number of places output after the decimal point is specified by the + user and PRECISION has no effect. Output words that specify the + number of places after the decimal point may use the value -1 to + force compact mode. F. FS. FE. G. always use compact mode. + + The character string returned by (F.) (FS.) (FE.) (G.) resides in the + pictured-numeric output area. An ambiguous condition exists if BASE + is not decimal or the character string exceeds the pictured-numeric + output area. + + (F.) ( r n -- c-addr u ) A + + Convert real number r to string c-addr u in fixed-point notation + with n places to the right of the decimal point. If n = -1, non- + essential zeros and signs are removed. Primitive used by F. F.R + + (FE.) ( r n -- c-addr u ) A + + Convert real number r to string c-addr u in engineering notation + with n places right of the decimal point. If n = -1, non-essential + zeros and signs are removed. Primitive used by FE. + FE.R + + (FS.) ( r n -- c-addr u ) A + + Convert real number r to string c-addr u in scientific notation + with n places right of the decimal point. If n = -1, non- + essential zeros and signs are removed. Primitive used by FS. FS.R + + (G.) ( r n -- c-addr u ) A + + Convert real number r to string c-addr u with n places right of + the decimal point. Fixed-point notation is used if the exponent is + in the range -4 to 5 otherwise use scientific notation. If n = -1, + non-essential zeros and signs are removed. Primitive used by G.R G. + + -FP ( -- a-addr ) S + + A MARKER word used to delete the floating-point with FORGET. + + See MARKER CHECKING + + >FLOAT ( c-addr u -- r true | false ) A 94 + + Convert the string c-addr u to a real number. If successful, + return the real number r and true or false otherwise. + + Note: A zero length string or a string with leading blanks will + return the real number 0.0E and true. + + D>F ( d -- r ) A 94 + + Convert the double number to its real number equivalent. + + F! ( r f-addr -- ) A 94 + + Store r at f-addr. + + F* ( r1 r2 -- r3 ) A 94 + + Multiply r1 by r2, giving the product r3. + + F** ( r1 r2 -- r3 ) A 94 + + Raise r1 to the power r2. + + F+ ( r1 r2 -- r3 ) A 94 + + Add r1 to r2, giving the sum r3. + + F, ( r -- ) S + + Reserve one floating-point cell of data space and store r in the + cell. + + F- ( r1 r2 -- r3 ) A 94 + + Subtract r2 from r1, giving the difference r3. + + F. ( r -- ) A + + Display r in floating-point notation followed by a space. + Non-essential zeros and signs are removed. + + F.R ( r n u -- ) A + + Display r in fixed-point notation right-justified in a field + width u with n places right of the decimal point. If n = -1, + non-essential zeros and signs are removed. + + F/ ( r1 r2 -- r3 ) A 94 + + Divide r1 by r2, giving the quotient r3. + + F0< ( r -- flag ) A 94 + + Return true if r is less than zero, or false otherwise. + + F0= ( r -- flag ) A 94 + + Return true if r is equal to zero, or false otherwise. + + F0> ( r -- flag ) A + + Flag is true if r is greater than zero. + + F< ( r1 r2 -- flag ) A 94 + + Return true if r1 is less than r2, or false otherwise. + + F> ( r1 r2 -- flag ) A + + Flag is true if r1 is greater than r2. + + F>D ( r -- d ) A 94 + + Convert the integer part of r to its double number equivalent. + + F>S ( r -- n ) A + + Convert the integer part of r to its single number equivalent. + + F@ ( f-addr -- r ) A 94 + + Return the value of the real number stored at f-addr. + + FABS ( r1 -- r2 ) A 94 + + Return the absolute value of r1. + + FATAN ( r1 -- r2 ) A 94 + + r2 is the principal radian angle whose tangent is r1. + + FCONSTANT ( r -- ) compilation A 94 + ( -- r ) run-time + + Define a floating point constant having the value r. + + FCOS ( r1 -- r2 ) A 94 + + r2 is the cosine of the radian angle r1. + + FDP ( -- a-addr ) A + + A VARIABLE that controls floating decimal point display. If zero + then trailing decimal points are not shown; if non-zero a decimal + point is always shown. Default is FDP ON. + + FDROP ( r -- ) A 94 + + Remove r from the stack. + + FDUP ( r -- r r ) A 94 + + Duplicate r. + + FE. ( r -- ) A + + Display r in engineering notation followed by a space. Non- + essential zeros and signs are removed. + + FE.R ( r n u -- ) A + + Display r in engineering notation right-justified in a field width + u with n places to the right of the decimal point. If n = -1, + non-essential zeros and signs are removed. + + FEXP ( r1 -- r2 ) A 94 + + Raise e to the power r1, giving r2. + + FLITERAL ( r -- ) compilation A 94 + ( -- r ) run-time + + Compile r into the dictionary. When later executed r is left on + the stack. + + FLN ( r1 -- r2 ) A 94 + + r2 is the natural logarithm of r1. + + FLOOR ( r1 -- r2 ) A 94 + + Round r1 to an integral value using the "round toward negative + infinity" rule, giving r2. + + FMAX ( r1 r2 -- r3 ) A 94 + + r3 is the maximum of r1 and r2. + + FMIN ( r1 r2 -- r3 ) A 94 + + r3 is the minimum of r1 and r2. + + FNEGATE ( r1 -- r2 ) A 94 + + Negate r1, giving r2. + + FOVER ( r1 r2 -- r1 r2 r1 ) A 94 + + Place a copy of r1 on top of the stack. + + FPICK ( ru ... r0 u -- ru ... r0 ru ) A + + Remove u. Copy ru to the top of the stack. + + FRANDOM ( r1 -- r2 ) A + + If r1 is a positive non-zero number, return a pseudo-random number + r2 uniformly distributed in the range 0.0E to (but not including) + 1.0E. If r1 is zero, return the last random number generated. If + r1 is negative, r1 is used to re-seed the random number generator. + + FROT ( r1 r2 r3 -- r2 r3 r1 ) A 94 + + Rotate r1 to the top of the stack. + + FROUND ( r1 -- r2 ) A 94 + + Round r1 to an integral value using the "round to nearest" rule, + giving r2. + + FS. ( r -- ) A + + Display r in scientific notation followed by a space. Non- + essential zeros and signs are removed. + + FS.R ( r n u -- ) A + + Display r in scientific notation right-justified in a field width + u with n places to the right of the decimal point. If n = -1, + non-essential zeros and signs are removed. + + FS0 ( -- a-addr ) A + + A USER variable that contains the address of the top of the + separate floating point stack. + + Note: Has no function in the common stack floating point model + + FSIN ( r1 -- r2 ) A 94 + + r2 is the sine of the radian angle r1. + + FSP ( -- a-addr ) A + + A VARIABLE that returns the address of the current separate + floating point stack pointer. + + Note: Has no function in the common stack model + + FSQRT ( r1 -- r2 ) A 94 + + r2 is the square root of r1. + + FSWAP ( r1 r2 -- r2 r1 ) A 94 + + Exchange the top two floating point numbers. + + FVARIABLE ( -- ) compilation A 94 + ( -- f-addr ) run-time + + Define a floating point variable. + + G. ( r -- ) A + + Display real number r in floating-point notation followed by a + space. If the exponent is outside the range -4 to 5 then + scientific notation is used. Non-essential zeros and signs are + removed. + + G.R ( r n u -- ) A + + Display real number r right-justified in a field width u with n + places right of the decimal point. Fixed-point notation is used + if the exponent is in the range -4 to 5 otherwise use scientific + notation. If n = -1, non-essential zeros and signs are removed. + + MAX-PRECISION ( -- u ) A + + A CONSTANT returning the implementation-defined maximum PRECISION. + + See SET-PRECISION + + PI ( -- r ) A + + An FCONSTANT that returns the value for "pi" (3.141593..) + + PRECISION ( -- u ) A 94 + + Return the maximum number of significant digits currently used by + F. FS. FE. G. and in compact output mode F.R FS.R FE.R G.R (F.) + (FS.) (FE.) (G.) . + + REPRESENT ( r c-addr n1 -- n2 flag1 flag2 ) A 94 + + DX-Forth uses an enhanced REPRESENT. It follows the Forth-94 + definition with the following extensions: + + - if n1 is zero the entire significand of r is rounded to one or + zero following the system's rounding rule; if n1 is negative + then r is rounded to zero. + - the buffer size allocated at c-addr shall be the greater of n1 + or MAX-PRECISION. + + See http://dxforth.netbay.com.au/Represent_33.txt + + S>F ( n -- r ) A + + Convert the single number to its real number equivalent. + + SET-PRECISION ( u -- ) A 94 + + Set the maximum number of significant digits used by F. FS. FE. + G. and in compact output mode F.R FS.R FE.R G.R (F.) (FE.) (FS.) + (G.) . u is limited to MAX-PRECISION. + + +13. Compiler Security +--------------------- + + !CSP ( -- ) S FIG + + Save the current data stack position. Equivalent to: SP@ CSP ! + + See ?CSP + + ?BAL ( flag -- ) S + + Issue an error message 'definition unbalanced' and abort if flag + and CHECKING are not zero. + + See CHECKING + + ?CSP ( -- ) S FIG + + Issue an error message 'definition unbalanced' and abort if the + current data stack position does not match the value saved by !CSP + and CHECKING is not zero. + + See CHECKING + + ?COMP ( -- ) S FIG + + Issue an error message 'compilation only' and abort if not + compiling. + + ?EXEC ( -- ) S FIG + + Issue an error message 'execution only' and abort if not + executing. + + ?STACK ( -- ) S FIG + + Issue an error message and abort if a stack underflow or overflow + occurs. Data, return and floating point stack (if present) are + tested. + + Note: A non-System version of ?STACK is provided in MISC.SCR for + turnkey applications requiring run-time stack checking. + + BAL ( -- a-addr ) S + + A VARIABLE containing the current control structure balance level. + + Note: This replaces +BAL -BAL which incremented/decremented the + value in BAL respectively. + + CHECKING ( -- a-addr ) S + + A VARIABLE that controls compiler security - including control + structure balance, data stack level and protected dictionary. + If the contents are zero, checking is disabled. Default is + CHECKING ON. + + See ?BAL ?CSP BEHEAD FORGET + + CSP ( -- a-addr ) S FIG + + A 2VARIABLE . The first cell contains the current data stack + pointer saved by !CSP . The second cell (not FIG compatible) + contains the current control-flow stack base address. + + See !CSP + + SMUDGE ( -- ) S FIG + + Toggle the 'smudge' bit in the header of the last defined word. + If the smudge bit is set, the definition will not be found during + a dictionary search. + + +14. Control Flow +---------------- + +In DX-Forth the control-flow stack is implemented on the data stack. +Extension words CS-DROP CS-PUSH CS-POP CS-MARK CS-TEST are available +when the 'cfs' equate in the kernel source is enabled. See MISER.SCR +for example of use. + + MARK ( C: -- orig ) S 83 + + Reserve space in the dictionary for a forward branch address + to be later resolved by THEN . Formerly named FORWARD . + + >RESOLVE ( C: orig -- ) S 83 + + This function is not provided. In DX-Forth use POSTPONE THEN + instead. + + AHEAD ( C: -- orig ) S 94 + + Put the location of a new unresolved forward reference orig + onto the control flow stack. Similar to IF but compiles an + unconditional forward branch. + + CS-PICK ( C: xu..x0 -- xu..x0 xu ) ( S: u -- ) S 94 + + Remove u. Place a copy of item xu on top of the control-flow + stack. + + CS-ROLL ( C: xu..x0 -- xu-1..x0 xu ) ( S: u -- ) S 94 + + Remove u. Rotate item xu to the top of the control-flow stack. + + CS-DROP ( C: x -- ) S + + Remove the top item from the control-flow stack. + + CS-PUSH ( C: xu..x1 x0 -- x0 xu..x1 ) S + + Rotate items on the control-flow stack such that the top item + becomes the bottom. An ambiguous condition exists if the control- + flow stack is empty before CS-PUSH is executed. + + CS-POP ( C: xu xu-1..x0 -- xu-1..x0 xu ) S + + Rotate items on the control-flow stack such that the bottom item + becomes the top. An ambiguous condition exists if the control- + flow stack is empty before CS-POP is executed. + + CS-MARK ( C: -- x ) S + + Place a marker on the control-flow stack. A marker occupies the + same width as an orig|dest but is distinguishable using CS-TEST. + + CS-TEST ( C: x -- x ) ( S: -- flag ) S + + Return a true flag if x is an orig|dest, or false if a marker. + x is not altered or removed. + + If the control-flow stack is implemented using the data stack, + flag shall be the topmost item on the data stack. + diff --git a/DX-FORTH v430/DXFORTH.TXT b/DX-FORTH v430/DXFORTH.TXT new file mode 100644 index 0000000..571caf1 --- /dev/null +++ b/DX-FORTH v430/DXFORTH.TXT @@ -0,0 +1,900 @@ +DX-Forth for MS-DOS +------------------- + +This is the documentation for DX-Forth. It is divided into two parts: + +- A walk-through that introduces new users (even those without + previous Forth experience) to a few concepts and illustrates some of + DX-Forth's special features. However, no attempt is made to teach + Forth - for this, get hold of an introductory text such as: + + "Forth Programmer's Handbook", Conklin & Rather + "Programming Forth", Stephen Pelc + "And so Forth...", J.L. Bezemer + +- A technical section for prospective DX-Forth programmers. It assumes + the reader has some familiarity with the Forth language programming. + + +Contents: +--------- + + 1. Introduction + + 1.1 Overview + 1.2 Distribution files + 1.3 Acknowledgments + 1.4 Legal + 1.5 Installation + 1.6 Getting started + 1.7 Source files + 1.8 Screen editor + 1.9 Resident text file editor + 1.10 Command-line interface + 1.11 Machine code assembler + 1.12 Increasing System space + 1.13 Further suggestions + 1.14 Error messages + + 2. Programming reference + + 2.1 File system + 2.2 Application and System words + 2.3 Executing applications + 2.4 No Warm-Boot option + 2.5 User Patch area + 2.6 Overlays + 2.7 Multitasking + 2.8 User variables + 2.9 System vectors + 2.10 Deferred words + 2.11 Search order + 2.12 Compiler security + 2.13 Exception handling + 2.14 Exception codes + 2.15 Key codes + + +1. Introduction + +1.1 Overview + +DX-Forth is a Forth language compiler and development system +for MS-DOS 2.x and compatible disk operating systems. It is +intended to be a complete, easy to use, programming tool for +the creation of DOS applications. + +Features include: + + - ANS-FORTH Standard (FORTH-94) * + - Fast direct-threaded code + - Generate turnkey applications without compiler overhead + - Fast floating point and trigonometric functions + - Forth-94 file I/O + - DOSLIB application library + - Multitasking + - ANS locals + - Overlays for large applications + - 8086/87 Forth assembler for CODE words + - Full source code included + +* DX-FORTH 4 generally follows the FORTH-94 Standard but + does not seek to be strictly compliant. + + +1.2 Distribution files + +See FILES.TXT + + +1.3 Acknowledgments + +No software is written in a vacuum; therefore the author wishes to +gratefully acknowledge all those in the CP/M and Forth communities who +have generously made their source code available for public scrutiny. +Without these to serve as a starting point and source for ideas, +DX-Forth would not have been written. + + +1.4 Legal + +DX-Forth and all the files in this distribution (apart from excerpts +taken from the FORTH-83 and ANS-FORTH documents) are hereby placed into +the PUBLIC DOMAIN by the author. + +DX-Forth is an experimental software and is provided without support or +warranty. The author makes no guarantee as to fitness for purpose, nor +assumes liability for any error, omission, damage or loss caused by the +use of DX-Forth. Anyone wishing to use this software does so entirely +at their own risk. + + +1.5 Installation + +Not applicable to the MS-DOS version of DX-Forth. + + +1.6 Getting started + +Several versions of the DX-Forth compiler are available: + +FORTH.EXE The forth compiler kernel. It includes everything + required to load and compile forth source files. + +FORTH-F.EXE Same as FORTH.EXE but includes software floating point + and trigonometric functions. These increase the size + of the kernel by approximately 3K bytes. + +DX.EXE FORTH-F.EXE with full-screen editor loaded. + +FORTH-C.EXE Same as FORTH-F.EXE but uses "common stack" model + i.e. floating point items are placed on the data stack + rather than on a separate stack. + + Note: FORTH-C.EXE is not in the distribution but can + be generated by rebuilding the system with FMAKE.BAT + +First, enter forth by executing FORTH.EXE (or FORTH-F.EXE or DX.EXE) +from the DOS prompt e.g. + + A> FORTH + +You will be greeted with DX-Forth's start-up screen showing the +version number and compilation date. If you executed FORTH-F.EXE +you will also be informed that the floating point functions are +available. + +Now type + + FYI + +"For Your Information". It displays information about the current +forth environment including dictionary size, vocabularies, logged +drive and open screenfiles. + +To see the names of functions (Forth calls them "words") in the +dictionary, type + + WORDS + +Press any key to stop the display or to pause. If you want +to see only word names that contain the sequence 'MOD' then type + + WORDS: MOD + +You will notice some words are accompanied by an attribute. + +The bold attribute (normally blue) indicates the word resides in the +SYSTEM dictionary. All other words reside in the APPLICATION +dictionary. If the brightness attribute is on, it indicates the word +is IMMEDIATE. Attributes are accumulative. Thus a word that appears +in bold and has the brightness toggled is both a SYSTEM word and +IMMEDIATE. + +Forth users will be familiar with IMMEDIATE words. SYSTEM words are +peculiar to DX-Forth and are explained in the programming section. + +You can capture screen output to a printer e.g. + + PRINTER WORDS + +then restore output to the console with + + CONSOLE + +Adding a new function to forth's dictionary is easy. Let's try the +ubiquitous 'hello world' program. Type the following paying +attention to the space between ." and Hello . + + : HELLO-WORLD ." Hello world" ; + +If you make a mistake entering text you may use the backspace key + to delete the previous character, or escape key to erase +the entire line. + +Spaces are important to forth as they distinguish elements within a +forth statement. Forth syntax is very simple - a forth statement +consists of functions or numbers separated by one or more spaces. +In the example above : ." ; each represents a distinct forth +function. + +You have just compiled a new function or 'word' called HELLO-WORLD. +Now type + + WORDS + +This lists all words in the current vocabulary. key may +be used to pause/resume the listing or to stop. Note that +HELLO-WORLD appears at the top of the list since it was the most +recent addition to the dictionary. + +Now execute HELLO-WORLD by typing its name. It should display the +text + + Hello world + +Should you need to enter a quote character '"' within a quote- +delimited string, this may be done by entering it twice e.g. + + S" this text includes ""quote"" marks" CR TYPE + +produces + + this text includes "quote" marks + +Removing a word from the dictionary is even easier. Type + + FORGET HELLO-WORLD + +This discards HELLO-WORLD ... and any forth word you defined after +it! Use WORDS to check that HELLO-WORLD was deleted. + +Perhaps you would like to save HELLO-WORLD as your first turnkey DOS +application. To do this, re-enter the HELLO-WORLD definition if you +discarded it. Once you have tested it to make sure that it works as +expected, save it to disk with + + TURNKEY HELLO-WORLD HELLO + +If you now type DIR *.EXE you should see HELLO.EXE in the disk +directory. + +Now - the most important thing you should know - how to get out of +forth and back to DOS. Do this now by typing + + BYE + +Now that you are back in DOS you may try out your new HELLO program. +You will note that HELLO.EXE executable is considerably smaller in +size than the FORTH.EXE used to create it. This illustrates one of +DX-Forth's features - turnkey applications may be saved without the +compiler and word headers. The benefit is that applications take +less disk space, are quicker to load, and have more free memory +available to them when they execute. + + +1.7 Source files + +Forth has traditionally used 'blocks' for mass storage. Blocks may +hold any type of data including text. In DX-Forth, blocks are used +primarily to store forth program source. Each 'screen' (the name +given to blocks that hold forth text) represents 1024 bytes of data +organized as 16 lines of 64 characters each. DX-Forth screens are +saved as conventional DOS disk files and are distinguished by a .SCR +filetype (some forths use .BLK as the filetype). + +DX-Forth also supports forth source in standard text files. To load +and compile such a file, use: + + INCLUDE filename[.F] + +If no filetype is given then .F is assumed. Another form is: + + S" filename[.F]" INCLUDED ( Forth-94 Standard ) + +Forth source files (text or screen) may be nested to the default +maximum of 6. + + +1.8 Screen editor + +Screen files require a special text editor. DX-Forth includes such +an editor in the form of SED.SCR. The editor is automatically +loaded and run by FORTH.EXE or FORTH-F.EXE by typing + + n SED + +where n is the screen number to be edited. If n is omitted and the +data stack is empty then the editor will use the last LISTed, or if +an error occured, the screen that caused the error. + +If you have a slow computer or are working from a floppy disk then +it will be convenient to save a version of forth where the editor is +permanently loaded. Let's do this now. + +From the DOS prompt, load forth and open SED.SCR + + A>FORTH-F SED ( if no filetype is given .SCR is assumed ) + +Forth will boot-up with the message 'Using SED.SCR'. Alternately, +open SED.SCR from within forth with + + USING SED + +In DX-FORTH the most recently opened screenfile is termed the +'current' file and all screen and block commands operate on it. +CLOSE closes the 'current' screenfile. SWAP-FILE permits users +to switch between two open screenfiles. + +Once SED.SCR has been opened, you may view the contents of the +file with the LIST command. 0 LIST displays screen 0, 1 LIST +displays screen 1 etc. The following shortcuts are provided: + + L ( -- ) (L)ist the current screen + N ( -- ) list the (N)ext screen + B ( -- ) list the previous screen i.e. (B)ack + LS ( -- ) (S)wap screenfiles and (L)ist + +Line 0 of each screen is called the index line and traditionally +contains a comment indicating the contents of the screen. Typing + + 0 QX + +displays a 'quick index' of 60 screens beginning at screen 0. + +To list screens to a printer one could use + + PRINTER 0 LIST 1 LIST 2 LIST CONSOLE + +or more simply + + 0 2 SHOW + +which prints screens 0 to 2 at three screens per page. + +To print all the screens in a source file, type + + LISTING + +Now compile the editor into the dictionary with + + 1 LOAD + +Once loading has completed, typing WORDS will show new commands have +been added to the dictionary. In addition, FYI reveals some system +memory has been consumed and there is now a new vocabulary in addition +to FORTH - the EDITOR vocabulary. If you are curious to see what is +in the EDITOR vocabulary, type + + EDITOR WORDS + +Now that the editor has been loaded, let's make it permanent by saving +it and the current contents of the forth dictionary as a new executable. + +But before doing that you may prefer to use the name EDIT instead of +SED. That's easily done by creating a synonym e.g. + + AKA SED EDIT + +You can now use either SED or EDIT to invoke the screen editor. + +Let's finish saving our custom version of DX-Forth to disk. + + SAVE DX.EXE ( if no filetype is given .EXE is assumed ) + +Note: DX-Forth comes supplied with DX.EXE so you can omit the above +step if you wish. + +For details on using the editor, refer to the SED.TXT documentation +file. + + +1.9 Resident text file editor + +DX-Forth includes TED - a simple text file editor. As with the screen +editor, text source files may be edited without leaving the forth +environment. See TED.TXT for further information. + + +1.10 Command-line interface + +DX-Forth allows file opening and command processing from the DOS command +line. The syntax is: + + A:> FORTH item1 item2 ... itemn + +where: + + item1 filename to be opened (assumed suffix is .SCR) + item2...itemn forth command(s) to be executed + +Once the command sequence is completed, the DX-Forth sign-on message +appears and control passes to the user. + +To bypass file opening, replace item1 with a '-' character. + +Including BYE at the end of the command sequence will cause an immediate +return to DOS. This can be very useful and allows use of the forth +compiler within DOS batch files. + + +1.11 Machine code assembler + +Although threaded-code forth generates code that is compact and quite +fast - up to 10 times faster than interpreted BASIC - there may be +occasion when the full speed of machine code is required. + +The assembler provided with DX-Forth allows writing of forth 'code' +words. Code words are simply machine language routines that end with +a jump to NEXT. Documentation for the assembler may be found in the +file ASM.TXT. + + +1.12 Increasing System space + +The FORTH and FORTH-F executables are supplied with tools and assembler +installed. If either are not required, the System dictionary space may +be increased accordingly. To facilitate this, two marker words are +provided: + + -TOOLS removes the tools and all subsequent words. + -ASM removes the assembler and all subsequently defined words. + +E.g. To remove TOOLS type the following: + + CHECKING OFF FORGET -TOOLS CHECKING ON + +Note: As of DX-Forth 3.3, word headers are stored in their own segment +rather than in the System dictionary. Consequently there is now much +less need to conserve System dictionary space. + + +1.13 Further suggestions + +If you have worked your way through the previous sections, you now +know your way around DX-Forth - how to list and compile forth screen +files, save new versions of forth and create turnkey applications. + +If this is your first encounter with forth, I hope this brief tour +through DX-Forth will encourage you to look further. Get a book on +forth and learn it - forth really is EASY! + +The best way to learn forth (or any language) is by studying examples. +Several simple applications have been provided with DX-Forth. When +you encounter a forth word which is unfamiliar, find its definition +in the Forth-94 Standard, or the DX-Forth glossary if not a Standard +word. + +A sample filecopy program FCOPY is provided in source form. As well +as illustrating a complete forth application, it also serves as a +primer on using DX-Forth's file functions. It will show you how to: + +- get arguments from the DOS command line +- create file-handles and assign file-buffers +- open disk files +- read data from a disk file +- write data to a disk file +- close disk files +- handle errors + +Routines may be extracted for your own use or the entire program can +serve as the basis for a more complex one. + +NEWAPP.SCR is a skeletal program that allows users to quickly develop +DOS applications. Using DOSLIB.SCR it provides access to DOS functions +and routine tasks such as command-line parsing and buffered I/O. See +NEWAPP.TXT for details. + + +1.14 Error messages + +Compiler error messages +----------------------- +"block out of range" Attempt to access a block past end of + file. +"block r/w error" Error encountered during a block read or + write operation. +"no file open" File operation was requested but no file + was open. +"can't open file" File not found or write-protected. +"can't create file" Existing file write-protected or disk full. +"can't delete file" File not found or write-protected. +"can't resize file" File not found or write-protected. +"can't rename file" File exists, not found or write-protected. +"can't save file" Error occurred during save (probably disk + full). +"compilation only" Use only during compilation. +"execution only" Use only during execution. +"loading only" Use only during loading. +"definition unbalanced" Definition is not properly formed e.g. + conditional statements (IF ELSE THEN etc) + were incorrectly used or the data stack level + changed. +"is protected" Word is located in PROTECTed dictionary. +"is alias" Operation on alias not allowed e.g. FORGET. +"invalid name" Word name length outside the range 1 to 31 + characters. +"specify filename" A filename is required but none was given. +"too many files" Exceeded maximum number of open source files. +"is redefined" Definition with the same name already exists. + Note: this is a warning - not an error. +"is system" A System word is being compiled into the + Application dictionary. See section 2.2 + Note: aliases will be displayed using the + primary name. +"is undefined" Word could not be found in the dictionary + using the current search order, or was not + a valid number. +"no name space" Header dictionary full. +"stack?" Data stack under/overflow. +"r-stack?" Return stack under/overflow. +"f-stack?" Floating point stack under/overflow. +"invalid chain" Illegal CHAIN argument. See glossary. + +Run-time error messages +----------------------- +Apart from those listed below, DX-Forth does not perform run-time error +checking. It is the responsibility of the application programmer to +include error checking appropriate to the task. + +"HOLD buffer overflow" The string being built in the HOLD buffer + exceeded the maximum size. +"uninitiated DEFER" A DEFERed word was defined but never + initialized with IS. +"exception = [n]" Exception error code n was executed. See + section 2.14 for a list of system and DOS + codes. Application-defined error codes are + typically represented by a positive number. +"no data space" Data space or dictionary full. +"not enough RAM" Insufficient DOS memory. +"wrong DOS version" Requires DOS version 2.x or later. + +Assembler error messages +------------------------ +"definition unbalanced" Definition is not properly formed. +"duplicate label" Label number was previously used. +"execution only" Word may be used only during execution. +"invalid label" Incorrect label number or too many labels + used. +"branch out of range" Exceeded the range of a short relative + branch (128 bytes). +"too many references" Exceeded the maximum number of forward + references to labels. +"unresolved reference" A label was referenced but never defined. + + +2. Programming reference + +This section contains programming and technical information specific +to DX-Forth. + + +2.1 File system + +DX-Forth uses FORTH-94 disk file management. + + +2.2 Application and System words + +When a word is compiled into DX-Forth, it is added to either the +Application dictionary or the System dictionary. + +The above suggests that DX-Forth uses two dictionaries. In reality, +there is one dictionary physically divided into two parts. It is this +physical partitioning that enables DX-Forth to generate small turnkey +applications, free of compiler overhead. + +Executing the words APPLICATION or SYSTEM causes all subsequent +definitions to be compiled into the corresponding dictionary segment. +The word FYI shows the current compilation dictionary and statistics. + +The 'application' dictionary contains words (less their headers) that +are available for use by either TURNKEY applications or by the forth +compiler. + +The 'system' dictionary contains words that are used exclusively by the +forth compiler. Headers of forth words are located in their own +segment. System words and headers are NOT saved during the generation +of TURNKEY applications. + +To see which words are System or Application, type WORDS. If the word +is displayed with a bold attribute (usually blue), then it resides in +the System dictionary otherwise it resides in the Application dictionary. + +Compiling SYSTEM words + +Under no circumstances should an application compiled with TURNKEY be +allowed to execute a System word. Attempting to do so will result in +unpredictable behaviour and failure of the application. + +To assist users from inadvertently compiling System words into TURNKEY +applications, DX-Forth will issue a warning message should this be +attempted (assuming WARNING has not been disabled). + +Applications saved with TURNKEY-SYSTEM may safely ignore System warnings +as the entire forth dictionary including compiler and headers is saved. + +Spurious SYSTEM warnings + +It is possible to receive a System warning message that is neither an +error condition, nor results in failure of the turnkey application. +Typically it occurs during the compilation of defining words e.g. + + APPLICATION WARNING ON + + : BYTE-CONSTANT + CREATE C, DOES> C@ ; + +Compiling the above causes the following message to appear + + "CREATE is system C, is system (;CODE) is system" + +DX-Forth is warning the user that words CREATE C, (;CODE) are System +words and are being compiled into the Application dictionary. + +The reason this will NOT cause the application to fail is that the +words between CREATE and DOES> inclusive represent the "compiling" part +of the defining word. This part is executed only during compilation +- never when the application is run. + +To disable spurious System warning messages one may use WARNING OFF or +precede the offending definition with -? which will turn off WARNING +for that definition only. + +Tip: For an alternative way of creating defining words which avoids the +peculiarities of CREATE ... DOES> see BUILD in the glossary. + + +2.3 Executing applications + +Applications can often be fully tested and debugged from within the +forth environment. However when they are eventually TURNKEYed and +executed from the DOS command-line, there will be differences of which +the programmer should be aware: + + - The amount of unused memory available to an application will vary + depending on whether it is run from within forth or from the DOS + command-line. UNUSED may be used by applications to determine how + much free memory is currently available. + + - SET-LIMIT allows the programmer to specify a top-of-memory address + or LIMIT for the application. The effect of SET-LIMIT is postponed + until the turnkey application is executed. + + - The memory region at 5Ch and 80h (DOS default FCB and DMA buffer) is + overwritten by the forth compiler during DIR, RENAME, INCLUDE etc. + Otherwise, this region is unaffected and may be used by turnkey + applications to interrogate the DOS command-line. + + +2.4 No Warm-Boot option + +Not applicable to the MS-DOS version of DX-Forth. + + +2.5 User patch area + +Not applicable to the MS-DOS version of DX-Forth. + + +2.6 Overlays + +As DX-Forth resides in a single 64K segment, there will be a limit on +the size of applications that may be compiled. If larger applications +are needed this can often be achieved with overlays. + +Using overlays will require a little more planning of the application. +Some important aspects the programmer must consider are listed below. + + - The resident part of the program must ensure that the correct overlay + is in memory before executing an overlay word. + + - An overlay must not execute words that exist in other overlays. + + - An overlay must not execute words in the resident part, which in + turn, execute words in a different overlay. + +See OVERLAY.SCR for a demonstration of a simple overlay system. + + +2.7 Multitasking + +A co-operative 'round robin' multi-tasker is provided with DX-Forth. +It permits an application to have several tasks run concurrently. + +Refer to the multitasker documentation MULTI.TXT and the source file +MULTI.SCR for further details. + + +2.8 User variables + +In common with most forth systems, DX-Forth has 'user' variables. User +variables occupy a common region in memory. They hold various system +and boot up values and are also used for multi-tasking applications. + +In DX-Forth the default size of the user area is 128 bytes. User +variables are defined as follows: + + 44 USER VAR1 + 46 USER VAR2 + 50 USER VAR3 ... + +The number preceding USER is the offset in bytes of the variable from +the user base address (given by the variable UP). Offsets beginning +with 44 decimal are available to applications. In the above example, +VAR1 occupies 2 bytes (1 cell) at offset 44, VAR2 occupies 4 bytes +(2 cells) at offset 46 etc. See #USER in the glossary. + +As with normal variables, executing the name of a user variable returns +its address. Unlike normal variables, the literal value of the address +may differ at compile and run time. In multi-tasking applications the +contents of a user variable may differ between tasks. + +Predefined user variables in DX-Forth are: + +S0 R0 DP VOC-LINK FS0 DPH DPL BASE OUT CATCHER + + +2.9 System vectors + +SYS-VEC returns the address of the system vector and parameter table. +The table contains default values used by the system. Applications +may alter the vectors and values in the table as needed. Note that +some changes will not take effect until COLD is executed. Refer to +SYS-VEC in the glossary document for details. + + +2.10 Deferred words + +The following is a list of DX-Forth words built with DEFER IS . + + BEEP FIND MS PAUSE REFILL ACCEPT SOUND + +The current action of a deferred word may be obtained using: + + ' >BODY @ ( "name" -- xt ) or + ADDR @ ( "name" -- xt ) + + +2.11 Search order + +The dictionary search order is CONTEXT CURRENT FORTH where each +represents a vocabulary or "wordlist". Complex search orders are +possible using the CHAIN command. + + +2.12 Compiler security + +DX-Forth includes compiler security to detect malformed definitions +and constructs e.g. failing to terminate an IF section with a THEN. + +Compiler security words used by DX-Forth are listed in the glossary. +How and when to use them is a topic of its own and is not discussed +here (see the DX-Forth source files for examples of use). + +It is sometimes useful to disable balance checking in high-level or +code definitions. This may be done by setting variable CHECKING +to false (i.e. zero). + + +2.13 Exception handling + +CATCH THROW provide a mechanism for handling errors conditions within +a program. + +It is recommended that applications use only positive THROW codes. +Exception values in the range -1 to -4095 are reserved by ANS-FORTH +for use by the system. See: "Exception codes" + + +2.14 Exception codes + +DX-Forth implements only a subset of ANS-FORTH Standard exception +codes. Codes in the range -257 to -511 are reserved for DOS related +errors. + +DX-Forth exception codes: + + 0 no error + -1 ABORT + -2 ABORT" + -256 reserved + -257 to -511 DOS error code + +The correlation between DOS error code and DX-Forth exception code +is given below: + + Forth DOS + 0 0 no error + -511 1 invalid function number + -510 2 file not found + -509 3 path not found + -508 4 too many open files + -507 5 access denied + -506 6 invalid handle + -505 7 memory control block destroyed + -504 8 insufficient memory + -503 9 memory block address invalid + -502 10 environment invalid + -501 11 format invalid + -499 12 access code invalid + -498 13 data invalid + -497 14 reserved + -496 15 invalid drive + -495 16 attempted to remove current directory + -494 17 not same device + -493 18 no more files + ... ... + -257 255 unspecified error e.g. disk full + +Note: To convert an exception code in the range -257 to -511 to its +corresponding DOS error code, use: 255 AND + + +2.15 Key codes + +DX-Forth supports IBM-PC extended keystrokes and enhanced keyboards. +For ease of use, two-byte extended keystrokes are returned as single +values. The codes below are for an enhanced 101-key US keyboard. +Ascii codes 32-126 are not shown. + + Key Code Key Code Key Code + ---- ----- ---- ----- ---- ------ + 00 0 Alt F A1 161 Ctrl F7 E4 228 + Ctrl A 01 1 Alt G A2 162 Ctrl F8 E5 229 + Ctrl B 02 2 Alt H A3 163 Ctrl F9 E6 230 + Ctrl C 03 3 Alt J A4 164 Ctrl F10 E7 231 + Ctrl D 04 4 Alt K A5 165 Alt F1 E8 232 + Ctrl E 05 5 Alt L A6 166 Alt F2 E9 233 + Ctrl F 06 6 Alt ; A7 167 Alt F3 EA 234 + Ctrl G 07 7 Alt ' A8 168 Alt F4 EB 235 + Ctrl H 08 8 Alt ` A9 169 Alt F5 EC 236 + Ctrl I 09 9 AA 170 Alt F6 ED 237 + Ctrl J 0A 10 Alt \ AB 171 Alt F7 EE 238 + Ctrl K 0B 11 Alt Z AC 172 Alt F8 EF 239 + Ctrl L 0C 12 Alt X AD 173 Alt F9 F0 240 + Ctrl M 0D 13 Alt C AE 174 Alt F10 F1 241 + Ctrl N 0E 14 Alt V AF 175 Ctrl Prtsc F2 242 + Ctrl O 0F 15 Alt B B0 176 Ctrl Left F3 243 + Ctrl P 10 16 Alt N B1 177 Ctrl Right F4 244 + Ctrl Q 11 17 Alt M B2 178 Ctrl End F5 245 + Ctrl R 12 18 Alt , B3 179 Ctrl PgDn F6 246 + Ctrl S 13 19 Alt . B4 180 Ctrl Home F7 247 + Ctrl T 14 20 Alt / B5 181 Alt 1 F8 248 + Ctrl U 15 21 B6 182 Alt 2 F9 249 + Ctrl V 16 22 * Alt * B7 183 Alt 3 FA 250 + Ctrl W 17 23 B8 184 Alt 4 FB 251 + Ctrl X 18 24 B9 185 Alt 5 FC 252 + Ctrl Y 19 25 BA 186 Alt 6 FD 253 + Ctrl Z 1A 26 F1 BB 187 Alt 7 FE 254 + Ctrl [ 1B 27 F2 BC 188 Alt 8 FF 255 + Ctrl \ 1C 28 F3 BD 189 Alt 9 100 256 + Ctrl ] 1D 29 F4 BE 190 Alt 0 101 257 + Ctrl ^ 1E 30 F5 BF 191 Alt - 102 258 + Ctrl _ 1F 31 F6 C0 192 Alt = 103 259 + F7 C1 193 Ctrl PgUp 104 260 + Ctrl <- 7F 127 F8 C2 194 F11 105 261 + 80 128 F9 C3 195 F12 106 262 + Alt Esc 81 129 F10 C4 196 Shift F11 107 263 + 82 130 C5 197 Shift F12 108 264 + 83 131 C6 198 Ctrl F11 109 265 + 84 132 Home C7 199 Ctrl F12 10A 266 + 85 133 Up C8 200 Alt F11 10B 267 + 86 134 PgUp C9 201 Alt F12 10C 268 + 87 135 * Alt - CA 202 Ctrl Up 10D 269 + 88 136 Left CB 203 * Ctrl - 10E 270 + 89 137 * 5 CC 204 * Ctrl _ 10F 271 + 8A 138 Right CD 205 110 272 + 8B 139 * Alt + CE 206 Ctrl Down 111 273 + 8C 140 End CF 207 Ctrl Ins 112 274 + 8D 141 Down D0 208 Ctrl Del 113 275 + Alt <- 8E 142 PgDn D1 209 Ctrl Tab 114 276 +Shift Tab 8F 143 Ins D2 210 Ctrl / 115 277 + Alt Q 90 144 Del D3 211 * Ctrl * 116 278 + Alt W 91 145 Shift F1 D4 212 Alt Home 117 279 + Alt E 92 146 Shift F2 D5 213 Alt Up 118 280 + Alt R 93 147 Shift F3 D6 214 Alt PgUp 119 281 + Alt T 94 148 Shift F4 D7 215 11A 282 + Alt Y 95 149 Shift F5 D8 216 Alt Left 11B 283 + Alt U 96 150 Shift F6 D9 217 11C 284 + Alt I 97 151 Shift F7 DA 218 Alt Right 11D 285 + Alt O 98 152 Shift F8 DB 219 11E 286 + Alt P 99 153 Shift F9 DC 220 Alt End 11F 287 + Alt [ 9A 154 Shift F10 DD 221 Alt Down 120 288 + Alt ] 9B 155 Ctrl F1 DE 222 Alt PgDn 121 289 +Alt Enter 9C 156 Ctrl F2 DF 223 Alt Ins 122 290 + 9D 157 Ctrl F3 E0 224 Alt Del 123 291 + Alt A 9E 158 Ctrl F4 E1 225 * Alt / 124 292 + Alt S 9F 159 Ctrl F5 E2 226 Alt Tab 125 293 + Alt D A0 160 Ctrl F6 E3 227 * Alt Enter 126 294 + +(*) on keypad + +Note: + + - Codes 261 and above are only available on AT-class machines + fitted with an enhanced keyboard + + - DOS versions prior to 4.0 do not support enhanced keys + irrespective of the hardware + diff --git a/DX-FORTH v430/DXFORTH.WDS b/DX-FORTH v430/DXFORTH.WDS new file mode 100644 index 0000000..fcf6b31 --- /dev/null +++ b/DX-FORTH v430/DXFORTH.WDS @@ -0,0 +1,562 @@ +! +!CSP +!L +# +#> +#S +#SCREENS +#USER +' +'AH +'AX +'BH +'BP +'BX +'CH +'CX +'DH +'DI +'DS +'DX +'ES +'FLAGS +'NEXT +'SI +'SOURCE +( +(* +(.) +(;CODE) +(D.) +(F.) +(FE.) +(FS.) +(G.) +(NAME) +(U.) +* +*/ +*/MOD ++ ++! ++EXT ++LOOP ++STRING +, +," +- +--> +-1 +-? +-ALLOT +-ASM +-BLANKS +-EXT +-FP +-PATH +-ROLL +-ROT +-TASK +-TOOLS +-TRAILING +. +." +.( +.FREE +.ID +.NAME +.R +.S +.VOC +/ +/MOD +/MS +/PARSE +/STRING +0 +0< +0<> +0= +0> +1 +1+ +1- +2 +2! +2!L +2* +2+ +2- +2/ +2>R +2@ +2@L +2CONSTANT +2DROP +2DUP +2LITERAL +2NIP +2OVER +2R> +2R@ +2ROT +2SWAP +2VARIABLE +3 +: +:NONAME +; +;C +;CODE +< +<# +<> + +>< +>BODY +>FLOAT +>FNAME +>IN +>MARK +>NUMBER +>R +? +?BAL +?BLOCK +?COMP +?CSP +?DO +?DUP +?EXEC +?STACK +@ +@EXECUTE +@L +ABORT +ABORT" +ABS +ACCEPT +ADDR +AGAIN +AHEAD +AKA +ALIGN +ALIGNED +ALLOT +AND +APPLICATION +ASSEMBLER +AT-XY +ATTRIB +B +B/BUF +BACKGROUND +BAL +BASE +BEEP +BEGIN +BEHEAD +BETWEEN +BIN +BINARY +BIOS-IO +BL +BLANK +BLK +BLOCK +BOLD +BOUNDS +BRIGHT +BUFFER +BUILD +BYE +C! +C!L +C, +C/L +C@ +C@L +CAPS +CASE +CATCH +CATCHER +CELL+ +CELL- +CELLS +CHAIN +CHAR +CHAR+ +CHARS +CHECKING +CLEAR-LINE +CLOSE +CLOSE-ALL +CLOSE-FILE +CMDTAIL +CMOVE +CMOVE> +CMOVEL +CODE +COLD +COLOR-TABLE +COMPARE +COMPILE +COMPILE, +COND +CONSOLE +CONSTANT +CONTEXT +COUNT +CR +CREATE +CREATE-FILE +CS-DROP +CS-MARK +CS-PICK +CS-POP +CS-PUSH +CS-ROLL +CS-TEST +CSEG +CSP +D+ +D- +D. +D.R +D0< +D0= +D2* +D2/ +D< +D= +D>F +D>S +DABS +DECIMAL +DEFER +DEFINITIONS +DELETE +DELETE-FILE +DELETE-LINE +DEPTH +DIR +DMAX +DMIN +DNEGATE +DO +DOES> +DOS-IO +DOSCALL +DOSERR? +DOSVER +DP +DPH +DPL +DROP +DU< +DUMP +DUP +DXFORTH +ELSE +EMIT +EMPTY +EMPTY-BUFFERS +END +ENDCASE +ENDOF +EOL +ERASE +EVALUATE +EXECUTE +EXIT +F! +F* +F** +F+ +F, +F- +F. +F.R +F/ +F0< +F0= +F0> +F< +F> +F>D +F>S +F@ +FABS +FALIGN +FALIGNED +FALSE +FATAN +FCONSTANT +FCOS +FDB +FDEPTH +FDP +FDROP +FDUP +FE. +FE.R +FEXP +FILE-POSITION +FILE-SIZE +FILE-STATUS +FILEBLOCKS +FILL +FIND +FLITERAL +FLN +FLOAD +FLOAT+ +FLOATS +FLOOR +FLUSH +FLUSH-FILE +FM/MOD +FMAX +FMIN +FNEGATE +FOREGROUND +FORGET +FORTH +FOVER +FPICK +FRANDOM +FROT +FROUND +FS. +FS.R +FS0 +FSIN +FSP +FSQRT +FSWAP +FVARIABLE +FYI +G. +G.R +GET-CURRENT +GET-WINDOW +GET-XY +GETFILENAME +HERE +HEX +HLIMIT +HOLD +HSEG +I +I' +ICLOSE +IF +IMMEDIATE +INCLUDE +INCLUDED +INDEX +INSERT-LINE +INTCALL +INTERPRET +INVERSE +INVERT +IS +J +KEY +KEY? +L +LABEL +LAST +LASTFILE +LDUMP +LEAVE +LFILL +LIMIT +LINK, +LIST +LISTING +LITERAL +LOAD +LOADED +LOADFILE +LOADLINE +LOOP +LREAD +LS +LSHIFT +LWRITE +M* +M*/ +M+ +MACRO +MARKER +MAX +MAX-PRECISION +MIN +MOD +MOVE +MS +N +N>NAME +NEGATE +NHOLD +NIP +NOOP +NORMAL +NOT +NUMBER? +OF +OFF +ON +OPEN +OPEN-FILE +OR +ORDER +OUT +OVER +P! +P@ +PACK +PAD +PAGE +PARSE +PATH +PAUSE +PC! +PC@ +PI +PICK +PLACE +POSTPONE +PRECISION +PRINTER +PROTECT +QUIT +QX +R/O +R/W +R0 +R> +R@ +READ-FILE +READ-LINE +RECURSE +REFILL +REMEMBER +RENAME +RENAME-FILE +REPEAT +REPOSITION-FILE +REPRESENT +RESIZE-FILE +RETURN +ROLL +ROT +RP! +RP@ +RSHIFT +S" +S, +S.R +S0 +S>D +S>F +SAVE +SAVE-BUFFERS +SCAN +SCR +SCREEN? +SEARCH +SED +SET-CURRENT +SET-LIMIT +SET-PRECISION +SET-WINDOW +SHOLD +SHOW +SIGN +SKIP +SLITERAL +SM/REM +SMUDGE +SOUND +SOURCE +SP! +SP@ +SPACE +SPACES +SSEG +STATE +SWAP +SWAP-FILE +SYS +SYS-VEC +SYSTEM +TED +THEN +THENS +THROW +THRU +TICKS +TO +TOKEN +TRIM +TRUE +TUCK +TURNKEY +TURNKEY-SYSTEM +TYPE +U. +U.R +U2/ +U< +U> +UM* +UM/MOD +UMAX +UMIN +UNLOOP +UNNEST +UNTIL +UNUSED +UP +UPCASE +UPDATE +UPPER +USER +USING +VALUE +VARIABLE +VOC-LINK +VOCABULARY +VOCS +W/O +W>NAME +WAIT-TICK +WARNING +WHILE +WITHIN +WORD +WORDS +WORDS: +WRITE-FILE +WRITE-LINE +XOR +Y/N +ZCOUNT +ZPLACE +[ +['] +[ASM +[CHAR] +[COMPILE] +[DEFINED] +[ELSE] +[IF] +[THEN] +[UNDEFINED] +\ +\\ +] diff --git a/DX-FORTH v430/EXTEND.SCR b/DX-FORTH v430/EXTEND.SCR new file mode 100644 index 0000000..4f401cd --- /dev/null +++ b/DX-FORTH v430/EXTEND.SCR @@ -0,0 +1 @@ +\ Extend Extend DX-Forth kernel \ Load block empty forth definitions decimal system marker -TASK ( editor stubs) : SED s" #1 FLOAD SED SED" evaluate ; : TED s" LOADLINE @ LASTFILE INCLUDE TED (TED)" evaluate ; 1 fload TOOLS 1 fload ASM application protect \ No newline at end of file diff --git a/DX-FORTH v430/F87.TXT b/DX-FORTH v430/F87.TXT new file mode 100644 index 0000000..f4a2dff --- /dev/null +++ b/DX-FORTH v430/F87.TXT @@ -0,0 +1,92 @@ +F87 - Hardware Floating-Point for DX-Forth + +F87 requires an 80387 or compatible floating-point processor. Applications +compiled with F87 will check whether a suitable FPU is present and abort +with an error if none is found. + +F87 models currently supported: + +F87S.SCR single precision (32 bit) reals on data stack +F87D.SCR double precision (64 bit) reals on data stack +F87DS.SCR double precision (64 bit) reals on separate stack +F87X.SCR extended precision (80 bit) reals on data stack + +Compile the model of your choice e.g. FORTH.EXE F87D 1 LOAD BYE + +While F87 includes several IEEE 754 features such as NaN/Inf, signed-zero, +rounding modes etc. there is no attempt to be IEEE 754 compliant. + +Acknowlegements: + +F83 8087 FLOATING POINT 1984 by Steve Pollack + + +F87 Glossary: + +FINIT ( -- ) Performs 80x87 FPU instruction 'finit' resetting the + FPU hardware and rounding mode to "round to nearest/ + even". If a compatible FPU is not present an error + message "requires 80387+ FPU" is issued and the + application aborts. By default FINIT is executed by + COLD. + +CW@ ( -- cw ) Get FPU control word +CW! ( cw -- ) Set FPU control word + +SET-NEAR ( -- ) Set FPU rounding to "nearest or even" (default) +SET-FLOOR ( -- ) Set FPU rounding to "round down" +SET-CEIL ( -- ) Set FPU rounding to "round up" +SET-TRUNC ( -- ) Set FPU rounding to "round towards zero" i.e. truncate + +FROUND ( r1 -- r2 ) Round to integral value using current rounding mode +FNEAR ( r1 -- r2 ) Round to integral value nearest or even +FLOOR ( r1 -- r2 ) Round to integral value nearest negative infinity +FCEIL ( r1 -- r2 ) Round to integral value nearest positive infinity +FTRUNC ( r1 -- r2 ) Round to integral value nearest zero + +SIGNED-ZERO ( -- addr ) A VARIABLE which controls floating-point + negative-zero display. Default is OFF. + +F0= ( r -- flag ) Return true if r is zero, or false otherwise. Does not + differentiate between positive and negative zero. + +F= ( r1 r2 -- flag ) Return true if r1 and r2 are equal, or false otherwise. + Does not differentiate between positive and negative + zero. + +FLOG ( r1 -- r2 ) r2 is the base-ten logarithm of r1. An ambiguous + condition exists if r1 is less than or equal to zero. + +FALOG ( r1 -- r2 ) Raise ten to the power r1, giving r2. + +FSIGNBIT ( r -- sign ) Return sign of r as indicated by the IEEE sign bit. + +FSIGN ( r -- sign ) As for FSIGNBIT except the sign of -0.0E is determined + by variable SIGNED-ZERO. + +FCLASS ( r -- +n ) Return class of floating-point number r. +n is a + positive non-zero value indicating NaN, infinite, + normal, subnormal, zero or the 80x87 conditions + unsupported and empty. + +FP-NORMAL ( -- +n ) CONSTANT representing f/p finite class +FP-SUBNORMAL ( -- +n ) CONSTANT representing f/p subnormal class +FP-ZERO ( -- +n ) CONSTANT representing f/p zero class +FP-INFINITE ( -- +n ) CONSTANT representing f/p infinity class +FP-NAN ( -- +n ) CONSTANT representing f/p NaN class + ++INF ( -- r ) FCONSTANT returning f/p number '+Inf' +-INF ( -- r ) FCONSTANT returning f/p number '-Inf' ++NAN ( -- r ) FCONSTANT returning f/p number '+NaN' +-NAN ( -- r ) FCONSTANT returning f/p number '-NaN' + +>FLOAT ( c-addr u -- r true | false | other 1 ) + Extend >FLOAT semantics to return 1 and the corresponding IEEE datum + if any of the case-insensitive strings "NaN" "Inf" "Infinity", with or + without sign, are present. + +REPRESENT ( r c-addr n1 -- n2 flag1 flag2 ) + In addition to the semantics for REPRESENT (see DX-Forth glossary) when + flag2=false return a string "+NAN" "-NAN" "+INF" "-INF" or "BADFLT" in + the buffer at c-addr padded with trailing blanks (BL). n2 is reserved + and flag1=sign. Rounding direction is per current rounding mode. diff --git a/DX-FORTH v430/F87D.SCR b/DX-FORTH v430/F87D.SCR new file mode 100644 index 0000000..36cfa0a --- /dev/null +++ b/DX-FORTH v430/F87D.SCR @@ -0,0 +1 @@ +\ 80387 15-digit floating point (common stack) Compile with: FORTH - 1 FLOAD FP87D BYE Variable SIGNED-ZERO controls floating point signed zero display. Default is off. \ Load screen empty forth definitions decimal marker -FP 1 fload ASM87 cr .( loading 80387 15-digit floating point, common stack ) blk @ 1+ #screens 1- thru protect cr .( Save to disk? ) y/n [if] save F87D [then] \ 8087? CPU? [undefined] 8087? [if] code 8087? ( -- flag ) ax ax sub ax push sp bp xchg $E3DB , ( FINIT ) #100 # cx mov 1 $: 1 $ loop $7ED9 , 0 c, ( FSTCW [BP] ) sp bp xchg bx pop bx bx or 2 $ jz ax dec 2 $: 1push end-code [then] [undefined] cpu? [if] code CPU? ( -- n ) \ n= $86, $286, $386 pushf $86 # ax mov sp push bx pop bx sp cmp 1 $ jnz 2 # ah mov pushf bx pop $F0 # bh or bx push popf pushf bx pop $F0 # bh and 1 $ jz ah inc 1 $: popf 1push end-code [then] \ CW@ CW! FINIT hex code CW@ ( -- cw ) ax push sp di mov 0 [di] fstcw wait next end-code code CW! ( cw -- ) sp di mov 0 [di] fldcw ax pop next end-code : FINIT ( -- ) 8087? cpu? $287 > and 0= abort" requires 80387+ FPU" ( cw@ $FCFF and $0100 or cw! ) ; \ FLOATS FLOAT+ FALIGN FALIGNED FDEPTH code FLOATS ( x1 -- x2 ) ax pop ax shl ax shl ax shl ax push next end-code code FLOAT+ ( f-addr1 -- f-addr2 ) ax pop 1 floats # ax add ax push next end-code aka noop FALIGN ( -- ) immediate aka noop FALIGNED ( addr -- f-addr ) immediate : FDEPTH ( -- +n ) depth [ 1 floats 2/ ] literal / ; \ F@ F! FDROP code F@ ( addr -- r ) bx pop 6 [bx] push 4 [bx] push 2 [bx] push 0 [bx] push next end-code code F! ( r addr -- ) bx pop 0 [bx] pop 2 [bx] pop 4 [bx] pop 6 [bx] pop next end-code code FDROP ( r -- ) 1 floats # sp add next end-code \ F, FLITERAL FCONSTANT FVARIABLE code flit si push 1 floats # si add ' f@ ) jmp end-code system : F, ( r -- ) here [ 1 floats ] literal allot f! ; : FLITERAL postpone flit f, ; immediate : FCONSTANT ['] f@ build f, ; : FVARIABLE create [ 1 floats ] literal allot ; application \ FDUP FSWAP code FDUP ( r -- r r ) sp di mov 6 [di] push 4 [di] push 2 [di] push 0 [di] push next end-code code FSWAP ( r1 r2 -- r2 r1 ) sp di mov qword 0 [di] fld qword 8 [di] fld qword 0 [di] fstp wait qword 8 [di] fstp wait next end-code \ FOVER FROT code FOVER ( r1 r2 -- r1 r2 r1 ) sp di mov 0E [di] push 0C [di] push 0A [di] push 08 [di] push next end-code code FROT ( r1 r2 r3 -- r2 r3 r1 ) sp di mov qword 0 [di] fld qword 8 [di] fld qword 10 [di] fld qword 0 [di] fstp wait qword 10 [di] fstp wait qword 8 [di] fstp wait next end-code \ FPICK F2DUP FTUCK FNIP code FPICK ( rn..r0 n -- rn..r0 rn ) di pop 1 floats # ax mov di mul ax di mov sp bp xchg qword 0 [di+bp] fld 1 floats # bp sub qword 0 [bp] fstp wait sp bp xchg next end-code : F2DUP ( r1 r2 -- r1 r2 r1 r2 ) fover fover ; : FTUCK ( r1 r2 -- r2 r1 r2 ) fswap fover ; : FNIP ( r1 r2 -- r2 ) fswap fdrop ; \ F+ F- code F+ ( r1 r2 -- r3 ) sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fadd qword 0 [bp] fstp wait sp bp xchg next end-code code F- ( r1 r2 -- r3 ) sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fsubr qword 0 [bp] fstp wait sp bp xchg next end-code \ F* F/ code F* ( r1 r2 -- r3 ) sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fmul qword 0 [bp] fstp wait sp bp xchg next end-code code F/ ( r1 r2 -- r3 ) sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fdivr qword 0 [bp] fstp wait sp bp xchg next end-code \ FSQRT FNEGATE FABS code FSQRT ( r1 -- r2 ) sp di mov qword 0 [di] fld fsqrt qword 0 [di] fstp wait next end-code code FNEGATE ( r1 -- r2 ) sp di mov qword 0 [di] fld fchs qword 0 [di] fstp wait next end-code code FABS ( r1 -- r2 ) sp di mov qword 0 [di] fld fabs qword 0 [di] fstp wait next end-code \ F0> F0< F0= label ztst sp di mov qword 0 [di] fld ftst ax fstsw st(0) fstp 1 floats # sp add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F0> ( r -- flag ) 00 # cl mov ztst ju end-code code F0< ( r -- flag ) 01 # cl mov ztst ju end-code code F0= ( r -- flag ) 40 # cl mov ztst ju end-code \ F< F> F= label tst sp di mov qword 1 floats [di] fld qword 0 [di] fld fcompp ax fstsw st(0) fstp 2 floats # sp add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F< ( r1 r2 -- flag ) 00 # cl mov tst ju end-code code F> ( r1 r2 -- flag ) 01 # cl mov tst ju end-code code F= ( r1 r2 -- flag ) 40 # cl mov tst ju end-code \\ F0<> F<> F<= F>= : F0<> ( r -- flag ) f0= 0= ; : F<> ( r -- flag ) f= 0= ; : F<= ( r1 r2 -- flag ) f> 0= ; : F>= ( r1 r2 -- flag ) f< 0= ; \ FMAX FMIN : FMAX ( r1 r2 -- r-max ) fover fover f< if fswap then fdrop ; : FMIN ( r1 r2 -- r-min ) fover fover f> if fswap then fdrop ; \ FROUND code FROUND ( r1 -- r2 ) sp di mov qword 0 [di] fld frndint qword 0 [di] fstp wait next end-code label frnd 4 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 2 [bp] mov 2 [bp] fldcw sp bx mov qword 2 [bx] fld frndint qword 2 [bx] fstp wait 0 [bp] fldcw 4 # bp add ret end-code \ FNEAR FLOOR FCEIL FTRUNC code FNEAR ( r1 -- r2 ) 00 # al mov frnd ) call next end-code code FLOOR ( r1 -- r2 ) 04 # al mov frnd ) call next end-code code FCEIL ( r1 -- r2 ) 08 # al mov frnd ) call next end-code code FTRUNC ( r1 -- r2 ) 0C # al mov frnd ) call next end-code \ SET-NEAR/FLOOR/CEIL/TRUNC label setr 2 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 0 [bp] mov 0 [bp] fldcw 2 # bp add next end-code code SET-NEAR ( -- ) 00 # al mov setr ju end-code code SET-FLOOR ( -- ) 04 # al mov setr ju end-code code SET-CEIL ( -- ) 08 # al mov setr ju end-code code SET-TRUNC ( -- ) 0C # al mov setr ju end-code \ FMOD FREM code FMOD ( r1 r2 -- r3 ) \ modulus sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fld fprem qword 0 [bp] fstp wait sp bp xchg next end-code code FREM ( r1 r2 -- r3 ) \ IEEE remainder sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fld fprem1 qword 0 [bp] fstp wait sp bp xchg next end-code \ FLN FLOG code FLN ( r1 -- r2 ) sp bx mov qword 0 [bx] fld fldln2 st(1) fxch fyl2x qword 0 [bx] fstp wait next end-code code FLOG ( r1 -- r2 ) sp bx mov qword 0 [bx] fld fldlg2 st(1) fxch fyl2x qword 0 [bx] fstp wait next end-code \ FEXP FALOG F** label power sp bx mov qword 0 [bx] fld 1 floats # bp sub st(1) fmulp st(0) fld 0 [bp] fstcw wait 0 [bp] push 0F3FF # 0 [bp] and 0400 # 0 [bp] or 0 [bp] fldcw frndint 0 [bp] pop 0 [bp] fldcw st(0) fld qword 0 [bp] fstp st(1) fsubp fld1 fchs st(1) fxch fscale st(1) fstp f2xm1 fld1 st(1) faddp st(0) st fmul qword 0 [bp] fld st(1) fxch fscale st(1) fstp 1 floats # bp add qword 0 [bx] fstp wait next end-code \ FEXP FALOG F** code FEXP ( r1 -- r2 ) fldl2e power ju end-code code FALOG ( r1 -- r2 ) fldl2t power ju end-code : F** ( r1 r2 -- r3 ) fswap fln f* fexp ; \ D>F F>D code D>F ( d -- r ) dx pop ax pop 1 floats # sp sub sp di mov dx 2 [di] mov ax 0 [di] mov dword 0 [di] fild qword 0 [di] fstp wait next end-code code F>D ( r -- d ) 0C # al mov frnd ) call sp di mov qword 0 [di] fld dword 0 [di] fistp wait 1 floats # sp add 0 [di] push 2 [di] push next end-code \ S>F F>S code S>F ( n -- r ) ax pop 1 floats # sp sub sp di mov ax 0 [di] mov word 0 [di] fild qword 0 [di] fstp wait next end-code code F>S ( r -- n ) 0C # al mov frnd ) call sp di mov qword 0 [di] fld dword 0 [di] fistp wait 1 floats # sp add 0 [di] push next end-code \ SF@ SF! code SF@ ( addr -- r ) di pop dword 0 [di] fld 1 floats # sp sub sp di mov qword 0 [di] fstp wait next end-code code SF! ( r addr -- ) bx pop sp di mov qword 0 [di] fld 1 floats # sp add dword 0 [bx] fstp wait next end-code \ DF@ DF! aka F@ DF@ ( addr -- r ) aka F! DF! ( r addr -- ) \ FSIN FCOS FTAN code FSIN ( r1 -- r2 ) sp di mov qword 0 [di] fld fsin qword 0 [di] fstp wait next end-code code FCOS ( r1 -- r2 ) sp di mov qword 0 [di] fld fcos qword 0 [di] fstp wait next end-code code FTAN ( r1 -- r2 ) sp di mov qword 0 [di] fld fptan st(0) fstp qword 0 [di] fstp wait next end-code \ FATAN2 FATAN code FATAN2 ( r1 r2 -- r3 ) sp bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fld st(1) fxch fpatan qword 0 [bp] fstp wait sp bp xchg next end-code \ : FATAN ( r1 -- r2 ) [ 1. d>f ] fliteral fatan2 ; \\ F~ : F~ ( r1 r2 r3 -- flag ) fdup f0= if fdrop fdup fsign >r fover fsign >r f= 2r> xor 0= and else fdup f0< if fabs frot frot fover fover f- fabs frot fabs frot fabs f+ frot f* f< else frot frot f- fabs f> then then ; \ rmax PI INF NAN 7FEF FFFF FFFF FFFF fconstant rmax 4009 21FB 5444 2D18 fconstant PI 7FF0 0000 0000 0000 fconstant +INF FFF0 0000 0000 0000 fconstant -INF 7FF8 0000 0000 0000 fconstant +NAN FFF8 0000 0000 0000 fconstant -NAN decimal \ FSIGNBIT SIGNED-ZERO FSIGN \ test sign using IEEE sign bit code FSIGNBIT ( r -- sign ) sp di mov qword 0 [di] fld 1 floats # sp add fxam ax fstsw st(0) fstp bx bx sub $02 # ah test ( sign ) 1 $ jz bx dec 1 $: bx push next end-code \ signed-zero control variable SIGNED-ZERO signed-zero off \ test sign according to current mode : FSIGN ( r -- sign ) fdup f0= >r fsignbit r> if signed-zero @ 0<> and then ; \ FCLASS FP-NAN/NORMAL/INFINITE/ZERO/SUBNORMAL \ 1=Unsupp 2=NAN 5=norm 6=INF 65=zero 66=Empty 69=denorm code FCLASS ( r -- x ) sp di mov qword 0 [di] fld fxam ax fstsw st(0) fstp $45 # ah and $04 # ah cmp 1 $ jnz $0FFE # 1 floats 2- [di] test 1 $ jnz $40 # ah or 1 $: ah inc ( make non-zero) bx bx sub ah bl mov 1 floats # sp add bx push next end-code 2 constant FP-NAN 5 constant FP-NORMAL 6 constant FP-INFINITE 65 constant FP-ZERO 69 constant FP-SUBNORMAL \ nan? illegal? \ test for non-number : nan? ( r -- +n|0 ) fclass fp-normal of 0 end fp-subnormal of 0 end fp-zero of 0 end ; \ test illegal number : illegal? ( r -- x|0 ) fdup nan? >r \ non-finite fabs rmax f> \ out of range r> or ; \ >FLOAT : getc ( a u -- a' u' c ) 1 /string over 1- c@ ; \ get sign : gets ( a u -- a' u' n|0 ) dup if getc dup [char] - = if end [char] + <> /string then 0 ; \ >FLOAT variable exp \ exponent variable dpf \ decimal point fvariable tmp 10 0 d>f fconstant ften : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 9 u> if drop -1 /string end 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat ; \\ >FLOAT : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 10 u< while 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat drop -1 /string then ; \ >FLOAT : getmant ( a u -- a' u' flag ) tuck getdigs dup if over c@ [char] . = if -1 dpf ! 1 /string getdigs then then rot over - dpf @ + ; \ >FLOAT : getexp ( a u -- a' u' ) dup if over c@ 33 or [char] e = ( 'D' 'E' 'd' 'e') 1 and /string then gets >r 0 0 2swap >number 2swap d>s r> if negate then exp @ + begin ?dup while dup 0< if 1+ tmp f@ ften f/ else 1- tmp f@ ften f* then tmp f! repeat ; \ >FLOAT : fpin ( c-addr u -- r -1 | 0 ) cw@ >r set-near [ 0. d>f ] fliteral tmp f! exp off dpf off 2dup -trailing nip 0<> and dup if gets >r getmant if getexp dup while then 2drop 2r> drop cw! 0 end else 0 >r then 2drop tmp f@ r> if fnegate then fdup illegal? if fdrop 0 else -1 then r> cw! ; \ >FLOAT : >FLOAT ( c-addr u -- r -1 | 0 | nan/inf 1 ) 2dup gets >r 2dup s" NAN" caps compare if 2dup s" INF" caps compare if 2dup s" INFINITY" caps compare if 2drop r> drop fpin end then 2drop 2drop +inf else 2drop 2drop +nan then r> if fnegate then 1 ; \\ fnumber system \ standard behaviour : fnumber ( c-addr u -- [r] flag ) dup 1 > if ( at least 2 chars ) over dup c@ [char] . < - ( skip sign) c@ [char] . > >r ( 1st char can't be .) 2dup s" E" caps search >r 2drop 2r> and base @ #10 = and 0= while then 2drop 0 else >float then dup >r state @ and if postpone fliteral then r> ; application \ fnumber system \ allow leading decimal point : fnumber ( c-addr u -- [r] flag ) 2dup s" E" caps search -rot 2drop base @ #10 = and if >float else 2drop 0 then dup >r state @ and if postpone fliteral then r> ; application \ REPRESENT #15 constant #fdigits \ maximum usable precision aka #fdigits #fchars \ maximum float characters variable rm \ rounding mode variable ex \ exponent variable sgn \ sign \ REPRESENT \ build NAN string - don't exceed buffer! [defined] nanload [if] : nan$ ( r c-addr1 u1 -- r c-addr2 u2 ) ftmp 0 +string 2>r fdup nanload 0 <# 2dup or if [char] ) hold #s [char] ( hold then #> 2r> +string ; [else] aka noop nan$ immediate [then] \ REPRESENT \ normalize to 0.1 <= r < 1.0 : normalize ( r1 -- r2 ) fabs fdup f0= 0= if begin fdup [ 1. d>f ] fliteral f< 0= while ften f/ 1 ex +! repeat begin fdup [ 1. d>f ften f/ ] fliteral f< while ften f* -1 ex +! repeat then ; \ REPRESENT : REPRESENT ( r c-addr n1 -- n2 flag1 flag2 ) 2>r fdup fsignbit sgn ! fdup nan? ?dup if ( not a number) sgn @ if negate then case 2 of s" +NAN" nan$ endof -2 of s" -NAN" nan$ endof 6 of s" +INF" endof -6 of s" -INF" endof s" BADFLT" rot endcase 2r> #fchars max over swap blank swap cmove fdrop 0 sgn @ false end 2r> \ REPRESENT 2dup #fchars max [char] 0 fill #fdigits min ( a n ) 2>r cw@ rm ! set-near 0 ex ! normalize r@ 0 max 0 ?do ften f* loop ( scale to integer) sgn @ if fnegate then rm @ cw! fround ( with sign) fabs fdup <# set-near begin ften f/ fdup floor fswap fover f- ften f* fround f>d d>s [char] 0 + hold fdup f0= until fdrop 0 0 #> rm @ cw! dup r@ - ex +! 2r> rot min 1 max cmove f0= if ( 0.0E fix-up) 1 sgn @ signed-zero @ 0<> and else ex @ sgn @ then true ; \ PRECISION SET-PRECISION #fdigits value PRECISION ( -- n ) : SET-PRECISION ( n -- ) 1 max #fdigits min to precision ; \ Patch floating point defer fpinit ( -- ) system : fident ( -- ) cr ." 80387 15-digit floating point (common stack)" ; application ' fpinit sys-vec #10 + @ ! \ INIT patch ' fident sys-vec #12 + @ ! \ IDENTIFY patch ' fnumber sys-vec #14 + @ ! \ FNUMBER patch 0 sys-vec #16 + ! \ fp-stack size 0 sys-vec #20 + ! \ fp-stack min \\ Environment strings also environment definitions system -? aka true FLOATING -? aka true FLOATING-EXT : FLOATING-STACK [ sys-vec #16 + ] literal @ [ 1 floats ] literal / ; aka rmax MAX-FLOAT aka #fdigits MAX-FLOAT-DIGITS ( not ANS ) \ aka #fchars REPRESENT-CHARS ( not ANS ) previous definitions application \ Output functions include FPOUT.F :noname ( -- ) finit #fdigits set-precision fdp on ; is fpinit \ Stack display system -? : .S ( ? -- ? ) .s fdepth ?dup if 0 do i' i - 1- fpick fs. loop ." and 0= abort" requires 80387+ FPU" ( cw@ $FCFF and $0100 or cw! ) ; \ FLOATS FLOAT+ FALIGN FALIGNED FDEPTH code FLOATS ( x1 -- x2 ) ax pop ax shl ax shl ax shl ax push next end-code code FLOAT+ ( f-addr1 -- f-addr2 ) ax pop 1 floats # ax add ax push next end-code aka noop FALIGN ( -- ) immediate aka noop FALIGNED ( addr -- f-addr ) immediate : FDEPTH ( -- +n ) fs0 @ fsp @ - [ 1 floats ] literal / ; \ \ Setup a temp f/p stack while loading 6 5 + floats sys-vec #16 + ! \ fp-stack size 6 floats sys-vec #20 + ! \ fp-stack min s0 @ 256 - dup :noname fs0 ! fsp ! ; execute \ F@ F! FDROP code F@ ( addr -- r ) bx pop addr fsp ) sp xchg 6 [bx] push 4 [bx] push 2 [bx] push 0 [bx] push addr fsp ) sp xchg next end-code code F! ( r addr -- ) bx pop addr fsp ) sp xchg 0 [bx] pop 2 [bx] pop 4 [bx] pop 6 [bx] pop addr fsp ) sp xchg next end-code code FDROP ( r -- ) 1 floats # addr fsp ) add next end-code \ F, FLITERAL FCONSTANT FVARIABLE code flit si push 1 floats # si add ' f@ ) jmp end-code system : F, ( r -- ) here [ 1 floats ] literal allot f! ; : FLITERAL postpone flit f, ; immediate : FCONSTANT ['] f@ build f, ; : FVARIABLE create [ 1 floats ] literal allot ; application \ FDUP FSWAP code FDUP ( r -- r r ) addr fsp ) sp xchg sp di mov 6 [di] push 4 [di] push 2 [di] push 0 [di] push addr fsp ) sp xchg next end-code code FSWAP ( r1 r2 -- r2 r1 ) addr fsp ) di mov qword 0 [di] fld qword 8 [di] fld qword 0 [di] fstp wait qword 8 [di] fstp wait next end-code \ FOVER FROT code FOVER ( r1 r2 -- r1 r2 r1 ) addr fsp ) sp xchg sp di mov 0E [di] push 0C [di] push 0A [di] push 08 [di] push addr fsp ) sp xchg next end-code code FROT ( r1 r2 r3 -- r2 r3 r1 ) addr fsp ) di mov qword 0 [di] fld qword 8 [di] fld qword 10 [di] fld qword 0 [di] fstp wait qword 10 [di] fstp wait qword 8 [di] fstp wait next end-code \ FPICK F2DUP FTUCK FNIP code FPICK ( rn..r0 n -- rn..r0 rn ) di pop 1 floats # ax mov di mul ax di mov addr fsp ) bp xchg qword 0 [di+bp] fld 1 floats # bp sub qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code : F2DUP ( r1 r2 -- r1 r2 r1 r2 ) fover fover ; : FTUCK ( r1 r2 -- r2 r1 r2 ) fswap fover ; : FNIP ( r1 r2 -- r2 ) fswap fdrop ; \ F+ F- code F+ ( r1 r2 -- r3 ) addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fadd qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code code F- ( r1 r2 -- r3 ) addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fsubr qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code \ F* F/ code F* ( r1 r2 -- r3 ) addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fmul qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code code F/ ( r1 r2 -- r3 ) addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fdivr qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code \ FSQRT FNEGATE FABS code FSQRT ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld fsqrt qword 0 [di] fstp wait next end-code code FNEGATE ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld fchs qword 0 [di] fstp wait next end-code code FABS ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld fabs qword 0 [di] fstp wait next end-code \ F0> F0< F0= label ztst addr fsp ) di mov qword 0 [di] fld ftst ax fstsw st(0) fstp 1 floats # addr fsp ) add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F0> ( r -- flag ) 00 # cl mov ztst ju end-code code F0< ( r -- flag ) 01 # cl mov ztst ju end-code code F0= ( r -- flag ) 40 # cl mov ztst ju end-code \ F< F> F= label tst addr fsp ) di mov qword 1 floats [di] fld qword 0 [di] fld fcompp ax fstsw st(0) fstp 2 floats # addr fsp ) add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F< ( r1 r2 -- flag ) 00 # cl mov tst ju end-code code F> ( r1 r2 -- flag ) 01 # cl mov tst ju end-code code F= ( r1 r2 -- flag ) 40 # cl mov tst ju end-code \\ F0<> F<> F<= F>= : F0<> ( r -- flag ) f0= 0= ; : F<> ( r -- flag ) f= 0= ; : F<= ( r1 r2 -- flag ) f> 0= ; : F>= ( r1 r2 -- flag ) f< 0= ; \ FMAX FMIN : FMAX ( r1 r2 -- r-max ) fover fover f< if fswap then fdrop ; : FMIN ( r1 r2 -- r-min ) fover fover f> if fswap then fdrop ; \ FROUND code FROUND ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld frndint qword 0 [di] fstp wait next end-code label frnd 4 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 2 [bp] mov 2 [bp] fldcw addr fsp ) bx mov qword 0 [bx] fld frndint qword 0 [bx] fstp wait 0 [bp] fldcw 4 # bp add ret end-code \ FNEAR FLOOR FCEIL FTRUNC code FNEAR ( r1 -- r2 ) 00 # al mov frnd ) call next end-code code FLOOR ( r1 -- r2 ) 04 # al mov frnd ) call next end-code code FCEIL ( r1 -- r2 ) 08 # al mov frnd ) call next end-code code FTRUNC ( r1 -- r2 ) 0C # al mov frnd ) call next end-code \ SET-NEAR/FLOOR/CEIL/TRUNC label setr 2 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 0 [bp] mov 0 [bp] fldcw 2 # bp add next end-code code SET-NEAR ( -- ) 00 # al mov setr ju end-code code SET-FLOOR ( -- ) 04 # al mov setr ju end-code code SET-CEIL ( -- ) 08 # al mov setr ju end-code code SET-TRUNC ( -- ) 0C # al mov setr ju end-code \ FMOD FREM code FMOD ( r1 r2 -- r3 ) \ modulus addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fld fprem qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code code FREM ( r1 r2 -- r3 ) \ IEEE remainder addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fld fprem1 qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code \ FLN FLOG code FLN ( r1 -- r2 ) addr fsp ) bx mov qword 0 [bx] fld fldln2 st(1) fxch fyl2x qword 0 [bx] fstp wait next end-code code FLOG ( r1 -- r2 ) addr fsp ) bx mov qword 0 [bx] fld fldlg2 st(1) fxch fyl2x qword 0 [bx] fstp wait next end-code \ FEXP FALOG F** label power addr fsp ) bx mov qword 0 [bx] fld 1 floats # bp sub st(1) fmulp st(0) fld 0 [bp] fstcw wait 0 [bp] push 0F3FF # 0 [bp] and 0400 # 0 [bp] or 0 [bp] fldcw frndint 0 [bp] pop 0 [bp] fldcw st(0) fld qword 0 [bp] fstp st(1) fsubp fld1 fchs st(1) fxch fscale st(1) fstp f2xm1 fld1 st(1) faddp st(0) st fmul qword 0 [bp] fld st(1) fxch fscale st(1) fstp 1 floats # bp add qword 0 [bx] fstp wait next end-code \ FEXP FALOG F** code FEXP ( r1 -- r2 ) fldl2e power ju end-code code FALOG ( r1 -- r2 ) fldl2t power ju end-code : F** ( r1 r2 -- r3 ) fswap fln f* fexp ; \ D>F F>D code D>F ( d -- r ) dx pop ax pop 1 floats # addr fsp ) sub addr fsp ) di mov dx 2 [di] mov ax 0 [di] mov dword 0 [di] fild qword 0 [di] fstp wait next end-code code F>D ( r -- d ) 0C # al mov frnd ) call addr fsp ) di mov qword 0 [di] fld dword 0 [di] fistp wait 1 floats # addr fsp ) add 0 [di] push 2 [di] push next end-code \ S>F F>S code S>F ( n -- r ) ax pop 1 floats # addr fsp ) sub addr fsp ) di mov ax 0 [di] mov word 0 [di] fild qword 0 [di] fstp wait next end-code code F>S ( r -- n ) 0C # al mov frnd ) call addr fsp ) di mov qword 0 [di] fld dword 0 [di] fistp wait 1 floats # addr fsp ) add 0 [di] push next end-code \ SF@ SF! code SF@ ( addr -- r ) di pop dword 0 [di] fld 1 floats # addr fsp ) sub addr fsp ) di mov qword 0 [di] fstp wait next end-code code SF! ( r addr -- ) bx pop addr fsp ) di mov qword 0 [di] fld 1 floats # addr fsp ) add dword 0 [bx] fstp wait next end-code \ DF@ DF! aka F@ DF@ ( addr -- r ) aka F! DF! ( r addr -- ) \ FSIN FCOS FTAN code FSIN ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld fsin qword 0 [di] fstp wait next end-code code FCOS ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld fcos qword 0 [di] fstp wait next end-code code FTAN ( r1 -- r2 ) addr fsp ) di mov qword 0 [di] fld fptan st(0) fstp qword 0 [di] fstp wait next end-code \ FATAN2 FATAN code FATAN2 ( r1 r2 -- r3 ) addr fsp ) bp xchg qword 0 [bp] fld 1 floats # bp add qword 0 [bp] fld st(1) fxch fpatan qword 0 [bp] fstp wait addr fsp ) bp xchg next end-code \ : FATAN ( r1 -- r2 ) [ 1. d>f ] fliteral fatan2 ; \\ F~ : F~ ( r1 r2 r3 -- flag ) fdup f0= if fdrop fdup fsign >r fover fsign >r f= 2r> xor 0= and else fdup f0< if fabs frot frot fover fover f- fabs frot fabs frot fabs f+ frot f* f< else frot frot f- fabs f> then then ; \ rmax PI INF NAN 7FEF FFFF FFFF FFFF sp@ f@ 2drop 2drop fconstant rmax 4009 21FB 5444 2D18 sp@ f@ 2drop 2drop fconstant PI 7FF0 0000 0000 0000 sp@ f@ 2drop 2drop fconstant +INF FFF0 0000 0000 0000 sp@ f@ 2drop 2drop fconstant -INF 7FF8 0000 0000 0000 sp@ f@ 2drop 2drop fconstant +NAN FFF8 0000 0000 0000 sp@ f@ 2drop 2drop fconstant -NAN decimal \ FSIGNBIT SIGNED-ZERO FSIGN \ test sign using IEEE sign bit code FSIGNBIT ( r -- sign ) addr fsp ) di mov qword 0 [di] fld 1 floats # addr fsp ) add fxam ax fstsw st(0) fstp bx bx sub $02 # ah test ( sign ) 1 $ jz bx dec 1 $: bx push next end-code \ signed-zero control variable SIGNED-ZERO signed-zero off \ test sign according to current mode : FSIGN ( r -- sign ) fdup f0= >r fsignbit r> if signed-zero @ 0<> and then ; \ FCLASS FP-NAN/NORMAL/INFINITE/ZERO/SUBNORMAL \ 1=Unsupp 2=NAN 5=norm 6=INF 65=zero 66=Empty 69=denorm code FCLASS ( r -- x ) addr fsp ) di mov qword 0 [di] fld fxam ax fstsw st(0) fstp $45 # ah and $04 # ah cmp 1 $ jnz $0FFE # 1 floats 2- [di] test 1 $ jnz $40 # ah or 1 $: ah inc ( make non-zero) bx bx sub ah bl mov 1 floats # addr fsp ) add bx push next end-code 2 constant FP-NAN 5 constant FP-NORMAL 6 constant FP-INFINITE 65 constant FP-ZERO 69 constant FP-SUBNORMAL \ nan? illegal? \ test for non-number : nan? ( r -- +n|0 ) fclass fp-normal of 0 end fp-subnormal of 0 end fp-zero of 0 end ; \ test illegal number : illegal? ( r -- x|0 ) fdup nan? >r \ non-finite fabs rmax f> \ out of range r> or ; \ >FLOAT : getc ( a u -- a' u' c ) 1 /string over 1- c@ ; \ get sign : gets ( a u -- a' u' n|0 ) dup if getc dup [char] - = if end [char] + <> /string then 0 ; \ >FLOAT variable exp \ exponent variable dpf \ decimal point fvariable tmp 10 0 d>f fconstant ften : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 9 u> if drop -1 /string end 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat ; \\ >FLOAT : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 10 u< while 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat drop -1 /string then ; \ >FLOAT : getmant ( a u -- a' u' flag ) tuck getdigs dup if over c@ [char] . = if -1 dpf ! 1 /string getdigs then then rot over - dpf @ + ; \ >FLOAT : getexp ( a u -- a' u' ) dup if over c@ 33 or [char] e = ( 'D' 'E' 'd' 'e') 1 and /string then gets >r 0 0 2swap >number 2swap d>s r> if negate then exp @ + begin ?dup while dup 0< if 1+ tmp f@ ften f/ else 1- tmp f@ ften f* then tmp f! repeat ; \ >FLOAT : fpin ( c-addr u -- r -1 | 0 ) cw@ >r set-near [ 0. d>f ] fliteral tmp f! exp off dpf off 2dup -trailing nip 0<> and dup if gets >r getmant if getexp dup while then 2drop 2r> drop cw! 0 end else 0 >r then 2drop tmp f@ r> if fnegate then fdup illegal? if fdrop 0 else -1 then r> cw! ; \ >FLOAT : >FLOAT ( c-addr u -- r -1 | 0 | nan/inf 1 ) 2dup gets >r 2dup s" NAN" caps compare if 2dup s" INF" caps compare if 2dup s" INFINITY" caps compare if 2drop r> drop fpin end then 2drop 2drop +inf else 2drop 2drop +nan then r> if fnegate then 1 ; \\ fnumber system \ standard behaviour : fnumber ( c-addr u -- [r] flag ) dup 1 > if ( at least 2 chars ) over dup c@ [char] . < - ( skip sign) c@ [char] . > >r ( 1st char can't be .) 2dup s" E" caps search >r 2drop 2r> and base @ #10 = and 0= while then 2drop 0 else >float then dup >r state @ and if postpone fliteral then r> ; application \ fnumber system \ allow leading decimal point : fnumber ( c-addr u -- [r] flag ) 2dup s" E" caps search -rot 2drop base @ #10 = and if >float else 2drop 0 then dup >r state @ and if postpone fliteral then r> ; application \ REPRESENT #15 constant #fdigits \ maximum usable precision aka #fdigits #fchars \ maximum float characters variable rm \ rounding mode variable ex \ exponent variable sgn \ sign \ REPRESENT \ build NAN string - don't exceed buffer! [defined] nanload [if] : nan$ ( r c-addr1 u1 -- r c-addr2 u2 ) ftmp 0 +string 2>r fdup nanload 0 <# 2dup or if [char] ) hold #s [char] ( hold then #> 2r> +string ; [else] aka noop nan$ immediate [then] \ REPRESENT \ normalize to 0.1 <= r < 1.0 : normalize ( r1 -- r2 ) fabs fdup f0= 0= if begin fdup [ 1. d>f ] fliteral f< 0= while ften f/ 1 ex +! repeat begin fdup [ 1. d>f ften f/ ] fliteral f< while ften f* -1 ex +! repeat then ; \ REPRESENT : REPRESENT ( r c-addr n1 -- n2 flag1 flag2 ) 2>r fdup fsignbit sgn ! fdup nan? ?dup if ( not a number) sgn @ if negate then case 2 of s" +NAN" nan$ endof -2 of s" -NAN" nan$ endof 6 of s" +INF" endof -6 of s" -INF" endof s" BADFLT" rot endcase 2r> #fchars max over swap blank swap cmove fdrop 0 sgn @ false end 2r> \ REPRESENT 2dup #fchars max [char] 0 fill #fdigits min ( a n ) 2>r cw@ rm ! set-near 0 ex ! normalize r@ 0 max 0 ?do ften f* loop ( scale to integer) sgn @ if fnegate then rm @ cw! fround ( with sign) fabs fdup <# set-near begin ften f/ fdup floor fswap fover f- ften f* fround f>d d>s [char] 0 + hold fdup f0= until fdrop 0 0 #> rm @ cw! dup r@ - ex +! 2r> rot min 1 max cmove f0= if ( 0.0E fix-up) 1 sgn @ signed-zero @ 0<> and else ex @ sgn @ then true ; \ PRECISION SET-PRECISION #fdigits value PRECISION ( -- n ) : SET-PRECISION ( n -- ) 1 max #fdigits min to precision ; \ Patch floating point defer fpinit ( -- ) system : fident ( -- ) cr ." 80387 15-digit floating point (separate stack)" ; application ' fpinit sys-vec #10 + @ ! \ INIT patch ' fident sys-vec #12 + @ ! \ IDENTIFY patch ' fnumber sys-vec #14 + @ ! \ FNUMBER patch 6 5 + floats sys-vec #16 + ! \ fp-stack size 6 floats sys-vec #20 + ! \ fp-stack min \\ Environment strings also environment definitions system -? aka true FLOATING -? aka true FLOATING-EXT : FLOATING-STACK [ sys-vec #16 + ] literal @ [ 1 floats ] literal / ; aka rmax MAX-FLOAT aka #fdigits MAX-FLOAT-DIGITS ( not ANS ) \ aka #fchars REPRESENT-CHARS ( not ANS ) previous definitions application \ Output functions include FPOUT.F :noname ( -- ) finit #fdigits set-precision fdp on ; is fpinit \ Stack display system -? : .S ( ? -- ? ) .s fdepth ?dup if 0 do i' i - 1- fpick fs. loop ." and 0= abort" requires 80387+ FPU" ( cw@ $FCFF and $0000 or cw! ) ; \ FLOATS FLOAT+ FALIGN FALIGNED FDEPTH code FLOATS ( x1 -- x2 ) ax pop ax shl ax shl ax push next end-code code FLOAT+ ( f-addr1 -- f-addr2 ) ax pop 1 floats # ax add ax push next end-code aka noop FALIGN ( -- ) immediate aka noop FALIGNED ( addr -- f-addr ) immediate : FDEPTH ( -- +n ) depth [ 1 floats 2/ ] literal / ; \ F@ F! FDROP aka 2@ F@ ( addr -- r ) aka 2! F! ( r addr -- ) aka 2drop FDROP ( r -- ) \ F, FLITERAL FCONSTANT FVARIABLE code flit si push 1 floats # si add ' f@ ) jmp end-code system : F, ( r -- ) here [ 1 floats ] literal allot f! ; : FLITERAL postpone flit f, ; immediate : FCONSTANT ['] f@ build f, ; : FVARIABLE create [ 1 floats ] literal allot ; application \ FDUP FSWAP aka 2dup FDUP ( r -- r r ) aka 2swap FSWAP ( r1 r2 -- r2 r1 ) \ FOVER FROT aka 2over FOVER ( r1 r2 -- r1 r2 r1 ) aka 2rot FROT ( r1 r2 r3 -- r2 r3 r1 ) \ FPICK F2DUP FTUCK FNIP code FPICK ( rn..r0 n -- rn..r0 rn ) di pop 1 floats # ax mov di mul ax di mov sp bp xchg dword 0 [di+bp] fld 1 floats # bp sub dword 0 [bp] fstp wait sp bp xchg next end-code : F2DUP ( r1 r2 -- r1 r2 r1 r2 ) fover fover ; : FTUCK ( r1 r2 -- r2 r1 r2 ) fswap fover ; : FNIP ( r1 r2 -- r2 ) fswap fdrop ; \ F+ F- code F+ ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fadd dword 0 [bp] fstp wait sp bp xchg next end-code code F- ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fsubr dword 0 [bp] fstp wait sp bp xchg next end-code \ F* F/ code F* ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fmul dword 0 [bp] fstp wait sp bp xchg next end-code code F/ ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fdivr dword 0 [bp] fstp wait sp bp xchg next end-code \ FSQRT FNEGATE FABS code FSQRT ( r1 -- r2 ) sp di mov dword 0 [di] fld fsqrt dword 0 [di] fstp wait next end-code code FNEGATE ( r1 -- r2 ) sp di mov dword 0 [di] fld fchs dword 0 [di] fstp wait next end-code code FABS ( r1 -- r2 ) sp di mov dword 0 [di] fld fabs dword 0 [di] fstp wait next end-code \ F0> F0< F0= label ztst sp di mov dword 0 [di] fld ftst ax fstsw st(0) fstp 1 floats # sp add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F0> ( r -- flag ) 00 # cl mov ztst ju end-code code F0< ( r -- flag ) 01 # cl mov ztst ju end-code code F0= ( r -- flag ) 40 # cl mov ztst ju end-code \ F< F> F= label tst sp di mov dword 1 floats [di] fld dword 0 [di] fld fcompp ax fstsw st(0) fstp 2 floats # sp add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F< ( r1 r2 -- flag ) 00 # cl mov tst ju end-code code F> ( r1 r2 -- flag ) 01 # cl mov tst ju end-code code F= ( r1 r2 -- flag ) 40 # cl mov tst ju end-code \\ F0<> F<> F<= F>= : F0<> ( r -- flag ) f0= 0= ; : F<> ( r -- flag ) f= 0= ; : F<= ( r1 r2 -- flag ) f> 0= ; : F>= ( r1 r2 -- flag ) f< 0= ; \ FMAX FMIN : FMAX ( r1 r2 -- r-max ) fover fover f< if fswap then fdrop ; : FMIN ( r1 r2 -- r-min ) fover fover f> if fswap then fdrop ; \ FROUND code FROUND ( r1 -- r2 ) sp di mov dword 0 [di] fld frndint dword 0 [di] fstp wait next end-code label frnd 4 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 2 [bp] mov 2 [bp] fldcw sp bx mov dword 2 [bx] fld frndint dword 2 [bx] fstp wait 0 [bp] fldcw 4 # bp add ret end-code \ FNEAR FLOOR FCEIL FTRUNC code FNEAR ( r1 -- r2 ) 00 # al mov frnd ) call next end-code code FLOOR ( r1 -- r2 ) 04 # al mov frnd ) call next end-code code FCEIL ( r1 -- r2 ) 08 # al mov frnd ) call next end-code code FTRUNC ( r1 -- r2 ) 0C # al mov frnd ) call next end-code \ SET-NEAR/FLOOR/CEIL/TRUNC label setr 2 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 0 [bp] mov 0 [bp] fldcw 2 # bp add next end-code code SET-NEAR ( -- ) 00 # al mov setr ju end-code code SET-FLOOR ( -- ) 04 # al mov setr ju end-code code SET-CEIL ( -- ) 08 # al mov setr ju end-code code SET-TRUNC ( -- ) 0C # al mov setr ju end-code \ FMOD FREM code FMOD ( r1 r2 -- r3 ) \ modulus sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fld fprem dword 0 [bp] fstp wait sp bp xchg next end-code code FREM ( r1 r2 -- r3 ) \ IEEE remainder sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fld fprem1 dword 0 [bp] fstp wait sp bp xchg next end-code \ FLN FLOG code FLN ( r1 -- r2 ) sp bx mov dword 0 [bx] fld fldln2 st(1) fxch fyl2x dword 0 [bx] fstp wait next end-code code FLOG ( r1 -- r2 ) sp bx mov dword 0 [bx] fld fldlg2 st(1) fxch fyl2x dword 0 [bx] fstp wait next end-code \ FEXP FALOG F** label power sp bx mov dword 0 [bx] fld 1 floats # bp sub st(1) fmulp st(0) fld 0 [bp] fstcw wait 0 [bp] push 0F3FF # 0 [bp] and 0400 # 0 [bp] or 0 [bp] fldcw frndint 0 [bp] pop 0 [bp] fldcw st(0) fld dword 0 [bp] fstp st(1) fsubp fld1 fchs st(1) fxch fscale st(1) fstp f2xm1 fld1 st(1) faddp st(0) st fmul dword 0 [bp] fld st(1) fxch fscale st(1) fstp 1 floats # bp add dword 0 [bx] fstp wait next end-code \ FEXP FALOG F** code FEXP ( r1 -- r2 ) fldl2e power ju end-code code FALOG ( r1 -- r2 ) fldl2t power ju end-code : F** ( r1 r2 -- r3 ) fswap fln f* fexp ; \ D>F F>D code D>F ( d -- r ) dx pop ax pop 1 floats # sp sub sp di mov dx 2 [di] mov ax 0 [di] mov dword 0 [di] fild dword 0 [di] fstp wait next end-code code F>D ( r -- d ) 0C # al mov frnd ) call sp di mov dword 0 [di] fld dword 0 [di] fistp wait ' swap ) jmp end-code \ S>F F>S code S>F ( n -- r ) ax pop 1 floats # sp sub sp di mov ax 0 [di] mov word 0 [di] fild dword 0 [di] fstp wait next end-code code F>S ( r -- n ) 0C # al mov frnd ) call sp di mov dword 0 [di] fld dword 0 [di] fistp wait ' nip ) jmp end-code \ SF@ SF! aka F@ SF@ ( addr -- r ) aka F! SF! ( r addr -- ) \ DF@ DF! code DF@ ( addr -- r ) di pop qword 0 [di] fld 1 floats # sp sub sp di mov dword 0 [di] fstp wait next end-code code DF! ( r addr -- ) bx pop sp di mov dword 0 [di] fld 1 floats # sp add qword 0 [bx] fstp wait next end-code \ FSIN FCOS FTAN code FSIN ( r1 -- r2 ) sp di mov dword 0 [di] fld fsin dword 0 [di] fstp wait next end-code code FCOS ( r1 -- r2 ) sp di mov dword 0 [di] fld fcos dword 0 [di] fstp wait next end-code code FTAN ( r1 -- r2 ) sp di mov dword 0 [di] fld fptan st(0) fstp dword 0 [di] fstp wait next end-code \ FATAN2 FATAN code FATAN2 ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fld st(1) fxch fpatan dword 0 [bp] fstp wait sp bp xchg next end-code \ : FATAN ( r1 -- r2 ) [ 1. d>f ] fliteral fatan2 ; \\ F~ : F~ ( r1 r2 r3 -- flag ) fdup f0= if fdrop fdup fsign >r fover fsign >r f= 2r> xor 0= and else fdup f0< if fabs frot frot fover fover f- fabs frot fabs frot fabs f+ frot f* f< else frot frot f- fabs f> then then ; \ rmax PI INF NAN 7EFF FFFF fconstant rmax 4049 0FDB fconstant PI 7F80 0000 fconstant +INF FF80 0000 fconstant -INF 7FC0 0000 fconstant +NAN FFC0 0000 fconstant -NAN decimal \ FSIGNBIT SIGNED-ZERO FSIGN \ test sign using IEEE sign bit code FSIGNBIT ( r -- sign ) sp di mov dword 0 [di] fld 1 floats # sp add fxam ax fstsw st(0) fstp bx bx sub $02 # ah test ( sign ) 1 $ jz bx dec 1 $: bx push next end-code \ signed-zero control variable SIGNED-ZERO signed-zero off \ test sign according to current mode : FSIGN ( r -- sign ) fdup f0= >r fsignbit r> if signed-zero @ 0<> and then ; \ FCLASS FP-NAN/NORMAL/INFINITE/ZERO/SUBNORMAL \ 1=Unsupp 2=NAN 5=norm 6=INF 65=zero 66=Empty 69=denorm code FCLASS ( r -- x ) sp di mov dword 0 [di] fld fxam ax fstsw st(0) fstp $45 # ah and $04 # ah cmp 1 $ jnz $01FE # 1 floats 2- [di] test 1 $ jnz $40 # ah or 1 $: ah inc ( make non-zero) bx bx sub ah bl mov 1 floats # sp add bx push next end-code 2 constant FP-NAN 5 constant FP-NORMAL 6 constant FP-INFINITE 65 constant FP-ZERO 69 constant FP-SUBNORMAL \ nan? illegal? \ test for non-number : nan? ( r -- +n|0 ) fclass fp-normal of 0 end fp-subnormal of 0 end fp-zero of 0 end ; \ test illegal number : illegal? ( r -- x|0 ) fdup nan? >r \ non-finite fabs rmax f> \ out of range r> or ; \ >FLOAT : getc ( a u -- a' u' c ) 1 /string over 1- c@ ; \ get sign : gets ( a u -- a' u' n|0 ) dup if getc dup [char] - = if end [char] + <> /string then 0 ; \ >FLOAT variable exp \ exponent variable dpf \ decimal point fvariable tmp 10 0 d>f fconstant ften : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 9 u> if drop -1 /string end 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat ; \\ >FLOAT : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 10 u< while 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat drop -1 /string then ; \ >FLOAT : getmant ( a u -- a' u' flag ) tuck getdigs dup if over c@ [char] . = if -1 dpf ! 1 /string getdigs then then rot over - dpf @ + ; \ >FLOAT : getexp ( a u -- a' u' ) dup if over c@ 33 or [char] e = ( 'D' 'E' 'd' 'e') 1 and /string then gets >r 0 0 2swap >number 2swap d>s r> if negate then exp @ + begin ?dup while dup 0< if 1+ tmp f@ ften f/ else 1- tmp f@ ften f* then tmp f! repeat ; \ >FLOAT : fpin ( c-addr u -- r -1 | 0 ) cw@ >r set-near [ 0. d>f ] fliteral tmp f! exp off dpf off 2dup -trailing nip 0<> and dup if gets >r getmant if getexp dup while then 2drop 2r> drop cw! 0 end else 0 >r then 2drop tmp f@ r> if fnegate then fdup illegal? if fdrop 0 else -1 then r> cw! ; \ >FLOAT : >FLOAT ( c-addr u -- r -1 | 0 | nan/inf 1 ) 2dup gets >r 2dup s" NAN" caps compare if 2dup s" INF" caps compare if 2dup s" INFINITY" caps compare if 2drop r> drop fpin end then 2drop 2drop +inf else 2drop 2drop +nan then r> if fnegate then 1 ; \\ fnumber system \ standard behaviour : fnumber ( c-addr u -- [r] flag ) dup 1 > if ( at least 2 chars ) over dup c@ [char] . < - ( skip sign) c@ [char] . > >r ( 1st char can't be .) 2dup s" E" caps search >r 2drop 2r> and base @ #10 = and 0= while then 2drop 0 else >float then dup >r state @ and if postpone fliteral then r> ; application \ fnumber system \ allow leading decimal point : fnumber ( c-addr u -- [r] flag ) 2dup s" E" caps search -rot 2drop base @ #10 = and if >float else 2drop 0 then dup >r state @ and if postpone fliteral then r> ; application \ REPRESENT #7 constant #fdigits \ maximum usable precision aka #fdigits #fchars \ maximum float characters variable rm \ rounding mode variable ex \ exponent variable sgn \ sign \ REPRESENT \ build NAN string - don't exceed buffer! [defined] nanload [if] : nan$ ( r c-addr1 u1 -- r c-addr2 u2 ) ftmp 0 +string 2>r fdup nanload 0 <# 2dup or if [char] ) hold #s [char] ( hold then #> 2r> +string ; [else] aka noop nan$ immediate [then] \ REPRESENT \ normalize to 0.1 <= r < 1.0 : normalize ( r1 -- r2 ) fabs fdup f0= 0= if begin fdup [ 1. d>f ] fliteral f< 0= while ften f/ 1 ex +! repeat begin fdup [ 1. d>f ften f/ ] fliteral f< while ften f* -1 ex +! repeat then ; \ REPRESENT : REPRESENT ( r c-addr n1 -- n2 flag1 flag2 ) 2>r fdup fsignbit sgn ! fdup nan? ?dup if ( not a number) sgn @ if negate then case 2 of s" +NAN" nan$ endof -2 of s" -NAN" nan$ endof 6 of s" +INF" endof -6 of s" -INF" endof s" BADFLT" rot endcase 2r> #fchars max over swap blank swap cmove fdrop 0 sgn @ false end 2r> \ REPRESENT 2dup #fchars max [char] 0 fill #fdigits min ( a n ) 2>r cw@ rm ! set-near 0 ex ! normalize r@ 0 max 0 ?do ften f* loop ( scale to integer) sgn @ if fnegate then rm @ cw! fround ( with sign) fabs fdup <# set-near begin ften f/ fdup floor fswap fover f- ften f* fround f>d d>s [char] 0 + hold fdup f0= until fdrop 0 0 #> rm @ cw! dup r@ - ex +! 2r> rot min 1 max cmove f0= if ( 0.0E fix-up) 1 sgn @ signed-zero @ 0<> and else ex @ sgn @ then true ; \ PRECISION SET-PRECISION #fdigits value PRECISION ( -- n ) : SET-PRECISION ( n -- ) 1 max #fdigits min to precision ; \ Patch floating point defer fpinit ( -- ) system : fident ( -- ) cr ." 80387 7-digit floating point (common stack)" ; application ' fpinit sys-vec #10 + @ ! \ INIT patch ' fident sys-vec #12 + @ ! \ IDENTIFY patch ' fnumber sys-vec #14 + @ ! \ FNUMBER patch 0 sys-vec #16 + ! \ fp-stack size 0 sys-vec #20 + ! \ fp-stack min \\ Environment strings also environment definitions system -? aka true FLOATING -? aka true FLOATING-EXT : FLOATING-STACK [ sys-vec #16 + ] literal @ [ 1 floats ] literal / ; aka rmax MAX-FLOAT aka #fdigits MAX-FLOAT-DIGITS ( not ANS ) \ aka #fchars REPRESENT-CHARS ( not ANS ) previous definitions application \ Output functions include FPOUT.F :noname ( -- ) finit #fdigits set-precision fdp on ; is fpinit \ Stack display system -? : .S ( ? -- ? ) .s fdepth ?dup if 0 do i' i - 1- fpick fs. loop ." and 0= abort" requires 80387+ FPU" ( cw@ $FCFF and $0300 or cw! ) ; \ FLOATS FLOAT+ FALIGN FALIGNED FDEPTH code FLOATS ( x1 -- x2 ) ax pop ax bx mov ax shl ax shl bx ax add ax shl ax push next end-code code FLOAT+ ( f-addr1 -- f-addr2 ) ax pop 1 floats # ax add ax push next end-code aka noop FALIGN ( -- ) immediate aka noop FALIGNED ( addr -- f-addr ) immediate : FDEPTH ( -- +n ) depth [ 1 floats 2/ ] literal / ; \ F@ F! FDROP code F@ ( addr -- r ) bx pop 8 [bx] push 6 [bx] push 4 [bx] push 2 [bx] push 0 [bx] push next end-code code F! ( r addr -- ) bx pop 0 [bx] pop 2 [bx] pop 4 [bx] pop 6 [bx] pop 8 [bx] pop next end-code code FDROP ( r -- ) 1 floats # sp add next end-code \ F, FLITERAL FCONSTANT FVARIABLE code flit si push 1 floats # si add ' f@ ) jmp end-code system : F, ( r -- ) here [ 1 floats ] literal allot f! ; : FLITERAL postpone flit f, ; immediate : FCONSTANT ['] f@ build f, ; : FVARIABLE create [ 1 floats ] literal allot ; application \ FDUP FSWAP code FDUP ( r -- r r ) sp di mov 8 [di] push 6 [di] push 4 [di] push 2 [di] push 0 [di] push next end-code code FSWAP ( r1 r2 -- r2 r1 ) sp di mov tbyte 0 [di] fld tbyte 0A [di] fld tbyte 0 [di] fstp wait tbyte 0A [di] fstp wait next end-code \ FOVER FROT code FOVER ( r1 r2 -- r1 r2 r1 ) sp di mov 12 [di] push 10 [di] push 0E [di] push 0C [di] push 0A [di] push next end-code code FROT ( r1 r2 r3 -- r2 r3 r1 ) sp di mov tbyte 0 [di] fld tbyte 0A [di] fld tbyte 14 [di] fld tbyte 0 [di] fstp wait tbyte 14 [di] fstp wait tbyte 0A [di] fstp wait next end-code \ FPICK F2DUP FTUCK FNIP code FPICK ( rn..r0 n -- rn..r0 rn ) di pop 1 floats # ax mov di mul ax di mov sp bp xchg tbyte 0 [di+bp] fld 1 floats # bp sub tbyte 0 [bp] fstp wait sp bp xchg next end-code : F2DUP ( r1 r2 -- r1 r2 r1 r2 ) fover fover ; : FTUCK ( r1 r2 -- r2 r1 r2 ) fswap fover ; : FNIP ( r1 r2 -- r2 ) fswap fdrop ; \ F+ F- code F+ ( r1 r2 -- r3 ) sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld st(1) faddp tbyte 0 [bp] fstp wait sp bp xchg next end-code code F- ( r1 r2 -- r3 ) sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld st(1) fsubrp tbyte 0 [bp] fstp wait sp bp xchg next end-code \ F* F/ code F* ( r1 r2 -- r3 ) sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld st(1) fmulp tbyte 0 [bp] fstp wait sp bp xchg next end-code code F/ ( r1 r2 -- r3 ) sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld st(1) fdivrp tbyte 0 [bp] fstp wait sp bp xchg next end-code \ FSQRT FNEGATE FABS code FSQRT ( r1 -- r2 ) sp di mov tbyte 0 [di] fld fsqrt tbyte 0 [di] fstp wait next end-code code FNEGATE ( r1 -- r2 ) sp di mov tbyte 0 [di] fld fchs tbyte 0 [di] fstp wait next end-code code FABS ( r1 -- r2 ) sp di mov tbyte 0 [di] fld fabs tbyte 0 [di] fstp wait next end-code \ F0> F0< F0= label ztst sp di mov tbyte 0 [di] fld ftst ax fstsw st(0) fstp 1 floats # sp add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F0> ( r -- flag ) 00 # cl mov ztst ju end-code code F0< ( r -- flag ) 01 # cl mov ztst ju end-code code F0= ( r -- flag ) 40 # cl mov ztst ju end-code \ F< F> F= label tst sp di mov tbyte 1 floats [di] fld tbyte 0 [di] fld fcompp ax fstsw st(0) fstp 2 floats # sp add 41 # ah and bx bx sub cl ah cmp 1 $ jnz bx dec 1 $: bx push next end-code code F< ( r1 r2 -- flag ) 00 # cl mov tst ju end-code code F> ( r1 r2 -- flag ) 01 # cl mov tst ju end-code code F= ( r1 r2 -- flag ) 40 # cl mov tst ju end-code \\ F0<> F<> F<= F>= : F0<> ( r -- flag ) f0= 0= ; : F<> ( r -- flag ) f= 0= ; : F<= ( r1 r2 -- flag ) f> 0= ; : F>= ( r1 r2 -- flag ) f< 0= ; \ FMAX FMIN : FMAX ( r1 r2 -- r-max ) fover fover f< if fswap then fdrop ; : FMIN ( r1 r2 -- r-min ) fover fover f> if fswap then fdrop ; \ FROUND code FROUND ( r1 -- r2 ) sp di mov tbyte 0 [di] fld frndint tbyte 0 [di] fstp wait next end-code label frnd 4 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 2 [bp] mov 2 [bp] fldcw sp bx mov tbyte 2 [bx] fld frndint tbyte 2 [bx] fstp wait 0 [bp] fldcw 4 # bp add ret end-code \ FNEAR FLOOR FCEIL FTRUNC code FNEAR ( r1 -- r2 ) 00 # al mov frnd ) call next end-code code FLOOR ( r1 -- r2 ) 04 # al mov frnd ) call next end-code code FCEIL ( r1 -- r2 ) 08 # al mov frnd ) call next end-code code FTRUNC ( r1 -- r2 ) 0C # al mov frnd ) call next end-code \ SET-NEAR/FLOOR/CEIL/TRUNC label setr 2 # bp sub 0 [bp] fstcw wait 0 [bp] bx mov 0F3FF # bx and al bh or bx 0 [bp] mov 0 [bp] fldcw 2 # bp add next end-code code SET-NEAR ( -- ) 00 # al mov setr ju end-code code SET-FLOOR ( -- ) 04 # al mov setr ju end-code code SET-CEIL ( -- ) 08 # al mov setr ju end-code code SET-TRUNC ( -- ) 0C # al mov setr ju end-code \ FMOD FREM code FMOD ( r1 r2 -- r3 ) \ modulus sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld fprem tbyte 0 [bp] fstp wait sp bp xchg next end-code code FREM ( r1 r2 -- r3 ) \ IEEE remainder sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld fprem1 tbyte 0 [bp] fstp wait sp bp xchg next end-code \ FLN FLOG code FLN ( r1 -- r2 ) sp bx mov tbyte 0 [bx] fld fldln2 st(1) fxch fyl2x tbyte 0 [bx] fstp wait next end-code code FLOG ( r1 -- r2 ) sp bx mov tbyte 0 [bx] fld fldlg2 st(1) fxch fyl2x tbyte 0 [bx] fstp wait next end-code \ FEXP FALOG F** label power sp bx mov tbyte 0 [bx] fld 1 floats # bp sub st(1) fmulp st(0) fld 0 [bp] fstcw wait 0 [bp] push 0F3FF # 0 [bp] and 0400 # 0 [bp] or 0 [bp] fldcw frndint 0 [bp] pop 0 [bp] fldcw st(0) fld tbyte 0 [bp] fstp st(1) fsubp fld1 fchs st(1) fxch fscale st(1) fstp f2xm1 fld1 st(1) faddp st(0) st fmul tbyte 0 [bp] fld st(1) fxch fscale st(1) fstp 1 floats # bp add tbyte 0 [bx] fstp wait next end-code \ FEXP FALOG F** code FEXP ( r1 -- r2 ) fldl2e power ju end-code code FALOG ( r1 -- r2 ) fldl2t power ju end-code : F** ( r1 r2 -- r3 ) fswap fln f* fexp ; \ D>F F>D code D>F ( d -- r ) dx pop ax pop 1 floats # sp sub sp di mov dx 2 [di] mov ax 0 [di] mov dword 0 [di] fild tbyte 0 [di] fstp wait next end-code code F>D ( r -- d ) 0C # al mov frnd ) call sp di mov tbyte 0 [di] fld dword 0 [di] fistp wait 1 floats # sp add 0 [di] push 2 [di] push next end-code \ S>F F>S code S>F ( n -- r ) ax pop 1 floats # sp sub sp di mov ax 0 [di] mov word 0 [di] fild tbyte 0 [di] fstp wait next end-code code F>S ( r -- n ) 0C # al mov frnd ) call sp di mov tbyte 0 [di] fld dword 0 [di] fistp wait 1 floats # sp add 0 [di] push next end-code \ SF@ SF! code SF@ ( addr -- r ) di pop dword 0 [di] fld 1 floats # sp sub sp di mov tbyte 0 [di] fstp wait next end-code code SF! ( r addr -- ) bx pop sp di mov tbyte 0 [di] fld 1 floats # sp add dword 0 [bx] fstp wait next end-code \ DF@ DF! code DF@ ( addr -- r ) di pop qword 0 [di] fld 1 floats # sp sub sp di mov tbyte 0 [di] fstp wait next end-code code DF! ( r addr -- ) bx pop sp di mov tbyte 0 [di] fld 1 floats # sp add qword 0 [bx] fstp wait next end-code \ FSIN FCOS FTAN code FSIN ( r1 -- r2 ) sp di mov tbyte 0 [di] fld fsin tbyte 0 [di] fstp wait next end-code code FCOS ( r1 -- r2 ) sp di mov tbyte 0 [di] fld fcos tbyte 0 [di] fstp wait next end-code code FTAN ( r1 -- r2 ) sp di mov tbyte 0 [di] fld fptan st(0) fstp tbyte 0 [di] fstp wait next end-code \ FATAN2 FATAN code FATAN2 ( r1 r2 -- r3 ) sp bp xchg tbyte 0 [bp] fld 1 floats # bp add tbyte 0 [bp] fld st(1) fxch fpatan tbyte 0 [bp] fstp wait sp bp xchg next end-code \ : FATAN ( r1 -- r2 ) [ 1. d>f ] fliteral fatan2 ; \\ F~ : F~ ( r1 r2 r3 -- flag ) fdup f0= if fdrop fdup fsign >r fover fsign >r f= 2r> xor 0= and else fdup f0< if fabs frot frot fover fover f- fabs frot fabs frot fabs f+ frot f* f< else frot frot f- fabs f> then then ; \ rmax PI INF NAN 7FFE FFFF FFFF FFFF FFFF fconstant rmax 4000 C90F DAA2 2168 C235 fconstant PI 7FFF 8000 0000 0000 0000 fconstant +INF FFFF 8000 0000 0000 0000 fconstant -INF 7FFF C000 0000 0000 0000 fconstant +NAN FFFF C000 0000 0000 0000 fconstant -NAN decimal \ FSIGNBIT SIGNED-ZERO FSIGN \ test sign using IEEE sign bit code FSIGNBIT ( r -- sign ) sp di mov tbyte 0 [di] fld 1 floats # sp add fxam ax fstsw st(0) fstp bx bx sub $02 # ah test ( sign ) 1 $ jz bx dec 1 $: bx push next end-code \ signed-zero control variable SIGNED-ZERO signed-zero off \ test sign according to current mode : FSIGN ( r -- sign ) fdup f0= >r fsignbit r> if signed-zero @ 0<> and then ; \ FCLASS FP-NAN/NORMAL/INFINITE/ZERO/SUBNORMAL \ 1=Unsupp 2=NAN 5=norm 6=INF 65=zero 66=Empty 69=denorm code FCLASS ( r -- x ) sp di mov tbyte 0 [di] fld fxam ax fstsw st(0) fstp $45 # ah and \ $04 # ah cmp 1 $ jnz \ $FFFE # 1 floats 2- [di] test 1 $ jnz $40 # ah or 1 $: ah inc ( make non-zero) bx bx sub ah bl mov 1 floats # sp add bx push next end-code 2 constant FP-NAN 5 constant FP-NORMAL 6 constant FP-INFINITE 65 constant FP-ZERO 69 constant FP-SUBNORMAL \ nan? illegal? \ test for non-number : nan? ( r -- +n|0 ) fclass fp-normal of 0 end fp-subnormal of 0 end fp-zero of 0 end ; \ test illegal number : illegal? ( r -- x|0 ) fdup nan? >r \ non-finite fabs rmax f> \ out of range r> or ; \ >FLOAT : getc ( a u -- a' u' c ) 1 /string over 1- c@ ; \ get sign : gets ( a u -- a' u' n|0 ) dup if getc dup [char] - = if end [char] + <> /string then 0 ; \ >FLOAT variable exp \ exponent variable dpf \ decimal point fvariable tmp 10 0 d>f fconstant ften : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 9 u> if drop -1 /string end 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat ; \\ >FLOAT : getdigs ( a u -- a' u' ) begin dup while getc [char] 0 - dup 10 u< while 0 d>f tmp f@ ften f* f+ tmp f! dpf @ exp +! repeat drop -1 /string then ; \ >FLOAT : getmant ( a u -- a' u' flag ) tuck getdigs dup if over c@ [char] . = if -1 dpf ! 1 /string getdigs then then rot over - dpf @ + ; \ >FLOAT : getexp ( a u -- a' u' ) dup if over c@ 33 or [char] e = ( 'D' 'E' 'd' 'e') 1 and /string then gets >r 0 0 2swap >number 2swap d>s r> if negate then exp @ + begin ?dup while dup 0< if 1+ tmp f@ ften f/ else 1- tmp f@ ften f* then tmp f! repeat ; \ >FLOAT : fpin ( c-addr u -- r -1 | 0 ) cw@ >r set-near [ 0. d>f ] fliteral tmp f! exp off dpf off 2dup -trailing nip 0<> and dup if gets >r getmant if getexp dup while then 2drop 2r> drop cw! 0 end else 0 >r then 2drop tmp f@ r> if fnegate then fdup illegal? if fdrop 0 else -1 then r> cw! ; \ >FLOAT : >FLOAT ( c-addr u -- r -1 | 0 | nan/inf 1 ) 2dup gets >r 2dup s" NAN" caps compare if 2dup s" INF" caps compare if 2dup s" INFINITY" caps compare if 2drop r> drop fpin end then 2drop 2drop +inf else 2drop 2drop +nan then r> if fnegate then 1 ; \\ fnumber system \ standard behaviour : fnumber ( c-addr u -- [r] flag ) dup 1 > if ( at least 2 chars ) over dup c@ [char] . < - ( skip sign) c@ [char] . > >r ( 1st char can't be .) 2dup s" E" caps search >r 2drop 2r> and base @ #10 = and 0= while then 2drop 0 else >float then dup >r state @ and if postpone fliteral then r> ; application \ fnumber system \ allow leading decimal point : fnumber ( c-addr u -- [r] flag ) 2dup s" E" caps search -rot 2drop base @ #10 = and if >float else 2drop 0 then dup >r state @ and if postpone fliteral then r> ; application \ REPRESENT #18 constant #fdigits \ maximum usable precision aka #fdigits #fchars \ maximum float characters variable rm \ rounding mode variable ex \ exponent variable sgn \ sign \ REPRESENT \ build NAN string - don't exceed buffer! [defined] nanload [if] : nan$ ( r c-addr1 u1 -- r c-addr2 u2 ) ftmp 0 +string 2>r fdup nanload 0 <# 2dup or if [char] ) hold #s [char] ( hold then #> 2r> +string ; [else] aka noop nan$ immediate [then] \ REPRESENT \ normalize to 0.1 <= r < 1.0 : normalize ( r1 -- r2 ) fabs fdup f0= 0= if begin fdup [ 1. d>f ] fliteral f< 0= while ften f/ 1 ex +! repeat begin fdup [ 1. d>f ften f/ ] fliteral f< while ften f* -1 ex +! repeat then ; \ REPRESENT : REPRESENT ( r c-addr n1 -- n2 flag1 flag2 ) 2>r fdup fsignbit sgn ! fdup nan? ?dup if ( not a number) sgn @ if negate then case 2 of s" +NAN" nan$ endof -2 of s" -NAN" nan$ endof 6 of s" +INF" endof -6 of s" -INF" endof s" BADFLT" rot endcase 2r> #fchars max over swap blank swap cmove fdrop 0 sgn @ false end 2r> \ REPRESENT 2dup #fchars max [char] 0 fill #fdigits min ( a n ) 2>r cw@ rm ! set-near 0 ex ! normalize r@ 0 max 0 ?do ften f* loop ( scale to integer) sgn @ if fnegate then rm @ cw! fround ( with sign) fabs fdup <# set-near begin ften f/ fdup floor fswap fover f- ften f* fround f>d d>s [char] 0 + hold fdup f0= until fdrop 0 0 #> rm @ cw! dup r@ - ex +! 2r> rot min 1 max cmove f0= if ( 0.0E fix-up) 1 sgn @ signed-zero @ 0<> and else ex @ sgn @ then true ; \ PRECISION SET-PRECISION #fdigits value PRECISION ( -- n ) : SET-PRECISION ( n -- ) 1 max #fdigits min to precision ; \ Patch floating point defer fpinit ( -- ) system : fident ( -- ) cr ." 80387 18-digit floating point (common stack)" ; application ' fpinit sys-vec #10 + @ ! \ INIT patch ' fident sys-vec #12 + @ ! \ IDENTIFY patch ' fnumber sys-vec #14 + @ ! \ FNUMBER patch 0 sys-vec #16 + ! \ fp-stack size 0 sys-vec #20 + ! \ fp-stack min \\ Environment strings also environment definitions system -? aka true FLOATING -? aka true FLOATING-EXT : FLOATING-STACK [ sys-vec #16 + ] literal @ [ 1 floats ] literal / ; aka rmax MAX-FLOAT aka #fdigits MAX-FLOAT-DIGITS ( not ANS ) \ aka #fchars REPRESENT-CHARS ( not ANS ) previous definitions application \ Output functions include FPOUT.F :noname ( -- ) finit #fdigits set-precision fdp on ; is fpinit \ Stack display system -? : .S ( ? -- ? ) .s fdepth ?dup if 0 do i' i - 1- fpick fs. loop ." \ GETARG FERROR BUFSIZE GET \ Get argument, if none show help and exit : GETARG ( n -- adr u ) ARGV 0= IF HELP ABORT THEN ; \ Display filename and exit : FERROR ( n -- ) ARGV IF TYPE THEN ABORT ; \ Buffer size - use max available memory, allow for stack etc : BUFSIZE ( -- u ) UNUSED 500 - ; \ Read u1 chars from input file, u2 = #chars actually read : GET ( u1 -- u2 ) PAD SWAP H1 @ READ-FILE ABORT" read error" ; --> \ PUT COPY-FILE \ Write u chars to output file : PUT ( u -- ) PAD SWAP H2 @ WRITE-FILE ABORT" write error: probably out of disk space" ; \ Copy loop : COPY-FILE ( -- ) BEGIN BUFSIZE GET ?DUP WHILE ( not end-of-file ) PUT REPEAT ; --> \ OPEN-FILES CLOSE-FILES MAIN \ Open source and destination files : OPEN-FILES ( -- ) 1 GETARG R/O OPEN-FILE \ open 1st IF ." can't open: " 1 FERROR THEN H1 ! \ save handle 2 GETARG R/W CREATE-FILE \ create 2nd IF ." can't create: " 2 FERROR THEN H2 ! ; \ save handle \ Close source and destination files : CLOSE-FILES ( -- ) H1 @ CLOSE-FILE DROP H2 @ CLOSE-FILE IF ." error closing: " 2 FERROR THEN ; : MAIN ( -- ) CR ." FCOPY" CR OPEN-FILES COPY-FILE CLOSE-FILES ." file copied" CR ; \ No newline at end of file diff --git a/DX-FORTH v430/FILES.TXT b/DX-FORTH v430/FILES.TXT new file mode 100644 index 0000000..2a96320 --- /dev/null +++ b/DX-FORTH v430/FILES.TXT @@ -0,0 +1,64 @@ +The following files are included in the DX-Forth distribution: + +Executables - + +FORTH.EXE DX-Forth compiler +FORTH-F.EXE DX-Forth compiler with floating point +DX.EXE FORTH-F.EXE with screen editor loaded +LISTING.BAT Make a formatted listing file from a screen file + +Documentation - + +WHATSNEW.TXT Summary of additions/changes/fixes +CHANGES.TXT Important changes information +DXFORTH.TXT DX-Forth documentation +DXFORTH.GLO DX-Forth glossary of non-standard words +DXFORTH.WDS DX-Forth kernel words +SED.TXT Screen file editor +TED.TXT Text file editor +ASM.TXT 8086/8087 assembler +F87.TXT 80387 floating point +OBSOLETE.TXT When old DX-Forth applications no longer compile... +MULTI.TXT Multitasker +FILES.TXT Files list + +System source - + +MAKEF.BAT Build DX-Forth binaries (needs Borland TASM) +MAKEF87.BAT Build 80387 floating point binaries +KERNEL.ASM MASM/TASM source for DX-Forth +EXTEND.SCR Extends kernel +TOOLS.SCR Resident extensions & utilities +ASM.SCR Forth 8086 assembler +ASM87.SCR 8087 assembler extensions +SED.SCR Screen file editor +TED.F Text file editor + +Misc source - + +ASMCOND.SCR Assembler structured conditionals +ASMTEST.SCR Test assembler +OBSOLETE.SCR Obsolete DX-Forth functions +MULTI.SCR Multitasker +F87D.SCR 80387 double-precision f/p +F87S.SCR 80387 single-precision f/p +F87X.SCR 80387 extended-precision f/p +F87DS.SCR 80387 double-precision f/p with separate stack +FPOUT.F Support for 80387 floating point +OVERLAY.SCR Overlay system +STRINGS.SCR Sample string package +FCOPY.SCR Sample filecopy utility +TXT2BLK.SCR Text to block conversion utility +BLK2TXT.SCR Block to text conversion utility +BREAKGO.SCR Debugging utility +MISC.SCR Miscellaneous function library +SHOW.SCR Print source files 6 screens per page +SSED.SCR Create stand-alone screen editor +NEWAPP.SCR Skeletal MS-DOS application +DOSLIB.SCR Function library and NEWAPP support +STKCHK.SCR Stack balance check utility +LFN.SCR Long filename support for Windows 95 +LOCALS.SCR ANS locals +HLOCALS.SCR Hayes locals extension +MISER.SCR Miser Case extensions & demo + diff --git a/DX-FORTH v430/FILE_ID.DIZ b/DX-FORTH v430/FILE_ID.DIZ new file mode 100644 index 0000000..efaba7d --- /dev/null +++ b/DX-FORTH v430/FILE_ID.DIZ @@ -0,0 +1,24 @@ +DX-Forth 4 - Forth compiler for MS-DOS +-------------------------------------- + +DX-Forth is a Forth language compiler and development system +for MS-DOS 2.x and compatible disk operating systems. It is +intended to be a complete, easy to use, programming tool for +the creation of DOS applications. + +Features include: + + - ANS FORTH Standard (FORTH-94) * + - Fast direct-threaded code + - Generate turnkey applications without compiler overhead + - Fast floating point and trigonometric functions + - Forth-94 file I/O + - DOSLIB application library + - Multitasking + - ANS locals + - Overlays for large applications + - 8086/87 Forth assembler for CODE words + - Full source code included + +* DX-FORTH 4 generally follows the FORTH-94 Standard but + does not seek to be strictly compliant. diff --git a/DX-FORTH v430/FORTH-F.EXE b/DX-FORTH v430/FORTH-F.EXE new file mode 100644 index 0000000..33fe74d Binary files /dev/null and b/DX-FORTH v430/FORTH-F.EXE differ diff --git a/DX-FORTH v430/FORTH.EXE b/DX-FORTH v430/FORTH.EXE new file mode 100644 index 0000000..5623394 Binary files /dev/null and b/DX-FORTH v430/FORTH.EXE differ diff --git a/DX-FORTH v430/FPOUT.F b/DX-FORTH v430/FPOUT.F new file mode 100644 index 0000000..75840f8 --- /dev/null +++ b/DX-FORTH v430/FPOUT.F @@ -0,0 +1,451 @@ +\ +\ FPOUT.F version 3.10 +\ +\ A Forth floating-point output words package +\ +\ Main words: +\ +\ Compact Formatted String +\ ------- --------- ------ +\ FS. FS.R (FS.) Scientific +\ FE. FE.R (FE.) Engineering +\ F. F.R (F.) Floating-point +\ G. G.R (G.) General +\ +\ FDP ( -- a-addr ) +\ +\ A variable controlling decimal point display. If the +\ contents are zero then trailing decimal points are +\ not shown. If non-zero (default) the decimal point is +\ displayed. +\ +\ FECHAR ( -- c-addr ) +\ +\ A character variable containing the output character +\ used to indicate the exponent. Default is 'E'. +\ +\ FEDIGITS ( -- a-addr ) +\ +\ A variable containing the minimum number of exponent +\ digits to display in formatted output mode. Default +\ value is 2, minimum is 1. Does not affect compact +\ output mode. +\ +\ MAX-PRECISION ( -- n ) +\ +\ A constant returning the implementation-defined +\ maximum precision. Equivalent to the value returned +\ by the environment-query string MAX-FLOAT-DIGITS. +\ +\ Notes: +\ +\ Output words which specify the number of places after +\ the decimal point may use the value -1 to force compact +\ mode. +\ +\ In compact mode non-essential zeros and signs are +\ removed and the number of significant digits output is +\ limited to MAX-PRECISION digits. FS. FE. F. G. operate +\ in compact mode. +\ +\ In formatted mode the number of decimal places output +\ is fixed and PRECISION has no effect. +\ +\ The character string returned by (FS.) (FE.) (F.) (G.) +\ resides in the pictured-numeric output area. +\ +\ An ambiguous condition exists if: BASE is not decimal; +\ character string exceeds pictured-numeric output area; +\ PRECISION returns a value less than one or greater +\ than MAX-FLOAT-DIGITS. +\ +\ For use with separate or common stack floating-point +\ Forth models. +\ +\ This code is PUBLIC DOMAIN. Use at your own risk. +\ +\ ***************************************************** +\ This version of FPOUT requires REPRESENT conform to +\ the specification proposed here: +\ +\ ftp://ftp.taygeta.com/pub/Forth/Applications/ANS/ +\ Represent_33.txt (2014-03-17) +\ +\ If your Forth does not have a compliant REPRESENT +\ then use FPOUT v2.2 instead. +\ ***************************************************** +\ +\ History: +\ +\ 3.1 2006-11-13 es Demo for REPRESENT proposal. +\ 3.2 2007-06-05 es Changed default to trailing +\ decimal point on. +\ 3.3 2007-11-19 es Add FECHAR FEDIGITS. Fix zero +\ sign in (F.) F.R +\ 3.4 2008-01-23 es Updated to REPRESENT spec 2.1 +\ 3.5 2010-12-05 es Updated to REPRESENT spec 3.0 +\ 3.6 2011-02-06 es Changed FECHAR storage from +\ cell to character. +\ 3.7 2011-02-16 es Renamed mp# to MAX-PRECISION. +\ Removed effect of PRECISION in +\ formatted mode. +\ 3.8 2011-05-25 es Fixed log(0) in (f1) +\ 3.9 2012-05-20 es Range check FEDIGITS PRECISION. +\ FEDIGITS minimum changed to 1. +\ 3.10 2014-06-06 es Factor out S.R SHOLD NHOLD. No +\ functional change. + +CR .( Loading FPOUT 3.10 2014-06-06 ... ) CR + +DECIMAL + +\ Useful tools which exist in some Forth systems albeit +\ under different names + +[UNDEFINED] DXFORTH [IF] + +\ type string right-justified +: S.R ( c-addr u width -- ) + OVER - SPACES TYPE ; + +\ HOLD string +: SHOLD ( c-addr u -- ) + BEGIN DUP WHILE 1- 2DUP CHARS + C@ HOLD + REPEAT 2DROP ; + +\ HOLD n characters +: NHOLD ( n char -- ) + SWAP 0 ?DO DUP HOLD LOOP DROP ; + +[THEN] + +\ Compile application + +CREATE FDP 2 CELLS ALLOT +CREATE FECHAR 1 CHARS ALLOT +VARIABLE FEDIGITS + +\ ****************** USER OPTIONS ******************* + +1 FDP ! \ trailing decimal point +2 FEDIGITS ! \ minimum exponent digits +CHAR E FECHAR C! \ output character for exponent + +\ ***************************************************** + +[DEFINED] DXFORTH [IF] #fdigits ( n) [ELSE] + +S" MAX-FLOAT-DIGITS" ENVIRONMENT? 0= [IF] + CR .( MAX-FLOAT-DIGITS not found ) ABORT +[THEN] ( n) + +[THEN] + +\ Maximum PRECISION +( n) CONSTANT MAX-PRECISION + +\ Define SET-PRECISION PRECISION if not present +[UNDEFINED] SET-PRECISION [IF] + +\ Return the number of significant digits currently used +\ by F. FE. FS. G. +MAX-PRECISION VALUE PRECISION + +\ Set the number of significant digits currently used by +\ F. FE. FS. G. +: SET-PRECISION ( +n -- ) + 1 MAX MAX-PRECISION MIN TO PRECISION ; + +[THEN] + +MAX-PRECISION SET-PRECISION \ set to maximum + +[DEFINED] DXFORTH [IF] MAX-PRECISION ( n) [ELSE] + +S" REPRESENT-CHARS" ENVIRONMENT? +0= [IF] MAX-PRECISION [THEN] ( n ) + +[THEN] + +( n ) CONSTANT mc# \ max chars output from REPRESENT + +CREATE fbuf mc# CHARS ALLOT + +0 VALUE ex# \ exponent +0 VALUE sn# \ sign +0 VALUE ef# \ exponent factor 1=FS. 3=FE. +0 VALUE pl# \ +n places right of decimal point + \ -1 compact display + +\ get exponent +: (f1) ( F: r -- r ) ( -- exp ) + FDUP [UNDEFINED] FLOG [IF] + fbuf MAX-PRECISION REPRESENT NIP AND + [ELSE] + F0= IF 1 ELSE FDUP + FABS FLOG FLOOR F>D D>S 1+ THEN + [THEN] ; + +\ apply exponent factor +: (f2) ( exp -- offset exp2 ) + S>D ef# FM/MOD ef# * ; + +\ float to character string +: (f3) ( F: r -- ) ( places -- c-addr u flag ) + DUP TO pl# 0< IF + PRECISION + ELSE + (f1) ef# 0> IF 1- (f2) DROP 1+ THEN pl# + + THEN MAX-PRECISION MIN fbuf SWAP REPRESENT >R + TO sn# TO ex# fbuf mc# -TRAILING R> <# ; + +\ insert exponent +: (f4) ( exp -- ) + DUP ABS S>D pl# 0< 0= DUP >R IF FEDIGITS @ + 1 MAX 1 ?DO # LOOP THEN #S 2DROP DUP SIGN 0< 0= + R> AND IF [CHAR] + HOLD THEN FECHAR C@ HOLD ; + +\ conditionally set flag +: (f5) ( n -- +n|0 ) + 0 MAX DUP FDP CELL+ +! ; + +\ insert string +: (f6) ( c-addr n -- ) + (f5) SHOLD ; + +\ insert '0's +: (f7) ( n -- ) + (f5) [CHAR] 0 NHOLD ; + +\ insert sign +: (f8) ( -- ) + sn# SIGN 0 0 #> ; + +\ trim trailing '0's +: (f9) ( c-addr u1 -- c-addr u2 ) + pl# 0< IF + BEGIN DUP WHILE 1- 2DUP CHARS + + C@ [CHAR] 0 - UNTIL 1+ THEN + THEN ; + +: (fa) ( n -- n n|pl# ) + pl# 0< IF DUP ELSE pl# THEN ; + +\ insert fraction string n places right of dec. point +: (fb) ( c-addr u n -- ) + 0 FDP CELL+ ! + >R (f9) R@ + + (fa) OVER - (f7) \ trailing 0's + (fa) MIN R@ - (f6) \ fraction + R> (fa) MIN (f7) \ leading 0's + FDP 2@ OR IF + [CHAR] . HOLD + THEN ; + +\ split string into integer/fraction parts at n and insert +: (fc) ( c-addr u n -- ) + >R 2DUP R@ MIN 2SWAP R> /STRING 0 (fb) (f6) ; + +\ exponent form +: (fd) ( F: r -- ) ( n factor -- c-addr u ) + TO ef# (f3) IF ex# 1- (f2) (f4) 1+ (fc) (f8) THEN ; + +\ Main words + +\ Convert real number r to a string c-addr u in scientific +\ notation with n places right of the decimal point. +: (FS.) ( F: r -- ) ( n -- c-addr u ) + 1 (fd) ; + +\ Display real number r in scientific notation right- +\ justified in a field width u with n places right of the +\ decimal point. +: FS.R ( F: r -- ) ( n u -- ) + >R (FS.) R> S.R ; + +\ Display real number r in scientific notation followed by +\ a space. Non-essential zeros and signs are removed. +: FS. ( F: r -- ) + -1 0 FS.R SPACE ; + +\ Convert real number r to a string c-addr u in engineering +\ notation with n places right of the decimal point. +: (FE.) ( F: r -- ) ( n -- c-addr u ) + 3 (fd) ; + +\ Display real number r in engineering notation right- +\ justified in a field width u with n places right of the +\ decimal point. +: FE.R ( F: r -- ) ( n u -- ) + >R (FE.) R> S.R ; + +\ Display real number r in engineering notation followed +\ by a space. Non-essential zeros and signs are removed. +: FE. ( F: r -- ) + -1 0 FE.R SPACE ; + +\ Convert real number r to string c-addr u in fixed-point +\ notation with n places right of the decimal point. +: (F.) ( F: r -- ) ( n -- c-addr u ) + 0 TO ef# (f3) IF + ex# DUP mc# > IF + fbuf 0 ( dummy ) 0 (fb) + mc# - (f7) (f6) + ELSE + DUP 0> IF + (fc) + ELSE + ABS (fb) 1 (f7) + THEN + THEN (f8) + THEN ; + +\ Display real number r in fixed-point notation right- +\ justified in a field width u with n places right of the +\ decimal point. +: F.R ( F: r -- ) ( n u -- ) + >R (F.) R> S.R ; + +\ Display real number r in floating-point notation followed +\ by a space. Non-essential zeros and signs are removed. +: F. ( F: r -- ) + -1 0 F.R SPACE ; + +\ Convert real number r to string c-addr u with n places +\ right of the decimal point. Fixed-point is used if the +\ exponent is in the range -4 to 5 otherwise use scientific +\ notation. +: (G.) ( F: r -- ) ( n -- c-addr u ) + >R (f1) [ -4 1+ ] LITERAL [ 5 2 + ] LITERAL WITHIN + R> SWAP IF (F.) ELSE (FS.) THEN ; + +\ Display real number r right-justified in a field width u +\ with n places right of the decimal point. Fixed-point is +\ used if the exponent is in the range -4 to 5 otherwise +\ use scientific notation. +: G.R ( F: r -- ) ( n u -- ) + >R (G.) R> S.R ; + +\ Display real number r followed by a space. Floating-point +\ is used if the exponent is in the range -4 to 5 otherwise +\ use scientific notation. Non-essential zeros and signs are +\ removed. +: G. ( F: r -- ) + -1 0 G.R SPACE ; + +CR FDP @ [IF] + CR .( Decimal point always displayed. Use 0 FDP ! ) + CR .( or FDP OFF to disable trailing decimal point. ) +[ELSE] + CR .( Trailing decimal point not displayed. Use ) + CR .( 1 FDP ! or FDP ON for FORTH-94 compliance. ) +[THEN] CR + +[DEFINED] DXFORTH [IF] BEHEAD mc# (fd) [THEN] + +\ ****************** DEMONSTRATION ****************** + +0 [IF] + +CR .( Loading demo words... ) CR +CR .( TEST1 formatted, n decimal places ) +CR .( TEST2 compact & right-justified ) +CR .( TEST3 display FS. ) +CR .( TEST4 display F. ) +CR .( TEST5 display G. ) +CR .( TEST6 display 8087 non-numbers ) CR +CR .( 'n PLACES' sets decimal places for TEST1. ) +CR .( SET-PRECISION sets maximum significant ) +CR .( digits displayable. ) +CR CR + +[UNDEFINED] F, [IF] +: F, ( r -- ) HERE 1 FLOATS ALLOT F! ; +[THEN] + +\ floating-point numbers array + +FALIGN HERE ( *) + 1.23456E-16 F, +-1.23456E-11 F, + 1.23456E-7 F, +-1.23456E-6 F, + 1.23456E-5 F, +-1.23456E-4 F, + 1.23456E-3 F, +-1.23456E-2 F, + 1.23456E-1 F, +-0.E0 F, + 1.23456E+0 F, +-1.23456E+1 F, + 1.23456E+2 F, +-1.23456E+3 F, + 1.23456E+4 F, +-1.23456E+5 F, + 1.23456E+6 F, +-1.23456E+7 F, + 1.23456E+11 F, +-1.23456E+16 F, + +( *) HERE OVER - 1 FLOATS / CONSTANT #numbers +( *) CONSTANT f-array + +: do-it ( xt -- ) + #numbers 0 DO + f-array FALIGNED I FLOATS + + OVER >R F@ CR R> EXECUTE + LOOP DROP ; + +2VARIABLE (dw) +: d.w ( -- dec.places width ) (dw) 2@ ; +: PLACES ( places -- ) d.w SWAP DROP (dw) 2! ; +: WIDTH ( width -- ) d.w DROP SWAP (dw) 2! ; + +5 PLACES 18 WIDTH + +: (t1) ( r -- ) + FDUP d.w FS.R FDUP d.w F.R FDUP d.w G.R d.w FE.R ; + +: TEST1 ( -- ) + CR ." TEST1 right-justified, formatted (" + d.w DROP 0 .R ." decimal places)" CR + ['] (t1) do-it CR ; + +: (t2) ( r -- ) + FDUP -1 d.w NIP FS.R FDUP -1 d.w NIP F.R + FDUP -1 d.w NIP G.R -1 d.w NIP FE.R ; + +: TEST2 ( -- ) + CR ." TEST2 right-justified, compact" CR + ['] (t2) do-it CR ; + +: TEST3 ( -- ) + CR ." TEST3 FS." + CR ['] FS. do-it CR ; + +: TEST4 ( -- ) + CR ." TEST4 F." + CR ['] F. do-it CR ; + +: TEST5 ( -- ) + CR ." TEST5 G." + CR ['] G. do-it CR ; + +: TEST6 ( -- ) + PRECISION >R 1 SET-PRECISION + CR ." TEST6 8087 non-numbers PRECISION = 1" CR + CR 1.E0 0.E0 F/ FDUP G. + CR FNEGATE G. + CR 0.E0 0.E0 F/ FDUP G. + CR FNEGATE G. + CR + R> SET-PRECISION ; + +[ELSE] + +CR .( To compile demonstration words TEST1..TEST6 ) +CR .( enable conditional in FPOUT source. ) CR + +[THEN] + +\ end diff --git a/DX-FORTH v430/HLOCALS.SCR b/DX-FORTH v430/HLOCALS.SCR new file mode 100644 index 0000000..b144109 --- /dev/null +++ b/DX-FORTH v430/HLOCALS.SCR @@ -0,0 +1 @@ +\ Hayes-style locals Adapted from: http://www.complang.tuwien.ac.at/forth/anslocal.fs \ Hayes-style locals [undefined] (local) [if] 1 fload locals [then] forth definitions system -? : lp >in @ swap token 2dup s" --" compare if 2dup s" }" compare over 0> and if s" |" compare 0= or false else true then else [char] } parse 2drop true then if 2drop 2drop >in @ end dup if false postpone literal then recurse swap >in ! token (local) ; : { false lp >in ! 0 0 (local) ; immediate application behead lp lp \ No newline at end of file diff --git a/DX-FORTH v430/KERNEL.ASM b/DX-FORTH v430/KERNEL.ASM new file mode 100644 index 0000000..9561d0d --- /dev/null +++ b/DX-FORTH v430/KERNEL.ASM @@ -0,0 +1,9838 @@ +; +; DX-FORTH +; +; A direct-threaded 8086 Forth compiler for MSDOS 2.x +; +; +; Assemble to preliminary COM file using MASM or TASM: +; +; for Borland TASM 3 +; +; TASMX /l KERNEL.ASM +; TLINK /t KERNEL +; +; for Microsoft MASM 5.1 +; +; MASM /l KERNEL.ASM +; LINK KERNEL.OBJ +; EXE2BIN KERNEL.EXE KERNEL.COM +; +; Make compressed EXE executable: +; +; KERNEL.COM - SAVE KERNEL BYE +; DEL KERNEL.COM +; + + .8086 + +no equ 0 +yes equ not no + +; Date last revised + +date macro + db '2017-02-11' + endm + +; Modification level + +rel equ 4 ; release # +rev equ 30 ; revision # +beta equ no ; beta release + +; Equates for conditional assembly + +debug equ no ; debugging messages +ucase equ yes ; forth names case insensitive +fpeng equ yes ; engineering output functions +cfs equ yes ; control flow stack extensions +wopt equ yes ; warning options +ldp equ yes ; allow leading decimal point on f/p input +fpx equ no ; extra f/p functions +ints equ yes ; control interrupts + +; Command-line assembly options + +x = no ; show hidden words +fstack = yes ; separate floating point stack +float = yes ; include floating point routines +nfd = 6 ; max open source files (min = 2) +retro = no ; classic forth behaviours + + ifdef NOHIDE +x = yes + endif + + ifdef NOFLOAT +float = no + endif + + ifdef NOFSTACK +fstack = no + endif + + ifdef FILES +nfd = files + endif + + ifdef CLASSIC +retro = yes + endif + +; Memory sizes +; +; Set memory used by the forth compiler (default is 96K). +; Systems with limited memory may use reduced values e.g. +; EM=9000h, SM=4000h, HM=2800h results in a 46k footprint. +; +; EM SM HM must be a multiple of 16 bytes! + +em = 0fff0h ; end of memory + 1 +sm = 0b000h ; system dict. start +hm = 8000h ; header memory size + +cw equ 2 ; cell size (bytes) +fw equ 4 ; float size (bytes) + +; user-specified values from the command-line + + ifdef ems +em = ems AND 0fff0h + endif + + ifdef sms +sm = sms AND 0fff0h + endif + + ifdef hms +hm = hms AND 0fff0h + endif + +; Buffer sizes + +us equ 128 ; user variable space +rts equ 256 ; return stack space + +tibsiz equ 80 ; TIB buffer size +bufsiz equ 10*128 ; max block size (multiple of 128) +pfsiz equ 79+1 ; max path/filename size +wbsiz equ 31+5 ; min WORD buffer size +pssiz equ 255 ; max parsed string buffer size +fdsiz equ pfsiz+(4*cw) ; file descriptor size +pno equ 68 ; pictured numeric buffer size + +; DOS and memory equates + + if retro +psb equ em-pssiz ; buffer S" + else +psb equ em-wbsiz-pssiz ; buffer WORD S" + endif +tib equ psb-tibsiz ; TIB +sfb equ tib-bufsiz ; screen block buffer +fdbs equ sfb-(fdsiz*nfd) ; file descriptor blocks + +dosfcb equ 005ch ; default file control block +dosbuf equ 0080h ; default DTA and command-line buffer +tpa equ 0100h ; program start + +; Equates + +init = noop ; INIT +ident = noop ; IDENT +fnu = false ; FNUMBER +fnum = 0 ; fp-stack items +fps = 0 ; fp-stack size + +toppru = 0 ; top prunes + + if float + +maxsig = 7 ; max significant digits + +init = fpini +ident = fiden +fnu = fnumb + if fstack +fnum = 6 +fps = (fnum+5)*fw ; allow extra for fp display etc + endif + +toppru = fprun1 + + endif + +; ASCII characters + +bel equ 07h ; bell +bs equ 08h ; backspace +tab equ 09h ; tab +lf equ 0ah ; line feed +ff equ 0ch ; form feed +cr equ 0dh ; carriage return +can equ 18h ; ctl-x +ctlz equ 1ah ; ctl-z +escape equ 1bh ; escape + +; +; Forth Registers +; +; FORTH 8086 Forth preservation rules +; ----- ---- ------------------------ +; IP SI Interpretive pointer. Should be preserved across +; forth words. +; SP SP Data stack pointer. Should be used only as data +; stack across forth words. May be used within forth +; words if restored before NEXT. +; RP BP Return stack pointer. Should be preserved across +; forth words. +; AX Input only when APUSH called. +; DX Input only when DPUSH called. +; +; comment conventions: +; +; a = address +; c = 8b character +; u = 16b unsigned number +; n = 16b signed number +; x = 16b signed or unsigned number +; d = 32b signed double number +; ud = 32b unsigned double number +; xd = 32b signed or unsigned number +; cfa,xt = addr of code field (execution token) +; lfa = addr of link field +; nfa = addr of name field +; pfa = addr of parameter field (body) +; +; FIG Fig-FORTH model +; F79 Forth-79 Standard +; F83 Forth-83 Standard +; F94 Forth-94 ANS FORTH Standard + +; +; Memory allocation +; +; The memory above LIMIT is used only by the interpreter. This space +; is not wasted for turnkey applications as LIMIT, user variables and +; stacks are relocated to EM giving applications more free ram (as +; indicated by UNUSED). Word headers have their own segment. +; +; HM |------------- +; | +; DPH |------------- +; | word headers +; 0 |------------- +; +; EM |------------- end of memory +; | parsed string buffer +; PSB |------------- +; | terminal input buffer +; TIB |------------- +; | block buffer +; SFB |------------- +; | file descriptor blocks +; ESM |------------- end of system memory +; | +; DPS |------------- +; | system dictionary +; LIMIT |------------- +; | user variables +; R0 |------------- +; | return stack +; FS0 |------------- +; | separate fp stack +; S0 |------------- +; | data stack +; PAD |------------- +; | word and number conversion area +; DP |------------- +; | application dictionary +; 0100h |------------- + +; +; Macro for generating word header +; + +lastl = 0 ; initial link pointer (end of list) + +hdr macro en,str,im,fl,axt + local a,b + ;; en = enable hdr 0=disable + ;; str = name string + ;; im = immediate + ;; fl = application/system flag + ;; axt = alias xt + + if en ;; if header enable + + ifb + cseg + else + aseg + endif + +cfadr = $ ;; code field address + +heads segment public ;; put heads in own segment +lnk = $ ;; link address for next word + +bits = 0 + + ifnb +bits = bits+40h ;; set immediate bit + endif + + ifnb ;; if alias +cfadr = axt ;; set cfa +bits = bits+80h ;; set alias bit + endif + + db a ;; generate count byte +b db str ;; generate name +a = $-b+bits + + dw lastl ;; generate link field + dw cfadr ;; for application words + +lastl = lnk-horig + +heads ends + + endif + + ifb ;; switch to system or application + cseg + else + aseg + endif + + endm + +; Macro to generate counted string + +dcs macro s1,s2,s3,s4 ;; allow comma separated + local a,b + db a ;; generate count byte +b db s1 + ifnb + db s2 + ifnb + db s3 + ifnb + db s4 + endif + endif + endif +a = $-b + endm + +; Macro to switch between application and system memory + +cseg macro +loc = $ + if loc ge (orig+sm) +pchi = $ + org pclo + endif + endm + +aseg macro +loc = $ + if loc lt (orig+sm) +pclo = $ + org pchi + endif + endm + +; Macro for I/O delay to same peripheral + +iodelay macro + jmp short $+2 + endm + +; Macro for inline NEXT + +nextt macro + lodsw + jmp ax + endm + +; Macro to ignore next 1 bytes + +ignore1 macro + db 0a8h ;; test al,n + endm + +; Macro to ignore next 2 bytes + +ignore2 macro + db 0a9h ;; test ax,n + endm + +; Macro to generate fdb table + +gfdb macro + local a +a = fdbs + rept nfd + dw a +a = a+fdsiz + endm + endm + +; Assembly initialisation + +dgroup group main,heads ; put in same segment for COM file + +main segment byte public 'CODE' +main ends + +heads segment byte public +horig = $ ; base of segment +dnfa db 0 ; dummy nfa - don't remove! +heads ends + +main segment + assume cs:main,ds:main,ss:main,es:main + + org 0 +orig equ $ + + org $+tpa +pclo = $ + + org sm +pchi = $ + +; +; Code starts here +; + cseg + +start: jmp cldd + + org start+3 + +; Video parameters - do not change + +cattr db ?,? ; current video attribute 0103 +cmode db ?,? ; current video mode, page 0105 +wmin db ?,? ; current window min (col,row) 0107 +wmax db ?,? ; current window max (col,row) 0109 + + db 5 dup (?) ; reserved 010B + +; Temporary filename buffers + +zbsiz equ pfsiz+1 + +zb1 db zbsiz dup (0) +zb2 db zbsiz dup (0) + +tmpstk equ $-cw ; temp stack for startup & EXE load + +; DXFORTH ( -- minor major ) + + hdr 1,'DXFORTH' +dxf: mov ax,rel + mov dx,rev + +; NEXT is forth's address interpreter. For primitives, it is usually +; compiled in-line for maximum speed. + +dpush: push dx ; 2PUSH +apush: push ax ; 1PUSH + +; NOOP ( -- ) + + hdr 1,'NOOP' ; FIG +noop equ $ + +next: nextt ; NEXT + +imode db ?,? ; initial video mode, page +iattr db ? ; initial video attribute + db 2 dup (?) ; spare + +; Boot up variables used by COLD, must be in same order as USER variables + +initu equ $ ; <<< beginning data + dw 3 dup (?) ; reserved for multitasking +is0 dw ? ; s0 +ir0 dw ? ; r0 +idp dw initdp ; dp +idps dw initdps ; dps +ivoc dw forth2 ; voc-link +ifs0 dw ? ; fs0 +idph dw initdph ; dph +initu2 equ $ ; <<< end data + +esm dw ? ; end of system memory +iboot dw ? ; initial boot value +dosv dw 0,0 ; DOS version (major,minor) +defdrv db ? ; default drive +scaps db ? ; COMPARE SEARCH case flag +cmdf db ? ; command line flag +kbfn db ?,? ; keyboard functions +kbpend db ? ; key pending (0 if none) +fssav dw ? ; forth stack save +ulimit dw ?,? ; LIMIT for turnkey + dw ? ; spare + dw ? ; spare + +; Misc. subroutines + +; set cursor position + +scurs: mov ah,2 + ignore2 + +; get cursor position + +gcurs: mov ah,3 + +; perform int 10h using current page number + +videop: mov bh,cmode+1 + jmp short video + +; perform INT 10h using current attribute + +videoa: mov bh,cattr + +; perform INT 10h saving SI, BP + +video: push si + push bp + int 10h + pop bp + pop si + ret + +; get video mode AL=mode AH=page BH=cols + +gmode: mov ah,0fh + call video + xchg bh,ah + mov word ptr cmode,ax ; save + ret + +; read BIOS tick timer AX:DX = ticks after midnight +; +; BIOS INT 1Ah AH=0 is not used as it may cause +; DOS to fail to increment the system date + + if ints + +tod: push ds + sub ax,ax + mov ds,ax + pushf + cli + mov dx,ds:[046ch] + mov ax,ds:[046eh] + popf + pop ds + ret + + else + +tod: push ds + sub ax,ax + mov ds,ax +tod1: mov ax,ds:[046eh] + mov dx,ds:[046ch] + cmp ax,ds:[046eh] + jnz tod1 + pop ds + ret + + endif + +; wait for timer tick AX:DX = TOD + +tsync: push bx + call tod +tsync1: mov bx,dx + call tod + cmp bx,dx + jz tsync1 + pop bx + ret + +; make uppercase AL + +upc: cmp al,'a' + jc upc1 + cmp al,'z'+1 + jnc upc1 + xor al,20h +upc1: ret + +; move block down AX = src, DI = dest, CX = cnt + +bmovd: push ds + pop es +bmovd1: xchg si,ax + rep movsb + mov si,ax + ret + +; move block up/down AX = src, DI = dest, CX = cnt, DX = scratch + +bmove: mov dx,di + sub dx,ax + cmp dx,cx + jc bmovu ; overlap and moving-up +; jmp movd + +; move block down AX = src, DI = dest, CX = cnt +; increment by word NOTE: does not propagate + +movd: push ds + pop es + xchg si,ax + shr cx,1 + rep movsw + jnc movd1 + movsb +movd1: mov si,ax + ret + +; move block up AX = src, DI = dest, CX = cnt + +bmovu: push ds + pop es + xchg si,ax + dec cx + add di,cx + add si,cx + inc cx + std + rep movsb + cld + mov si,ax + ret + +; runtime for colon definitions + +docol: sub bp,cw ; push IP onto return stack + mov [bp],si + pop si ; get new IP from 'call' + nextt + +; runtime for user variables + +douse: pop bx + mov ax,upp + add ax,[bx] + push ax + nextt + +; EXIT ( -- ) exit colon definition + + hdr 1,'EXIT' +exit: mov si,[bp] ; pop IP from return stack + +; UNNEST ( -- ) + + hdr 1,'UNNEST' +unnest: add bp,cw +unnest1:nextt + +; EXIT1 exit colon to code + +exit1: push si + mov si,[bp] + add bp,cw + +; EXECUTE ( xt -- ) + + hdr 1,'EXECUTE' +exec: ret + +; @EXECUTE ( a-addr -- ) + + hdr 1,'@EXECUTE' +aexec: pop bx + mov cx,[bx] + jcxz unnest1 + jmp cx + +; clit ( -- char ) + + hdr x,'CLIT' ; FIG +clit: sub ax,ax + lodsb + push ax + nextt + +; lit ( -- n ) + + hdr x,'LIT' ; FIG +lit: lodsw + push ax + nextt + +; 2lit ( -- x1 x2 ) + + hdr x,'2LIT' +tlit: lodsw + mov dx,ax + lodsw + push ax + push dx + nextt + +; +; Stack Manipulation +; +; SP@ SP! RP@ RP! >R R> R@ 2>R 2R> 2R@ DROP DUP ?DUP +; SWAP OVER ROT -ROT ROLL -ROLL PICK NIP TUCK >< 2DROP +; 2DUP 2SWAP 2OVER 2ROT 2NIP DEPTH +; + +; SP@ ( -- addr ) + + hdr 1,'SP@' +spat: mov ax,sp ; 'push sp' won't work on 8086 + jmp apush + +; SP! ( addr -- ) + + hdr 1,'SP!' +spsto: pop ax + mov sp,ax + nextt + +; RP@ ( -- addr ) + + hdr 1,'RP@' +rpat: push bp + nextt + +; RP! ( addr -- ) + + hdr 1,'RP!' +rpsto: pop bp + nextt + +; >R ( x -- ) + + hdr 1,'>R' +tor: sub bp,cw + pop [bp] + nextt + +; R> ( -- x ) + + hdr 1,'R>' +fromr: push [bp] + add bp,cw + nextt + +; R@ ( -- x ) + + hdr 1,'R@' +rat: push [bp] + nextt + +; 2>R ( x1 x2 -- ) + + hdr 1,'2>R' +ttor: sub bp,cw*2 + pop [bp] + pop [bp+cw] + nextt + +; 2R> ( -- x1 x2 ) + + hdr 1,'2R>' +tfrom: push [bp+cw] + push [bp] + add bp,cw*2 + nextt + +; 2R@ ( -- x1 x2 ) + + hdr 1,'2R@' +trat: mov bx,bp + jmp tat1 + +; DROP ( x -- ) + + hdr 1,'DROP' +drop: add sp,cw + nextt + +; DUP ( x -- x x ) + + hdr 1,'DUP' +dupp: mov bx,sp + push [bx] + nextt + +; ?DUP ( x -- 0 | x x ) + + hdr 1,'?DUP' +qdup: mov bx,sp + mov cx,[bx] + jcxz qdup1 + push cx +qdup1: nextt + +; SWAP ( x1 x2 -- x2 x1 ) + + hdr 1,'SWAP' +swap: pop dx + pop ax + push dx + push ax + nextt + +; OVER ( x1 x2 -- x1 x2 x1 ) + + hdr 1,'OVER' +over: mov bx,sp + push [bx+cw] + nextt + +; ROT ( x1 x2 x3 -- x2 x3 x1 ) + + hdr 1,'ROT' +rot: pop dx + pop bx + pop ax + push bx + push dx + push ax + nextt + +; -ROT ( x1 x2 x3 -- x3 x1 x2 ) + + hdr 1,'-ROT' +drot: pop bx + pop ax + pop dx + push bx + push dx + push ax + nextt + +; ROLL ( xu xu-1 .. x0 u -- xu-1 .. x0 xu ) + + hdr 1,'ROLL' +roll: pop cx +;; jcxz roll2 + mov di,cx + shl di,1 + add di,sp + push si + lea si,[di-cw] + std +roll1: mov ax,[di] + push ds + pop es + rep movsw + cld + mov [di],ax + pop si +roll2: nextt + +; -ROLL ( xu .. xu+1 x0 u -- x0 xu .. xu+1 ) + + hdr 1,'-ROLL' +droll: pop cx +;; jcxz roll2 + mov di,sp + push si + lea si,[di+cw] + jmp roll1 + +; PICK ( xu .. x1 x0 u -- xu .. x1 x0 xu ) + + hdr 1,'PICK' +pick: pop bx + shl bx,1 + add bx,sp + push [bx] + nextt + +; NIP ( x1 x2 -- x2 ) + + hdr 1,'NIP' +nip: pop ax + add sp,cw + push ax + nextt + +; TUCK ( x1 x2 -- x2 x1 x2 ) + + hdr 1,'TUCK' +tuck: pop ax + pop dx + push ax + push dx + push ax + nextt + +; >< ( x1 -- x2 ) + + hdr 1,'><' +bswp: pop ax + xchg ah,al + jmp apush + +; 2DROP ( x1 x2 -- ) + + hdr 1,'2DROP' +tdrop: add sp,cw*2 + nextt + +; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) + + hdr 1,'2DUP' +tdup: mov bx,sp + push [bx+cw] + push [bx] + nextt + +; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) + + hdr 1,'2SWAP' +tswap: pop bx + pop cx + pop ax + pop dx + push cx + push bx + push dx + push ax + nextt + +; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) + + hdr 1,'2OVER' +tover: mov bx,sp + push [bx+cw*3] + push [bx+cw*2] + nextt + +; 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) 5 roll 5 roll + + hdr 1,'2ROT' +trot: call docol + dw clit + db 5 + dw roll + dw clit + db 5 + dw roll + dw exit + +; 2NIP ( x1 x2 x3 x4 -- x3 x4 ) + + hdr 1,'2NIP' +tnip: pop ax + pop dx + add sp,cw*2 + jmp dpush + +; DEPTH ( -- +n ) sp@ s0 @ swap - 2/ + + hdr 1,'DEPTH' +depth: mov bx,upp + mov ax,[bx+6] ; S0 + sub ax,sp + sar ax,1 + jmp apush + +; +; Memory & String Operations +; +; CSEG SSEG HSEG @ ! C@ C! 2@ 2! @L !L C@L C!L +; 2@L 2!L +! h@ h! hc@ ON OFF BLANK ERASE FILL +; LFILL CMOVE CMOVE> CMOVEL MOVE COUNT PACK PLACE +; affix SCAN SKIP -TRAILING TRIM /STRING COMPARE +; SEARCH +STRING ZCOUNT ZPLACE S.R +; + +; CSEG ( -- seg ) code segment + + hdr 1,'CSEG' +csegg: call docon +cseg1 dw ? ; patched + +; SSEG ( -- a-addr ) search segment + + hdr 1,'SSEG' +sseg: call docre +sseg1 dw ? + +; HSEG ( -- seg ) heads segment + + hdr 1,'HSEG' +hseg: call docon +hseg1 dw ? ; patched + +; @ ( a-addr -- x ) + + hdr 1,'@' +at: pop bx + push [bx] + nextt + +; ! ( x a-addr -- ) + + hdr 1,'!' +store: pop bx + pop [bx] + nextt + +; C@ ( c-addr -- char ) + + hdr 1,'C@' +cat: pop bx + sub ax,ax + mov al,[bx] + push ax + nextt + +; C! ( char c-addr -- ) + + hdr 1,'C!' +cstor: pop bx + pop ax + mov [bx],al + nextt + +; 2@ ( a-addr -- x1 x2 ) + + hdr 1,'2@' +tat: pop bx +tat1: push [bx+cw] + push [bx] + nextt + +; 2! ( x1 x2 a-addr -- ) + + hdr 1,'2!' +tstor: pop bx + pop [bx] + pop [bx+cw] + nextt + +; @L ( seg offs -- x ) + + hdr 1,'@L' +atl: pop bx + pop ds + push [bx] + mov bx,cs + mov ds,bx + nextt + +; !L ( x seg offs -- ) + + hdr 1,'!L' +storl: pop bx + pop ds + pop [bx] + mov bx,cs + mov ds,bx + nextt + +; C@L ( seg offs -- char ) + + hdr 1,'C@L' +catl: pop bx + pop ds + sub ax,ax + mov al,[bx] + mov bx,cs + mov ds,bx + push ax + nextt + +; C!L ( char seg offs -- ) + + hdr 1,'C!L' +cstorl: pop bx + pop ds + pop ax + mov [bx],al + mov bx,cs + mov ds,bx + nextt + +; 2@L ( seg offs -- x1 x2 ) + + hdr 1,'2@L' +tatl: pop bx + pop ds + push [bx+cw] + push [bx] + mov bx,cs + mov ds,bx + nextt + +; 2!L ( x1 x2 seg offs -- ) + + hdr 1,'2!L' +tstorl: pop bx + pop ds + pop [bx] + pop [bx+cw] + mov bx,cs + mov ds,bx + nextt + +; +! ( x a-addr -- ) + + hdr 1,'+!' +pstor: pop bx + pop ax + add [bx],ax + nextt + +; h@ ( h-addr -- x ) + + hdr x,'H@',,1 +hat: pop bx + push word ptr hseg1 + push bx + jmp atl + +; h! ( x h-addr -- ) + + hdr x,'H!',,1 +hstor: pop bx + push word ptr hseg1 + push bx + jmp storl + +; hc@ ( h-addr -- char ) + + hdr x,'HC@',,1 +hcat: pop bx + push word ptr hseg1 + push bx + jmp catl + +; ON ( addr -- ) -1 swap ! + + hdr 1,'ON' +on: pop bx +on1: mov word ptr [bx],-1 + nextt + +; OFF ( addr -- ) 0 swap ! + + hdr 1,'OFF' +off: pop bx +off1: mov word ptr [bx],0 + nextt + +; BLANK ( c-addr u -- ) bl fill + + hdr 1,'BLANK' +blank: mov al,20h + ignore2 + +; ERASE ( addr u -- ) 0 fill + + hdr 1,'ERASE' +erase: mov al,0 + ignore1 + +; FILL ( c-addr u char -- ) + + hdr 1,'FILL' +fill: pop ax + mov cx,ds + mov es,cx + pop cx + pop di +fill1: rep stosb + nextt + +; LFILL ( seg offs u char -- ) + + hdr 1,'LFILL' +lfill: pop ax + pop cx + pop di + pop es + jmp fill1 + +; CMOVE ( c-addr1 c-addr2 u -- ) + + hdr 1,'CMOVE' +cmove: pop cx + pop di + pop ax +cmove1: call bmovd + nextt + +; CMOVE> ( c-addr1 c-addr2 u -- ) + + hdr 1,'CMOVE>' +cmovu: pop cx + pop di + pop ax + call bmovu + nextt + +; CMOVEL ( seg1 offs1 seg2 offs2 u -- ) + + hdr 1,'CMOVEL' +cmovl: mov bx,ds + pop cx + pop di + pop es + pop ax + pop ds + call bmovd1 + mov ds,bx + nextt + +; MOVE ( a-addr1 a-addr2 u -- ) >r 2dup u< if r> cmove> else r> +; cmove then + + hdr 1,'MOVE' +move: pop cx + pop di + pop ax + call bmove + nextt + +; COUNT ( c-addr1 -- c-addr2 u ) dup 1+ swap c@ + + hdr 1,'COUNT' +count: pop bx + sub ax,ax + mov al,[bx] + inc bx + push bx + jmp apush + +; PACK ( c-addr1 u c-addr2 -- c-addr2 ) +; 2dup 2>r 1+ swap move 2r> tuck c! + + hdr 1,'PACK' +pack: pop di + pop cx + pop ax + push di + push cx + push di + inc di + call bmove + jmp cstor + +; PLACE ( c-addr1 u c-addr2 -- ) pack drop + + hdr 1,'PLACE' +place: call docol + dw pack,drop + dw exit + +; affix ( c-addr char -- c-addr ) over count + c! + + hdr x,'AFFIX' ; append char to counted string +affix: call docol ; count unchanged + dw over + dw count,plus + dw cstor + dw exit + +; SCAN ( c-addr1 u1 char -- c-addr2 u2 ) + + hdr 1,'SCAN' +scan: pop ax + pop cx + pop di + jcxz scan1 + mov es,sseg1 + repnz scasb + jnz scan1 + inc cx + dec di +scan1: push di + push cx + nextt + +; SKIP ( c-addr1 u1 char -- c-addr2 u2 ) + + hdr 1,'SKIP' +skip: pop ax + pop cx + pop di + jcxz skip1 + mov es,sseg1 + rep scasb + jz skip1 + inc cx + dec di +skip1: push di + push cx + nextt + +; -TRAILING ( c-addr u1 -- c-addr u2 ) bl trim + + hdr 1,'-TRAILING' +dtrai: mov al,' ' + ignore1 + +; TRIM ( c-addr u1 char -- c-addr u2 ) + + hdr 1,'TRIM' +trim: pop ax + pop cx + pop di + push di + jcxz trim1 + mov es,sseg1 + add di,cx + dec di + std + repz scasb + cld + jz trim1 + inc cx +trim1: push cx + nextt + +; -BLANKS ( c-addr u1 -- c-addr u2 ) bl skip -trailing + + hdr 1,'-BLANKS' +dblan: call docol + dw bll,skip + dw dtrai + dw exit + +; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) rot over + -rot - + + hdr 1,'/STRING' +sstr: pop ax + mov bx,sp + sub [bx],ax + add [bx+cw],ax + nextt + +; -caps ( -- ) disable caps COMPARE/SEARCH + + hdr x,'-CAPS' +dcaps: mov al,0 + ignore2 + +; CAPS ( -- ) enable caps COMPARE/SEARCH + + hdr 1,'CAPS' +caps: mov al,1 + mov scaps,al + nextt + +; string compare + + cseg + +cmpss: cmp byte ptr scaps,0 + jnz cmpnc + rep cmpsb + ret + +cmpnc: push ax + cmp cx,cx ; clear S Z flags + jcxz cmpnc2 +cmpnc1: lodsb + call upc + mov ah,al + mov al,es:[di] + inc di + call upc + cmp ah,al + jnz cmpnc2 + loop cmpnc1 +cmpnc2: pop ax + ret + +; COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) + + hdr 1,'COMPARE' +cmpp: mov dx,si + pop cx + pop si + pop bx + pop di + mov es,sseg1 + sub ax,ax + cmp cx,bx + jz cmpp2 + ja cmpp1 + inc ax + jmp short cmpp2 + +cmpp1: dec ax + mov cx,bx +cmpp2: call cmpss + jz cmpp3 + mov ax,-1 + jnc cmpp3 + neg ax +cmpp3: mov si,dx + push ax + jmp dcaps + +; SEARCH ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 -1 | c-addr1 u1 0 ) + + hdr 1,'SEARCH' +sear: pop bx + pop ax + or bx,bx ; u2=0 + jz sear3 ; match + pop dx + pop di + push di + push dx + push si + xchg si,ax + mov es,sseg1 + sub dx,bx + js sear5 ; u2r swap cmove 0 r> c! + + hdr 1,'ZPLACE' +zplace: pop di + pop cx + pop ax + call movd + mov byte ptr [di],0 + nextt + +; S.R ( c-addr n1 n2 -- ) over - spaces type + + hdr 1,'S.R' ; type string right-justified +sdotr: call docol + dw over,subb + dw spacs + dw typee + dw exit + +; +; Comparison Functions +; +; D0= 0= 0<> = <> 0< 0> < > U< U> MIN MAX UMIN UMAX +; WITHIN BETWEEN D= D0< D< DU< DMIN DMAX +; + +; D0= ( d -- flag ) or 0= + + hdr 1,'D0=' +dzequ: pop ax + pop bx + or ax,bx + ignore1 + +; 0= ( x -- flag ) + + hdr 1,'0=' +zequ: pop ax +zequ1: sub ax,1 + sbb ax,ax + push ax + nextt + +; 0<> ( x -- flag ) + + hdr 1,'0<>' +zneq: pop ax +zneq1: neg ax + sbb ax,ax + push ax + nextt + +; = ( x1 x2 -- flag ) + + hdr 1,'=' +equal: pop ax + pop bx + sub ax,bx + sub ax,1 + sbb ax,ax + push ax + nextt + +; <> ( x1 x2 -- flag ) + + hdr 1,'<>' +nequ: pop ax + pop bx + sub ax,bx + neg ax + sbb ax,ax + push ax + nextt + +; 0< ( n -- flag ) + + hdr 1,'0<' +zless: pop ax + cwd + push dx + nextt + +; 0> ( n -- flag ) + + hdr 1,'0>' +zgrea: pop bx + sub cx,cx +zgrea1: sub ax,ax + cmp bx,cx + jng zgrea2 + dec ax +zgrea2: push ax + nextt + +; < ( n1 n2 -- flag ) + + hdr 1,'<' +less: pop bx + pop cx + jmp short zgrea1 + +; > ( n1 n2 -- flag ) + + hdr 1,'>' +great: pop cx + pop bx + jmp short zgrea1 + +; U< ( u1 u2 -- flag ) + + hdr 1,'U<' +uless: pop ax + pop bx + sub bx,ax + sbb ax,ax + push ax + nextt + +; U> ( u1 u2 -- flag ) + + hdr 1,'U>' +ugrea: pop ax + pop bx + sub ax,bx + sbb ax,ax + push ax + nextt + +; MIN ( n1 n2 -- n1 | n2 ) 2dup > if swap then drop + + hdr 1,'MIN' +min: pop ax + pop bx + cmp ax,bx + jl min1 + mov ax,bx +min1: push ax + nextt + +; 0max ( n1 -- n2 ) 0 max + + hdr x,'0MAX' +zmax: sub ax,ax + ignore1 + +; MAX ( n1 n2 -- n1 | n2 ) 2dup < if swap then drop + + hdr 1,'MAX' +max: pop ax + pop bx + cmp ax,bx + jg max1 + mov ax,bx +max1: push ax + nextt + +; UMIN ( u1 u2 -- u1 | u2 ) 2dup u> if swap then drop + + hdr 1,'UMIN' +umin: pop ax + pop bx + cmp ax,bx + jc umin1 + mov ax,bx +umin1: push ax + nextt + +; UMAX ( u1 u2 -- u1 | u2 ) 2dup u< if swap then drop + + hdr 1,'UMAX' +umax: pop ax + pop bx + cmp ax,bx + ja umax1 + mov ax,bx +umax1: push ax + nextt + +; WITHIN ( x1 x2 x3 -- flag ) over - >r - r> u< + + hdr 1,'WITHIN' +within: pop bx + pop ax + pop cx + sub cx,ax + sub bx,ax + cmp cx,bx + sbb ax,ax + jmp apush + + if 1 + +; BETWEEN ( x1 x2 x3 -- flag ) over - -rot - u< 0= + + hdr 1,'BETWEEN' +betw: pop bx + pop ax + pop cx + sub bx,ax + sub cx,ax + cmp bx,cx + cmc + sbb ax,ax + jmp apush + + endif + +; D= ( d1 d2 -- flag ) d- d0= + + hdr 1,'D=' +dequ: call docol + dw dsub + dw dzequ + dw exit + +; D0< ( d -- flag ) nip 0< + + hdr 1,'D0<' +dzle: pop ax + pop bx + cwd + push dx + nextt + +; D< ( d1 d2 -- flag ) + + hdr 1,'D<' +dless: pop dx + pop bx + pop cx + pop ax + sub ax,bx + sbb cx,dx + jl dless1 + jmp false + +dless1: jmp true + +; DU< ( ud1 ud2 -- flag ) + + hdr 1,'DU<' +dules: pop dx + pop bx + pop cx + pop ax + sub ax,bx + sbb cx,dx + sbb ax,ax + jmp apush + +; DMIN ( d1 d2 -- d1 | d2 ) 2over 2over d< 0= if 2swap then 2drop + + hdr 1,'DMIN' +dmin: call docol + dw tover,tover + dw dless,zequ +dmin1 dw zbran,dmin2 + dw tswap +dmin2 dw tdrop + dw exit + +; DMAX ( d1 d2 -- d1 | d2 ) 2over 2over d< if 2swap then 2drop + + hdr 1,'DMAX' +dmax: call docol + dw tover,tover + dw dless + dw bran,dmin1 + +; +; Arithmetic and Logical Functions +; +; AND OR XOR INVERT NOT S>D D>S NEGATE ABS DNEGATE DABS + +; - M+ D+ D- 1+ 2+ 1- 2- UM* M* UM/MOD SM/REM FM/MOD +; */MOD */ /MOD / MOD M*/ 2* 2/ U2/ D2* D2/ LSHIFT RSHIFT +; + +; AND ( x1 x2 -- x3 ) + + hdr 1,'AND' +andd: pop ax + pop bx + and ax,bx + push ax + nextt + +; OR ( x1 x2 -- x3 ) + + hdr 1,'OR' +orr: pop ax + pop bx + or ax,bx + push ax + nextt + +; XOR ( x1 x2 -- x3 ) + + hdr 1,'XOR' +xorr: pop ax + pop bx + xor ax,bx + push ax + nextt + +; INVERT ( x1 -- x2 ) one's complement + + hdr 1,'INVERT' +invert: pop ax + not ax + push ax + nextt + +; NOT ( x1 -- x2 ) aka 0= not + + hdr 1,'NOT',,,zequ ; F79 NOT +nott equ zequ + +; S>D ( n -- d ) + + hdr 1,'S>D' +stod: pop ax + cwd + push ax + push dx + nextt + +; D>S ( d -- n ) aka drop d>s + + hdr 1,'D>S',,,drop +dtos equ drop + +; NEGATE ( n1 -- n2 ) + + hdr 1,'NEGATE' +negat: pop ax + neg ax + push ax + nextt + +; ABS ( n -- +n ) + + hdr 1,'ABS' +abss: pop ax + cwd + xor ax,dx + sub ax,dx + jmp apush + +; DNEGATE ( d1 -- d2 ) + + hdr 1,'DNEGATE' +dnegat: pop ax +dnegat1:pop dx + neg ax + neg dx + sbb ax,0 + jmp dpush + +; DABS ( d -- +d ) + + hdr 1,'DABS' +dabs: pop ax + or ax,ax + js dnegat1 + jmp apush + +; + ( x1 x2 -- x3 ) + + hdr 1,'+' +plus: pop ax + pop bx + add ax,bx + push ax + nextt + +; - ( x1 x2 -- x3 ) + + hdr 1,'-' +subb: pop dx + pop ax + sub ax,dx + push ax + nextt + +; M+ ( xd1 n -- xd2 ) s>d d+ + + hdr 1,'M+' +mplus: pop ax + cwd + ignore2 + +; D+ ( xd1 xd2 -- xd3 ) + + hdr 1,'D+' +dplus: pop dx + pop ax + mov bx,sp + add [bx+cw],ax + adc [bx],dx + nextt + +; D- ( xd1 xd2 -- xd3 ) dnegate d+ + + hdr 1,'D-' +dsub: pop dx + pop ax + mov bx,sp + sub [bx+cw],ax + sbb [bx],dx + nextt + +; 1+ ( x1 -- x2 ) + + hdr 1,'1+' +onep: pop ax + inc ax + push ax + nextt + +; 2+ ( x1 -- x2 ) + + hdr 1,'2+' +twop: pop ax + add ax,2 + push ax + nextt + +; 1- ( x1 -- x2 ) + + hdr 1,'1-' +onem: pop ax + dec ax + push ax + nextt + +; 2- ( x1 -- x2 ) + + hdr 1,'2-' +twom: pop ax + sub ax,2 + push ax + nextt + +; UM* ( u1 u2 -- ud ) + + hdr 1,'UM*' +umstr: pop ax + pop bx + mul bx + push ax + push dx + nextt + +; M* ( n1 n2 -- d ) + + hdr 1,'M*' +mstar: pop ax + pop bx + imul bx + push ax + push dx + nextt + +; * ( x1 x2 -- x3 ) um* drop + + hdr 1,'*' +star: pop ax + pop bx + mul bx + push ax + nextt + +; UM/MOD ( ud u1 -- u2 u3 ) + + hdr 1,'UM/MOD' +umslm: pop bx + pop dx + pop ax + cmp dx,bx ; divide zero or overflow + jnc cverr + div bx + push dx + push ax + nextt + + cseg + +msm: mov di,dx + mov cx,bx + or dx,dx + jns msm1 + sub dx,dx + neg ax + sbb dx,di +msm1: or bx,bx + jns msm2 + neg bx +msm2: cmp dx,bx ; overflow? + jnc cverr0 + div bx + or di,di ; sign remainder + jns msm3 + neg dx +msm3: xor di,cx ; sign quotient + jns msm4 + neg ax + ret + +msm4: pop di + jmp dpush + +; math or conversion error - set regs to -1 + +cverr0: pop ax +cverr: mov ax,-1 + cwd + jmp dpush + +; SM/REM ( d n1 -- n2 n3 ) + + hdr 1,'SM/REM' +smrem: pop bx + pop dx + pop ax +smrem1: call msm + jmp dpush + +; FM/MOD ( d n1 -- n2 n3 ) + + hdr 1,'FM/MOD' +fmmod: pop bx + pop dx + pop ax +fmmod1: call msm + or dx,dx ; floor + jz fmmod2 + dec ax + add dx,cx + xor di,ax ; overflow? + js cverr +fmmod2: jmp dpush + +; */MOD ( n1 n2 n3 -- n4 n5 ) >r m* r> sm/rem + + hdr 1,'*/MOD' +ssmod: pop bx + pop ax + pop cx + imul cx + jmp smrem1 + +; */ ( n1 n2 n3 -- n4 ) */mod nip + + hdr 1,'*/' +ssla: call docol + dw ssmod,nip + dw exit + +; /MOD ( n1 n2 -- n3 n4 ) >r s>d r> sm/rem + + hdr 1,'/MOD' +slmod: pop bx + pop ax + cwd + jmp smrem1 + +; / ( n1 n2 -- n3 ) /mod nip + + hdr 1,'/' +slash: call docol + dw slmod,nip + dw exit + +; MOD ( n1 n2 -- n3 ) /mod drop + + hdr 1,'MOD' +modd: call docol + dw slmod,drop + dw exit + +; M*/ ( d1 n1 +n2 -- d2 ) >r 2dup xor swap abs >r -rot dabs +; swap r@ um* rot r> um* rot 0 d+ r@ +; um/mod -rot r> um/mod nip swap rot +; 0< if dnegate then + + hdr 1,'M*/' +mssl: pop di + pop bx + pop cx + pop ax + mov dx,cx + xor dx,bx + pushf + or bx,bx + jns mssl1 + neg bx +mssl1: or cx,cx + jns mssl2 + neg cx + neg ax + sbb cx,0 +mssl2: mul bx + push dx + xchg cx,ax + mul bx + pop bx + add ax,bx + adc dx,0 + cmp dx,di + jnc mssl5 + div di + xchg ax,cx + cmp dx,di + jnc mssl5 + div di + popf + jns mssl4 +; if floord +; or dx,dx +; jz mssl3 +; add ax,1 +; adc cx,0 +; endif +mssl3: neg cx + neg ax + sbb cx,0 +mssl4: push ax + push cx + nextt + +mssl5: jmp cverr0 + +; 2* ( x1 -- x2 ) + + hdr 1,'2*' +tstar: pop ax + shl ax,1 + push ax + nextt + +; 2/ ( n1 -- n2 ) + + hdr 1,'2/' +twodiv: pop ax + sar ax,1 + push ax + nextt + +; U2/ ( u1 -- u2 ) + + hdr 1,'U2/' +utdiv: pop ax + shr ax,1 + push ax + nextt + +; D2* ( xd1 -- xd2 ) + + hdr 1,'D2*' +dtstr: pop ax + pop dx + shl dx,1 + rcl ax,1 + jmp dpush + +; D2/ ( d1 -- d2 ) + + hdr 1,'D2/' +dtdiv: pop ax + pop dx + sar ax,1 + rcr dx,1 + jmp dpush + +; LSHIFT ( x1 u -- x2 ) + + hdr 1,'LSHIFT' +lsh: pop cx + pop ax + shl ax,cl + push ax + nextt + +; RSHIFT ( x1 u -- x2 ) + + hdr 1,'RSHIFT' +rsh: pop cx + pop ax + shr ax,cl + push ax + nextt + +; +; Numeric Conversion +; +; BINARY HEX DECIMAL digit >NUMBER NUMBER? <# #> +hold +; # HOLD SIGN #S SHOLD NHOLD decimal? +; + +; BINARY ( -- ) 2 base ! + + hdr 1,'BINARY' +bin: mov al,2 + ignore2 + +; HEX ( -- ) 16 base ! + + hdr 1,'HEX' +hex: mov al,16 + ignore2 + +; DECIMAL ( -- ) 10 base ! + + hdr 1,'DECIMAL' +decim: mov al,10 + cbw + push ax + call docol + dw base,store + dw exit + +; digit ( char base -- u true | false ) + + hdr x,'DIGIT' +digit: pop dx + pop ax + call upc ; make uppercase + sub al,'0' + jc digit2 + cmp al,10 + jc digit1 + sub al,7 + cmp al,10 + jc digit2 +digit1: cmp al,dl + jnc digit2 + sub ah,ah + push ax + jmp true + +digit2: jmp false + +; >NUMBER ( d1 addr1 u1 -- d2 addr2 u2 ) +; begin dup while over c@ base @ digit while +; >r 2swap r> swap base @ um* drop rot base @ +; um* d+ 2swap 1 /string 1 dpl +! repeat then + + hdr 1,'>NUMBER' +tonum: call docol +tonum1 dw dupp ; begin + dw zbran,tonum2 ; while + dw over,cat + dw base,at + dw digit + dw zbran,tonum2 ; while + dw tor + dw tswap,fromr + dw swap + dw base,at + dw umstr,drop + dw rot + dw base,at + dw umstr + dw dplus + dw tswap + dw one,sstr + dw one,dpl,pstor + dw bran,tonum1 ; repeat +tonum2 dw exit ; then + +; NUMBER? ( c-addr u -- d -1 | 0 ) +; over c@ [char] - = over 0> and dup >r 1 +; and /string over c@ [char] . > and 0 0 +; 2swap ?dup if >number dpl on dup if 1- +; over c@ [char] . - or dpl off then while +; then r> 2drop 2drop false else drop r> if +; dnegate then true then + + hdr 1,'NUMBER?' +numq: call docol ; convert string to double number + dw over,cat + dw clit + db '-' + dw equal + dw over,zgrea + dw andd + dw dupp,tor + dw one,andd + dw sstr + dw over,cat + dw clit + db '.' + dw great,andd + dw zero,zero + dw tswap + dw qdup + dw zbran,numq2 + dw tonum + dw dpl,on + dw dupp + dw zbran,numq1 + dw onem + dw over,cat + dw clit + db '.' + dw subb,orr + dw dpl,off +numq1 dw zbran,numq3 +numq2 dw fromr + dw tdrop,tdrop + dw false + dw bran,numq5 +numq3 dw drop + dw fromr + dw zbran,numq4 + dw dnegat +numq4 dw true +numq5 dw exit + +; <# ( -- ) pad hld ! + + hdr 1,'<#' +bdigs: call docol + dw pad + dw hld,store + dw exit + +; #> ( d -- c-addr u ) 2drop hld @ pad over - + + hdr 1,'#>' +edigs: call docol + dw tdrop + dw hld,at + dw pad + dw over + dw subb + dw exit + +; +hold ( +n -- c-addr ) negate hld tuck +! @ dup dp @ u< +; abort" HOLD buffer overflow" + + hdr x,'+HOLD' +phld: call docol + dw negat + dw hld,tuck + dw pstor + dw at,dupp + dw dpp,at,uless + dw pabq + dcs 'HOLD buffer overflow' + dw exit + +; # ( ud1 -- ud2 ) 0 base @ um/mod >r base @ um/mod r> +; rot dup 9 > 7 and + [char] 0 + hold + + hdr 1,'#' +dig: pop ax + pop bx + mov di,upp + add di,24 ; BASE + sub dx,dx + div word ptr [di] + xchg ax,bx + div word ptr [di] + push ax + push bx + cmp dl,9 + jna dig1 + add dl,7 +dig1: add dl,'0' + push dx +; jmp hold + +; HOLD ( char -- ) 1 +hold c! + + hdr 1,'HOLD' +hold: call docol + dw one,phld + dw cstor + dw exit + +; SIGN ( n -- ) 0< if [char] - hold then + + hdr 1,'SIGN' +sign: call docol + dw zless + dw zbran,sign1 + dw clit + db '-' + dw hold +sign1 dw exit + +; #S ( ud -- 0 0 ) begin # 2dup d0= until + + hdr 1,'#S' +digs: call docol +digs1 dw dig + dw tdup,dzequ + dw zbran,digs1 + dw exit + +; SHOLD ( c-addr u -- ) dup +hold swap move + + hdr 1,'SHOLD' ; hold string +shold: call docol + dw dupp,phld + dw swap,move + dw exit + +; NHOLD ( n char -- ) over +hold -rot fill + + hdr 1,'NHOLD' ; hold n characters +nhold: call docol + dw over,phld + dw drot,fill + dw exit + +; decimal? ( -- flag ) base @ 10 = + + hdr x,'DECIMAL?' +dcmq: call docol + dw base,at ; decimal base? + dw clit + db 10 + dw equal + dw exit + +; +; Control Structures +; +; (of) branch ?branch (loop) (+loop) UNLOOP (leave) (?do) (do) +; BAL +bal -bal ?BAL ?depth ?orig ?dest BEGIN >MARK MARK ( -- orig ) postpone begin 0 , + + hdr 1,'>MARK',,1 +fmark: call docol + dw begin + dw zero + dw comma + dw exit + +; mark +; ;immediate + + hdr 1,'IF',1,1 +iff: call docol + dw comp,zbran + dw fmark + dw exit + +; AHEAD ( -- orig ) postpone branch >mark +; ;immediate + + hdr 1,'AHEAD',1,1 +ahead: call docol + dw comp,bran + dw fmark + dw exit + +; ELSE ( orig1 -- orig2 ) ?orig postpone ahead swap postpone +; then ;immediate + + hdr 1,'ELSE',1,1 +elsee: call docol + dw qorig + dw ahead + dw swap + dw then + dw exit + +; UNTIL ( dest -- ) postpone ?branch mark dup to lv +; postpone begin ;immediate + + hdr 1,'DO',1,1 +do: mov ax,offset xdo +do1: push ax + call docol + dw comxt + dw lvv + dw fmark + dw dupp + dw pto,lvv + dw begin + dw exit + +; ?DO ( -- orig dest ) postpone (?do) lv >mark dup to lv +; postpone begin ;immediate + + hdr 1,'?DO',1,1 +qdo: mov ax,offset xqdo + jmp do1 + +; I ( -- x ) + + hdr 1,'I' +ido: mov ax,[bp] + add ax,[bp+cw] + push ax + nextt + +; I' ( -- x ) + + hdr 1,'I''' +idot: mov ax,[bp+cw] + sub ax,8000h + jmp apush + +; J ( -- x ) + + hdr 1,'J' +jdo: mov ax,[bp+cw*2] + add ax,[bp+cw*3] + push ax + nextt + +; LEAVE ( -- ) postpone (leave) lv ?orig , +; ;immediate + + hdr 1,'LEAVE',1,1 +leavee: call docol + dw comp,pleav + dw lvv + dw qorig + dw comma + dw exit + +; LOOP ( addr1 addr2 -- ) postpone (loop) + + hdr 1,'CS-TEST',,1 +cstes: call docol + dw qdep + dw dupp + dw zneq + dw exit + +; COND ?comp cs-mark immediate + + hdr 1,'COND',1,1 +cond: call docol + dw qcomp + dw csm + dw exit + +; THENS begin cs-test while postpone then +; repeat cs-drop ;immediate + + hdr 1,'THENS',1,1 +thens: call docol +thens1 dw cstes + dw zbran,thens2 + dw then + dw bran,thens1 +thens2 dw csdro + dw exit + + else + +; COND ?comp 0 +bal ;immediate + + hdr 1,'COND',1,1 +cond: call docol + dw qcomp + dw zero + dw pbal + dw exit + +; THENS begin ?depth ?dup while postpone then +; repeat -bal ;immediate + + hdr 1,'THENS',1,1 +thens: call docol +thens1 dw qdep + dw qdup + dw zbran,thens2 + dw then + dw bran,thens1 +thens2 dw dbal + dw exit + + endif + +; Eaker/ANS CASE support + +; OF ( -- addr ) postpone (of) >mark ;immediate + + hdr 1,'OF',1,1 +of: call docol + dw comp,pof + dw fmark + dw exit + +; ENDOF ( addr1 -- addr2 ) aka else endof + + hdr 1,'ENDOF',1,,elsee +endof equ elsee + +; CASE ( -- sys ) aka cond case + + hdr 1,'CASE',1,,cond +casee equ cond + +; ENDCASE ( sys -- ) postpone drop postpone thens +; ;immediate + + hdr 1,'ENDCASE',1,1 +endc: call docol + dw comp,drop + dw thens + dw exit + +; [ELSE] ( -- ) 1 begin token 2dup upper dup if 2dup +; s" [IF]" compare if 2dup s" [ELSE]" +; compare if s" [THEN]" compare 0= else +; 2drop dup 1 = then else 2drop 1 then + +; else 2drop refill and then ?dup 0= until +; ;immediate + + hdr 1,'[ELSE]',1,1 +pels: call docol + dw one +pels1 dw token + if ucase + dw tdup,upper + endif + dw dupp + dw zbran,pels6 + dw tdup + dw psqot + dcs '[IF]' + dw cmpp + dw zbran,pels4 + dw tdup + dw psqot + dcs '[ELSE]' + dw cmpp + dw zbran,pels2 + dw psqot + dcs '[THEN]' + dw cmpp,zequ + dw bran,pels3 +pels2 dw tdrop + dw dupp,one,equal +pels3 dw bran,pels5 +pels4 dw tdrop,one +pels5 dw plus + dw bran,pels7 +pels6 dw tdrop + dw refil,andd +pels7 dw qdup,zequ + dw zbran,pels1 + dw exit + +; [IF] ( flag -- ) 0= if postpone [else] then ;immediate + + hdr 1,'[IF]',1,1 +pif: pop cx + jcxz pels + nextt + +; [THEN] ( -- ) aka noop [then] immediate + + hdr 1,'[THEN]',1,,noop +pthen equ next + +; +; Numeric Output +; +; (U.) (D.) U. D. U.R D.R .R (.) ? . +; + +; (U.) ( u -- ) 0 (d.) + + hdr 1,'(U.)' +pudot: sub ax,ax + push ax +; jmp pddot + +; (D.) ( d -- c-addr u ) tuck dabs <# #s rot sign #> + + hdr 1,'(D.)' +pddot: call docol + dw tuck + dw dabs + dw bdigs + dw digs + dw rot,sign + dw edigs + dw exit + +; U. ( u -- ) 0 d. + + hdr 1,'U.' +udot: sub ax,ax + push ax +; jmp ddot + +; D. ( d -- ) (d.) type space + + hdr 1,'D.' +ddot: call docol + dw pddot +ddot1 dw typee,space + dw exit + +; U.R ( u1 u2 -- ) 0 swap d.r + + hdr 1,'U.R' +udotr: pop ax + sub dx,dx + push dx + push ax +; jmp ddotr + +; D.R ( d n -- ) >r (d.) r> s.r + + hdr 1,'D.R' +ddotr: call docol + dw tor + dw pddot +ddotr1 dw fromr + dw sdotr + dw exit + +; .R ( n u -- ) >r s>d r> d.r + + hdr 1,'.R' +dotr: pop bx + pop ax + cwd + push ax + push dx + push bx + jmp ddotr + +; (.) ( n -- ) s>d (d.) + + hdr 1,'(.)' +pdot: call docol + dw stod,pddot + dw exit + +; ? ( addr -- ) @ . + + hdr 1,'?' +ques: pop bx + push [bx] +; jmp dot + +; . ( x -- ) decimal? if s>d d. end u. + + hdr 1,'.' +dot: call docol + dw dcmq + dw zbran,dot1 + dw stod,ddot + dw exit +dot1 dw udot + dw exit + +; DOSVER ( -- minor major ) + + hdr 1,'DOSVER' +dosver: mov bx,offset dosv + jmp tat1 + + cseg + +regs dw 10 dup (?) ; cpu registers + +; DOSCALL ( u -- ) + + hdr 1,'DOSCALL' +dosc: pop ax + mov byte ptr regs+1,al + mov regs+14,ds + mov al,21h + ignore1 + +; INTCALL ( u -- ) + + hdr 1,'INTCALL' +intc: pop ax + push si + push bp + push cs + mov byte ptr intc1+1,al + mov si,offset regs + lodsw + push ax ; AX + lodsw + mov bx,ax + lodsw + mov cx,ax + lodsw + mov dx,ax + lodsw + mov bp,ax + lodsw + push ax ; SI + lodsw + mov di,ax + lodsw + push ax ; DS + lodsw + mov es,ax + pop ds + pop si + pop ax + mov cs:fssav,sp +intc1: int 0 ; NOTE: self-modifying code + cli + mov ss,cs:cseg1 ; restore SS:SP + mov sp,cs:fssav ; for DOS 2.x + sti + pushf + push es + push di + push cs + pop es + mov di,offset regs + cld + stosw + mov ax,bx + stosw + mov ax,cx + stosw + mov ax,dx + stosw + mov ax,bp + stosw + mov ax,si + stosw + pop ax ; DI + stosw + mov ax,ds + stosw + pop ax ; ES + stosw + pop ax ; flags + stosw + pop ds + pop bp + pop si + nextt + + hdr 1,'''FLAGS' +tfl: mov al,18 + ignore2 + + hdr 1,'''ES' +tes: mov al,16 + ignore2 + + hdr 1,'''DS' +tds: mov al,14 + ignore2 + + hdr 1,'''DI' +tdi: mov al,12 + ignore2 + + hdr 1,'''SI' +tsi: mov al,10 + ignore2 + + hdr 1,'''BP' +tbp: mov al,8 + ignore2 + + hdr 1,'''DH' +tdh: mov al,7 + ignore2 + + hdr 1,'''DX' +tdx: mov al,6 + ignore2 + + hdr 1,'''CH' +tch: mov al,5 + ignore2 + + hdr 1,'''CX' +tcx: mov al,4 + ignore2 + + hdr 1,'''BH' +tbh: mov al,3 + ignore2 + + hdr 1,'''BX' +tbx: mov al,2 + ignore2 + + hdr 1,'''AH' +tah: mov al,1 + ignore2 + + hdr 1,'''AX' +tax: mov al,0 + cbw + add ax,offset regs + jmp apush + +; DOSERR? ( -- ior ) 'flags @ 1 and if 'ax @ else 0 then + + hdr 1,'DOSERR?' +doserr: test byte ptr regs+18,1 + jz doserr2 + mov ax,regs + stc + +; test for DOS error + +doserr1:jnc doserr2 + mov ah,0feh ; convert DOS error# to ior value + jmp apush + +doserr2:jmp zero + +; Port fetch and store instructions + +; PC@ ( p-addr -- 8bit ) + + hdr 1,'PC@' ; FIG P@ +pcat: pop dx + sub ax,ax + in al,dx + push ax + nextt + +; PC! ( 8bit p-addr -- ) + + hdr 1,'PC!' ; FIG P! +pcsto: pop dx + pop ax + out dx,al + nextt + +; P@ ( p-addr -- 16bit ) + + hdr 1,'P@' +pat: pop dx + in ax,dx + push ax + nextt + +; P! ( 16bit p-addr -- ) + + hdr 1,'P!' +psto: pop dx + pop ax + out dx,ax + nextt + +; TICKS ( -- d ) + + hdr 1,'TICKS' +ticks: call tod + jmp dpush + +; WAIT-TICK ( -- ) + + hdr 1,'WAIT-TICK' +wtick: call tsync + nextt + +; (/MS) ( -- ) detect timer0 mode and adjust MS + + hdr x,'(/MS)' +psms: mov ax,nmscon ; assume mode 3 + mov word ptr ms5,ax + mov ntmode,3 + call tsync ; sync to tick timer + push dx ; TOD + push ax + mov cx,280 ; wait ~5 ticks + call ms1 + call tod + pop cx + cmp ax,cx + jnc psms1 + add dx,0b0h ; midnight crossed +psms1: pop ax + sub dx,ax + cmp dx,8 + jc psms2 + sar word ptr ms5,1 ; was mode 2 + dec ntmode +psms2: nextt + +; /MS ( -- ) detect timer0 mode and adjust MS + + hdr 1,'/MS' +smss: call aexec + dw psms + +; (BEEP) ( -- ) + + hdr x,'(BEEP)' +beep0: mov ax,75 + push ax + mov cx,600 + call sound1 + +; (MS) ( ms -- ) + + hdr x,'(MS)' +ms0: pop cx + push tnext1 + +; delay (ms) in CX ; uses timer 0 + +ms1: jcxz ms6 +ms2: push cx + test cl,3 ; PAUSE each 4mS for + jnz ms3 ; multitasking + call docol + dw pause + dw exit1 +ms3: call ms7 + mov cx,bx +ms4: call ms7 + sub bx,cx + cmp bx,-2386 ; patched by COLD + +ms5 equ $-cw + + jnc ms4 + pop cx + loop ms2 +ms6: ret + + if ints + +ms7: pushf + cli + sub al,al + out 43h,al + iodelay + in al,40h + mov bl,al + iodelay + in al,40h + mov bh,al + popf + ret + + else + +ms7: push ds + sub bx,bx + mov ds,bx +ms8: mov bx,ds:[046ch] + sub al,al + out 43h,al + iodelay + in al,40h + mov ah,al + iodelay + in al,40h + cmp bx,ds:[046ch] + jnz ms8 + mov bh,al + mov bl,ah + pop ds + ret + + endif + +; (SOUND) ( freq ms -- ) + + hdr x,'(SOUND)' +sound0: pop ax + pop cx + push tnext1 + +sound1: push ax ; uses timer 2 + mov dx,12h + cmp dx,cx + jnc sound2 ; trap zero/overflow + mov ax,34ddh + div cx + mov cx,ax + in al,61h + or al,3 ; enable spkr + iodelay + out 61h,al + mov al,0b6h ; set mode 3 + out 43h,al + mov al,cl + iodelay + out 42h,al + mov al,ch + iodelay + out 42h,al +sound2: pop cx + call ms1 + in al,61h + and al,0fch ; disable spkr + iodelay + out 61h,al + ret + +; MS ( ms -- ) + + hdr 1,'MS' +ms: call aexec + dw ms0 + +; SOUND ( freq ms -- ) + + hdr 1,'SOUND' +sound: call aexec + dw sound0 + +; BEEP ( -- ) + + hdr 1,'BEEP' +beep: call aexec + dw beep0 + +; AT-XY ( x y -- ) position cursor at col x, row y + + hdr 1,'AT-XY' ; not bounds checked - allows any +atxy: pop ax ; BIOS permissible value + pop dx + mov dh,al + add dl,wmin + add dh,wmin+1 +atxy1: call scurs + nextt + +; GET-XY ( -- x y ) get cursor position col x, row y + + hdr 1,'GET-XY' +getxy: call gcurs + sub dl,wmin + sub dh,wmin+1 +getxy1: sub ax,ax + xchg al,dh + jmp dpush + +; SET-WINDOW ( x1 y1 x2 y2 -- ) + + hdr 1,'SET-WINDOW' +setwin: pop ax + pop cx + mov ch,al + pop ax + pop dx + mov dh,al + mov word ptr wmin,dx + mov word ptr wmax,cx + jmp atxy1 + +; GET-WINDOW ( -- x1 y1 x2 y2 ) + + hdr 1,'GET-WINDOW' +getwin: mov dx,word ptr wmin + sub ax,ax + xchg al,dh + push dx + push ax + mov dx,word ptr wmax + jmp getxy1 + +; ATTRIB ( -- addr ) address of video attribute byte + + hdr 1,'ATTRIB' +attrib: call docon + dw cattr + +; FOREGROUND ( u -- ) 0-15 + + hdr 1,'FOREGROUND' +fg: pop ax + and al,0fh + and byte ptr cattr,0f0h +fg1: or cattr,al + nextt + +; BACKGROUND ( u -- ) 0-7 + + hdr 1,'BACKGROUND' +bg: pop ax + and al,7 + mov cl,4 + shl al,cl + and byte ptr cattr,8fh + jmp fg1 + +; COLOR-TABLE ( -- addr ) default colors + + hdr 1,'COLOR-TABLE' +clrtbl: call docre +dnorm db 07h ; normal +dinver db 70h ; inverse +dbold db 03h ; bold +dbrite db 0Bh ; bright + +; NORMAL ( -- ) + + hdr 1,'NORMAL' +vnorm: mov al,dnorm +vnorm1: mov cattr,al + nextt + +; INVERSE ( -- ) + + hdr 1,'INVERSE' +vinver: mov al,dinver + jmp vnorm1 + +; BOLD ( -- ) + + hdr 1,'BOLD' +vbold: mov al,dbold + jmp vnorm1 + +; BRIGHT ( -- ) + + hdr 1,'BRIGHT' +vbrite: mov al,dbrite + jmp vnorm1 + +; CLEAR-LINE ( -- ) + + hdr 1,'CLEAR-LINE' +cleol: call gcurs + mov ax,0600h + mov cx,dx + mov dl,wmax +cleol1: call videoa + nextt + +; INSERT-LINE ( -- ) + + hdr 1,'INSERT-LINE' +insln: mov ax,0701h +insln1: push ax + call gcurs + pop ax + mov ch,dh + mov cl,wmin + mov dx,word ptr wmax + jmp cleol1 + +; DELETE-LINE ( -- ) + + hdr 1,'DELETE-LINE' +delln: mov ax,0601h + jmp insln1 + +; PAUSE ( -- ) + + hdr 1,'PAUSE' ; multitasking support +pause: call aexec +pause1 dw 0 ; patched by COLD + +; bios console key test (AL) + + cseg + +bconq: cmp byte ptr kbpend,0 + jnz bconq1 + mov ah,kbfn+1 + int 16h +bconq1: mov al,0 + jz bconq2 + dec al +bconq2: ret + +; dos console key test (AL) + + cseg + +dconq: mov ah,0bh + int 21h + ret + +; bios console in (AL) + + cseg + +bconi: sub al,al + xchg al,kbpend + or al,al + jnz bconi2 + mov ah,kbfn + int 16h + or al,al + jz bconi1 + cmp al,80h ; needed when using + jc bconi2 ; INT16 AH=10h + sub al,al ; +bconi1: mov kbpend,ah + or ah,ah + jnz bconi2 + mov al,3 +bconi2: ret + +; dos console in (AL) + + cseg + +dconi: mov ah,8 ; allow ctl-C/Break + int 21h + ret + +; dos console out (AL) + + cseg + +dcono: mov ah,2 ; allow ctl-C/Break + mov dl,al + int 21h + ret + +; bios console out (AL) + + cseg + +bcono: push ax + call gcurs + pop ax + cmp al,bel ; BEL + jz bcono3 + cmp al,bs + jz bcono5 + cmp al,cr ; CR + jz bcono4 + cmp al,lf ; LF + jz bcono1 + cmp al,tab ; TAB + jz bcono6 + mov ah,9 + mov bl,cattr + mov cx,1 + push dx + call videop + pop dx + inc dl + cmp dl,wmax + jna bcono2 + mov dl,wmin +bcono1: inc dh + cmp dh,wmax+1 + jna bcono2 + dec dh + push cx + push dx + mov ax,0601h + mov cx,word ptr wmin + mov dx,word ptr wmax + call videoa + pop dx + pop cx +bcono2: jmp scurs + +bcono3: mov ah,0eh + call videop + jmp bcono2 + +bcono4: mov dl,wmin +bcono5: cmp dl,wmin + jz bcono2 + dec dl + jmp bcono2 + +bcono6: sub dl,wmin + and dl,7 + mov al,8 + sub al,dl +bcono7: push ax + mov al,20h + call bcono + pop ax + dec al + jnz bcono7 + jmp bcono2 + + cseg + +iofn dw biosfn + +biosfn dw bconq ; bios functions + dw bconi + dw bcono + +dosfn dw dconq ; dos functions + dw dconi + dw dcono + +; BIOS-IO ( -- ) use BIOS for I/O calls + + hdr 1,'BIOS-IO' +biosio: mov ax,offset biosfn +biosio1:mov iofn,ax + mov byte ptr kbpend,0 + nextt + +; DOS-IO ( -- ) use DOS for I/O calls + + hdr 1,'DOS-IO' +dosio: mov ax,offset dosfn + jmp biosio1 + +; ?terminal ( -- flag ) + + hdr x,'?TERMINAL' +qterm: mov bx,iofn + call [bx] + cbw + jmp apush + +; KEY? ( -- flag ) (vkeyq) @execute pause + + hdr 1,'KEY?' +keyq: call docol + dw lit,vkeyq + dw aexec + dw pause + dw exit + +; pckey ( -- char ) + + hdr x,'PCKEY' +pckey: mov bx,iofn + call [bx+cw] + sub ah,ah + jmp apush + +; conin ( -- char ) begin key? until pckey dup 0= +; if drop pckey 128 + then + + hdr x,'CONIN' +conin: call docol +conin1 dw keyq + dw zbran,conin1 + dw pckey + dw dupp,zequ + dw zbran,conin2 + dw drop + dw pckey + dw clit + db 128 + dw plus +conin2 dw exit + +; KEY ( -- char ) (vkey) @execute pause + + hdr 1,'KEY' +key: call docol + dw lit,vkey + dw aexec + dw pause + dw exit + +; cls ( -- ) home cursor and clear-screen sequence + + cseg + +cls: mov ax,0600h + mov cx,word ptr wmin + push cx + mov dx,word ptr wmax + call videoa + pop dx + call scurs + nextt + +; conout ( char -- ) + + hdr x,'CONOUT' +conout: pop ax + cmp al,ff ; FF + jz cls + mov bx,iofn + call [bx+cw*2] + nextt + +; lstout ( char -- ) + + hdr x,'LSTOUT' +lstout: pop dx + mov ah,5 + int 21h + nextt + +; PAGE ( -- ) 12 emit + + hdr 1,'PAGE' +pagee: mov al,ff ; formfeed char + ignore2 + +; SPACE ( -- ) 32 emit + + hdr 1,'SPACE' +space: mov al,20h + sub ah,ah + push ax +; jmp emit + +; EMIT ( char -- ) (vemit) @execute 1 out +! pause + + hdr 1,'EMIT' +emit: call docol + dw lit,vemit + dw aexec + dw one,outt,pstor + dw pause + dw exit + +; TYPE ( c-addr n -- ) 0max 0 ?do count emit loop drop + + hdr 1,'TYPE' +typee: call docol + dw zmax,zero + dw xqdo,typee2 +typee1 dw count,emit + dw xloop,typee1 +typee2 dw drop + dw exit + +; SPACES ( n -- ) 0max 0 ?do space loop + + hdr 1,'SPACES' +spacs: call docol + dw zmax,zero + dw xqdo,spacs2 +spacs1 dw space + dw xloop,spacs1 +spacs2 dw exit + +; EOL ( -- c-addr u ) ' count build EOL 2 c, $0D c, $0A c, 0 c, + + hdr 1,'EOL' +eol: call count + db 2,cr,lf,0 + +; CR ( -- ) eol type out off + + hdr 1,'CR' +crr: call docol + dw eol,typee + dw outt,off + dw exit + +; CONSOLE ( -- ) (vcon) @ (vemit) ! + + hdr 1,'CONSOLE' ; set EMIT to terminal +consol: mov ax,vcon + mov vemit,ax + nextt + +; PRINTER ( -- ) (vlst) @ (vemit) ! + + hdr 1,'PRINTER' ; set EMIT to printer +prnt: mov ax,vlst + mov vemit,ax + nextt + +; UPCASE ( char1 -- char2 ) + + hdr 1,'UPCASE' ; make char uppercase +upcas: pop ax + call upc + jmp apush + +; UPPER ( c-addr u -- ) + + hdr 1,'UPPER' ; make string uppercase +upper: pop cx + pop bx + jcxz upper2 +upper1: mov al,[bx] + call upc + mov [bx],al + inc bx + loop upper1 +upper2: nextt + +; CONTEXT ( -- addr ) + + hdr 1,'CONTEXT',,1 +cont: call docre +acont dw ? ; context +acurr dw ? ; current + dw forth1 ; forth + +; get-context ( -- wid ) + + hdr x,'GET-CONTEXT',,1 +getcon: push acont + nextt + +; GET-CURRENT ( -- wid ) + + hdr 1,'GET-CURRENT',,1 +getcur: push acurr + nextt + +; SET-CURRENT ( wid -- ) + + hdr 1,'SET-CURRENT',,1 +setcur: pop acurr + nextt + +; wfind ( c-addr wid -- 0 | xt nfa -1 | xt nfa 1 ) + + hdr x,'WFIND',,1 +wfind: pop bx + pop di + or bx,bx ; wid=0 + jz wfind5 + mov al,[di] + inc di + mov dx,di + cmp al,31+1 ; in range? + jnc wfind5 + or al,al + jz wfind5 + sub ch,ch + mov bx,[bx] + mov es,hseg1 +wfind1: mov bx,es:[bx] + or bx,bx ; end of list? + jz wfind5 + mov di,bx + mov ah,es:[bx] ; nfa + inc bx + mov cl,ah + and cl,31 ; word length + cmp cl,al + jz wfind3 +wfind2: add bx,cx ; move to link + jmp wfind1 + +wfind3: test ah,20h ; smudged? + jnz wfind2 + push si + push di + mov si,dx + mov di,bx + if ucase + call cmpnc + else + rep cmpsb + endif + mov cl,al + pop di + pop si + jnz wfind2 + add bx,cx + push es:[bx+cw] ; xt + push di ; nfa + and ah,40h ; immediate? + jnz wfind4 + jmp true + +wfind4: jmp one + +wfind5: jmp zero + +; (find) ( c-addr -- c-addr 0 | xt -1 | xt 1 ) +; 0 3 0 ?do over i cells context + @ +; wfind ?dup if nip 2nip leave then loop + + hdr x,'(FIND)',,1 +pfind: call docol + dw zero + dw three + dw zero + dw xqdo,pfind3 +pfind1 dw over + dw ido,cells + dw cont + dw plus,at + dw wfind,qdup + dw zbran,pfind2 + dw nip,tnip + dw pleav,pfind1-cw +pfind2 dw xloop,pfind1 +pfind3 dw exit + +; FIND ( c-addr -- c-addr 0 | xt -1 | xt 1 ) + + hdr 1,'FIND',,1 +find: call aexec + dw pfind + + if 0 + +; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt -1 | xt 1 ) +; >r wpack r> wfind dup if nip then + + hdr 1,'SEARCH-WORDLIST',,1 +swlis: call docol + dw tor + dw wpack + dw fromr + dw wfind + dw dupp + dw zbran,swlis1 + dw nip +swlis1 dw exit + + endif + + if wopt + +; -? ( -- ) warning @ 0fffe and warning ! + + hdr 1,'-?',,1 ; disable warnings for next definition only +dques: and byte ptr warnn1,0feh ; clear bit 0 + nextt + +; warning? ( -- 0|1 ) warning @ dup if 1 and $7FFF over 0<> or +; warning ! then + + hdr x,'WARNING?',,1 ; get warning flag and apply mask +qwarn: call docol + dw warnn,at + dw dupp + dw zbran,qwarn1 + dw one,andd ; test redefinition warning + dw lit,7fffh ; disable system warning + dw over,zneq ; else enable all warnings + dw orr + dw warnn,store +qwarn1 dw exit + + endif + +; header ( xt|0 "name" -- ) +; warning? 2>r dph @ (hm-64) u> +; abort" no name space" cseg bl-word dup +; c@ 32 1 within abort" invalid name" dup +; find nip r> and if over count type +; ." is redefined " then hseg over count +; tuck + get-current w>name over ! cell+ +; swap 5 + dph @ over dph +! dup get-current +; @ h! rot r> ?dup 0= if here then dup rot ! +; over last 2! swap cmovel + + hdr x,'HEADER',,1 +headr: call docol + if wopt + dw qwarn + else + dw warnn,at + endif + dw ttor + dw dph,at + dw lit,hm-64 + dw ugrea + dw pabq + dcs 'no name space' + dw csegg + dw blword + dw dupp,cat + dw clit + db 32 + dw one,within + dw pabq + dcs 'invalid name' + dw dupp,find,nip + dw fromr,andd + dw zbran,headr1 + dw dupp,count,typee + dw pdotq + dcs ' is redefined ' +headr1 dw hseg + dw over,count + dw tuck + dw plus + dw getcur,wtnam + dw over,store + dw cellp,swap + dw clit + db 5 + dw plus + dw dph,at + dw over,dph,pstor + dw dupp + dw getcur + dw at,hstor ; MS-DOS version + dw rot + dw fromr,qdup,zequ + dw zbran,headr2 + dw here +headr2 dw dupp,rot,store + dw over,last,tstor + dw swap,cmovl + dw exit + +; ,call ( addr -- ) $E8 c, here 2+ - , + + hdr x,',CALL',,1 +comcall:call docol + dw clit + db 0e8h ; 'call' opcode + dw ccomm + dw here,twop,subb ; relative for 8086 + dw comma + dw exit + +; CREATE ( -- addr ) 'next build + + hdr 1,'CREATE',,1 +creat: push tnext1 +; jmp build + +docre equ next + +; BUILD ( xt "name" -- ) 0 header ,call + + hdr 1,'BUILD',,1 +build: call docol + dw zero,headr + dw comcall + dw exit + +; : ( -- ) (docol) build smudge bal off sp@ dup +; csp 2! ] + + hdr 1,':',,1 +colon: call docol + dw lit,docol + dw build + dw smudg +colon1 dw bal,off + dw spat,dupp + dw cspp,tstor + dw rbrac + dw exit + +; ; ( -- ) postpone exit bal @ ?bal ?csp smudge +; postpone [ ;immediate + + hdr 1,';',1,1 +semic: call docol + dw comp,exit + dw bal,at + dw qbal + dw qcsp + dw smudg + dw lbrac + dw exit + +; :NONAME ( -- xt ) warning? drop here dup (dnfa) last 2! +; (docol) ,call bal off sp@ dup csp 2! ] + + hdr 1,':NONAME',,1 +nonam: call docol + if wopt + dw qwarn,drop ; allow -? + endif + dw here + dw dupp ; allow RECURSE + dw lit,dnfa-horig ; allow IMMEDIATE + dw last,tstor + dw lit,docol + dw comcall + dw bran,colon1 + +; (;CODE) last cell+ @ 1+ r> over 2+ - swap ! + + hdr 1,'(;CODE)',,1 +pscod: mov bx,last2 + inc bx + sub si,bx ; relative for 8086 + dec si ; + dec si ; + mov [bx],si + jmp exit + +; DOES> postpone (;code) (docol) ,call ;immediate + + hdr 1,'DOES>',1,1 +does: call docol + dw comp,pscod + dw lit,docol + dw comcall + dw exit + +; VARIABLE ( -- addr ) create 2 allot + + hdr 1,'VARIABLE',,1 +var: call docol + dw creat + dw two,allot + dw exit + +; VALUE ( -- x ) (doval) build , + + hdr 1,'VALUE',,1 +value: call docol +value1 dw lit,doval + dw build + dw comma + dw exit + +doval equ at + +; CONSTANT ( -- x ) char? if (docco) build c, +; else value then + + hdr 1,'CONSTANT',,1 +con: call docol + dw charq + dw zbran,value1 + dw lit,docco + dw build + dw ccomm + dw exit + +docon equ at +docco equ cat + +; 2VARIABLE ( -- addr ) create 4 allot + + hdr 1,'2VARIABLE',,1 +tvar: call docol + dw creat + dw clit + db 4 + dw allot + dw exit + +dotvar equ next + +; 2CONSTANT ( -- x2 x1 ) (dotcon) build , , + + hdr 1,'2CONSTANT',,1 +tcon: call docol + dw lit,dotcon + dw build + dw comma,comma + dw exit + +dotcon equ tat + +; USER ( -- addr ) (douse) build , + + hdr 1,'USER',,1 ; FIG +user: call docol + dw lit,douse + dw build + dw comma + dw exit + +; ADDR ( -- addr ) ' >body state? if postpone literal then +; ;immediate + + hdr 1,'ADDR',1,1 ; state-smart +addr: call docol + dw tick,tbody + dw stateq + dw zbran,addr1 + dw liter +addr1 dw exit + +; (to) ( x -- ) r> dup cell+ >r @ >body ! + + hdr x,'(TO)' +pto: lodsw + mov bx,ax + pop [bx+3] + nextt + +; TO ' state? if postpone (to) , else >body ! +; then ;immediate + + hdr 1,'TO',1,1 ; state-smart +to: call docol + dw tick + dw stateq + dw zbran,to1 + dw comp,pto + dw comma + dw bran,to2 +to1 dw tbody,store +to2 dw exit + + cseg + +undef: call docol + dw one + dw pabq + dcs 'uninitiated DEFER' + +; DEFER ( -- ) ['] @execute build (undef) , + + hdr 1,'DEFER',,1 +defer: call docol + dw lit,aexec + dw build + dw lit,undef + dw comma + dw exit + +; IS aka to is + + hdr 1,'IS',1,,to ; state-smart +is equ to + +pis equ pto + +; AKA ( "oldname" "newname" -- ) defined tuck ?defined header +; $80 xnfa 0> if immediate then + + hdr 1,'AKA',,1 +aka: call docol + dw defined + dw tuck,qdef + dw headr ; equivalent of + dw clit ; ALIAS ( xt "newname" -- ) + db 80h ; + dw xnfa ; + dw zgrea + dw zbran,aka1 + dw immed +aka1 dw exit + +; Constants + +; TRUE ( -- -1 ) + + hdr 1,'TRUE' +true: mov ax,-1 + push ax + nextt + +; FALSE ( -- 0 ) + + hdr 1,'FALSE' +false: sub ax,ax + push ax + nextt + +; -1 ( -- -1 ) aka true -1 + + hdr 1,'-1',,,true + +; 0 ( -- 0 ) aka false 0 + + hdr 1,'0',,,false +zero equ false + +; 1 ( -- 1 ) + + hdr 1,'1' +one: call docco + db 1 + +; 2 ( -- 2 ) + + hdr 1,'2' +two: call docco + db 2 + +; 3 ( -- 3 ) + + hdr 1,'3' +three: call docco + db 3 + +; BL ( -- 32 ) ascii value for space character + + hdr 1,'BL' +bll: call docco + db 32 + +; B/BUF ( -- u ) bytes per screen buffer + + hdr 1,'B/BUF',,1 ; FIG +bbuf: call doval +bbuf1 dw 128*8 ; default + +; C/L ( -- u ) chars per screen line + + hdr 1,'C/L',,1 ; FIG +csll: call doval + dw 64 ; default + +; For applications, LIMIT is the upper limit of available memory. +; In forth, it is the beginning of the area which holds the screen +; file buffer, word headers and system definitions. + +; LIMIT ( -- addr ) + + hdr 1,'LIMIT' ; FIG +limit: call docon ; application word - used by COLD +limit1 dw ? ; patched on startup + +; HLIMIT ( -- addr ) + + hdr 1,'HLIMIT',,1 ; upper limit of heads memory +hlimit: call docon + dw hm + +; 'NEXT ( -- addr ) address of NEXT + + hdr 1,"'NEXT" +tnext: call docon +tnext1 dw next + +; SYS-VEC ( -- addr ) system vector table + + hdr 1,'SYS-VEC' +sysvec: call docre + +vkeyq dw qterm ; 0 KEY? +vkey dw conin ; 2 KEY +vemit dw conout ; 4 EMIT +vcon dw conout ; 6 CONSOLE out +vlst dw lstout ; 8 PRINTER out +ainit dw pinit ; 10 INIT patch +aident dw piden ; 12 IDENTIFY patch +afnumb dw pfnum ; 14 FNUMBER patch +nfps dw fps ; 16 fp-stack size (bytes) +anumb dw pnumb ; 18 NUMBER? patch +nfpm dw fnum*fw ; 20 fp-stack min (bytes) +nrts dw rts ; 22 return stack (bytes) +nus dw us ; 24 user area (bytes) +npno dw pno ; 26 HOLD buffer size (bytes) +nmscon dw -2386 ; 28 MS timing constant +ntmode dw 3 ; 30 Timer 0 mode + +; Variables + +; UP ( -- addr ) user area pointer + + hdr 1,'UP' +up: call docre +upp dw ? + +; FSP ( -- addr ) fp stack pointer + + hdr 1,'FSP' +fsp: call docre +fspp dw ? + +; boot ( -- addr ) boot word (holds forth/application xt) + + hdr x,'BOOT' +boot: call docre +boot1 dw 0 ; xt +boot2 dw 0 ; 0=forth + +; SYS ( -- addr ) compile to system or application + + hdr 1,'SYS' +sys: call docre ; application word - used by HERE UNUSED +sys1 dw 0 + +; LAST ( -- addr ) occupies 2 cells + + hdr 1,'LAST',,1 +last: call docre +last1 dw topnfa ; latest nfa +last2 dw topxt ; latest xt + +; BLK + + hdr 1,'BLK',,1 +blk: call docre +blk1 dw ? + +; >IN + + hdr 1,'>IN',,1 +inn: call docre +inn1 dw ? + +; 'SOURCE occupies 2 cells + + hdr 1,'''SOURCE',,1 +tsourc: call docre +tsour1 dw ?,? + +; STATE + + hdr 1,'STATE',,1 +state: call docre +state1 dw ? + +; SCR ( -- addr ) occupies 2 cells + + hdr 1,'SCR',,1 +scr: call docre + dw ?,? ; screen number, offset + +; WARNING + + hdr 1,'WARNING',,1 ; FIG +warnn: call docre +warnn1 dw ? + +; CSP ( -- addr ) occupies 2 cells + + hdr 1,'CSP',,1 ; FIG +cspp: call docre +cspp1 dw ? ; current stack pointer +cfz1 dw ? ; control flow stack base + +; CHECKING + + hdr 1,'CHECKING',,1 +check: call docre +check1 dw ? + +; errmsg ( -- addr ) message holder for abort" + + hdr x,'ERRMSG' +errmsg: call docre + dw ?,? + +; zbuf ( -- addr ) filename buffer pointers + + hdr x,'ZBUF' +zbuf: call docre +zbuf1 dw zb1 ; next buffer + dw zb2 ; last buffer + +; User Variables + +; bytes 0-5 reserved for multitasking + +; S0 + + hdr 1,'S0' ; FIG +szero: call douse + dw 6 + +; R0 + + hdr 1,'R0' ; FIG +rzero: call douse + dw 8 + +; DP application dictionary pointer + + hdr 1,'DP' ; FIG +dpp: call douse + dw 10 + +; dps system dictionary pointer + + hdr x,'DPS',,1 ; must follow DP +dps: call douse + dw 12 + +; VOC-LINK + + hdr 1,'VOC-LINK',,1 ; FIG +vocl: call douse + dw 14 + +; FS0 + + hdr 1,'FS0' +fszero: call douse + dw 16 + +; DPH ( -- addr ) heads dictionary pointer + + hdr 1,'DPH',,1 +dph: call douse + dw 18 + +; End of boot-up literals + +; bytes 20-21 reserved for locals + +; CATCHER + + hdr 1,'CATCHER' +catchr: call douse + dw 22 + +; BASE + + hdr 1,'BASE' +base: call douse + dw 24 + +; hld + + hdr x,'HLD' ; FIG +hld: call douse + dw 26 + +; DPL + + hdr 1,'DPL' ; FIG +dpl: call douse + dw 28 + +; OUT + + hdr 1,'OUT' ; FIG +outt: call douse + dw 30 + +; User area bytes #USER onwards are available for user applications + +; #USER ( -- +n ) + + hdr 1,'#USER',,1 +nusr: call doval + dw 32 + +; sys? ( -- flag ) sys @ 0<> + + hdr x,'SYS?' +sysq: push word ptr sys1 + jmp zneq + +; state? ( -- flag ) state @ 0<> + + hdr x,'STATE?',,1 +stateq: push word ptr state1 + jmp zneq + +; check? ( -- flag ) checking @ 0<> + + hdr x,'CHECK?',,1 +chkq: push word ptr check1 + jmp zneq + +; APPLICATION ( -- ) sys off + + hdr 1,'APPLICATION' +app: mov bx,offset sys1 + jmp off1 + +; SYSTEM ( -- ) sys on + + hdr 1,'SYSTEM',,1 +system: mov bx,offset sys1 + jmp on1 + +; h ( -- addr ) sys @ if dps else dp then + + hdr x,'H' +hh: mov ax,sys1 + or ax,ax + jnz hh1 + jmp dpp +hh1: jmp dps + +; HERE ( -- addr ) h @ + + hdr 1,'HERE' +here: call docol + dw hh,at + dw exit + +; ALLOT ( u -- ) here over dup unused u> +; abort" no data space" erase h +! + + hdr 1,'ALLOT' ; non-standard +allot: call docol + dw here,over + dw dupp,unus,ugrea + dw pabq + dcs 'no data space' + dw erase +allot1 dw hh,pstor + dw exit + +; -ALLOT ( u -- ) negate h +! + + hdr 1,'-ALLOT' +dallot: call docol + dw negat + dw bran,allot1 + +; C, ( char -- ) here 1 allot c! + + hdr 1,'C,',,1 +ccomm: call docol + dw here + dw one,allot + dw cstor + dw exit + +; , ( x -- ) here 2 allot ! + + hdr 1,',',,1 +comma: call docol + dw here + dw two,allot + dw store + dw exit + +; >BODY ( xt -- addr ) 3 + + + hdr 1,'>BODY' +tbody: pop ax + add ax,3 + jmp apush + +; body> ( addr -- xt ) 3 - +; +; hdr x,'BODY>' +;fbody: pop ax +; sub ax,3 +; jmp apush + +; n>count ( nfa -- h-addr len ) dup 1+ swap hc@ 31 and + + hdr x,'N>COUNT',,1 +ncnt: pop bx + mov es,hseg1 + mov al,es:[bx] + inc bx + push bx + and ax,31 + jmp apush + +; n>link ( nfa -- lfa ) n>count + + + hdr x,'N>LINK',,1 +nlnk: call docol + dw ncnt,plus + dw exit + +; N>NAME ( nfa1 -- nfa2 | 0 ) n>link h@ + + hdr 1,'N>NAME',,1 +ntnam: call docol + dw nlnk,hat + dw exit + +; name> ( nfa -- xt ) n>link cell+ h@ + + hdr x,'NAME>',,1 +namef: call docol + dw nlnk,cellp + dw hat + dw exit + +; W>NAME ( wid -- nfa | 0 ) @ h@ + + hdr 1,'W>NAME',,1 +wtnam: pop bx + push [bx] + jmp hat + +; -alias ( nfa -- nfa flag ) dup hc@ $80 < + + hdr x,'-ALIAS',,1 ; false if alias +dalias: call docol + dw dupp,hcat + dw clit + db 80h + dw less + dw exit + +; >name ( xt -- nfa | 0 ) +; voc-link begin @ dup while tuck cell- w>name +; begin ?dup while -alias if 2dup name> = if +; -rot 2drop end then n>name repeat swap +; repeat nip + + hdr x,'>NAME',,1 +tnam: call docol + dw vocl +tnam1 dw at + dw dupp + dw zbran,tnam5 + dw tuck + dw cellm + dw wtnam +tnam2 dw qdup + dw zbran,tnam4 + dw dalias ; skip if alias + dw zbran,tnam3 + dw tdup,namef + dw equal + dw zbran,tnam3 + dw drot,tdrop + dw exit +tnam3 dw ntnam + dw bran,tnam2 +tnam4 dw swap + dw bran,tnam1 +tnam5 dw nip + dw exit ; not found + +; (NAME) ( nfa -- c-addr u ) n>count <# begin dup while +; 1- 2dup + hc@ hold repeat #> + + hdr 1,'(NAME)',,1 +pname: call docol + dw ncnt + dw bdigs +pname1 dw dupp + dw zbran,pname2 + dw onem + dw tdup,plus,hcat + dw hold + dw bran,pname1 +pname2 dw edigs + dw exit + +; .ID ( nfa | 0 -- ) ?dup if dup name> limit u< if (dnorm) else +; (dbold) then c@ over hc@ $40 and 3 rshift +; xor attrib c! (name) type normal end +; ." [noname]" + + hdr 1,'.ID',,1 +dotid: call docol + dw qdup + dw zbran,dotid3 + dw dupp,namef + dw limit,uless + dw zbran,dotid1 + dw lit,dnorm ; normal + dw bran,dotid2 +dotid1 dw lit,dbold ; bold +dotid2 dw cat + dw over,hcat + dw clit ; immediate? + db 40h + dw andd + dw three,rsh + dw xorr ; toggle bright + dw attrib,cstor + dw pname,typee + dw vnorm + dw exit +dotid3 dw pdotq + dcs '[noname]' + dw exit + +; .NAME ( xt -- ) >name .id + + hdr 1,'.NAME',,1 +dotnam: call docol + dw tnam,dotid + dw exit + +; .VOC ( wid -- ) cell+ cell+ @ .id + + hdr 1,'.VOC',,1 +dotvoc: pop bx + add bx,cw*2 + push [bx] + jmp dotid + +; !CSP ( -- ) sp@ csp ! + + hdr 1,'!CSP',,1 ; FIG +scsp: mov ax,sp + mov cspp1,ax + nextt + +; ?CSP ( -- ) sp@ csp @ - ?bal + + hdr 1,'?CSP',,1 ; FIG +qcsp: mov ax,cspp1 + sub ax,sp + push ax + jmp qbal + +; ?COMP ( -- ) state? 0= abort" compilation only" + + hdr 1,'?COMP',,1 ; FIG +qcomp: call docol + dw stateq + dw zequ + dw pabq + dcs 'compilation only' + dw exit + +; ?EXEC ( -- ) state? abort" execution only" + + hdr 1,'?EXEC',,1 ; FIG +qexec: call docol + dw stateq + dw pabq + dcs 'execution only' + dw exit + +; ?STACK ( -- ) sp@ s0 @ 1+ pad within abort" stack?" +; rp@ r0 @ 1+ fs0 @ within abort" r-stack?" +; fsp @ fs0 @ dup 1+ swap (nfpm) @ - within +; abort" f-stack?" + + hdr 1,'?STACK',,1 ; FIG +qstac: call docol + dw spat + dw szero,at + dw onep + dw pad + dw within + dw pabq + dcs 'stack?' + dw rpat + dw rzero,at + dw onep + dw fszero,at ; = S0 if no float + dw within + dw pabq + dcs 'r-stack?' + dw fsp,at + dw fszero,at + dw dupp,onep,swap + dw lit,nfpm + dw at + dw subb + dw within + dw pabq + dcs 'f-stack?' + dw exit + +; ?defined ( flag -- ) 0= abort" is undefined" + + hdr x,'?DEFINED',,1 +qdef: call docol + dw zequ + dw pabq + dcs 'is undefined' + dw exit + +; [ state off ;immediate + + hdr 1,'[',1,1 +lbrac: mov bx,offset state1 + jmp off1 + +; ] state on + + hdr 1,']',,1 +rbrac: mov bx,offset state1 ; must be -1 for INTERPRET to work + jmp on1 + +; (ACCEPT) ( c-addr +n1 -- +n2) +; 0 begin key dup >r dup bl 127 within 2over - +; and if dup emit over 4 pick + c! 1+ else 2dup +; dup 8 = swap esc = or and if esc = if 0 swap +; else 1- 1 then begin 8 dup emit space emit 1- +; dup 0= until then drop then r> 13 = until +; -rot 2drop + + hdr x,'(ACCEPT)' +pacce: call docol + dw zero +pacce1 dw key + dw dupp,tor + dw dupp,bll ; only accept chars between 32 and 126 + dw clit + db 127 + dw within + dw tover,subb + dw andd + dw zbran,pacce2 + dw dupp,emit + dw over + dw clit + db 4 + dw pick + dw plus + dw cstor + dw onep + dw bran,pacce6 +pacce2 dw tdup + dw dupp + dw clit + db bs ; backspace? + dw equal,swap + dw clit + db escape ; escape? + dw equal,orr + dw andd + dw zbran,pacce5 + dw clit + db escape ; escape? + dw equal + dw zbran,pacce3 + dw zero,swap + dw bran,pacce4 +pacce3 dw onem,one +pacce4 dw clit + db bs + dw dupp,emit + dw space,emit + dw onem + dw dupp,zequ + dw zbran,pacce4 +pacce5 dw drop +pacce6 dw fromr + dw clit + db cr ; cr? + dw equal + dw zbran,pacce1 + dw drot,tdrop + dw exit + +; ACCEPT ( c-addr +n1 -- +n2) + + hdr 1,'ACCEPT' +accept: call aexec + dw pacce + +; PAD ( -- addr ) dp @ (npno) @ + + + hdr 1,'PAD' +pad: mov bx,upp + mov ax,[bx+10] ; DP + add ax,npno + jmp apush + +; SOURCE ( -- c-addr u ) 'source 2@ + + hdr 1,'SOURCE',,1 +source: mov bx,offset tsour1 + jmp tat1 + +; PARSE ( char -- c-addr u ) 0 (parse) + + hdr 1,'PARSE',,1 +parse: sub ax,ax + push ax +; jmp ppars + +; (parse) ( char f -- c-addr u ) 2>r source >in @ /string r> if tuck +; r@ skip over - >in +! then 2dup r> +; scan nip tuck - dup rot 0<> - >in +! + + hdr 0,'(PARSE)',,1 +ppars: call docol + dw ttor + dw source + dw inn,at,sstr + dw fromr + dw zbran,ppars1 + dw tuck + dw rat,skip + dw rot,over,subb + dw inn,pstor +ppars1 dw tdup + dw fromr + dw scan,nip + dw tuck + dw subb,dupp + dw rot,zneq + dw subb + dw inn,pstor + dw exit + +; +psb ( a1 n1 n2 -- n3 ) >r (pssiz) r@ - umin r> 2dup + >r +; (psb) + swap cmove r> + + hdr x,'+PSB',,1 +ppsb: pop bx + pop cx + mov di,pssiz + sub di,bx + cmp di,cx + jnc ppsb1 + mov cx,di +ppsb1: mov di,offset orig+psb + add di,bx + add bx,cx + pop ax + push bx + jmp cmove1 + +; /PARSE ( char "ccc" -- a n ) 0 begin >r dup parse 2dup r> +psb >r +; 1+ + dup source + u< while 2dup c@ = +; while 1 dup >in +! r> +psb repeat +; then 2drop (psb) r> + + hdr 1,'/PARSE',,1 +spars: call docol + dw zero +spars1 dw tor + dw dupp,parse + dw tdup + dw fromr,ppsb + dw tor + dw onep,plus + dw dupp + dw source,plus + dw uless + dw zbran,spars2 + dw tdup,cat + dw equal + dw zbran,spars2 + dw one,dupp + dw inn,pstor + dw fromr,ppsb + dw bran,spars1 +spars2 dw tdrop + dw lit,psb + dw fromr + dw exit + +; pwa ( -- adr ) parsed word address + + hdr x,'PWA',,1 +pwa: call doval + dw ? + +; wpack ( c-addr1 u -- c-addr2 ) +; 255 umin (em-5) over 31 max - dup to pwa +; pack bl affix + + hdr x,'WPACK',,1 ; pack string into WORD's buffer +wpack: call docol + dw clit + db 255 + dw umin + if retro + dw here + else + dw lit,em-5 + dw over + dw clit ; word buffer 31+5 chars min (F94) + db 31 + dw max + dw subb + endif + dw dupp + dw pto,pwa + dw pack + dw bll,affix ; trailing blank + dw exit + +; bl-word ( -- c-addr ) bl word + + hdr x,'BL-WORD',,1 +blword: mov ax,20h + push ax +; jmp wordd + +; WORD ( char -- c-addr ) true (parse) wpack + + hdr 1,'WORD',,1 +wordd: call docol + dw true,ppars + dw wpack + dw exit + +; TOKEN ( -- c-addr u ) bl-word count + + hdr 1,'TOKEN',,1 +token: call docol + dw blword,count + dw exit + +; defined ( -- c-addr 0 | xt -1 | xt 1 ) bl-word find + + hdr x,'DEFINED',,1 +defined:call docol + dw blword,find + dw exit + +; ' ( -- xt ) defined ?defined + + hdr 1,'''',,1 +tick: call docol + dw defined + dw qdef + dw exit + +; [UNDEFINED] ( -- flag ) defined nip 0= ;immediate + + hdr 1,'[UNDEFINED]',1,1 +budef: call docol + dw defined + dw nip + dw zequ + dw exit + +; [DEFINED] ( -- flag ) postpone [undefined] 0= ;immediate + + hdr 1,'[DEFINED]',1,1 +bdef: call docol + dw budef,zequ + dw exit + +; IMMEDIATE ( -- ) $40 xnfa + + hdr 1,'IMMEDIATE',,1 +immed: mov dl,40h + ignore1 + +; xnfa ( x -- ) toggle nfa bit + +xnfa: pop dx + mov bx,last1 + mov es,hseg1 + xor es:[bx],dl + nextt + +; SMUDGE ( -- ) $20 xnfa + + hdr 1,'SMUDGE',,1 ; FIG +smudg: mov dl,20h + jmp xnfa+1 + +; \ ( "ccc" -- ) source blk @ if c/l >in @ over / 1+ * +; min then >in ! drop ;immediate + + hdr 1,'\',1,1 +bslas: call docol + dw source + dw blk,at + dw zbran,bslas1 + dw csll + dw inn,at + dw over,slash + dw onep,star + dw min +bslas1 dw inn,store + dw drop + dw exit + +; \\ ( "ccc" -- ) source >in ! drop ;immediate + + hdr 1,'\\',1,1 +bslss: call docol + dw source + dw bran,bslas1 + +; ( ( "ccc" ) [char] ) parse 2drop ;immediate + + hdr 1,'(',1,1 +paren: call docol + dw clit + db ')' + dw parse,tdrop + dw exit + +; .( ( "ccc" ) [char] ) /parse type ;immediate + + hdr 1,'.(',1,1 +dotp: call docol + dw clit + db ')' + dw spars + dw typee + dw exit + +; LINK, ( a -- ) here over @ , swap ! + + hdr 1,'LINK,',,1 +linkc: call docol + dw here + dw over,at + dw comma + dw swap,store + dw exit + +; WORDLIST ( -- wid ) here dph @ $2001 over h! cell+ 0 over h! +; [ 2 cells ] literal dph +! , voc-link link, +; 0 , + + hdr x,'WORDLIST',,1 +wlist: call docol + dw here + dw dph,at + dw lit,2001h + dw over,hstor + dw cellp + dw zero ; nfa of top word in vocabulary + dw over,hstor + dw clit + db cw*2 + dw dph,pstor + dw comma + dw vocl,linkc ; link in wordlist + dw zero,comma ; null name + dw exit + +; VOCABULARY ( "name" ) sys? system wordlist dup value last @ +; swap cell+ cell+ ! sys ! does> @ context ! + + hdr 1,'VOCABULARY',,1 +vocab: call docol + dw sysq + dw system + dw wlist + dw dupp,value + dw last,at ; set name field in wordlist struct + dw swap + dw cellp,cellp + dw store + dw sys,store + dw pscod +dovoc: call docol + dw at + dw cont,store + dw exit + +; DEFINITIONS ( -- ) get-context set-current + + hdr 1,'DEFINITIONS',,1 +defin: call docol + dw getcon + dw setcur + dw exit + +; wordlist structure + +heads segment public + + dw 2001h ; dummy nfa for vocab chaining +forth0 dw topnfa ; nfa of top word in vocabulary + +heads ends + + aseg + +forth1 dw forth0-horig ; top word pointer +forth2 dw 0 ; previous vocabulary + dw forth3 ; vocab nfa + +; FORTH vocabulary forth + + hdr 1,'FORTH',,1 +forth: call dovoc + dw forth1 ; address of wid + +forth3 = lastl + +; UNUSED ( -- u ) sys? if (esm) else s0 then @ here +; 255 + 2dup u> -rot - and + + hdr 1,'UNUSED' +unus: call docol + dw sysq + dw zbran,unus1 + dw lit,esm + dw bran,unus2 +unus1 dw szero +unus2 dw at + dw here + dw clit ; allow margin + db 255 + dw plus + dw tdup + dw ugrea + dw drot + dw subb + dw andd + dw exit + +; INTERPRET ( -- ) begin bl-word dup c@ while find ?dup if +; state? = if compile, else execute then +; else count base @ >r over c@ case [char] % +; of binary 1 endof [char] $ of hex 1 endof +; [char] # of decimal 1 endof 0 swap endcase +; /string 2dup number? if 2nip dpl @ 0< if +; drop state? if postpone literal then else +; state? if postpone 2literal then then true +; else fnumber then r> base ! ?defined then +; ?stack repeat drop + + hdr 1,'INTERPRET',,1 +inte: call docol +inte1 dw blword + dw dupp,cat + dw zbran,inte15 ; while not end of input stream + dw find + dw qdup + dw zbran,inte4 ; if found + dw stateq + dw equal + dw zbran,inte2 ; if compiling and not immediate + dw comxt + dw bran,inte3 +inte2 dw exec +inte3 dw bran,inte14 +inte4 dw count + dw base,at,tor + dw over,cat + dw clit + db '%' + dw pof,inte5 + dw bin,one + dw bran,inte8 +inte5 dw clit + db '$' + dw pof,inte6 + dw hex,one + dw bran,inte8 +inte6 dw clit + db '#' + dw pof,inte7 + dw decim,one + dw bran,inte8 +inte7 dw zero,swap + dw drop +inte8 dw sstr + dw tdup +pnumb equ $ + dw numq ; NUMBER? patch + dw zbran,inte12 + dw tnip + dw dpl,at,zless + dw zbran,inte10 + dw drop + dw stateq + dw zbran,inte9 + dw liter +inte9 dw bran,inte11 +inte10 dw stateq + dw zbran,inte11 + dw tlite +inte11 dw true + dw bran,inte13 +inte12 equ $ +pfnum equ $ + dw fnu ; FNUMBER patch +inte13 dw fromr,base,store + dw qdef +inte14 dw qstac + dw bran,inte1 +inte15 dw drop + dw exit + +; (eval) ( c-addr u blk -- ) blk @ >in @ 2>r source 2>r blk ! +; 'source 2! >in off interpret +; 2r> 'source 2! 2r> >in ! blk ! + + hdr x,'(EVAL)',,1 ; does not restore block contents +peval: call docol + dw blk,at + dw inn,at + dw ttor + dw source,ttor + dw blk,store + dw tsourc,tstor + dw inn,off ; reset >IN + dw inte + dw tfrom + dw tsourc,tstor + dw tfrom + dw inn,store + dw blk,store + dw exit + +; ?BLOCK ( -- ) blk @ dup if block then drop + + hdr 1,'?BLOCK',,1 ; reload block +qblock: call docol + dw blk,at + dw dupp + dw zbran,qblock1 + dw block +qblock1 dw drop + dw exit + +; EVALUATE ( c-addr u -- ) 0 (eval) ?block + + hdr 1,'EVALUATE',,1 +eval: call docol + dw zero,peval + dw qblock + dw exit + +; (refill) ( -- flag ) blk @ ?dup if 1+ dup #screens u< and dup +; while dup blk ! block b/buf else (tib) +; dup 80 accept space then 'source 2! >in +; off true then + + hdr x,'(REFILL)',,1 ; doesn't correctly handle source +prefil: call docol ; from EVALUATE + if debug + dw pdotq + dcs '(REFILL) ' + endif + dw blk,at + dw qdup + dw zbran,prefil1 + dw onep,dupp + dw nscr,uless + dw andd,dupp + dw zbran,prefil3 + dw dupp,blk,store + dw block,bbuf + dw bran,prefil2 +prefil1 dw lit,tib + dw dupp + dw clit + db 80 + dw accept + dw space +prefil2 dw tsourc,tstor + dw inn,off + dw true +prefil3 dw exit + +; REFILL ( -- flag ) + + hdr 1,'REFILL',,1 +refil: call aexec + dw prefil + +; reset ( -- ) catcher off cseg sseg ! -caps bios-io +; console + + hdr x,'RESET' +reset: call docol + dw catchr,off ; reset error handler + dw csegg ; set search segment + dw sseg,store + dw dcaps ; reset COMPARE/SEARCH caps + dw biosio ; default i/o mode + dw consol ; set EMIT vector + dw exit + +; /interpret ( -- ) blk off >in off postpone [ + + hdr x,'/INTERPRET',,1 +sinte: sub ax,ax + mov blk1,ax + mov inn1,ax + jmp lbrac + +; forth-reset ( -- ) (em) set-limit empty warning on checking +; on (fdbs) (fdsiz*nfd) erase empty-buffers +; /interpret 'source off bl-word drop sp@ +; csp cell+ ! + + hdr x,'FORTH-RESET',,1 +freset: call docol + dw lit,em + dw setlim + dw empty ; reset vocabulary pointers + dw warnn,on ; enable warnings + dw check,on ; enable checking + dw lit,fdbs ; clear files + dw lit,fdsiz*nfd ; + dw erase ; + dw mtbuf ; mark screen buffer as empty + dw sinte ; reset interpreter + dw tsourc,off ; clear parsed word buffer + dw blword,drop ; + if cfs + dw spat ; set CF stack base to safe value + dw cspp,cellp + dw store + endif + dw exit + +; (quit) ( -- ) r0 @ rp! reset normal /interpret begin +; cr (refill) drop interpret state? 0= if +; ." ok" then again + + hdr x,'(QUIT)',,1 +pqui: call docol + dw rzero,at + dw rpsto + dw reset + dw vnorm + dw sinte + if debug + dw pdotq + dcs ' QUIT ' + endif +pqui1 dw crr + dw prefil,drop + dw inte + dw stateq + dw zequ + dw zbran,pqui2 + dw pdotq + dcs ' ok' +pqui2 dw bran,pqui1 + +; RETURN ( x -- ) exit to DOS with return code x + + hdr 1,'RETURN' +retrn: mov al,iattr ; restore video attribute + mov cattr,al + mov al,cr ; force update - this kludge + call bcono ; works if cursor is located + mov al,lf ; on bottom screen row + call bcono + call gmode ; restore video mode + mov ax,word ptr imode + cmp ax,word ptr cmode + jz retrn1 + sub ah,ah + int 10h +retrn1: mov dl,defdrv ; restore drive + mov ah,0eh + int 21h + pop ax + mov ah,4Ch + int 21h + +; BYE ( -- ) close-all console normal 0 return + + hdr 1,'BYE',,1 +bye: call docol + dw closa + dw consol + dw vnorm + dw zero,retrn + +; boot? ( -- bootword ) (iboot) @ + + hdr x,'BOOT?' +bootq: mov ax,iboot + jmp apush + +; QUIT ( i*x -- i*x ) 0 ?return + + hdr 1,'QUIT' +quit: sub ax,ax + push ax +; jmp qret + +; ?return ( code -- ) boot? if return then drop (quit) + + hdr x,'?RETURN' +qret: call docol + dw bootq + dw zbran,qret1 + dw retrn +qret1 dw drop + dw pqui + +; (abort) ( -- ) s0 @ sp! fs0 @ fsp ! 1 ?return + + hdr x,'(ABORT)' +pabor: call docol + dw szero,at + dw spsto + dw fszero,at + dw fsp,store + if debug + dw pdotq + dcs ' (ABORT) ' + endif + dw one,qret + +; .error ( -- ) cr blk @ ?dup if screen? and if filename type +; >in @ 2- 0max blk @ 2dup scr 2! ." Scr " +; u. c/l / ." Line " . cr then then ." Error: " +; [char] " dup emit pwa count 31 min type emit + + hdr x,'.ERROR',,1 +doterr: call docol + dw crr + dw blk,at + dw qdup + dw zbran,doterr1 + dw scrnq + dw andd ; screen file open and loading from block? + dw zbran,doterr1 + dw loadf,typee + dw inn,at + dw twom ; adjust pointer + dw zmax + dw blk,at + dw tdup ; set error block, offset + dw scr,tstor + dw pdotq + dcs ' Screen ' + dw udot + dw csll + dw slash + dw pdotq + dcs 'Line ' + dw dot + dw crr +doterr1 dw pdotq + dcs 'Error: ' + dw clit + db '"' + dw dupp,emit + dw pwa,count + dw clit + db 31 + dw min + dw typee + dw emit + dw exit + +; error ( n -- ) -1 of (abort) then -2 of boot cell+ @ 0= +; if .error then space errmsg 2@ type +; (abort) then ." exception = " . (abort) + + hdr x,'ERROR' +error: call docol + dw true ; -1 + dw pof,error1 + dw pabor +error1 dw lit,-2 + dw pof,error3 + dw boot,cellp,at + dw zequ + dw zbran,error2 + dw doterr ; skipped by applications +error2 dw space + dw errmsg,tat + dw typee + dw pabor +error3 dw pdotq + dcs ' exception = ' + dw dot + dw pabor + +; ABORT ( -- ) -1 throw + + hdr 1,'ABORT' +abort: mov ax,-1 + push ax +; jmp throw + +; THROW ( n -- ) ?dup if catcher @ ?dup 0= if error then rp! +; r> catcher ! 2r> fsp ! swap >r sp! drop r> +; then + + hdr 1,'THROW' +throw: call docol + dw qdup + dw zbran,throw2 + dw catchr,at + if debug + dw pdotq + dcs ' THROW:' + dw over,dot + dw pdotq + dcs 'CATCHER:' + dw dupp,udot + endif + dw qdup,zequ + dw zbran,throw1 + dw error +throw1 dw rpsto + dw fromr,catchr,store + dw tfrom,fsp,store + dw swap,tor + dw spsto + dw drop + dw fromr +throw2 dw exit + +; CATCH ( xt -- n | 0 ) sp@ fsp @ 2>r catcher @ >r rp@ catcher +; ! execute 0 r> catcher ! 2r> 2drop + + hdr 1,'CATCH' +catch: call docol + dw spat + dw fsp,at + dw ttor + dw catchr,at,tor + dw rpat,catchr,store + dw exec + dw zero + dw fromr,catchr,store + dw tfrom +catch1 dw tdrop + dw exit + +; (abort") ( n -- ) r> count 2dup + >r ?abort + + hdr x,'(ABORT")' +pabq: sub ax,ax + lodsb + push si + push ax + add si,ax +; jmp qabor + +; ?abort ( n c-addr u -- ) rot if errmsg 2! -2 throw then 2drop + + hdr x,'?ABORT' +qabor: call docol + dw rot + dw zbran,catch1 + dw errmsg,tstor ; only change msg on error + dw lit,-2 + dw throw + +; ABORT" state? if postpone (abort") ," end +; postpone s" ?abort ;immediate + + hdr 1,'ABORT"',1,1 +aborq: call docol + dw stateq + dw zbran,aborq1 + dw comp,pabq + dw comq + dw exit +aborq1 dw squot + dw qabor + dw exit + +; CMDTAIL ( -- c-addr u ) (dosbuf) count -blanks + + hdr 1,'CMDTAIL' +cmdtail:call docol + dw clit + db dosbuf + dw count + dw dblan + dw exit + +; Cold start from DOS + + cseg + +nodos db 'wrong DOS version',cr,lf,'$' +noram db 'not enough RAM',cr,lf,'$' + +cldd: cld + mov ax,cs + mov ds,ax + mov cseg1,ax + mov hseg1,ax ; adjusted later + mov sp,offset tmpstk + + mov ax,3000h ; check dos version + int 21h + mov byte ptr dosv,al + mov byte ptr dosv+cw,ah + cmp al,2 + mov dx,offset nodos + mov ah,0 + jc cldd2 + + mov ax,boot1 ; get BOOT word + mov iboot,ax ; save it + test ax,boot2 + pushf + + mov bx,ulimit ; turnkey limit + jnz cldd1 + mov bx,em/16 ; default limit + add hseg1,bx ; set heads segment + add bx,hm/16 ; add heads space +cldd1: push cs + pop es + mov ah,4ah ; adjust memory + int 21h + mov dx,offset noram + mov ax,4C01h ; error-code = 1 + jnc cldd3 + +cldd2: push ax + mov ah,9 ; show failure + int 21h + pop ax + int 21h ; terminate + +cldd3: call gmode + and al,7fh ; ignore no-blank bit + mov word ptr imode,ax ; save video mode + mov bh,ah + mov ah,8 + int 10h + mov iattr,ah ; save video attribute + + mov ah,19h ; save current drive + int 21h + mov defdrv,al + + mov ax,40h ; set keyboard type + mov es,ax + mov bx,96h + test byte ptr es:[bx],10h + mov ax,0100h ; old + jz cldd4 + mov ax,1110h ; extended +cldd4: mov word ptr kbfn,ax + + popf + jz cldd5 ; need forth system + + mov word ptr prese,offset noop ; patch out forth init + mov di,ulimit+cw ; LIMIT for applications + jmp short cldd8 + +cldd5: mov byte ptr cmdf,0ffh ; enable command line flag + + push ds ; move heads into place + mov di,idph +cldd6: sub cx,cx ; later patched to MOV CX,DI + dec di + mov si,di + mov es,hseg1 + mov ax,ds + add ax,hstart + mov ds,ax + std + rep movsb + cld + pop ds + + mov ax,idp ; move system into place + mov di,offset orig+sm + mov cx,idps +cldd7: sub cx,cx ; later patched to SUB CX,DI + call bmovu + inc di + +cldd8: mov limit1,di ; patch LIMIT + + db 0E9h ; 'jmp' +cldd9 dw movpat-$-2 ; later patched to 'cold' + +; COLD ( -- ) + + hdr 1,'COLD' ; FIG +cold: cld + mov ax,cs + mov ds,ax + cli + mov ss,ax + mov sp,offset tmpstk + sti + + mov word ptr esm,offset orig+fdbs ; patch end of system memory + + mov ax,limit1 ; get LIMIT + sub ax,nus + mov bp,ax ; init return stack + mov ir0,ax ; patch R0 + mov upp,ax ; patch UP + sub ax,nrts + mov fspp,ax ; init fp stack + mov ifs0,ax ; patch FS0 + sub ax,nfps ; fp stack size + mov sp,ax ; init data stack + mov is0,ax ; patch S0 + mov di,bp ; init boot up variables + mov ax,offset initu + mov cx,initu2-initu + call movd + + mov word ptr pause1,0 ; patch PAUSE + + mov ax,0500h ; set video page = 0 +cold1: call video + call gmode ; get video mode + cmp al,7 ; 80 col mono + jz cold2 + cmp al,3 ; 80 col color + jz cold2 + cmp al,2 ; 80 col b/w + jz cold2 + mov ax,3 ; set video mode = 80 col color + jmp cold1 ; (screen will blank) +cold2: dec bh ; cols + mov wmax,bh + sub bh,bh + sub dl,dl ; assume old CGA card + mov ax,1130h + call video + or dl,dl ; rows if EGA+ + jnz cold3 + mov dl,24 +cold3: mov wmax+1,dl + mov word ptr wmin,0 + + mov al,iattr ; set default attribute + and al,7fh + mov cattr,al + + mov dx,offset orig+dosbuf ; reset DOS DTA + mov ah,1ah + int 21h + + call docol + dw smss ; calibrate MS + dw app ; default is APPLICATION + dw decim ; default base + dw reset ; general reset +prese equ $ + dw freset ; forth reset +pinit equ $ + dw init ; run INIT eg. for float + dw bootq + dw dupp,boot,store ; restore BOOT + dw qdup + dw zbran,cold6 + dw exec ; run application + dw zero,retrn ; exit to DOS + + aseg ; run forth interpreter + +cold6 dw cmdtail ; process command-line + dw lit,cmdf + dw cat,andd + dw tuck + dw lit,tib ; copy to tib + dw zero,pstr + dw tsourc,tstor + dw zero + dw lit,cmdf ; disable + dw cstor + dw zbran,cold8 + dw blword ; parse first word + dw at + dw lit + db 1,'-' ; skips file open + dw subb + dw zbran,cold7 + dw inn,off + dw getfn,popen +cold7 dw inte ; interpret +cold8 dw vnorm + dw crr,pagee + dw pdotq + db elogo-$-1 +logo equ $ + db 'DX-Forth ' + db '0'+rel,'.','0'+rev/10 + db '0'+rev mod 10 + db ' ' + if beta + db 'unofficial test release' + else + date + endif + db ' ' +elogo equ $ + dw crr +piden equ $ + dw ident ; run IDENTIFY + dw crr + dw scrnq + dw zbran,cold9 + dw crr + dw pdotq + dcs 'Using ' + dw loadf,typee + dw crr +cold9 dw pqui ; jump to interpreter + +; SET-LIMIT ( addr -- ) $fff0 and dup 4 rshift (ulimit) 2! + + hdr 1,'SET-LIMIT',,1 +setlim: pop ax + and al,0f0h + mov ulimit+cw,ax + mov cl,4 + shr ax,cl + mov ulimit,ax + nextt + +; PROTECT ( -- ) up @ (initu) (initu2-initu) cmove + + hdr 1,'PROTECT',,1 +prot: call docol + dw up,at + dw lit,initu + dw lit,initu2-initu + dw cmove + dw exit + +; 'prune variable 'prune 'prune off + + hdr x,"'PRUNE",,1 +tprun: call docre + dw toppru ; 0=end + +; REMEMBER ( xt -- ) 'prune link, , + + hdr 1,'REMEMBER',,1 ; add xt to prunes +remem: call docol + dw tprun,linkc + dw comma + dw exit + +; xdp ( adr -- adr xdp ) dup limit u< if dp else dps then + + hdr x,'XDP',,1 +xdp: pop ax + push ax + cmp ax,limit1 + jnc xdp1 + jmp dpp +xdp1: jmp dps + +; prunes ( -- ) begin 'prune @ dup while dup xdp @ u< 0= +; while 2@ 'prune ! execute repeat then drop + + hdr x,'PRUNES',,1 +pruns: call docol +pruns1 dw tprun,at + dw dupp + dw zbran,pruns2 + dw dupp + dw xdp,at + dw uless,zequ + dw zbran,pruns2 + dw tat + dw tprun,store + dw exec + dw bran,pruns1 +pruns2 dw drop + dw exit + +; ?protected ( h-addr -- h-addr ) (idph) @ over u> check? and +; abort" is protected" + + hdr x,'?PROTECTED',,1 +qprot: call docol + dw lit,idph + dw at + dw over,ugrea + dw chkq,andd + dw pabq + dcs 'is protected' + dw exit + +; name? ( "name" -- xt nfa ) bl-word get-context wfind ?defined +; ?protected + + hdr x,'NAME?',,1 ; find name in context wordlist +nameq: call docol + dw blword + dw getcon + dw wfind,qdef + dw qprot + dw exit + +; lfind ( wid nfa -- lfa | 0 ) swap @ begin 2dup h@ - while h@ +; dup while n>link repeat then nip + + hdr x,'LFIND',,1 ; find link field containing nfa, 0=none +lfind: call docol + dw swap,at +lfind1 dw tdup,hat + dw subb + dw zbran,lfind2 + dw hat,dupp + dw zbran,lfind2 + dw nlnk + dw bran,lfind1 +lfind2 dw nip + dw exit + +; BEHEAD ( "name1" "name2" -- ) name? nip name? nip 2dup u< if swap +; then n>name get-context rot lfind h! + + hdr 1,'BEHEAD',,1 ; unlink word heads +behead: call docol + dw nameq,nip + dw nameq,nip + dw tdup,uless + dw zbran,behead1 + dw swap +behead1 dw ntnam + dw getcon + dw rot,lfind + dw hstor + dw exit + +; ?chain ( flag -- ) abort" invalid chain" + + hdr x,'?CHAIN',,1 +qchai: call docol + dw pabq + dcs 'invalid chain' + dw exit + +; CHAIN ( "name" -- ) get-current postpone addr @ 2dup +; = ?chain @ cell- $2001 over h@ - +; ?chain 2dup lfind ?chain swap 0 +; lfind ?protected 2dup u> ?chain h! + + hdr 1,'CHAIN',,1 +chain: call docol + dw getcur + dw addr,at + dw tdup,equal ; same wordlist + dw qchai + dw at,cellm + dw lit,2001h + dw over,hat,subb ; not a wordlist + dw qchai + dw tdup,lfind ; already chained + dw qchai + dw swap + dw zero,lfind + dw qprot + dw tdup,ugrea ; forward reference + dw qchai + dw hstor + dw exit + +; (forget) ( nfa dps dp -- ) +; dp 2! >r voc-link begin @ dup cell- @ cell+ +; r@ u< until dup voc-link ! begin dup cell- +; @ dup h@ begin dup r@ u< 0= while -alias if +; dup name> xdp tuck @ umin swap ! then n>name +; repeat swap h! @ ?dup 0= until r> dup dph ! +; (idph) @ u< if protect then prunes + + hdr x,'(FORGET)',,1 +pforg: call docol + dw dpp,tstor ; starting maximums + dw tor + dw vocl ; trim vocs > nfa +pforg1 dw at + dw dupp + dw cellm,at,cellp ; vocab nfa (WORDLIST compatible) + dw rat,uless + dw zbran,pforg1 + dw dupp,vocl,store +pforg2 dw dupp,cellm,at ; scan remaining vocs + dw dupp,hat +pforg3 dw dupp,rat ; for each word >= nfa + dw uless,zequ + dw zbran,pforg5 + dw dalias ; not an alias + dw zbran,pforg4 + dw dupp,namef ; get its xt + dw xdp + dw tuck,at + dw umin,swap,store ; trim dict +pforg4 dw ntnam + dw bran,pforg3 +pforg5 dw swap,hstor + dw at + dw qdup,zequ + dw zbran,pforg2 ; until all vocs done + dw fromr + dw dupp,dph,store + dw lit,idph ; below fence? + dw at,uless + dw zbran,pforg6 + dw prot ; fix bootup values +pforg6 dw pruns ; run prunes list + dw exit + +; EMPTY ( -- ) forth definitions (idph) @ (idp) +; 2@ (forget) + + hdr 1,'EMPTY',,1 +empty: call docol + dw forth,defin ; switch to a safe vocabulary + dw lit,idph + dw at + dw lit,idp + dw tat + dw pforg + dw exit + +; FORGET ( "name" -- ) get-current context ! name? -alias +; 0= abort" is alias" swap limit over u< +; if dp @ else dps @ swap then (forget) + + hdr 1,'FORGET',,1 +forg: call docol + dw getcur + dw cont,store + dw nameq + dw dalias,zequ ; alias? + dw pabq + dcs 'is alias' + dw swap + dw limit + dw over,uless + dw zbran,forg1 + dw dpp,at + dw bran,forg2 +forg1 dw dps,at + dw swap +forg2 dw pforg + dw exit + +; MARKER ( "name" -- ) sys? system ['] drop build sys ! + + hdr 1,'MARKER',,1 +marker: call docol + dw sysq + dw system + dw lit,drop + dw build + dw sys,store + dw exit + +; COMPILE, ( xt -- ) warning @ 0< if dup limit u< sys? d0= +; if dup .name ." is system " then then , + + hdr 1,'COMPILE,',,1 +comxt: call docol + dw warnn,at + if wopt + dw zless + endif + dw zbran,comxt1 + dw dupp,limit + dw uless + dw sysq + dw dzequ + dw zbran,comxt1 + dw dupp + dw dotnam + dw pdotq + dcs ' is system ' +comxt1 dw comma + dw exit + +; COMPILE ( -- ) ?comp r> dup cell+ >r @ compile, + + hdr 1,'COMPILE',,1 +comp: call docol + dw qcomp ; prevent crash if interpreting + dw fromr + dw dupp,cellp + dw tor + dw at + dw comxt + dw exit + +; POSTPONE defined dup ?defined 0< if compile +; compile then compile, ;immediate + + hdr 1,'POSTPONE',1,1 +postp: call docol + dw defined + dw dupp,qdef + dw zless + dw zbran,postp1 + dw comp,comp +postp1 dw comxt + dw exit + +; S, ( c-addr u -- ) 255 umin here over 1+ allot place + + hdr 1,'S,',,1 +scomm: call docol + dw clit + db 255 + dw umin + dw here,over + dw onep,allot + dw place + dw exit + +; ," ( "ccc" -- ) [char] " /parse s, + + hdr 1,',"',,1 +comq: call docol + dw clit + db '"' + dw spars + dw scomm + dw exit + +; (s") ( -- c-addr u ) r> count 2dup + >r + + hdr x,'(S")' +psqot: sub ax,ax + lodsb + push si + push ax + add si,ax + nextt + +; SLITERAL ( c-addr u -- ) postpone (s") s, ;immediate + + hdr 1,'SLITERAL',1,1 +slite: call docol + dw comp,psqot + dw scomm + dw exit + +; S" ( -- c-addr u ) [char] " /parse state? if postpone sliteral +; then ;immediate + + hdr 1,'S"',1,1 ; state smart version +squot: call docol + dw clit + db '"' + dw spars + dw stateq + dw zbran,squot1 + dw slite +squot1 dw exit + + if 0 + +; (c") ( -- c-addr ) r> dup count + >r + + hdr x,'(C")' +pcqot: push si + sub ax,ax + lodsb + add si,ax + nextt + +; C" ( -- c-addr ) postpone (c") ," ;immediate + + hdr 1,'C"',1,1 +cquot: call docol + dw comp,pcqot + dw comq + dw exit + + endif + +; (.") r> count 2dup + >r type + + hdr x,'(.")' +pdotq: sub ax,ax + lodsb + push si + push ax + add si,ax + jmp typee + +; ." postpone (.") ," ;immediate + + hdr 1,'."',1,1 +dotq: call docol + dw comp,pdotq + dw comq + dw exit + +; CHAR? ( x -- x flag ) + + hdr x,'CHAR?',,1 +charq: pop ax + push ax + mov al,ah + jmp zequ1 + +; LITERAL ( n -- ) char? if postpone clit c, end +; postpone lit , ;immediate + + hdr 1,'LITERAL',1,1 +liter: call docol + dw charq + dw zbran,liter1 + dw comp,clit + dw ccomm + dw exit +liter1 dw comp,lit + dw comma + dw exit + +; 2LITERAL ( x1 x2 -- ) postpone 2lit , , ;immediate + + hdr 1,'2LITERAL',1,1 +tlite: call docol + dw comp,tlit + dw comma,comma + dw exit + +; ['] ' postpone literal ;immediate + + hdr 1,'['']',1,1 +btick: call docol + dw tick + dw liter + dw exit + +; [COMPILE] ' compile, ;immediate + + hdr 1,'[COMPILE]',1,1 +bcomp: call docol + dw tick + dw comxt + dw exit + +; RECURSE ( -- ) last cell+ @ compile, ;immediate + + hdr 1,'RECURSE',1,1 +recurs: push last2 + jmp comxt + +; CHAR ( -- char ) bl-word 1+ c@ + + hdr 1,'CHAR',,1 +char: call docol + dw blword + dw onep,cat + dw exit + +; [CHAR] ( -- char ) char postpone literal ;immediate + + hdr 1,'[CHAR]',1,1 +pchar: call docol + dw char + dw liter + dw exit + +; Y/N ( -- flag ) ." (y/n) N\bs" key upcase [char] Y = dup +; if [char] Y else [char] N then emit space + + hdr 1,'Y/N' +yn: call docol + dw pdotq + dcs '(y/n) N',bs + dw key,upcas + dw clit + db 'Y' + dw equal,dupp + dw zbran,yn1 + dw clit + db 'Y' + dw bran,yn2 +yn1 dw clit + db 'N' +yn2 dw emit,space + dw exit + +; +; File and Block Functions +; +; PATH -PATH filetype? +EXT -EXT FILE-POSITION FILE-SIZE +; RESIZE-FILE REPOSITION-FILE READ-FILE LREAD WRITE-FILE +; LWRITE fh READ-LINE WRITE-LINE >FNAME R/O W/O R/W BIN +; OPEN-FILE CREATE-FILE CLOSE-FILE FLUSH-FILE FILE-STATUS +; DELETE-FILE RENAME-FILE sfp SWAP-FILE FDB fnb scr# +; blks fid fd buf blk# SCREEN? LOADFILE ?open #SCREENS +; EMPTY-BUFFERS UPDATE blkerr blk-rw ?blk SAVE-BUFFERS +; FLUSH BUFFER BLOCK --> LOAD THRU FILEBLOCKS CLOSE +; CLOSE-ALL LASTFILE .lastfile ?create init-scr OPEN +; (open) GETFILENAME USING LOADED FLOAD SAVE TURNKEY +; TURNKEY-SYSTEM + +; PATH ( u1 -- c-addr u2 ior ) + + hdr 1,'PATH' ; uses filename buffer +path: pop ax + or ax,ax + jnz path1 + mov ah,19h + int 21h + inc al +path1: mov dl,al + mov bx,zbuf1 + push bx + add al,'@' + mov [bx],al + inc bx + mov [bx],'\:' + add bx,2 + push si + mov si,bx + mov ah,47h + int 21h + pop si + jc path3 + pop bx + push bx + push ds + pop es + call zcnt2 + cmp ax,3 + jz path2 + mov byte ptr [bx],'\' + inc ax +path2: push ax + jmp zero + +path3: mov dx,0 ; don't change CF + push dx + jmp doserr1 + +; -PATH ( c-addr1 u1 -- c-addr2 u2 ) +; 2dup [char] : scan dup if 1 /string 2swap +; then begin 2drop 2dup [char] \ scan dup +; while 1 /string 2swap repeat 2drop + + hdr 1,'-PATH' +dpath: call docol + dw tdup + dw clit + db ':' + dw scan + dw dupp + dw zbran,dpath1 + dw one,sstr + dw tswap +dpath1 dw tdrop + dw tdup + dw clit + db '\' + dw scan,dupp + dw zbran,dpath2 + dw one,sstr + dw tswap + dw bran,dpath1 +dpath2 dw tdrop + dw exit + +; filetype? ( c-addr1 u1 -- u2 ) -path [char] . scan nip + + hdr x,'FILETYPE?' ; get filetype length +ftype: call docol + dw dpath + dw clit + db '.' + dw scan + dw nip + dw exit + +; +EXT ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 ) +; 2over filetype? if 2drop end 3 min +; s" ." 2rot -trailing (pfsiz-5) min zbuf +; @ 1+ 0 +string +string +string + + hdr 1,'+EXT' ; uses filename buffer +pext: call docol + dw tover,ftype + dw zbran,pext1 + dw tdrop,exit +pext1 dw three,min + dw psqot + dcs '.' + dw trot + dw dtrai ; trim trailing blanks + dw clit + db pfsiz-5 + dw min + dw zbuf,at ; unused + dw onep + dw zero + dw pstr + dw pstr + dw pstr + dw exit + +; -EXT ( c-addr1 u1 -- c-addr2 u2 ) 2dup filetype? - + + hdr 1,'-EXT' +dext: call docol + dw tdup,ftype + dw subb + dw exit + +; FILE-POSITION ( fileid -- ud ior ) + + hdr 1,'FILE-POSITION' +fpos: pop bx + sub cx,cx + mov dx,cx + mov ax,4201h + int 21h + push ax + push dx +fpos1: jmp doserr1 + +; FILE-SIZE ( fileid -- ud ior ) + + hdr 1,'FILE-SIZE' +fsiz: pop bx + sub cx,cx + mov dx,cx + mov ax,4201h + int 21h + push ax + push dx + jc fpos1 + mov dx,cx ; assume CX BX unchanged + mov ax,4202h + int 21h + pop cx + pop di + push ax + push dx + mov dx,di + mov ax,4200h + int 21h + jmp zero + +; RESIZE-FILE ( ud fileid -- ior ) + + hdr 1,'RESIZE-FILE' +resizf: pop bx + pop cx + pop dx + mov ax,4200h + int 21h + jc resizf2 + sub cx,cx ; truncate file + mov ah,40h ; assume BX unchanged +resizf1:int 21h +resizf2:jmp doserr1 + +; REPOSITION-FILE ( ud fileid -- ior ) + + hdr 1,'REPOSITION-FILE' +reposf: pop bx + pop cx + pop dx + mov ax,4200h + jmp resizf1 + +; READ-FILE ( c-addr u1 fileid -- u2 ior ) + + hdr 1,'READ-FILE' +readf: pop bx + pop cx + pop dx + push ds +readf1: pop ax + mov ds,ax + mov ah,3fh +readf2: int 21h + push cs + pop ds + push ax + jmp doserr1 + +; LREAD ( seg offs u fileid -- ior ) + + hdr 1,'LREAD' +lread: pop bx + pop cx + pop dx + jmp readf1 + +; WRITE-FILE ( c-addr u fileid -- ior ) + + hdr 1,'WRITE-FILE' +writf: pop bx + pop cx + pop dx + push ds +writf1: pop ax + or cx,cx ; must trap CX=0 + jnz writf2 + jmp zero + +writf2: mov ds,ax + mov ah,40h + int 21h + push cs + pop ds + jc writf3 + cmp ax,cx ; assume CX unchanged + mov al,255 +writf3: jmp doserr1 + +; LWRITE ( seg offs u fileid -- ior ) + + hdr 1,'LWRITE' +lwrit: pop bx + pop cx + pop dx + jmp writf1 + +; fh ( -- fid ) 0 value fh + + hdr x,'FH' +fh: call doval + dw ? + +; READ-LINE ( addr u1 fid -- u2 flag ior ) +; to fh over swap fh read-file ?dup if end +; 2dup bounds ?do i dup c@ $1A = if rot - +; fh file-size drop fh reposition-file drop +; leave then c@ eol rot scan nip ?dup if i +; + >r over + r> swap - dup 0<> fh +; file-position drop d+ fh reposition-file +; drop i swap - -1 0 unloop end loop nip +; dup 0<> 0 + + hdr 1,'READ-LINE' +readl: call docol + dw pto,fh + dw over,swap + dw fh,readf,qdup + dw zbran,readl1 + dw exit +readl1 dw tdup,bounds + dw xqdo,readl5 +readl2 dw ido + dw dupp,cat + dw clit + db ctlz + dw equal + dw zbran,readl3 + dw rot,subb + dw fh,fsiz,drop + dw fh,reposf,drop + dw pleav,readl2-cw +readl3 dw cat + dw eol,rot + dw scan,nip + dw qdup + dw zbran,readl4 + dw ido,plus,tor + dw over,plus + dw fromr + dw swap,subb + dw dupp,zneq ; handle buffer > 32K + dw fh,fpos,drop + dw dplus + dw fh,reposf,drop + dw ido,swap,subb + dw true,zero + dw unloo,exit +readl4 dw xloop,readl2 +readl5 dw nip + dw dupp,zneq,zero + dw exit + +; WRITE-LINE ( c-addr u fileid -- ior ) +; dup >r write-file ?dup if r> drop end +; eol r> write-file + + hdr 1,'WRITE-LINE' +writl: call docol + dw dupp,tor + dw writf + dw qdup + dw zbran,writl1 + dw fromr,drop + dw exit +writl1 dw eol + dw fromr + dw writf + dw exit + +; >FNAME ( addr1 u -- addr2 ) -blanks (pfsiz-1) min zbuf @ pack +; 0 affix zbuf 2@ swap zbuf 2! + + hdr 1,'>FNAME' +tfnam: call docol + dw dblan + dw clit + db pfsiz-1 + dw min + dw zbuf,at + dw pack + dw zero,affix ; trailing null + dw zbuf,tat + dw swap + dw zbuf,tstor + dw exit + + cseg + +pascii: push bx + push ax + call docol + dw tfnam,onep + dw exit1 + pop dx ; addr + ret + +; R/O ( -- fam ) aka 0 r/o + + hdr 1,'R/O',,,zero +rso equ zero + +; W/O ( -- fam ) aka 1 w/o + + hdr 1,'W/O',,,one +wso equ one + +; R/W ( -- fam ) aka 2 r/w + + hdr 1,'R/W',,,two +rsw equ two + +; BIN ( fam1 -- fam2 ) aka noop bin immediate + + hdr 1,'BIN',1,,noop +binn equ next + +; OPEN-FILE ( c-addr u fam -- fileid ior ) + + hdr 1,'OPEN-FILE' +openf: pop dx + pop ax + pop bx + push dx + call pascii +openf1: pop ax ; fam + mov ah,3dh + jmp readf2 + +; CREATE-FILE ( c-addr u fam -- fileid ior ) + + hdr 1,'CREATE-FILE' +creatf: pop dx + pop ax + pop bx + push dx ; fam (or dummy fileid if fail) + call pascii + push dx ; asciiz + sub cx,cx ; normal attribute + mov ah,3ch + int 21h + jnc creatf1 + pop dx ; discard + jmp doserr1 ; failed + +creatf1:mov bx,ax ; close and re-open file using fam + mov ah,3eh + int 21h + pop dx ; asciiz + jmp openf1 + +; CLOSE-FILE ( fileid -- ior ) + + hdr 1,'CLOSE-FILE' +closf: pop bx + mov ah,3eh + jmp resizf1 + +; FLUSH-FILE ( fileid -- ior ) + + hdr 1,'FLUSH-FILE' +flusf: pop bx + mov ah,45h + int 21h + jc flusf1 + push ax + jmp closf + +flusf1: jmp doserr1 + +; FILE-STATUS ( c-addr u -- x ior ) get file attributes + + hdr 1,'FILE-STATUS' +statf: pop ax + pop bx + call pascii + mov ax,4300h + int 21h + push cx + jmp doserr1 + +; DELETE-FILE ( c-addr u -- ior ) + + hdr 1,'DELETE-FILE' +delf: pop ax + pop bx + call pascii + mov ah,41h + jmp resizf1 + +; RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ior ) + + hdr 1,'RENAME-FILE' +renf: pop ax + pop bx + call pascii + pop ax + pop bx + push dx + call pascii + pop di + mov ax,ds + mov es,ax + mov ah,56h + int 21h + jmp doserr1 + +; screen file selector + + aseg + +fdtab: gfdb ; fdb table + +; sfp ( -- a ) + + hdr x,'SFP',,1 +sfp: call docre +sfp1 dw fdtab ; current +sfp2 dw fdtab+cw ; swap-file + +; SWAP-FILE ( -- ) screen? if scr @ scr# ! then sfp 2@ swap +; sfp 2! scr# @ scr ! empty-buffers + + hdr 1,'SWAP-FILE',,1 +swapf: call docol + dw scrnq + dw zbran,swapf1 + dw scr,at + dw snum,store +swapf1 dw sfp,tat + dw swap + dw sfp,tstor + dw snum,at + dw scr,store + dw mtbuf + dw exit + +; FDB ( -- addr ) (fdtab) (nfd) 0 do dup @ @ 0= if unloop end +; cell+ loop abort" too many files" + + hdr 1,'FDB',,1 ; get a free slot +fdb: mov bx,offset fdtab + mov cx,nfd +fdb1: +; cmp bx,sfp2 ; skip swap-file +; jz fdb2 + mov di,[bx] + cmp word ptr [di],0 + jz fdb3 +fdb2: inc bx + inc bx + loop fdb1 + call docol + dw one + dw pabq + dcs 'too many files' + +fdb3: push bx + nextt + +; file descriptor fields +; +; FD cell status 0=closed +; FID cell file handle +; BLKS cell file size (blocks) +; SCR# cell current SCR# +; FNB 'pfsiz' bytes file name + +; fnb ( -- addr ) + + hdr x,'FNB',,1 +fnb: mov al,cw*4 ; file name field + ignore2 + +; scr# ( -- addr ) + + hdr x,'SCR#',,1 +snum: mov al,cw*3 ; current SCR# field + ignore2 + +; blks ( -- addr ) + + hdr x,'BLKS',,1 +blks: mov al,cw*2 ; file size field + ignore2 + +; fid ( -- addr ) + + hdr x,'FID',,1 +fid: mov al,cw*1 ; file handle field + ignore2 + +; fd ( -- addr ) + + hdr x,'FD',,1 +fd: mov al,0 ; file descriptor field + sub ah,ah + mov di,sfp1 + add ax,[di] + jmp apush + +; buf ( -- addr ) + + hdr x,'BUF',,1 +buf: call docon ; file buffer address + dw sfb + +; blk# ( -- addr ) + + hdr x,'BLK#',,1 +bnum: call docre ; block#, update flag +bnum1 dw ? + +; SCREEN? ( -- flag ) fd @ 0< + + hdr 1,'SCREEN?',,1 +scrnq: call docol + dw fd,at + dw zless + dw exit + +; LOADFILE ( -- c-addr u ) fnb count + + hdr 1,'LOADFILE',,1 +loadf: call docol + dw fnb,count + dw exit + +; ?open ( -- ) screen? 0= abort" no file open" + + hdr x,'?OPEN',,1 +qopen: call docol + dw scrnq + dw zequ + dw pabq + dcs 'no file open' + dw exit + +; #SCREENS ( -- +n ) ?open blks @ + + hdr 1,'#SCREENS',,1 +nscr: call docol + dw qopen + dw blks,at + dw exit + +; EMPTY-BUFFERS ( -- ) $7fff blk# ! + + hdr 1,'EMPTY-BUFFERS',,1 +mtbuf: mov bnum1,7fffh + nextt + +; UPDATE ( -- ) ?open blk# @ $8000 or blk# ! + + hdr 1,'UPDATE',,1 +update: call docol + dw qopen + dw exit1 + or bnum1,8000h + nextt + +; blkerr ( flag -- ) abort" block r/w error" + + hdr x,'BLKERR',,1 +blkerr: call docol + dw pabq + dcs 'block r/w error' + dw exit + +; blk-rw ( +n mode -- ) >r b/buf um* fid @ reposition-file blkerr +; buf b/buf fid @ r> if write-file blkerr +; fid @ flush-file else read-file blkerr +; b/buf < then blkerr + + hdr x,'BLK-RW',,1 +blkrw: call docol + dw tor + dw bbuf,umstr + dw fid,at + dw reposf + dw blkerr + dw buf,bbuf + dw fid,at + dw fromr + dw zbran,blkrw1 + dw writf + dw blkerr + dw fid,at + dw flusf ; flush CP/M 3 buffers + dw bran,blkrw2 +blkrw1 dw readf + dw blkerr + dw bbuf,less +blkrw2 dw blkerr + dw exit + +; ?blk ( +n -- +n ) dup #screens 0 within +; abort" block out of range" + + hdr x,'?BLK',,1 +qblk: call docol + dw dupp + dw nscr,zero + dw within ; block in range? + dw pabq + dcs 'block out of range' + dw exit + +; SAVE-BUFFERS ( -- ) ?open blk# @ 0< if blk# @ $7fff and +; dup blk# ! ?blk 1 blk-rw then + + hdr 1,'SAVE-BUFFERS',,1 +savbuf: call docol + dw qopen + dw bnum,at + dw zless + dw zbran,savbuf1 + dw bnum,at + dw lit,7fffh + dw andd + dw dupp + dw bnum,store + dw qblk ; block in range? + dw one,blkrw +savbuf1 dw exit + +; FLUSH ( -- ) save-buffers empty-buffers + + hdr 1,'FLUSH',,1 +flush: call docol + dw savbuf,mtbuf + dw exit + +; BUFFER ( +n -- addr ) save-buffers ?blk blk# ! buf + + hdr 1,'BUFFER',,1 +buffer: call docol + dw savbuf + dw qblk + dw bnum,store + dw buf + dw exit + +; BLOCK ( +n -- addr ) ?open blk# @ $7fff and over - if dup +; buffer drop 0 blk-rw else drop then buf + + hdr 1,'BLOCK',,1 +block: call docol + dw qopen + dw bnum,at + dw lit,7fffh + dw andd,over,subb + dw zbran,block1 + dw dupp,buffer,drop + dw zero,blkrw + dw bran,block2 +block1 dw drop +block2 dw buf + dw exit + +; --> ( -- ) blk @ 0= abort" loading only" (refill) drop +; ;immediate + + hdr 1,'-->',1,1 +arrow: call docol + dw blk,at + dw zequ + dw pabq + dcs 'loading only' + dw prefil,drop + dw exit + +; (thru) ( +n1 +n2 -- ) 1+ swap ?do i block b/buf i (eval) loop + + hdr x,'(THRU)',,1 +pthru: call docol + dw onep,swap + dw xqdo,pthru2 +pthru1 dw ido,block + dw bbuf + dw ido,peval + dw xloop,pthru1 +pthru2 dw exit + +; LOAD ( +n -- ) dup thru + + hdr 1,'LOAD',,1 +load: pop ax + push ax + push ax +; jmp thru + +; THRU ( +n1 +n2 -- ) (thru) ?block + + hdr 1,'THRU',,1 +thru: call docol + dw pthru + dw qblock + dw exit + +; (fbk) ( +n -- ) #screens 2dup u< if drop dup then dup b/buf +; um* fid @ resize-file throw over blks ! ?do +; i buffer b/buf blank update save-buffers loop + + hdr x,'(FBK)',,1 +pfbk: call docol + dw nscr ; tests if file open + dw tdup,uless + dw zbran,pfbk1 + dw drop,dupp +pfbk1 dw dupp + dw bbuf,umstr + dw fid,at + dw resizf,throw +pfbk2 dw over + dw blks,store ; update max block + dw xqdo,pfbk4 +pfbk3 dw ido,buffer + dw bbuf,blank + dw update,savbuf + dw xloop,pfbk3 +pfbk4 dw exit + +; FILEBLOCKS ( +n -- ) ['] (fbk) catch abort" can't resize file" + + hdr 1,'FILEBLOCKS',,1 +fbloc: call docol + dw lit,pfbk + dw catch + dw pabq + dcs 'can''t resize file' + dw exit + +; CLOSE ( -- ) screen? if flush fid @ close-file drop +; fd off then empty-buffers +; +; NOTE: errors are NOT reported with this function + + hdr 1,'CLOSE',,1 ; close current file +close: call docol + dw scrnq + dw zbran,close1 + dw flush + dw fid,at + dw closf,drop + dw fd,off +close1 dw mtbuf + dw exit + +; CLOSE-ALL ( -- ) close (fdtab) nfd 0 do dup sfp ! close +; cell+ loop drop + + hdr 1,'CLOSE-ALL',,1 +closa: call docol + dw close ; ensure buffer flushed + dw lit,fdtab + dw clit + db nfd + dw zero + dw xdo,closa2 +closa1 dw dupp + dw sfp,store + dw close + dw cellp + dw xloop,closa1 +closa2 dw drop + dw exit + +; LASTFILE ( -- c-addr u ) zbuf cell+ @ count + + hdr 1,'LASTFILE',,1 +lastf: call docol ; last named file used by open-file etc + dw zbuf,cellp + dw at,count + dw exit + +; .lastfile ( -- ) beep cr lastfile type space + + hdr x,'.LASTFILE',,1 +dotlf: call docol + dw beep,crr + dw lastf,typee + dw space + dw exit + +; ?create ( c-addr u -- fileid ) +; r/o open-file 0= tuck if close-file then +; drop if .lastfile ." exists - delete it? " +; y/n 0= if abort then then lastfile r/w +; create-file abort" can't create file" + + hdr x,'?CREATE',,1 +qcreat: call docol + dw rso,openf ; test if file exists + dw zequ,tuck + dw zbran,qcreat1 + dw closf +qcreat1 dw drop + dw zbran,qcreat2 + dw dotlf + dw pdotq + dcs 'exists - delete it? ' + dw yn,zequ + dw zbran,qcreat2 + dw abort +qcreat2 dw lastf,rsw,creatf + dw pabq + dcs 'can''t create file' + dw exit + +; init-scr ( fileid ior -- ) if drop end fdb sfp ! fd on +; dup fid ! file-size drop b/buf +; um/mod nip blks ! lastfile fnb +; pack count upper empty-buffers + + hdr x,'INIT-SCR',,1 +iniscr: call docol ; init screenfile + dw zbran,iniscr1 + dw drop + dw exit +iniscr1 dw fdb,sfp,store + dw fd,on + dw dupp,fid,store + dw fsiz,drop + dw bbuf,umslm,nip ; overflow stores $FFFF + dw blks,store + dw lastf,fnb,pack + dw count,upper + dw mtbuf + dw exit + +; OPEN ( c-addr u fam -- ior ) fdb drop >r s" scr" +ext r> +; open-file tuck init-scr + + hdr 1,'OPEN',,1 ; open a screen file +open: call docol + dw fdb,drop ; free slot? + dw tor + dw psqot + dcs 'scr' + dw pext + dw fromr,openf + dw tuck + dw iniscr + dw exit + +; (open) ( c-addr u -- ) r/w open abort" can't open file" + + hdr x,'(OPEN)',,1 +popen: call docol + dw rsw,open + dw pabq + dcs 'can''t open file' + dw exit + +; GETFILENAME ( -- c-addr u ) >in @ char dup rot >in ! [char] " +; - if drop bl then word count dup +; 0= abort" specify filename" + +; GETFILENAME ( -- c-addr u ) token dup 0= abort" specify filename" + + hdr 1,'GETFILENAME',,1 +getfn: call docol + dw token + dw dupp,zequ + dw pabq + dcs 'specify filename' + dw exit + +; USING ( "filename[.SCR]" -- ) close getfilename r/w open ?dup if +; .lastfile -507 = if ." access denied" +; 0 else ." not found - create it? " +; y/n then 0= if abort then lastfile +; ?create 0 init-scr then 0 0 scr 2! + + hdr 1,'USING',,1 ; open/make a screen file +using: call docol + dw close + dw getfn + dw rsw,open,qdup + dw zbran,using4 + dw dotlf + dw lit,-507 + dw equal + dw zbran,using1 + dw pdotq + dcs 'access denied' + dw zero + dw bran,using2 +using1 dw pdotq + dcs 'not found - create it? ' + dw yn +using2 dw zequ + dw zbran,using3 + dw abort +using3 dw lastf,qcreat + dw zero,iniscr +using4 dw zero,zero ; reset SCR + dw scr,tstor + dw exit + +; LOADED ( +n1 +n2 c-addr u -- ) sfp @ >r (open) (thru) close r> +; sfp ! ?block + + hdr 1,'LOADED',,1 +loaded: call docol + dw sfp,at + dw tor + dw popen + dw pthru + dw close + dw fromr + dw sfp,store + dw qblock + dw exit + +; FLOAD ( +n "filename[.SCR]" -- ) dup getfilename loaded + + hdr 1,'FLOAD',,1 +fload: call docol + dw dupp + dw getfn + dw loaded + dw exit + + cseg + +hstart dw ? ; segment offset of heads in image + + aseg + +exehdr db 'MZ' ; 0 EXE id + dw ? ; 2 file size (mod 512) + dw ? ; 4 file size (512 byte blocks) + dw 0 ; 6 # relocation items + dw 2 ; 8 exe header size (paragraphs) + dw 0 ; A minimum paragraphs needed + dw 0FFFFh ; C maximum paragraphs needed + dw 0FFF0h ; E stack segment + dw tmpstk ;10 stack offset + dw 0 ;12 checksum (ignored by DOS) + dw start ;14 start address + dw 0FFF0h ;16 code segment + dw 1Ch ;18 offset 1st relocation + dw 0 ;1A overlay # 0=resident code + dw 0 ;1C null relocation item + dw 0 ;1E " " + +; SAVE ( "filename[.EXE]" -- ) +; 0 0 protect getfilename s" exe" +ext +; ?create >r over swap boot 2! (logo) (zb1) +; dup (zbsiz*2) erase (elogo-logo) cmove +; (exehdr) (100h-20h) $20 cmove 0= >r hseg +; 0 dph @ r@ and limit dp 2@ >r over - r@ + +; $0F + $FFF0 and r@ - r> over + 4 rshift +; (hstart) ! r> and (100h-20h) dp @ over - +; dup 3 pick + 0 6 pick m+ 512 um/mod over +; 0<> - swap (100h-20h+2) 2! r@ write-file +; boot cell+ off ?dup 0= if r@ write-file +; ?dup 0= if r@ lwrite then then r> +; close-file or abort" can't save file" + + hdr 1,'SAVE',,1 +save: call docol + dw zero,zero +save1 dw prot + dw getfn + dw psqot + dcs 'exe' + dw pext + dw qcreat + dw tor ; fid + dw over,swap ; set boot flags + dw boot,tstor + dw lit,logo ; insert compiler logo + dw lit,zb1 + dw dupp + dw clit + db zbsiz*2 + dw erase + dw clit + db elogo-logo + dw cmove + dw lit,exehdr ; position header + dw lit,100h-20h + dw clit + db 20h + dw cmove + dw zequ,tor ; system flag + dw hseg,zero + dw dph,at + dw rat,andd ; heads size + dw limit + dw dpp,tat + dw tor + dw over,subb + dw rat,plus + dw clit + db 0fh + dw plus + dw lit,0fff0h + dw andd + dw rat,subb + dw fromr + dw over,plus + dw clit + db 4 + dw rsh + dw lit,hstart + dw store + dw fromr,andd ; system size + dw clit + db 100h-20h + dw dpp,at + dw over,subb + dw dupp + dw three,pick + dw plus + dw zero + dw clit + db 6 + dw pick + dw mplus + dw lit,512 + dw umslm + dw over,zneq,subb + dw swap + dw lit,100h-20h+2 + dw tstor + dw rat,writf ; save application + dw boot,cellp,off ; reset forth flag + dw qdup,zequ + dw zbran,save2 ; error + dw rat,writf ; save system + dw qdup,zequ + dw zbran,save2 ; error + dw rat,lwrit ; save heads +save2 dw fromr,closf + dw orr + dw pabq + dcs 'can''t save file' + dw exit + +; TURNKEY ( "bootword" "filename[.EXE]" -- ) + + hdr 1,'TURNKEY',,1 +turnk: call docol + dw true +turnk1 dw tick + dw bran,save1 + +; TURNKEY-SYSTEM ( "bootword" "filename[.EXE]" -- ) + + hdr 1,'TURNKEY-SYSTEM',,1 +turnks: call docol + dw zero + dw bran,turnk1 + +; CHAR+ ( c-addr1 -- c-addr2 ) aka 1+ char+ + + hdr 1,'CHAR+',,,onep +charp equ onep + +; CHARS ( n1 -- n2 ) aka noop chars immediate + + hdr 1,'CHARS',1,,noop +chars equ next + +; CELL+ ( addr1 -- addr2 ) aka 2+ cell+ + + hdr 1,'CELL+',,,twop +cellp equ twop + +; CELL- ( addr1 -- addr2 ) aka 2- cell- + + hdr 1,'CELL-',,,twom +cellm equ twom + +; CELLS ( n1 -- n2 ) aka 2* cells + + hdr 1,'CELLS',,,tstar +cells equ tstar + +; ALIGN ( -- ) aka noop align immediate + + hdr 1,'ALIGN',1,,noop +alignn equ next + +; ALIGNED ( addr -- a-addr ) aka noop aligned immediate + + hdr 1,'ALIGNED',1,,noop +alignd equ next + + if float +; +; Floating Point Functions +; +; -FP FLOAT+ FLOATS FALIGN FALIGNED F, FLITERAL FCONSTANT +; FVARIABLE FDEPTH FDROP FDUP FSWAP FOVER FROT F@ F! FPICK +; FABS FNEGATE D>F F>D S>F F>S F0= F= F0< F< F0> F> +; FMIN FMAX FLOOR FROUND FTRUNC FCEIL F+ F- F* F/ FRANDOM +; MAX-PRECISION REPRESENT >FLOAT PRECISION SET-PRECISION (FS.) +; FS.R FS. (FE.) FE.R FE. (F.) F.R F. (G.) G.R G. FSQRT +; FEXP FLN F** FSIN FCOS FATAN PI fpinit fident fnumber +; + +; -FP ( -- addr ) marker -FP + + hdr 1,'-FP',,1 +dfp: call drop + +; FLOAT+ ( f-addr1 -- f-addr2 ) 4 + + + hdr 1,'FLOAT+' +floatp: pop ax + add ax,fw + jmp apush + +; FLOATS ( n1 -- n2 ) 4 * + + hdr 1,'FLOATS' +floats: pop ax + shl ax,1 + shl ax,1 + jmp apush + +; FALIGN ( -- ) aka noop falign immediate + + hdr 1,'FALIGN',1,,noop +falign equ next + +; FALIGNED ( addr -- f-addr ) aka noop faligned immediate + + hdr 1,'FALIGNED',1,,noop +falignd equ next + + if fstack + + cseg + +; pop fp-stack to CX,DX + +fpop: mov bx,fspp + mov cx,[bx] + mov dx,[bx+2] + add word ptr fspp,fw + ret + +; push CX,DX to fp-stack + +fpush: sub word ptr fspp,fw + mov bx,fspp + mov [bx],cx + mov [bx+2],dx + ret + +; FLITERAL runtime + +flit: lodsw + mov cx,ax + lodsw + mov dx,ax + call fpush + nextt + +; FCONSTANT runtime + +dofcon: pop bx + mov cx,[bx] + mov dx,[bx+2] + call fpush + nextt + + else + +flit equ tlit +dofcon equ tat + + endif ;fstack + +; F, (F: r -- ) or ( r -- ) + + hdr 1,'F,',,1 +fcomm: call docol + dw here + dw clit + db fw + dw allot + dw fstor + dw exit + +; FLITERAL ( -- r ) postpone flit f, ;immediate + + hdr 1,'FLITERAL',1,1 +flite: call docol + dw comp,flit + dw fcomm + dw exit + +; FCONSTANT ( -- r ) + + hdr 1,'FCONSTANT',,1 +fcon: call docol + dw lit,dofcon + dw build + dw fcomm + dw exit + +; FVARIABLE ( -- f-addr ) aka 2variable fvariable + + hdr 1,'FVARIABLE',,,tvar +fvar equ tvar + +; FDEPTH ( -- +n ) fs0 @ fsp @ - 2/ 2/ + + hdr 1,'FDEPTH' +fdepth: call docol + if fstack + dw fszero,at + dw fsp,at + dw subb + dw twodiv + else + dw depth + endif + dw twodiv + dw exit + +; FDROP ( r -- ) + + if fstack + hdr 1,'FDROP' +fdrop: add word ptr fspp,fw + nextt + else + hdr 1,'FDROP',,,tdrop ; aka 2drop fdrop +fdrop equ tdrop + endif + +; FDUP ( r -- r r ) + + if fstack + hdr 1,'FDUP' +fdup: xchg fspp,sp + mov bx,sp + push [bx+2] + push [bx] + xchg fspp,sp + nextt + else + hdr 1,'FDUP',,,tdup ; aka 2dup fdup +fdup equ tdup + endif + +; FSWAP ( r1 r2 -- r2 r1 ) + + if fstack + hdr 1,'FSWAP' +fswap: mov bx,fspp + mov ax,[bx] + xchg ax,[bx+4] + mov [bx],ax + mov ax,[bx+2] + xchg ax,[bx+6] + mov [bx+2],ax + nextt + else + hdr 1,'FSWAP',,,tswap ; aka 2swap fswap +fswap equ tswap + endif + +; FOVER ( r1 r2 -- r1 r2 r1 ) + + if fstack + hdr 1,'FOVER' +fover: xchg fspp,sp + mov bx,sp + push [bx+6] + push [bx+4] + xchg fspp,sp + nextt + else + hdr 1,'FOVER',,,tover ; aka 2over fover +fover equ tover + endif + +; FROT ( r1 r2 r3 -- r2 r3 r1 ) + + if fstack + hdr 1,'FROT' +frot: mov bx,fspp + mov ax,[bx] + xchg ax,[bx+4] + xchg ax,[bx+8] + mov [bx],ax + mov ax,[bx+2] + xchg ax,[bx+6] + xchg ax,[bx+10] + mov [bx+2],ax + nextt + else + hdr 1,'FROT',,,trot ; aka 2rot frot +frot equ trot + endif + +; F@ ( f-addr -- r ) + + if fstack + hdr 1,'F@' +fat: pop bx + mov cx,[bx] + mov dx,[bx+2] + call fpush + nextt + else + hdr 1,'F@',,,tat ; aka 2@ f@ +fat equ tat + endif + +; F! ( r f-addr -- ) + + if fstack + hdr 1,'F!' +fstor: call fpop + pop bx + mov [bx],cx + mov [bx+2],dx + nextt + else + hdr 1,'F!',,,tstor ; aka 2! f! +fstor equ tstor + endif + +; FPICK ( +n -- r ) floats sp@ cell+ + f@ + + hdr 1,'FPICK' +fpick: call docol + dw floats + if fstack + dw fsp,at + else + dw spat,cellp + endif + dw plus,fat + dw exit + + cseg + +; floating point accumulator + +acce db 5 dup (?) ; exponent +accs = acce+1 ; sign +acc1 = accs+1 ; 1st fraction (msb) +acc2 = acc1+1 ; 2nd fraction +acc3 = acc2+1 ; 3rd fraction + +sf db ? ; subtraction flag + +f1 dd ? ; temp float storage +f2 dd ? ; +f3 dd ? ; + +ften: call dofcon +fp10 db 84h,20h,0,0 ; 10.0 + +; save/load temp fp registers + +savf1: mov bx,offset f1 ; save regs to f1 + jmp short stom + +savf2: mov bx,offset f2 ; save regs to f2 + jmp short stom + +lodf1: mov bx,offset f1 ; load accum/regs from f1 + jmp short lod + +lodf2: mov bx,offset f2 ; load accum/regs from f2 + jmp short lod + +; pop float from stack to accum + +ldop: + if fstack + call fpop + mov bx,offset f1 + mov [bx],cx + mov [bx+2],dx + else + pop dx + pop word ptr f1 + pop word ptr f1+2 + push dx + mov bx,offset f1 + endif + jmp short lod + +; pop 2 float from stack to bx (f2) and accum + +ld2op: + if fstack + call fpop + mov bx,offset f2 + push bx + mov [bx],cx + mov [bx+2],dx + call ldop + pop bx + else + pop di + pop word ptr f2 + pop word ptr f2+2 + call ldop + push di + mov bx,offset f2 + endif + ret + +; push float registers to stack and exit + +svop: mov dl,cl + mov cl,al + if fstack + call fpush + else + push dx + push cx + endif + nextt + +; overflow - set regs to maximum, set cy + +ovf: mov cx,7fffh + mov al,cl + mov dh,cl + stc + ret + +; zero - set accum and regs to zero + +zro: sub ax,ax + mov acce,al + mov cx,ax + mov dh,al + ret + +; load float [bx] to accum and regs, set flags +; entry - bx=adr +; exit - cx:dh (packed), al=exp, flags set + +lod: mov dl,[bx] + and dl,dl + jnz lod1 + jmp short zro + +lod1: mov ch,[bx+1] + mov cl,[bx+2] + mov dh,[bx+3] + mov al,ch + or ch,80h + xor al,ch +lod2: call storr + xor al,ch + jmp short tst1 + +; store regs to accum dl=exp + +storr: mov bx,offset acce + mov [bx],dl + inc bx + +; store regs to mem +; entry - bx=adr al=exp cx:dh (packed) +; exit - none + +stom: mov [bx],al +stom1: mov [bx+1],ch + mov [bx+2],cl + mov [bx+3],dh + ret + +; change sign of accumulator and again +; when calling routine completes + +chss: call chs + pop bx + call bx + +; change sign of accumulator +; entry - none +; exit - cx:dh (packed) al=exp flags set + +chs: xor byte ptr accs,80h + +; load regs from acc and test + +lodr: mov bx,offset acce + mov dl,[bx] ; exp + or dl,dl + jz zro + mov al,[bx+1] ; accs + xor al,[bx+2] ; msb sign packed + mov cl,[bx+3] + mov dh,[bx+4] + +; entry - al:cl:dh (packed) dl=exp +; exit - cx:dh (packed) al=exp flags set + +tst1: mov ch,al +tst2: or al,1 ; test sign, clear Z C flags +tst3: mov al,dl + ret + +; entry - al=exp +; exit - dl=exp Z=zero S=negative + +tstr: mov dl,al + or al,al + jnz tstr1 + ret + +tstr1: mov al,ch + jmp tst2 + +; normalize and pack cx:dx + +npack: or ch,ch + js fpack + call norm + js fpack + jmp zro ; underflow or zero + +; pack cx:dx + +fpack: call rondr ; round cx:dx + jnc tst1 + jmp ovf + +; compare regs with mem [bx], return S if regs < mem, Z if match +; bx preserved + +fcmp: cmp byte ptr [bx],0 + jz tstr ; mem=0 test regs sign + + or al,al + mov dl,al + mov al,[bx+1] + not al + jz tst2 ; regs=0 test mem sign + + xor al,ch + jns tstr1 ; signs differ + + cmp dl,[bx] + jnz fcmp1 + cmp ch,[bx+1] + jnz fcmp1 + cmp cl,[bx+2] + jnz fcmp1 + cmp dh,[bx+3] + jz tst3 ; regs = mem +fcmp1: rcr al,1 ; carry to sign + xor al,ch ; complement sign for neg values + jmp tst2 + +; right shift n bits +; entry - cx:dh al=count +; exit - cx:dx + +shrr: sub dl,dl +shrr1: or al,al ; test for zero + jz shrr2 + shr cx,1 + rcr dx,1 + dec al + jmp shrr1 + +shrr2: ret + +; Complement cx:dx adjust accs, return sign flag + +fcpl: xor byte ptr accs,80h ; change accum sign + neg cx ; complement fraction + neg dx + sbb cx,0 + ret + +; Normalize cx:dx adjust acce +; entry - cx:dx +; exit - cx:dx z=cx:dx=0 or acce=0 sign=underflow + +norm: mov bl,32 ; max shift +norm1: or ch,ch + jnz norm3 + xchg ch,cl + xchg cl,dh + xchg dh,dl + sub bl,8 + jnz norm1 + ret ; cx:dx = zero + +norm2: dec bl ; shl until bit 31 set + shl dx,1 + rcl cx,1 + or ch,ch +norm3: jns norm2 + mov al,bl ; adjust accum exp + sub al,32 + mov bx,offset acce + add al,[bx] + mov [bx],al + jz norm4 + rcr al,1 ; carry to sign + and al,al ; sign = underflow +norm4: ret + +; Round the cx:dx registers, save to acc +; entry - cx:dx +; exit - cx:dh al=packed msb dl=exp cy=ovf + +rondr: and dl,dl ; test bit 7 and clear cy + mov bx,offset acce ; exp + mov dl,[bx] + jns rondr1 + inc dh ; round up cx:dh dl=exp + jnz rondr1 + inc cx + jnz rondr1 + mov ch,80h ; new 1st fraction + add dl,1 ; inc exp adjust cy + mov acce,dl ; new acc exp +rondr1: jc rondr2 ; overflow + mov al,ch + inc bx ; accs + xor al,[bx] ; a=packed msb + jmp stom1 ; save cx:dh to acc + +rondr2: ret + +; fsu floating point subtract subroutine + +fsu: mov ch,80h ; mask to change operand sign + ignore2 + +; fad floating point add subroutine + +fad: mov ch,0 + mov dl,[bx] ; load operand + xor ch,[bx+1] + mov cl,[bx+2] + mov dh,[bx+3] + and dl,dl + jz fad2 ; operand zero + + mov al,ch ; unpack + or ch,80h + xor al,ch ; generate subtraction flag + + mov bx,offset accs + xor al,[bx] + mov sf,al + +; determine relative magnitudes of operand and accum + + dec bx + mov al,[bx] ; acce + or al,al + jz fad8 ; accum zero + + sub al,dl ; get difference of exponents + jc fad3 ; accum smaller + +; check insignificant operand + + js fad2 + + cmp al,25 ; compare shift count to 25 + jc fad4 + +fad2: jmp lodr + +; check insignificant accum + +fad3: jns fad8 + + cmp al,0-25 ; compare shift count to -25 + jc fad8 ; move operand to accum + + mov [bx],dl ; set acce + neg al ; complement shift count + mov dl,sf + xor [bx+1],dl ; set accs + xchg ch,[bx+2] ; exchange fraction + xchg cl,[bx+3] + xchg dh,[bx+4] + +; position the operand, check if add or subtract + +fad4: call shrr + mov bx,offset acc3 + mov al,sf + or al,al + js fad6 + + add dh,[bx] ; add + adc cl,[bx-1] + adc ch,[bx-2] + jnc fad5 + + rcr cx,1 ; rshift fraction + rcr dx,1 + add byte ptr acce,1 ; adjust exponent + jnc fad5 + jmp ovf ; overflow + +fad5: jmp fpack + +fad6: neg dl ; subtract + mov al,[bx] + sbb al,dh + mov dh,al + mov al,[bx-1] + sbb al,cl + mov cl,al + mov al,[bx-2] + sbb al,ch + mov ch,al + jnc fad7 + call fcpl ; complement +fad7: jmp npack + +; move operand to accumulator + +fad8: mov al,sf + mov bx,offset accs + xor al,[bx] + jmp lod2 + +; read the operand at (bx), check the accum exponent + +mdex: mov ch,al + mov cl,[bx+1] + mov dh,[bx+2] + mov dl,[bx+3] + + mov bx,offset acce ; accum exp + mov al,[bx] + or al,al + jz mdex2 ; is zero + + add al,ch ; result exp plus bias + mov ch,al + rcr al,1 ; carry to sign + xor al,ch ; carry and sign must differ + mov al,ch ; result exp plus bias + mov ch,80h ; exp bias, sign mask, most sig bit + jns mdex1 ; if over or underflow + + sub al,ch ; remove excess exp bias + jz mdex2 ; return if underflow + + mov [bx],al ; result exp + inc bx ; address accum sign + xor [bx],cl ; result sign in sign bit + and [bx],ch ; result sign + + mov al,cl ; operand sign and 1st fraction + or al,ch ; operand first fraction + ret + +mdex1: rol al,1 ; set carry bit if overflow + jc mdex2 + sub al,al ; clear register +mdex2: ret + +; fixed point multiply subroutine al:dx * acc -> cx:dh + +mulx: mov di,dx ; 3rd 2nd multiplicand + +; multiply by each accumulator fraction in turn + + sub ah,ah ; clear 6th product + sub dx,dx ; clear 4th 5th product + mov bx,offset acc3 ; multiply by accum 3rd fraction + call mulx2 + mov bx,offset acc2 ; multiply by accum 2nd fraction + call mulx1 + mov bx,offset acc1 + +; multiply by one accumulator byte + +mulx1: mov ah,dh ; 5th partial product + mov dx,cx ; 3rd 4th partial prod +mulx2: mov ch,[bx] ; multiplier + sub cl,cl ; 2nd partial prod + cmp cl,ch ; set carry bit for exit flag + jc mulx4 ; if multiplier is zero + mov cl,dh ; 2nd partial product + mov dh,dl ; 3rd partial prod +mulx3: ret + +; loop for each bit of multiplier byte + +mulx4: adc ah,ah ; shift exit flag out if done + jz mulx3 ; exit if multiplication done + rcl dx,1 ; 4th 3rd partial prod + rcl cx,1 ; 2nd 1st partial prod + jnc mulx4 ; if addition required + +; add the multiplicand to the product if the multiplier bit is one + + add dx,di ; 4th 3rd partial prod + adc cl,al ; 2nd partial prod + adc ch,0 ; add carry to 1st prod + clc + jmp mulx4 + +; fmu floating point multiplication subroutine + +fmu: mov al,[bx] ; operand exponent + or al,al + push bx + jz fmu1 + call mdex ; read operand +fmu1: pop bx + jz fmu3 ; zero or underflow + jc fmu4 ; overflow + call mulx ; fixed mult + or ch,ch ; normalize if necessary + js fmu2 + dec byte ptr acce ; dec accum exp + jz fmu3 ; underflow + shl dx,1 + rcl cx,1 +fmu2: jmp fpack + +fmu3: jmp zro ; zero or underflow +fmu4: jmp ovf ; overflow + +; fixed point divide +; entry - al:dx +; exit - cx:dx nc=overflow + +; subtract divisor from accum to obtain 1st remainder + +divx: mov bx,offset acc1 + sub [bx+2],dl ; acc 3rd fraction + sbb [bx+1],dh ; acc 2nd fraction + sbb [bx],al ; acc 1st fraction + +; halve divisor and store for addition or subtraction cl:dx:ch + + sub ah,ah ; init quot 1st fraction + sar al,1 ; divisor 1st fraction + rcr dx,1 ; divisor 2nd 3rd fraction + rcr ah,1 ; divisor 4th fraction is zero + + mov di,dx + +; load 1st remainder + + mov dl,[bx] ; 1st fraction + mov bx,[bx+1] ; 2nd 3rd fraction + xchg bh,bl + +; position remainder, initialise quotient, check sign + + sub cx,cx ; init quot 2nd fraction + sub dh,dh ; init quot 3rd fraction + or dl,dl ; test sign, clear cy + js divx5 ; remainder negative + inc byte ptr acce ; inc quotient exponent + jnz divx1 + ret ; overflow + +divx1: inc dh ; init quot 3rd fraction + ; sub divisor if remainder positive +divx2: neg ah ; 4th fraction is zero + neg ah + sbb bx,di ; 2nd 3rd fraction + sbb dl,al ; 1st fraction + +divx3: rol ch,1 ; shift remainder left one bit + ror ch,1 + jnc divx4 + ret ; division complete + +divx4: rol ah,1 ; shift remainder 4th fraction to carry + ror ah,1 + rcl bx,1 ; shift cx:dx:bx + rcl dx,1 + rcl cx,1 + + ; branch if subtraction is required + ror dh,1 ; quotient 3rd fraction + rol dh,1 ; remainder sign to carry bit + jc divx2 ; to sub divisor if remainder positive + ; add divisor if remainder negative +divx5: add bx,di ; 2nd 3rd fraction + adc dl,al ; 1st fraction + jmp divx3 + +; fdi floating point division subroutine + +fdi: sub al,al + sub al,[bx] ; complement of divisor exponent + cmp al,1 ; set carry if division by zero + push bx + jc fdi1 + call mdex ; read operand if not zero +fdi1: pop bx + jc fdi2 + jz fdi3 + call divx ; fixed division + jnc fdi2 + jmp fpack + +fdi2: jmp ovf ; overflow or division by zero +fdi3: jmp zro ; underflow or zero + +; convert signed integer AL to float + +flta: mov ch,al + sub cl,cl + sub dx,dx + mov al,8 + ignore2 + +; convert 32 bit signed integer to float +; entry - cx:dx (int) + +flt: mov al,32 ; scaling factor + xor al,80h ; apply exponent bias + mov bx,offset acce + mov [bx],al + mov byte ptr [bx+1],80h ; assume positive + or ch,ch + jns flt2 + call fcpl ; negate +flt2: jmp npack + +; fix convert float in acc to 32 bit signed integer +; exit - cx:dx (int) cy=overflow + +fix: mov dl,32 ; scaling + or al,al + jz fix2 ; zero + xchg dl,al + add al,80h-1 ; add bias-1 + sub al,dl ; shift count -1 + jc fix1 ; accum too large + cmp al,31 ; compare to large shift + jnc fix2 ; accum too small + inc al ; shift count + or ch,80h ; unpack msb + call shrr ; position the fraction + test byte ptr accs,80h + js fix1 + call fcpl +fix1: clc + ret + +fix2: sub cx,cx ; zero + sub dx,dx + ret + +; Round/floor/trunc accum to integer +; entry - al cx:dh +; exit - al cx:dh dl=signed integer + +flr: mov bl,1 ; mode +flr1: or al,al + jz flr6 ; zero + mov dl,dh + mov ah,80h+24 + cmp al,ah + jnc flr5 ; no fraction + mov acce,ah + mov bh,ch ; save sign + xor bh,bl ; adjust for mode + or ch,80h ; unpack msb + test bl,1 + jz flr2 + or bh,bh + jns flr2 + sub dh,1 ; dec cx:dh + sbb cx,0 +flr2: neg al + add al,ah + call shrr + test bl,1 + jz flr3 + or bh,bh + jns flr3 + add dh,1 ; inc cx:dh + adc cx,0 +flr3: or bl,bl + jnz flr4 + add dl,dl ; round + adc dh,0 + adc cx,0 +flr4: push dx + sub dl,dl + call npack ; normalize and pack + pop bx + mov dl,bh +flr5: or ch,ch + jns flr6 + neg dl +flr6: ret + +; FABS (F: r1 -- r2 ) or ( r1 -- r2 ) + + hdr 1,'FABS' +fabss: + if fstack + mov bx,fspp + else + mov bx,sp + endif + and byte ptr [bx+1],7fh + nextt + +; FNEGATE ( r1 -- r2 ) + + hdr 1,'FNEGATE' +fneg: + if fstack + mov bx,fspp + else + mov bx,sp + endif + xor byte ptr [bx+1],80h + nextt + +; D>F ( d -- r ) + + hdr 1,'D>F' +dtof: pop cx + pop dx + call flt + jmp svop + +; F>D ( r -- d ) + + hdr 1,'F>D' +ftod: call ldop + call fix + jnc ftod1 + jmp cverr ; overflow + +ftod1: push dx + push cx + nextt + +; S>F ( n -- r ) s>d d>f + + hdr 1,'S>F' +stof: call docol + dw stod,dtof + dw exit + +; F>S ( r -- n ) f>d d>s + + hdr 1,'F>S' +ftos: call docol + dw ftod,dtos + dw exit + +; F0= ( r -- flag ) + + hdr 1,'F0=' +fze: call ldop +fze1: jnz ffl + jmp true +ffl: jmp false + + if fpx + +; F= ( r1 r2 -- flag ) + + hdr 1,'F=' +feq: call ld2op + call fcmp + jmp fze1 + + endif + +; F0< ( r -- flag ) + + hdr 1,'F0<' +fzl: call ldop +fzl1: jns ffl + jmp true + +; F< ( r1 r2 -- flag ) + + hdr 1,'F<' +fles: call ld2op + call fcmp + jmp fzl1 + +; F0> ( r -- flag ) + + hdr 1,'F0>' +fzg: call ldop +fzg1: jz ffl + js ffl + jmp true + +; F> ( r1 r2 -- flag ) + + hdr 1,'F>' +fgre: call ld2op + call fcmp + jmp fzg1 + +; FMIN ( r1 r2 -- r3 ) + + hdr 1,'FMIN' +fmin: call ld2op + call fcmp + js fmin1 + call lod ; r1 >= r2 +fmin1: jmp svop + +; FMAX ( r1 r2 -- r3 ) + + hdr 1,'FMAX' +fmax: call ld2op + call fcmp + jns fmax1 + call lod ; r1 < r2 +fmax1: jmp svop + +; FLOOR ( r1 -- r2 ) + + hdr 1,'FLOOR' +floor: call ldop + call flr + jmp svop + +; FROUND ( r1 -- r2 ) + + hdr 1,'FROUND' +frnd: call ldop + mov bl,0 +frnd1: call flr1 + jmp svop + + if fpx + +; FTRUNC ( r1 -- r2 ) + + hdr 1,'FTRUNC' +ftrunc: call ldop + mov bl,2 + jmp frnd1 + +; FCEIL ( r1 -- r2 ) + + hdr 1,'FCEIL' +fceil: call ldop + mov bl,-1 + jmp frnd1 + + endif + +; F+ ( r1 r2 -- r3 ) + + hdr 1,'F+' +faddd: call ld2op + call fad + jmp svop + +; F- ( r1 r2 -- r3 ) + + hdr 1,'F-' +fsubb: call ld2op + call fsu + jmp svop + +; F* ( r1 r2 -- r3 ) + + hdr 1,'F*' +fstar: call ld2op + call fmu + jmp svop + +; F/ ( r1 r2 -- r3 ) + + hdr 1,'F/' +fslas: call ld2op + call fdi + jmp svop + +; FRANDOM ( r1 -- r2 ) + + hdr 1,'FRANDOM' +rand: call ldop + js rand1 ; neg = seed generator + pushf + mov bx,offset rand5 + call lod + popf + jz rand2 ; zero = return last value + mov bx,offset rand3 ; pos = get next value + call fmu + mov bx,offset rand4 + call fad +rand1: mov bx,offset acc3 + mov ch,[bx] ; swap msb lsb + mov cl,[bx-1] + mov dh,[bx-2] + mov byte ptr [bx-3],80h ; make positive + mov dl,[bx-4] + mov byte ptr [bx-4],80h ; fix exponent + call npack ; normalize + mov bx,offset rand5 + call stom +rand2: jmp svop + +rand3 db 98h,35h,44h,7Ah +rand4 db 68h,28h,0B1h,46h +rand5 db 80h,31h,41h,59h ; seed + + cseg + +finstr dw ?,? ; string addr, count +finsgn db ? ; sign +finpt db ? ; decimal point flag +finexp db ? ; decimal exponent +fincvt db ? ; converted digits + +; fin convert character string to float +; entry - bx=adr, ax=len +; exit - result in accum, cy=error + +fin: dec bx ; init string adr, count + inc ax + mov finstr,bx + mov finstr+2,ax + + mov finsgn,80h ; set sign positive + xor al,al + mov finpt,al ; clear decimal point flag + mov finexp,al ; set decimal exponent = 0 + mov fincvt,al ; zero converted digits + mov acce,al ; zero accum + + call fin21 ; get 1st char + jz fin7 ; treat zero length as blanks + + cmp al,' ' + jnz fin2 +fin1: call fin21 ; treat all blanks as zero + jz fin7 + cmp al,' ' + jz fin1 + stc + ret + +fin2: cmp al,'+' ; check for sign + jz fin3 + cmp al,'-' + jnz fin4 + mov finsgn,0 ; set negative flag +fin3: call fin21 ; get char after sign + jz fin5 ; none + +fin4: cmp al,'.' ; check for decimal point + jnz fin8 + xor finpt,-1 ; 2nd decimal point? + jnz fin9 +fin5: stc ; error + ret + +fin6: cmp fincvt,0 + jz fin5 +fin7: jmp short fin16 + +; process char + +fin8: call fin22 ; convert char to digit + jc fin5 ; bad + + inc fincvt + push ax + mov bx,offset fp10 ; mult old value by 10 + call fmu + call savf1 + pop ax + call flta ; convert digit to floating point + mov bx,offset f1 ; add to old value + call fad + + mov al,finpt ; if decimal point + add finexp,al ; decrement exponent + +; get next char + +fin9: mov ch,0 ; zero exponent + call fin21 + jz fin6 ; done + +; check for exponent + + cmp al,'+' + jz fin11 + cmp al,'-' + jz fin11 + call upc + cmp al,'E' + jz fin10 + cmp al,'D' + jnz fin4 + +; process exponent + +fin10: call fin21 ; next char + jz fin6 ; done + +fin11: mov dl,al + sub dl,'-' ; test minus sign + jz fin12 + cmp dl,'+'-'-' ; test plus sign + jnz fin13 + +fin12: call fin21 ; got sign, get 1st digit + +fin13: mov ch,0 ; possible decimal exponent +; jnz fin14 +; jmp fin5 ; none - error + jz fin6 ; none - assume zero exponent + +fin14: call fin22 + jnc fin15 + ret ; not digit + +fin15: mov cl,10 ; accumulate exponent + xchg cl,al + mul ch + add al,cl + mov ch,al + + call fin21 ; get next + jnz fin14 + and dl,dl ; test exponent sign + jnz fin16 + neg ch ; complement if neg + +fin16: mov al,finsgn ; store accum sign + mov accs,al + +; adjust exponent + +fin17: mov bx,offset finexp + add ch,[bx] + jnz fin18 + jmp lodr ; done + +fin18: mov [bx],ch + mov bx,offset fp10 + jns fin19 + call fdi ; div by 10 + mov ch,1 + jmp fin17 + +fin19: call fmu ; mul by 10 + jnc fin20 + ret ; overflow + +fin20: mov ch,-1 + jmp fin17 + +; get next char al return z if end + +fin21: mov bx,offset finstr + inc word ptr [bx] + dec word ptr [bx+2] + mov bx,[bx] + mov al,[bx] + ret + +; convert ascii char (a) to digit, return cy if not in range 0-9 + +fin22: sub al,'0' + jc fin23 + cmp al,10 + cmc +fin23: ret + +; >FLOAT ( c-addr u -- r true | false ) + + hdr 1,'>FLOAT' +tflt: pop ax + pop bx + call fin + jc tflt1 + mov dl,cl + mov cl,al + if fstack + call fpush + else + push dx + push cx + endif + jmp true + +tflt1: jmp false + + hdr 1,'MAX-PRECISION' +mprec: call docco ; max precision + db maxsig + + hdr x,'EXSN' +exsn: call docre ; exponent, sign + dw 2 dup (?) + +; REPRESENT ( r c-addr n -- exp sign flag ) +; 2dup max-precision max [char] 0 fill +; max-precision min 2>r fdup f0< 0 exsn 2! +; fabs fdup f0= 0= if begin fdup 1.0e f< +; 0= while 10.0e f/ 1 exsn +! repeat begin +; fdup 0.1e f< while 10.0e f* -1 exsn +! +; repeat then r@ 0 max 0 ?do 10.0e f* loop +; fround f>d 2dup <# #s #> dup r@ - exsn +! +; 2r> rot min 1 max cmove d0= if 1 0 else +; exsn 2@ swap then true + + hdr 1,'REPRESENT' +repr: call docol + dw tdup + dw mprec,max + dw clit + db '0' + dw fill + dw mprec,min + dw ttor + dw fdup,fzl + dw zero,exsn,tstor + dw fabss + dw fdup,fze + dw zequ + dw zbran,repr3 +repr1 dw fdup ; begin + dw flit + db 81h,0,0,0 + dw fles,zequ + dw zbran,repr2 ; while + dw ften,fslas + dw one,exsn,pstor + dw bran,repr1 ; repeat +repr2 dw fdup ; begin + dw flit + db 7dh,4ch,0cch,0cdh + dw fles + dw zbran,repr3 ; while + dw ften,fstar + dw true,exsn,pstor + dw bran,repr2 ; repeat +repr3 dw rat + dw zero,max,zero + dw xqdo,repr5 +repr4 dw ften,fstar + dw xloop,repr4 +repr5 dw frnd,ftod + dw tdup + dw bdigs,digs,edigs + dw dupp + dw rat,subb ; handle overflow + dw exsn,pstor + dw tfrom + dw rot,min + dw one,max + dw cmove + dw dzequ + dw zbran,repr6 + dw one,zero ; 0.0E fixup + dw bran,repr7 +repr6 dw exsn,tat + dw swap +repr7 dw true + dw exit + +; PRECISION ( -- u ) + + hdr 1,'PRECISION' +prec: call doval + dw ? ; set by FPINIT + +; SET-PRECISION ( u -- ) 1 max max-precision min to precision + + hdr 1,'SET-PRECISION' +setpr: call docol + dw one,max + dw mprec,min + dw pto,prec + dw exit + + hdr 1,'FDP' +fdp: call docre ; decimal point display + dw ?,? ; set by FPINIT + + hdr x,'FBUF' +fbuf: call docre ; fp string buffer + db maxsig dup (?) + + hdr x,'EX#' +exn: call doval ; exponent + dw ? + + hdr x,'SN#' +snn: call doval ; sign + dw ? + + hdr x,'EF#' +efn: call doval ; exponent factor + dw ? + + hdr x,'PL#' +pln: call doval ; places after decimal point + dw ? + +; (f1) ( r -- r exp ) +; fdup fbuf max-precision represent 2drop + + hdr x,'(F1)' ; get exponent +pf1: call docol + dw fdup + dw fbuf,mprec + dw repr,tdrop ; never error + dw exit + +; (f2) ( exp -- offset exp' ) s>d ef# fm/mod ef# * + + hdr x,'(F2)' ; apply exponent factor +pf2: call docol + dw stod + dw efn,fmmod + dw efn,star + dw exit + +; (f3) ( r places -- c-addr u ) +; dup to pl# 0< if precision else (f1) ef# 0> +; if 1- (f2) drop 1+ then pl# + max-precision +; min then fbuf swap represent drop to sn# to +; ex# fbuf max-precision -trailing <# ; + + hdr x,'(F3)' ; float to ascii +pf3: call docol + dw dupp + dw pto,pln + dw zless + dw zbran,pf31 + dw prec + dw bran,pf33 +pf31 dw pf1 + dw efn,zgrea + dw zbran,pf32 + dw onem + dw pf2,drop + dw onep +pf32 dw pln,plus + dw mprec,min +pf33 dw fbuf,swap + dw repr + dw drop ; never error + dw pto,snn + dw pto,exn + dw fbuf + dw mprec + dw dtrai + dw bdigs + dw exit + +; (f4) ( exp -- ) pl# 0< >r dup abs s>d r@ 0= if # then #s +; 2drop dup sign 0< r> d0= if [char] + hold +; then [char] E hold + + hdr x,'(F4)' ; insert exponent +pf4: call docol + dw pln,zless + dw tor + dw dupp + dw abss,stod + dw rat,zequ + dw zbran,pf41 + dw dig +pf41 dw digs + dw tdrop + dw dupp,sign + dw zless + dw fromr + dw dzequ + dw zbran,pf42 + dw clit + db '+' + dw hold +pf42 dw clit + db 'E' + dw hold + dw exit + +; (f5) ( n -- +n|0 ) 0max dup fdp 2+ +! + + hdr x,'(F5)' ; conditionally set flag +pf5: call docol + dw zmax + dw dupp + dw fdp,twop + dw pstor + dw exit + +; (f6) ( c-addr u -- ) (f5) shold + + hdr x,'(F6)' ; insert string +pf6: call docol + dw pf5,shold + dw exit + +; (f7) ( n -- ) (f5) [char] 0 nhold + + hdr x,'(F7)' ; insert '0's +pf7: call docol + dw pf5 + dw clit + db '0' + dw nhold + dw exit + +; (f8) ( -- ) sn# sign 0 0 #> + + hdr x,'(F8)' ; insert sign +pf8: call docol + dw snn,sign + dw zero,zero + dw edigs + dw exit + +; (f9) ( c-addr u1 -- c-addr u2 ) pl# 0< if [char] 0 trim then + + hdr x,'(F9)' ; trim trailing '0's +pf9: call docol + dw pln,zless + dw zbran,pf91 + dw clit + db '0' + dw trim +pf91 dw exit + +; (fa) ( u1 -- u1 u2 ) pl# 0< if dup else pl# then + + hdr x,'(FA)' +pfaa: call docol + dw pln,zless + dw zbran,pfaa1 + dw dupp + dw bran,pfaa2 +pfaa1 dw pln +pfaa2 dw exit + +; (fb) ( c-addr u n -- ) fdp cell+ off >r (f9) r@ + (fa) over - +; (f7) (fa) min r@ - (f6) r> (fa) min (f7) +; fdp 2@ or if [char] . hold then + + hdr x,'(FB)' ; insert fraction n places right of dec. pt +pfbb: call docol + dw fdp,twop + dw off + dw tor + dw pf9 + dw rat,plus + dw pfaa + dw over,subb + dw pf7 + dw pfaa,min + dw rat,subb + dw pf6 + dw fromr + dw pfaa,min + dw pf7 + dw fdp,tat,orr + dw zbran,pfbb1 + dw clit + db '.' + dw hold +pfbb1 dw exit + +; (fc) ( c-addr u n -- ) +; >r 2dup r@ min 2swap r> /string 0 (fb) (f6) + + hdr x,'(FC)' ; split into int/frac and insert +pfcc: call docol + dw tor + dw tdup + dw rat,min + dw tswap + dw fromr,sstr + dw zero,pfbb + dw pf6 + dw exit + +; (fd) ( r n factor -- c-addr u ) +; to ef# (f3) ex# 1- (f2) (f4) 1+ (fc) (f8) + + hdr x,'(FD)' ; exponent form +pfdd: call docol + dw pto,efn + dw pf3 + dw exn,onem + dw pf2 + dw pf4 + dw onep,pfcc + dw pf8 + dw exit + +; (FS.) ( r n -- c-addr u ) 1 (fd) + + hdr 1,'(FS.)' +pfsd: mov ax,1 + push ax + jmp pfdd + +; FS.R ( r n1 n2 -- ) >r (fs.) r> s.r + + hdr 1,'FS.R' +fsdr: call docol + dw tor + dw pfsd + dw bran,ddotr1 + +; FS. ( r -- ) -1 0 fs.r space + + hdr 1,'FS.' +fsdot: call docol + dw true + dw zero,fsdr + dw space + dw exit + + if fpeng + +; (FE.) ( r -- c-addr u ) 3 (fd) + + hdr 1,'(FE.)' +pfse: mov ax,3 + push ax + jmp pfdd + +; FE.R ( r n1 n2 -- ) >r (fe.) r> s.r + + hdr 1,'FE.R' +fedr: call docol + dw tor + dw pfse + dw bran,ddotr1 + +; FE. ( r -- ) -1 0 fe.r space + + hdr 1,'FE.' +fedot: call docol + dw true + dw zero,fedr + dw space + dw exit + + endif + +; (F.) ( r n -- c-addr u ) +; 0 to ef# (f3) ex# dup max-precision > if +; fbuf 0 0 (fb) max-precision - (f7) (f6) +; else dup 0> if (fc) else abs (fb) 1 (f7) +; then then (f8) + + hdr 1,'(F.)' +pfd: call docol + dw zero + dw pto,efn + dw pf3 + dw exn,dupp + dw mprec,great + dw zbran,pfd1 ; if + dw fbuf,zero + dw zero,pfbb + dw mprec,subb + dw pf7 + dw pf6 + dw bran,pfd3 ; else +pfd1 dw dupp,zgrea + dw zbran,pfd2 + dw pfcc + dw bran,pfd3 ; else +pfd2 dw abss + dw pfbb + dw one,pf7 +pfd3 dw pf8 ; then then + dw exit + +; F.R ( r n1 n2 -- ) >r (f.) r> s.r + + hdr 1,'F.R' +fdotr: call docol + dw tor + dw pfd + dw bran,ddotr1 + +; F. ( r -- ) -1 0 f.r space + + hdr 1,'F.' +fdot: call docol + dw true + dw zero,fdotr + dw space + dw exit + +; (G.) ( r n -- c-addr u ) +; >r (f1) -3 7 within r> swap if (f.) else +; (fs.) then + + hdr 1,'(G.)' +pgd: call docol + dw tor + dw pf1 + dw lit,-3 + dw clit + db 7 + dw within + dw fromr,swap + dw zbran,pgd1 ; if + dw pfd + dw bran,pgd2 ; else +pgd1 dw pfsd +pgd2 dw exit ; then + +; G.R ( r n1 n2 -- ) >r (g.) r> s.r + + hdr 1,'G.R' +gdotr: call docol + dw tor + dw pgd + dw bran,ddotr1 + +; G. ( r -- ) -1 0 g.r space + + hdr 1,'G.' +gdot: call docol + dw true + dw zero,gdotr + dw space + dw exit + + cseg + +; sqr + +sqr: call tstr + jnz sqr1 + ret ; zero + +sqr1: jns sqr2 + jmp ovf ; neg + +sqr2: call savf1 + and al,al + rcr al,1 + add al,40h + call savf2 + mov dh,5 +sqr3: push dx + call lodf1 + mov bx,offset f2 + call fdi + mov bx,offset f2 + call fad + sub al,1 + call savf2 + pop dx + dec dh + jnz sqr3 + mov bx,offset f2 + jmp lod + +; poly + +poly: push bx + call savf1 + pop bx + mov al,[bx] + mov poly3,al + inc bx + push bx + call lod + jmp short poly2 + +poly1: push bx + mov bx,offset f1 + call fmu + pop bx + push bx + call fad +poly2: pop bx + add bx,fw + dec byte ptr poly3 + jnz poly1 + ret + +poly3 db ? + +; polx + +polx: push bx + call savf2 + mov bx,offset f2 + call fmu + pop bx + call poly + mov bx,offset f2 + jmp fmu + +; exp + +exp: mov bx,offset ln2 + call fdi + cmp al,88h + jnc exp3 + + cmp al,68h + jnc exp1 + mov bx,offset fp1 + jmp lod + +exp1: call savf2 + call flr + call savf1 + mov al,dl + add al,81h + jz exp2 + + push ax + call lodf2 + mov bx,offset f1 + call fsu + mov bx,offset exp4 + call poly + pop ax + mov cx,0 + mov dh,ch + call savf1 + mov bx,offset f1 + jmp fmu + +exp2: call lodr + jns exp3 + jmp zro + +exp3: jmp ovf + +exp4 db 7 + db 74h,59h,88h,7ch + db 77h,26h,97h,0e0h + db 7ah,1eh,1dh,0c4h + db 7ch,63h,50h,5eh + db 7eh,75h,0feh,1ah +ln2 db 80h,31h,72h,18h ; ln2 +fp1 db 81h,0,0,0 ; 1.0 + +; log + +log: call tstr + jng log1 ; neg or zero + xor al,80h + push ax + mov al,80h + mov bx,offset log2 + call poly + call savf1 + pop ax + call flta + mov bx,offset f1 + call fad + mov bx,offset ln2 + jmp fmu + +log1: jmp zro + +log2 db 9 + db 82h,94h,0eeh,0d8h + db 84h,7dh,0aah,0a9h + db 86h,0bfh,99h,7dh + db 87h,28h,0e5h,7bh + db 87h,0c0h,71h,8ah + db 87h,14h,95h,6eh + db 86h,0a0h,1eh,0b2h + db 85h,02h,7ah,0adh + db 83h,8dh,9dh,09h + +; sin / cos + +cos: mov bx,offset fpi2 + call fad +sin: or al,al + jnz sin1 + ret + +sin1: cmp al,80h+25 + jc sin2 + jmp ovf + +sin2: mov bx,offset f2pi + call fdi + call savf1 + call flr + or al,al + pushf + jz sin3 + call savf2 +sin3: call lodf1 + popf + jz sin4 + mov bx,offset f2 + call fsu +sin4: mov bx,offset fp25 ; 0.25 + call fsu + pushf + js sin5 + mov bx,offset fp50 ; 0.5 + call fsu + js sin5 + call chs +sin5: mov bx,offset fp25 ; 0.25 + call fad + popf + js sin6 + call chs +sin6: mov bx,offset sin7 + jmp polx + +sin7 db 5 + db 86h,1eh,0d7h,0fbh + db 87h,99h,26h,64h + db 87h,23h,34h,58h + db 86h,0a5h,5dh,0e1h +f2pi db 83h,49h,0fh,0dbh ; 2pi + +fpi2 db 81h,49h,0fh,0dbh ; pi/2 +fp50 db 80h,0,0,0 ; 0.5 +fp25 db 7fh,0,0,0 ; 0.25 + +; atan + +atan: call tstr + jns atan1 + call chss ; make positive +atan1: cmp al,81h + jc atan2 ; < 1 + + mov bx,offset atan4 + push bx + call savf1 + mov bx,offset fp1 + call lod + mov bx,offset f1 + call fdi +atan2: mov bx,offset atan9 + call fcmp + js atan3 + + mov bx,offset atan5 + push bx + call savf1 + mov bx,offset atan7 + call fad + mov bx,offset f3 + call stom + call lodf1 + mov bx,offset atan6 + call poly + mov bx,offset f3 + call fdi +atan3: mov bx,offset atan8 + jmp polx + +atan4: mov bx,offset fpi2 + call fsu + jmp chs + +atan5: mov bx,offset atan10 + jmp fad + +atan6 db 2 +atan7 db 81h,5dh,0b3h,0d7h + db 81h,80h,0,0 ; -1.0 + +atan8 db 4 + db 7eh,83h,35h,62h + db 7eh,4ch,24h,50h + db 7fh,0aah,0a9h,79h + db 81h,0,0,0 + +atan9 db 7fh,09h,38h,0a3h +atan10 db 80h,06h,0ah,92h + +; FSQRT ( r1 -- r2 ) + + hdr 1,'FSQRT' +fsqr: call ldop + call sqr + jmp svop + +; FEXP ( r1 -- r2 ) + + hdr 1,'FEXP' +fexp: call ldop + call exp + jmp svop + +; FLN ( r1 -- r2 ) + + hdr 1,'FLN' +ffln: call ldop + call log + jmp svop + +; F** ( r1 -- r2 ) fswap fln f* fexp + + hdr 1,'F**' +fsq: call docol + dw fswap,ffln + dw fstar,fexp + dw exit + +; FSIN ( r1 -- r2 ) + + hdr 1,'FSIN' +fsinn: call ldop + call sin + jmp svop + +; FCOS r1 -- r2 ) + + hdr 1,'FCOS' +fcoss: call ldop + call cos + jmp svop + +; FATAN ( r1 -- r2 ) + + hdr 1,'FATAN' +fatan: call ldop + call atan + jmp svop + +; PI ( -- r ) + + hdr 1,'PI' +fpi: call dofcon + db 82h,49h,0fh,0dbh ; pi + +; fpinit ( -- ) max-precision set-precision fdp on + + hdr x,'FPINIT' +fpini: call docol + dw mprec,setpr + dw fdp,on + dw exit + +; fident ( -- ) + + hdr x,'FIDENT',,1 +fiden: call docol + dw crr + dw pdotq + db fiden1-$-1 + db 'Software floating-point (' + if fstack + db 'separate' + else + db 'common' + endif + db ' stack)' +fiden1 dw exit + + if not ldp ; F94 requires digit before decimal-point + +; fnumber ( c-addr u -- [r] flag ) +; dup 1 > if over dup c@ [char] . < - c@ +; [char] . > >r 2dup s" E" caps search -rot +; 2drop r> and decimal? and 0= while then +; 2drop 0 else >float then dup >r state? +; and if postpone fliteral then r> + + hdr x,'FNUMBER',,1 +fnumb: call docol + dw dupp,one,great + dw zbran,fnumb1 + dw over + dw dupp,cat + dw clit + db '.' + dw less,subb ; skip sign + dw cat + dw clit + db '.' + dw great ; digit? + dw tor + dw tdup ; scan 'E' + dw psqot + dcs 'E' + if ucase + dw caps + endif + dw sear + dw drot,tdrop + dw fromr,andd + dw dcmq ; decimal base? + dw andd,zequ + dw zbran,fnumb2 +fnumb1 dw tdrop,zero + dw bran,fnumb3 +fnumb2 dw tflt +fnumb3 dw dupp,tor + dw stateq + dw andd + dw zbran,fnumb4 + dw flite +fnumb4 dw fromr + dw exit + + else ; allow leading decimal-point + +; fnumber ( c-addr u -- [r] flag ) +; 2dup s" E" caps search -rot 2drop decimal? +; and if >float else 2drop 0 then dup >r +; state? and if postpone fliteral then r> + + hdr x,'FNUMBER',,1 +fnumb: call docol + dw tdup ; scan 'E' + dw psqot + dcs 'E' + if ucase + dw caps + endif + dw sear + dw drot,tdrop + dw dcmq ; decimal base? + dw andd + dw zbran,fnumb2 +fnumb1 dw tflt + dw bran,fnumb3 +fnumb2 dw tdrop,zero +fnumb3 dw dupp,tor + dw stateq + dw andd + dw zbran,fnumb4 + dw flite +fnumb4 dw fromr + dw exit + + endif + + aseg + +; ( -- ) :noname ['] noop dup (pinit) ! (piden) ! +; ['] false (pfnum) ! (nfps) off (nfpm) off +; ; remember + + hdr x,'(-FP)',,1 +fprun: mov ax,offset noop + mov word ptr pinit,ax ; INIT + mov word ptr piden,ax ; INDENTIFY + mov ax,offset false + mov word ptr pfnum,ax ; FNUMBER + sub ax,ax + mov nfps,ax + mov nfpm,ax + nextt + +fprun1 dw 0 ; link + dw fprun ; xt + + endif ; float + +topnfa equ lnk-horig ; nfa of top word in forth vocab +topxt equ cfadr ; xt of top word in forth vocab + + cseg +initdp equ $ + + aseg +initdps equ $ + +heads segment public +initdph equ $-horig +heads ends + + cseg + +; Move heads into place for .COM executable only. +; Assumes heads located entirely in DS segment. +; Code is run once then disabled. + +; MOVE-PATCH ( -- ) + +movpat: mov es,hseg1 ; ES = headers segment + mov cx,idph ; move heads + mov di,cx + dec di + mov si,di + add si,idps + std + rep movsb + cld + mov word ptr cldd6,0CF8Bh ; change 'MOV CX,DI' + mov word ptr cldd7,0F929h ; change 'SUB CX,DI' + mov word ptr cldd9,cold-cldd9-2 ; patch myself out + jmp cold + +main ends + + end start ; start address + +; End + diff --git a/DX-FORTH v430/LFN.SCR b/DX-FORTH v430/LFN.SCR new file mode 100644 index 0000000..8295d59 --- /dev/null +++ b/DX-FORTH v430/LFN.SCR @@ -0,0 +1 @@ +\ Long filename support Long filename support for Windows95+ \ Long filename support forth definitions decimal application blk @ 1+ #screens 1- thru \ Long filename support \ Return true if DOS version 7 or greater : dos7 ( -- flag ) dosver nip 6 > ; \ Return error code : lfnerr ( -- ior ) 'AX @ $7100 - if doserr? else $FEFF then ; \ buffer for asciiz strings create zbuf 260 2 + allot \ CREATE-FILE OPEN-FILE \ open/create long filename : lopen ( c-addr u fam mode -- fid ior ) 'DX ! 'BX ! zbuf zplace zbuf 'SI ! 0 'CX ! 0 'DI ! $6C 'AX c! $71 doscall 'AX @ lfnerr ; -? : CREATE-FILE ( c-addr u fam -- fid ior ) dos7 if $12 lopen else create-file then ; -? : OPEN-FILE ( c-addr u fam -- fid ior ) dos7 if $01 lopen else open-file then ; \ DELETE-FILE \ delete long filename -? : DELETE-FILE ( c-addr u -- ior ) dos7 if zbuf zplace zbuf 'DX ! 0 'CX ! 0 'SI ! $41 'AX c! $71 doscall lfnerr else delete-file then ; behead dos7 lopen \ No newline at end of file diff --git a/DX-FORTH v430/LISTING.BAT b/DX-FORTH v430/LISTING.BAT new file mode 100644 index 0000000..0897a15 --- /dev/null +++ b/DX-FORTH v430/LISTING.BAT @@ -0,0 +1,7 @@ +echo off +echo Usage: LISTING screenfile output +if "%1"=="" goto end +if "%2"=="" goto end +forth %1 :noname 'DX c! 2 doscall ; sys-vec 8 + ! listing bye >%2 +echo done! +:end diff --git a/DX-FORTH v430/LOCALS.SCR b/DX-FORTH v430/LOCALS.SCR new file mode 100644 index 0000000..1859881 --- /dev/null +++ b/DX-FORTH v430/LOCALS.SCR @@ -0,0 +1 @@ +\ locals based on locals code by B. Muench ( ANS ) (LOCAL) LOCALS| TO ( optional ) ADDR \ locals forth definitions decimal application 2 #screens 1- thru \ locals #20 user LP \ locals pointer (don't change) \ add locals to CATCH -? : CATCH ( xt -- except# | 0 ) lp @ >r catch r> over if lp ! else drop then ; \ locals label ladr \ BX <- address of local LP [up] bx mov byte lods ah ah sub ax bx sub ret end-code code L@ ( -- x ) \ fetch local ladr ) call 0 [bx] push next end-code code L! ( x -- ) \ store local ladr ) call 0 [bx] pop next end-code code L& ( -- addr ) \ address of local ladr ) call bx push next end-code \ locals \ build locals frame, init locals, push locals exit code L{ bp sp xchg LP [up] push sp 0 [di] mov byte lods ah ah sub ax cx mov 1 $: 0 [bp] push 2 # bp add 1 $ loop 2 $ # ax mov ax push bp sp xchg next 2 $: here cell+ , \ locals exit \ remove locals frame LP [up] bp mov bp sp xchg 0 [di] pop bp sp xchg ' exit ) jmp end-code \ locals system : ERR? ( x -- ) abort" locals error" ; : LGET ( "name" -- c-addr u ) token dup 0= err? ; #128 constant #NB \ name buffer size create NB #nb allot \ name buffer variable LC \ locals count variable NP \ name pointer : L[ ( -- ) lc off nb #nb erase nb np ! ; l[ \ local offset : LOS ( ? index -- u ) nip cells ; \ locals \ search local names : L= ( c-addr -- index | 0 ) 0 state @ if \ compiling only nb >r begin 1+ r@ c@ 0<> and dup while over count r> count 2dup + >r caps compare 0= until then r> drop then nip ; \ new FIND : LFIND ( c-addr -- c-addr 0 | xt flag ) dup l= ?dup if postpone l@ los c, ['] noop 1 end [ addr find @ compile, ] ; \ (LOCAL) LOCALS| : (LOCAL) ( c-addr u | 0 0 -- ) \ ANS dup if np @ 2dup + nb #nb 2- + u> err? over 1+ np +! place 1 lc +! else 2drop lc @ ?dup if postpone l{ c, then then ; \ assign locals : LOCALS| ( "name1...namen |" ) \ ANS begin lget 2dup s" |" compare while (local) repeat 2drop 0 0 (local) ; immediate \ TO ADDR -? : TO ( x "name" -- ) \ ANS >in @ bl word l= ?dup if postpone l! los c, end >in ! postpone to ; immediate \ Address of a local -? : ADDR ( "name" -- addr ) >in @ bl word l= ?dup if postpone l& los c, end >in ! postpone addr ; immediate \ locals -? : DOES> postpone does> l[ ; immediate -? : : : l[ ; -? : :NONAME :noname l[ ; \ add to remember chain :noname [ addr find @ ] literal is find ; remember ' lfind is find application \ locals behead ladr lfind \ No newline at end of file diff --git a/DX-FORTH v430/MAKEF.BAT b/DX-FORTH v430/MAKEF.BAT new file mode 100644 index 0000000..e82cc53 --- /dev/null +++ b/DX-FORTH v430/MAKEF.BAT @@ -0,0 +1,12 @@ +rem opts: NOFLOAT NOFSTACK FLOORED NOHIDE +rem opts: EMS= HMS= SMS= FILES= +tasmx /t /dnofstack /d%1 /d%2 /d%3 /d%4 /d%5 /d%6 kernel.asm +tlink /t kernel +kernel.com - 1 fload EXTEND save FORTH-C.EXE bye +tasmx /l /t /d%1 /d%2 /d%3 /d%4 /d%5 /d%6 kernel.asm +tlink /t kernel +kernel.com - 1 fload EXTEND save FORTH-F.EXE bye +forth-f - checking off forget -FP checking on 1 fload EXTEND save FORTH.EXE bye +forth-f - 1 fload SED aka sed EDIT save DX.EXE bye +del kernel.obj +del kernel.map diff --git a/DX-FORTH v430/MAKEF87.BAT b/DX-FORTH v430/MAKEF87.BAT new file mode 100644 index 0000000..f1af53c --- /dev/null +++ b/DX-FORTH v430/MAKEF87.BAT @@ -0,0 +1,5 @@ +forth F87D 1 load bye +forth F87DS 1 load bye +forth F87S 1 load bye +forth F87X 1 load bye +copy /y f87d.exe F87.EXE diff --git a/DX-FORTH v430/MISC.SCR b/DX-FORTH v430/MISC.SCR new file mode 100644 index 0000000..d7f68e8 --- /dev/null +++ b/DX-FORTH v430/MISC.SCR @@ -0,0 +1 @@ +\ Miscellaneous functions \ Common forth words : 0<= ( n -- flag ) 0> 0= ; : 0>= ( n -- flag ) 0< 0= ; : <= ( n1 n2 -- flag ) > 0= ; : >= ( n1 n2 -- flag ) < 0= ; : U<= ( u1 u2 -- flag ) u> 0= ; : U>= ( u1 u2 -- flag ) u< 0= ; \ Common forth words \ Duplicate a triple number : 3DUP ( x1 x2 x3 -- x1 x2 x3 x1 x2 x3 ) dup 2over rot ; \ Negate n1/d1 if n is negative (FIG: +- D+-) : ?NEGATE ( n1 n -- n2 ) 0< if negate then ; : ?DNEGATE ( d1 n -- d2 ) 0< if dnegate then ; \ UNDER UNDER+ \ : UNDER ( a b -- a a b ) over swap ; code UNDER ( a b -- a a b ) ax pop sp bx mov 0 [bx] dx mov 2push end-code \ : UNDER+ ( a b x -- a+x b ) rot + swap ; code UNDER+ ( a b x -- a+x b ) ax pop sp bx mov ax 2 [bx] add next end-code \ Number utilities \ Numeric string : (UD.) ( ud -- a u ) <# #s #> ; : UD. ( ud -- ) (ud.) type space ; : UD.R ( ud n -- ) >r (ud.) r> s.r ; \ Hex formatted : (DH.N) ( ud n -- ) base @ >r hex <# 0 do # loop #> r> base ! ; : (DH.) ( ud -- a u ) 4 cells (dh.n) ; : (H.) ( u -- a u ) 0 2 cells (dh.n) ; : (HW.) ( u -- a u ) 0 4 (dh.n) ; : (HB.) ( u -- a u ) 0 2 (dh.n) ; \ Hex dot-separated : (DH..) ( ud -- a u ) base @ >r hex <# 1 cells 0 do # # # # [char] . hold loop #> 1 /string r> base ! ; \ Number utilities \ Right-justified numeric string e.g. : (D.R) ( d n -- adr len ) >r (d.) r@ over - 0 max bl nhold #> r> min ; : (U.R) ( u n -- adr len ) 0 swap (d.r) ; \ OpenFirmware : PUSH-HEX ( -- ) base @ r> 2>r hex ; : PUSH-DECIMAL ( -- ) base @ r> 2>r decimal ; : POP-BASE ( -- ) 2r> >r base ! ; \ NUMBER? (old version) : NUMBER? ( c-addr u -- d true | 0 ) over c@ [char] - = >r 0. 2swap dup if r@ 1 and /string >number dpl on begin dup if over c@ bl <> and then dup while over c@ dup [char] : = swap [char] + [char] 0 within or 0= if r> drop 2drop 2drop 0 end 1 /string dpl off >number repeat then 2drop r> if dnegate then true ; \ Patch into forth interpreter \ ' NUMBER? SYS-VEC #18 + @ ! PROTECT \ U-NUMBER S-NUMBER \ convert numeric string to unsigned single integer : U-NUMBER ( adr len -- u -1 | 0 ) number? if 0= ?dup and end 0 ; \ convert numeric string to signed single integer : S-NUMBER ( adr len -- n -1 | 0 ) number? if over 0< xor 0= ?dup and end 0 ; \ Comma formatted numeric output \ Method from Greenarrays pF \ As for #S but places a comma after each 3 digits : ?# ( ud -- ud ) # 2dup d0= if unnest then ; : #,S ( ud -- 0. ) begin ?# ?# ?# [char] , hold again ; behead ?# ?# : (D,.) ( d -- a u ) tuck dabs <# #,s rot sign #> ; : D,. ( d -- ) (d,.) type space ; : D,.R ( d n -- ) >r (d,.) r> s.r ; : (UD,.) ( ud -- a u ) <# #,s #> ; : UD,. ( ud -- ) (ud,.) type space ; : UD,.R ( ud n -- ) >r (ud,.) r> s.r ; \ FOR NEXT \ Count is placed on return stack and decremented at NEXT, \ terminates when zero. sys @ application -? code nxt ( run-time for NEXT ) 0 [bp] dec 1 $ jz 0 [si] si mov next 1 $: 2 # bp add 2 # si add next end-code system : FOR ( u -- ) postpone >r postpone begin ; immediate : NEXT ( -- ) postpone nxt r hex number? r> base ! ; \ Display n backspace characters : BACKSPACES ( n -- ) 0 max 0 ?do 8 emit loop ; \ Exception tools \ THROW exception code n if flag is non-zero : ?THROW ( flag n -- ) swap 0<> and throw ; \ Perform CATCH intercepting exception code n only : ?CATCH ( xt n -- n ) >r catch dup r> <> over and throw ; \ Intercepting a range of exception codes \ ['] do-it CATCH case \ x1 of ... endof \ catch error x1 \ x2 of ... endof \ catch error x2 \ dup throw \ throw all others \ endcase \ DEFER tools sys @ system \ Add new behaviour to existing deferred word : +IS ( xt -- ) >r :noname r> compile, ' >body dup >r @ compile, postpone ; r> ! ; \ Compile current behaviour of a deferred word : DEFERS ( -- ) ' >body @ compile, ; immediate sys ! \ Stack tools \ A version of ?STACK for use within turnkey applications. \ Checks data, return and fp stacks for under/overflow. : ?STACK ( ? -- ? ) sp@ s0 @ 1+ pad within abort" stack?" rp@ r0 @ 1+ fs0 @ within abort" r-stack?" fsp @ fs0 @ dup 1+ swap [ sys-vec #20 + ] literal @ - within abort" f-stack?" ; \ Quad - DUM* \ Multiply doubles leaving quad. Unsigned. code DUM* ( ud1 ud2 -- uq ) di pop bx pop cx pop dx pop 2 # sp sub bp push si push dx si mov bx ax mov dx mul sp bp mov ax 4 [bp] mov dx si xchg di ax mov dx mul ax si add 0 # dx adc bx ax mov dx bx mov cx mul bp bp xor ax si add dx bx adc 0 # bp adc cx ax mov di mul bx ax add bp dx adc si bx mov si pop bp pop bx push ax push dx push next end-code \ Quad - DUM/MOD \ Divide quad by double. Unsigned. code DUM/MOD ( uq ud -- udrem udquot ) di pop es pop ax pop bx pop cx pop dx pop si push bp push es si mov #32 # bp mov 1 $: dx shl cx rcl bx rcl ax rcl 2 $ jnc si bx sub di ax sbb 3 $ ju 2 $: si bx sub di ax sbb 3 $ jnc si bx add di ax adc 1 # dx sub 0 # cx sbb 3 $: dx inc 4 $ jnz cx inc 4 $: bp dec 1 $ jnz bp pop si pop bx push ax push dx push cx push next end-code \ Double - D* DU/MOD \ Multiply doubles. Signed or unsigned code D* ( d|ud1 d|ud2 -- d|ud3 ) cx pop bx pop ax pop di pop bx mul cx ax xchg di mul ax cx add di ax xchg bx mul cx dx add ax push dx push next end-code \ Divide doubles. Unsigned. code DU/MOD ( ud1 ud2 -- udrem udquot ) di pop bx pop dx pop ax pop si push bp push bx si mov cx cx sub bx bx sub #33 # bp mov 1 $: bx rcl cx rcl si bx sub di cx sbb 2 $ jnc si bx add di cx adc 2 $: cmc ax rcl dx rcl bp dec 1 $ jnz bp pop si pop bx push cx push ax push dx push next end-code \ Double - D* DU/MOD high level \ Multiply doubles. Signed or unsigned. : D* ( d|ud1 d|ud2 -- d|ud3 ) >r swap >r 2dup um* rot r> * + rot r> * + ; \ Divide doubles. Unsigned. : DU/MOD ( ud1 ud2 -- udrem udquot ) 0. 2rot #32 0 do 2 pick over 2>r d2* 2swap d2* r> 0< 1 and m+ 2dup 7 pick 7 pick du< 0= r> 0< or if 5 pick 5 pick d- 2swap 1 m+ else 2swap then loop 2rot 2drop ; \ Double - FD/MOD SD/REM \ Divide doubles signed by unsigned. Floored. : FD/MOD ( d ud -- drem dquot ) 2dup 2>r 2swap dup >r dabs 2swap du/mod r> 0< if dnegate 2over or if 1. d- 2r@ 2rot d- 2swap then then 2r> 2drop ; \ Divide doubles. Signed. Symmetric. : SD/REM ( d1 d2 -- drem dquot ) 2 pick 2dup xor 2>r dabs 2swap dabs 2swap du/mod r> 0< if dnegate then r> 0< if 2swap dnegate 2swap then ; \ Double operations \ Memory : M+! ( n a -- ) dup >r 2@ rot m+ r> 2! ; : D+! ( d a -- ) dup >r 2@ d+ r> 2! ; \ Logical : DAND ( xd1 xd2 -- xd3 ) rot and >r and r> ; : DOR ( xd1 xd2 -- xd3 ) rot or >r or r> ; : DXOR ( xd1 xd2 -- xd3 ) rot xor >r xor r> ; : DINVERT ( xd1 -- xd2 ) invert swap invert swap ; \ Shift : DLSHIFT ( xd1 n -- xd2 ) 0 ?do d2* loop ; : DRSHIFT ( xd1 n -- xd2 ) 0 ?do d2/ $7FFF and loop ; \ Mixed - MU/MOD UT* UT/ UM*/ \ Divide double by single. Unsigned. : MU/MOD ( ud u -- urem udquot ) >r 0 r@ um/mod r> swap >r um/mod r> ; \ Multiply double by single leaving triple. Unsigned. : UT* ( ud u -- ut ) dup rot um* 2>r um* 0 2r> d+ ; \ Divide triple by single leaving double. Unsigned. : UT/ ( ut u -- ud ) dup >r um/mod swap rot 0 r@ um/mod swap rot r> um/mod nip 0 2swap swap d+ ; \ Unsigned M/* : UM*/ ( ud1 u1 u2 -- ud2 ) >r ut* r> ut/ ; \ Mixed - FDM/MOD \ Divide signed double by positive single. Floored. : FDM/MOD ( d +n -- drem dquot ) tuck >r s>d r> fm/mod >r swap um/mod 0 swap r> ; \ 16-bit fast integer square root \ Returns root and remainder, or 0 -1 if n is negative FD14/5 : SQRT ( +n -- root rem ) dup 0< if drop 0 -1 else 0 swap 16384 ( 2^14 ) begin >r dup 2 pick - r@ - dup 0< if drop swap 2/ else nip swap 2/ r@ + then swap r> 2/ 2/ dup 0= until drop then ; \ 32-bit fast integer square root \ Returns root and remainder, or 0 -1 if d is negative FD14/5 : DSQRT ( +d -- droot drem ) dup 0< if 2drop 0. -1. else 0. 2swap 1073741824. ( 2^30 ) begin 2>r 2dup 5 pick 5 pick d- 2r@ d- dup 0< if 2drop 2swap d2/ else 2nip 2swap d2/ 2r@ d+ then 2swap 2r> d2/ d2/ 2dup d0= until 2drop then ; \ 32-bit integer square root \ Returns root or -1 if d is negative M.Barr code DSQRT ( +d -- u ) cx pop bx pop 3 $ jcxz cx dx mov -1 # di mov 1 $: dx shl 2 $ jc dx shl 2 $ jc di shr 1 $ ju 2 $: cx dx mov bx ax mov di dx cmp 4 $ jnc di div di ax cmp 4 $ jnc ax di add di rcr 2 $ ju 3 $: bx dx mov $FF # di mov bx bx or 1 $ jnz bx di mov 4 $: di push next end-code \ 31-bit integer square root code DSQRT ( +d -- +n ) bx pop dx pop ax ax sub di di sub 16 # cx mov 1 $: dx shl bx rcl di rcl dx shl bx rcl di rcl ax shl ax shl ax inc ax di cmp 2 $ jc ax di sub ax inc 2 $: ax shr 1 $ loop ax push next end-code \ Simple random number generator \ LCS generator from 'Starting Forth' variable RND 1 rnd ! \ Get random number : RAND ( -- u ) rnd @ 31421 * 6727 + dup rnd ! ; \ Get random number between 0 and u-1 : RANDOM ( u -- 0..u-1 ) rand um* nip ; \ Minimum standard random number generator \ LCS generator using Turbo-C algorithm 2variable RND 1. rnd 2! \ : D* >r swap >r 2dup um* rot r> * + rot r> * + ; code D* cx pop bx pop ax pop di pop bx mul cx ax xchg di mul ax cx add di ax xchg bx mul cx dx add ax push dx push next end-code \ Get random number : RAND ( -- u ) rnd 2@ $015A4E35. d* 1. d+ tuck rnd 2! ; \ Get random number between 0 and u-1 : RANDOM ( u -- 0..u-1 ) rand um* nip ; \ CRC-16 \ x16+x15+x2+1 Initial CRC = 0 \ : CRC-16 ( crc byt -- crc' ) \ xor 8 0 do dup 1 and if u2/ $A001 xor else u2/ then loop ; code CRC-16 ( crc byt -- crc' ) dx pop ax pop dx ax xor 8 # cx mov 1 $: ax 1 shr 2 $ jnc $A001 # ax xor 2 $: 1 $ loop 1push end-code \ CRC-16 table-driven \ x16+x15+x2+1 Initial CRC = 0 -? create tb #256 2* allot -? : !tb #256 0 do i 8 0 do dup 1 and >r u2/ r> if $A001 xor then loop i 2* tb + ! loop ; !tb forget !tb \ : CRC-16 ( crc 8b -- crc' ) \ over xor $FF and 2* tb + @ swap 8 rshift xor ; code CRC-16 ( crc 8b -- crc' ) bx pop dx pop dl bl xor bx bx add tb # bx add 0 [bx] ax mov dl dh xchg dh dh sub dx ax xor 1push end-code behead tb tb \ CRC-CCITT \ x16+x12+x5+1 Initial CRC = $1D0F \ : CRC-CCITT ( crc byt -- crc' ) \ >< xor 8 0 do dup 0< if 2* $1021 xor else 2* then loop ; code CRC-CCITT ( crc byt -- crc' ) dx pop ax pop dl dh xchg dx ax xor 8 # cx mov 1 $: ax 1 shl 2 $ jnc $1021 # ax xor 2 $: 1 $ loop 1push end-code \ CRC-CCITT table-driven \ x16+x12+x5+1 Initial CRC = $1D0F -? create tb #256 2* allot -? : !tb #256 0 do 0 i >< xor 8 0 do dup 0< if 2* $1021 xor else 2* then loop i 2* tb + ! loop ; !tb forget !tb \ : CRC-CCITT ( crc 8b -- crc' ) \ over 8 rshift xor 2* tb + @ swap 8 lshift xor ; code CRC-CCITT ( crc 8b -- crc' ) bx pop dx pop dh bl xor bx bx add tb # bx add 0 [bx] ax mov dl ah xor 1push end-code behead tb tb \ CRC-X25 \ x16+x12+x5+1 Initial CRC = -1, INVERT final CRC \ : CRC-X25 ( crc byt -- crc' ) \ xor 8 0 do dup 1 and if u2/ $8408 xor else u2/ then loop ; code CRC-X25 ( crc byt -- crc' ) dx pop ax pop dx ax xor 8 # cx mov 1 $: ax 1 shr 2 $ jnc $8408 # ax xor 2 $: 1 $ loop 1push end-code \ CRC-X25 table-driven \ x16+x12+x5+1 Initial CRC = -1, INVERT final CRC -? create tb #256 2* allot -? : !tb #256 0 do i 8 0 do dup 1 and >r u2/ r> if $8408 xor then loop i 2* tb + ! loop ; !tb forget !tb \ : CRC-X25 ( crc 8b -- crc' ) \ over xor $FF and 2* tb + @ swap 8 rshift xor ; code CRC-X25 ( crc 8b -- crc' ) bx pop dx pop dl bl xor bx bx add tb # bx add 0 [bx] ax mov dl dh xchg dh dh sub dx ax xor 1push end-code behead tb tb \ CRC-XMODEM \ x16+x12+x5+1 Initial CRC = 0 \ : CRC-XMODEM ( crc byt -- crc' ) \ >< xor 8 0 do dup 0< if 2* $1021 xor else 2* then loop ; code CRC-XMODEM ( crc byt -- crc' ) dx pop ax pop dl dh xchg dx ax xor 8 # cx mov 1 $: ax 1 shl 2 $ jnc $1021 # ax xor 2 $: 1 $ loop 1push end-code \ CRC-XMODEM table-driven \ x16+x12+x5+1 Initial CRC = 0 -? create tb #256 2* allot -? : !tb #256 0 do 0 i >< xor 8 0 do dup 0< if 2* $1021 xor else 2* then loop i 2* tb + ! loop ; !tb forget !tb \ : CRC-XMODEM ( crc 8b -- crc' ) \ over 8 rshift xor 2* tb + @ swap 8 lshift xor ; code CRC-XMODEM ( crc 8b -- crc' ) bx pop dx pop dh bl xor bx bx add tb # bx add 0 [bx] ax mov dl ah xor 1push end-code behead tb tb \ CRC-32 \ CCITT Initial CRC = -1, DINVERT final CRC \ : CRC-32 ( dcrc byt -- dcrc' ) \ 8 0 do -rot over 3 pick xor 1 and >r d2/ $7FFF and r> if \ $EDB8 xor swap $8320 xor swap then rot 1 rshift loop drop ; code CRC-32 ( dcrc byt -- dcrc' ) bx pop ax pop dx pop 8 # cx mov 1 $: bl bh mov dl bh xor ax 1 shr dx 1 rcr bh 1 shr 2 $ jnc $EDB8 # ax xor $8320 # dx xor 2 $: bl 1 shr 1 $ loop 2push end-code : DINVERT ( d1 -- d2 ) invert swap invert swap ; \ CRC-32 table-driven \ CCITT Initial CRC = -1, DINVERT final CRC -? create tb #256 2* 2* allot -? : !tb #256 0 do i 0 8 0 do over 1 and >r d2/ $7FFF and r> if $EDB8 xor swap $8320 xor swap then loop i 2* 2* tb + 2! loop ; !tb forget !tb \ : CRC-32 ( dcrc 8b -- dcrc' ) \ 2 pick xor $FF and 2* 2* tb + 2@ 2>r 8 0 do \ d2/ loop $FF and r> xor swap r> xor swap ; code CRC-32 ( dcrc 8b -- dcrc' ) bx pop ax pop dx pop dl bl xor bx bx add bx bx add tb # bx add dh dl mov al dh mov ah al mov ah ah sub 0 [bx] ax xor 2 [bx] dx xor 2push end-code behead tb tb : DINVERT ( d1 -- d2 ) invert swap invert swap ; \ Sieve BYTE benchmark 8190 constant SIZE create FLAGS size allot : PRIME ( -- ) flags size 1 fill 0 size 0 do flags i + c@ if i dup + 3 + dup i + begin dup size < while 0 over flags + c! over + repeat drop drop 1+ then loop cr . ." Primes " ; : SIEVE ( -- ) cr 10 0 do prime loop ; \ Interface Age benchmark : BENCH ( 1000 -- ) dup 2 / 1+ swap cr ." Starting " CR 1 do dup i 1 rot 2 do drop dup i /mod dup 0= if drop drop 1 leave else 1 = if drop 1 else dup 0 > if drop 1 else 0= if 0 leave then then then then loop if 4 .r else drop then loop drop cr ." Finished. " ; \ PARSE-WORD sys @ system : PARSE-WORD ( char -- c-addr u ) >r source >in @ /string over swap r@ skip drop swap - >in +! r> parse ; : PARSE-NAME ( -- c-addr u ) bl parse-word ; sys ! \ MOVEL \ smart intersegment block move code MOVEL ( seg1 offs1 seg2 offs2 u -- ) sp bx mov 3 $ ) call 3 $ ) call cx pop di pop bx pop dx pop ax pop si push ds push dx si mov bx ax cmp 1 $ jb 2 $ ja di si cmp 2 $ ja 1 $: cx si add cx di add si dec di dec std 2 $: bx es mov ax ds mov rep byte movs cld ds pop si pop next 3 $: bx inc bx inc 0 [bx] ax mov 4 # cl mov ax cl shr $0F # 0 [bx] and bx inc bx inc ax 0 [bx] add ret end-code \ *ARRAY multi-dimension array : *ARRAY ( dimn..dim1 n itemsize "name" ) create >r dup c, 1 swap 0 do over , * loop r> dup , * allot does> ( idxn..idx1 -- addr ) count 0 tuck do >r cell+ dup @ rot r> + * loop + cell+ ; \ *ARRAY multi-dimension array sys @ application -? code doa ( idxn..idx1 -- addr ) bx pop ( pfa) 0 [bx] cl mov ch ch sub bx inc ax ax sub 1 $: dx pop dx ax add 2 # bx add 0 [bx] mul 1 $ loop bx inc bx inc ax bx add bx push next end-code system : *ARRAY ['] doa build ( dimn..dim1 n itemsize "name" ) >r dup c, 1 swap 0 do over , * loop r> dup , * allot ; sys ! behead doa doa \ F2DUP FTUCK FNIP FCEIL FTRUNC FMOD : F2DUP ( r1 r2 -- r1 r2 r1 r2 ) fover fover ; : FTUCK ( r1 r2 -- r2 r1 r2 ) fswap fover ; : FNIP ( r1 r2 -- r2 ) fswap fdrop ; : FCEIL ( r1 -- r2 ) fnegate floor fnegate ; : FTRUNC ( r1 -- r2 ) fdup f0< if fceil else floor then ; : FMOD ( r1 r2 -- r3 ) f2dup f/ ftrunc f* f- ; \ FATAN2 : FATAN2 ( y x -- r ) fdup f0< >r fdup f0= if fswap f< if [ pi 0.5e f* ] fliteral else [ pi -0.5e f* ] fliteral then else f/ fatan then r> if pi fover f0> if f- else f+ then then ; \ +FIELD \ Define a field within a data structure : +FIELD create ( offs1 size "name" -- offs2 ) over , + does> ( a1 -- a2 ) @ + ; \ +FIELD \ Define a field within a data structure sys @ application -? code dof ( a1 -- a2 ) bx pop ( pfa) ax pop 0 [bx] ax add ax push next end-code system : +FIELD ( offs1 size "name" -- offs2 ) ['] dof build over , + ; sys ! behead dof dof \ FVALUE FTO sys @ system : FVALUE ['] f@ build f, ; : FTO ( r "name" -- ) postpone addr state @ if postpone f! else f! then ; immediate sys ! \ C@+ C!+ @+ !+ : C@+ ( a1 -- a2 c ) dup char+ swap c@ ; : C!+ ( a1 c -- a2 ) over c! char+ ; : @+ ( a1 -- a2 n ) dup cell+ swap @ ; : !+ ( a1 n -- a2 ) over ! cell+ ; \ C@+ C!+ @+ !+ code C@+ ( a1 -- a2 c ) bx pop 0 [bx] al mov ah ah sub bx inc bx push ax push next end-code code C!+ ( a1 c -- a2 ) ax pop bx pop al 0 [bx] mov bx inc bx push next end-code code @+ ( a1 -- a2 n ) bx pop 0 [bx] ax mov 2 # bx add bx push ax push next end-code code !+ ( a1 n -- a2 ) ax pop bx pop ax 0 [bx] mov 2 # bx add bx push next end-code \ F@+ \ : F@+ ( a1 -- a2 r ) \ dup [ 1 floats ] literal + swap f@ ; code F@+ ( a1 -- a2 r ) sp di mov 0 [di] push 1 floats # 0 [di] add ' f@ ) jmp end-code \ 1+! 1-! C@+ C!+ -C@ -C! \ pointer operations on a VARIABLE : 1+! ( a -- ) 1 swap +! ; : 1-! ( a -- ) -1 swap +! ; \ post-incrementing : C@+ ( a -- c ) dup @ c@ swap 1+! ; : C!+ ( c a -- ) tuck @ c! 1+! ; \ pre-decrementing : -C@ ( a -- c ) dup 1-! @ c@ ; : -C! ( c a -- ) dup 1-! @ c! ; \ 1+! 1-! C@+ C!+ -C@ -C! \ pointer operations on a VARIABLE code 1+! ( a -- ) bx pop 0 [bx] inc next end-code code 1-! ( a -- ) bx pop 0 [bx] dec next end-code \ post-incrementing code C@+ ( a -- c ) bx pop 0 [bx] push 0 [bx] inc ' c@ ) jmp end-code code C!+ ( c a -- ) bx pop 0 [bx] push 0 [bx] inc ' c! ) jmp end-code \ pre-decrementing code -C@ ( a -- c ) bx pop 0 [bx] dec 0 [bx] push ' c@ ) jmp end-code code -C! ( c a -- ) bx pop 0 [bx] dec 0 [bx] push ' c! ) jmp end-code \ R-ALLOT \ Allocate u bytes on return stack. R@ gives buffer address. \ Discard return stack item before exiting definition. code R-ALLOT ( u -- ) ax pop ax inc $FFFE # ax and ( make even ) bp bx mov ax bp sub bp push 6 # bp sub bx 4 [bp] mov 1 $ # ax mov ax 2 [bp] mov 0 [bp] pop next \ remove buffer on exit 1 $: here cell+ , 0 [bp] bp mov ' exit ) jmp end-code \ E/MOD Euclidean division \ Returns a positive remainder irrespective of input sign \ Ref: 'divmodnote.pdf' D.Leijen : E/MOD ( dividend divisor -- rem quot ) >r s>d r@ sm/rem over 0< if r@ 0> if 1- swap r@ + swap else 1+ swap r@ - swap then then r> drop ; \ ANEW sys @ system \ Forget marker if it exists then create new : ANEW ( "name" ) >in @ postpone [defined] if dup >in ! forget then >in ! marker ; sys ! \ SEAL sys @ system \ Remove FORTH from search order leaving CONTEXT and CURRENT : SEAL ( -- ) context 2 cells + off ; sys ! \ +USER sys @ system \ Create USER variable reserving u bytes : +USER ( u "name" ) #user dup user + to #user ; sys ! \ SET-BIT CLEAR-BIT TOGGLE-BIT TEST-BIT code SET-BIT ( mask c-addr -- ) bx pop ax pop al 0 [bx] or next end-code code CLEAR-BIT ( mask c-addr -- ) bx pop ax pop al not al 0 [bx] and next end-code code TOGGLE-BIT ( mask c-addr -- ) bx pop ax pop al 0 [bx] xor next end-code code TEST-BIT ( mask c-addr -- flag ) bx pop ax pop al 0 [bx] test 1 $ jz ' true ) jmp 1 $: ' false ) jmp end-code \ Quotations \ Load before locals to give quotations access to parent locals system : [: ( c: -- q-sys ) state @ if last 2@ postpone ahead bal @ csp 2@ true else false then :noname ; immediate : ;] ( c: q-sys -- ; -- | xt ) postpone ; >r if csp 2! bal ! ] postpone then last 2! r> postpone literal else r> then ( xt ) ; immediate application \ DO LOOP extensions sys @ application \ Copy of nth loop index code I-TH ( n -- index ) di pop di shl di shl 0 [bp+di] ax mov 2 [bp+di] ax add 1push end-code sys ! \ SYNONYM sys @ system : SYNONYM ( "newname" "oldname" ) <# token shold token 1+ shold s" AKA " shold 0 0 #> evaluate ; sys ! \ FEED \ Feed string a u to parsing word xt sys @ system : FEED ( a u xt -- ) -rot s" EXECUTE " pad 0 +string +string evaluate ; sys ! \ MJD - Modified Julian Date \ MJD is number of days since 1899-12-31 stored as 16-bit \ unsigned number. Valid range is 1900-3-1 to 2079-6-5. \ Modulo seven of MJD number returns day-of-week. -? #365 4 * 1 + constant d/y -? create days -1 , 0 , #31 , #59 , #90 , #120 , #151 , #181 , #212 , #243 , #273 , #304 , #334 , #367 , -? : @mth ( u1 -- u2 ) cells days + @ ; : >MJD ( d m y -- mjd ) #1900 - >r @mth #58 over < if r@ 3 and 0= - then + 1- r> d/y um* 4 um/mod swap 0<> - + ; : MJD> ( mjd -- d m y ) 4 um* d/y um/mod #1900 + swap 4 /mod 1+ dup rot 0= if dup #60 > + swap dup #59 > + then 1 begin 1+ 2dup @mth > 0= until 1- nip tuck @mth - swap rot ; behead d/y @mth \ No newline at end of file diff --git a/DX-FORTH v430/MISER.SCR b/DX-FORTH v430/MISER.SCR new file mode 100644 index 0000000..94bac95 --- /dev/null +++ b/DX-FORTH v430/MISER.SCR @@ -0,0 +1 @@ +\ Miser's Case Extend CASE with Pascal and C style features COND OF ELSE THENS (in DX-Forth kernel) COND EQUAL RANGE WHEN CONTINUE IF See demo screen for usage \ Miser's Case forth definitions decimal cr .( loading Miser's Case ) 2 5 thru \ .( loading Case demo ) 6 load \ Miser's Case application code (equ) bx pop ax pop ax bx cmp 1 $ jz ax push 2 # si add next 1 $: 0 [si] si mov next end-code code (rng) bx pop dx pop ax pop ax cx mov dx cx sub dx bx sub bx cx cmp 1 $ jna ax push 2 # si add next 1 $: 0 [si] si mov next end-code \ Miser's Case system \ Wil Baden's COND THENS (now in DX-FORTH kernel) \ : COND \ cs-mark ; immediate \ : THENS \ begin cs-test while postpone then repeat cs-drop ; \ immediate \ Add Pascal-like features : EQUAL postpone (equ) >mark ; immediate : RANGE postpone (rng) >mark ; immediate \ Miser's Case : WHEN postpone else cs-push postpone thens cs-pop ; immediate \ Add C Switch flow-through : CONTINUE cs-push postpone thens postpone cond cs-pop ; immediate application \ Miser's Case behead (equ) (rng) \ Case demo : test ( n ) space cond [ hex ] cond 0 1F range 7F equal when ." Control char " else cond 20 2F range 3A 40 range 5B 60 range 7B 7E range when ." Punctuation " else cond 30 39 range when ." Digit " else cond 41 5A range when ." Upper case letter " else cond 61 7A range when ." Lower case letter " else drop ." Not a character " [ decimal ] thens ; --> \ Case demo cr cr .( [press any key] ) key drop cr cr .( Miser's CASE demo ...) cr cr char a .( ) dup emit test cr char , .( ) dup emit test cr char 8 .( ) dup emit test cr char ? .( ) dup emit test cr char K .( ) dup emit test cr 0 dup 3 .r test cr 127 dup 3 .r test cr 128 dup 3 .r test \ No newline at end of file diff --git a/DX-FORTH v430/MULTI.SCR b/DX-FORTH v430/MULTI.SCR new file mode 100644 index 0000000..c05ed6f --- /dev/null +++ b/DX-FORTH v430/MULTI.SCR @@ -0,0 +1 @@ +\ Forth co-operative multitasker /TASKER ( -- ) initialize multitasker links TCB ( u s r "ccc" ; -- tcb ) create a task control block HIS ( tcb user -- user' ) get a task's user variable address ACTIVATE ( tcb -- ) initialize stacks and run task WAKE ( tcb -- ) resume a task SLEEP ( tcb -- ) suspend a task STOP ( -- ) stop current task, switch to next MULTI ( -- ) enable multitasker SINGLE ( -- ) disable multitasker PAUSE ( -- ) switch to next active task GRAB ( sem -- ) grab resource GET ( sem -- ) pause then grab resource RELEASE ( sem -- ) release resource #FLOAT ( u -- ) per-task f/p stack bytes \ Load screen forth definitions decimal application cr .( loading Multitasker ) 2 #screens 1- thru \ STATUS LINK TOS /TASKER HIS \ Define reserved user variables 0 user TOS \ save top of stack 2 user STATUS status on \ task active flag 4 user LINK \ link to next task's user link value tlink \ topmost LINK \ Initialize multitasker links : /TASKER ( -- ) status tlink ! ; /tasker \ Calculate task local user address : HIS ( tcb user -- user' ) tos - + ; \ (pause) \ Pause current task & switch to next active code (pause) ( -- ) true # al mov \ wake fsp ) push si push bp push \ push FSP IP RP up ) bx mov sp 0 [bx] mov \ save SP to TOS 2 # bx add al 0 [bx] mov \ wake or sleep 1 $: 2 # bx add 0 [bx] bx mov \ find active task false # byte 0 [bx] cmp 1 $ jz false # byte 0 [bx] mov \ sleep 2 # bx sub bx up ) mov \ load UP 0 [bx] sp mov \ restore SP bp pop si pop fsp ) pop \ pop RP IP FSP next end-code \ STOP WAKE SLEEP SINGLE MULTI \ Stop current task & switch to next active code STOP ( -- ) al al sub ' (pause) 2 + ) jmp end-code \ Resume a task : WAKE ( tcb -- ) cell+ on ; \ Suspend a task : SLEEP ( tcb -- ) cell+ off ; \ Disable multitasker : SINGLE ( -- ) ['] noop is pause ; \ Enable multitasker : MULTI ( -- ) ['] (pause) is pause ; \\ (activate) \ Initialize stacks & wake task : (activate) ( tcb -- ) dup s0 his @ \ get task stack cell- over fs0 his @ over ! \ push FS0 cell- r> over ! \ push start IP cell- over r0 his @ over ! \ push R0 over tos his ! \ set TOS dup catcher his off \ set CATCHER wake ; \ (activate) \ Initialize stacks & wake task code (activate) ( tcb -- ) bx pop s0 user# [bx] ax mov \ get task stack sp ax xchg fs0 user# [bx] push \ push FS0 si push \ push start IP r0 user# [bx] push \ push R0 sp ax xchg ax tos user# [bx] mov \ set TOS 0 # catcher user# [bx] mov \ set CATCHER true # byte status user# [bx] mov \ awake ' exit ) jmp end-code \ ACTIVATE system \ Execution begins with word following ACTIVATE : ACTIVATE ?comp postpone (activate) ; immediate application \ #FLOAT TCB system fs0 @ s0 @ - value #FLOAT \ f/p stack bytes \ create task control block : TCB ( u s r "ccc" ; -- tcb ) create here >r rot dup allot up @ r@ rot cmove \ copy USER vars here dup r@ dp his 2! \ DP DPS swap allot here r@ s0 his ! \ S0 #float allot here r@ fs0 his ! \ FS0 allot here r@ r0 his ! \ R0 r@ sleep r@ status his tlink ! \ sleep & add task r> link his to tlink /tasker ; \ application \ GRAB GET RELEASE \ Grab resource code GRAB ( sem -- ) bx pop up ) ax mov 0 [bx] cx mov 1 $ jcxz cx ax cmp 2 $ jz bx push 2 # si sub ' (pause) ) jmp 1 $: ax 0 [bx] mov 2 $: next end-code \ Pause then grab resource : GET ( sem -- ) pause grab ; \ Release resource code RELEASE ( sem -- ) bx pop up ) ax mov 0 [bx] ax sub 1 $ jnz ax 0 [bx] mov 1 $: next end-code \ discard heads behead tlink tlink behead (pause) (pause) behead (activate) (activate) \\ Demo 1 variable SCREEN screen off #user dup user CNT 1 cells + ( u) dup 64 64 tcb DCOUNTING \ task1 control block ( u) 64 64 tcb HCOUNTING \ task2 control block : DCOUNTER ( -- ) dcounting activate decimal 0 cnt ! begin screen get get-xy 0 2 at-xy cnt @ dup 0 10 d.r 1+ cnt ! at-xy screen release pause again ; : HCOUNTER ( -- ) hcounting activate hex 0 cnt ! begin screen get get-xy 15 2 at-xy cnt @ dup 0 10 d.r 1- cnt ! at-xy screen release pause again ; : RUN ( -- ) /tasker status on page ." 2 tasks counting:" dcounter hcounter multi begin key? until key drop single ; cr .( Save demo1? ) y/n [if] turnkey run DEMO1 bye [then] \\ Demo 2 variable SCREEN screen off #user dup user CNT 1 floats + ( u) dup 200 64 tcb UCOUNTING \ task1 control block ( u) 200 64 tcb DCOUNTING \ task2 control block : UPCOUNT ( -- ) ucounting activate 0e cnt f! begin screen get get-xy 0 2 at-xy cnt f@ fdup 0 10 f.r 1e f+ cnt f! at-xy screen release pause again ; : DOWNCOUNT ( -- ) dcounting activate 0e cnt f! begin screen get get-xy 15 2 at-xy cnt f@ fdup 0 10 f.r 1e f- cnt f! at-xy screen release pause again ; : RUN ( -- ) /tasker status on page ." 2 f/p tasks counting:" upcount downcount multi begin key? until key drop single ; cr .( Save demo2? ) y/n [if] turnkey run DEMO2 bye [then] \ No newline at end of file diff --git a/DX-FORTH v430/MULTI.TXT b/DX-FORTH v430/MULTI.TXT new file mode 100644 index 0000000..4ee62e1 --- /dev/null +++ b/DX-FORTH v430/MULTI.TXT @@ -0,0 +1,306 @@ +DX-Forth Multitasker +-------------------- + +1. Introduction +2. Multitasking words +3. Design considerations +4. Semaphores +5. Messages +6. A multitasking example +7. Turnkey applications +8. Task Control Block + + +1. Introduction + +A co-operative multitasker MULTI.SCR is provided with DX-Forth +allowing several tasks to run concurrently within an application. + +Each task has its own stacks, user variables and (if required) +PAD and HOLD buffer. Tasks are linked in a 'round-robin' loop +with switching occuring on each encounter of PAUSE. + +2. Multitasking words + + TCB ( u s r "ccc" -- ) compiling + ( -- tcb ) run-time + + Create a task control block named ccc. u s r is the number + of bytes reserved for the task's user area, data and return + stacks respectively. The task is initially put to sleep. + When ccc is executed, the address of the task control block + is placed on the data stack. + + See: ACTIVATE + + ACTIVATE ( tcb -- ) + + Initialize the stacks and wake task tcb. Task execution + begins with the word following ACTIVATE. ACTIVATE must be + used inside a definition. + + HIS ( tcb user -- user' ) + + Get address of user variable belonging to task tcb. + + PAUSE ( -- ) + + Save the current task state and pass control to the next + active task. + + STOP ( -- ) + + Put the current task to sleep and switch to next active + task. + + WAKE ( tcb -- ) + + Resume the task identified by tcb. + + SLEEP ( tcb -- ) + + Suspend the task identified by tcb. + + SINGLE ( -- ) + + Disable the multitasker. Only the current task remains + active. + + MULTI ( -- ) + + Enable the multitasker. + + Note: MULTI does not enable individual tasks. See + ACTIVATE. + + GRAB ( sem -- ) + + Obtain the resource identified by the semaphore variable. + If owned by another task, repeatedly execute PAUSE until + the resource becomes available. + + GET ( sem -- ) + + Same as GRAB but performs an initial PAUSE. + + RELEASE ( sem -- ) + + Release the resource identified by the semaphore variable. + If the resource is owned by another task, do nothing. + + /TASKER ( -- ) + + Initialize the multitasker links. TURNKEYed applications + must execute /TASKER before launching the multitasker. + + #FLOAT ( -- u ) + + A VALUE returning the size in bytes of the separate floating + point stack to be assigned for each task. #FLOAT is preset + to the system default value but may be changed prior to + executing TCB. + +3. Design considerations + +3.1 Data and return stacks + +Sufficient data and return stack space must be allocated for each +task. Inadequate stack can cause mysterious crashes or unexpected +behaviour and can be difficult to trace. It is usually better to +start with larger stack sizes during development and reduce it +once the application is fully debugged. + +Note: Task switching consumes 3 cells (6 bytes) of data stack and +must be included when calculating task data stack allocation. If +the task uses floating point on the data stack this must be +included also. + +3.2 PAD and HOLD buffer + +Tasks are not automatically alloted a PAD or HOLD buffer. If a +PAD or HOLD buffer is required it must be allocated by assigning +extra space to the data stack. When defining a task control block, +use the following calculation: + + s (bytes) = task data stack requirement + + HOLD buffer size (default 68 bytes) + + PAD size required + +Tasks that display numbers or use the pictured numeric operators +<# ... #> HOLD etc. will require a HOLD buffer. If a task requires +PAD then a HOLD buffer (default 68 bytes) must also be provided. + +3.3 USER area + +The size of a task user area should be at least #USER bytes. Tasks +may begin defining their per-task user variables at offset #USER. + +3.4 Floating-point + +If a separate floating-point system is detected, each task is +automatically allocated an f/p stack. The size of the f/p stack +is determined by #FLOAT. If a task performs no floating-point +then #FLOAT may be set to zero. + +3.5 PAUSE + +Each active task is required to PAUSE to give other tasks a chance +to execute. In DX-Forth PAUSE is automatically performed by KEY? +KEY EMIT TYPE and MS. If a task does not perform any of these +function (or does so infrequently) then a PAUSE must be explicitly +included in the program. + +3.6 Other + +Tasks are typically defined as an infinite loop e.g. within a BEGIN +AGAIN construct. If a task needs to terminate, use STOP. + +Tasks should not assume the initial contents of a user variable e.g. +a task which uses BASE directly or indirectly must explicitly set +BASE to the required number radix. + +To build a multitasking application, load MULTI.SCR from your +application. TURNKEY applications must execute /TASKER before +starting the multitasker. + +During testing, do not FORGET tasks. Instead use COLD and reload +the application. Do not use SAVE or TURNKEY while the multitasker +is active. + +4. Semaphores + +Semaphores are used to prevent conflicts that may arise when +several tasks access a common resource. In DX-Forth a semaphore +is simply a VARIABLE with the contents initialized to zero. + +Consider the case when two tasks send output to the screen. Since +PAUSE is built into EMIT this would result in a jumbled display. +A solution is to enclose the display routine with SINGLE and MULTI. +While this would work it has the disadvantage that the multitasker +is disabled for all other tasks while printing takes place. + +A better way is with semaphores. A semaphore is a variable which +signals whether a resource is available. + +In the example below, tasks which display to the screen GET the +resource making it unavailable to other tasks. When the task has +finished with the screen it is RELEASEd. Tasks waiting for a +resource automatically PAUSE until the resource becomes available. + +GET GRAB RELEASE are modelled after the Forth Inc. functions of +the same name. + + VARIABLE SCREEN \ create a resource for the screen + SCREEN OFF \ mark screen as available + + \ TASK1 + ... + SCREEN GET + 10 10 AT-XY ." Task 1" + SCREEN RELEASE + ... + + \ TASK2 + ... + SCREEN GET + 50 10 AT-XY ." Task 2" + SCREEN RELEASE + ... + + \ TASK3 + ... + +5. Messages + +Messages (also known as mailboxes) provide a way of passing data +between tasks. The following is an example of a simple message +system. While 16 bit data is assumed, the concept can be expanded +to pass data of any type or size - strings, CP/M records etc. + + \ Define a message variable + CREATE ( -- addr ) + 0 , \ flag 0=empty + 1 CELLS ALLOT \ storage space + + \ Send message + : SEND ( x addr -- ) + BEGIN PAUSE DUP @ 0= UNTIL DUP ON CELL+ ! ; + + \ Receive message + : RECEIVE ( addr -- x ) + BEGIN PAUSE DUP @ UNTIL DUP OFF CELL+ @ ; + +6. A Multitasking Example + +This simple example that shows how to write a task, launch it, turn +it on and off, disable it and the multitasker altogether. + +First load the multitasker system: + + USING MULTI.SCR 1 LOAD + +Create a task by entering the following definitions: + + VARIABLE COUNTS + + #USER 32 32 TCB COUNTING + + : COUNTER ( -- ) + COUNTING ACTIVATE + BEGIN PAUSE 1 COUNTS +! AGAIN ; + + : X ( -- ) COUNTS @ U. ; + +We have created a task block called COUNTING and reserved #USER +bytes of user area and 32 bytes each for data and return stacks. +Since the task won't be outputting numbers or need a PAD we +haven't allocated any space for them. + +The definition COUNTER embodies both the task initialization and +its action. COUNTING ACTIVATE resets the task stacks and wakes it. +Task execution begins with the word immediately following ACTIVATE. + +Our example task is very simple - it simply increments the value +held in COUNTS. Since the task is defined as an endless loop, +COUNTS will update automatically whenever the task is in control. +Note there is a PAUSE within the loop - this is important as it +allows other tasks a chance to execute. + +Should we want COUNTER to run once or stop looping after some +event, a STOP can be included in the definition. + +The following shows how to start and control COUNTER. You may +type X at any time to see whether the task is running. + +To control the task we can use: + + MULTI ( start the multitasker ) + COUNTER ( start our task ) + + COUNTING SLEEP ( put the task to sleep ) + COUNTING WAKE ( wake the task again ) + + SINGLE ( stop the multitasker ) + MULTI ( restart the multitasker again ) + +7. Turnkey applications + +It is important that /TASKER is executed by turnkey applications +before the multitasker is invoked. + +8. Task Control Block + +R0 ;---------------------- + ; return stack +FS0 ;---------------------- + ; fp-stack (if used) +S0 ;---------------------- + ; data stack + ;---------------------- + ; PAD buffer (if used) +PAD ;---------------------- + ; HOLD buffer (if used) +HERE ;---------------------- + ; user variables +tcb ;---------------------- + diff --git a/DX-FORTH v430/NEWAPP.SCR b/DX-FORTH v430/NEWAPP.SCR new file mode 100644 index 0000000..b459aaa --- /dev/null +++ b/DX-FORTH v430/NEWAPP.SCR @@ -0,0 +1 @@ +\ Information NEWAPP is a skeletal program that allows users to quickly develop a DOS application. It provides often needed tasks including error handling, command-line parsing, file operations, buffered I/O, help screen, number and string functions. NEWAPP comprises two parts: NEWAPP.SCR skeletal application program DOSLIB.SCR function support library \ Load - main screen empty forth definitions decimal application warning on : TITLE ." NEWAPP version 0.0 2017-01-17" cr ; cr .( Compiling: ) title 2 load cr .( Save to disk? ) y/n [if] \ reserve @ pad + 256 + limit s0 @ - + set-limit turnkey program NEWAPP [then] \ Load - defaults variable RESERVE 0 reserve ! \ reserved memory tally defer ?BREAK ' noop is ?break \ break check off defer SET-IO ' bios-io is set-io \ default console mode defer ONERROR ' noop is onerror \ reset on-error handler defer ONSTART ' noop is onstart \ startup initialization blk @ 1+ #screens 1- thru \ load electives & application ' (?break) is ?break \ enable user break \ ' dos-io is set-io \ enable console redirection ' deloutfile +is onerror \ delete outfile on error \ wrtchk off \ disable overwrite check \ Electives 1 fload DOSLIB \ DOSLIB library _Errors \ error handler _Inout1 \ number output _Inout2 \ string & number input \ _Compare1 \ basic compare _String1 \ basic strings \ _String2 \ extra strings _Parsing1 \ command-line parsing \ _Parsing2 \ command-line parsing _Fileprims \ file primitives _Files \ default files _Bufinfile \ buffered input file _Bufoutfile \ buffered output file \\ Electives _Dos1 \ dosver dta _Dos2 \ ctl-brk int _Disk \ disk _Memory \ memory allocate _Timedate1 \ time/date _Timedate2 \ time/date _Timepack \ time/date packing _Filematch \ file find first/next _Filestamp \ file stamp/attribute _Diskdir \ directory _Env \ environment _Exec \ exec prog/command _Video1 \ textcolor attrib cursor _Video2 \ mode page \\ Electives _Timing1 \ timer _Timing2 \ delay _Device1 \ 8087 cpu keybd \ Help screen - HELP : HELP ( -- ) dos-io cr cr title cr ." Use: NEWAPP [options] file[.TXT] [file[.DOC]]" cr cr ." -A set A option" cr ." -B set B option" cr ." -Cn set C option using numeric argument (1-10)" cr \ Help screen - HELP cr ." default: list program defaults here" cr cr ." Insert a brief description of program here." cr ." The HELP screen should be invoked when a program" cr ." is unable to proceed due to fatal user error." set-io error1 ; \ Variables variable A-VAR \ variable B-VAR \ 1 value C-VAL \ \ (SETOPTION) \ Set options : (SETOPTION) ( a u char -- a u ) upcase [char] A of A-VAR on end [char] B of B-VAR off end [char] C of 1 10 /numrange to C-VAL end badoption ; ' (setoption) is setoption \ (PARSEFILENAME) \ Parse filenames : (PARSEFILENAME) ( -- ) argv 0= if help then s" TXT" +ext infile setname argv 0= if infile filename -path -ext then s" DOC" +ext outfile setname ; ' (parsefilename) is parsefilename \ (RUN) \ Run application : (RUN) ( -- ) cr ." infile: " infile .file r/o openinfile cr ." outfile: " outfile .file r/w makeoutfile cr ( perform the application tasks ) begin readchar while writechar repeat \ a sample application closefiles ; \ DEFAULTS \ Set application defaults : DEFAULTS ( -- ) ; defaults \ RUN PROGRAM \ Run application with error handling : RUN ( -- ) ['] (run) catch ?dup if >r onerror r> throw then ; \ Main : PROGRAM ( -- ) onstart \ startup initialization set-io \ set console mode defaults \ set defaults cr title \ show application name cmdtail parsecmd \ process command-line run \ run application cr ." done" \ show success ; \ No newline at end of file diff --git a/DX-FORTH v430/NEWAPP.TXT b/DX-FORTH v430/NEWAPP.TXT new file mode 100644 index 0000000..52d1d18 --- /dev/null +++ b/DX-FORTH v430/NEWAPP.TXT @@ -0,0 +1,160 @@ + + NEWAPP and DOSLIB + + *** IMPORTANT *** + +NEWAPP.SCR and DOSLIB.SCR are subject to change (really!) There is +no guarantee - or intent - that future versions will remain backward +compatible. When backing up or distributing application source code +that uses DOSLIB.SCR, it is important to include a copy as later +versions of DOSLIB may no longer be compatible. + + Introduction + +NEWAPP is a skeletal program that allows users to quickly develop a +DOS application. It provides often needed tasks including error +handling, command-line parsing, file operations, buffered I/O, help +screen, number and string functions. + +NEWAPP comprises two parts: + + NEWAPP.SCR skeletal main program + DOSLIB.SCR function library + +NEWAPP is supplied as a functioning program which may be turnkeyed. +Styled as a typical DOS command-line application it demonstrates +how the various tasks are integrated to form a functioning program. +Making NEWAPP perform a useful task can be as easy as adding one +line. In this instance it is line 6 of the definition (RUN) which +turns NEWAPP into a simple filecopy utility. + +DOSLIB is a library of Forth and DOS functions in source form. +While the primary role is support for NEWAPP, DOSLIB may be used +by any application. DOSLIB is organized as named modules. +1 FLOAD DOSLIB causes the names of all the modules contained in +DOSLIB to be loaded into the dictionary. Executing the name of a +module causes the corresponding code to be loaded into memory. +NEWAPP automatically loads DOSLIB and a default set of modules. + +New users are encouraged to examine and understand how NEWAPP works +before attempting to create their own application. The following +notes should help with some of the less obvious aspects. Unless +otherwise stated all screen references refer to NEWAPP.SCR. + +First, an explanation of the function +IS which is used by NEWAPP. ++IS is similar to IS but instead of replacing the existing behaviour +of a DEFERed word, it chains in a new action. When the deferred word +is eventually executed, all actions in the chain will be performed +beginning with the most recently added. + +1. Setting the options + + Screen 1 defines the title of the program, version, date and name + for the turnkey executable. + + The programmer may optionally specify the upper limit of memory for + turnkey applications (Screen 1 line 10). This is useful for + environments where memory is limited. The calculation includes 256 + bytes for PAD and data stack, plus any RESERVE bytes tallied at + compile-time. Typically RESERVE holds the total number of bytes the + program will ALLOT or otherwise need at run-time. By default LIMIT + is set to the maximum available memory i.e. the compiler's top of + memory address (usually $FFF0 for MS-DOS or CCP/BDOS base for CP/M). + + Screen 2 loads the remainder of the application. It also defines + and sets the action for several deferred words which are explained + below. + + ONSTART is a deferred word. Its function is to perform any system + initialization that may be required before the application begins. + Typically these will be "run once" tasks such as alloting buffers + or initializing memory management functions. Actions are added to + ONSTART via +IS. + + SET-IO is a deferred word that sets the console input/output method. + By default SET-IO is set to BIOS-IO. Users needing DOS console I/O + redirection can do so either by selectively surrounding words with + DOS-IO ... SET-IO pairs or by uncommenting the line: + ' DOS-IO IS SET-IO. + + The DOSLIB disk read/write routines include a keyboard test. If + ESC CTRL-C or CTRL-BREAK keys are detected, the user is given an + opportunity to abort the program. The feature may be disabled by + commenting out the line: ' (?BREAK) IS ?BREAK. + + ONERROR is the application's top-level error handler. It intercepts + exceptions before the system's error handler deals with it. ONERROR + permits the application to perform any necessary 'clean-up' tasks + before aborting. + + ONERROR is a deferred word whose action is modified with +IS. An + example is the DOSLIB 'files' module which extends ONERROR to + automatically close the default files should an error occur. + + Note: If a function performed by ONERROR itself generates an exception + then the original exception that caused ONERROR to execute is likely + to be masked. + +2. Loading DOSLIB modules + + Screen 3 of NEWAPP.SCR initializes the DOSLIB library then proceeds + to load the named modules. This screen contains the support modules + typically needed by NEWAPP based applications. If your application + does not require a particular module and you wish to conserve space, + then you may comment out the line on which the module's name appears. + +3. Default files + + The default files module simplifies much of the drudgery associated + with file handling e.g. display of filenames when opening, overwrite + checking, error messages when reading or writing files etc. + + One input and one output file are supported which is sufficient for + most applications. The usual file read/write functions are provided + including file position and reposition. Output file overwrite + checking is enabled by default. It may be turned off by uncommenting + the line: WRTCHK OFF on screen 2. + + When an application aborts as a result of a fatal error, the default + files will be automatically flushed and closed. If it is desired to + delete the default output file, it can be done by uncommenting the + line on screen 2: ' DELOUTFILE +IS ONERROR + + FLUSHWRITE is an optional function that works similarly to FLUSH-FILE. + Data written to the default output file is forced to disk updating + the directory. Buffered output, if loaded, is also flushed. + +4. Buffered files + + This is an optional extension to the default files and allows reading + and writing one character at a time. For speed buffers are used to + hold the data. Buffer refill and flushing is automatic and requires + no user intervention. The default buffer size is 512 bytes and is + given by /INBUF /OUTBUF respectively. Normally the buffers are + allocated at compile-time but this can be changed to run-time if + desired. + + Example: Allocate the buffered output file at run-time and change + the buffer size to 1024 bytes. + + Make the following changes to the copy of NEWAPP.SCR that will be + your application. + + Step 1. Disable compile-time buffer allocation by setting /OUTFILE + to zero prior to executing _Bufoutfile. + + ( Screen 3 Line 13) + 0 to /OUTFILE _Bufoutfile \ buffered output file + + Step 2. Initialize output buffer at run-time by creating a word to + perform the task and appending it to deferred word ONSTART. + + ( Screen 2 Line 13) + :noname ( -- ) #1024 to /OUTFILE here to OUTFILE + /OUTFILE allot resetoutbuf ; +is ONSTART + + Note: Applications may apply this technique to any large buffer used + by the program. It is useful for keeping turnkey executables small + and/or allocating buffers greater than would fit in memory at compile- + time. + diff --git a/DX-FORTH v430/OBSOLETE.SCR b/DX-FORTH v430/OBSOLETE.SCR new file mode 100644 index 0000000..b6e844d --- /dev/null +++ b/DX-FORTH v430/OBSOLETE.SCR @@ -0,0 +1 @@ +\ Information This file contains former DX-Forth words that are obsolete or no longer present in the kernel. Should an old DX-Forth source file fail to load due to obsolete words, then type 1 FLOAD OBSOLETE before loading your application. See OBSOLETE.TXT for further information \ Load screen forth definitions decimal application cr .( Loading obsolete DX-Forth words ) marker -OBSOLETE 2 #screens 1- thru freeze \ : STRING+ 2swap +string ; aka +EXT +FILENAME aka -EXT -FILENAME aka LOADFILE FNAME aka LOADFILE FILENAME aka CSEG DSEG aka REMEMBER +PRUNE aka +PRUNE PRUNES aka GET-XY AT-XY? aka GET-WINDOW WINDOW? aka 'AX regAX aka 'BX regBX aka 'CX regCX aka 'DX regDX aka 'BP regBP aka 'SI regSI aka 'DI regDI aka 'DS regDS aka 'ES regES aka 'FLAGS regFLAGS aka 'SOURCE (SOURCE) aka FYI MAP aka BEHEAD EXCISE aka CATCHER HANDLER aka PROTECT FREEZE aka PACK PACKED aka /PARSE PARSE$ code BDOS ( DX x -- AL ) ax pop dx pop bx bx sub cx cx sub al ah xchg $21 int ah ah sub 1push end-code \ ?PAIRS system : ?PAIRS ( n1 n2 -- ) - ABORT" conditionals not paired" ; application \ L: L# #) S) #S) JP JNP [defined] assembler [if] assembler definitions \ aka $: L: aka $ L# aka ) #) aka [] S) aka [] #S) aka JPE JP aka JPO JNP forth definitions [then] \ INVERSE BOLD BRIGHT : INVERSE ( -- ) [ color-table 1+ ] literal c@ attrib c! ; : BOLD ( -- ) [ color-table 2+ ] literal c@ attrib c! ; : BRIGHT ( -- ) [ color-table 3 + ] literal c@ attrib c! ; \ Simple locals system : local ( "name" ) sys @ system ['] noop value immediate sys ! does> @ state @ if compile, else execute then ; application local %1 local %2 local %3 local %4 local %5 local %6 local %7 local %8 behead local local \ No newline at end of file diff --git a/DX-FORTH v430/OBSOLETE.TXT b/DX-FORTH v430/OBSOLETE.TXT new file mode 100644 index 0000000..53e2c95 --- /dev/null +++ b/DX-FORTH v430/OBSOLETE.TXT @@ -0,0 +1,19 @@ +A note for users upgrading from previous versions of DX-Forth +------------------------------------------------------------- + +Changes and improvements to DX-Forth may occasionally result in +compatibility issues with previous application software. + +Usually the problem takes the form of an application either not +loading successfully or (less common) not running - despite its +compiling and running correctly on a previous version of DX-Forth. + +For the first case, the user should try loading OBSOLETE.SCR before +loading the application. In most cases this will fix the problem. +OBSOLETE.SCR contains functions that once existed in DX-Forth but +were removed due to obsolescence. + +Should the application compile but fail to execute correctly then +the incompatibility is likely to be more subtle. In this instance +one should read CHANGES.TXT to ascertain what function behaviours +have changed since the application was originally developed. diff --git a/DX-FORTH v430/OVERLAY.SCR b/DX-FORTH v430/OVERLAY.SCR new file mode 100644 index 0000000..99f5026 --- /dev/null +++ b/DX-FORTH v430/OVERLAY.SCR @@ -0,0 +1 @@ +\ Overlay - Information 001119es These screens shows how to implement an overlay system for DX-Forth. It allows the creation of applications larger than would otherwise be possible. WARNING: when running or debugging programs using overlays, do not attempt to execute a word in an overlay if that overlay is not currently loaded - it will cause the system to crash. This version is only suitable for MSDOS DX-FORTH 2. \ Overlay - Load screen 001119esFORTH DEFINITIONS DECIMAL APPLICATION CR .( loading the overlay words... ) 2 LOAD CR .( now creating 3 overlays... ) 4 LOAD CR .( now testing it... ) TEST \ Overlay - OBASE OSIZE FILE LOAD-OVERLAY 001119esFORTH DEFINITIONS DECIMAL APPLICATION VARIABLE OBASE \ base address of the overlay segment VARIABLE OSIZE \ size of largest overlay segment VARIABLE FILE 66 ALLOT \ filename buffer \ Load overlay : LOAD-OVERLAY ( c-addr u -- ior ) 2DUP FILE PLACE R/W OPEN-FILE ?DUP IF SWAP DROP EXIT THEN >R OBASE @ OSIZE @ R@ READ-FILE SWAP DROP R> CLOSE-FILE OR ; --> \ Overlay - OVERLAY 001119esSYSTEM \ Save overlay to disk and discard segment memory : OVERLAY ( -- ) BL WORD COUNT R/W CREATE-FILE ABORT" can't create overlay" OBASE @ HERE OVER - ROT over >R >R \ overlay size DUP OSIZE @ MAX OSIZE ! \ update max size R@ WRITE-FILE ABORT" can't write overlay" R> CLOSE-FILE ABORT" can't close overlay" R> NEGATE ALLOT ; \ discard memory APPLICATION \ Overlay - Demo 001119esAPPLICATION \ MUST be located in application space HERE OBASE ! \ overlay start address 0 OSIZE ! \ initial size : WORD1 ( -- ) CR ." This is WORD1 from SAMPLE1.OVL" ; OVERLAY SAMPLE1.OVL : WORD2 ( -- ) CR ." This is WORD2 from SAMPLE2.OVL" ; OVERLAY SAMPLE2.OVL : WORD3 ( -- ) CR ." This is WORD3 from SAMPLE3.OVL" ; OVERLAY SAMPLE3.OVL OSIZE @ ALLOT \ reserve memory for overlays --> \ Overlay - Demo 001119es\ Display file error msg and abort : FILE-ERROR ( c-addr u -- ) CR TYPE FILE COUNT TYPE ABORT ; \ Load overlay, handle any errors : OLOAD ( c-addr u -- ) LOAD-OVERLAY IF S" Error loading overlay: " FILE-ERROR THEN ; \ Create loader for each overlay : OVERLAY1 ( -- ) S" SAMPLE1.OVL" OLOAD ; : OVERLAY2 ( -- ) S" SAMPLE2.OVL" OLOAD ; : OVERLAY3 ( -- ) S" SAMPLE3.OVL" OLOAD ; \ Test the overlays : TEST ( -- ) OVERLAY1 WORD1 OVERLAY2 WORD2 OVERLAY3 WORD3 ; \ No newline at end of file diff --git a/DX-FORTH v430/SED.SCR b/DX-FORTH v430/SED.SCR new file mode 100644 index 0000000..b16f3b6 --- /dev/null +++ b/DX-FORTH v430/SED.SCR @@ -0,0 +1 @@ +\ Information A full-screen editor for DX-Forth. Based on the editor from "Forth - A Text and Reference" by Kelly & Spies. Usage: n SED ( edit screen n ) SED ( edit screen where error occured ) Ctl-D Right cursor Ctl-Y Delete line Ctl-C Next block Ctl-S Left cursor Ctl-N Insert line Ctl-R Prev Block Ctl-E Up cursor Ctl-T Erase to EOL Ctl-L Restore blk Ctl-X Down cursor Ctl-A Save line Ctl-J Jump to blk Ctl-I Tab cursor Ctl-P Restore line Ctl-K Update block Ctl-Q Home cursor Ctl-O Open-up line Ctl-V Insert toggleCtl-G Del next char Ctl-W Split line Ctl-B Redraw screenCtl-H Del prev char Ctl-F Join line Ctl-Z Functions Ctl-U Exit editor Esc Graphic toggle \ Load block forth definitions decimal sys @ system cr .( loading Screen Editor ) 2 #screens 1- thru forth definitions decimal sys ! \ Constants, variables vocabulary EDITOR editor definitions \ 1024 constant B/BUF \ bytes per block buffer \ 64 constant C/L \ columns per line : L/S b/buf c/l / ; \ lines per screen 4 constant X \ screen x offset 2 constant Y \ screen y offset 4 constant TBS \ tab size increment variable R# \ cursor row position variable C# \ cursor col position variable INS \ insert flag variable QF \ quit flag variable GF \ graphics flag \ WAIT HI RNG? \ Short pause : WAIT ( -- ) 500 ms ; \ Highest block number : HI ( -- u ) #screens 1- 0 max ; \ Test if block u is within range : RNG? ( u -- u f ) dup 0 #screens within ; \ COPY COPIES \ Copy screen u1 to u2 : COPY ( u1 u2 -- ) swap block swap buffer b/buf cmove update save-buffers ; \ Copy u3 screens from screen u1 to u2 : COPIES ( u1 u2 u3 -- ) ?dup if swap 2 pick - >r over + r@ 0< if swap 1 else 1- -1 then r> 2swap do i 2dup + copy over +loop then 2drop ; \ ?EXTEND EXPAND \ Extend file if block u is not in range : ?EXTEND ( u -- ) rng? if drop else 1+ fileblocks then ; \ Insert blank screen at block u : EXPAND ( u -- ) dup dup 1+ over #screens dup ?extend swap - copies block b/buf blank update ; \ SHRINK \ Delete screen u, copying it to buffer : SHRINK ( u -- ) rng? if pad dup b/buf + b/buf cmove dup 1+ swap over #screens swap - copies #screens 1- dup fileblocks 1- scr @ min scr ! else drop then ; \ !XY @XY CXY UP DN \ Save cursor pos : !XY ( y x -- ) c# ! r# ! ; \ Get cursor pos : @XY ( -- y x ) r# @ c# @ ; \ Restore cursor pos : CXY ( -- ) @xy x + swap y + at-xy ; \ ^E move cursor up one position -? : UP ( -- ) r# @ 0> if -1 r# +! cxy then ; \ ^X move cursor down one position : DN ( -- ) r# @ l/s 1- < if 1 r# +! cxy then ; \ LFT RT HOM TAB \ ^S move cursor left one position : LFT ( -- ) c# @ 0> if -1 c# +! cxy then ; \ ^D move cursor right one position : RT ( -- ) c# @ c/l < if 1 c# +! cxy then ; \ ^Q Move cursor to home position : HOM ( -- ) 0 0 !xy cxy ; \ ^I Move cursor to next tab position : TAB ( -- ) tbs c# @ over mod - 0 do rt loop cxy ; \ SOL NEWL LSTART LEND \ Move cursor to start of current line : SOL ( -- ) 0 c# ! cxy ; \ ^M Move cursor to start of next line : NEWL ( -- ) sol dn ; \ Line start address : LSTART ( -- a ) pad r# @ c/l * + ; \ Line end address : LEND ( -- a ) lstart c/l 1- + ; \ CPOS BLINE LB BELOW BLEFT \ Cursor position address : CPOS ( -- a ) lstart c# @ + ; \ Buffer address : BLINE ( -- a ) b/buf 2* pad + ; \ Line buffer address : LB ( -- a ) bline c/l + ; \ : BELOW ( -- n ) l/s r# @ - c/l * b/buf + ; \ Number of chars from cursor to end-of-line : BLEFT ( -- n ) lend cpos - ; \ BORDER .LINE .LINES \ Draw border : .BORDER ( -- ) x y 1- at-xy c/l 1- 0 do i tbs 2* mod if [char] - else [char] ! then emit loop [char] ! emit 0 y at-xy l/s 0 do i 2 .r cr loop ( cr ." B:") ; \ Display line from cursor position to end : .LINE ( -- ) clear-line cpos bleft 1+ -trailing type cxy ; \ Display all screen lines : .LINES ( -- ) @xy l/s r# @ do i r# ! sol .line loop !xy cxy ; \ .MODE ~INS ~ESC \ Display mode : .MODE ( -- ) 10 0 at-xy gf @ if ." GFX " else ." Norm " then ins @ if ." Ins" else ." Ovr" then ; \ ^V Toggle insert mode : ~INS ( -- ) ins @ not ins ! .mode cxy ; \ ESC Toggle graphic mode : ~ESC ( -- ) gf @ not gf ! .mode cxy ; \ .STAT .LB .BLK .SCR CLS \ Display status line : .STAT ( -- ) 0 0 at-xy ." Scr " scr @ . space 20 0 at-xy loadfile type cxy ; \ Display line buffer : .LB ( -- ) x y l/s + 1+ 0 over at-xy ." B:" at-xy lb c/l type cxy ; \ Display status line and screen lines : .BLK ( -- ) @xy hom .stat .lines !xy cxy ; \ ^B Redraw screen : .SCR ( -- ) page .border .mode .blk .lb ; \ Clear screen : CLS ( -- ) pad b/buf blank .blk ; \ CLB CLL @BLK !BLK RESTORE \ Clear circular buffer : CLB ( -- ) pad b/buf + b/buf c/l + blank ; \ Clear one line buffer : CLL ( -- ) lb c/l blank ; \ Load block : @BLK ( -- ) scr @ block pad b/buf cmove ; \ Save block and update : !BLK ( -- ) pad scr @ buffer b/buf cmove> update ; \ ^L Reload block and display it : RESTORE ( -- ) @blk .scr ; \ +BLK -BLK ?KEY INP \ ^C Go to next block : +BLK ( -- ) scr @ hi < if 1 scr +! restore then ; \ ^R Go to previous block : -BLK ( -- ) scr @ 0> if -1 scr +! restore then ; \ Get key and display if printable : ?KEY ( -- c ) key upcase dup 32 127 within if dup emit then ; \ Get input string 0=empty : INP ( -- a u -1 | 0 ) here dup 20 accept bl skip dup if -1 else and then ; \ CLM CLM2 CLRMSG \ Clear space for msg : CLM ( y-offs -- ) y + l/s + 0 swap at-xy clear-line ; \ Clear space for msg2 : CLM2 ( -- ) 2 clm ; \ Clear space for msgs : CLRMSG ( -- ) clm2 1 clm ; \ FUNC \ ^Z Function select : FUNC ( -- ) clrmsg ." *** SCREEN: (I)nsert, (D)elete " clm2 ." CLEAR: (B)uffer, (S)creen ? " ?key case [char] I of scr @ expand restore endof [char] D of scr @ shrink restore endof [char] B of clb endof [char] S of cls hom endof endcase clrmsg .lb cxy ; \ ?EXIT JMP \ ^U Quit editor : ?EXIT ( -- ) clrmsg ." *** EXIT: (S)ave, (Q)uit ? " ?key case [char] S of update flush qf on endof [char] Q of empty-buffers qf on endof clrmsg .lb cxy endcase ; \ ^J Jump to block : JMP ( -- ) begin clrmsg ." *** JUMP: Screen (0-" hi 0 .r ." )? " inp 0= if clrmsg .lb cxy end number? until drop dup ?extend scr ! clrmsg hom restore ; \ (OPN) OPN TRIM \ Open up line at cursor : (OPN) ( -- ) c# @ c/l < lend c@ bl = and if cpos dup 1+ bleft cmove> bl cpos c! else beep then ; \ ^O Open up line at cursor : OPN ( -- ) (opn) .line ; \ ^T Delete from cursor to end of line -? : TRIM ( -- ) cpos bleft 1+ dup spaces cxy blank ; \ DEL UPD OTYPE \ Delete char at cursor : DEL ( -- ) c# @ c/l < if cpos 1+ cpos bleft cmove bl lend c! .line then ; \ ^K Update and save screen : UPD ( -- ) !blk clrmsg ." *** UPDATED BLOCK: " scr @ . wait clrmsg .lb cxy ; \ Overtype char at cursor : OTYPE ( c -- ) c# @ c/l < if dup emit cpos c! 1 c# +! else drop beep then ; \ INSERT BSP GET \ Insert char at cursor : INSERT ( c -- ) lend c@ bl = if (opn) otype .line else drop beep then ; \ ^H Backspace (delete prev character) : BSP ( -- ) c# @ if lft del then ; \ ^P Copy from one-line buffer : GET ( -- ) lb lstart c/l cmove @xy sol .line !xy cxy ; \ PUT KILL INSL \ ^A Copy line to line buffer : PUT ( -- ) lstart lb c/l cmove .lb ; \ ^Y Kill line, push to circular buffer : KILL ( -- ) lstart bline c/l cmove lstart c/l + lstart below cmove .lines ; \ ^N Insert line from circular buffer : INSL ( -- ) lstart dup c/l + below cmove> bline lstart c/l cmove .lines ; \ SPLIT JOIN \ ^W Split line at cursor : SPLIT ( -- ) cpos dup below bleft + c/l /string cmove> cpos c/l blank .lines ; \ ^F Join line with next : JOIN ( -- ) lstart c/l + 0 c/l 0 do drop count bl - if i leave then i loop >r 1- c/l r> - bleft 1+ min cpos swap cmove .lines ; \ 'CMD create 'CMD ] put ( A save line ) .scr ( B redraw scr ) +blk ( C next blk ) rt ( D right curs ) up ( E up curs ) join ( F join line ) del ( G del char ) bsp ( H destruct bs ) tab ( I tab key ) jmp ( J jump to blk ) upd ( K update ) restore ( L restore blk ) newl ( M cr ) insl ( N insert line ) opn ( O open txt ) get ( P restore line) hom ( Q home curs ) -blk ( R prev block ) lft ( S left curs ) trim ( T delet to EOL) ?exit ( U exit ) ~ins ( V insert toggl) split ( W split line) dn ( X down curs ) kill ( Y kill line ) func ( Z function ) ~esc ( \ graphic ) [ \ INIT CMD !CHR \ Initialisation : INIT ( scr offs -- ) dup 0 b/buf within and \ check offset c/l /mod swap !xy 0 tuck max hi min scr 2! \ check scr clear offset clb cll \ clear buffers ins on gf off \ set mode restore \ load and display scr cxy ; \ position cursor \ Execute command n : CMD ( n -- ) 1- 2* 'cmd + @ execute ; \ Insert character : !CHR ( c -- ) ins @ if insert else otype then ; \ MAPKEY \ Map IBM PC extended keys : KMAP ( c -- c' ) 200 of 5 end \ up arrow 208 of 24 end \ down arrow 205 of 4 end \ right arrow 203 of 19 end \ left arrow 210 of 22 end \ insert 211 of 7 end \ delete 201 of 18 end \ page up 209 of 3 end \ page down 199 of 17 end \ home ( c) ; \ (E) \ Edit screen/offset : (E) ( scr offs -- ) init qf off begin key gf @ if dup 27 = if drop ~esc else !chr then else kmap dup 1 28 within if cmd else dup 32 127 within if !chr else drop beep then then then qf @ until cr ; \ IMPORT EXPORT \ Copy screens n1-n2 from secondary file : IMPORT ( n1 n2 -- ) scr @ -rot 1+ swap ?do dup expand swap-file i block drop swap-file dup buffer drop update flush 1+ dup scr ! loop drop ; \ Copy screens n1-n2 to secondary file : EXPORT ( n1 n2 -- ) swap-file import swap-file ; \ SED forth definitions editor \ Edit screen u or where LOAD error occured -? : SED ( ? -- ) application unused b/buf 2* c/l + u< abort" out of memory" 0 ?extend depth if 0 else scr 2@ swap then (e) ; \ aka SED EDIT behead l/s (e) forth \ No newline at end of file diff --git a/DX-FORTH v430/SED.TXT b/DX-FORTH v430/SED.TXT new file mode 100644 index 0000000..6860885 --- /dev/null +++ b/DX-FORTH v430/SED.TXT @@ -0,0 +1,152 @@ + Full-Screen Editor for DX-FORTH + ------------------------------- + + *** IMPORTANT *** + + After editing a screen, Ctrl-K must be pressed to UPDATE + the changes. This is a safeguard as there is no backup + copy of the source file being editing. Until Ctrl-K is + pressed, the screen may be restored to its previous state + using Ctrl-L. + + +INSTALLATION: + +DX-FORTH for CP/M must be configured for your terminal before +using the full screen editor. See DX-FORTH.TXT for further +details. + + +INVOKING: + +The screen editor is invoked typing SED. If the editor is not +resident it is automatically loaded from the disk file SED.SCR. + +If you mainly use screen files you may want to add EDIT as a +synonym for SED e.g. AKA SED EDIT + +DX (COM or EXE) comes pre-loaded with the screen editor. + + +COMMANDS: + + SED ( n | -- ) + + Enter the full screen editor, selecting screen n for + editing. If no screen number is specified, then the screen + last LISTed is used or, in the case a LOAD error, the screen + and position where the error occured. + + Note: If the screen number is out of range, then the highest + screen available is used. If the size of the screen file + was zero when EDIT was called, it will be extended by one + block. + + L ( -- ) List + + Lists the current screen. The screen number is obtained + from the variable SCR which is set by LIST, EDIT or when a + LOAD error occurs. + + N ( -- ) Next + + Increment the screen number in variable SCR then list it. + + B ( -- ) Back + + Decrement the screen number in variable SCR then list it. + + LS ( -- ) List Swap + + Perform SWAP-FILE and list the screen specified by SCR. + + +EDITOR COMMANDS: + +1. Cursor movement + +Ctrl-E Move cursor up +Ctrl-X Move cursor down +Ctrl-D Move cursor right +Ctrl-S Move cursor left +Ctrl-I Move cursor 4 places to the right (TAB) +Ctrl-Q Move cursor to the upper left of the screen + +2. Editing + +Ctrl-G Delete character to the right of the cursor +Ctrl-H Delete character to the left of the cursor +Ctrl-T Erase all characters to the right of the cursor +Ctrl-O Insert space at the current cursor position +Ctrl-Y Delete the current line. Lines below cursor are moved + up one position. Pop a line from circular buffer into + the bottom line +Ctrl-N Insert blank line. Lines below cursor are moved down + one position. Push bottom line to the circular buffer +Ctrl-W Split the current line at the cursor position +Ctrl-F Join the next line at the cursor position +Ctrl-A Copy the contents of the current line to the one-line + buffer +Ctrl-P Copy the contents of the one-line buffer to the + current line +Ctrl-K Update all changes made to the screen + +3. Miscellaneous + +Ctrl-C Move to the next screen +Ctrl-R Move to the previous screen +Ctrl-J Jump to another screen +Ctrl-B Redraw the screen. Used if the screen has become + garbled e.g. after displaying blocks containing binary + data +Ctrl-L Reload the current file block +Ctrl-V Toggle between insert or overwrite mode +Ctrl-U Exit the editor +Ctrl-Z Multi-function command + S - clear the screen contents + B - clear the circular buffer contents + I - insert a blank screen at the current position + D - delete the current screen copying it to the buffer +ESC Toggle between normal and graphics mode + +4. Utilities + +The following commands are available from the EDITOR vocabulary + + IMPORT ( n1 n2 -- ) + + Copy screens n1 thru n2 from the secondary file inserting + them beginning at screen SCR of the current file. + + EXPORT ( n1 n2 -- ) + + Copy screens n1 thru n2 from the current file inserting + them beginning at screen SCR of the secondary file. + +IMPORT and EXPORT assume two screen files are currently open +and SCR of the target file has been set (SCR may be viewed with +FYI). After the operation, target SCR is set to the last block +written plus 1. + +5. Notes + +In the DOS version of the editor, the arrows keys, PgUp, PgDn, +Home, Insert and Delete keys may be used in addition to the +usual control-key sequences. + +COPY COPIES EXPAND (found in earlier versions of the editor) +are redundant as the ability to insert or delete screens is now +available from Ctrl-Z. + +To extend a screenfile, enter EDIT then jump to the desired +screen number using Ctrl-J. Alternatively, truncating/ +extending a screenfile may also be done from the Forth +environment using FILEBLOCKS. + +A special graphics mode has been added. It is toggled via the +ESC key and allows graphic characters to be entered from the +keyboard. It is intended to allow the insertion of PC symbols +or graphic characters into quoted strings. Refer to +DX-FORTH.TXT for a table of keys and their corresponding codes. +To exit graphics mode, press ESC again. + diff --git a/DX-FORTH v430/SHOW.SCR b/DX-FORTH v430/SHOW.SCR new file mode 100644 index 0000000..eaa6e67 --- /dev/null +++ b/DX-FORTH v430/SHOW.SCR @@ -0,0 +1 @@ +\ Information A utility to print source screens. SHOW and LISTING work the same way as those in DX-Forth but print 6 screens per page. Requires a 132 column printer. \ Load screen - forth definitions decimal sys @ system cr .( loading SHOW LISTING ) 2 #screens 1- thru sys ! \ (scr) (line) \ Substitute screen n with screen 0 if out of range : (scr) ( n -- n | 0 ) dup #screens < and ; \ Return a string containing line n of block : (line) ( blk n -- adr u ) 64 * swap block + 64 ; \ SHOW \ Print screens n1 thru n2 -? : SHOW ( n1 n2 -- ) printer 1+ swap 6 / 6 * do cr ." Page " i 6 / 1+ . 11 out @ - spaces loadfile -path type i 3 + i do cr i dup 3 + (scr) swap (scr) cr 3 spaces dup u. 68 out @ - spaces over u. 16 0 do cr i 2 .r space dup i (line) type space over i (line) -trailing type loop 2drop loop cr page key? if key drop leave then 6 +loop console ; \ LISTING \ Print all screens -? : LISTING ( -- ) 0 #screens 1- show ; behead (scr) (line) \ No newline at end of file diff --git a/DX-FORTH v430/SIEVE.F b/DX-FORTH v430/SIEVE.F new file mode 100644 index 0000000..f15b4cd --- /dev/null +++ b/DX-FORTH v430/SIEVE.F @@ -0,0 +1,17 @@ +8190 CONSTANT SIZE +VARIABLE FLAGS SIZE ALLOT + +: SIEVE + ." primes 10 iterations: " + 10 0 DO + FLAGS SIZE -1 FILL + 0 SIZE 0 DO + I FLAGS + C@ IF + I 2 * 3 + DUP I + BEGIN + DUP SIZE < WHILE + DUP FLAGS + 0 SWAP C! OVER + + REPEAT DROP DROP 1+ + THEN LOOP + LOOP + . ; + diff --git a/DX-FORTH v430/SSED.SCR b/DX-FORTH v430/SSED.SCR new file mode 100644 index 0000000..ea1ca20 --- /dev/null +++ b/DX-FORTH v430/SSED.SCR @@ -0,0 +1 @@ +\ SED Turns DX-Forth screen editor into a stand-alone utility \ Load screen empty forth definitions decimal system checking off forget -TASK [defined] -FP [if] forget -FP [then] checking on 1 fload SED : PROGRAM ( -- ) cmdtail 'source 2! using cr ." Forth Screen Editor" cr ." type CTRL-U to exit " key drop 0 sed close ; turnkey-system program SED bye \ No newline at end of file diff --git a/DX-FORTH v430/STKCHK.SCR b/DX-FORTH v430/STKCHK.SCR new file mode 100644 index 0000000..4ab72e1 --- /dev/null +++ b/DX-FORTH v430/STKCHK.SCR @@ -0,0 +1 @@ +\ Stack Balance Checking Utility Helps locate words which should be stack-neutral but aren't! Use: place [S S] around the words you wish to test for balance e.g. BEGIN [S ... S] AGAIN Use as many [S S] pairs as needed. Should the stack level change at run-time, the application will stop and display the screen number where the offending definition was compiled. Nesting to 16 levels is allowed. CREATE csd 0 C, 16 CELLS ALLOT \ stack depth array : [S ( -- ) DEPTH csd COUNT 1+ 15 AND DUP csd C! CELLS + ! ; : [s] ( blk -- ) DUP SCR ! >R DEPTH csd COUNT DUP 1- csd C! CELLS + @ - IF PAGE ." Stack changed: Scr# = " R@ . CR QUIT THEN R> DROP ; : S] ( -- ) BLK @ POSTPONE LITERAL POSTPONE [s] ; IMMEDIATE \ No newline at end of file diff --git a/DX-FORTH v430/STRINGS.SCR b/DX-FORTH v430/STRINGS.SCR new file mode 100644 index 0000000..cb3a0b2 --- /dev/null +++ b/DX-FORTH v430/STRINGS.SCR @@ -0,0 +1 @@ +\ Information A simple string handling package SPLIT split string at character C+STRING append char to end of string C/STRING extract char from start of string STRING/ return right-most characters S= test two strings for equality S+ concatenate two strings; result in temp buffer These only work with string variables: STRING create string variable (255 chars max) S! store string to string variable \ Strings - Load screen forth definitions decimal application cr .( loading Strings ) 2 #screens 1- thru \ Strings - SPLIT STRING+C C/STRING STRING/ \ Split string at character leaving first on top : SPLIT ( a u char -- a2 u2 a3 u3 ) >r 2dup r> scan 2swap 2 pick - ; \ Append character to end of string : C+STRING ( char a u -- a2 u2 ) 2dup 2r> + c! 2r> 1+ ; \ Extract character from start of string : C/STRING ( a u -- a2 u2 char ) over >r 1 /string r> c@ ; \ Return u right-most characters of string : STRING/ ( a1 u1 u -- a2 u2 ) over umin over swap - /string ; \ Compare two strings for equality : S= ( a1 u1 a2 u2 -- flag ) compare 0= ; \ Strings - S= S+ STRING S! 255 ( buffer size ) -? create SB dup , allot \ Concatenate two strings placing result in temp buffer : S+ ( a1 u1 a2 u2 -- a3 u3 ) 2>r sb @ umin sb cell+ 0 +string sb @ over - 2r> rot min 2swap +string ; behead sb sb \ Define string variable with max length u -? : STRING create ( u -- ) 255 min dup c, 0 c, allot does> ( -- sa su ) 1+ count ; \ Store string a u to string variable : S! ( a u sa su -- ) drop 1- dup >r 1- c@ min r> place ; \ Strings - \ No newline at end of file diff --git a/DX-FORTH v430/TED.F b/DX-FORTH v430/TED.F new file mode 100644 index 0000000..dea94b6 --- /dev/null +++ b/DX-FORTH v430/TED.F @@ -0,0 +1,451 @@ +\ TED.F +\ +\ TED - A Tiny Text Editor for DX-Forth +\ +\ Based on the HT-68K editor by J.Bartel +\ +\ The HELP screen is only compiled for the +\ turnkey version +\ +\ ^E Up cursor ^R Prev page +\ ^X Down cursor ^C Next page +\ ^D Right cursor ^G Del next char +\ ^S Left cursor ^H Del prev char +\ ^L Restore line ^M New line +\ ^T Erase to EOL ^Y Delete line +\ ^U Exit editor ^Z Function +\ ^ZC Clear text ^ZH Help +\ ^ZR Read file ^ZW Write file +\ +\ Revision +\ 2016-09-25 es updated for DX-Forth +\ 2015-06-03 es specify a filename +\ 2015-12-09 es join lines with ^G or DEL +\ 2017-01-25 es replace EXIT THEN with END + +forth definitions decimal + +0 \ true for turnkey + +( *) dup [if] application [then] + +cr .( loading TED Text Editor ) + +\ Running DX-Forth for CP/M or DOS ? +: CPM? ( -- f ) $111 @ $4683 = ; + +[undefined] ZCOUNT [if] + : ZCOUNT ( a -- a u ) dup -1 0 scan drop over - ; +[then] + +[undefined] ZPLACE [if] + : ZPLACE ( a -- a u ) 2dup + >r swap cmove 0 r> c! ; +[then] + +[undefined] PACK [if] + : PACK ( a u a2 -- a2 ) dup >r place r> ; +[then] + +[undefined] TOKEN [if] + : TOKEN ( "name" -- c-addr u ) bl word count ; +[then] + +\ Video terminal specific + +79 value XMAX \ #columns - 1 +24 value YMAX \ #rows - 1 + +\ INSERT-LINE ( -- ) insert blank line at cursor; +\ remaining rows scroll down +\ DELETE-LINE ( -- ) delete line at cursor; +\ remaining rows scroll up +\ CLEAR-LINE ( -- ) blank from cursor to end of line + +\ pointer operations +: 1+! ( a -- ) 1 swap +! ; +: 1-! ( a -- ) -1 swap +! ; +: C@+ ( a -- c ) dup @ c@ swap 1+! ; +: C!+ ( c a -- ) tuck @ c! 1+! ; +: -C@ ( a -- c ) dup 1-! @ c@ ; +: -C! ( c a -- ) dup 1-! @ c! ; + +\ max line length +132 constant COLS + +0 value YBOT \ edit bottom row +0 value BUF \ edit buffer addr +0 value BUFE \ edit buffer end + 1 +0 value TBUF \ text buffer addr +0 value LINES \ line count +0 value MEM \ top of memory +0 value FNAM \ filename buffer addr +0 value FID \ file handle + +variable COL \ current column# +variable LIN \ current line# +variable LADR \ current line addr +variable LTOP \ absolute line# at top of screen +variable LPOS \ current line# relative to top of screen +variable BPOS \ address of char in edit buffer +variable NXT \ next free addr in text (contains 0) +variable UPD \ edit buffer change flag +variable XF \ quit flag + +: UKEY ( -- c ) key upcase ; +: LMAX ( -- n ) lines 1- 0 max ; +: GOXY ( x y -- ) 1+ at-xy ; +: CXY ( -- ) col @ XMAX min lpos @ goxy ; +: MSG ( -- ) 0 0 at-xy clear-line ; +: CHGD ( -- ) upd on ; + +: CONT ( -- ) xf off + ." Press a key to continue " key drop ; + +: .FIL ( -- ) fnam count 20 min type ; + +: .POS ( -- ) + 13 0 at-xy lin @ 1+ u. + 22 0 at-xy col @ 1+ u. cxy ; + +: .HD ( -- ) msg 10 0 at-xy +[ dup ] [if] + ." Ln Cl ^ZH Help File " +[else] + ." Ln Cl File " +[then] + .fil .pos ; + +: .ERR ( a u -- ) msg .fil space space type cont .hd ; + +: SURE? ( a u -- f ) + msg type ." Are you sure? " ukey [char] Y = ; + +: LINE ( -- a u ) ladr @ zcount ; + +: .LINE ( -- ) line XMAX 1+ min type ; + +: .RT ( -- ) \ display string right of cursor + bpos @ bufe over - XMAX 1+ bpos @ buf - - min type ; + +: ROOM? ( -- f ) bufe 1- c@ bl = ; + +: LINE@ ( -- lin adr ) lin @ ladr @ ; +: LINE! ( lin adr -- ) ladr ! lin ! ; + +: GOTOP ( -- ) tbuf ladr ! lin off ; + +: CURTOP ( -- ) + gotop ltop off col off lpos off ; + +\ clear text, filename, reset cursor +: -TXT ( -- ) tbuf dup 1- 3 erase ( nulls ) + 1+ nxt ! 1 to lines 0 fnam c! curtop ; + +: SETUP ( -- ) +[ cpm? ] [if] + $168 c@ 1- to XMAX + $169 c@ 1- dup to YMAX 2- to YBOT +[else] + get-window ( x1 y1 x2 y2 ) + rot - dup to YMAX 2- to YBOT + swap - to XMAX +[then] + application here unused + to mem pad 80 + + dup to fnam 80 + dup to buf COLS + dup to bufe + 2+ dup to tbuf mem u> abort" no space" -txt ; + +: INSC ( c -- ) \ insert char in buf + bpos @ dup 1+ bufe over - 1+ cmove> + bpos c!+ ; + +: LU ( -- ) \ go up one line in text + lin 1-! + ladr dup 1-! begin dup -c@ 0= until 1+! ; + +: LD ( -- ) \ go down one line in text + lin 1+! ladr begin dup c@+ 0= until drop ; + +: SETLIN ( n -- ) \ setup for line n + tbuf over 0 ?do zcount + 1+ loop + ladr ! lin ! ; + +: LINES+ ( -- ) lines 1+ to lines ; +: LINES- ( -- ) lines 1- to lines ; + +: ?MEM ( -- ) + nxt @ mem u< not if s" no space" .err then ; + +: REPL ( a u -- ) \ replace line in text + >r line r@ over - >r + over + dup r@ + nxt @ 1+ dup >r + 2 pick - move 2r> + dup off nxt ! + r> cmove ?mem ; + +: BSTR ( -- a u ) \ string in buffer + buf bufe over - -trailing ; + +: LEAV ( -- ) \ leave the line we are on + upd @ if bstr repl then upd off ; + +: ENTER ( -- ) \ start changes on this line + line buf dup COLS blank swap cmove + buf col @ + bpos ! upd off ; + +: .ALL ( -- ) \ update screen + leav enter + page line@ + ltop @ dup setlin + lmax swap - YBOT min + 1+ 0 ?do 0 i goxy .line ld loop + line! .hd cxy ; + +: SLN ( ltop lin -- ) + >r 0 max lmax min dup r> max lmax min + dup setlin over - lpos ! ltop ! .all ; + +: PU ( -- ) \ ^R page up + lin @ if + leav ltop @ YBOT - lin @ YBOT - sln + then ; + +: PD ( -- ) \ ^C page dn + lin @ lines < if + leav ltop @ YBOT + lin @ YBOT + sln + then ; + +: SU ( -- ) \ scroll up, new line at bottom + 0 0 goxy delete-line 0 YBOT dup lpos ! goxy ; + +: SD ( -- ) \ scroll down, new line at top + 0 0 goxy insert-line lpos off ; + +-? : UP ( -- ) \ ^E line up + lin @ if + leav lu + lin @ ltop @ 1- = if + sd .line ltop 1-! + else + lpos 1-! + then + enter .pos + then ; + +: DN ( -- ) \ ^X line dn + lin @ lines < if + leav ld + lin @ ltop @ YBOT 1+ + = if + su .line ltop 1+! + else + lpos 1+! + then + enter .pos + then ; + +: RT ( -- ) \ ^D right + col @ XMAX < if + col 1+! bpos 1+! .pos + then ; + +: LFT ( -- ) \ ^S left + col @ if + bpos 1-! col 1-! .pos + then ; + +: TAB ( -- ) \ ^I tab + 4 col @ over mod - 0 do rt loop ; + +: NLN ( -- ) \ ^M new line + room? if + 13 insc chgd leav + ladr begin dup c@+ 13 = until 0 over -c! 1+! + lines+ lin 1+! + clear-line col off enter + lpos @ YBOT = if + su ltop 1+! + else + lpos 1+! insert-line cxy + then + .all + then ; + +: DEL ( -- ) \ ^G del next + bpos @ bstr + < if ( del char) + bpos @ dup 1+ swap bufe bl over c! over - 1+ cmove + .rt cxy chgd + else ( join line) + chgd leav line COLS over - >r + + dup 1+ zcount r> min rot zplace .all + then ; + +: BS ( -- ) \ ^H del prev + col @ if lft del then ; + +: DLN ( -- ) \ ^Y del line + lin @ lines < if + ladr @ + ld enter 13 ladr -c! + ladr ! + chgd leav enter + lines- lin 1-! + delete-line + ltop @ YBOT + lines < if + line@ + ltop @ YBOT + setlin 0 YBOT goxy .line + line! + then + .pos + then ; + +: RST ( -- ) \ ^L restore line + 0 lpos @ goxy clear-line .line cxy + enter ; + +: DEOL ( -- ) \ ^T delete to EOL + bufe bpos @ - blank + clear-line cxy chgd ; + +: CHAROK ( c -- ) + dup bl 126 between room? and if + dup insc dup emit col 1+! .rt + .pos chgd + then drop ; + +: CLR ( -- ) \ ^ZC + s" *** Clear text: " sure? if leav -txt then + .all ; + +: GETN ( -- a u ) msg ." Filename: " + pad dup XMAX 10 - accept ; + +: STNAM ( a u -- a u ) + 2dup fnam pack count upper 0 to fid ; + +: CLOSF ( -- ) fid ?dup if close-file drop then ; + +: CLN ( a u -- ) \ ctl chars to spaces + over + swap ?do i c@ bl max i c! loop ; + +: (RD) ( a u -- ) + stnam r/w open-file throw to fid + 0 to lines tbuf dup off dup 1+ nxt ! + ( a) begin + dup COLS 2dup + mem u> throw + fid read-line throw ( a u' f ) + while + 2dup cln + 0 over c! ( null) + 1+ dup nxt ! lines+ + repeat 2drop nxt @ off ; + +: RD ( a u -- ) + s" F" +ext ( append .F extension if none ) + leav ['] (rd) catch if + 2drop s" load/size error" .err -txt + then closf curtop .all ; + +: (WR) ( a u -- ) + stnam r/w create-file throw to fid + tbuf begin ( a) + dup nxt @ u< + while + zcount 2dup fid write-line drop + 1+ + repeat drop ; + +: WR ( a u -- ) + leav ['] (wr) catch if + 2drop s" save error" .err + then closf .all ; + +: ZRD ( -- ) \ ^ZR read file into text buffer + getn rd .hd ; + +: ZWR ( -- ) \ ^ZW write text to file + getn wr .hd ; + +: SAV ( -- ) + fnam count dup 0= if 2drop getn then wr ; + +dup [if] +: HLP ( -- ) \ ^ZH help + leav page 14 spaces ." Help Menu" + cr ." ^E Up cursor ^R Prev page" + cr ." ^X Down cursor ^C Next page" + cr ." ^D Right cursor ^G Del next char" + cr ." ^S Left cursor ^H Del prev char" + cr ." ^L Restore line ^M New line" + cr ." ^T Erase to EOL ^Y Delete line" + cr ." ^U Exit editor ^Z Function" + cr ." ^ZC Clear text ^ZH Help" + cr ." ^ZR Read file ^ZW Write file" + cr cr cont .all ; +[then] + +: FN ( -- ) \ ^Z function +[ dup ] [if] + msg ." *** (R)ead, (W)rite, (C)lear, (H)elp ? " ukey + [char] H of hlp end \ ^ZH help +[else] + msg ." *** (R)ead, (W)rite, (C)lear ? " ukey +[then] + [char] C of clr end \ ^ZC clear + [char] R of zrd end \ ^ZR read + [char] W of zwr end \ ^ZW write + drop .hd ; + +: DONE ( -- ) \ ^U Quit editor + msg ." *** Exit: (S)ave, (Q)uit ? " ukey + [char] Q of xf on end + [char] S of sav xf on end + drop .hd ; + +: KMAP ( c1 -- c2 ) \ map in arrow keys etc +[ cpm? ] [if] + $14F c@ of 5 end $150 c@ of 24 end + $151 c@ of 4 end $152 c@ of 19 end + 127 of 7 end +[else] + 200 of 5 end 208 of 24 end + 205 of 4 end 203 of 19 end + 211 of 7 end + 210 of 22 end 201 of 18 end + 209 of 3 end 199 of 17 end +[then] ; + +: CMD ( -- ) key kmap + 3 of pd ( ^C) end 4 of rt ( ^D) end + 5 of up ( ^E) end 7 of del ( ^G) end + 8 of bs ( ^H) end 9 of tab ( ^I) end + 12 of rst ( ^L) end 13 of nln ( ^M) end + 18 of pu ( ^R) end 19 of lft ( ^S) end + 20 of deol ( ^T) end 21 of done ( ^U) end + 24 of dn ( ^X) end 25 of dln ( ^Y) end + 26 of fn ( ^Z) end + charok ; + +\ Load & edit textfile addr len. If len=0 don't load. +: (TED) ( line addr len -- ) + setup page .hd + ?dup if + rd ( line ) 1- dup 7 - swap sln + else 2drop then + enter xf off begin cmd xf @ until + 0 YMAX at-xy cr cr ; + +( *) [if] + +\ Turnkey version +-? : TED ( -- ) 1 cmdtail (ted) ; turnkey ted ted bye + +[else] + +\ Resident version +-? : TED ( "filename[.F]" -- ) token dup if 1 -rot + else 2drop loadline @ lastfile then (ted) ; + +\ aka TED EDIT + +behead cpm? cmd + +[then] + +forth definitions application + diff --git a/DX-FORTH v430/TED.TXT b/DX-FORTH v430/TED.TXT new file mode 100644 index 0000000..9f21df9 --- /dev/null +++ b/DX-FORTH v430/TED.TXT @@ -0,0 +1,79 @@ + + Text File Editor for DX-FORTH + ----------------------------- + +TED is a resident text file editor. + + +INSTALLATION: + +DX-FORTH for CP/M must be configured for your terminal before +using the text file editor. See DX-FORTH.TXT for further +details. + +Users who prefer working with text files can replace the +resident screen file editor in DX-Forth with TED. To do this +enter the following from the DOS command prompt: + + A:FORTH-F - SYSTEM INCLUDE TED AKA TED EDIT SAVE DX BYE + + +INVOKING: + +The text editor is invoked by typing TED. If the editor is +not resident it is automatically loaded from disk file TED.F + +If you mainly use text files you may want to add EDIT as a +synonym for TED as previously described. + + TED ( "filename[.F]" -- ) + +Load and edit the text file "filename". If no filename is +given use the file specified by LASTFILE and LOADLINE. + +Note: Specifying a filename with TED is only available once +TED has been loaded and the loader stub overwritten. + +A "load/size error" is reported if the file cannot be found, +is write-protected or too large to fit in memory. + +Edits are confined to memory and only written to disk on +exit with ^U (S)ave or when writing to another filename with +^Z (W)rite. + +Lines can be up to 132 characters but only the leftmost are +displayed and directly editable. Tabs are converted to +single spaces. + + +COMMANDS: + +1. Cursor movement + +Ctrl-E Move cursor up +Ctrl-X Move cursor down +Ctrl-D Move cursor right +Ctrl-S Move cursor left +Ctrl-I Move cursor to the next tab stop (TAB) + +2. Editing + +Ctrl-G Delete character to the right of the cursor +Ctrl-H Delete character to the left of the cursor +Ctrl-T Erase all characters to the right of the cursor +Ctrl-Y Delete the current line. Lines below cursor are moved + up one position. +Ctrl-M Insert a blank line at the cursor position + +3. Miscellaneous + +Ctrl-C Move to the next page +Ctrl-R Move to the previous page +Ctrl-L Restore the current line +Ctrl-U Exit the editor +Ctrl-Z Multi-function command + C - clear the text buffer + H - show help screen (if present) + R - read file from disk + W - write file to disk + diff --git a/DX-FORTH v430/TOOLS.SCR b/DX-FORTH v430/TOOLS.SCR new file mode 100644 index 0000000..d74e414 --- /dev/null +++ b/DX-FORTH v430/TOOLS.SCR @@ -0,0 +1 @@ +\ Information These are the default tools loaded when DX-Forth is initially built. Users may change or add to the tools as needed. \ Load block forth definitions decimal system marker -TOOLS cr .( loading Tools ) 2 #screens 1- thru forth definitions decimal application \ Subroutines : l/s ( -- n ) b/buf c/l / ; \ lines/screen : esc? ( -- flag ) \ test key - space resumes key? dup if key bl = if drop key bl <> then then ; : .line ( line blk -- ) block swap c/l * + c/l -trailing type ; \ .S \ Display stack : .S ( ? -- ? ) cr ?stack depth 0 ?do i' i - 1- pick . loop ." r 0 context @ w>name cr begin esc? not and ?dup while dup (name) tuck 2r@ caps search nip nip and ?dup if out @ + 68 > if cr 50 ms then dup .id 2 spaces swap 1+ swap then n>name repeat 2r> 2drop cr . ." words" ; : WORDS: ( "ccc" -- ) token .words ; : WORDS ( -- ) here 0 .words ; behead .words .words \ LDUMP DUMP : h.n ( u n -- ) base @ >r hex <# 0 tuck do # loop #> type r> base ! ; \ Dump u bytes in hex and ascii : LDUMP ( seg offs u -- ) cr 8 spaces 16 0 do over i + 2 spaces 1 h.n loop over + swap ?do cr 50 ms esc? if leave then dup 4 h.n [char] : emit i 4 h.n space 16 0 do dup i j + c@l 2 h.n space loop 16 0 do dup i j + c@l dup 127 bl within if drop [char] . then emit loop 16 +loop drop ; : DUMP ( addr u -- ) cseg -rot ldump ; \ VOCS ORDER \ Show vocabs : VOCS ( -- ) voc-link begin @ ?dup while dup cell- .voc space repeat ; \ Show search order : ORDER ( -- ) context 2@ cr ." context: " .voc cr ." current: " .voc ; : .scr ( -- ) screen? if scr ? loadfile type ." (" #screens 0 u.r ." )" else ." ---" then swap-file ; : .mem ( u1 u2 -- ) swap 5 u.r ." (" 5 u.r ." free)" ; \ .FREE FYI \ Show memory : .FREE ( -- ) sys @ dp 2@ cr ." applic: " $100 - application unused .mem cr ." system: " limit - system unused .mem cr ." heads: " dph @ hlimit over - .mem sys ! ; \ 'For Your Information' : FYI ( -- ) cr ." Dictionary" .free cr ." Wordlist " vocs order cr ." Compile " sys @ if ." SYSTEM" else ." APPLICATION" then cr ." Path" 6 spaces 0 path if 2drop else type then cr ." Scr file " .scr cr 10 spaces .scr ; behead .scr .mem \ INDEX \ Display index line of screens n1 thru n2 : INDEX ( n1 n2 -- ) 1+ swap do cr 50 ms i 3 .r space 0 i .line esc? if leave then loop ; \ QX \ Display 'quick index' starting at screen n : QX ( n -- ) page 60 0 do i 20 /mod 26 * swap at-xy dup #screens u< if dup 3 .r space dup block 2+ 21 type then 1+ loop drop cr ; \ SHOW LISTING \ List screens n1 thru n2 in triads to printer : SHOW ( n1 n2 -- ) printer 1+ swap 3 / 3 * do cr ." Page " i 3 / 1+ . 11 out @ - spaces loadfile -path type i 3 + i do cr i dup #screens u< and list loop cr page esc? if leave then 3 +loop console ; \ List all screens to printer : LISTING ( -- ) 0 #screens 1- 0 max show ; \ DIR \ List disk directory : DIR ( "path\filename" -- ) getfilename >fname 1+ 'DX ! 'CX off $4E doscall doserr? 0= if cr begin out @ c/l > if cr 50 ms then [ $80 30 + ] literal zcount dup >r type 15 r> - spaces $4F doscall doserr? esc? or until then ; \ DELETE RENAME \ Delete disk file : DELETE ( "filename" -- ) getfilename delete-file abort" can't delete file" ; \ Rename disk file : RENAME ( "oldfilename" "newfilename" -- ) getfilename $80 pack count getfilename rename-file abort" can't rename file" ; \\ INCLUDE Load forth text source files INCLUDE ( "filename[.F]" -- ) \ load text file "filename" INCLUDED ( c-addr u -- ) \ load named text file ICLOSE ( -- ) \ close include file LOADLINE ( -- a-addr ) \ line number being loaded \\ ( -- ) \ skip remainder file/screen Text files are automatically closed. If an error occurs only the current file is closed. Use \\ to skip compilation as QUIT will leave files open and cause loading problems. Should the latter occur use ICLOSE or CLOSE-ALL. \ INCLUDE variable LOADLINE ( -- a ) fdb value tfdb : fd ( -- a ) tfdb @ ; : tid ( -- a ) fd cell+ ; : tpos ( -- a ) fd [ 2 cells ] literal + ; : tfnb ( -- a ) fd [ 4 cells ] literal + ; : txt? ( -- flag ) fd @ 0> ; \ text file open? : ICLOSE ( -- ) txt? if tid @ close-file drop fd off then ; : tread ( -- a u flag ) $80 dup #126 tid @ read-line throw >r 2dup over + swap ?do i c@ bl max i c! loop r> ; \ INCLUDE \ is source a text file : tf? ( -- flag ) txt? blk @ 0= and ; : tfill ( -- flag ) tid @ file-position throw tpos 2! tread -rot 'source 2! >in off 1 loadline +! ; : ?line ( -- ) \ reload current line fd @ if tpos 2@ tid @ reposition-file throw tread drop 2drop then ; \ INCLUDE : tload ( fid -- ) tfdb loadline @ 2>r source 2>r >in @ blk @ 2>r fdb to tfdb fd [ 4 cells ] literal erase tid ! lastfile tfnb pack count upper 1 fd ! loadline off begin tfill while blk off interpret repeat iclose 2r> blk ! >in ! 2r> 'source 2! 2r> loadline ! to tfdb ?line ?block ; : INCLUDED ( a u -- ) s" F" +ext r/o open-file abort" can't open file" ['] tload catch dup txt? and if cr tfnb count type ." Line " loadline @ u. iclose then throw ; : INCLUDE ( "filename" ) getfilename included ; \ INCLUDE -? : ( ( "ccc" -- ) tf? if begin [char] ) parse + source + = while tfill 0= until then else postpone ( then ; immediate -? : \\ ( -- ) tf? if begin tfill 0= until else postpone \\ then ; immediate -? : LOADFILE ( -- a u ) tf? if tfnb count else loadfile then ; \ INCLUDE \ new REFILL :noname ( -- flag ) tf? if tfill else [ addr refill @ compile, ] then ; ( xt) \ restore old REFILL if new forgotten :noname [ addr refill @ ] literal is refill ; remember ( xt) is refill behead tfdb txt? behead tread tload \ (* \ Block comment end with '*)' : (* ( "ccc " ) begin token dup if s" *)" compare else 2drop refill then 0= until ; immediate \ Delete headers behead l/s .line behead h.n h.n \ No newline at end of file diff --git a/DX-FORTH v430/TXT2BLK.SCR b/DX-FORTH v430/TXT2BLK.SCR new file mode 100644 index 0000000..a94bf27 --- /dev/null +++ b/DX-FORTH v430/TXT2BLK.SCR @@ -0,0 +1 @@ +\ TXT2BLK - Information Convert ascii text files to forth screens. A minor quirk with this utility is that if a text line is exactly 64 characters then an extra blank line will appear in the screen file. This can be avoided by using the -T option; however lines greater than 64 characters will be truncated. The -1 switch permits writing one line per screen. \ TXT2BLK - Load screen FORTH DEFINITIONS DECIMAL APPLICATION 2 #SCREENS 1- THRU \ compile program TURNKEY MAIN TXT2BLK \ create turnkey application \ TXT2BLK - HELP ARGV GETARG \ Show help : HELP ( -- ) ." Usage: TXT2BLK [-opt] file[.TXT] file[.SCR]" CR ." Convert ASCII text files to Forth screens." CR ." -T truncate lines" CR ." -1 one line per screen" CR ; \ Parse blank delimited argument from commandline. : ARGV ( n -- adr u -1 | 0 ) 0 0 ROT 128 COUNT ROT 0 ?DO 2NIP BL SKIP 2DUP BL SCAN ROT OVER - -ROT LOOP 2DROP DUP IF -1 ELSE AND THEN ; \ Get argument, if none show help and exit : GETARG ( n -- adr u ) ARGV 0= IF HELP ABORT THEN ; \ TXT2BLK - F1 F2 H1 H2 CNT TFLAG 1LINE C/L FERROR \ Filename buffers CREATE F1 80 ALLOT CREATE F2 80 ALLOT \ File handles VARIABLE H1 VARIABLE H2 VARIABLE CNT VARIABLE TFLAG VARIABLE 1LINE 64 VALUE C/L 1024 VALUE B/BUF \ Display filename and exit : FERROR ( adr -- ) COUNT TYPE ABORT ; \ TXT2BLK - CLEAN BLANKBUF GETLN \ Convert tabs or control chars in text to blanks : CLEAN ( -- ) PAD B/BUF OVER + SWAP DO I C@ BL MAX I C! LOOP ; \ Fill text buffer with blanks : BLANKBUF ( -- ) PAD B/BUF BLANK ; \ Read a line : GETLN ( -- flag ) PAD B/BUF + DUP C/L TFLAG @ IF 2* THEN H1 @ READ-LINE ABORT" read error" >R PAD CNT @ + SWAP C/L MIN CMOVE R> ; \ TXT2BLK - PUT COPY-FILE \ Write buffer to output file : PUT ( -- ) CLEAN PAD B/BUF H2 @ WRITE-FILE ABORT" write error: probably out of disk space" BLANKBUF CNT OFF ; \ Copy loop : COPY-FILE ( -- ) BLANKBUF CNT OFF BEGIN GETLN WHILE ( not end of file ) C/L CNT +! CNT @ B/BUF = IF PUT THEN REPEAT CNT @ IF ( buffer not empty ) PUT THEN ; \ TXT2BLK - PARSEOPT \ Get commandline options : PARSEOPT ( -- arg# ) 64 TO C/L TFLAG OFF 1 DUP GETARG S" -1" COMPARE 0= IF B/BUF TO C/L 1+ THEN DUP GETARG S" -T" COMPARE 0= OVER GETARG S" -t" COMPARE 0= OR IF TFLAG ON 1+ THEN ; \ TXT2BLK - OPEN-FILES \ Open source and destination files : OPEN-FILES ( -- ) PARSEOPT DUP GETARG S" TXT" +EXT 2DUP F1 PLACE R/W OPEN-FILE \ open 1st IF ." can't open: " F1 FERROR THEN H1 ! \ save handle 1+ GETARG S" SCR" +EXT 2DUP F2 PLACE 2DUP R/O OPEN-FILE NIP 0= \ create 2nd IF ." file exists: " F2 FERROR THEN R/W CREATE-FILE IF ." can't create: " F2 FERROR THEN H2 ! ; \ save handle \ TXT2BLK - CLOSE-FILES MAIN \ Close source and destination files : CLOSE-FILES ( -- ) H1 @ CLOSE-FILE IF ." error closing: " F1 FERROR THEN H2 @ CLOSE-FILE IF ." error closing: " F2 FERROR THEN ; : MAIN ( -- ) CR ." TXT2BLK" CR OPEN-FILES COPY-FILE CLOSE-FILES ." file copied" CR ; \ No newline at end of file diff --git a/DX-FORTH v430/WHATSNEW.TXT b/DX-FORTH v430/WHATSNEW.TXT new file mode 100644 index 0000000..f40275d --- /dev/null +++ b/DX-FORTH v430/WHATSNEW.TXT @@ -0,0 +1,94 @@ +WHATSNEW.TXT - DX-FORTH for DOS + +Note: only significant changes/fixes are listed. + +! changed + added * fixed - removed + +v4.30 2017-02-11 + ++ I' END BOUNDS +! EXIT made non-immediate +! MISC: Add MJD. Rename D/MOD to SD/REM +- (EXIT) + +v4.20 2016-10-07 + ++ EOL +! QUIT moved to Application +! Rename PARSE$ FREEZE PACKED to /PARSE PROTECT PACK + +v4.10 2016-07-13 + ++ (.) (U.) + +v4.09 2016-05-20 + +! Rename WORDS-LIKE to WORDS: + +v4.08 2016-01-16 + +* File not found error in INCLUDE displays wrong filename + +v4.07 2016-01-07 + ++ TRIM +* WARNING incorrectly disabled by consecutive -? + +v4.06 2015-07-26 + ++ LAST BAL +! CSP extended to 2 cells +- +BAL -BAL +* Turnkey initialization improperly wrote to high memory + +v4.05 2015-05-16 + ++ BINARY -BLANKS LASTFILE ++ Interpret numbers with % prefix as binary ++ TED text file editor +! APPLICATION moved to Application dictionary +- CTOGGLE (see MISC.SCR for alternative) + +v4.04 2015-04-12 + ++ #USER .FREE LS BOLD BRIGHT INVERSE +! ABORT" made state-smart +! Rename FILE? to SCREEN? +! Revised multitasker locals +* Fix ASMTEST to use -ALLOT + +v4.03 2015-01-07 + ++ -ALLOT +! ALLOT may no longer use negative values. See glossary. +! /MS is now DEFERed + +v4.02 2014-09-29 + ++ WAIT-TICK +! . and ? display unsigned when BASE not decimal +* LOCALS.SCR updated to compile with DX4 + +v4.01 2014-07-22 + +* ASM: Fix bug in XCHG which caused subsequent instructions to be + assembled in BYTE mode + +v4.00 2014-07-19 + ++ 2NIP @EXECUTE W>NAME CMDTAIL PARSE$ >FNAME TOKEN WORDS-LIKE CHAIN ++ CTOGGLE PACKED S.R SHOLD NHOLD LREAD LWRITE LINK, S, ?BLOCK ++ FPICK S>F F>S ++ READ-LINE recognizes CP/M EOF terminator ($1A) +! ADDR made state-smart +! OPEN now requires a file-access-method +! Rename >NEXT, FORWARD, BACK to 'NEXT, >MARK,