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

\ FILE: FPTOOL.SEQ
\ 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 FPTOOL.SEQ ... )
HEX

VARIABLE MA 2 ALLOT

: HM. ( seg adr -- )
MA 2! BASE @ >R HEX
<#
0A 0 DO MA 2@ I + @L 0 # # # #
2DROP ASCII . HOLD
2 +LOOP
MA 2@ 8 + @L 8000 AND
IF ASCII - ELSE ASCII + THEN HOLD
ASCII : HOLD
MA 2@ 8 + @L 7FFF AND BIAS - DUP >R ABS 0 # # # # 2DROP
R> 0< IF ASCII - ELSE ASCII + THEN HOLD
0 0 #> TYPE SPACE R> BASE ! ;


: .FS ( -- )
FDEPTH DUP 0>
IF
CR ." TRUE BIASED"
CR ." EXP : EXP | 64 - BIT MANTISSA | DECIMAL REPRESENTATION"
0 DO CR ?CS: F0 @ I 1+ FPSIZE * - HM.
FDEPTH I - 1- FPICK FSIGN 0>
IF SPACE THEN ..
LOOP ." <<== TOP OF FP STACK"
ELSE CR ." FP stack depth = " . THEN ;

comment:
: .SS ( -- )
DEPTH ?DUP IF
0 ?DO DEPTH I - 1- PICK
( DEPTH I - 2- PICK )
. ( D. 8 EMIT ASCII . EMIT )
( 2 +) LOOP
ELSE ." Empty" THEN ;
comment;

DECIMAL

: .FF ( F: --- )( JWB 860202 )( DJL 880106 )
FDEPTH ?DUP
IF DUP 0>
IF 0 SWAP 1-
DO I FPICK FDUP 8 (..) ?DUP 0=
IF DROP ?NONAN1 IF 6 (E.) ELSE (.NAN) THEN
ELSE FDROP
THEN TYPE SPACE
#OUT @ 72 > IF CR THEN
-1
+LOOP
ELSE ." Depth=" .
THEN
ELSE ." Empty "
THEN ;

: .STACKS .SS ASCII | EMIT .FF ;


\ ALSO BUG
\ ' .STACKS IS DBG.S
\ PREVIOUS

DECIMAL

/* Primitive compile crash debugger.
VARIABLE LINECOUNTER LINECOUNTER OFF

: \ 1 LINECOUNTER +! LINECOUNTER @ CR .
ASCII : EMIT .STACKS [COMPILE] \ ; IMMEDIATE

*/