Apple-2gs-SW
/
ORCALib
mirror of https://github.com/byteworksinc/ORCALib.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into gno-version

This commit is contained in:
Stephen Heumann 2022-01-10 19:07:55 -06:00
parent 3dac15e6b9 997e430562
commit 522a6fc3f8
19 changed files with 4729 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
cc.asm
View File

@ -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
****************************************************************

14
cc.macros
View File

@ -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

1
equates.asm
View File

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

23
fpextra.asm
View File

@ -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

6
fpextra.macros
View File

@ -34,3 +34,9 @@
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FRINTX
&LAB PEA $0014
LDX #$090A
JSL $E10000
MEND

31
int64.asm
View File

@ -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

107
locale.asm Normal file
View File

@ -0,0 +1,107 @@
keep obj/locale
mcopy locale.macros
case on
****************************************************************
*
* Locale - locale support
*
* This currently implements a minimalistic version of the
* <locale.h> 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

93
locale.macros Normal file
View File

@ -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

4
make
View File

@ -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}

2750
math2.asm
View File

File diff suppressed because it is too large Load Diff

524
math2.macros
View File

@ -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

4
stdio.asm
View File

@ -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
****************************************************************

99
stdlib.asm
View File

@ -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.
*

66
string.asm
View File

@ -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

12
string.macros
View File

@ -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

651
time.asm
View File

@ -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

14
time.macros
View File

@ -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

203
uchar.asm Normal file
View File

@ -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

133
uchar.macros Normal file
View File

@ -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