diff --git a/cc.asm b/cc.asm index a15101a..398a5aa 100644 --- a/cc.asm +++ b/cc.asm @@ -730,6 +730,8 @@ lb3 sec csubroutine (4:len,4:source),0 dest equ source+4 + pei dest+2 save original dest value + pei dest ldx len+2 move whole banks beq lm2 ldy #0 @@ -764,7 +766,11 @@ lb2 lda [source],Y bne lb2 lb3 lda [source] sta [dest] -lb4 creturn +lb4 pla restore original dest value + sta dest + pla + sta dest+2 + creturn end **************************************************************** @@ -865,7 +871,9 @@ lb2 lda [source],Y bne lb2 lb3 lda [source] sta [dest] -lb4 creturn +lb4 bcc lb5 if the move length was odd + dec4 dest restore original dest value +lb5 creturn end **************************************************************** diff --git a/cc.macros b/cc.macros index 52b8821..c86c357 100644 --- a/cc.macros +++ b/cc.macros @@ -280,11 +280,6 @@ ~&SYSCNT ~RESTM MEND MACRO -&LAB JEQ &BP -&LAB BNE *+5 - BRL &BP - MEND - MACRO &LAB LONG &A,&B LCLB &I LCLB &M @@ -539,3 +534,12 @@ .j rtl mend + macro +&l dec4 &a +&l ~setm + lda &a + bne ~&SYSCNT + dec 2+&a +~&SYSCNT dec &a + ~restm + mend diff --git a/equates.asm b/equates.asm index 4d7fd05..b09f088 100644 --- a/equates.asm +++ b/equates.asm @@ -19,6 +19,7 @@ EMFILE gequ 8 too many files are open EACCES gequ 9 access bits prevent the operation EEXIST gequ 10 the file exists ENOSPC gequ 11 the file is too large +EILSEQ gequ 12 encoding error ; ; masks for the __ctype array ; diff --git a/fpextra.asm b/fpextra.asm index ac9f035..7698c03 100644 --- a/fpextra.asm +++ b/fpextra.asm @@ -75,12 +75,26 @@ fpextra private dummy segment * Inputs: * extended-format real on stack * +* Note: This avoids calling FX2C on negative numbers, +* because it is buggy for certain values. +* **************************************************************** * ~CompPrecision start - tsc + tsc round to integer clc adc #4 + pea 0 + pha + FRINTX + lda 4+8,s + pha save original sign + asl a force sign to positive + lsr a + sta 6+8,s + tsc limit precision + clc + adc #6 ldy #0 phy pha @@ -92,6 +106,11 @@ fpextra private dummy segment pha FX2C FC2X - rtl + pla restore original sign + bpl ret + lda 4+8,s + ora #$8000 + sta 4+8,s +ret rtl end diff --git a/fpextra.macros b/fpextra.macros index ddba238..bda9964 100644 --- a/fpextra.macros +++ b/fpextra.macros @@ -34,3 +34,9 @@ LDX #$090A JSL $E10000 MEND + MACRO +&LAB FRINTX +&LAB PEA $0014 + LDX #$090A + JSL $E10000 + MEND diff --git a/int64.asm b/int64.asm index 0be044c..926a7d1 100644 --- a/int64.asm +++ b/int64.asm @@ -646,6 +646,9 @@ ret pld * Outputs: * signed long long int on stack * +* Note: This avoids calling FX2C on negative numbers, +* because it is buggy for certain values. +* **************************************************************** * ~CnvRealLongLong start @@ -668,11 +671,16 @@ ret pld sta 10,s sta 8,s sta 6,s - bra done + bra done otherwise -convert tsc if it is not LONG_MIN, call fx2c: +convert lda 4+8,s + pha save original sign + asl a force sign to positive + lsr a + sta 6+8,s + tsc clc - adc #4 + adc #6 pea 0 push src address for fx2c pha pea 0 push dst address for fx2c @@ -680,7 +688,22 @@ convert tsc if it is not LONG_MIN, call fx2c: inc a pha fx2c convert - + pla if original value was negative + bpl done + sec + lda #0 negate result + sbc 6,s + sta 6,s + lda #0 + sbc 6+2,s + sta 6+2,s + lda #0 + sbc 6+4,s + sta 6+4,s + lda #0 + sbc 6+6,s + sta 6+6,s + done phb move return address pla plx diff --git a/locale.asm b/locale.asm new file mode 100644 index 0000000..a1ba8af --- /dev/null +++ b/locale.asm @@ -0,0 +1,107 @@ + keep obj/locale + mcopy locale.macros + case on +**************************************************************** +* +* Locale - locale support +* +* This currently implements a minimalistic version of the +* functions, supporting only the "C" locale. +* +**************************************************************** +* +Locale private dummy routine + end + +**************************************************************** +* +* char *setlocale(int category, const char *locale); +* +* Set or query current locale +* +* Inputs: +* category - locale category to set or query +* locale - locale name (or NULL for query) +* +* Outputs: +* returns locale string (for relevant category), +* or NULL if locale cannot be set as requested +* +**************************************************************** +* +setlocale start +LC_MAX equ 5 maximum valid LC_* value + + csubroutine (2:category,4:locale),0 + + lda category if category is invalid + cmp #LC_MAX+1 + bge err return NULL + lda locale if querying the current locale + ora locale+2 + beq good return "C" + lda [locale] + cmp #'C' if locale is "C" or "", we are good + beq good + and #$00FF + bne err +good lda #C_str if successful, return "C" + sta locale + lda #^C_str + sta locale+2 + bra ret +err stz locale otherwise, return NULL for error + stz locale+2 +ret creturn 4:locale + +C_str dc c'C',i1'0' + end + +**************************************************************** +* +* struct lconv *localeconv(void); +* +* Get numeric formatting conventions +* +* Outputs: +* returns pointer to a struct lconv containing +* appropriate values for the current locale +* +**************************************************************** +* +localeconv start +CHAR_MAX equ 255 + + ldx #^C_locale_lconv + lda #C_locale_lconv + rtl + +C_locale_lconv anop +decimal_point dc a4'period' +thousands_sep dc a4'emptystr' +grouping dc a4'emptystr' +mon_decimal_point dc a4'emptystr' +mon_thousands_sep dc a4'emptystr' +mon_grouping dc a4'emptystr' +positive_sign dc a4'emptystr' +negative_sign dc a4'emptystr' +currency_symbol dc a4'emptystr' +frac_digits dc i1'CHAR_MAX' +p_cs_precedes dc i1'CHAR_MAX' +n_cs_precedes dc i1'CHAR_MAX' +p_sep_by_space dc i1'CHAR_MAX' +n_sep_by_space dc i1'CHAR_MAX' +p_sign_posn dc i1'CHAR_MAX' +n_sign_posn dc i1'CHAR_MAX' +int_curr_symbol dc a4'emptystr' +int_frac_digits dc i1'CHAR_MAX' +int_p_cs_precedes dc i1'CHAR_MAX' +int_n_cs_precedes dc i1'CHAR_MAX' +int_p_sep_by_space dc i1'CHAR_MAX' +int_n_sep_by_space dc i1'CHAR_MAX' +int_p_sign_posn dc i1'CHAR_MAX' +int_n_sign_posn dc i1'CHAR_MAX' + +period dc c'.',i1'0' +emptystr dc i1'0' + end diff --git a/locale.macros b/locale.macros new file mode 100644 index 0000000..f23f1b0 --- /dev/null +++ b/locale.macros @@ -0,0 +1,93 @@ + 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 diff --git a/make b/make index ebb32f1..0976585 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 fenv fpextra math2 + for i in cc ctype string stdlib time setjmp orca fcntl vars toolglue signal int64 fenv fpextra math2 locale uchar Newer obj/{i}.a {i}.asm if {Status} != 0 set exit on @@ -40,7 +40,7 @@ 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} fenv.a fpextra.a math2.a +set list {list} fenv.a fpextra.a math2.a locale.a uchar.a for i in {list} echo makelib orcalib +obj/{i} makelib orcalib +obj/{i} diff --git a/math2.asm b/math2.asm index 3f353b3..d173779 100644 --- a/math2.asm +++ b/math2.asm @@ -13,6 +13,31 @@ **************************************************************** math2 private dummy segment + copy equates.asm + end + +INVALID gequ $0001 exceptions +UNDERFLOW gequ $0002 +OVERFLOW gequ $0004 +DIVBYZERO gequ $0008 +INEXACT gequ $0010 + +TONEAREST gequ 0 rounding directions +UPWARD gequ 1 +DOWNWARD gequ 2 +TOWARDZERO gequ 3 + +**************************************************************** +* +* MathCommon2 - common work areas for the math library +* +**************************************************************** +* +MathCommon2 privdata +; +; temporary work space/return value +; +t1 ds 10 end **************************************************************** @@ -153,3 +178,2728 @@ __signbit start creturn 2:val end + +**************************************************************** +* +* int __fpcompare(long double x, long double y, short mask); +* +* Compare two floating-point values, not signaling invalid +* if they are unordered. +* +* Inputs: +* x,y - values to compare +* mask - mask of bits as returned in X register from FCMP +* +* Outputs: +* 1 if x and y have one of the relations specified by mask +* 0 otherwise +* +**************************************************************** +* +__fpcompare start + + csubroutine (10:x,10:y,2:mask),0 + + tdc + clc + adc #x + pea 0 + pha + tdc + clc + adc #y + pea 0 + pha + FCMPX + txa + and mask + beq lb1 + lda #1 +lb1 sta mask + + creturn 2:mask + end + +**************************************************************** +* +* double acosh(double x); +* +* Returns the inverse hyperbolic cosine of x. +* +**************************************************************** +* +acosh start +acoshf entry +acoshl entry + using MathCommon2 + + csubroutine (10:x),0 + + phb + phk + plb + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + lda x y = sqrt(x-1) + sta y + lda x+2 + sta y+2 + lda x+4 + sta y+4 + lda x+6 + sta y+6 + lda x+8 + sta y+8 + ph4 #one + ph4 #y + FSUBI + ph4 #y + FSQRTX + + lda x t1 = sqrt(x+1) + 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 + ph4 #one + ph4 #t1 + FADDI + ph4 #t1 + FSQRTX + + ph4 #y t1 = ln(1+y*(y+t1)) + ph4 #t1 + FADDX + ph4 #y + ph4 #t1 + FMULX + ph4 #t1 + FLN1X + + lda t1+8 if t1 = +inf + cmp #32767 + bne ret + lda t1+6 + asl a + ora t1+4 + ora t1+2 + ora t1 + bne ret + + pea 0 clear exceptions + FSETENV + lda x t1 = ln(x) + ln(2) + 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 + ph4 #t1 + FLNX + ph4 #ln2 + ph4 #t1 + FADDX + +ret FPROCEXIT restore env & raise any new exceptions + plb + lda #t1 return t1 + sta x + lda #^t1 + sta x+2 + creturn 4:x + +y ds 10 temporary variable +one dc i'1' constants +ln2 dc e'0.69314718055994530942' + end + +**************************************************************** +* +* double asinh(double x); +* +* Returns the inverse hyperbolic sine of x. +* +**************************************************************** +* +asinh start +asinhf entry +asinhl entry + using MathCommon2 + + csubroutine (10:x),0 + + phb + phk + plb + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + pei x+8 save sign of x + asl x+8 x = abs(x) + lsr x+8 + + lda x t1 = y = z = x + sta y + sta z + sta t1 + lda x+2 + sta y+2 + sta z+2 + sta t1+2 + lda x+4 + sta y+4 + sta z+4 + sta t1+4 + lda x+6 + sta y+6 + sta z+6 + sta t1+6 + lda x+8 + sta y+8 + sta z+8 + sta t1+8 + + lda x if value is zero (or typical inf) + ora x+2 + ora x+4 + ora x+6 + beq skipcalc return the input value + + lda x+8 else if x is very small + cmp #-33+16383 + bge calc + pea INEXACT raise "inexact" exception + FSETXCP +skipcalc brl setsign return the input value + +calc cmp #16383/2+16383 else if x is very large (or nan) + blt notbig + ph4 #z z = ln(x) + ln(2) + FLNX + ph4 #ln2 + ph4 #z + FADDX + brl setsign else + +notbig pea -2 t1 = 1 / (t1 * t1) + ph4 #t1 + FXPWRI + + ph4 #one t1 = 1 + t1 + ph4 #t1 + FADDI + + ph4 #t1 t1 = sqrt(t1) + FSQRTX + + pea -1 y = 1 / y + ph4 #y + FXPWRI + + ph4 #y t1 = t1 + y + ph4 #t1 + FADDX + + ph4 #t1 z = z / t1 + ph4 #z + FDIVX + + tdc z = z + x + clc + adc #x + pea 0 + pha + ph4 #z + FADDX + + ph4 #z z = ln(1+z) + FLN1X + +setsign asl z+8 sign of z = original sign of x + pla + asl a + ror z+8 + + FPROCEXIT restore env & raise any new exceptions + plb + lda #z return z + sta x + lda #^z + sta x+2 + creturn 4:x + +y ds 10 temporary variables +z ds 10 +one dc i'1' constants +ln2 dc e'0.69314718055994530942' + end + +**************************************************************** +* +* double atanh(double x); +* +* Returns the inverse hyperbolic tangent of x. +* +**************************************************************** +* +atanh start +atanhf entry +atanhl entry + using MathCommon2 + + csubroutine (10:x),0 + + phb + phk + plb + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + pei x+8 save sign of x + asl x+8 x = abs(x) + lsr x+8 + + lda x t1 = x + 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 + + lda x+8 if x is very small + cmp #-33+16383 + bge calc + lda x if value is not zero + ora x+2 + ora x+4 + ora x+6 + beq skipcalc + pea INEXACT raise "inexact" exception + FSETXCP +skipcalc bra setsign skip next steps (return input value) + +calc ph4 #one x = x - 1 + tdc + clc + adc #x + pea 0 + pha + FSUBI + + tdc t1 = t1 / x + clc + adc #x + pea 0 + pha + ph4 #t1 + FDIVX + + lda t1+8 if t1 is inf/nan + asl a + cmp #32767*2 + beq setsign skip next steps (so atanh(1) = +inf) + + ph4 #minustwo t1 = t1 * -2 + ph4 #t1 + FMULI + + ph4 #t1 t1 = ln(1+t1) + FLN1X + + ph4 #minustwo t1 = t1 / -2 + ph4 #t1 + FDIVI + +setsign asl t1+8 sign of t1 = original sign of x + pla + asl a + ror t1+8 + + FPROCEXIT restore env & raise any new exceptions + plb + lda #t1 return t1 + sta x + lda #^t1 + sta x+2 + creturn 4:x + +one dc i'1' constants +minustwo dc i'-2' + end + +**************************************************************** +* +* double cbrt(double x); +* +* Returns x^(1/3) (the cube root of x). +* +**************************************************************** +* +cbrt start +cbrtf entry +cbrtl entry + using MathCommon2 +scale equ 1 + + csubroutine (10:x),2 + + phb + phk + plb + + stz scale scale by 0 by default (for inf/nan) + + lda x+8 + pha save original sign + and #$7FFF + sta x+8 force sign to + + cmp #32767 skip scaling for inf/nan + beq do_calc + + ldx x+6 if number is denormalized + bmi div_exp + bne normaliz + ldx x+4 + bne normaliz + ldx x+2 + bne normaliz + ldx x + beq div_exp + +normaliz dec a normalize it and adjust exponent + asl x + rol x+2 + rol x+4 + rol x+6 + bpl normaliz + +div_exp pha calculate exponent/3 + pha + pha + pea 3 + _SDivide + pla a = quotient + plx x = remainder + cpx #2 adjust remainder of 2 to -1 + bne setscale + ldx #-1 + inc a + +setscale sec calculate amount to scale result by + sbc #16383/3 + sta scale + txa use remainder as exponent for calc. + clc + adc #16383 +do_calc sta t1+8 + + lda x place mantissa in work area + sta t1 + lda x+2 + sta t1+2 + lda x+4 + sta t1+4 + lda x+6 + sta t1+6 + + ph4 #onethird compute val^(1/3) + ph4 #t1 + FXPWRY + + clc apply scaling + lda t1+8 + adc scale + sta t1+8 + + asl t1+8 set sign of result to orig. sign of x + pla + asl a + ror t1+8 + + plb + lda #t1 return t1 + sta x + lda #^t1 + sta x+2 + creturn 4:x + +onethird dc e'0.33333333333333333333' + end + +**************************************************************** +* +* double copysign(double x, double y); +* +* Returns a value with the magnitude of x and the sign of y. +* +**************************************************************** +* +copysign start +copysignf entry +copysignl entry + using MathCommon2 + + phb place x in a work area... + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + asl a ...with the sign bit shifted off + sta t1+8 + + pla remove y + pla + pla + pla + pla + asl a get sign bit of y + ror t1+8 give return value that sign + + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double exp2(double x); +* +* Returns 2^x. +* +**************************************************************** +* +exp2 start +exp2f entry +exp2l entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FEXP2X + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double expm1(double x); +* +* Returns e^x - 1. +* +**************************************************************** +* +expm1 start +expm1f entry +expm1l entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FEXP1X + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double fdim(double x, double y); +* +* Returns x - y if x > y, or +0 if x <= y. +* +**************************************************************** +* +fdim start +fdimf entry +fdiml entry + using MathCommon2 + + phb + phk + plb + + tsc compare x and y + clc + adc #5 + pea 0 + pha + adc #10 + pea 0 + pha + FCMPX + bmi x_le_y + beq x_le_y + + tsc if x > y (or unordered) + clc + adc #5+10 + pea 0 + pha + sbc #10-1 (carry is clear) + pea 0 + pha + FSUBX x = x - y + lda 5,s t1 = x + sta t1 + lda 5+2,s + sta t1+2 + lda 5+4,s + sta t1+4 + lda 5+6,s + sta t1+6 + lda 5+8,s + sta t1+8 + bra ret else + +x_le_y stz t1 t1 = +0.0 + stz t1+2 + stz t1+4 + stz t1+6 + stz t1+8 + +ret plx clean up stack + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double fmax(double x, double y); +* +* Returns the maximum numeric value of x or y. +* If one is a NaN, returns the other. +* +**************************************************************** +* +fmax start +fmaxf entry +fmaxl entry + using MathCommon2 + + phb + phk + plb + phd + + tsc set up direct page + clc + adc #7 + tcd + + pea 0 compare x and y + pha + clc + adc #10 + pea 0 + pha + FCMPX + + bmi use_y if x < y, return y + bvs use_x if x >= y, return x + beq use_x + + pea 0 if x,y are unordered + phd + FCLASSX + txa + and #$00FE + cmp #$00FC if x is not a nan, return x + beq use_y else return y + +use_x ldx #0 + bra copyit + +use_y ldx #10 + +copyit lda 0,x copy result to t1 + sta t1 + lda 2,x + sta t1+2 + lda 4,x + sta t1+4 + lda 6,x + sta t1+6 + lda 8,x + sta t1+8 + + pld clean up stack + plx + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double fmin(double x, double y); +* +* Returns the minimum numeric value of x or y. +* If one is a NaN, returns the other. +* +**************************************************************** +* +fmin start +fminf entry +fminl entry + using MathCommon2 + + phb + phk + plb + phd + + tsc set up direct page + clc + adc #7 + tcd + + pea 0 compare x and y + pha + clc + adc #10 + pea 0 + pha + FCMPX + + bmi use_x if x < y, return x + bvs use_y if x >= y, return y + beq use_y + + pea 0 if x,y are unordered + phd + FCLASSX + txa + and #$00FE + cmp #$00FC if x is not a nan, return x + beq use_y else return y + +use_x ldx #0 + bra copyit + +use_y ldx #10 + +copyit lda 0,x copy result to t1 + sta t1 + lda 2,x + sta t1+2 + lda 4,x + sta t1+4 + lda 6,x + sta t1+6 + lda 8,x + sta t1+8 + + pld clean up stack + plx + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double hypot(double x, double y); +* +* Returns the square root of x^2 + y^2, without undue overflow +* or underflow. +* +**************************************************************** +* +hypot start +hypotf entry +hypotl entry + using MathCommon2 +scale equ 1 scaling factor + + csubroutine (10:x,10:y),2 + + phb + phk + plb + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + stz scale no scaling by default + + asl x+8 x = abs(x) + lsr x+8 + asl y+8 y = abs(y) + lsr y+8 + + tdc if x < y + clc + adc #x + pea 0 + pha + adc #y-x + pea 0 + pha + FCMPX + bpl sorted + + ldx #8 exchange x and y +xchgloop lda x,x + ldy y,x + sta y,x + sty x,x + dex + dex + bpl xchgloop +sorted anop at this point, 0 <= y <= x (if ordered) + + lda x+8 if x or y is nan or inf + ldy y+8 + cpy #32767 + beq naninf + cmp #32767 + beq naninf skip exponent manipulation + + cmp #8190+16383+1 if exponent of x > 8190 + blt chksmall + sec scale x and y down by 2^8300 + sbc #8300 + sta x+8 + lda #8300 + sta scale + lda y+8 + sec + sbc #8300 + sta y+8 + bpl compute + stz y (zero out y if needed) + stz y+2 + stz y+4 + stz y+6 + stz y+8 + bra compute + +chksmall cmp #-8100+16383 else if exponent of x < -8100 + bge compute + clc scale x and y up by 2^8300 + adc #8300 + sta x+8 + lda y+8 + clc + adc #8300 + sta y+8 + lda #-8300 + sta scale + +compute tdc x = x*x + clc + adc #x + pea 0 + pha + pea 0 + pha + FMULX + + tdc y = y*y + clc + adc #y + pea 0 + pha + pea 0 + pha + FMULX + +naninf anop (we skip to here if x or y is nan/inf) + lda x copy x to t1 + 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 + + tdc t1 = x*x + y*y + clc + adc #y + pea 0 + pha + ph4 #t1 + FADDX + + ph4 #t1 t1 = sqrt(t1) + FSQRTX + + lda scale if scaling is needed + beq done + pha do it + ph4 #t1 + FSCALBX + +done FPROCEXIT restore env + lda #^t1 return t1 + sta x+2 + lda #t1 + sta x + plb + creturn 4:x + end + +**************************************************************** +* +* int ilogb(double x); +* +* Returns the binary exponent of x (a signed integer value), +* treating denormalized numbers as if they were normalized. +* Handles inf/nan/0 cases specially. +* +**************************************************************** +* +ilogb start +ilogbf entry +ilogbl entry + + csubroutine (10:x),0 + + tdc check for special cases + clc + adc #x + pea 0 + pha + FCLASSX + ldy #$7FFF + txa + and #$FF + cmp #$FE if x is INF + beq special return INT_MAX + lsr a + beq do_logb if x is 0 or NAN + iny return INT_MIN +special sty x + bra ret + +do_logb tdc compute logb(x) + clc + adc #x + pea 0 + pha + FLOGBX + + tdc convert to integer + clc + adc #x + pea 0 + pha + pea 0 + pha + FX2I + +ret creturn 2:x return it + rtl + end + +**************************************************************** +* +* long long llrint(double x); +* +* Rounds x to an integer using current rounding direction +* and returns it as a long long (if representable). +* +* Note: This avoids calling FX2C on negative numbers, +* because it is buggy for certain values. +* +**************************************************************** +* +llrint start +llrintf entry +llrintl entry +retptr equ 1 + + csubroutine (10:x),4 + stx retptr + stz retptr+2 + + tdc + clc + adc #x + pea 0 push src address for fcpxx + pha + pea llmin|-16 push dst address for fcpxx + pea llmin + pea 0 push operand address for frintx + pha + FRINTX round + FCPXX compare with LLONG_MIN + bne convert + + lda #$8000 if it is LLONG_MIN, use that value + ldy #6 + sta [retptr],y + asl a + dey + dey + sta [retptr],y + dey + dey + sta [retptr],y + sta [retptr] + bra done otherwise + +convert pei x+8 save sign of x + asl x+8 x = abs(x) + lsr x+8 + tdc + clc + adc #x + pea 0 push src address for fx2c + pha + pei retptr+2 push dst address for fx2c + pei retptr + FX2C convert x + + pla if x was negative + bpl done + sec + lda #0 negate result + sbc [retptr] + sta [retptr] + ldy #2 + lda #0 + sbc [retptr],y + sta [retptr],y + iny + iny + lda #0 + sbc [retptr],y + sta [retptr],y + iny + iny + lda #0 + sbc [retptr],y + sta [retptr],y + +done creturn + +llmin dc e'-9223372036854775808' + end + +**************************************************************** +* +* long long llround(double x); +* +* Rounds x to the nearest integer, rounding halfway cases away +* from 0, and returns it as a long long (if representable). +* +* Note: This avoids calling FX2C on negative numbers, +* because it is buggy for certain values. +* +**************************************************************** +* +llround start +llroundf entry +llroundl entry +retptr equ 1 + + csubroutine (10:x),4 + stx retptr + stz retptr+2 + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + tdc if x == LLONG_MIN + clc + adc #x + pea 0 + pha + ph4 #llmin + FCMPX + beq retllmin return LLONG_MIN + tdc else if x == LLONG_MIN+0.5 + clc + adc #x + pea 0 + pha + ph4 #llminp05 + FCPXX + bne convert + + pea INEXACT raise "inexact" exception + FSETXCP +retllmin lda #$8000 return LLONG_MIN + ldy #6 + sta [retptr],y + asl a + dey + dey + sta [retptr],y + dey + dey + sta [retptr],y + sta [retptr] + brl ret else + +convert pei x+8 save sign of x + asl x+8 x = abs(x) + lsr x+8 + + tdc round to integer + clc + adc #x + pea 0 + pha + pei retptr+2 + pei retptr + FX2C + + pea INEXACT + FTESTXCP if there was no inexact exception + beq chk_neg we're done: x was an integer/nan/inf + + FGETENV else + txa + ora #TOWARDZERO*$4000 round toward zero + pha + FSETENV + + ph4 #onehalf x = x + 0.5 (rounded toward 0) + tdc + clc + adc #x + pea 0 + pha + FADDS + tdc round to integer + clc + adc #x + pea 0 + pha + pei retptr+2 + pei retptr + FX2C + +chk_neg pla if x was negative + bpl ret + sec + lda #0 negate result + sbc [retptr] + sta [retptr] + ldy #2 + lda #0 + sbc [retptr],y + sta [retptr],y + iny + iny + lda #0 + sbc [retptr],y + sta [retptr],y + iny + iny + lda #0 + sbc [retptr],y + sta [retptr],y + +ret FPROCEXIT restore env & raise any new exceptions + creturn + +llmin dc e'-9223372036854775808' +llminp05 dc e'-9223372036854775807.5' +onehalf dc f'0.5' + end + +**************************************************************** +* +* double log1p(double x); +* +* Returns ln(1+x). +* +**************************************************************** +* +log1p start +log1pf entry +log1pl entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FLN1X + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double log2(double x); +* +* Returns log2(x) (the base-2 logarithm of x). +* +**************************************************************** +* +log2 start +log2f entry +log2l entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FLOG2X + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double logb(double x); +* +* Returns the binary exponent of x (a signed integer value), +* treating denormalized numbers as if they were normalized. +* +**************************************************************** +* +logb start +logbf entry +logbl entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FLOGBX + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* long lrint(double x); +* +* Rounds x to an integer using current rounding direction +* and returns it as a long (if representable). +* +* Note: This avoids calling FX2L or FX2C on negative numbers, +* because they are buggy for certain values. +* +**************************************************************** +* +lrint start +lrintf entry +lrintl entry + + csubroutine (10:x),0 + + pei x+8 save sign of x + + tdc + clc + adc #x + pea 0 + pha + pea 0 + pha + pea 0 + pha + FRINTX round x to integer + asl x+8 x = abs(x) + lsr x+8 + FX2C convert to comp + + lda x+4 if x is out of range of long + ora x+6 + bne flag_inv + cmpl x,#$80000000 + blt chk_neg + bne flag_inv + lda 1,s + bmi chk_neg +flag_inv pea INVALID raise "invalid" exception + FSETXCP + +chk_neg pla if x was negative + bpl ret + sub4 #0,x,x negate result + +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). +* +* Note: This avoids calling FX2L or FX2C on negative numbers, +* because they are buggy for certain values. +* +**************************************************************** +* +lround start +lroundf entry +lroundl entry +result equ 1 result value + + csubroutine (10:x),8 + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + pei x+8 save sign of x + asl x+8 x = abs(x) + lsr x+8 + + tdc round to integer with default rounding + clc + adc #x + pea 0 + pha + adc #result-x + pea 0 + pha + FX2C + + pea INEXACT + FTESTXCP if there was no inexact exception + beq chkrange we are done: x was an integer/nan/inf + + FGETENV + txa + ora #TOWARDZERO*$4000 set rounding direction to "toward zero" + pha + FSETENV + + ph4 #onehalf x = x + 0.5 (rounded toward 0) + tdc + clc + adc #x + pea 0 + pha + FADDS + tdc round to integer + clc + adc #x + pea 0 + pha + adc #result-x + pea 0 + pha + FX2C + +chkrange lda result+4 if x is out of range of long + ora result+6 + bne flag_inv + cmpl result,#$80000000 + blt chk_neg + bne flag_inv + lda 1,s + bmi chk_neg +flag_inv pea INVALID raise "invalid" exception + FSETXCP + +chk_neg pla if x was negative + bpl ret + sub4 #0,result,result negate result + +ret FPROCEXIT restore env & raise any new exceptions + creturn 4:result return the result + +onehalf dc f'0.5' + end + +**************************************************************** +* +* float modff(float x, float *iptr); +* +* Splits x into integer and fractional parts. Returns the +* fractional part and stores integer part as a float in *iptr. +* +**************************************************************** +* +modff start + using MathCommon2 + + csubroutine (10:x,4:iptr),0 + + phb + phk + plb + + lda x copy x to t1 + 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 + + asl a check for infinity or nan + cmp #32767|1 + bne finite + lda x+6 + asl a + ora x+4 + ora x+2 + ora x + bne storeint if value is nan, return it as-is + stz t1 if value is +-inf, fractional part is 0 + stz t1+2 + stz t1+4 + stz t1+6 + stz t1+8 + bra storeint + +finite tdc truncate x to an integer + clc + adc #x + pea 0 + pha + FTINTX + + tdc t1 := t1 - x + clc + adc #x + pea 0 + pha + ph4 #t1 + FSUBX + +storeint tdc copy x to *iptr, converting to float + clc + adc #x + pea 0 + pha + pei iptr+2 + pei iptr + FX2S + +copysign asl t1+8 copy sign of x to t1 + asl x+8 + ror t1+8 + + lda #^t1 return t1 (fractional part) + sta iptr+2 + lda #t1 + sta iptr + plb + creturn 4:iptr + end + +**************************************************************** +* +* long double modfl(long double x, long double *iptr); +* +* Splits x into integer and fractional parts. Returns the +* fractional part and stores the integer part in *iptr. +* +**************************************************************** +* +modfl start + using MathCommon2 + + csubroutine (10:x,4:iptr),0 + + phb + phk + plb + + lda x copy x to *iptr and t1 + sta [iptr] + sta t1 + ldy #2 + lda x+2 + sta [iptr],y + sta t1+2 + iny + iny + lda x+4 + sta [iptr],y + sta t1+4 + iny + iny + lda x+6 + sta [iptr],y + sta t1+6 + iny + iny + lda x+8 + sta [iptr],y + sta t1+8 + + asl a check for infinity or nan + cmp #32767|1 + bne finite + lda x+6 + asl a + ora x+4 + ora x+2 + ora x + bne ret if value is nan, return it as-is + stz t1 if value is +-inf, fractional part is 0 + stz t1+2 + stz t1+4 + stz t1+6 + stz t1+8 + bra copysign + +finite pei iptr+2 if value is finite + pei iptr + FTINTX truncate *iptr to an integer + + pei iptr+2 t1 := t1 - *iptr + pei iptr + ph4 #t1 + FSUBX + +copysign asl t1+8 copy sign of x to t1 + asl x+8 + ror t1+8 + +ret lda #^t1 return t1 (fractional part) + sta iptr+2 + lda #t1 + sta iptr + plb + creturn 4:iptr + end + +**************************************************************** +* +* double nan(const char *tagp); +* +* Returns a quiet NaN, with NaN code determined by the +* argument string. +* +**************************************************************** +* +nan start +nanf entry +nanl entry + using MathCommon2 + + csubroutine (4:tagp) + + phb + phk + plb + + stz t1+6 initial code is 0 + +loop lda [tagp] do + and #$00FF get next character + beq loopdone if end of string, break + cmp #'0' + blt no_code + cmp #'9'+1 + bge no_code if not a digit, treat as no code + and #$000F + asl t1+6 code = code*10 + digit + clc + adc t1+6 + asl t1+6 + asl t1+6 + clc + adc t1+6 + sta t1+6 + inc4 tagp tagp++ + bra loop while true + +no_code stz t1+6 if no code specified, default to 0 + +loopdone lda t1+6 + and #$00FF use low 8 bits as NaN code + bne codeok if code is 0 + lda #21 use NANZERO +codeok ora #$4000 set high bit of f for quiet NaN + sta t1+6 + + lda #32767 e=32767 for NaN + sta t1+8 + stz t1+4 set rest of fraction field to 0 + stz t1+2 + stz t1 + + lda #^t1 return a pointer to the result + sta tagp+2 + lda #t1 + sta tagp + plb + creturn 4:tagp + end + +**************************************************************** +* +* double nearbyint(double x); +* +* Rounds x to an integer using current rounding direction, +* never raising the "inexact" exception. +* +**************************************************************** +* +nearbyint start +nearbyintf entry +nearbyintl entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + FGETENV save environment + phx + ph4 #t1 compute the value + FRINTX + FSETENV restore environment + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double nextafter(double x, double y); +* +* Returns next representable value (in double format) +* after x in the direction of y. Returns y if x equals y. +* +**************************************************************** +* +nextafter start + using MathCommon2 + + tsc x = (double) x + clc + adc #4 + pea 0 + pha + pea 0 + pha + FX2D + lda 4,s save low bits of x + sta 4+8,s + + tsc y = (double) y + clc + adc #4+10 + pea 0 + pha + pea 0 + pha + FX2D + + tsc push address of y + clc + adc #4+10 + pea 0 + pha + sbc #10-1 push address of x + pea 0 + pha + FNEXTD x = nextafter x toward y + + tsc store x (as extended) in t1 + clc + adc #4 + pea 0 + pha + ph4 #t1 + FD2X + + phb + lda 4+8+1,s if original x might be 0 then + bne ret + tsc + clc + adc #4+10+1 + pea 0 + pha + ph4 #t1 + FCPXD + bne ret if t1 == y then + phk + plb + asl t1+8 sign of t1 = sign of y + lda 4+10+1+6,s + asl a + ror t1+8 + +ret plx move return address + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* float nextafterf(float x, float y); +* +* Returns next representable value (in float format) +* after x in the direction of y. Returns y if x equals y. +* +**************************************************************** +* +nextafterf start + using MathCommon2 + + tsc x = (float) x + clc + adc #4 + pea 0 + pha + pea 0 + pha + FX2S + lda 4,s save low bits of x + sta 4+8,s + + tsc y = (float) y + clc + adc #4+10 + pea 0 + pha + pea 0 + pha + FX2S + + tsc push address of y + clc + adc #4+10 + pea 0 + pha + sbc #10-1 push address of x + pea 0 + pha + FNEXTS x = nextafter x toward y + + tsc store x (as extended) in t1 + clc + adc #4 + pea 0 + pha + ph4 #t1 + FS2X + + phb + lda 4+8+1,s if original x might be 0 then + bne ret + tsc + clc + adc #4+10+1 + pea 0 + pha + ph4 #t1 + FCPXS + bne ret if t1 == y then + phk + plb + asl t1+8 sign of t1 = sign of y + lda 4+10+1+2,s + asl a + ror t1+8 + +ret plx move return address + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* long double nextafterl(long double x, long double y); +* long double nexttowardl(long double x, long double y); +* +* Returns next representable value (in extended format) +* after x in the direction of y. Returns y if x equals y. +* +**************************************************************** +* +nextafterl start +nexttowardl entry + using MathCommon2 + + tsc push address of x + clc + adc #4 + pea 0 + pha + adc #10 push address of y + pea 0 + pha + FCPXX + bne getnext if x == y then + tsc + clc + adc #4+10 return y + bra storeval else + +getnext tsc push address of y + clc + adc #4+10 + pea 0 + pha + sbc #10-1 push address of x + pea 0 + pha + FNEXTX x = nextafter x toward y + + tsc return x + clc + adc #4 +storeval pea 0 store return value to t1 + pha + ph4 #t1 + FX2X + + phb move return address + plx + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double nexttoward(double x, long double y); +* +* Returns next representable value (in double format) +* after x in the direction of y. Returns y if x equals y. +* +**************************************************************** +* +nexttoward start + using MathCommon2 + + tsc x = (double) x + clc + adc #4 + pea 0 + pha + pea 0 + pha + FX2D + + tsc push address of x + clc + adc #4 + pea 0 + pha + adc #10 push address of y + pea 0 + pha + FCPXD compare x and y + + bvs x_gt_y + bmi x_lt_y + beq x_eq_y + + tsc x,y unordered case: do nextafter(x,y) + clc + adc #4+10 + pea 0 + pha + pea 0 + pha + pea 0 + pha + FX2D + bra getnext + +x_gt_y ph4 #minusinf x > y case: do nextafter(x,-inf) + bra getnext + +x_lt_y ph4 #plusinf x < y case: do nextafter(x,+inf) + bra getnext + +x_eq_y phb + phk + plb + lda 4+10+1,s x == y case: return y + sta t1 + lda 4+10+1+2,s + sta t1+2 + lda 4+10+1+4,s + sta t1+4 + lda 4+10+1+6,s + sta t1+6 + lda 4+10+1+8,s + sta t1+8 + bra ret + +getnext tsc compute nextafter(x,...) + clc + adc #4+4 + pea 0 + pha + FNEXTD + + tsc store x (as extended) in t1 + clc + adc #4 + pea 0 + pha + ph4 #t1 + FD2X + + phb move return address +ret plx + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + +plusinf dc d'+inf' +minusinf dc d'-inf' + end + +**************************************************************** +* +* float nexttowardf(float x, long double y); +* +* Returns next representable value (in float format) +* after x in the direction of y. Returns y if x equals y. +* +**************************************************************** +* +nexttowardf start + using MathCommon2 + + tsc x = (double) x + clc + adc #4 + pea 0 + pha + pea 0 + pha + FX2S + + tsc push address of x + clc + adc #4 + pea 0 + pha + adc #10 push address of y + pea 0 + pha + FCPXS compare x and y + + bvs x_gt_y + bmi x_lt_y + beq x_eq_y + + tsc x,y unordered case: do nextafter(x,y) + clc + adc #4+10 + pea 0 + pha + pea 0 + pha + pea 0 + pha + FX2S + bra getnext + +x_gt_y ph4 #minusinf x > y case: do nextafter(x,-inf) + bra getnext + +x_lt_y ph4 #plusinf x < y case: do nextafter(x,+inf) + bra getnext + +x_eq_y phb + phk + plb + lda 4+10+1,s x == y case: return y + sta t1 + lda 4+10+1+2,s + sta t1+2 + lda 4+10+1+4,s + sta t1+4 + lda 4+10+1+6,s + sta t1+6 + lda 4+10+1+8,s + sta t1+8 + bra ret + +getnext tsc compute nextafter(x,...) + clc + adc #4+4 + pea 0 + pha + FNEXTS + + tsc store x (as extended) in t1 + clc + adc #4 + pea 0 + pha + ph4 #t1 + FS2X + + phb move return address +ret plx + ply + tsc + clc + adc #20 + tcs + phy + phx + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + +plusinf dc f'+inf' +minusinf dc f'-inf' + end + +**************************************************************** +* +* double remainder(double x, double y); +* +* Returns x REM y as specified by IEEE 754: r = x - ny, +* where n is the integer nearest to the exact value of x/y. +* When x/y is halfway between two integers, n is even. +* If r = 0, its sign is that of x. +* +**************************************************************** +* +remainder start +remainderf entry +remainderl entry + using MathCommon2 + + phb place x in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + + tsc compute the value + clc + adc #5 + pea 0 + pha + ph4 #t1 + FREMX + + pla move return address + sta 9,s + pla + sta 9,s + tsc + clc + adc #6 + tcs + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double remquo(double x, double y, int *quo); +* +* Returns x REM y as specified by IEEE 754 (like remainder). +* Also, sets *quo to a value whose sign is the same as x/y +* and whose magnitude gives the low-order 7 bits of the +* magnitude of the integer quotient x/y. +* +**************************************************************** +* +remquo start +remquof entry +remquol entry + using MathCommon2 + + phb place x in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + + tsc compute the value + clc + adc #5 + pea 0 + pha + ph4 #t1 + FREMX + + phd + php save sign flag + tsc + tcd + txa calculate value to store in *quo + and #$007F + plp + bpl setquo + eor #$FFFF + inc a +setquo sta [18] store it + pld + + pla move return address + sta 13,s + pla + sta 13,s + tsc + clc + adc #10 + tcs + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double rint(double x); +* +* Rounds x to an integer using current rounding direction. +* +**************************************************************** +* +rint start +rintf entry +rintl entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FRINTX + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double round(double x); +* +* Rounds x to the nearest integer, rounding halfway cases +* away from 0. +* +**************************************************************** +* +round start +roundf entry +roundl entry + using MathCommon2 + + csubroutine (10:x),0 + + phb + phk + plb + + pha save env & set to default + tsc + inc a + pea 0 + pha + FPROCENTRY + + lda x t1 = x + 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 + + ph4 #t1 round to integer with default rounding + FRINTX + + 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 t1 = abs(x) + sta t1 + lda x+2 + sta t1+2 + lda x+4 + sta t1+4 + lda x+6 + sta t1+6 + lda x+8 + and #$7fff + sta t1+8 + + ph4 #onehalf t1 = t1 + 0.5 (rounded toward 0) + ph4 #t1 + FADDS + ph4 #t1 round to integer + FRINTX + asl t1+8 restore sign from x + asl x+8 + ror t1+8 + +ret FPROCEXIT restore env & raise any new exceptions + plb + + lda #^t1 return a pointer to the result + sta x+2 + lda #t1 + sta x + creturn 4:x + +onehalf dc f'0.5' + 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); +* +* Returns x * 2^n. +* +**************************************************************** +* +scalbn start +scalbnf entry +scalbnl entry + using MathCommon2 + + phb place x in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + + pla get n + phy + phx + + pha compute the value + ph4 #t1 + FSCALBX + + plb + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* double trunc(double x); +* +* Truncates x to an integer (discarding fractional part). +* +**************************************************************** +* +trunc start +truncf entry +truncl entry + using MathCommon2 + + phb place the number in a work area + plx + ply + phk + plb + pla + sta t1 + pla + sta t1+2 + pla + sta t1+4 + pla + sta t1+6 + pla + sta t1+8 + phy + phx + plb + + ph4 #t1 compute the value + FTINTX + + ldx #^t1 return a pointer to the result + lda #t1 + rtl + end + +**************************************************************** +* +* float and long double versions of functions in SysFloat +* +**************************************************************** +* +acosf start +acosl entry + jml acos + end + +asinf start +asinl entry + jml asin + end + +atanf start +atanl entry + jml atan + end + +atan2f start +atan2l entry + jml atan2 + end + +ceilf start +ceill entry + jml ceil + end + +cosf start +cosl entry + jml cos + end + +coshf start +coshl entry + jml cosh + end + +expf start +expl entry + jml exp + end + +fabsf start +fabsl entry + jml fabs + end + +floorf start +floorl entry + jml floor + end + +fmodf start +fmodl entry + jml fmod + end + +frexpf start +frexpl entry + jml frexp + end + +ldexpf start +ldexpl entry + jml ldexp + end + +logf start +logl entry + jml log + end + +log10f start +log10l entry + jml log10 + end + +powf start +powl entry + jml pow + end + +sinf start +sinl entry + jml sin + end + +sinhf start +sinhl entry + jml sinh + end + +sqrtf start +sqrtl entry + jml sqrt + end + +tanf start +tanl entry + jml tan + end + +tanhf start +tanhl entry + jml tanh + end diff --git a/math2.macros b/math2.macros index ba5bd1a..85cf3de 100644 --- a/math2.macros +++ b/math2.macros @@ -92,6 +92,285 @@ rtl mend MACRO +&LAB PH4 &N1 + LCLC &C +&LAB ANOP +&C AMID &N1,1,1 + AIF "&C"="#",.D + AIF S:LONGA=1,.A + REP #%00100000 +.A + AIF "&C"<>"{",.B +&C AMID &N1,L:&N1,1 + AIF "&C"<>"}",.G +&N1 AMID &N1,2,L:&N1-2 + LDY #2 + LDA (&N1),Y + PHA + LDA (&N1) + PHA + AGO .E +.B + AIF "&C"<>"[",.C + LDY #2 + LDA &N1,Y + PHA + LDA &N1 + PHA + AGO .E +.C + LDA &N1+2 + PHA + LDA &N1 + PHA + AGO .E +.D +&N1 AMID &N1,2,L:&N1-1 + PEA +(&N1)|-16 + PEA &N1 + AGO .F +.E + AIF S:LONGA=1,.F + SEP #%00100000 +.F + MEXIT +.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 +&l inc4 &a +&l ~setm + inc &a + 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 +&l cmpl &n1,&n2 + lclb &yistwo +&l ~setm + ~lda.h &n1 + ~op.h cmp,&n2 + bne ~a&SYSCNT + ~lda &n1 + ~op cmp,&n2 +~a&SYSCNT anop + ~restm + mend + MACRO &LAB FCLASSS &LAB PEA $021C LDX #$090A @@ -121,3 +400,248 @@ LDX #$090A JSL $E10000 MEND + MACRO +&LAB FCMPX +&LAB PEA $0008 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FEXP2X +&LAB PEA $000A + LDX #$0B0A + JSL $E10000 + MEND + MACRO +&LAB FEXP1X +&LAB PEA $000C + LDX #$0B0A + JSL $E10000 + MEND + MACRO +&LAB FLN1X +&LAB PEA $0004 + LDX #$0B0A + JSL $E10000 + MEND + MACRO +&LAB FLOG2X +&LAB PEA $0002 + LDX #$0B0A + JSL $E10000 + MEND + MACRO +&LAB FLOGBX +&LAB PEA $001A + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FX2I +&LAB PEA $0410 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FTINTX +&LAB PEA $0016 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FRINTX +&LAB PEA $0014 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FXPWRY +&LAB PEA $0012 + LDX #$0B0A + JSL $E10000 + MEND + MACRO +&LAB FREMX +&LAB PEA $000C + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSCALBX +&LAB PEA $0018 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSUBX +&LAB PEA $0002 + LDX #$090A + JSL $E10000 + 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 FX2C +&LAB PEA $0510 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FCPXX +&LAB PEA $0A + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FNEXTX +&LAB PEA $001E + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FX2X +&LAB PEA $0010 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FCPXD +&LAB PEA $010A + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FNEXTD +&LAB PEA $011E + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FD2X +&LAB PEA $010E + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FS2X +&LAB PEA $020E + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FNEXTS +&LAB PEA $021E + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FCPXS +&LAB PEA $020A + 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 FSETXCP +&LAB PEA $0015 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FADDX +&LAB PEA $0000 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FADDI +&LAB PEA $0400 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSUBI +&LAB PEA $0402 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FMULX +&LAB PEA $0004 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FSQRTX +&LAB PEA $0012 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FLNX +&LAB PEA $0000 + LDX #$0B0A + JSL $E10000 + MEND + MACRO +&lab _SDivide +&lab ldx #$0A0B + jsl $E10000 + MEND + MACRO +&LAB FMULI +&LAB PEA $0404 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FDIVI +&LAB PEA $0406 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FDIVX +&LAB PEA $0006 + LDX #$090A + JSL $E10000 + MEND + MACRO +&LAB FXPWRI +&LAB PEA $0010 + LDX #$0B0A + JSL $E10000 + MEND diff --git a/stdio.asm b/stdio.asm index d17de58..af88cd5 100644 --- a/stdio.asm +++ b/stdio.asm @@ -2179,7 +2179,7 @@ rts creturn 4:s **************************************************************** * perror start -maxErr equ ENOSPC max error in sys_errlist +maxErr equ EILSEQ max error in sys_errlist s equ 4 string address @@ -3010,6 +3010,7 @@ sys_errlist start dc a4'EACCESS' dc a4'EEXISTS' dc a4'ENOSPC' + dc a4'EILSEQ' ! Note: if more errors are added, change maxErr in perror() and strerror(). @@ -3025,6 +3026,7 @@ EMFILE cstr 'too many files are open' EACCESS cstr 'access bits prevent the operation' EEXISTS cstr 'the file exists' ENOSPC cstr 'the file is too large' +EILSEQ cstr 'encoding error' end **************************************************************** diff --git a/stdlib.asm b/stdlib.asm index 8b3a183..b45f250 100644 --- a/stdlib.asm +++ b/stdlib.asm @@ -638,6 +638,47 @@ addr equ 1 lldiv_t ds 16 end +**************************************************************** +* +* int mblen(const char *s, size_t n) +* +* Inputs: +* s - NULL or pointer to character +* n - maximum number of bytes to inspect +* +* Outputs: +* If s is NULL, returns 0, indicating encodings are not +* state-dependent. Otherwise, returns 0 if s points to a +* null character, -1 if the next n or fewer bytes do not +* form a valid character, or the number of bytes forming +* a valid character. +* +* Note: This implementation assumes we do not support actual +* multi-byte or state-dependent character encodings. +* +**************************************************************** +* +mblen start + + csubroutine (4:s,4:n) + ldx #0 + lda s if s == NULL + ora s+2 + beq ret return 0 + lda n if n == 0 + ora n+2 + bne readchar + dex return -1 + bra ret +readchar lda [s] if *s == '\0' + and #$00FF + beq ret return 0 + inx else return 1 + +ret stx n + creturn 2:n + end + **************************************************************** * * void qsort(base, count, size, compar) @@ -877,6 +918,31 @@ srand start brl ~RANX2 end +**************************************************************** +* +* strtof - convert a string to a float +* strtold - convert a string to a long double +* +* Inputs: +* str - pointer to the string +* ptr - pointer to a pointer; a pointer to the first +* char past the number is placed here. If ptr is +* nil, no pointer is returned +* +* Outputs: +* X-A - pointer to result +* +* Note: These are currently implemented by just calling strtod +* (in SysFloat). As such, all of these function really +* return values in the SANE extended format. +* +**************************************************************** +* +strtold start +strtof entry + jml strtod + end + **************************************************************** * * strtol - convert a string to a long @@ -1610,8 +1676,37 @@ empty ds 2 **************************************************************** * -* void __va_end(list) -* va_list list; +* void __record_va_info(va_list ap); +* +* Record that a traversal of variable arguments has finished. +* Data is recorded in the internal va info that will be used +* to remove variable arguments at the end of the function. +* +* Inputs: +* ap - the va_list +* +**************************************************************** +* +__record_va_info start +va_info_ptr equ 1 pointer to the internal va info + + csubroutine (4:ap),4 + ldy #4 get pointer to internal va info + lda [ap],y + sta va_info_ptr + stz va_info_ptr+2 + + lda [ap] update end of variable arguments + cmp [va_info_ptr] + blt ret + sta [va_info_ptr] + +ret creturn + end + +**************************************************************** +* +* void __va_end(internal_va_info *list); * * Remove variable length arguments from the stack. * diff --git a/string.asm b/string.asm index 7bfd5fe..9d3b3bc 100644 --- a/string.asm +++ b/string.asm @@ -763,6 +763,31 @@ lb4 long M rtl end +**************************************************************** +* +* int strcoll(const char *s1, const char *s2); +* +* Compare *s1 to *s2 based on current locale's collation order. +* If *s1 < *s2 then return a negative number; if they are +* equal, return 0; otherwise, return a positive number. +* +* Inputs: +* s1 - first string ptr +* s2 - second string ptr +* +* Outputs: +* A - result +* +* Notes: +* The current implementation assumes all supported locales +* have the same collation order as given by strcmp. +* +**************************************************************** +* +strcoll start + jml strcmp + end + **************************************************************** * * strcpy - string copy @@ -1758,3 +1783,44 @@ lb10 ldx set+2 get the return value isp ds 4 internal state pointer (isp) end + +**************************************************************** +* +* size_t strxfrm(char *s1, const char *s2, size_t n); +* +* Transform string *s2 into *s1, such that two output strings +* from strxfrm will compare the same way with strcmp that the +* input strings would with strcoll. Writes at most n bytes. +* +* Inputs: +* s1 - output string pointer +* s2 - input string pointer +* n - max length to write +* +* Outputs: +* *s1 - transformed output string (if it fits) +* A - length of full transformed string +* (not including terminating null) +* +* Notes: +* The current implementation assumes all supported locales +* have the same collation order as given by strcmp. +* +**************************************************************** +* +strxfrm start + + csubroutine (4:s1,4:s2,4:n),4 +len equ 1 length of s2 + + ph4 s2 len = strlen(s2) + jsl strlen + sta len + stx len+2 + cmpl len,n if len < n + bge ret + ph4 s2 + ph4 s1 + jsl strcpy strcpy(s1,s2) +ret creturn 4:len return len + end diff --git a/string.macros b/string.macros index e13001c..da86bdb 100644 --- a/string.macros +++ b/string.macros @@ -555,3 +555,15 @@ &l bne *+5 brl &bp mend + macro +&l cmpl &n1,&n2 + lclb &yistwo +&l ~setm + ~lda.h &n1 + ~op.h cmp,&n2 + bne ~a&SYSCNT + ~lda &n1 + ~op cmp,&n2 +~a&SYSCNT anop + ~restm + mend diff --git a/time.asm b/time.asm index b2b0a8b..52e4dcc 100644 --- a/time.asm +++ b/time.asm @@ -543,3 +543,654 @@ lb1 lda count plb creturn 4:tptr end + +**************************************************************** +* +* size_t strftime( +* char * restrict s, +* size_t maxsize, +* const char * restrict format, +* const struct tm * restrict timeptr); +* +* Inputs: +* s - pointer to output buffer +* maxsize - max number of bytes to write +* format - format string +* timeptr - the time/date +* +* Outputs: +* s - formatted string representation of the time/date +* returns length of s (not including terminating null), +* or 0 if maxsize is too small +* +**************************************************************** +* +strftime start + + csubroutine (4:s,4:maxsize,4:format,4:timeptr),14 +substfmt equ 1 substitute format str (used if non-null) +s_orig equ substfmt+2 original s pointer (start of output str) +overflow equ s_orig+4 overflow flag +numstr equ overflow+2 string representation of a number + +numstr_len equ 6 length of numstr + +tm_sec equ 0 displacements into the time record +tm_min equ 2 +tm_hour equ 4 +tm_mday equ 6 +tm_mon equ 8 +tm_year equ 10 +tm_wday equ 12 +tm_yday equ 14 +tm_isdst equ 16 + + phb set data bank = program bank + phk + plb + +;initialization of local variables + stz substfmt substfmt = 0 + lda s s_orig = s + sta s_orig + lda s+2 + sta s_orig+2 + stz overflow overflow = false + +;main loop to process the format string +fmtloop jsr nextch get next character in format + cmp #'%' if it is not '%' + beq dosubst +nonfmt jsr writech write it to the output + bra fmtloop continue format loop +dosubst jsr nextch get next character in format + cmp #'E' if it is 'E' or 'O' + beq skipalt + cmp #'O' + bne dofmt +skipalt jsr nextch skip it +dofmt cmp #'%' if format character is '%' + beq nonfmt write it like an ordinary character + cmp #'@' if fmt chr is outside valid range + blt fmtloop skip it + cmp #'z'+1 + bge fmtloop + and #$003f if we are here, fmt chr is in ['@'..'z'] + asl a convert to jump table position + asl a + tax + lda fmttbl+2,x if there is a substitution + beq fmtcall + sta substfmt do the substitution + bra fmtloop +fmtcall jsr (fmttbl,x) otherwise, call the format routine + bra fmtloop continue format loop + + +;subroutine to get next character in format string (call only from main loop) +;returns with character in a, or exits via strftime_return if character is 0 +nextch lda substfmt if there is a substitute format string + beq nosubst + lda (substfmt) get next character from it + inc substfmt advance subst string pointer + and #$00FF + bne retchar if at end of substitute format string + stz substfmt go back to using main format string +nosubst lda [format] get next character from main fmt string + and #$00FF + beq strftime_return if char is '\0', return from strftime + inc4 format advance fmt string pointer +retchar rts return from nextch + +;code to return from strftime +strftime_return anop + jsr writech write '\0' to output + pla discard nextch return address + lda overflow if there was an overflow + beq ret_good + stz maxsize maxsize = 0 + stz maxsize+2 + bra ret +ret_good clc else + lda s maxsize = s - s_orig - 1 + sbc s_orig + sta maxsize + lda s+2 + sbc s_orig+2 + sta maxsize+2 +ret plb restore program bank + creturn 4:maxsize return maxsize + + +;subroutine to write a character to the output +;input: character in low-order byte of a (high-order byte is ignored) +;leaves x unchanged +writech ldy maxsize if remaining size is 0 + bne writeok + ldy maxsize+2 + bne writeok + lda #1 set overflow flag + sta overflow + rts return +writeok short M write the character to s + sta [s] + long M + inc4 s s++ + dec4 maxsize maxsize-- + rts return + + +;table of formatting routines or substitutions for the conversion specifiers +;first ptr is a routine, second is a subst string - only one should be non-zero +fmttbl anop + dc a2'fmt_invalid,0' @ + dc a2'fmt_A,0' A + dc a2'fmt_B,0' B + dc a2'fmt_C,0' C + dc a2'0,subst_D' D + dc a2'fmt_invalid,0' E + dc a2'0,subst_F' F + dc a2'fmt_G,0' G + dc a2'fmt_H,0' H + dc a2'fmt_I,0' I + dc a2'fmt_invalid,0' J + dc a2'fmt_invalid,0' K + dc a2'fmt_invalid,0' L + dc a2'fmt_M,0' M + dc a2'fmt_invalid,0' N + dc a2'fmt_invalid,0' O + dc a2'fmt_invalid,0' P + dc a2'fmt_invalid,0' Q + dc a2'0,subst_R' R + dc a2'fmt_S,0' S + dc a2'0,subst_T' T + dc a2'fmt_U,0' U + dc a2'fmt_V,0' V + dc a2'fmt_W,0' W + dc a2'0,subst_X' X + dc a2'fmt_Y,0' Y + dc a2'fmt_Z,0' Z + dc a2'fmt_invalid,0' [ + dc a2'fmt_invalid,0' \ + dc a2'fmt_invalid,0' ] + dc a2'fmt_invalid,0' ^ + dc a2'fmt_invalid,0' _ + dc a2'fmt_invalid,0' ` + dc a2'fmt_a,0' a + dc a2'fmt_b,0' b + dc a2'0,subst_c' c + dc a2'fmt_d,0' d + dc a2'fmt_e,0' e + dc a2'fmt_invalid,0' f + dc a2'fmt_g,0' g + dc a2'fmt_h,0' h + dc a2'fmt_invalid,0' i + dc a2'fmt_j,0' j + dc a2'fmt_invalid,0' k + dc a2'fmt_invalid,0' l + dc a2'fmt_m,0' m + dc a2'fmt_n,0' n + dc a2'fmt_invalid,0' o + dc a2'fmt_p,0' p + dc a2'fmt_invalid,0' q + dc a2'0,subst_r' r + dc a2'fmt_invalid,0' s + dc a2'fmt_t,0' t + dc a2'fmt_u,0' u + dc a2'fmt_invalid,0' v + dc a2'fmt_w,0' w + dc a2'0,subst_x' x + dc a2'fmt_y,0' y + dc a2'fmt_z,0' z + +;%a - abbreviated weekday name +fmt_a ldy #tm_wday + lda [timeptr],y + asl a + tay + ldx weekdays,y + lda |0,x + jsr writech + lda |1,x + jsr writech + lda |2,x + brl writech + +;%A - full weekday name +fmt_A ldy #tm_wday + lda [timeptr],y + asl a + tay + ldx weekdays,y +A_loop lda |0,x + and #$00FF + beq A_ret + jsr writech + inx + bra A_loop +A_ret rts + +;%b - abbreviated month name +fmt_b ldy #tm_mon + lda [timeptr],y + asl a + tay + ldx months,y + lda |0,x + jsr writech + lda |1,x + jsr writech + lda |2,x + brl writech + +;%B - full month name +fmt_B ldy #tm_mon + lda [timeptr],y + asl a + tay + ldx months,y +B_loop lda |0,x + and #$00FF + beq A_ret + jsr writech + inx + bra A_loop +B_ret rts + +;%c - date and time +subst_c dc c'%a %b %e %H:%M:%S %Y',i1'0' + +;%C - century +fmt_C jsr format_year + ldx #0 +C_loop lda numstr,x + and #$00FF + cmp #' ' + beq C_skip + jsr writech +C_skip inx + cpx #numstr_len-2 + blt C_loop + rts + +;%d - day of the month (01-31) +fmt_d ldy #tm_mday + brl print2digits_of_field + +;%D - equivalent to %m/%d/%y +subst_D dc c'%m/%d/%y',i1'0' + +;%e - day of the month (1-31, padded with space if a single digit) +fmt_e ldy #tm_mday + lda [timeptr],y + ldy #2 + cmp #10 + bge e_print + tax + lda #' ' + jsr writech + txa + ldy #1 +e_print brl printdigits + +;%F - equivalent to %Y-%m-%d +subst_F dc c'%Y-%m-%d',i1'0' + +;%g - last two digits of week-based year +fmt_g jsr week_number_V + jsr format_year_altbase + brl write_year_2digit + +;%G - week-based year +fmt_G jsr week_number_V + jsr format_year_altbase + brl write_year + +;%h - equivalent to %b +fmt_h brl fmt_b + +;%H - hour (24-hour clock, 00-23) +fmt_H ldy #tm_hour + brl print2digits_of_field + +;%I - hour (12-hour clock, 01-12) +fmt_I ldy #tm_hour + lda [timeptr],y + bne I_adjust + lda #12 +I_adjust cmp #12+1 + blt I_print + sbc #12 +I_print brl print2digits + +;%j - day of the year (001-366) +fmt_j ldy #tm_yday + lda [timeptr],y + inc a + ldy #3 + brl printdigits + +;%m - month number +fmt_m ldy #tm_mon + lda [timeptr],y + inc a + brl print2digits + +;%M - minute +fmt_M ldy #tm_min + brl print2digits_of_field + +;%n - new-line character +fmt_n lda #$0A + brl writech + +;%p - AM/PM +fmt_p ldy #tm_hour + lda [timeptr],y + cmp #12 + bge p_pm + lda #'A' + bra p_write +p_pm lda #'P' +p_write jsr writech + lda #'M' + brl writech + +;%r - time (using 12-hour clock) +subst_r dc c'%I:%M:%S %p',i1'0' + +;%R - equivalent to %H:%M +subst_R dc c'%H:%M',i1'0' + +;%S - seconds +fmt_S ldy #tm_sec + brl print2digits_of_field + +;%t - horizontal tab character +fmt_t lda #$09 + brl writech + +;%T - equivalent to %H:%M:%S +subst_T dc c'%H:%M:%S',i1'0' + +;%u - weekday number (1-7, Monday=1) +fmt_u ldy #tm_wday + lda [timeptr],y + bne u_print + lda #7 +u_print ldy #1 + brl printdigits + +;%U - week number of the year (first Sunday starts week 01) +fmt_U ldy #tm_yday + lda [timeptr],y + clc + adc #7 + sec + ldy #tm_wday + sbc [timeptr],y + jsr div7 + tya + brl print2digits + +;%V - ISO 8601 week number +fmt_V jsr week_number_V + txa + brl print2digits + +;%w - weekday number (0-6, 0=Sunday) +fmt_w ldy #tm_wday + lda [timeptr],y + ldy #1 + brl printdigits + +;%W - week number of the year (first Monday starts week 01) +fmt_W jsr week_number_W + tya + brl print2digits + +;%x - date +subst_x dc c'%m/%d/%y',i1'0' + +;%X - time +subst_X dc c'%T',i1'0' + +;%y - last two digits of year +fmt_y jsr format_year +write_year_2digit anop + lda numstr+4 + jsr writech + lda numstr+5 + brl writech + +;%Y - year +fmt_Y jsr format_year +write_year anop + ldx #0 +Y_loop lda numstr,x + and #$00FF + cmp #' ' + beq Y_skip + jsr writech +Y_skip inx + cpx #numstr_len + blt Y_loop + rts + +;%z - offset from UTC, if available +;we print nothing, because time zone info is not available +fmt_z rts + +;%Z - time zone name or abbreviation, if available +;we print nothing, because time zone info is not available +fmt_Z rts + +fmt_invalid rts + + +;get decimal representation of the year in numstr +;the string is adjusted to have at least four digits +format_year anop + lda #1900 +format_year_altbase anop alt entry point using year base in a + ldx #1 default to signed + clc + ldy #tm_year + adc [timeptr],y + bvc year_ok + ldx #0 use unsigned if signed value overflows +year_ok jsr int2dec + short M,I + ldx #4 +yr_adjlp lda numstr,x adjust year to have >= 4 digits + cmp #'-' + bne yr_adj1 + sta numstr-1,x + bra yr_adj2 +yr_adj1 cmp #' ' + bne yr_adj3 +yr_adj2 lda #'0' + sta numstr,x +yr_adj3 dex + cpx #2 + bge yr_adjlp + long M,I + rts + + +;get the week number as for %W (first Monday starts week 1) +;output: week number in y +week_number_W anop + ldy #tm_wday + lda [timeptr],y + beq W_yday + sec + lda #7 + sbc [timeptr],y +W_yday sec + ldy #tm_yday + adc [timeptr],y + brl div7 + + +;get the ISO 8601 week number (as for %V) and corresponding year adjustment +;output: week number in x, adjusted year base in a (1900-1, 1900, or 1900+1) +week_number_V anop + jsr week_number_W get %W-style week number (kept in x) + tyx + ldy #tm_wday calculate wday for Jan 1 (kept in a) + lda [timeptr],y + sec + ldy #tm_yday + sbc [timeptr],y + clc + adc #53*7 + jsr div7 + cmp #2 if Jan 1 was Tue/Wed/Thu + blt V_adjust + cmp #4+1 + bge V_adjust + inx inc week (week 1 started in last year) +V_adjust txy + bne V_not0 week 0 is really 52 or 53 of last year: + ldx #52 assume 52 + cmp #5 if Jan 1 is Fri + bne V_0notfr + inx last year had week 53 + bra V_0done +V_0notfr cmp #6 else if Jan 1 is Sat + bne V_0done + ldy #tm_year + lda [timeptr],y + dec a + jsr leapyear if last year was a leap year + bne V_0done + inx last year had week 53 +V_0done lda #-1+1900 year adjustment is -1 + bra V_done +V_not0 cpx #53 week 53 might be week 1 of next year: + bne V_noadj + cmp #4 if Jan 1 was Thu + beq V_noadj it is week 53 + cmp #3 else if Jan 1 was Wed + bne V_53is1 + ldy #tm_year + lda [timeptr],y + jsr leapyear and this is a leap year + beq V_noadj it is week 53 +V_53is1 ldx #1 otherwise, it is really week 1 + lda #1+1900 and year adjustment is +1 + rts +V_noadj lda #0+1900 if we get here, year adjustment is 0 +V_done rts + + +;check if a year is a leap year +;input: tm_year value in a +;output: z flag set if a leap year, clear if not; x,y unmodified +leapyear and #$0003 not multiple of 4 => not leap year + bne ly_done + clc calculate year mod 400 + adc #1900-1600 + bpl ly_lp400 + clc + adc #32800 + sec +ly_lp400 sbc #400 + bcs ly_lp400 + adc #400 + beq ly_done multiple of 400 => leap year + sec +ly_lp100 sbc #100 + bcs ly_lp100 + cmp #-100 + bne ly_leap + dec a other multiple of 100 => not leap year + rts +ly_leap lda #0 other multiple of 4 => leap year +ly_done rts + + +;divide a number (treated as unsigned) by 7 +;input: dividend in a +;output: quotient in y, remainder in a, x unmodified +div7 ldy #-1 + sec +sublp iny + sbc #7 + bcs sublp + adc #7 + rts + + +;print the low-order two digits of a field of struct tm +;(with leading zeros, if any) +;input: offset of field in y +print2digits_of_field anop + lda [timeptr],y load the field + +;print the low-order two digits of a number (with leading zeros, if any) +;input: number in a +print2digits anop + ldy #2 print two digits + +;print the low-order digits of a number (with leading zeros, if any) +;input: number in a, how many digits to print in y +printdigits anop +pd1 phy save number of digits to print + ldx #0 treat as signed + jsr int2dec convert to decimal string + sec calculate where to print from + lda #numstr_len + sbc 1,s + ply + tax +pd_loop lda numstr,x print the digits + and #$00FF + cmp #' ' change padding spaces to zeros + bne pd_write + lda #'0' +pd_write jsr writech + inx + cpx #numstr_len + blt pd_loop + rts + + +;get decimal representation of a number, placed in numstr +;input: number in a, signed flag in y +int2dec pha number to convert + pea 0000 pointer to string buffer + tdc + clc + adc #numstr + pha + pea numstr_len length of string buffer + phx signed flag + _Int2Dec + rts + + +weekdays dc a2'sun,mon,tue,wed,thu,fri,sat' +sun dc c'Sunday',i1'0' +mon dc c'Monday',i1'0' +tue dc c'Tuesday',i1'0' +wed dc c'Wednesday',i1'0' +thu dc c'Thursday',i1'0' +fri dc c'Friday',i1'0' +sat dc c'Saturday',i1'0' + +months dc a2'jan,feb,mar,apr,may,jun,jul,aug,sep,oct,nov,dec' +jan dc c'January',i1'0' +feb dc c'February',i1'0' +mar dc c'March',i1'0' +apr dc c'April',i1'0' +may dc c'May',i1'0' +jun dc c'June',i1'0' +jul dc c'July',i1'0' +aug dc c'August',i1'0' +sep dc c'September',i1'0' +oct dc c'October',i1'0' +nov dc c'November',i1'0' +dec dc c'December',i1'0' + end diff --git a/time.macros b/time.macros index c50a85f..d5b39e5 100644 --- a/time.macros +++ b/time.macros @@ -600,3 +600,17 @@ longi off .c mend + macro +&l dec4 &a +&l ~setm + lda &a + bne ~&SYSCNT + dec 2+&a +~&SYSCNT dec &a + ~restm + mend + MACRO +&LAB _INT2DEC +&LAB LDX #$260B + JSL $E10000 + MEND diff --git a/uchar.asm b/uchar.asm new file mode 100644 index 0000000..6484fed --- /dev/null +++ b/uchar.asm @@ -0,0 +1,203 @@ + keep obj/uchar + mcopy uchar.macros + case on + +**************************************************************** +* +* UChar - Unicode utilities +* +* This code implements conversions to and from Unicode. +* It assumes the multibyte character set is Mac OS Roman. +* +**************************************************************** +* +uchar private + copy equates.asm + end + +**************************************************************** +* +* size_t mbrtoc16(char16_t * pc16, const char * s, size_t n, +* mbstate_t * ps); +* +* size_t mbrtoc32(char32_t * pc32, const char * s, size_t n, +* mbstate_t * ps); +* +* Convert a multibyte character to UTF-16 or UTF-32. +* +* Inputs: +* pc16 or pc32 - pointer to output location +* s - pointer to multibyte character +* n - maximum number of bytes to examine +* ps - conversion state +* +* Outputs: +* *pc16 or *pc32 - UTF-16 or UTF-32 code unit +* Returns number of bytes in multibyte character or +* 0 for null character. +* +**************************************************************** +* +mbrtoc16 start + clv v flag clear => doing mbrtoc16 + bra csub + +mbrtoc32 entry + sep #$40 v flag set => doing mbrtoc32 + +csub csubroutine (4:pc16,4:s,4:n,4:ps),0 + + lda s if s == NULL + ora s+2 + bne check_n + stz n call is equivalent to + stz n+2 mbrtoc16(NULL, "", 1, ps), + bra ret so return 0 +check_n lda n if n = 0 + ora n+2 + bne getchar + dec a return (size_t)(-2) + sta n+2 + dec a + sta n + bra ret +getchar ldy #1 assume return value is 1 + lda [s] load character *s + and #$00ff + bne set_rv if *s == '\0' + dey return value is 0 +set_rv sty n set return value + stz n+2 + cmp #$0080 if *s is an ASCII character + blt output store it as-is + asl a else + and #$00FF + tax + lda >macRomanToUCS,x convert it to Unicode +output ldx pc16 if pc16 != NULL + bne storeit + ldx pc16+2 + beq ret +storeit sta [pc16] store result to *pc16 + bvc ret if doing mbrtoc32 + lda #0 + ldy #2 + sta [pc16],y store 0 as high word of result + +ret creturn 4:n + end + + +**************************************************************** +* +* size_t c16rtomb(char * s, char16_t c16, mbstate_t * ps); +* +* Convert a UTF-16 code unit to a multibyte character. +* +* Inputs: +* s - pointer to output location +* c16 - UTF-16 code unit +* ps - conversion state +* +* Outputs: +* *s - converted character +* Returns number of bytes stored, or -1 for error. +* +**************************************************************** +* +c16rtomb start + + csubroutine (4:s,2:c16,4:ps),0 + + lda s if s == NULL, call is equivalent to + ora s+2 c16rtomb(internal_buf, 0, ps), + beq return_1 so return 1 + lda c16 if c16 is an ASCII character + cmp #$0080 + blt storeit store it as-is + short I + ldx #0 +cvt_loop lda >macRomanToUCS,x for each entry in macRomanToUCS + cmp c16 if it matches c16 + beq gotit break and handle the mapping + inx + inx + bne cvt_loop + lda #EILSEQ if no mapping was found + sta >errno errno = EILSEQ + lda #-1 return -1 + sta s + sta s+2 + long I + bra ret +gotit longi off + txa if we found a mapping + lsr a compute the MacRoman character + ora #$0080 +storeit short M store the character + sta [s] + long M,I +return_1 lda #1 return 1 + sta s + stz s+2 + +ret creturn 4:s + end + + +**************************************************************** +* +* size_t c32rtomb(char * s, char16_t c16, mbstate_t * ps); +* +* Convert a UTF-32 code unit to a multibyte character. +* +* Inputs: +* s - pointer to output location +* c16 - UTF-32 code unit +* ps - conversion state +* +* Outputs: +* *s - converted character +* Returns number of bytes stored, or -1 for error. +* +**************************************************************** +* +c32rtomb start + + lda 10,s if char is outside the BMP + beq fixstack + lda #$FFFD substitute REPLACEMENT CHARACTER + bra fs2 + +fixstack lda 8,s adjust stack for call to c16rtomb +fs2 sta 10,s + lda 6,s + sta 8,s + lda 4,s + sta 6,s + lda 2,s + sta 4,s + pla + sta 1,s + jml c16rtomb do the equivalent c16rtomb call + end + + +macRomanToUCS private + dc i2'$00C4, $00C5, $00C7, $00C9, $00D1, $00D6, $00DC, $00E1' + dc i2'$00E0, $00E2, $00E4, $00E3, $00E5, $00E7, $00E9, $00E8' + dc i2'$00EA, $00EB, $00ED, $00EC, $00EE, $00EF, $00F1, $00F3' + dc i2'$00F2, $00F4, $00F6, $00F5, $00FA, $00F9, $00FB, $00FC' + dc i2'$2020, $00B0, $00A2, $00A3, $00A7, $2022, $00B6, $00DF' + dc i2'$00AE, $00A9, $2122, $00B4, $00A8, $2260, $00C6, $00D8' + dc i2'$221E, $00B1, $2264, $2265, $00A5, $00B5, $2202, $2211' + dc i2'$220F, $03C0, $222B, $00AA, $00BA, $03A9, $00E6, $00F8' + dc i2'$00BF, $00A1, $00AC, $221A, $0192, $2248, $2206, $00AB' + dc i2'$00BB, $2026, $00A0, $00C0, $00C3, $00D5, $0152, $0153' + dc i2'$2013, $2014, $201C, $201D, $2018, $2019, $00F7, $25CA' + dc i2'$00FF, $0178, $2044, $00A4, $2039, $203A, $FB01, $FB02' + dc i2'$2021, $00B7, $201A, $201E, $2030, $00C2, $00CA, $00C1' + dc i2'$00CB, $00C8, $00CD, $00CE, $00CF, $00CC, $00D3, $00D4' + dc i2'$F8FF, $00D2, $00DA, $00DB, $00D9, $0131, $02C6, $02DC' + dc i2'$00AF, $02D8, $02D9, $02DA, $00B8, $02DD, $02DB, $02C7' + end diff --git a/uchar.macros b/uchar.macros new file mode 100644 index 0000000..e402109 --- /dev/null +++ b/uchar.macros @@ -0,0 +1,133 @@ + 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 +&l long &a,&b + lclb &i + lclb &m +&a amid &a,1,1 +&m setb ("&a"="M").or.("&a"="m") +&i setb ("&a"="I").or.("&a"="i") + aif c:&b=0,.a +&b amid &b,1,1 +&m setb ("&b"="M").or.("&b"="m").or.&m +&i setb ("&b"="I").or.("&b"="i").or.&i +.a +&l rep #&m*32+&i*16 + aif .not.&m,.b + longa on +.b + aif .not.&i,.c + longi on +.c + mend + macro +&l short &a,&b + lclb &i + lclb &m +&a amid &a,1,1 +&m setb ("&a"="M").or.("&a"="m") +&i setb ("&a"="I").or.("&a"="i") + aif c:&b=0,.a +&b amid &b,1,1 +&m setb ("&b"="M").or.("&b"="m").or.&m +&i setb ("&b"="I").or.("&b"="i").or.&i +.a +&l sep #&m*32+&i*16 + aif .not.&m,.b + longa off +.b + aif .not.&i,.c + longi off +.c + mend