Category : Forth Source Code
Archive   : VPSFP102.ZIP
Filename : FPNUMBER.SEQ

 
Output of file : FPNUMBER.SEQ contained in archive : VPSFP102.ZIP
\ FILE: FPNUMBER.SEQ Support for floating point number I/O
\ VP-Planner floating point for F-PC.

/*
Kent Brothers and Stephenson Software Ltd. are making these floating
point routines available to the Forth language community to further the
growth of Forth as an application development language. It is licensed
for incorporation into programs (with or without modifications) with no
fee as long as the following notice is displayed on screen and in the
documentation:

VP-Planner floating point routines copyright 1985-1989
Kent Brothers, Stephenson Software Ltd.

The source code may be distributed free of charge provided this entire
message (including the notice) is left at the top.
*/


CR .( Loading FPNUMBER.SEQ ... )

\ JWB 890331 Converted some VP floating point I/O support for F-PC
\ JWB 890404 Added code versions of # Q# etc for speed
\ JWB 900420 Fixed bug in F-PC version of NHOLD this fixes Smiley's
\ FLOATS 0.0 E. BUG. which crashes system.

FORTH DEFINITIONS HEX
\ Scan forward from string at adr len for first occurance of char.
CODE CSCAN ( adr len char -- adr' true : if found )
( false : not found )
MOV DX, ES
MOV AX, CS
MOV ES, AX
POP AX
POP CX
POP DI
REPNE
SCASB
JE 1 $
XOR BX, BX
JMP 2 $
1 $: DEC DI
PUSH DI
MOV BX, # FFFF
2 $: MOV ES, DX
PUSH BX
NEXT
END-CODE

\ Scan string, adr len, backwards for first occurance of not char.
CODE - ( adr len char -- adr' true : if character not equal to char found )
( false : if all characters equal to char )
MOV DX, ES
MOV AX, CS
MOV ES, AX
POP AX
POP CX
POP DI
ADD DI, CX
DEC DI
STD
REPE
SCASB
CLD
JNE 1 $ \ found
XOR BX, BX
JMP 2 $
1 $: INC DI
PUSH DI
MOV BX, # FFFF
2 $: MOV ES, DX
PUSH BX
NEXT
END-CODE


CODE DBL0 ( -- 0 0 )
XOR BX, BX
PUSH BX
PUSH BX
NEXT
END-CODE


/* VP-Planner definition.
VARIABLE (#) -2 ALLOT ASSEMBLER FRCLR RESET ( KMB 85 07 07 )
( AX: DL BX: DH CX: counter SI: BASE DI: HLD )
DX, DX XOR AX, BX XCHG SI DIV AX, BX XCHG SI DIV
1$: DL, # 30 ADD DL, # 3A CMP 2$ JL ( convert to numeric digit )
DL, # 7 ADD ( convert to upper-case letter )
2$: DI DEC CS: [DI], DL MOV RET ( store digit )
*/

HEADERLESS

LABEL (#) ( JWB 890404 )
\ Input register contents: AX: DL BX: DH CX: counter SI: BASE DI: HLD
XOR DX, DX
XCHG AX, BX
DIV SI
XCHG AX, BX
DIV SI
ADD DL, # 30
CMP DL, # 3A
JL 1 $ ( convert to numeric digit )
ADD DL, # 7 ( convert to upper-case letter )
1 $: DEC DI
MOV CS: 0 [DI], DL
RET ( store digit )
END-CODE

/* VP-Planner definition.
VARIABLE (Q#) -2 ALLOT ASSEMBLER RESET ( KMB 85 06 13 )
( AX: Q2 BX: Q3 CX: Q1 SI: BASE DI: HLD BP: Q0 )
DX, DX XOR
AX, BX XCHG SI DIV AX, BX XCHG SI DIV
AX, CX XCHG SI DIV AX, BP XCHG SI DIV
AX, BP XCHG AX, CX XCHG 1$ JMP
*/

LABEL (Q#) ( JWB 89 04 04 )
\ Input registers: AX: Q2 BX: Q3 CX: Q1 SI: BASE DI: HLD BP: Q0
XOR DX, DX
XCHG AX, BX
DIV SI
XCHG AX, BX
DIV SI
XCHG AX, CX
DIV SI
XCHG AX, BP
DIV SI
XCHG AX, BP
XCHG AX, CX
ADD DL, # 30
CMP DL, # 3A
JL 1 $ ( convert to numeric digit )
ADD DL, # 7 ( convert to upper-case letter )
1 $: DEC DI
MOV CS: 0 [DI], DL
RET ( store digit )
END-CODE
HEADERS

/* VP-Planner definition
CODE # ( D1 --- D2 ) ( KMB 85 07 07 )
AX POP
SI PUSH SI, CS: ' BASE 3+ MOV SI, CS: [SI] MOV
DI PUSH DI, CS: ' HLD 3+ MOV DI, CS: [DI] MOV
(#) CALL SI, CS: ' HLD 3+ MOV CS: [SI], DI MOV
DI POP SI POP AX PUSH NEXT END-CODE
*/

CODE # ( D1 --- D2 ) ( KMB 85 07 07 ) ( JWB 89 04 04 )
POP BX
POP AX
PUSH SI
MOV CS: SI, UP
MOV CS: SI, ' BASE 3 + @ [SI]
MOV CS: DI, UP
MOV CS: DI, ' HLD 3 + @ [DI]
CALL (#)
MOV CS: SI, UP
MOV CS: ' HLD 3 + @ [SI], DI
POP SI
PUSH AX
PUSH BX
NEXT
END-CODE


/* VP-Planner definition
CODE N#S ( D1 N --- D2 ) ( KMB 85 07 07 )
CX, BX MOV BX POP 2$ JCXZ
AX POP
SI PUSH SI, CS: ' BASE 3+ MOV SI, CS: [SI] MOV
DI PUSH DI, CS: ' HLD 3+ MOV DI, CS: [DI] MOV
1$: (#) CALL 1$ LOOP SI, CS: ' HLD 3+ MOV CS: [SI], DI MOV
DI POP SI POP AX PUSH
2$: NEXT END-CODE
*/

CODE N#S ( D1 N --- D2 ) ( KMB 85 07 07 ) ( JWB 89 04 04 )
POP CX
POP BX
JCXZ 2 $
POP AX
PUSH SI
MOV CS: SI, UP
MOV CS: SI, ' BASE 3 + @ [SI]
MOV CS: DI, UP
MOV CS: DI, ' HLD 3 + @ [DI]
1 $: CALL (#)
LOOP 1 $
MOV CS: SI, UP
MOV CS: ' HLD 3 + @ [SI], DI
POP SI
PUSH AX
2 $: PUSH BX
NEXT
END-CODE

/* VP-Planner definition
CODE #S ( D1 --- 0 0 ) ( KMB 85 07 07 )
AX POP
SI PUSH SI, CS: ' BASE 3+ MOV SI, CS: [SI] MOV
DI PUSH DI, CS: ' HLD 3+ MOV DI, CS: [DI] MOV
1$: (#) CALL DX, AX MOV DX, BX OR 1$ JNZ
SI, CS: ' HLD 3+ MOV CS: [SI], DI MOV
DI POP SI POP AX PUSH NEXT END-CODE
*/

CODE #S ( D1 --- 0 0 ) ( KMB 85 07 07 ) ( JWB 89 04 04 )
POP BX
POP AX
PUSH SI
MOV CS: SI, UP
MOV CS: SI, ' BASE 3 + @ [SI]
MOV CS: DI, UP
MOV CS: DI, ' HLD 3 + @ [DI]
1 $: CALL (#)
MOV DX, AX
OR DX, BX
JNZ 1 $
MOV CS: SI, UP
MOV CS: ' HLD 3 + @ [SI], DI
POP SI
PUSH AX
PUSH BX
NEXT
END-CODE


/* VP-Planner definition
CODE Q# ( Q1 --- Q2 ) ( KMB 85 07 30 )
AX POP CX POP DX POP BP PUSH BP, DX MOV
SI PUSH SI, CS: ' BASE 3+ MOV SI, CS: [SI] MOV
DI PUSH DI, CS: ' HLD 3+ MOV DI, CS: [DI] MOV
(Q#) CALL SI, CS: ' HLD 3+ MOV CS: [SI], DI MOV
DI POP SI POP DX POP
BP PUSH BP, DX MOV CX PUSH AX PUSH NEXT END-CODE
*/

CODE Q# ( Q1 --- Q2 ) ( KMB 85 07 30 ) ( JWB 89 04 04 )
POP BX
POP AX
POP CX
POP DX
PUSH BP
MOV BP, DX
PUSH SI
MOV CS: SI, UP
MOV CS: SI, ' BASE 3 + @ [SI]
MOV CS: DI, UP
MOV CS: DI, ' HLD 3 + @ [DI]
CALL (Q#)
MOV CS: SI, UP
MOV CS: ' HLD 3 + @ [SI], DI
POP SI
POP DX
PUSH BP
MOV BP, DX
PUSH CX
PUSH AX
PUSH BX
NEXT
END-CODE


/* VP-Planner definition
CODE Q#S ( Q1 --- 0 0 ) ( KMB 85 07 07 )
AX POP CX POP DX POP BP PUSH BP, DX MOV
SI PUSH SI, CS: ' BASE 3+ MOV SI, CS: [SI] MOV
DI PUSH DI, CS: ' HLD 3+ MOV DI, CS: [DI] MOV
1$: (Q#) CALL DX, BP MOV DX, AX OR DX, BX OR DX, CX OR 1$ JNZ
SI, CS: ' HLD 3+ MOV CS: [SI], DI MOV
DI POP SI POP BP POP AX PUSH NEXT END-CODE
*/

CODE Q#S ( Q1 --- 0 0 0 0 ) ( KMB 85 07 07 ) ( JWB 89 04 04 )
POP BX
POP AX
POP CX
POP DX
PUSH BP
MOV BP, DX
PUSH SI
MOV CS: SI, UP
MOV CS: SI, ' BASE 3 + @ [SI]
MOV CS: DI, UP
MOV CS: DI, ' HLD 3 + @ [DI]
1 $: CALL (Q#)
MOV DX, BP
OR DX, AX
OR DX, BX
OR DX, CX
JNZ 1 $
MOV CS: SI, UP
MOV CS: ' HLD 3 + @ [SI], DI
POP SI
POP BP
PUSH DX
PUSH CX
PUSH AX
PUSH BX
NEXT
END-CODE


/* VP-Planner definition
CODE HOLD ( C --- ) ( KMB 85 07 07 )
AX, BX MOV BX, CS: ' HLD 3+ MOV WORD CS: [BX] DEC BX, CS: [BX] MOV
BYTE CS: [BX], AL MOV BX POP NEXT END-CODE
*/

CODE HOLD ( C --- ) ( KMB 85 07 07 ) ( JWB 89 04 04 )
POP AX
MOV CS: BX, UP
DEC CS: ' HLD 3 + @ [BX] WORD
MOV CS: BX, ' HLD 3 + @ [BX]
MOV CS: 0 [BX], AL
NEXT
END-CODE


/* VP-Planner definition
CODE NHOLD ( N C --- ) ( KMB 85 07 07 )
AX, BX MOV CX POP DX, CS MOV ES, DX MOV
DX, DI MOV BX, CS: ' HLD 3+ MOV DI, CS: [BX] MOV DI DEC
STD REP BYTE STOS CLD
DI INC CS: [BX], DI MOV DI, DX MOV BX POP NEXT END-CODE
*/

\ Apparently NHOLD is only used in the definition of (E.)
\ to move a string of zeros to pad if the mantissa is 0.0 !!
\ No doubt it is used elsewere in vpplanner and hence it is
\ a CODEd defintion.

CODE NHOLD ( N C --- ) ( KMB 85 07 07 ) ( JWB 90 04 20 )
POP AX
POP CX
MOV DX, ES
MOV BX, CS
MOV ES, BX
MOV CS: BX, UP
MOV CS: DI, ' HLD 3 + @ [BX]
DEC DI
STD
REP
STOSB
CLD
INC DI
MOV CS: ' HLD 3 + @ [BX], DI
MOV ES, DX
NEXT
END-CODE

\ Drop n single number from the parameter stack.
CODE NDROP ( n -- ) ( JWB 89 04 04 )
POP BX
ADD BX, BX
ADD SP, BX
NEXT
END-CODE


: "HOLD ( adr len -- ) ( KMB 85 06 17 )
DUP NEGATE HLD +!
HLD @ SWAP CMOVE ;


\ Leave false flag if DPL still initialized.
: FDOUBLE? ( -- flag )
DPL @ 8000 - \ DPL was initialized to 8000
0<> ; \ true flag if any thing else.

\ Accumulate string at adr1 into double number d1 and leave as d2.
: FCONVERT ( +d1 adr1 -- +d2 adr2 )
BEGIN 1+ dup>r C@ BASE @ DIGIT
WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+
FDOUBLE? IF DPL INCR THEN R>
REPEAT DROP R> ;


VARIABLE DNUM 2 ALLOT VARIABLE INVADDR

\ The address of first invalid character is left in the VARIABLE INVADDR
\ If the string is a number, then INVADDR contains A+L
\ If the string is not a valid number, the value of the number up to the first
\ invalid digit is stored in the double VARIABLE DNUM, with exponent in DPL

: FNUMBER? ( addr --- dn true : if a number ) ( KMB 85 01 17 )
( --- 0 0 false: otherwise )
COUNT \ JWB 890331 changed stack input from addr len to addr.
OVER + DUP C@ >R >R
BL R@ C! ( blank at end of string: A / A+L C[A+L] )
DBL0 ROT DUP
C@ ASCII - = DUP >R
IF 1+ THEN ( 0 0 A1 / sgn[D] ... )
8000 DPL ! 1- ( JWB)
FCONVERT DUP C@ ASCII . = ( |D| A2 F1 / sgn[D] ... )
IF DPL OFF ( 1+ JWB ) FCONVERT
THEN DUP C@ ASCII E = ( |D| A3 F2 / sgn[D] ... )
IF DPL @ 0 MAX >R 1+ DUP C@ ( |D| A4 C / DPL sgn[D] ... )
CASE
ASCII + OF 1+ 0 ENDOF
ASCII - OF 1+ 1 ENDOF
DUP OF 0 ENDOF
DROP \ Added for F-PC case statement.
ENDCASE
>R DUP C@ BL = ( |D| A5 F4 / sgn[E] DPL sgn[D] ... )
IF 1- R> R> 2DROP ( |D| A5 / sgn[D] ... )
ELSE DBL0 ROT
1- ( JWB) FCONVERT ( |D| DE A6 / sgn[E] DPL sgn[D] ... )
NIP SWAP R> 0=
IF NEGATE THEN
R> + DPL ! ( |D| A6 / sgn[D] ... )
THEN
THEN ( |D| A7 / sgn[D] A+L C[A+L] )
INVADDR !
R> IF DNEGATE THEN
R@ INVADDR @ = DUP NOT ( D F ~F / A+L C[A+L] )
IF ( invalid number )
-ROT 2DUP DNUM 2! ROT ( 0 / A+L C[A+L] )
THEN R> R> SWAP C! ;


: (FNUMBER) ( adr -- d )
FNUMBER? NOT ?MISSING ;


DECIMAL
BEHEAD


  3 Responses to “Category : Forth Source Code
Archive   : VPSFP102.ZIP
Filename : FPNUMBER.SEQ

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/