diff --git a/math2.asm b/math2.asm index 61b8646..cca4a1d 100644 --- a/math2.asm +++ b/math2.asm @@ -882,6 +882,86 @@ ret creturn 4:x return it rtl end +**************************************************************** +* +* long lround(double x); +* +* Rounds x to the nearest integer, rounding halfway cases +* away from 0, and returns it as a long (if representable). +* +**************************************************************** +* +lround start +lroundf entry +lroundl entry +result equ 1 result value + + csubroutine (10:x),4 + + phb + phk + plb + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + tdc round to integer with default rounding + clc + adc #x + pea 0 + pha + adc #result-x + pea 0 + pha + FX2L + + pea INEXACT + FTESTXCP if there was no inexact exception + beq ret we are done: x was an integer/nan/inf + + FGETENV + txa + ora #TOWARDZERO*$4000 set rounding direction to "toward zero" + pha + FSETENV + + lda x+8 + pha save sign of x + ora #$8000 + sta x+8 x = -abs(x) + + ph4 #onehalf x = x - 0.5 (rounded toward 0) + tdc + clc + adc #x + pea 0 + pha + FSUBS + tdc round to integer + clc + adc #x + pea 0 + pha + adc #result-x + pea 0 + pha + FX2L + + pla if x was positive + bmi ret + sub4 #0,result,result negate result + +ret FPROCEXIT restore env & raise any new exceptions + plb + creturn 4:result return the result + +onehalf dc f'0.5' + end + **************************************************************** * * float modff(float x, float *iptr); diff --git a/math2.macros b/math2.macros index 5d79de2..5035dbe 100644 --- a/math2.macros +++ b/math2.macros @@ -281,6 +281,82 @@ bne ~&SYSCNT inc 2+&a ~&SYSCNT ~restm + mend + macro +&l sub4 &m1,&m2,&m3 + lclb &yistwo + lclc &c +&l ~setm + aif c:&m3,.a +&c amid "&m2",1,1 + aif "&c"<>"#",.a +&c amid "&m1",1,1 + aif "&c"="{",.a + aif "&c"="[",.a +&c amid "&m2",2,l:&m2-1 + aif &c>=65536,.a + sec + ~lda &m1 + ~op sbc,&m2 + ~sta &m1 + bcs ~&SYSCNT + ~op.h dec,&m1 +~&SYSCNT anop + ago .c +.a + aif c:&m3,.b + lclc &m3 +&m3 setc &m1 +.b + sec + ~lda &m1 + ~op sbc,&m2 + ~sta &m3 + ~lda.h &m1 + ~op.h sbc,&m2 + ~sta.h &m3 +.c + ~restm + mend + macro +&l ~sta &op + lclc &c +&c amid "&op",1,1 + aif "&c"<>"{",.b +&c amid "&op",l:&op,1 + aif "&c"="}",.a + mnote "Missing closing '}'",2 +&op setc &op} +.a +&op amid "&op",2,l:&op-2 +&op setc (&op) +.b +&l sta &op + mend + macro +&l ~sta.h &op +&l anop + lclc &c +&c amid "&op",1,1 + aif "&c"="[",.b + aif "&c"<>"{",.d +&c amid "&op",l:&op,1 + aif "&c"="}",.a + mnote "Missing closing '}'",2 +&op setc &op} +.a +&op amid "&op",2,l:&op-2 +&op setc (&op) +.b + aif &yistwo,.c +&yistwo setb 1 + ldy #2 +.c +&op setc "&op,y" + sta &op + mexit +.d + sta 2+&op mend MACRO &LAB FCLASSS @@ -439,12 +515,6 @@ JSL $E10000 MEND MACRO -&LAB FX2D -&LAB PEA $0110 - LDX #$090A - JSL $E10000 - MEND - MACRO &LAB FNEXTD &LAB PEA $011E LDX #$090A @@ -474,7 +544,33 @@ LDX #$090A JSL $E10000 MEND - - - - + MACRO +&LAB FPROCENTRY +&LAB PEA $0017 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FPROCEXIT +&LAB PEA $0019 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FTESTXCP +&LAB PEA $001B + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FADDS +&LAB PEA $0200 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSUBS +&LAB PEA $0202 + LDX #$090A + JSL $E10000 + MEND