Implement scalbln.

This differs from scalbn in that the exponent has type long. When scaling an extended value, exponents slightly outside the range of int can actually be used meaningfully. We address this by doing multiple SCALBX calls (at most 2) in a loop.

math2.asm

@@ -916,6 +916,81 @@ rintl    entry
          rtl
          end
 
+****************************************************************
+*
+*  double scalbln(double x, long n);
+*
+*  Returns x * 2^n.
+*
+****************************************************************
+*
+scalbln  start
+scalblnf entry
+scalblnl entry
+         using MathCommon2
+         
+         csubroutine (10:x,4:n),0
+         
+         phb
+         phk
+         plb
+
+         lda   x                        place x in a work area
+         sta   t1
+         lda   x+2
+         sta   t1+2
+         lda   x+4
+         sta   t1+4
+         lda   x+6
+         sta   t1+6
+         lda   x+8
+         sta   t1+8
+
+loop     cmp4  n,#32767+1               if n > INT_MAX
+         blt   notbig
+         pea   32767                      scale by INT_MAX
+         pea   0
+         bra   adjust_n
+notbig   cmp4  n,#-32768                else if n < INT_MIN
+         bge   notsmall
+         pea   -32768+64                  scale by INT_MIN
+         pea   -1
+
+adjust_n sec                            if n is out of range of int
+         lda   n                          subtract scale factor from n
+         sbc   3,s
+         sta   n
+         lda   n+2
+         sbc   1,s
+         sta   n+2
+         pla
+         bra   do_scalb                 else
+notsmall pei   n                          scale by n
+         stz   n                          remaining amount to scale by is 0
+         stz   n+2
+
+do_scalb ph4   #t1                      scale the number
+         FSCALBX
+
+         lda   n                        if no more scaling to do
+         ora   n+2
+         beq   done                       we are done
+         
+         ph4   #t1                      else if value is nan/inf/zero
+         FCLASSX
+         txa
+         and   #$FE
+         bne   done                       stop: more scaling would not change it
+         brl   loop                     else scale by remaining amount
+
+done     lda   #^t1                     return a pointer to the result
+         sta   n+2
+         lda   #t1
+         sta   n
+         plb
+         creturn 4:n
+         end
+
 ****************************************************************
 *
 *  double scalbn(double x, int n);

math2.macros

@@ -137,6 +137,143 @@
 .G
  MNOTE "Missing closing '}'",16
  MEND
+ macro
+&l cmp4 &n1,&n2
+ lclb &yistwo
+&l ~setm
+ ~lda.h &n1
+ ~op.h eor,&n2
+ bpl ~a&SYSCNT
+ ~lda.h &n2
+ ~op.h cmp,&n1
+ bra ~b&SYSCNT
+~a&SYSCNT ~lda.h &n1
+ ~op.h cmp,&n2
+ bne ~b&SYSCNT
+ ~lda &n1
+ ~op cmp,&n2
+~b&SYSCNT anop
+ ~restm
+ mend
+ macro
+&l ~lda &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 lda &op
+ mend
+ macro
+&l ~lda.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"
+ lda &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ lda &op
+ mexit
+.e
+ lda 2+&op
+ mend
+ macro
+&l ~op &opc,&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 &opc &op
+ mend
+ macro
+&l ~op.h &opc,&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"
+ &opc &op
+ mexit
+.d
+ aif "&c"<>"#",.e
+&op amid "&op",2,l:&op-1
+&op setc "#^&op"
+ &opc &op
+ mexit
+.e
+ &opc 2+&op
+ mend
+ macro
+&l ~restm
+&l anop
+ aif (&~la+&~li)=2,.i
+ sep #32*(.not.&~la)+16*(.not.&~li)
+ aif &~la,.h
+ longa off
+.h
+ aif &~li,.i
+ longi off
+.i
+ mend
+ macro
+&l ~setm
+&l anop
+ aif c:&~la,.b
+ gblb &~la
+ gblb &~li
+.b
+&~la setb s:longa
+&~li setb s:longi
+ aif s:longa.and.s:longi,.a
+ rep #32*(.not.&~la)+16*(.not.&~li)
+ longa on
+ longi on
+.a
+ mend
  MACRO
 &LAB FCLASSS
 &LAB PEA $021C