Transactor/Transactor_16_1987_Transactor_Publishing.d64/struct.src

Text File | 2023-02-26 | 12KB | 567 lines

;
;structured programming (parser)
;by frank e. digioia
;11/12/85
;
 * = $c000    ;convenient start
;
chrget = $0073  ;get byte of text
chrgot = $0079  ;get same byte
igone  = $0308  ;evaluation vector
;
init = *       ;initialize routine
 lda #<struct
 sta igone
 lda #>struct
 sta igone+1
 lda #<note
 ldy #>note
 jmp $ab1e
;
note .byte '> structured commands'
.byte ' enabled.',$0d,$00
;
struct = *
 jsr chrget ;get a byte of text
 jsr chkout ;structured command?
 jmp $a7ae  ;intepreter loop
;
rem jmp $a93b ;rem command
;
newrun jsr kill ;kill edit mode
 jmp basic      ;give to basic
;
chkout cmp #$27 ;single quote?
 beq rem       ;classy rem
 cmp #$8b    ;can't have new cmds
 bne *+5     ;without a new if
 jmp if
 cmp #$8a    ;'run' token
 beq newrun  ;end edit and run
 tax         ;set flags
 bmi basic   ;token/give to basic
;
 ldy #$0a   ;check on 'wend'
 sty count  ;point to 'wend'
 cmp #'w'   ;current char = 'w'?
 bne setup  ;no/not wend
 ldy #$01   ;yes/check next char
 lda ($7a),y ;next byte of text
 cmp #$80    ;'end'?
 beq exec    ;yes/execute wend
;
setup lda #$00 ;clear all regs
 sta count  ;and keyword counter
 tax
 tay
 dey        ;pre-loop decrement
;
loop iny      ;incr text index
 lda table,x  ;get table byte
 beq basic    ;end of table
 inx          ;incr table pointer
 cmp ($7a),y  ;cmpare with text
 bne next     ;find next word
 beq loop     ;match/keep looking
;
next dex      ;bump .x down once
 lda table,x  ;end of table word?
 bpl find     ;no/find end of word
 and #$7f     ;yes/mask flag
 cmp ($7a),y  ;is it a match?
 beq exec     ;hooray!!!
 bne x1       ;go back for more
;
find inx      ;find end of word
 lda table,x  ;look for negative
 beq basic    ;end of table
 bpl find     ;keep looking
;
x1 inx        ;point to next word
 inc count    ;word # in table
 ldy #$ff     ;reset text index
 jmp loop     ;search some more
;
exec = *      ;execution routine
 tya          ;update text pointer
 clc
 adc $7a
 sta $7a
 bcc *+4
 inc $7b
;
 lda count    ;get offset in table
 asl a        ;multiply by two
 tax          ;use as index
 lda adrtab+1,x ;hi byte adr
 pha          ;as return adr hi
 lda adrtab,x ;lo byte adr
 pha          ;as return adr lo
 jmp chrget   ;execute routine
;
basic jsr chrgot ;reset flags
 jmp $a7ed     ;give it to basic
;
count .byte $00
;
table .byte 'repea',$d4,'unti',$cc
.byte 'whil',$c5,'exi',$d4,'cal'
.byte $cc,'pro',$c3,'els',$c5
.byte 'edi',$d4,'kil',$cc,'basic'
.byte $b2,$00
;
adrtab .word repeat-1,until-1
.word while-1,exit-1,call-1
.word xproc-1,else-1,edit-1,kill-1
.word basic2-1,wend-1
;
;edit mode commands
;
edit lda #$ff  ;ignore pi symbol
 sta $81       ;alter chrget
 rts           ;that's it!
;
kill lda #$20  ;ignore spaces
 sta $81       ;fix chrget
 rts
;
basic2 lda #$e4 ;fix igone vector
 sta igone
 lda #$a7
 sta igone+1
 lda #<note2    ;notify user
 ldy #>note2
 jmp $ab1e
 rts
