1 line
57 KiB
Plaintext
1 line
57 KiB
Plaintext
\ 80387 15-digit floating point (separate stack) Compile with: FORTH - 1 FLOAD FP87DS 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, separate stack ) blk @ 1+ #screens 1- thru protect cr .( Save to disk? ) y/n [if] save F87DS [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 ) 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 ." <f-stack " then ; application \ Finalize \ Add to prunes :noname \ unlink floating-point ['] noop [ sys-vec #10 + @ ] literal ! \ INIT ['] noop [ sys-vec #12 + @ ] literal ! \ IDENTIFY ['] false [ sys-vec #14 + @ ] literal ! \ FNUMBER [ sys-vec #16 + ] literal off \ fp-stack size [ sys-vec #20 + ] literal off \ fp-stack min ; remember \ Discard heads behead flit flit behead ztst ztst behead tst tst behead frnd frnd behead setr setr behead power power behead rmax rmax behead nan? fpin behead fnumber normalize behead fpinit fident |