1 line
56 KiB
Plaintext
1 line
56 KiB
Plaintext
\ 80387 18-digit floating point (common stack) Compile with: FORTH - 1 FLOAD FP87X 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 18-digit floating point, common stack ) blk @ 1+ #screens 1- thru protect cr .( Save to disk? ) y/n [if] save F87X [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 $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 ." <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 |