1 line
56 KiB
Plaintext
1 line
56 KiB
Plaintext
\ 80387 7-digit floating point (common stack) Compile with: FORTH - 1 FLOAD FP87S 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 7-digit floating point, common stack ) blk @ 1+ #screens 1- thru protect cr .( Save to disk? ) y/n [if] save F87S [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 $0000 or cw! ) ; \ FLOATS FLOAT+ FALIGN FALIGNED FDEPTH code FLOATS ( x1 -- x2 ) ax pop 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 aka 2@ F@ ( addr -- r ) aka 2! F! ( r addr -- ) aka 2drop FDROP ( r -- ) \ 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 aka 2dup FDUP ( r -- r r ) aka 2swap FSWAP ( r1 r2 -- r2 r1 ) \ FOVER FROT aka 2over FOVER ( r1 r2 -- r1 r2 r1 ) aka 2rot FROT ( r1 r2 r3 -- r2 r3 r1 ) \ 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 dword 0 [di+bp] fld 1 floats # bp sub dword 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 dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fadd dword 0 [bp] fstp wait sp bp xchg next end-code code F- ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fsubr dword 0 [bp] fstp wait sp bp xchg next end-code \ F* F/ code F* ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fmul dword 0 [bp] fstp wait sp bp xchg next end-code code F/ ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fdivr dword 0 [bp] fstp wait sp bp xchg next end-code \ FSQRT FNEGATE FABS code FSQRT ( r1 -- r2 ) sp di mov dword 0 [di] fld fsqrt dword 0 [di] fstp wait next end-code code FNEGATE ( r1 -- r2 ) sp di mov dword 0 [di] fld fchs dword 0 [di] fstp wait next end-code code FABS ( r1 -- r2 ) sp di mov dword 0 [di] fld fabs dword 0 [di] fstp wait next end-code \ F0> F0< F0= label ztst sp di mov dword 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 dword 1 floats [di] fld dword 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 dword 0 [di] fld frndint dword 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 dword 2 [bx] fld frndint dword 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 dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fld fprem dword 0 [bp] fstp wait sp bp xchg next end-code code FREM ( r1 r2 -- r3 ) \ IEEE remainder sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fld fprem1 dword 0 [bp] fstp wait sp bp xchg next end-code \ FLN FLOG code FLN ( r1 -- r2 ) sp bx mov dword 0 [bx] fld fldln2 st(1) fxch fyl2x dword 0 [bx] fstp wait next end-code code FLOG ( r1 -- r2 ) sp bx mov dword 0 [bx] fld fldlg2 st(1) fxch fyl2x dword 0 [bx] fstp wait next end-code \ FEXP FALOG F** label power sp bx mov dword 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 dword 0 [bp] fstp st(1) fsubp fld1 fchs st(1) fxch fscale st(1) fstp f2xm1 fld1 st(1) faddp st(0) st fmul dword 0 [bp] fld st(1) fxch fscale st(1) fstp 1 floats # bp add dword 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 dword 0 [di] fstp wait next end-code code F>D ( r -- d ) 0C # al mov frnd ) call sp di mov dword 0 [di] fld dword 0 [di] fistp wait ' swap ) jmp 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 dword 0 [di] fstp wait next end-code code F>S ( r -- n ) 0C # al mov frnd ) call sp di mov dword 0 [di] fld dword 0 [di] fistp wait ' nip ) jmp end-code \ SF@ SF! aka F@ SF@ ( addr -- r ) aka F! SF! ( r addr -- ) \ DF@ DF! code DF@ ( addr -- r ) di pop qword 0 [di] fld 1 floats # sp sub sp di mov dword 0 [di] fstp wait next end-code code DF! ( r addr -- ) bx pop sp di mov dword 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 dword 0 [di] fld fsin dword 0 [di] fstp wait next end-code code FCOS ( r1 -- r2 ) sp di mov dword 0 [di] fld fcos dword 0 [di] fstp wait next end-code code FTAN ( r1 -- r2 ) sp di mov dword 0 [di] fld fptan st(0) fstp dword 0 [di] fstp wait next end-code \ FATAN2 FATAN code FATAN2 ( r1 r2 -- r3 ) sp bp xchg dword 0 [bp] fld 1 floats # bp add dword 0 [bp] fld st(1) fxch fpatan dword 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 7EFF FFFF fconstant rmax 4049 0FDB fconstant PI 7F80 0000 fconstant +INF FF80 0000 fconstant -INF 7FC0 0000 fconstant +NAN FFC0 0000 fconstant -NAN decimal \ FSIGNBIT SIGNED-ZERO FSIGN \ test sign using IEEE sign bit code FSIGNBIT ( r -- sign ) sp di mov dword 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 dword 0 [di] fld fxam ax fstsw st(0) fstp $45 # ah and $04 # ah cmp 1 $ jnz $01FE # 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 #7 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 7-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 cw@ cw! 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 |