1 line
56 KiB
Plaintext
1 line
56 KiB
Plaintext
\ 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 ." <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 |