Add an implementation of <fenv.h> to ORCALib.
This commit is contained in:
parent
7e95f8b182
commit
0685ce71ca
|
@ -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
|
|
@ -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
|
4
make
4
make
|
@ -19,7 +19,7 @@ if {#} == 0
|
||||||
unset exit
|
unset exit
|
||||||
end
|
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
|
Newer obj/{i}.a {i}.asm
|
||||||
if {Status} != 0
|
if {Status} != 0
|
||||||
set exit on
|
set exit on
|
||||||
|
@ -39,7 +39,7 @@ echo delete orcalib
|
||||||
delete orcalib
|
delete orcalib
|
||||||
|
|
||||||
set list vars.a assert.a cc.a setjmp.a ctype.a string.a stdlib.a
|
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}
|
for i in {list}
|
||||||
echo makelib orcalib +obj/{i}
|
echo makelib orcalib +obj/{i}
|
||||||
makelib orcalib +obj/{i}
|
makelib orcalib +obj/{i}
|
||||||
|
|
Loading…
Reference in New Issue