note2 .byte '> cmds disabled',$00
;
;structured programming module
;by frank e. digioia
;11/23/85
;
;tokens for lookups & cmp's
;
whltok = $eb
wndtok = $ec
reptok = $e7
gosubs = $8d
for    = $81
proc   = $e5
;
stack  = $0100  ;6510 stack area
frmevl = $ad9e  ;evaluate formula
getptr = $a38a  ;pntr to stack id
chkstk = $a3fb  ;check stack space
;
if = *
 jsr chrget ;get next byte
 jsr $ad9e  ;evaluate expression
 jsr $0079  ;get last char
 cmp #$89   ;"goto" token?
 beq chkexp ;yeah/check result
 lda #$a7   ;"then" token
 jsr $aeff  ;check on "then"
chkexp lda $61 ;expression true?
 bne doit   ;yes/execute cmd
 jsr fndels ;no/look for "else"
 tax        ;eoln?
 bne cmmd   ;no/do else clause
 rts        ;yes/return to interp
;
doit jsr chrgot ;get last char
 bcs decptr ;not digit/execute it
 jmp $a8a0  ;digit/execute goto
;
decptr lda $7a ;decrement txtptr
 sec
 sbc #$01
 sta $7a
 bcs *+4
 dec $7b
 ldy #$00   ;clear .y for update
;
cmmd pla     ;clear return address
 pla
 jmp ($0308) ;execute via vector
;
fndels jsr $a906   ;find next stmt
 pha               ;save byte
 jsr $a8fb         ;update txtptr
 pla               ;get byte back
 beq noelse        ;end of line?
 ldx #$03          ;compare 4 byte
chkels jsr chrget  ;get a byte
 cmp esle,x        ;comare bkwrd
 bne fndels        ;no/next stmt
 dex               ;bump index
 bpl chkels        ;keep checking
noelse rts
;
esle .byte 'esle'
;
else jmp $a93b  ;do a rem
;
repeat = *
 lda #$03  ;need 6 bytes
 jsr chkstk ;check stack space
 jsr $a8f8 ;point next st'ment
 lda $7b   ;save text pointer
 pha
 lda $7a
 pha
 lda $3a   ;save line number
 pha
 lda $39
 pha
 lda #reptok
 pha
 jmp $a7ae ;interpreter loop
;
until = *
 jsr getptr  ;find id on stack
 txs         ;replace pointer
 cmp #reptok ;repeat id?
 bne uerr1   ;'missing repeat'
 jsr chrgot  ;condition present?
 beq nocond  ;'missing cond.'
 jsr frmevl  ;evaluate expression
 tsx         ;get stack pointer
 txa         ;place in .a
 clc
 adc #$05    ;backup 5 on stack
 tax
 tay
;
 lda $61    ;check result (t/f)
 bne utrue  ;true/fix stack
;
 ldx #01    ;false/copy data from
getdat dey  ;stack into program
 lda stack+1,y ;pointer & curlin
 sta $7a,x  ;to continue execution
 lda stack-1,y ;at top of loop.
 sta $39,x
 dex
 bpl getdat
 jmp $a7ae  ;interpreter loop
;
utrue txs  ;update stack pointer
 rts
;
uerr1 lda #$00
 .byte $2c
werr1 lda #$01
 .byte $2c
werr2 lda #$02
 .byte $2c
nocond lda #$03
  jmp error      ;print error msg
;
while = *
 jsr chrgot ;condition present?
 beq nocond ;no/error mesg
 lda #$03   ;need 6 bytes
 jsr chkstk ;check stack space
 lda $7a    ;save pointer to
 sta t1     ;the conditional
 lda $7b    ;expression for
 sta t2     ;later use.
 jsr frmevl ;evaluate expression
 lda $61    ;true or false?
 bne wtrue  ;true/load up stack
 jmp fndwnd ;false/find wend
;
wtrue lda t2 ;save pointer to
 pha         ;the logical
 lda t1      ;expression on
 pha         ;stack
 lda $3a     ;save line number
 pha         ;on stack
 lda $39
 pha
 lda #whltok ;save id for while
 pha         ;on stack
 jmp $a7ae
