diff --git a/fenv.asm b/fenv.asm new file mode 100644 index 0000000..f240a25 --- /dev/null +++ b/fenv.asm @@ -0,0 +1,369 @@ + keep obj/fenv + mcopy fenv.macros + case on + +**************************************************************** +* +* Fenv - Floating-point environment access +* +* This code provides routines to query and modify the +* floating-point environment. +* +* Note: This relies on and only works with SANE. +* +**************************************************************** +* +fenv private dummy segment + end + +FE_ALL_EXCEPT gequ $001F + +**************************************************************** +* +* int feclearexcept(int excepts); +* +* Clear floating-point exceptions +* +* Inputs: +* excepts - floating-point exceptions to clear +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +feclearexcept start + + csubroutine (2:excepts),0 + + FGETENV get current environment + phx + + lda excepts + and #FE_ALL_EXCEPT + eor #$FFFF mask off excepts to clear + xba + and 1,S + sta 1,S + FSETENV clear them + + stz excepts + creturn 2:excepts + end + +**************************************************************** +* +* int fegetexceptflag(fexcept_t *flagp, int excepts); +* +* Get floating-point exception flags. +* +* Inputs: +* flagp - pointer to location to store exception flags +* excepts - floating-point exceptions to get +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +fegetexceptflag start + + csubroutine (4:flagp,2:excepts),0 + + FGETENV get current environment + tya + and excepts get desired exceptions + and #FE_ALL_EXCEPT + sta [flagp] store them in *flagp + + stz excepts + creturn 2:excepts + end + +**************************************************************** +* +* int feraiseexcept(int excepts); +* +* Raise floating-point exceptions +* +* Inputs: +* excepts - floating-point exceptions to raise +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +feraiseexcept start + + csubroutine (2:excepts),0 + + lda excepts + and #FE_ALL_EXCEPT + beq done + pha + FSETXCP raise exceptions + +done stz excepts + creturn 2:excepts + end + +**************************************************************** +* +* int fesetexceptflag(fexcept_t *flagp, int excepts); +* +* Set (but do not raise) floating-point exception flags +* +* Inputs: +* flagp - pointer to stored exception flags +* excepts - floating-point exceptions to set +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** + +fesetexceptflag start + + csubroutine (4:flagp,2:excepts),0 + + FGETENV get env with excepts masked off + phx + lda excepts + and #FE_ALL_EXCEPT + eor #$FFFF + xba + and 1,S + sta 1,S + + lda [flagp] set new exceptions + and excepts + and #FE_ALL_EXCEPT + xba + ora 1,S + sta 1,S + FSETENV + + stz excepts + creturn 2:excepts + end + +**************************************************************** +* +* int fetestexcept(int excepts); +* +* Test if floating-point exception flags are set +* +* Inputs: +* excepts - floating-point exceptions to test for +* +* Outputs: +* Bitwise or of exceptions that are set +* +**************************************************************** +* +fetestexcept start + + csubroutine (2:excepts),0 + + FGETENV get exception flags + tya + and excepts mask to just the ones we want + and #FE_ALL_EXCEPT + sta excepts + + creturn 2:excepts + end + +**************************************************************** +* +* int fegetround(void); +* +* Get the current rounding direction +* +* Outputs: +* The current rounding direction +* +**************************************************************** +* +fegetround start + FGETENV get high word of environment + tya + and #$00C0 just rounding direction + rtl + end + +**************************************************************** +* +* int fesetround(int round); +* +* Set the current rounding direction +* +* Inputs: +* round - the rounding direction to set +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +fesetround start + + csubroutine (2:round),0 + + lda round flip words + xba + sta round + and #$3FFF do nothing if not a valid rounding dir + bne done + + FGETENV set the rounding direction + txa + and #$3FFF + ora round + pha + FSETENV + + stz round +done creturn 2:round + end + +**************************************************************** +* +* int fegetenv(fenv_t *envp); +* +* Get the current floating-point environment +* +* Inputs: +* envp - pointer to location to store environment +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +fegetenv start + + csubroutine (4:envp),0 + + FGETENV get the environment + txa + sta [envp] store it in *envp + + stz envp + creturn 2:envp + end + +**************************************************************** +* +* int feholdexcept(fenv_t *envp); +* +* Get environment, then clear status flags and disable halts +* +* Inputs: +* envp - pointer to location to store environment +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +feholdexcept start + + csubroutine (4:envp),0 + + FGETENV get the environment + txa + sta [envp] store it in *envp + + and #$E0E0 clear exception flags and disable halts + pha + FSETENV set the new environment + + stz envp + creturn 2:envp + end + +**************************************************************** +* +* int fesetenv(const fenv_t *envp); +* +* Set the floating-point environment +* +* Inputs: +* envp - pointer to environment to set +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +fesetenv start + + csubroutine (4:envp),0 + + lda [envp] set the environment + pha + FSETENV + + stz envp + creturn 2:envp + end + +**************************************************************** +* +* int feupdateenv(const fenv_t *envp); +* +* Save exceptions, set environment, then re-raise exceptions +* +* Inputs: +* envp - pointer to environment to set +* +* Outputs: +* Returns 0 if successful, non-zero otherwise +* +**************************************************************** +* +feupdateenv start + + csubroutine (4:envp),0 + + lda [envp] set the environment + pha + FPROCEXIT + + stz envp + creturn 2:envp + end + +**************************************************************** +* +* Default floating-point environment +* +**************************************************************** +* +__FE_DFL_ENV start + dc i2'0' + end + +**************************************************************** +* +* int __get_flt_rounds(void); +* +* Get the value of FLT_ROUNDS, accounting for rounding mode +* +* Outputs: +* Current value of FLT_ROUNDS +* +**************************************************************** +* +__get_flt_rounds start + FGETENV + tya get rounding direction in low bits of A + asl a + asl a + xba + inc a convert to values used by FLT_ROUNDS + and #$0003 + rtl + end diff --git a/fenv.macros b/fenv.macros new file mode 100644 index 0000000..aa38744 --- /dev/null +++ b/fenv.macros @@ -0,0 +1,117 @@ + MACRO +&lab csubroutine &parms,&work +&lab anop + aif c:&work,.a + lclc &work +&work setc 0 +.a + gbla &totallen + gbla &worklen +&worklen seta &work +&totallen seta 0 + aif c:&parms=0,.e + lclc &len + lclc &p + lcla &i +&i seta 1 +.b +&p setc &parms(&i) +&len amid &p,2,1 + aif "&len"=":",.c +&len amid &p,1,2 +&p amid &p,4,l:&p-3 + ago .d +.c +&len amid &p,1,1 +&p amid &p,3,l:&p-2 +.d +&p equ &totallen+4+&work +&totallen seta &totallen+&len +&i seta &i+1 + aif &i<=c:&parms,^b +.e + tsc + aif &work=0,.f + sec + sbc #&work + tcs +.f + phd + tcd + mend + MACRO +&lab creturn &r +&lab anop + lclc &len + aif c:&r,.a + lclc &r +&r setc 0 +&len setc 0 + ago .h +.a +&len amid &r,2,1 + aif "&len"=":",.b +&len amid &r,1,2 +&r amid &r,4,l:&r-3 + ago .c +.b +&len amid &r,1,1 +&r amid &r,3,l:&r-2 +.c + aif &len<>2,.d + ldy &r + ago .h +.d + aif &len<>4,.e + ldx &r+2 + ldy &r + ago .h +.e + aif &len<>10,.g + ldy #&r + ldx #^&r + ago .h +.g + mnote 'Not a valid return length',16 + mexit +.h + aif &totallen=0,.i + lda &worklen+2 + sta &worklen+&totallen+2 + lda &worklen+1 + sta &worklen+&totallen+1 +.i + pld + tsc + clc + adc #&worklen+&totallen + tcs + aif &len=0,.j + tya +.j + rtl + mend + MACRO +&LAB FGETENV +&LAB PEA $03 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSETENV +&LAB PEA $01 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSETXCP +&LAB PEA $15 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FPROCEXIT +&LAB PEA $19 + LDX #$090A + JSL $E10000 + MEND diff --git a/make b/make index 1676424..31f523e 100644 --- a/make +++ b/make @@ -19,7 +19,7 @@ if {#} == 0 unset exit end - for i in cc ctype string stdlib time setjmp orca fcntl vars toolglue signal int64 + for i in cc ctype string stdlib time setjmp orca fcntl vars toolglue signal int64 fenv Newer obj/{i}.a {i}.asm if {Status} != 0 set exit on @@ -39,7 +39,7 @@ echo delete orcalib delete orcalib set list vars.a assert.a cc.a setjmp.a ctype.a string.a stdlib.a -set list {list} time.a signal.a toolglue.a orca.a fcntl.a stdio.a int64.a +set list {list} time.a signal.a toolglue.a orca.a fcntl.a stdio.a int64.a fenv.a for i in {list} echo makelib orcalib +obj/{i} makelib orcalib +obj/{i}