ORCA-C/Scanner.asm
Stephen Heumann 785a6997de Record source file changes within a function as part of debug info.
This affects functions whose body spans multiple files due to includes, or is treated as doing so due to #line directives. ORCA/C will now generate a COP 6 instruction to record each source file change, allowing debuggers to properly track the flow of execution across files.
2022-02-05 18:32:11 -06:00

1024 lines
28 KiB
NASM

mcopy scanner.macros
datachk off
****************************************************************
*
* ConvertHexFloat - Parse a hexadecimal floating-point constant
*
* Inputs:
* str - pointer to the string (p-string)
*
* Outputs:
* Returns the extended value (or a NAN on error).
*
****************************************************************
*
ConvertHexFloat start scanner
subroutine (4:str),26
end_idx equ 0 index one past end of string
got_period equ end_idx+2 flag: have we encountered a period?
full equ got_period+2 flag: is mantissa full?
mantissa equ full+2 mantissa
extrabits equ mantissa+8 extra bits that do not fit in mantissa
exp_adjust equ extrabits+2 exponent adjustment
negate_exp equ exp_adjust+2 flag: is exponent negative?
exp equ negate_exp+2 exponent
nonzero equ exp+2 flag: is mantissa non-zero?
got_digit equ nonzero+2 flag: got any digit yet?
stz got_period no period yet
stz full not full yet
stz negate_exp assume positive exponent
stz got_digit no digit yet
stz exp exponent value = 0
stz mantissa mantissa = 0.0
stz mantissa+2
stz mantissa+4
stz mantissa+6
stz extrabits extrabits = 0
lda #63 exponent adjustment = 63
sta exp_adjust
lda [str] end_idx = string length + 1
and #$00FF
inc a
sta end_idx
ldy #1 string index = 1
jsr nextch check for 0x or 0X prefix
cmp #'0'
beq check_x
brl error
check_x jsr nextch
and #$df
cmp #'X'
beq digitlp
brl error
digitlp jsr nextch get a character
ldx got_period if there was no period yet
bne check_p
cmp #'.' if character is '.'
bne check_p
dec got_period flag that we got a period
bra digitlp loop for another digit
check_p cmp #'p' if character is 'p' or 'P'
beq normal mantissa is done: normalize it
cmp #'P'
beq normal
sta got_digit flag that we (presumably) got a digit
jsr hexdigit must be a hex digit: get value
ldx full if mantissa is full
beq donibble
ora extrabits record extra bits for rounding
sta extrabits
lda got_period if we are not past the period
bne digitlp
lda #4 exp_adjust += 4
clc
adc exp_adjust
; bvs error no overflow with p-string input
sta exp_adjust
bra digitlp loop for another digit
donibble xba get nibble value in high bits
asl a
asl a
asl a
asl a
ldx #4 for each bit in nibble:
bitloop bit mantissa+6 if mantissa is now full
bpl notfull
inc full full = true
sta extrabits record next bit(s) for rounding
lda got_period if we are not past the period
bne digitlp
txa exp_adjust += number of extra bits
clc
adc exp_adjust
sta exp_adjust
bra digitlp loop for another digit
notfull asl a shift bit into mantissa
rol mantissa
rol mantissa+2
rol mantissa+4
rol mantissa+6
bit got_period if we are past the period
bpl nextbit
dec exp_adjust exp_adjust-- (no overflow w/ p-str)
nextbit dex
bne bitloop
bra digitlp
normal lda got_digit check that there was a mantissa digit
bne chkzero
brl error
chkzero lda mantissa check if mantissa is nonzero
ora mantissa+2
ora mantissa+4
ora mantissa+6
sta nonzero set nonzero flag as appropriate
beq do_exp if mantissa is nonzero, normalize:
lda mantissa+6 if high bit of mantissa is not 1:
bmi do_exp do
normallp dec exp_adjust exp_adjust--
asl mantissa shift mantissa left one bit
rol mantissa+2
rol mantissa+4
rol mantissa+6
bpl normallp while high bit of mantissa is not 1
do_exp jsr nextch get next character
cmp #'+' if it is '+'
bne chkminus
jsr nextch ignore it and get next char
bra exploop
chkminus cmp #'-' else if it is '-'
bne exploop
jsr nextch get next character
inc negate_exp flag that exponent is negative
exploop jsr decdigit for each exponent digit
asl exp exp = exp*10 + digit
pei exp
bcs bigexp
bmi bigexp
asl exp
asl exp
bcs bigexp
bmi bigexp
adc 1,s
bvs bigexp
clc
adc exp
bvs bigexp
sta exp
pla
jsr nextch
bpl exploop
bra neg_exp
bigexp pla
lda #$7fff if exponent value overflows
sta exp exp = INT_MAX
bigexplp jsr nextch
bpl bigexplp
neg_exp lda negate_exp if exponent is negative
beq finalexp
lda exp negate exp
eor #$ffff
inc a
sta exp
finalexp lda exp add in exponent adjustment
clc
adc exp_adjust
bvc expdone if addition overflows
lda #$7fff positive exponent -> INT_MAX
ldx negate_exp
beq expdone
inc a negative exponent -> INT_MIN
expdone ldx nonzero if value is zero
bne bias
txa exponent field = 0
bra storeexp
bias clc else
adc #16383 compute biased exp. [-16385..49150]
storeexp sta exp
cmp #32767 if it is [0..32766], it is valid
blt round
cmp #32767+16383+1 if it is larger, generate an infinity
blt inf otherwise, denormalize:
denormlp lsr mantissa+6 while biased exponent is negative:
ror mantissa+4 shift mantissa left one bit
ror mantissa+2
ror mantissa
ror extrabits adjust extrabits
bcc dn_next
lda extrabits
ora #1
sta extrabits
dn_next inc exp exp++
bmi denormlp
round lda extrabits implement SANE/IEEE round-to-nearest:
cmp #$8000 if less than halfway to next number
blt done return value as-is
bne roundup if more than halfway to next: round up
lda mantissa if exactly halfway to next number
lsr a if least significant bit is 0
bcc done return value as-is
roundup inc mantissa otherwise, round up to next number:
bne done increment mantissa
inc mantissa+2
bne done
inc mantissa+4
bne done
inc mantissa+6
bne done
lda #$8000 if mantissa overflowed:
sta mantissa+6 mantissa = 1.0
inc exp exp++ (could generate an infinity)
done jsr nextch if we have not consumed the full input
bpl error flag an error
lda mantissa done: store return value
sta >retval
lda mantissa+2
sta >retval+2
lda mantissa+4
sta >retval+4
lda mantissa+6
sta >retval+6
lda exp
sta >retval+8
bra ret
inf lda #32767 infinity: exponent field = 32767
sta >retval+8 mantissa = 1.0
inc a
sta >retval+6
asl a
sta >retval+4
sta >retval+2
sta >retval+0
bra ret
error lda #32767 bad input: return NANASCBIN
sta >retval+8
lda #$C011
sta >retval+6
lda #0
sta >retval+4
sta >retval+2
sta >retval
ret lda #retval
sta str
lda #^retval
sta str+2
return 4:str
;get next character of string, or -1 if none (nz flags also set based on value)
nextch cpy end_idx
bge no_ch
lda [str],y
iny
and #$00FF
rts
no_ch lda #-1
rts
;get value of A, taken as a hex digit
;branches to error if it is not a valid digit
hexdigit cmp #'0'
blt baddigit
cmp #'9'+1
bge letter
and #$000F
rts
letter and #$df
cmp #'A'
blt baddigit
cmp #'F'+1
bge baddigit
and #$000F
adc #9
rts
;get value of A, taken as a decimal digit
;branches to error if it is not a valid digit
decdigit cmp #'0'
blt baddigit
cmp #'9'+1
bge baddigit
and #$000F
rts
baddigit pla
brl error
retval ds 10
end
****************************************************************
*
* Convertsl - Convert a string to a long integer
*
* Inputs:
* str - pointer to the string
*
* Outputs:
* Returns the value.
*
* Notes:
* Assumes the string is valid.
*
****************************************************************
*
Convertsl start scanner
val equ 0 return value
subroutine (4:str),4
stz val initialize the number to zero
stz val+2
lda [str] set X to the number of characters
and #$00FF
tax
ldy #1 Y is the disp into the string
lb1 asl val val := val*10
rol val+2
ph2 val+2
lda val
asl val
rol val+2
asl val
rol val+2
adc val
sta val
pla
adc val+2
sta val+2
lda [str],Y add in the new digit
and #$000F
adc val
sta val
bcc lb2
inc val+2
lb2 iny next character
dex
bne lb1
return 4:val
end
****************************************************************
*
* Convertsll - Convert a string to a long long integer
*
* Inputs:
* qval - pointer to location to save value
* str - pointer to the string
*
* Outputs:
* Saves the value to [qval].
*
* Notes:
* Assumes the string is valid.
*
****************************************************************
*
Convertsll start scanner
disp equ 0 displacement into the string
count equ 2 number of characters remaining to read
subroutine (4:qval,4:str),4
lda [str] set count to length of string
and #$00FF
sta count
lda #1 start reading from character 1
sta disp
ph8 #0 initialize the number to zero
bra lb1a
lb1 ph8 #10 multiply by 10
jsl ~UMUL8
lb1a pea $0000
pea $0000
pea $0000
ldy disp
lda [str],Y add in the new digit
and #$000F
pha
jsl ~ADD8
lb2 inc disp next character
dec count
bne lb1
pl8 [qval] save the value
return
end
****************************************************************
*
* KeyPress - Has a key been pressed?
*
* If a key has not been pressed, this function returns
* false. If a key has been pressed, it clears the key
* strobe. If the key was an open-apple ., a terminal exit
* is performed; otherwise, the function returns true.
*
****************************************************************
*
KeyPress start scanner
KeyPressGS kpRec
lda >kpAvailable
beq rts
ReadKeyGS rkRec
lda >rkKey
cmp #'.'
bne lb1
lda >rkModifiers
and #$0100
beq lb1
ph2 #4
jsl TermError
lb1 lda #1
rts rtl
kpRec dc i'3'
kpKey ds 2
kpModifiers ds 2
kpAvailable ds 2
rkRec dc i'2'
rkKey ds 2
rkModifiers ds 2
end
****************************************************************
*
* NextCh - Read the next character from the file, skipping comments
*
* Outputs:
* ch - character read
*
****************************************************************
*
NextCh start scanner
eofChar equ 0 end of file character
eolChar equ 13 end of line character
stackFrameSize equ 14 size of the work space
maxPath equ 255 max length of a path name
fp equ 1 file record pointer; work pointer
p1 equ 5 work pointer
p2 equ 9
cch equ 13
enum (illegal,ch_special,ch_dash,ch_plus,ch_lt,ch_gt,ch_eq,ch_exc),0
enum (ch_and,ch_bar,ch_dot,ch_white,ch_eol,ch_eof,ch_char,ch_string)
enum (ch_asterisk,ch_slash,ch_percent,ch_carot,ch_pound,ch_colon)
enum (ch_backslash,letter,digit)
tsc create stack frame
sec
sbc #stackFrameSize
tcs
phd
tcd
! {flag for preprocessor check}
! if lastWasReturn then
! lastWasReturn := charKinds[ord(ch)] in [ch_eol,ch_white]
! else
! lastWasReturn := charKinds[ord(ch)] = ch_eol;
lda ch
asl A
tax
lda charKinds,X
ldy #1
cmp #ch_eol
beq pf2
ldx lastWasReturn
beq pf1
cmp #ch_white
beq pf2
pf1 dey
pf2 sty lastWasReturn
! 1:
lab1 anop
! if chPtr = eofPtr then begin {flag end of file if we're there}
lda chPtr
cmp eofPtr
bne la1
lda chPtr+2
cmp eofPtr+2
beq la2
la1 brl lb5
la2 anop
! if not lastWasReturn then begin
! lastWasReturn := true;
! needWriteLine := true;
! ch := chr(eolChar);
! goto le2;
! end; {if}
lda lastWasReturn
bne la3
lda #1
sta lastWasReturn
sta needWriteLine
lda #eolChar
sta ch
brl le2
! ch := chr(eofChar);
la3 stz ch
! if needWriteLine then begin {do eol processing}
! WriteLine;
! wroteLine := false;
! lineNumber := lineNumber+1;
! firstPtr := chPtr;
! end; {if}
lda needWriteLine
beq lb1
jsl WriteLine
stz wroteLine
inc lineNumber
move4 chPtr,firstPtr
lb1 anop
! if fileList = nil then begin
lda fileList
ora fileList+2
bne lb3
lb2 anop
! skipping := false;
sta skipping
! end {if}
brl le2
! else begin
lb3 anop
! {purge the current source file}
! with ffDCBGS do begin
! pCount := 5;
lda #5
sta ffDCBGS
! action := 7;
lda #7
sta ffDCBGS+2
! name := @includeFileGS.theString
lla ffDCBGS+12,includeFileGS+2
! end; {with}
! FastFileGS(ffDCBGS);
FastFileGS ffDCBGS
! fp := fileList; {open the file that included this one}
move4 fileList,fp
! fileList := fp^.next;
ldy #2
lda [fp]
sta fileList
lda [fp],Y
sta fileList+2
! includeFileGS := fp^.name;
! sourceFileGS := fp^.sname;
add4 fp,#4,p1
add4 fp,#4+maxPath+4,p2
short M
ldy #maxPath+3
lb4 lda [p1],Y
sta includeFileGS,Y
lda [p2],Y
sta sourceFileGS,Y
dey
bpl lb4
long M
! changedSourceFile := true;
lda #1
sta changedSourceFile
! lineNumber := fp^.lineNumber;
ldy #4+maxPath+4+maxPath+4
lda [fp],Y
sta lineNumber
! ReadFile;
jsl ReadFile
! eofPtr := pointer(ord4(bofPtr) + ffDCBGS.fileLength);
add4 bofPtr,ffDCBGS+46,eofPtr
! chPtr := pointer(ord4(bofPtr) + fp^.disp);
! includeChPtr := chPtr;
! firstPtr := chPtr;
ldy #4+maxPath+4+maxPath+4+2
clc
lda bofPtr
adc [fp],Y
sta chPtr
sta firstPtr
sta includeChPtr
lda bofPtr+2
iny
iny
adc [fp],Y
sta chPtr+2
sta firstPtr+2
sta includeChPtr+2
! needWriteLine := false;
stz needWriteLine
! dispose(fp);
ph4 fp
jsl ~Dispose
! includeCount := includeCount + 1;
inc includeCount
! goto 1;
brl lab1
! end; {if}
! end {if}
! else begin
lb5 anop
! ch := chr(chPtr^); {fetch the character}
move4 chPtr,p1
lda [p1]
and #$00FF
sta ch
! if needWriteLine then begin {do eol processing}
! WriteLine;
! wroteLine := false;
! lineNumber := lineNumber+1;
! firstPtr := chPtr;
! end; {if}
lda needWriteLine
beq lb6
jsl WriteLine
stz wroteLine
inc lineNumber
move4 chPtr,firstPtr
lb6 anop
! needWriteLine := charKinds[ord(ch)] = ch_eol;
stz needWriteLine
lda ch
asl A
tax
lda charKinds,X
cmp #ch_eol
bne lb7
inc needWriteLine
lb7 anop
! chPtr := pointer(ord4(chPtr) + 1);
inc4 chPtr
! 2: if (ch = '\') and (charKinds[chPtr^] = ch_eol) then begin
! chPtr := pointer(ord4(chPtr) + 1);
! DebugCheck;
! needWriteLine := true;
! goto 1;
! end; {if}
lab2 lda ch
cmp #'\'
bne lb8
move4 chPtr,p1
lda [p1]
and #$00FF
asl A
tax
lda charKinds,X
cmp #ch_eol
bne lb8
inc4 chPtr
jsr DebugCheck
lda #1
sta needWriteLine
brl lab1
lb8 anop
! {check for debugger code}
! if needWriteLine then
! DebugCheck;
lda needWriteLine
beq lb9
jsr DebugCheck
lb9 anop
!
! {if it's a comment, skip the comment }
! {characters and return a space. }
! if (not doingStringOrCharacter) and (ch = '/') and (chPtr <> eofPtr)
! and ((chr(chPtr^) = '*')
! or ((chr(chPtr^) = '/') and allowSlashSlashComments))then begin
lda doingStringOrCharacter
jne lc6
lda ch
cmp #'/'
jne lc7
lda chPtr
cmp eofPtr
bne lc1
lda chPtr+2
cmp eofPtr+2
jeq lc6
lc1 move4 chPtr,p1
lda [p1]
and #$00FF
cmp #'*'
beq lc1a
cmp #'/'
jne lc6
ldx allowSlashSlashComments
jeq lc6
! cch := chr(chPtr^);
lc1a sta cch
! chPtr := pointer(ord4(chPtr)+1); {skip the '*' or '/'}
inc4 chPtr
! done := false;
! repeat
lc2 anop
! if chPtr = eofPtr then {if at eof, we're done}
! done := true
lda chPtr
cmp eofPtr
bne lc2a
lda chPtr+2
cmp eofPtr+2
jeq lc5
! else if (cch = '/') and (chPtr^ = return) then begin
lc2a lda cch
cmp #'/'
bne lc2b
! if charKinds[ord(ch)] = ch_eol then
! done := true
! else
! chPtr := pointer(ord4(chPtr)+1);
move4 chPtr,p1
lda [p1]
and #$00FF
asl A
tax
lda charKinds,X
cmp #ch_eol
jeq lc5
inc4 chPtr
bra lc2
! end {else if}
! else begin
! ch := chr(chPtr^); {check for terminating */}
lc2b move4 chPtr,p1
lda [p1]
and #$00FF
sta ch
! if charKinds[ord(ch)] = ch_eol then begin
! WriteLine;
! wroteLine := false;
! lineNumber := lineNumber+1;
! firstPtr := pointer(ord4(chPtr)+1);
! end; {if}
asl A
tax
lda charKinds,X
cmp #ch_eol
bne lc3
jsl WriteLine
stz wroteLine
inc lineNumber
add4 chPtr,#1,firstPtr
lc3 anop
! chPtr := pointer(ord4(chPtr)+1);
inc4 chPtr
! if ch = '*' then
! if (chr(chPtr^) = '/') and (chPtr <> eofPtr) then begin
! chPtr := pointer(ord4(chPtr)+1);
! done := true;
! end; {if}
lda ch
cmp #'*'
jne lc2
lda chPtr
cmp eofPtr
bne lc4
lda chPtr+2
cmp eofPtr+2
jeq lc2
lc4 move4 chPtr,p1
lda [p1]
and #$00FF
cmp #'/'
jne lc2
inc4 chPtr
! end; {else}
! until done;
lc5 anop
! {return a space as the result}
! ch := ' ';
lda #' '
sta ch
! end {if}
brl le2
! else if (ch = '?') and (chPtr <> eofPtr) and (chr(chPtr^) = '?') then begin
lc6 lda ch
lc7 cmp #'?'
jne le2
lda chPtr
cmp eofPtr
bne lc8
lda chPtr+2
cmp eofPtr+2
jeq le2
lc8 move4 chPtr,p1
lda [p1]
and #$00FF
cmp #'?'
jne le2
! chPtr2 := pointer(ord4(chPtr) + 1);
inc4 p1
! if (chPtr2 <> eofPtr)
lda p1
cmp eofPtr
bne ld1
lda p1+2
cmp eofPtr+2
beq le2
ld1 anop
! and (chr(chPtr2^) in ['(','<','/','''','=',')','>','!','-']) then begin
! case chr(chPtr2^) of
! '(': ch := '[';
lda [p1]
and #$00FF
cmp #'('
bne ld2
lda #'['
bra le1
! '<': ch := '{';
ld2 cmp #'<'
bne ld3
lda #'{'
bra le1
! '/': ch := '\';
ld3 cmp #'/'
bne ld4
lda #'\'
bra le1
! '''': ch := '^';
ld4 cmp #''''
bne ld5
lda #'^'
bra le1
! '=': ch := '#';
ld5 cmp #'='
bne ld6
lda #'#'
bra le1
! ')': ch := ']';
ld6 cmp #')'
bne ld7
lda #']'
bra le1
! '>': ch := '}';
ld7 cmp #'>'
bne ld8
lda #'}'
bra le1
! '!': ch := '|';
ld8 cmp #'!'
bne ld9
lda #'|'
bra le1
! '-': ch := '~';
ld9 cmp #'-'
bne le2
lda #'~'
! end; {case}
le1 sta ch
! chPtr := pointer(ord4(chPtr2) + 1);
add4 chPtr,#2
! goto 2;
brl lab2
! end; {if}
! end; {if}
! end; {else}
le2 anop
pld
tsc
clc
adc #stackFrameSize
tcs
rtl
! end; {NextCh}
;
; Local subroutine
;
enum (stop,break,autogo),0 line number debug types
! procedure DebugCheck;
!
! {Check for debugger characters; process if found }
!
! begin {DebugCheck}
DebugCheck anop
! if chPtr = eofPtr then
! debugType := stop
lda chPtr
ldx chPtr+2
cmp eofPtr
bne db1
cpx eofPtr+2
bne db1
stz debugType
bra db5
! else if ord(chPtr^) = $07 then begin
db1 sta p1
stx p1+2
lda [p1]
and #$00FF
cmp #$07
bne db2
! debugType := break
lda #break
sta debugType
bra db3
! else if ord(chPtr^) = $06 then
db2 cmp #$06
bne db4
! debugType := autoGo;
lda #autoGo
sta debugType
! chPtr := pointer(ord4(chPtr) + 1);
db3 inc4 chPtr
! end {if}
bra db5
! else
! debugType := stop;
db4 stz debugType
! end; {DebugCheck}
db5 rts
end
****************************************************************
*
* SetDateTime - set up the date/time strings
*
* Outputs:
* dateStr - date
* timeStr - time string
*
****************************************************************
*
SetDateTime private scanner
pha get the date/time
pha
pha
pha
_ReadTimeHex
lda 1,S set the minutes
xba
jsr convert
sta >time+5
pla set the seconds
jsr convert
sta >time+8
lda 1,S set the hour
jsr convert
sta >time+2
pla set the year
xba
and #$00FF
ldy #19
yearloop sec
sbc #100
bmi yeardone
iny
bra yearloop
yeardone clc
adc #100
jsr convert
sta >date+11
tya
jsr convert
sta >date+9
lda 1,S set the day
inc A
jsr convert
short M
cmp #'0'
bne dateOK
lda #' '
dateOK long M
sta >date+6
pla set the month
xba
and #$00FF
asl A
asl A
tax
lda >month,X
sta >date+2
lda >month+1,X
sta >date+3
pla
lla timeStr,time set the addresses
lla dateStr,date
rtl
month dc c'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec'
date dc i'12',c'mmm dd YYyy',i1'0'
time dc i'9',c'hh:mm:ss',i1'0'
convert and #$00FF
ldx #0
cv1 sec
sbc #10
bcc cv2
inx
bra cv1
cv2 clc
adc #10
ora #'0'
xba
pha
txa
ora #'0'
ora 1,S
plx
rts
end