;
wend jsr getptr ;find id on stack
 txs         ;update pointer
 cmp #whltok ;id for while?
 bne werr1   ;'missing while'
 jsr chrgot  ;end of statement?
 bne werr2   ;no/something wrong
;
 lda $7b     ;save text pointer
 sta t2
 lda $7a
 sta t1
 lda $3a
 sta ll2
 lda $39
 sta ll1
;
 tsx         ;get stack pointer
 txa         ;place in .a
 clc
 adc #$05    ;back up 5 on stack
 tax
 stx stkptr  ;store stack pointer
 tay
;
 ldx #$01    ;get adr of while
whldat dey   ;condition into
 lda stack+1,y ;$7a/$7b and line
 sta $7a,x   ;number into $39/$3a
 lda stack-1,y ;for frmevl to use
 sta $39,x
 dex
 bpl whldat
;
 jsr frmevl  ;evaluate expression
 lda $61     ;true or false?
 beq wfalse
 jmp $a7ae   ;true/cont execution
;
wfalse ldx stkptr
 txs        ;update stack pointer
 ldx #$01
wfill lda t1,x ;replace text pntr
 sta $7a,x
 lda ll1,x   ;replace line number
 sta $39,x
 dex
 bpl wfill
 rts        ;continue execution
;
fndwnd = *  ;find wend statement
 lda #$00
 pha        ;set flag on stack
wsrch jsr $a8f8 ;find next stment
 jsr chrgot ;end of line?
 tax
 beq eoln1  ;yes/deal with it
xx jsr chrget ;get next byte
 tax        ;end of line?
 beq eoln1  ;yes/deal with it
 jsr chkwnd ;cmp #wndtok
 beq xwend
 jsr chkwhl ;cmp #whltok
 beq xwhile
 bne wsrch
;
eoln1 ldy #$02 ;check for end text
 lda ($7a),y  ;link hi = 0?
 bne *+5      ;no/continue search
 jmp werr2    ;yes/missing wend
 iny          ;no/get line#
 lda ($7a),y  ;save line #
 sta ll1
 iny
 lda ($7a),y
 sta ll2
 jsr $a8fb   ;update text pointer
 jmp xx      ;do search
;
xwend pla    ;check flag
 beq wndfnd  ;found it!!!
 jmp wsrch
;
xwhile lda #whltok
 pha
 jmp wsrch
;
wndfnd lda ll1 ;load line #
 sta $39
 lda ll2
 sta $3a
 jmp $a8f8   ;find next statement
;
stkptr .byte $00
incrst .byte $00
t1 .byte $00
t2 .byte $00
ll1 .byte $00
ll2 .byte $00
;
exit = *
 pla        ;find id on stack
 pla
 pla
 cmp #for   ;for command?
 beq getinc ;get # of bytes
 cmp #gosubs ;gosub command?
 beq getinc+3
 cmp #reptok
 beq getinc+3
 cmp #whltok
 beq getinc+3
 lda #$04   ;error number 4
 jmp error  ;'nothing to exit'
;
getinc lda #$13 ;19 bytes on stack
 .byte $2c     ;skip next instr.
 lda #$06      ;6 bytes on stack
 sta incrst    ;incr for stkptr
 tsx           ;get stack pointer
 txa           ;put in .a for add
 clc
 adc incrst    ;increase stkptr
 tax           ;replace it
 txs           ;stack clean!
 jsr chrgot    ;get last char.
 jsr $a8a0     ;goto command
 jmp $a7ae     ;interpreter loop
;
call = *
 lda #$03     ;need 6 bytes
 jsr chkstk   ;check stack space
 lda $7b      ;save text pointer
 pha
 lda $7a
 pha
 lda $3a      ;save line number
 pha
 lda $39
 pha
 lda #$8d     ;id for gosub
 pha
