Initial implementation of lround().

This should work, and mostly does. However, it is affected by a bug in FX2L (and FX2C) which can sometimes give the wrong results for certain negative integers (such as -2147483648). I believe this can occur when at least the lower 16 bits if the integer (in two's-complement representation) are zeros.

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);

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