;
 jsr fndprc   ;find procedure adr
 ldx #$01     ;use .x as index
z lda $fb,x
 sta $7a,x    ;update text pointer
 lda $61,x
 sta $39,x    ;update line number
 dex
 bpl z
;
 jsr $a8f8    ;find next command
 jmp $a7ae    ;to interpreter loop
;
fndprc = *    ;find procedure
 lda $2b      ;start of basic
 sta $fd      ;as pointer
 lda $2c
 sta $fe
;
srchlp lda $fd ;update link pntr
 sta $fb
 lda $fe
 sta $fc
;
 ldy #$01     ;use .y as index
 lda ($fb),y  ;hi byte next line
;
 bne *+7      ;end of text?
 lda #$05     ;yes/error number 5
 jmp error    ;'proc not found'
;
 sta $fe      ;save next adr hi
 dey          ;bump pointer
 lda ($fb),y  ;get next adr lo
 sta $fd      ;save it
;
 ldy #$04     ;point to 1st byte
 lda ($fb),y  ;get the byte
 jsr chkprc   ;cmp #proc
 bne srchlp   ;no/try next line
;
 ldy #$03     ;yes/get line #
 lda ($fb),y  ;get hi byte
 sta $62      ;save it
 dey
 lda ($fb),y  ;get lo byte
 sta $61      ;save it
;
 ldy #$07     ;ldy #$04
xspc iny      ;skip leading spaces
 lda ($fb),y  ;get byte of name
 cmp #' '     ;space?
 beq xspc
;
 tya          ;get offset in .a
 clc
 adc $fb      ;update our txtptr
 sta $fb      ;to first byte of
 bcc *+4      ;procedure name
 inc $fc
;
 ldy #$ff     ;set .y = -1
compar iny    ;update index
chktxt lda ($7a),y ;byte of name
 beq chklst   ;end of exec name
 cmp #':'     ;end of exec name?
 beq chklst   ;check end procname
 cmp #' '     ;space?
 bne chknam   ;no/check proc name
 inc $7a      ;forget spaces
 bne *+4
 inc $7b
 jmp chktxt
;
chknam cmp ($fb),y ;cmp proc name
 beq compar   ;match/keep checking
 jmp srchlp   ;no/find next proc
;
chklst lda ($fb),y ;end procname?
 beq *+6
 cmp #':'
 bne srchlp
 rts
;
xproc lda #$06  ;error number 6
 jmp error
;
;this routine may be omitted if
;tokens are used (see article).
;
chkwnd ldx #$04  ;offset for wend
 .byte $2c    ;skip next instr
chkwhl ldx #$07  ;offset to while
 ldy $7a       ;copy text pointer
 sty $fb       ;to $fb/$fc
 ldy $7b
 sty $fc
 ldy #$ff      ;pre-loop index
 bne chkx      ;do the check
;
chkprc ldx #$ff ;offset for proc
 ldy #$03      ;pre-loop
;
chkx iny       ;compare loop
 inx           ;bump pointer
 lda name,x    ;get byte of name
 beq xit       ;end of name?
 cmp ($fb),y   ;compare to text
 beq chkx      ;match, keep on
xit rts
;
name .byte 'proc',$00,'w',$80,$00
 .byte 'while',$00
;
;error processor -- prints error
;messages and passes control to
;rom error routines
;
;frank e. digioia
;12/17/85
;
error asl a   ;mult err# by 2
 tax          ;use as index
 lda errmsg,x ;get mesg address
 sta $22
 lda errmsg+1,x
 jmp $a445    ;process error
;
errmsg .word u1msg,w1msg,w2msg
.word ncmsg,nemsg,npmsg,nocall
;
u1msg .byte 'until without repea',$d4
w1msg .byte 'wend without whil',$c5
w2msg .byte 'while without wen',$c4
ncmsg .byte 'missing logical expressio',$ce
nemsg .byte 'no structure to exi',$d4
npmsg .byte 'procedure not foun',$c4
nocall .byte 'proc without cal',$cc
;
.end