User:Zzo38/Famicom Z-machine: Difference between revisions

From NESdev Wiki
Jump to navigationJump to search
No edit summary
No edit summary
 
(6 intermediate revisions by the same user not shown)
Line 5: Line 5:
The assembler in use is Unofficial MagicKit (a modified version of NESASM).
The assembler in use is Unofficial MagicKit (a modified version of NESASM).


This program is being written by [[User:Zzo38]], and is using the Famicom keyboard. Only uppercase is supported; any lowercase is converted to uppercase for display (the positions for lowercase letters in the pattern table contain uppercase). The keyboard decoder still returns lowercase, since that is what the Z-machine requires.
This program is being written by [[User:Zzo38]], and is using the Famicom keyboard. It is not yet complete (and likely contains errors).


Due to overscan, the "MORE" prompt shall assume that the top and bottom two rows are not visible, and the scrolling routine shall blank out the bottom two rows (sixteen scanlines) of the screen to hide them on displays that would show the overscanned area anyways.
__TOC__


Unlike many Z-machine interpreters, this one supports permanent shifts even in version 3.
== Main file ==
<pre>
; Famizork II
; Public domain
 
debug = 1  ; change this to 1 to enable breakpoints 0 to disable
    ; set a breakpoint on opcode $1A in the debugger
 
inesmap 380 ; Famizork II mapper
ineschr 1 ; 8K CHR ROM
inesmir 3 ; horizontal arrangement with battery
 
; Zero-page variables:
;  $02 = data stack pointer
;  $03 = call stack pointer
;  $04 = temporary
;  $05 = temporary
;  $06 = temporary
;  $07 = temporary
;  $09 = current temporary shift state
;  $0A = current permanent shift state
;  $0B = saved permanent shift state
;  $0D = number of locals
;  $0E = bit16 of program counter
;  $10 = bit7-bit0 of program counter
;  $11 = low byte of first operand
;  $12 = low byte of second operand
;  $13 = low byte of third operand
;  $14 = low byte of fourth operand
;  $15 = temporary
;  $16 = low byte of text address if inside fword
;  $17 = low byte of packed word
;  $18 = temporary
;  $19 = low byte of packed word if inside fword
;  $20 = bit15-bit8 of program counter
;  $21 = high byte of first operand
;  $22 = high byte of second operand
;  $23 = high byte of third operand
;  $24 = high byte of fourth operand
;  $25 = temporary
;  $26 = high byte of text address if inside fword
;  $27 = high byte of packed word
;  $28 = temporary
;  $29 = high byte of packed word if inside fword
;  $30 = output buffer pointer
;  $31 = low byte of nametable address of cursor
;  $32 = high byte of nametable address of cursor
;  $33 = Y scroll amount
;  $34 = lines to output before <MORE>
;  $35 = saved high byte of return address for text unpacking
;  $36 = bit16 of current text address
;  $37 = bit16 of current text address if inside fword
;  $38-$39 = return address for text unpacking
;  $3A = current background color
;  $3B = current foreground color
;  $3C = remember if battery RAM is present (255=yes 0=no)
;  $3D = ARCFOUR "i" register
;  $3E = ARCFOUR "j" register
;  $40-$4F = low byte of locals
;  $50-$5F = high byte of locals
;  $E2-$FF = output buffer
 
code
 
datasp = $02
callsp = $03
locall = $40
localh = $50
 
dstackl = $200
dstackh = $300
 
cstackl = $400
cstackm = $480
cstackh = $500 ; bit4-bit1=number of locals, bit0=bit16 of PC
cstackx = $580 ; data stack pointer
 
arcfour = $600 ; use for random number generator
 
bank intbank+0,"Interpreter"
bank intbank+1,"Interpreter"
bank intbank+2,"Interpreter"
bank intbank+3,"Interpreter"
 
bank intbank
org $8000
 
macro breakpoint
if debug
db $1A ; unofficial NOP
endif
endm
 
macro breakpoint2
if debug
db $3A ; unofficial NOP
endif
endm
 
macro make_digit_table
macset 4,4,0
macgoto make_digit_table_0
endm
 
macro make_digit_table_0
db ((\4*\2)/\1)%10
macset 4,4,\4+1
macset 5,4,\4=\3
macgoto make_digit_table_\5
endm
 
macro make_digit_table_1
; Empty macro
endm
 
globodd = global&1


<b>Opcode</b>    <b>Status</b>
macro make_global_table
EQUAL?      OK
macset 2,4,16
LESS?      OK
macgoto make_global_table_0
GRTR?      OK
endm
DLESS?      OK
IGRTR?      OK
IN?        OK
BTST        OK
BOR        OK
BAND        OK
FSET?      OK
FSET        OK
FCLEAR      OK
SET        OK
MOVE        OK
GET        OK
GETB        OK
GETP        OK
GETPT      OK
NEXTP      OK
ADD        OK
SUB        OK
MUL        OK
DIV        X
MOD        X
ZERO?      OK
NEXT?      OK
FIRST?      OK
LOC        OK
PTSIZE      OK
INC        OK
DEC        OK
PRINTB      OK
REMOVE      OK
PRINTD      OK
RETURN      OK
JUMP        OK
PRINT      OK
VALUE      OK
BCOM        OK
RTRUE      OK
RFALSE      OK
PRINTI      OK
PRINTR      OK
NOOP        OK
SAVE        N/A
RESTORE    N/A
RESTART    OK
RSTACK      OK
FSTACK      OK
QUIT        OK
CRLF        OK
USL        N/A
VERIFY      OK
CALL        OK
PUT        OK
PUTB        OK
PUTP        OK
READ        X
PRINTC      OK
PRINTN      OK
RANDOM      X
PUSH        OK
POP        OK
SPLIT      N/A
SCREEN      N/A
(OK = implemented (but may contain errors), X = not implemented, P = partially implemented, N/A = no intention to implement in this version)


<!-- Please do not enable syntax highlighting for this program. -->
macro make_global_table_0
-----
db \1(global+\2+\2-32)
macset 2,4,\2+1
macset 3,4,\2=256
macgoto make_global_table_\3
endm


<pre>
macro make_global_table_1
; Z-machine interpreter (Z-code versions 1 to 3) for Famicom
; Empty macro
; version 0.0
endm
; Public domain
 
macro make_object_table
macset 2,4,0
macgoto make_object_table_0
endm


inesmap 5 ; MMC5 or "User:Zzo38/Mapper D"
macro make_object_table_0
inesmir 1 ; Horizontal arrangement
db \1(object+(\2*9)+62-9)
inesprg 16 ; 256K (bank 0 to 15 for story file, 16 to 31 for interpreter)
macset 2,4,\2+1
ineschr 1 ; 8K
macset 3,4,\2=256
macgoto make_object_table_\3
endm


; The C program will read, adjust the header, and then set asm macros, as follows:
macro make_object_table_1
;  zver: Z-machine version number.
; Empty macro
;  bytswap: Defined for small endian, undefined for big endian
endm
;  endlod: Beginning of non-preloaded code (this program extends core to 64K for simplicity)
;  purbot: Beginning of data to not enter into save file
;  start: Location where execution begins
;  vocab: Points to vocabulary table
;  sibcnt: Number of self-inserting break characters
;  voccnt: Number of entries in vocabulary table
;   ventsiz: Entry size of vocabulary table
;  object: Points to object table
;  globals: Points to global variable table
;  fwords: Points to fwords table
;  plenth: Length of program in words
;  pchksm: Checksum of all bytes


xobject = object+62-9 ; Offset for object headers
instadl ds 256
xglobal = global-32 ; Offset for global variables
instadh ds 256
xvocab = vocab+sibcnt+4 ; Actual start of vocab


; Low RAM usage:
globadl ds 16
;  $0xx = Miscellaneous variables
make_global_table low
;  $1xx = 6502 stack
globadh ds 16
;  $2xx = Bits 7:0 of Z-machine data stack
make_global_table high
;  $3xx = Bits 15:8 of Z-machine data stack
;  $4xx = Bits 7:0 of Z-machine call stack
;  $5xx = Bits 15:8 of Z-machine call stack
;  $6xx = Bit 16 of Z-machine call stack
;  $7xx = Pointer to bottom of data stack for a routine


zp
objadl make_object_table low
outbuf ds 32 ; The output buffer
objadh make_object_table high
r0 ds 1
r1 ds 1
r2 ds 1
r3 ds 1
r4 ds 1
r5 ds 1
r6 ds 1
r7 ds 1
op0l ds 1 ; First operand of an instruction
op0h ds 1
op1l ds 1
op1h ds 1
op2l ds 1
op2h ds 1
op3l ds 1
op3h ds 1
argtyp ds 1 ; Argument types (inverted; used for EQUAL? and CALL)
cstkcnt ds 1 ; Count of entries on the call stack
dstkcnt ds 1 ; Count of entries on the data stack
cursx ds 1 ; Cursor X position
readcnt ds 1 ; Number of characters input
cursxin ds 1 ; Cursor X position at start of input line
linecnt ds 1 ; Number of lines output before pausing (to implement "MORE")
bufptr ds 1 ; Pointer into output buffer
pcl ds 1 ; Low byte of program counter
pcm ds 1 ; Mid byte of program counter
pch ds 1 ; High byte of program counter
vlub ds 4 ; Vocabulary look up buffer
byth ds 1 ; High byte of value reading from memory (low byte is accum)
mapad ds 2 ; Mapped address (second byte is zero)
corel ds 1
coreh ds 1
idxl ds 1
idxh ds 1
outrdy ds 1 ; To set if output buffer is ready to display on the screen.
linrdy ds 1 ; To set if ready to add a linefeed to output
pshift ds 1 ; Permanent shift state (one of: $00, $20, $40)
tshift ds 1 ; Temporary shift state ($60=high escape, $80=low escape, $A0=fwords)
chroff ds 1 ; Partial character code or FWORDS index
blinker ds 1 ; Cursor blink time
curspal ds 1 ; Color of cursor
keychar ds 1 ; Keyboard character to print
scrolly ds 1 ; Scroll position ($00 to $E8)
lladl ds 1 ; Low byte of address of last line ($00 to $E0)
lladh ds 1 ; High byte of address of last line ($20 to $23)


rambank = $5113 ; xxxx xxxx
multabl ds 256 ; x*x/4
rombank = $5115 ; 1xxx xxx0
multabh ds 512 ; x*x/1024


; Mapping ROM address:
digit0l make_digit_table 1,1,256
;  Bank = ((A>>13)|128)&254
digit1l make_digit_table 10,1,256
;  Address = (A&$3FFF)|$8000
digit2l make_digit_table 100,1,256
digit0h make_digit_table 1,256,128
digit1h make_digit_table 10,256,128
digit2h make_digit_table 100,256,128
digit3h make_digit_table 1000,256,128


; Mapping RAM address:
bit1tab db  0,  1,  3,  3,  7,  7,  7,  7, 15, 15, 15, 15, 15, 15, 15, 15
;  Bank = A>>13
db  31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31
;  Address = (A&$1FFF)|$6000
db  63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63
db  63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255


macro romsel
zchad ds 256
lda #128|bank(\1)&254
sta rombank
endmac


macro bankcall
ptsizt db 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
ldy #128|bank(\1)&254
db 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
sty rombank
db 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3
jsr \1
db 4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4
endmac
db 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5
db 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6
db 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7
db 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8


macro bankjump
flagad if smalend
ldy #128|bank(\1)&254
db 1,1,1,1,1,1,1,1
sty rombank
db 0,0,0,0,0,0,0,0
jmp \1
db 3,3,3,3,3,3,3,3
endmac
db 2,2,2,2,2,2,2,2
else
db 0,0,0,0,0,0,0,0
db 1,1,1,1,1,1,1,1
db 2,2,2,2,2,2,2,2
db 3,3,3,3,3,3,3,3
endif


code
fwordsl = *-32
ds 96
fwordsh = *-32
ds 96
 
flagbit db 128,64,32,16,8,4,2,1
db 128,64,32,16,8,4,2,1
db 128,64,32,16,8,4,2,1
db 128,64,32,16,8,4,2,1
 
flagbic db 127,191,223,239,247,251,253,254
db 127,191,223,239,247,251,253,254
db 127,191,223,239,247,251,253,254
db 127,191,223,239,247,251,253,254


bank 16
digit4h make_digit_table 10000,256,128
org $8000


; Alphabet table row 2
; Z-character-decoding assigning macro
if zver=1
macro def_zchars
alpha2 db 32, 13, "*****0123456789.,!?_#'", 34, "/", 92, "<-:()"
if \#=1
macset 2,4,\1
else
else
alpha2 db " ******", 13, "0123456789.,!?_#'", 34, "/", 92, "-:()"
macset 2,4,\2
endif
macset 1,4,\1
macset 3,4,*
macset 4,4,?B
bank bank(zchad)
macgoto def_zchars_0
endm
 
macro def_zchars_0
macset 5,4,\1=\2
org zchad+\1
db low(\3-1)
if \3<$FE01
fail "Z-character routine out of range"
endif
if \3>$FF00
fail "Z-character routine out of range"
endif
endif
macset 1,4,\1+1
macgoto def_zchars_\5
endm
macro def_zchars_1
bank \4
org \3
endm
; Instruction assigning macro
macro def_inst
macset 2,4,*
macset 3,4,?B
bank bank(instadl)
org instadl+(\1)
db low(\2-1)
org instadh+(\1)
db high(\2-1)
bank \3
org \2
endm
macro def_inst_2op
def_inst (\1)+$00
def_inst (\1)+$20
def_inst (\1)+$40
def_inst (\1)+$60
def_inst (\1)+$C0
endm


; Keyboard decoding table (lowercase is necessary)
macro def_inst_2op_eq
kbdt db "][", 13, 0, 0, 92, 15, 0
def_inst (\1)+$00
db ";:@", 0, "^-/_"
def_inst (\1)+$20
db "klo", 0, "0p,."
def_inst (\1)+$40
db "jui", 0, "89nm"
def_inst (\1)+$60
db "hgy", 0, "67vb"
endm
db "drt", 0, "45cf"
db "asw", 0, "3ezx"
db 0, "q", 0, 0, "21", 0, 15
db 0, 0, 0, 12, 0, 8, 32, 0


; Do the sending of output buffer (not using <r0 <r1)
macro def_inst_1op
sendout inc <outrdy
def_inst (\1)+$00
;TODO
def_inst (\1)+$10
lda #0
def_inst (\1)+$20
sta <bufptr
endm
pla
 
rti
macro def_inst_0op
def_inst (\1)+$00
endm
 
macro def_inst_ext
def_inst (\1)+$00
endm


; Send a line feed (not using <r0 <r1)
; Fetch next byte of program
sendlf inc <linrdy
; Doesn't affect carry flag and overflow flag
lda #1
macro fetch_pc
sta <cursx
inc $1010
bne n\@
inc $1020
if large
bne n\@
inc <$0E
n\@ ld\1 <$0E
\2 $5803,\1
else
n\@ \2 $5803
endif
endm
; (Bytes of above: 17)
; (Cycles of above: 16 or 25 or 27)


; Blank out the next line
; Initialization code
lda #$08
reset ldx #0
sta <r2
stx $2000
lda <scrolly
stx $2001
asl a
; Wait for frame
rol <r2
bit $2002
asl a
vwait1 bit $2002
rol <r2
bpl vwait1
ldx <r2
txa
stx <$0E ; bit16 of program counter
stx <$0D ; number of locals
stx <$33 ; Y scroll amount
stx <$3C ; battery flag
dex
stx <$03 ; call stack pointer
ldy #27
sty <$34 ; lines before <MORE>
ldy #$0F
sty <$3A ; background
ldy #$20
sty <$3B ; foreground
ldy #low(start-1)
sty <$10
ldy #$E2
sty <$30 ; output buffer pointer
ldy #$61
sty <$31 ; low byte of cursor nametable address
ldy #$27
sty <$32 ; high byte of cursor nametable address
; Wait for frame
bit $2002
vwait2 bit $2002
bpl vwait2
; Clear the screen
tax
lda #32
sta $2006
ldx #9
stx $2006
stx $2006
reset1 sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
inx
bne reset1
; Initialize palette
lda #$FF
sta $2006
sta $2006
lda #32
stx $2006
tax
lda <$3A
sendlf1 sta $2007
sta $2007
sta $2007
ldy <$3B
sty $2007
sty $2007
sta $2007
sta $2007
sty $2007
sty $2007
sta $2007
sta $2007
sty $2007
sty $2007
sta $2007
sta $2007
sty $2007
sty $2007
; Check if F8 is pushed (erases save data)
ldx #5
stx $4016
dex
stx $4016
lda $4017
and #2
beq reset2
; Check battery
ldx #0
stx $1011
stx $1021
lda $5800
cmp #69
bne reset2
inc $1011
lda $5800
cmp #105
beq reset3
; No save file exists; try to create one
reset2 stx $1011
lda #69
sta $5800
inc $1011
lda #105
sta $5800
inc $1011
stx $5800
lda #$FF
sta $1022
; Initialize ARCFOUR table
reset2a txa
sta arcfour,x
sta $1012
sta $5800
inx
bne reset2a
; Copy header from ROM into RAM
stx $1021
reset2b stx $1011
lda $5805
sta $5803
inx
bne reset2b
; Copy ROM starting from PURBOT into RAM
lda #high(purbot)
sta $1021
lda #low(purbot)
sta $1011
reset2c lda $5805
sta $5803
inc $1011
bne reset2c
inc $1021
if large=0
if maxaddr<$FF00
lda <$21
cmp #high(maxaddr)+1
endif
endif
bne reset2c
; Check if save file still exists
stx $1011
stx $1021
lda $5800
cmp #69
bne zrest
inc $1011
lda $5800
cmp #105
beq reset3
jmp zrest
; Battery is OK
reset3 lda #255
sta <$3C
; Load and permute saved ARCFOUR table
sta $1021
ldy #0
reset3a sty $1011
lax $5800
sta arcfour,y
inx
stx $5800
iny
bne reset3a
; fall through
 
; *** RESTART
def_inst_0op 183
zrest ldx #0
stx <$0E ; bit16 of program counter
stx <$0D ; number of locals
stx $1021
dex
dex
bne sendlf1
stx <$03 ; call stack pointer
; Load data from 64 to PURBOT from ROM into RAM
lda #64
sta $1011
zrest1 lda $5805
sta $5803
inc $1011
bne zrest1
inc $1021
if purbot<$FF00
lda <$21
cmp #high(purbot)+1
endif
bne zrest1
; Initialize program counter
lda #low(start-1)
sta <$10
lda #high(start-1)
sta $1020
jmp zcrlf
 
; *** USL
def_inst_0op 188
; fall through
 
; *** SPLIT
def_inst_ext 234
; fall through
 
; *** SCREEN
def_inst_ext 235
; fall through
 
; *** NOOP
def_inst_0op 180
; fall through
 
; Decode the next instruction
; For EXT instructions, number of operands is in the X register
nxtinst fetch_pc y,ldx
lda instadh,x
pha
lda instadl,x
pha
txa
bmi not2op
 
; It is 2OP
ldx #0
asl a
sta <4
arr #$C0
fetch_pc y,lda
bcc is2op1
jsr varop0
fetch_pc y,lda
bvc is2op2
jmp is2op3
is2op1 stx <$21
sta <$11
bit <4
fetch_pc y,lda
bvc is2op3
is2op2 inx
jmp varop0
is2op3 stx <$22
sta <$12
rts
 
; It isn't 2OP
not2op cmp #192
bcc notext
 
; It is EXT
fetch_pc y,lda
ldx #0
isext0 sec
rol a
bcs isext1
bmi isext3
 
; Long immediate
sta <4
fetch_pc y,lda
if smalend
sta <$11,x
else
sta <$21,x
endif
fetch_pc y,lda
if smalend
sta <$21,x
else
sta <$11,x
endif
inx
lda <4
sec
rol a
jmp isext0


; Advance scroll position and line position
; Variable or no more operands
lda <scrolly
isext1 bpl isext2
clc
adc #$08
cmp #$F0
bne sendlf2
lda #$00
sendlf2 sta <scrolly
;TODO


; Check if [MORE] prompt should be displayed
; No more operands
;TODO
rts


; Return from NMI
; Variable
pla
isext2 sta <4
rti
jsr varop
inx
lda <4
sec
rol a
jmp isext0


; Ready the output buffer for dumping to the screen
; Short immediate
; And then, wait for the NMI routine to clear it
isext3 sta <4
outdump dec <outrdy
lda #0
outdum1 bit <outrdy
sta <$21,x
bvs outdum1
fetch_pc y,lda
outdum2 rts
sta <$11,x
inx
lda <4
sec
rol a
jmp isext0


; Ready to output a line feed
; It isn't EXT; it is 1OP or 0OP
; Wait for NMI routine to clear the flag
notext asl a
lfodump dec <outrdy
asl a
lfdump dec <linrdy
asl a
lfdump1 bit <linrdy
bcs notext1
bvs lfdump1
bpl notext2
lfdump2 rts


; Print a character
; 1OP - short immediate
putchar cmp #0
fetch_pc y,lda
beq lfdump2 ; outputting ASCII code 0 has no effect
ldx #0
cmp #13
stx <$21
beq lfodump ; output the buffer and a line break
sta <$11
cmp #32
beq endword ; output a word and a space
putcha0 ldx <cursx
cpx #31
bcc putcha1
jsr lfdump
putcha1 ldx <bufptr
sta <outbuf,x
inc <bufptr
rts
rts


endword jsr outdump
notext1 bmi notext3
cpx #31
 
bcs lfdump
; 1OP - variable
bcc putcha1
ldx #0
jmp varop


; Print a signed 16-bit integer (<op0h,<op0l), then nxtinst
; 1OP - long immediate
printn lda <op0h
notext2 fetch_pc y,lda
bit #$80
if smalend
beq printn1
sta <$11,x
; Negative number
else
lda #45
sta <$21,x
jsr putcha0
endif
; Bitwise complement and increment
fetch_pc y,lda
lda <op0h
if smalend
eor #$FF
sta <$21,x
tax
else
lda <op0l
sta <$11,x
eor #$FF
endif
clc
; fall through
adc #1
 
sta <op0l
; 0OP
notext3 rts
 
zcall0 jmp val8
 
; *** CALL
def_inst_ext 224
stx <4
lax <$11
ora <$21
beq zcall0 ; calling function zero
; Save to call stack
inc <callsp
ldy <callsp
lda <$10
stx <$10
sta cstackl,y
lda <$20
sta cstackm,y
lsr <$0E
lax <$0D
rol a
sta cstackh,y
lda <datasp
sta cstackx,y
; Save locals
txa
txa
adc #0
beq zcall2
sta <op0h
; Print a positive number (0 to 32768)
; ones_tens (r0): ot256[H]+mod100[L]
; hund_thou (r1): ht256[H]+divten[divten[L]]+divten[divten[ones_tens]]
; myriads (A): myr256[H]+divten[divten[hund_thou]]
printn1 ldx <op0h
lda ot256,x
ldy <op0l
clc
clc
adc mod100,y
adc <datasp
sta <r0
tay
lda ht256,x
zcall1 lda <locall,x
ldx divten,y
sta dstackl,y
adc divten,x
lda <localh,x
ldy <r0
sta dstackh,y
ldx divten,y
dey
adc divten,x
dex
sta <r1
bne zcall1
lda <$0D
adc <datasp
sta <datasp
; Read function header (number of locals)
zcall2 asl $1010
lda <$21
rol a
sta $1020
rol <$0E
ldy <$0E
lda $5803,y
sta <$0D
; Load initial values of locals
beq zcall4
; Load arguments
ldx <4
dex
beq zcall3
lda <$12
sta <$41
lda <$22
sta <$51
cpx #1
beq zcall2a
lda <$13
sta <$42
lda <$23
sta <$52
cpx #2
beq zcall2a
lda <$14
sta <$43
lda <$24
sta <$53
zcall2a txa
asl a ; now clears carry flag
adc <$10
sta <$10
lda #0
adc <$20
sta $1020
if large
bcc zcall3
inc <$0E
endif
; Load default values
zcall3 fetch_pc y,lda
if smalend
sta <locall+1,x
else
sta <localh+1,x
endif
fetch_pc y,lda
if smalend
sta <localh+1,x
else
sta <locall+1,x
endif
inx
cpx <$0D
bne zcall3
zcall4 jmp nxtinst
 
; *** RFALSE
def_inst_0op 177
lda #0
; fall through
 
; Return a 8-bit value (from A)
ret8 pha
ldy <callsp
dec <callsp
lda cstackx,y
sta <datasp
lda cstackl,y
sta <$10
lda cstackm,y
sta $1020
lda cstackh,y
lsr a
sta <$0D
tax
tax
ldy divten,x
rol a
lda divten,y
anc #1
ldx <op0h
sta <$0E
adc myr256,x
; Restore locals
; Use the carry flag to indicate printing leading zeros or not
txa
jsr digpair
beq ret8b
lda <r1
adc <datasp
jsr digpair
tay
lda <r0
ret8a lda dstackl,y
jsr digpair
sta <locall,x
bcs printn2
lda dstackh,y
; The value is zero
sta <localh,x
lda #$30
dey
jsr putchar
dex
printn2 jmp nxtinst
bne ret8a
ret8b pla
; fall through


; Print a pair of digits
; Value of instruction is 8-bits (from A)
digpair tay
val8 fetch_pc y,ldx
lda divten,y
bne val8a
bne digpai1
; Push to stack
bcc digpai2
inc <datasp
digpai1 ora #$30
ldy <datasp
jsr putcha0
sta dstackl,y
sec
txa
digpai2 lda modten,y
sta dstackh,y
bne digpai3
jmp nxtinst
bcc digpai4
val8a cpx #16
digpai3 ora #$30
bcs val8b
jsr putcha0
; Local variable
sec
sta <locall,x
digpai4 rts
lda #0
sta <localh,x
jmp nxtinst
; Global variable
val8b ldy globadl,x
sty $1014
ldy globadh,x
sty $1024
if smalend
sta $5801
else
ldy #0
sty $5801
endif
inc $1014
if globodd
bne val8c
inc $1024
endif
val8c if smalend
lda #0
endif
sta $5801
lda $1020
jmp nxtinst


; Convert and print a Z-character
; Read the variable using as an instruction operand
putzch and #$1F
; X is operand number (0-3)
varop fetch_pc y,lda
varop0 bne varop1
; Pop from stack
ldy <datasp
dec <datasp
lda dstackl,y
sta <$11,x
lda dstackh,y
sta <$21,x
rts
varop1 cmp #16
bcs varop2
; Local variable
tay
tay
ora <tshift
lda locall,y
sta <$11,x
lda localh,y
sta <$21,x
rts
; Global variable
varop2 tay
lda globadl,y
sta $1015
lda globadh,y
sta $1025
lda $5801
if smalend
sta <$11,x
else
sta <$21,x
endif
inc $1015
if globodd
bne varop3
inc $1025
endif
varop3 lda $5801
if smalend
sta <$21,x
else
sta <$11,x
endif
lda $1020
rts
 
; *** RSTACK
def_inst_0op 184
ldx <datasp
lda dstackl,x
sta <$14
lda dstackh,x
jmp ret16
 
; *** RETURN
def_inst_1op 139
lda <$11
sta <$14
lda <$21
ret16 sta <$24
ldy <callsp
dec <callsp
lda cstackx,y
sta <datasp
lda cstackl,y
sta <$10
lda cstackm,y
sta $1020
lda cstackh,y
lsr a
sta <$0D
tax
tax
lda #$BF
rol a
pha
anc #1
lda zchlut,x
sta <$0E
pha
; Restore locals
rts
txa
beq ret16b
adc <datasp
tay
ret16a lda dstackl,y
sta <locall,x
lda dstackh,y
sta <localh,x
dey
dex
bne ret16a
ret16b ; fall through
 
; Value of instruction is 16-bits (from $x4)
val16 lda <$14
fetch_pc y,ldx
bne val16a
; Push to stack
inc <datasp
ldy <datasp
sta dstackl,y
lda <$24
sta dstackh,y
jmp nxtinst
val16a cpx #16
bcs val16b
; Local variable
sta <locall,x
lda <$24
sta <localh,x
jmp nxtinst
; Global variable
val16b ldy globadl,x
sty $1015
ldy globadh,x
sty $1025
if smalend
sta $5801
else
ldy <$24
sty $5801
endif
inc $1015
if globodd
bne val16c
inc $1025
endif
val16c if smalend
lda <$24
endif
sta $5801
lda $1020
jmp nxtinst


bank 17
; *** RTRUE
def_inst_0op 176
lda #1
jmp ret8


; Myriads of 256 times value (up to 128 only)
; *** EQUAL? (EXT)
org $B87F
def_inst_ext 193
myr256 db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0;
lda <$11
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0;
ldy <$21
db 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1;
cmp <$12
db 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2;
bne zequal1
db 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2;
cpy <$22
db 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3;
beq tpredic
db 3,3,3,3,3,3,3,3,3
zequal1 cpx #2
beq fpredic
cmp <$13
bne zequal2
cpy <$23
beq tpredic
zequal2 cpx #3
beq fpredic
cmp <$14
bne fpredic
cmp <$24
beq tpredic
jmp fpredic


; Modulo by one hundred
; *** GRTR?
org $B900
def_inst_2op 3
mod100 db 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19
lda <$12
db 20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39
cmp <$11
db 40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59
lda <$22
db 60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79
sbc <$21
db 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99
bvc zgrtr1
db 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19
and #128
db 20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39
jmp predic1
db 40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59
zgrtr1 bmi tpredic
db 60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79
jmp fpredic
db 80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99
db 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19
db 20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39
db 40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55


; Ones and tens of 256 times value
; *** LESS?
org $BA00
def_inst_2op 2
ot256 db 0,56,12,68,24,80,36,92,48,4,60,16,72,28,84,40,96,52,8,64;
lda <$11
db 20,76,32,88,44,0,56,12,68,24,80,36,92,48,4,60,16,72,28,84;
cmp <$12
db 40,96,52,8,64,20,76,32,88,44,0,56,12,68,24,80,36,92,48,4;
lda <$21
db 60,16,72,28,84,40,96,52,8,64,20,76,32,88,44,0,56,12,68,24;
sbc <$22
db 80,36,92,48,4,60,16,72,28,84,40,96,52,8,64,20,76,32,88,44;
bvc zgrtr1
db 0,56,12,68,24,80,36,92,48,4,60,16,72,28,84,40,96,52,8,64;
and #128
db 20,76,32,88,44,0,56,12,68,24,80,36,92,48,4,60,16,72,28,84;
jmp predic1
db 40,96,52,8,64,20,76,32,88,44,0,56,12,68,24,80,36,92,48,4;
db 60,16,72,28,84,40,96,52,8,64,20,76,32,88,44,0,56,12,68,24;
db 80,36,92,48,4,60,16,72,28,84,40,96,52,8,64,20,76,32,88,44;
db 0,56,12,68,24,80,36,92,48,4,60,16,72,28,84,40,96,52,8,64;
db 20,76,32,88,44,0,56,12,68,24,80,36,92,48,4,60,16,72,28,84;
db 40,96,52,8,64,20,76,32,88,44,0,56,12,68,24,80


; Hundreds and thousands of 256 times value
; *** EQUAL? (2OP)
org $BB00
def_inst_2op_eq 1
ht256 db 0,2,5,7,10,12,15,17,20,23,25,28,30,33,35,38,40,43,46,48;
lda <$11
db 51,53,56,58,61,64,66,69,71,74,76,79,81,84,87,89,92,94,97,99;
eor <$21
db 2,4,7,10,12,15,17,20,22,25,28,30,33,35,38,40,43,45,48,51;
bne fpredic
db 53,56,58,61,63,66,68,71,74,76,79,81,84,86,89,92,94,97,99,2;
lda <$12
db 4,7,9,12,15,17,20,22,25,27,30,32,35,38,40,43,45,48,50,53;
eor <$22
db 56,58,61,63,66,68,71,73,76,79,81,84,86,89,91,94,96,99,2,4;
beq predic1
db 7,9,12,14,17,20,22,25,27,30,32,35,37,40,43,45,48,50,53,55;
jmp fpredic
db 58,60,63,66,68,71,73,76,78,81,84,86,89,91,94,96,99,1,4,7;
db 9,12,14,17,19,22,24,27,30,32,35,37,40,42,45,48,50,53,55,58;
db 60,63,65,68,71,73,76,78,81,83,86,88,91,94,96,99,1,4,6,9;
db 12,14,17,19,22,24,27,29,32,35,37,40,42,45,47,50,52,55,58,60;
db 63,65,68,70,73,76,78,81,83,86,88,91,93,96,99,1,4,6,9,11;
db 14,16,19,22,24,27,29,32,34,37,40,42,45,47,50,52


; Divide by ten
; *** ZERO?
org $BC00
def_inst_1op 128
divten db 0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1
lda <$11
db 2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3
ora <$21
db 4,4,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5
beq tpredic
db 6,6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,7,7,7,7
; falls through
db 8,8,8,8,8,8,8,8,8,8,9,9,9,9,9,9,9,9,9,9
db 10,10,10,10,10,10,10,10,10,10,11,11,11,11,11,11,11,11,11,11
db 12,12,12,12,12,12,12,12,12,12,13,13,13,13,13,13,13,13,13,13
db 14,14,14,14,14,14,14,14,14,14,15,15,15,15,15,15,15,15,15,15
db 16,16,16,16,16,16,16,16,16,16,17,17,17,17,17,17,17,17,17,17
db 18,18,18,18,18,18,18,18,18,18,19,19,19,19,19,19,19,19,19,19
db 20,20,20,20,20,20,20,20,20,20,21,21,21,21,21,21,21,21,21,21
db 22,22,22,22,22,22,22,22,22,22,23,23,23,23,23,23,23,23,23,23
db 24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25


; Modulo by ten
; Predicate handling
org $BD00
fpredic lda #128
modten db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
jmp predic1
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
tpredic lda #0
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
predic1 fetch_pc x,eor
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
tax
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9 ;100
arr #$C0
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
bcs predic8
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9 ;200
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5 ;256


; Z-character jump tables
; If it should branch
org $BE00
txa
bvs predic3


zchlut ;     0    1    2    3    4    5    6    7    8    9  10  11  12  13  14  15
; Long offset
;    16  17  18  19  20   21  22  23  24  25  26  27  28  29  30  31
eor #$20
if zver=1
anc #$3F
db zza2,zza2,zzt1,zzt2,zzp1,zzp2,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
adc #$E0
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
if large
db zza2,zza2,zzt2,zzt0,zzp2,zzp0,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
bpl predic2
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
dec <$0E
db zza2,zza2,zzt0,zzt1,zzp0,zzp1,zzes,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
db zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
endif
endif
if zver=2
predic2 clc
db zza2,zzfw,zzt1,zzt2,zzp1,zzp2,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
adc <$20
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
sta $1020
db zza2,zzfw,zzt2,zzt0,zzp2,zzp0,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
if large
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
bcc predick
db zza2,zzfw,zzt0,zzt1,zzp0,zzp1,zzes,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
inc <$0E
db zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
endif
endif
if zver=3
predick fetch_pc y,lax
db zza2,zzfw,zzfw,zzfw,zzt1,zzt2,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
jmp predic4
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
 
db zza2,zzfw,zzfw,zzfw,zzp1,zzp0,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
; Short offset
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
predic3 and #$3F
db zza2,zzfw,zzfw,zzfw,zzp0,zzp2,zzes,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
cmp #2
db zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
bcc predicq
predic4 sbc #2
bcs predic5
if large
ldy <$20
dey
sty $1020
cpy #255
bne predic5
lsr <$0E
else
dec $1020
endif
endif
db zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe ;HIGH ESCAPE
predic5 sec
db zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe ;HIGH ESCAPE
adc <$10
db zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle ;LOW ESCAPE
sta <$10
db zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle ;LOW ESCAPE
bcc predic9
db zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs ;FWORDS
inc $1020
db zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs ;FWORDS
if large
bne predic9
inc <$0E
endif
jmp nxtinst
 
; If should not branch
predic8 bvc predic9
inc <$10
bne predic9
inc $1020
if large
bne predic9
inc <$0E
endif
predic9 jmp nxtinst
 
predicq jmp ret8
 
; *** IGRTR?
def_inst_2op 5
ldx <$11
jsr xvalue
inc <$14
bne zigrtr2
inc <$24
zigrtr1 jsr xstore
lda <$14
cmp <$11
lda <$24
sbc <$21
bvc zigrtr2
and #128
jmp predic1
zigrtr2 bmi zigrtr3
jmp fpredic
zigrtr3 jmp tpredic
 
; *** DLESS?
def_inst_2op 4
ldx <$11
jsr xvalue
ldy <$14
dey
sty <$14
cpy #255
bne zdless1
dec <$24
zdless1 jsr xstore
lda <$11
cmp <$14
lda <$21
sbc <$24
bvc zigrtr2
and #128
jmp predic1
 
; *** PTSIZE
def_inst_1op 132
lda $1021
ora #255
dcp $1011
bne zptsz1
dec $1021
zptsz1 ldx $5801
lda ptsizt,x
jmp val8


; Subroutines for dealing with specific Z-characters below
; *** PUT
org $BF01
def_inst_ext 225
lda <$12
asl a
rol <$22
clc
adc <$11
sta $1011
lda <$22
adc <$21
sta $1021
if smalend
lda <$13
else
lda <$23
endif
sta $5801
inc $1011
bne zput1
inc $1021
zput1 ds 0
if smalend
lda <$23
else
lda <$13
endif
sta $5801
bit $1020
jmp nxtinst


; Alphabet row 0 and 1 [11]
; *** PUTB
zzal = *-1
def_inst_ext 226
lda <pshift
lda <$12
sta <tshift
clc
tya
adc <$11
sta $1011
lda <$22
adc <$21
sta $1021
lda <$13
sta $5801
bit $1020
jmp nxtinst
 
; *** GET
def_inst_2op 15
lda <$12
asl a
rol <$22
clc
adc <$11
sta $1011
lda <$22
adc <$21
sta $1021
lda $5801
if smalend
sta <$14
else
sta <$24
endif
inc $1011
bne zget1
inc $1021
zget1 ds 0
lda $5801
if smalend
sta <$24
else
sta <$14
endif
bit $1020
jmp val16
 
; *** GETB
def_inst_2op 16
lda <$12
clc
adc <$11
sta $1011
lda <$22
adc <$21
sta $1021
lda $5801
bit $1020
jmp val8
 
; *** ADD
def_inst_2op 20
clc
lda <$11
adc <$12
sta <$14
lda <$21
adc <$22
sta <$24
jmp val16
 
; *** SUB
def_inst_2op 21
sec
lda <$11
sbc <$12
sta <$14
lda <$21
sbc <$22
sta <$24
jmp val16
 
; *** BAND
def_inst_2op 9
lda <$11
and <$12
sta <$14
lda <$21
and <$22
sta <$24
jmp val16
 
; *** BOR
def_inst_2op 8
lda <$11
ora <$12
sta <$14
lda <$21
ora <$22
sta <$24
jmp val16
 
; *** BCOM
def_inst_1op 143
lda <$11
eor #$FF
sta <$14
lda <$21
eor #$FF
sta <$24
jmp val16
 
; *** BTST
def_inst_2op 7
lda <$11
and <$12
eor <$12
sta <4
lda <$21
and <$22
eor <$22
ora <4
bne zbtst1
jmp predic1
zbtst1 jmp fpredic
 
; *** MUL
def_inst_2op 22
lax <$11
clc
adc <$12
bcc zmul1
eor #255
adc #0
zmul1 tay
txa
sec
sbc <$12
bcs zmul2
eor #255
adc #1
sec
zmul2 tax
lda multabl,y
sbc multabl,x
sta <$14
php
lda <$11
clc
adc <$12
tay
bcc zmul3
lda multabh+256,y
jmp zmul4
zmul3 lda multabh,y
zmul4 plp
sbc multabh,x
sta <$24
; low*high
lax <$11
clc
adc <$22
bcc zmul5
eor #255
adc #0
zmul5 tay
txa
sec
sbc <$22
bcs zmul6
eor #255
adc #1
sec
zmul6 tax
lda multabl,y
sbc multabl,x
clc
adc <$24
sta <$24
; high*low
lax <$21
clc
adc <$12
bcc zmul7
eor #255
adc #0
zmul7 tay
txa
sec
sbc <$12
bcs zmul8
eor #255
adc #1
sec
zmul8 tax
lda multabl,y
sbc multabl,x
clc
clc
adc #59
adc <$24
jmp putcha0
sta <$24
jmp val16


; Alphabet row 2 (and spaces and carriage return) [10]
; *** PUSH
zza2 = *-1
def_inst_ext 232
lda <pshift
inc <datasp
sta <tshift
ldx <datasp
lda alpha2,y
lda <$11
jmp putchar
sta dstackl,x
lda <$21
sta dstackh,x
jmp nxtinst
 
; *** POP
def_inst_ext 233
ldx <datasp
dec <datasp
lda dstackl,x
sta <$12
lda dstackh,x
sta <$22
ldx <$11
jsr xstore
jmp nxtinst
 
; *** FSTACK
def_inst_0op 185
dec <datasp
jmp nxtinst
 
; *** SET
def_inst_2op 13
lda <$12
sta <$14
lda <$22
sta <$24
ldx <$11
jsr xstore
jmp nxtinst
 
; *** VALUE
def_inst_1op 142
ldx <$11
jsr xvalue
jmp val16
 
; *** INC
def_inst_1op 133
ldx <$11
jsr xvalue
inc <$14
bne zinc1
inc <$24
zinc1 jsr xstore
jmp nxtinst


; Escape character [5]
; *** DEC
zzes = *-1
def_inst_1op 134
lda #$60
ldx <$11
sta <tshift
jsr xvalue
ldy <$14
dey
sty <$14
cpy #255
bne zinc1
dec <$24
jsr xstore
jmp nxtinst
 
; Store value from <$x4 into variable labeled X
xstore lda <$14
cpx #0
bne xstore1
; Top of stack
ldy <datasp
sta dstackl,y
lda <$24
sta dstackh,y
rts
xstore1 cpx #16
bcs xstore2
; Local variable
sta <locall,x
lda <$24
sta <localh,x
rts
; Global variable
xstore2 ldy globadl,x
sty $1014
ldy globadh,x
sty $1024
if smalend
sta $5801
else
ldy <$24
sty $5801
endif
inc $1014
if globodd
bne xstore3
inc $1024
endif
xstore3 if smalend
lda <$24
endif
sta $5801
lda $1020
rts
rts


; High escape [17]
; Read from variable labeled X into <$x4
zzhe = *-1
xvalue txa
sty <chroff
bne xvalue1
asl <chroff
; Top of stack
asl <chroff
ldy <datasp
asl <chroff
lda dstackl,y
asl <chroff
sta <$14
asl <chroff
lda dstackh,y
lda #$80
sta <$24
sta <tshift
rts
xvalue1 cpx #16
bcs xvalue2
; Local variable
lda <locall,x
sta <$14
lda <localh,x
sta <$24
rts
; Global vaiable
xvalue2 ldy globadl,x
sty $1015
ldy globadh,x
sty $1025
lda $5801
if smalend
sta <$14
else
sta <$24
endif
inc $1015
if globodd
bne xvalue3
inc $1025
endif
xvalue3 lda $5801
if smalend
sta <$24
else
sta <$14
endif
bit $1020
rts
rts


; Low escape [10]
; *** IN?
zzle = *-1
def_inst_2op 6
lda <pshift
ldx <$11
sta <tshift
clc
tya
lda objadl,x
ora <chroff
adc #4
jmp putchar
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
bit $1020
eor <$21
bne zin1
jmp predic1
zin1 jmp fpredic
 
; *** FSET?
def_inst_2op 10
ldx <$11
ldy <$12
clc
lda objadl,x
adc flagad,y
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
and flagbit,y
bne zfsetp1
bit $1020
jmp predic1
zfsetp1 jmp fpredic
 
; *** FSET
def_inst_2op 11
ldx <$11
ldy <$12
clc
lda objadl,x
adc flagad,y
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
ora flagbit,y
sta $5801
bit $1020
jmp nxtinst


; Temporary shift to row 0 [5]
; *** FCLEAR
zzt0 = *-1
def_inst_2op 12
lda #$00
ldx <$11
sta <tshift
ldy <$12
rts
clc
lda objadl,x
adc flagad,y
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
and flagbic,y
sta $5801
bit $1020
jmp nxtinst


; Temporary shift to row 1 [5]
; *** LOC
zzt1 = *-1
def_inst_1op 131
lda #$20
ldx <$11
sta <tshift
clc
rts
lda objadl,x
adc #4
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
bit $1020
jmp val8


; Temporary shift to row 2 [5]
; *** FIRST?
zzt2 = *-1
def_inst_1op 130
lda #$40
ldx <$11
sta <tshift
clc
rts
lda objadl,x
adc #6
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
bit $1020
jmp valp


; Permament shift to row 0 [7]
; *** NEXT?
zzp0 = *-1
def_inst_1op 129
lda #$00
ldx <$11
sta <tshift
clc
sta <pshift
lda objadl,x
rts
adc #5
sta $5010
lda objadh,x
adc #0
sta $5020
lda $5801
bit $1020
; fall through


; Permament shift to row 1 [7]
; Value of instruction is 8-bits (from A)
zzp1 = *-1
; Predicate is then if value is nonzero
lda #$20
valp fetch_pc y,ldx
sta <tshift
bne valpa
sta <pshift
; Push to stack
rts
inc <datasp
ldy <datasp
sta dstackl,y
sta <4
txa
sta dstackh,y
lda <4
jmp valpd1
valpa cpx #16
bcs valpb
; Local variable
sta <locall,x
ldy #0
sty <localh,x
jmp valpd
; Global variable
valpb ldy globadl,x
sty $1014
ldy globadh,x
sty $1024
if smalend
sta $5801
else
ldy #0
sty $5801
endif
inc $1014
if globodd
bne valpc
inc $1024
endif
valpc if smalend
ldy #0
sty $5801
else
sta $5801
endif
bit $1020
valpd tax
valpd1 beq valpe
jmp fpredic
valpe jmp tpredic


; Permament shift to row 2 [7]
; Macro to do one step of ARCFOUR
zzp2 = *-1
; Result is stored in accumulator
lda #$40
macro do_arcfour
sta <tshift
inc <$3D
sta <pshift
ldx <$3D
rts
lda arcfour,x
pha
clc
adc <$3E
sta <$3E
tay
sta arcfour,y
pla
sta arcfour,x
clc
adc arcfour,y
tax
lda arcfour,x
endm


; Start fwords [17]
; *** RANDOM
zzfw = *-1
def_inst_ext 231
sty <chroff
ldx <$21
asl <chroff
beq zrand1
asl <chroff
lda bit1tab,x
asl <chroff
sta <$23
asl <chroff
lda #$FF
asl <chroff
jmp zrand2
lda #$A0
zrand1 ldx <$11
sta <tshift
lda bit1tab,x
rts
zrand2 sta <$13
zrand3 do_arcfour
and <$23
sta <$24
cmp <$21
beq zrand4 ; exactly equal
bcs zrand1 ; try again; out of range
jmp zrand5 ; low byte doesn't need to check
zrand4 do_arcfour
and <$13
cmp <$11
bcs zrand1 ; try again; out of range
adc #1
sta <$14
jmp zrand6
zrand5 do_arcfour
sec
adc #0
sta <$14
zrand6 lda #0
adc <$24
sta <$24
jmp val16


; Print fwords [63]
; *** JUMP
zzfs = *-1
def_inst_1op 140
lda <$11
sec
sbc #2
tax
lda <$21
sbc #0
tay
bpl zjump1
dec <$0E
zjump1 txa
clc
adc <$10
sta <$10
tya
tya
ora <chroff
adc <$20
sta <idxl
sta $1020
lda #0
bcc zjump2
sta <idxh
inc <$0E
lda #low(fwords-64)
zjump2 jmp nxtinst
sta <corel
 
lda #high(fwords-64)
; Macro to find a property, given object and property number
sta <coreh
; Object in <$11, property in <$12, branch to \1 if found
lda <pshift
; If \1 is with # at front then assume always will be found
pha
; X contains property size only in high 3-bits if found
lda <pch
; X contains property number if not found
pha
; Output is $1014 and $1024 with address of property id
lda <pcm
macro propfind
pha
; Find the property table
lda <pcl
ldx <$11
pha
clc
jsr mget
lda objadl,x
asl a
adc #7
sta <pcl
sta $1015
lda <byth
lda objadh,x
adc #0
sta $1025
lda $5801
if smalend
sta <$14
else
sta <$24
endif
inc $1015
bne n\@a
inc $1025
n\@a lda $5801
if smalend
sta $1014
bit $1024
else
sta $1024
bit $1014
endif
; Skip the short description
lda $5801
sec
rol a
bcc n\@d
inc $1024
clc
n\@d adc <$14
sta $1014
bcc n\@b
inc $1024
; Find this property
n\@b lda $5081
if '\<1'!='#'
beq n\@c
endif
eor <$12
tax
and #$1F
if '\<1'='#'
beq n\@c
else
beq \1
endif
lda ptsizt,x
sec
adc <$14
sta $1014
bcc n\@b
inc $1024
jmp n\@b
n\@c ds 0
endm
 
; *** GETPT
def_inst_2op 18
propfind zgetpt1
lda $1020
and #0
jmp val8
zgetpt1 lda $1020
inc <$14
bne zgetpt2
inc <$24
zgetpt2 jmp val16
 
; *** GETP
def_inst_2op 17
propfind zgetp2
; Use default value
asl <$11
rol <$21 ;clears carry
lda #low(object-2)
adc <$11
sta $1015
lda #high(object-2)
adc <$21
sta $1025
lda $5801
if smalend
sta <$14
else
sta <$24
endif
inc $1015
if object&1
bne zgetp1
inc $1025
endif
zgetp1 lda $5801
if smalend
sta <$24
else
sta <$14
endif
bit $1020
jmp val16
; Use actual value
zgetp2 inc $1014
bne zgetp3
inc $1024
zgetp3 cpx #$20
bne zgetp5
; Long property
lda $5801
if smalend
sta <$14
else
sta <$24
endif
inc $1014
bne zgetp4
inc $1024
zgetp4 lda $5801
if smalend
sta <$14
else
sta <$24
endif
jmp val16
; Short property
zgetp5 lda $5801
bit $1020
jmp val8
 
; *** PUTP
def_inst_ext 227
propfind #
inc $1014
bne zputp2
inc $1024
zputp2 cpx #$20
bne zputp4
; Long property
if smalend
lda <$13
else
lda <$23
endif
sta $5801
inc $1014
bne zputp3
inc $1024
zputp3 if smalend
lda <$23
else
lda <$13
endif
sta $5801
lda $1020
jmp nxtinst
; Short property
zputp4 lda <$13
sta $5801
lda $1020
jmp nxtinst
 
; *** NEXTP
def_inst_2op 19
ldx <$11
bne znextp4
; Find first property
clc
lda objadl,x
adc #7
sta $1015
lda objadh,x
adc #0
sta $1025
lda $5801
if smalend
sta <$14
else
sta <$24
endif
inc $1015
bne znextp1
inc $1025
znextp1 lda $5801
if smalend
sta $1014
bit $1024
else
sta $1024
bit $1014
endif
; Skip the short description
lda $5801
sec
rol a
rol a
sta <pcm
bcc znextp2
inc $1024
clc
znextp2 adc <$14
sta $1014
bcc znextp3
inc $1024
znextp3 lda $5801
and #$1F
bit $1020
jmp val8
znextp4 propfind #
lda ptsizt,x
sec
adc <$14
sta $1014
bcc znextp5
inc $1024
znextp5 lda $5801
bit $1020
and #$1F
jmp val8
 
; *** REMOVE
def_inst_1op 137
lda #0
lda #0
rol a
sta <$12
sta <pch
; fall through
jsr putstr
 
pla
; *** MOVE
sta <pcl
def_inst_2op 14
pla
; Find the LOC of first object, see if need to remove
sta <pcm
ldx <$11
pla
clc
sta <pch
lda objadl,x
pla
adc #4
sta <pshift
sta $1013
sta <tshift
lda objadh,x
rts
adc #0
sta $1023
lda $5801
ldy <$12
sty $5801
tay
beq zmove2
; Look at the NEXT slot too
inc $1013
bne zmove1
inc $1023
zmove1 ldy $5801
ldx #0
stx $5801
; Find it in the FIRST-NEXT chain of the parent object
tax
lda objadl,x
adc #6
sta $1014
lda objadh,x
adc #0
sta $1024
lax $5801 ; not adjust carry flag
eor <$11
bne zmove3
; It is the first child object
; Let First(Parent)=Next(Child)
sty $5801
jmp zmove2
; It is not the first child object
zmove3 lda objadl,x
adc #5
sta $1014
lda objadh,x
adc #0
sta $1024
lax $5801
eor <$11
bne zmove3
; It is found
sty $5801
; Now insert the object into the new container (if nonzero)
zmove2 ldx <$12
beq zmove4
lda objadl,x
adc #6
sta $1014
lda objadh,x
adc #0
sta $1024
ldy $5801
stx $5801
bit $1013
bit $1023
sty $5801
zmove4 lda $1020
jmp nxtinst


bank 18
; Print a space
org $8000
space lda <$30
cmp #$E2
bne space1
lda <$31
and #$1F
bne space1
jsr bufout
lda <$31
and #$1F
bne space2
space1 inc <$31
space2 rts


; More reset initialization codes
; Output and clear the buffer
reset1 bit $2002
bufout lda <$31
vblw1 bit $2002
anc #$1F
bpl vblw1
adc <$30
dex
bcc bufout0
jsr addlin1
bufout0 ldx #0
lda <$32
ldy <$31
bufout1 bit $2002
bpl bufout1
stx $2001 ; render off
sta $2006
sty $2006
ldx #$E2
cpx <$30
beq bufout3
bufout2 lda <0,x
sta $2007
inx
inx
vblw2 bit $2002
cpx <$30
bpl vblw2
bne bufout2
; Zero some variables
bufout3 tya
lda #0
anc #$1F
sta <mapad+1
bne bufout4
sta <outrdy
; Blank the bottom row (just scrolled in)
sta <linrdy
lda <5
sta <cursx
sta <bufptr
sta <pch
sta <blinker
sta <keychar
sta <lladl
sta <cstkcnt
sta <dstkcnt
; Fill up the palette
ldx #$3F
stx $2006
sta $2006
sta $2006
stx $2007
lda <4
stx $2007
sta $2007
stx <curspal
; Clear CIRAM
ldy #$20
sty <lladh
sty $2006
sta $2006
sta $2006
tax
lda #32
reset2 sta $2007
sta $2007 ;1
sta $2007
sta $2007
sta $2007
sta $2007
Line 695: Line 2,119:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;10
sta $2007
sta $2007
sta $2007
sta $2007
Line 701: Line 2,126:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;16
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;20
sta $2007
sta $2007
sta $2007
sta $2007
Line 714: Line 2,139:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;30
bufout4 lda #$F8
sta $2005
ldx <$33
stx $2005
anc #$08
sta $2001
sta $2000
lda <$30
sbc #$E1
clc
adc <$31
sta <$31
lda <$32
adc #0
sta <$32
lda #$E2
sta <$30
bufout5 rts
; Skip to the next line
addline sec
addlin1 lda <$33
adc #7
sta <$33
cmp #$F0
bcc addlin2
anc #0
sta <$33
addlin2 lda <$31
and #$E0
adc #$20
sta <$31
lda <$32
adc #0
sta <$32
cmp #$27
bne addlin3
lda <$31
cmp #$C0
bne addlin3
lda #$24
sta <$32
lda #0
sta <$31
; Prepare address to blank out the line
addlin3 lax <$31
clc
adc #$40
sta <4
lda <$32
adc #0
sta <5
cmp #$27
bcc addlin4
cpx #$80
bcc addlin4
lda #$24
sax <4
sta <5
addlin4 dec <$34
bne addlin5
lda #27
sta <$34
jmp more
addlin5 rts
; Display the <MORE> prompt
more ldx #0
lda <$32
ldy <$31
more1 bit $2002
bpl more1
stx $2001 ; render off
sta $2006
sty $2006
lda #'<'
sta $2007
sta $2007
lda #'M'
sta $2007
sta $2007
lda #'O'
sta $2007
sta $2007
sta $2007 ;32
lda #'R'
sta $2007
sta $2007
lda #'E'
sta $2007
sta $2007
lda #'>'
sta $2007
sta $2007
; Blank the bottom row (just scrolled in)
lda <5
sta $2006
lda <4
sta $2006
lda #32
sta $2007 ;1
sta $2007
sta $2007
sta $2007
sta $2007
Line 729: Line 2,242:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;10
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;48
sta $2007
sta $2007
sta $2007
sta $2007
Line 739: Line 2,252:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;20
sta $2007
sta $2007
sta $2007
sta $2007
Line 744: Line 2,258:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;30
; Re-enable rendering
lda #$F8
sta $2005
ldx <$33
stx $2005
anc #$08
sta $2001
sta $2000
; Wait for keyboard not pushed
more2 ldx #5
stx $4016
dex
ldy #9
more3 stx $4016
lda $4017
ora #$E1
eor #$FF
bne more2
lda #6
sta $4016
lda $4017
ora #$E1
eor #$FF
bne more2
dey
bne more3
; Wait for space-bar pushed
ldx #5
lda #4
ldy #6
more4 stx $4016 ;reset
sta $4016 ;0/0
sty $4016 ;0/1
sta $4016 ;1/0
sty $4016 ;1/1
sta $4016 ;2/0
sty $4016 ;2/1
sta $4016 ;3/0
sty $4016 ;3/1
sta $4016 ;4/0
sty $4016 ;4/1
sta $4016 ;5/0
sty $4016 ;5/1
sta $4016 ;6/0
sty $4016 ;6/1
sta $4016 ;7/0
sty $4016 ;7/1
sta $4016 ;8/0
sty $4016 ;8/1
and $4017
bne more4
; Erase <MORE>
lda #0
sta $2001
lda <$32
sta $2006
lda <$31
sta $2006
lda #32
sta $2007
sta $2007
sta $2007
sta $2007
Line 749: Line 2,327:
sta $2007
sta $2007
sta $2007
sta $2007
sta $2007 ;64
sta $2007
rts
 
; *** PRINTC
def_inst_ext 229
lda <$11
beq zprntc2
cmp #32
beq zprntc1
cmp #13
beq zcrlf
ldx <$30
beq zprntc2
sta <0,x
inc <$30
zprntc1 jmp nxtinst
zprntc2 jsr space
jmp nxtinst
 
; *** CRLF
def_inst_0op 187
zcrlf jsr bufout
lda <$31
ora #$1F
sta <$31
zcrlf2 jmp nxtinst
 
; *** PRINTN
def_inst_ext 230
lda <$30
beq zcrlf2 ; ensure there is room in the buffer
ldy <$11
lax <$21
anc #$FF
bcc znum01
eor #$FF
sta <4
ldx <$30
inc <$30
lda #'-'
sta <0,x
tya
eor #$FF
tay
ldx <4
znum01 lda digit0l,y
adc digit0h,x
pha
cmp #10
lda digit1l,y
adc digit1h,x
pha
cmp #10
lda digit2l,y
adc digit2h,x
pha
cmp #10
lda #0
adc digit3h,x
pha
cmp #10
lda #0
adc digit4h,x
ldx <$30
tay ; make the flag according to accumulator
beq znum02
; Five digits
sta <0,x
pla
sta 1,x
pla
sta 2,x
pla
sta 3,x
pla
sta 4,x
txa
axs #-5
stx <$30
jmp nxtinst
znum02 pla
beq znum03
; Four digits
sta <0,x
pla
sta 1,x
pla
sta 2,x
pla
sta 3,x
txa
axs #-4
stx <$30
jmp nxtinst
znum03 pla
beq znum04
; Three digits
sta <0,x
pla
sta 1,x
pla
sta 2,x
txa
axs #-3
stx <$30
jmp nxtinst
znum04 pla
beq znum05
; Two digits
sta <0,x
inx
pla
sta <0,x
inx
inx
bne reset2
stx <$30
; Initialize variables
jmp nxtinst
lda #low(start)
znum05 pla
sta <pcl
; One digit
lda #high(start)
sta <0,x
sta <pcm
inc <$30
lda #(8*27)
sta <scrolly
lda #25
sta <linecnt
; Begin program
jmp nxtinst
jmp nxtinst


; Instruction decoding table
; *** PRINTI
opccnt = 236
def_inst_0op 178
jsr textpc
jmp nxtinst


macro opcode
; *** PRINTR
org opctab+(\1)
def_inst_0op 179
db high((\2)-1) ; Subtracting 1 so that RTS trick will be used
jsr textpc
org opctab+(\1)+opccnt
jsr bufout
db low((\2)-1)
lda <$31
if (\1)<$20
ora #$1F
opcode (\1)+$20, \2
sta <$31
opcode (\1)+$40, \2
lda #1
opcode (\1)+$60, \2
jmp ret8
opcode (\1)+$C0, \2
endif
if ((\1)>$7F)&((\1)<$90)
opcode (\1)+$10, \2
opcode (\1)+$20, \2
endif
endmac


opctab ds opccnt*2
; *** PRINTB
opcode 1, z_equal
def_inst_1op 135
opcode 2, z_less
jsr textba
opcode 3, z_grtr
jmp nxtinst
opcode 4, z_dless
opcode 5, z_igrtr
opcode 6, z_in
opcode 7, z_btst
opcode 8, z_bor
opcode 9, z_band
opcode 10, z_ftst
opcode 11, z_fset
opcode 12, z_fclr
opcode 13, z_set
opcode 14, z_move
opcode 15, z_get
opcode 16, z_getb
opcode 17, z_getp
opcode 18, z_getpt
opcode 19, z_nextp
opcode 20, z_add
opcode 21, z_sub
opcode 22, z_mul
opcode 23, z_div
opcode 24, z_mod
opcode 128, z_zero
opcode 129, z_next
opcode 130, z_first
opcode 131, z_loc
opcode 132, z_ptsiz
opcode 133, z_inc
opcode 134, z_dec
opcode 135, z_prntb
opcode 137, z_remov
opcode 138, z_prntd
opcode 139, z_ret
opcode 140, z_jump
opcode 141, z_print
opcode 142, z_value
opcode 143, z_bcom
opcode 176, z_rtrue
opcode 177, z_rfals
opcode 178, z_prnti
opcode 179, z_prntr
opcode 180, z_noop
opcode 181, z_save
opcode 182, z_rstor
opcode 183, z_rest
opcode 184, z_rstac
opcode 185, z_fstac
opcode 186, z_quit
opcode 187, z_crlf
opcode 188, z_usl
opcode 189, z_vrfy
opcode 224, z_call
opcode 225, z_put
opcode 226, z_putb
opcode 227, z_putp
opcode 228, z_read
opcode 229, z_prntc
opcode 230, z_prntn
opcode 231, z_randm
opcode 232, z_push
opcode 233, z_pop
opcode 234, z_split
opcode 235, z_scrn
org opctab+(opccnt*2)


; Multiply <op0h,<op0l by <op1h,<op1l
; *** PRINT
; [...W ...X ...Y ...Z]
def_inst_1op 141
multipl ;
asl <$11
 
rol <$21
; Z*Z
lda #0
lda <op1l
rol a
and #$0F
sta <$36
sta <r0
jsr textwa
lda <op0l
jmp nxtinst
asl a
asl a
asl a
asl a
sta <r3 ; used later
ora <r0
tax
lda multab,x
sta <r1


; Y*Z
; *** PRINTD
lda <op0l
def_inst_1op 138
and #$F0
ldx <$11
sta <r4 ; used later
ora <r0
tax
lda multabl,x
clc
clc
adc <r1
lda objadl,x
sta <r1
adc #7
lda multabr,x
sta $1012
lda objadh,x
adc #0
adc #0
sta <byth
sta $1022
if smalend
lda $5801
else
ldy $5801
endif
inc $1012
bne zprntd1
inc $1022
zprntd1 if smalend
adc #1
sta <$11
lda $5801
else
lda $5801
adc #1
sta <$11
tya
endif
adc #0
sta <$21
jsr textba
jmp nxtinst


; X*Z
; *** VERIFY
lda <op0h
def_inst_0op 189
asl a
jmp tpredic ; there is no disk, so just assume it is OK
asl a
 
asl a
; *** QUIT
asl a
def_inst_0op 186
ora <r0
jsr bufout
tax
lda <$31
lda multab,x
ora #$1F
clc
sta <$31
adc <byth
jsr bufout
sta <byth
zquit jmp zquit
 
; *** READ
jsr bufout
;TODO
zread jmp zread


; W*Z
bank intbank+3
lda <op0h
; Z-character decoding
and #$F0
; high 3-bits = state, low 5-bits = value
ora <r0
tax
lda multabl,x
clc
adc <byth
sta <byth


; Z*Y
org $F100-12
lda <op1l
; Text starting from program counter
and #$F0
textpc lda #0
sta <r0
sta <$38
lda <op0l
sta <$27
and #$0F
ldx #$A0
ora <r0
stx <$09
tax
stx <$0A
lda multabl,x
clc
adc <r1
sta <r1
lda multabr,x
adc <byth
sta <byth


; Y*Y
org $F100
lda <op0l
lda <$27
lsr a
bmi textpc1
lsr a
lda #$F2
sta <$39
lda #$FE
pha
fetch_pc y,lda
if smalend
sta <$17
else
sta <$27
endif
if smalend
fetch_pc y,lda
sta <$27
else
fetch_pc y,ldx
stx <$17
endif
lsr a
lsr a
lsr a
lsr a
ora <r0
anc #31
ora <$09
tax
tax
lda multab,x
lda zchad,x
clc
pha
adc <byth
textpc1 rts
sta <byth


; X*Y
org $F200
lda <op0h
lda #$FE
and #$0F
pha
ora <r0
inc <$39
ldx <$17
stx <4
lda <$27
asl <4
rol a
asl <4
rol a
asl <4
rol a
anc #31
ora <$09
tax
tax
lda multabl,x
lda zchad,x
clc
pha
adc <byth
rts
sta <byth


; Z*X
org $F300
lda <op1h
lda #$F1
and #$0F
sta <$39
sta <r0
lda #$FE
ora <r3
pha
tax
lda <$17
lda multab,x
anc #31
clc
ora <$09
adc <byth
sta <byth
 
; Y*X
lda <r0
ora <r4
tax
tax
lda multabl,x
lda zchad,x
clc
adc <byth
sta <byth
 
; Z*W
lda <op0l
and #$0F
sta <r0
lda <op1h
and #$F0
ora <r0
tax
lda multabl,x
clc
adc <byth
sta <byth
 
; Finished multiplication
lda <r1
jsr tostore
jmp nxtinst
 
bank 19
 
org $BD00
; Muliplication table shifted right
;  0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
multabr db $0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0  ; 0
db $0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0  ; 1
db $0,$0,$0,$0,$0,$0,$0,$0,$1,$1,$1,$1,$1,$1,$1,$1  ; 2
db $0,$0,$0,$0,$0,$0,$1,$1,$1,$1,$1,$2,$2,$2,$2,$2  ; 3
db $0,$0,$0,$0,$1,$1,$1,$1,$2,$2,$2,$2,$3,$3,$3,$3  ; 4
db $0,$0,$0,$0,$1,$1,$1,$2,$2,$2,$3,$3,$3,$4,$4,$4  ; 5
db $0,$0,$0,$1,$1,$1,$2,$2,$3,$3,$3,$4,$4,$4,$5,$5  ; 6
db $0,$0,$0,$1,$1,$2,$2,$3,$3,$3,$4,$4,$5,$5,$6,$6  ; 7
db $0,$0,$1,$1,$2,$2,$3,$3,$4,$4,$5,$5,$6,$6,$7,$7  ; 8
db $0,$0,$1,$1,$2,$2,$3,$3,$4,$5,$5,$6,$6,$7,$7,$8  ; 9
db $0,$0,$1,$1,$2,$3,$3,$4,$5,$5,$6,$6,$7,$8,$8,$9  ; A
db $0,$0,$1,$2,$2,$3,$4,$4,$5,$6,$6,$7,$8,$8,$9,$A  ; B
db $0,$0,$1,$2,$3,$3,$4,$5,$6,$6,$7,$8,$9,$9,$A,$B  ; C
db $0,$0,$1,$2,$3,$4,$4,$5,$6,$7,$8,$8,$9,$A,$B,$C  ; D
db $0,$0,$1,$2,$3,$4,$5,$6,$7,$7,$8,$9,$A,$B,$C,$D  ; E
db $0,$0,$1,$2,$3,$4,$5,$6,$7,$8,$9,$A,$B,$C,$D,$E  ; F
 
org $BE00
; Multiplication table shifted left
;  0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
multabl db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00  ; 0
db $00,$10,$20,$30,$40,$50,$60,$70,$80,$90,$A0,$B0,$C0,$D0,$E0,$F0  ; 1
db $00,$20,$40,$60,$80,$A0,$C0,$E0,$00,$20,$40,$60,$80,$A0,$C0,$E0  ; 2
db $00,$30,$60,$90,$C0,$F0,$20,$50,$80,$B0,$E0,$10,$40,$70,$A0,$D0  ; 3
db $00,$40,$80,$C0,$00,$40,$80,$C0,$00,$40,$80,$C0,$00,$40,$80,$C0  ; 4
db $00,$50,$A0,$F0,$40,$90,$E0,$30,$80,$D0,$20,$70,$C0,$10,$60,$B0  ; 5
db $00,$60,$C0,$20,$80,$E0,$40,$A0,$00,$60,$C0,$20,$80,$E0,$40,$A0  ; 6
db $00,$70,$E0,$50,$C0,$30,$A0,$10,$80,$F0,$60,$D0,$40,$B0,$20,$90  ; 7
db $00,$80,$00,$80,$00,$80,$00,$80,$00,$80,$00,$80,$00,$80,$00,$80  ; 8
db $00,$90,$20,$B0,$40,$D0,$60,$F0,$80,$10,$A0,$30,$C0,$50,$E0,$70  ; 9
db $00,$A0,$40,$E0,$80,$20,$C0,$60,$00,$A0,$40,$E0,$80,$20,$C0,$60  ; A
db $00,$B0,$60,$10,$C0,$70,$20,$D0,$80,$30,$E0,$90,$40,$F0,$A0,$50  ; B
db $00,$C0,$80,$40,$00,$C0,$80,$40,$00,$C0,$80,$40,$00,$C0,$80,$40  ; C
db $00,$D0,$A0,$70,$40,$10,$E0,$B0,$80,$50,$20,$F0,$C0,$90,$60,$30  ; D
db $00,$E0,$C0,$A0,$80,$60,$40,$20,$00,$E0,$C0,$A0,$80,$60,$40,$20  ; E
db $00,$F0,$E0,$D0,$C0,$B0,$A0,$90,$80,$70,$60,$50,$40,$30,$20,$10  ; F
 
org $BF00
; Multiplication 16x16 table
;  0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
multab db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00  ; 0
db $00,$01,$02,$03,$04,$05,$06,$07,$08,$09,$0A,$0B,$0C,$0D,$0E,$0F  ; 1
db $00,$02,$04,$06,$08,$0A,$0C,$0E,$10,$12,$14,$16,$18,$1A,$1C,$1E  ; 2
db $00,$03,$06,$09,$0C,$0F,$12,$15,$18,$1B,$1E,$21,$24,$27,$2A,$2D  ; 3
db $00,$04,$08,$0C,$10,$14,$18,$1C,$20,$24,$28,$2C,$30,$34,$38,$3C  ; 4
db $00,$05,$0A,$0F,$14,$19,$1E,$23,$28,$2D,$32,$37,$3C,$41,$46,$4B  ; 5
db $00,$06,$0C,$12,$18,$1E,$24,$2A,$30,$36,$3C,$42,$48,$4E,$54,$5A  ; 6
db $00,$07,$0E,$15,$1C,$23,$2A,$31,$38,$3F,$46,$4D,$54,$5B,$62,$69  ; 7
db $00,$08,$10,$18,$20,$28,$30,$38,$40,$48,$50,$58,$60,$68,$70,$78  ; 8
db $00,$09,$12,$1B,$24,$2D,$36,$3F,$48,$51,$5A,$63,$6C,$75,$7E,$87  ; 9
db $00,$0A,$14,$1E,$28,$32,$3C,$46,$50,$5A,$64,$6E,$78,$82,$8C,$96  ; A
db $00,$0B,$16,$21,$2C,$37,$42,$4D,$58,$63,$6E,$79,$84,$8F,$9A,$A5  ; B
db $00,$0C,$18,$24,$30,$3C,$48,$54,$60,$6C,$78,$84,$90,$9C,$A8,$B4  ; C
db $00,$0D,$1A,$27,$34,$41,$4E,$5B,$68,$75,$82,$8F,$9C,$A9,$B6,$C3  ; D
db $00,$0E,$1C,$2A,$38,$46,$54,$62,$70,$7E,$8C,$9A,$A8,$B6,$C4,$D2  ; E
db $00,$0F,$1E,$2D,$3C,$4B,$5A,$69,$78,$87,$96,$A5,$B4,$C3,$D2,$E1  ; F
 
bank 30
org $C000
 
; Macro for object address (35 bytes)
macro object_address
lda #low(xobject+\2)
sta <corel
lda #high(xobject+\2)
sta <coreh
lda #0
sta <idxh
sta <byth
lda \1
asl a
rol <idxh
asl a
rol <idxh
asl a
rol <idxh ; now carry flag is clear, have 8x value
adc \1 ; add the object number so you have 9x in total
sta <idxl
lda <idxh
adc #0 ; carry out if applicable
sta <idxh
endmac
 
; Print a string
putstr lda #0
sta <pshift
sta <tshift
putstr1 jsr pcgetw
pha
pha
sta <r1
lda <byth
lsr a
ror <r1
lsr a
ror <r1
bankcall putzch
lda <r1
lsr a
lsr a
lsr a
jsr putzch
pla
jsr putzch
bit <byth
bpl putstr1
rts
rts


; Read a word from instruction pointer
org $F400-12
pcgetw jsr pcgetb
; Text from byte address
sta <byth
textba lda #0
; falls through
sta <$38
sta <$27
ldx #$A0
stx <$09
stx <$0A


; Read a byte from instruction pointer, write to A
org $F400
; (clobbers X, Y, and flags)
lda <$27
pcgetb ldy <pcl ; To use later
bmi textba1
lda <pch
lda #$F5
bne pcgetbh ; In high memory; it is greater than 64K
sta <$39
; It is in core memory (always 64K in this program)
lda #$FE
lax <pcm
pha
and #$1F
lda $1011
ora #$60
lda $1021
sta <mapad
lda $5803
txa
if smalend
lsr a
sta <$17
lsr a
else
lsr a
sta <$27
lsr a
endif
lsr a
inc $1011
sta rambank
bne textba2
lda [mapad],y
inc $1021
jmp pcinc
textba2 if smalend
pcgetbh ; 0000 0001 xxyy yyyy zzzz zzzz -> bank=1000 1xx0, mem=10yy yyyy
lda $5803
lax <pcm
sta <$27
and #$3F
else
ora #$80
ldx $5803
sta <mapad
stx <$17
txa
endif
lsr a
inc $1011
lsr a
bne textba3
lsr a
inc $1021
textba3 lsr a
lsr a
lsr a
lsr a
anc #31
and #$06
ora <$09
ora #$88
sta rombank
lda [mapad],y
pcinc inc <pcl
bne pcirts
inc <pcm
bne pcirts
inc <pch
pcirts rts
 
; Deal with reading a register (as VALUE)
; Register in A, result in <byth and A
fetch cmp #16
bcc fetch1
; Global variables
sta <idxl
lda #0
sta <idxh
lda #low(xglobal)
sta <corel
lda #high(xglobal)
sta <coreh
jmp mget
fetch1 cmp #0
bne fetch3
ldx <dstkcnt
bne fetch2
fetch3 ; Local variables
ldx <cstkcnt
ldy $6FF,x
sty <r3
adc <r3 ; Carry flag is already cleared
tax
tax
fetch2 lda $1FF,x
lda zchad,x
sta <byth
pha
lda $2FF,x
rts
textba1 bit $1020
rts
rts


; Deal with store (uses A and <byth as value; instruction as dest)
org $F500
; The value A will remain there once stored
lda #$FE
tostore pha
pha
jsr pcgetb
inc <$39
cmp #0
ldx <$17
bne dostore
stx <4
inc <dstkcnt
lda <$27
; 'dostore' uses A as the register number, the the value on the stack
asl <4
; and <byth. It also omits pushing to the stack (cf. SET, INC, DEC)
rol a
dostore cmp #16
asl <4
bcc store1
rol a
; Global variables
asl <4
sta <idxl
rol a
lda #0
anc #31
sta <idxh
ora <$09
lda #low(xglobal)
sta <corel
lda #high(xglobal)
sta <coreh
jmp mput1
store1 cmp #0
bne store3
ldx <dstkcnt
bne store2 ; <dstkcnt is known to be nonzero
store3 ; Local variables
ldx <cstkcnt
ldy $6FF,x
sty <r3
adc <r3 ; Carry flag is already cleared
tax
tax
store2 pla
lda zchad,x
sta $1FF,x
pha
ldy <byth
sty $2FF,x
rts
rts


; Calculate the current RAM bank and offset given <core* and <idx*
org $F600
macro memory_address
lda #$F4
lda <corel
sta <$39
clc
lda #$FE
adc <idxl
pha
tay
lda <$17
lda <coreh
anc #31
adc <idxh
ora <$09
tax
tax
and #$1F
lda zchad,x
ora #$60
pha
sta <mapad
txa
lsr a
lsr a
lsr a
lsr a
lsr a
sta rambank
endmac
 
; Implement GET/GETB
; <corel=low addr, <coreh=high addr
; <idxl=low index, <idxh=high index
; A=low data, <byth=high data
mget asl <idxl
rol <idxh
jsr mgetb
sta <byth
inc <idxl
bne mgetb
inc <idxh
mgetb memory_address
lda [mapad],y
rts
rts


; Implment PUT/PUTB
org $F700-12
; <corel=low addr, <coreh=high addr
; Text from word address (aligned)
; <idxl=low index, <idxh=high index
textwa lda #0
; A=low data, <byth=high data
sta <$38
mput pha
sta <$27
mput1 asl <idxl
ldx #$A0
rol <idxh
stx <$09
lda <byth
stx <$0A
jsr mputb
sta <byth
inc <idxl
bne mputb
inc <idxh
pla
mputb pha
memory_address
pla
sta [mapad],y
rts


; Figure out property table address of object A
org $F700
; Store ressults to <coreh and <corel
lda <$27
ptad sta <mapad
bmi textwa1
object_address <mapad,7
lda #$F8
; Get high octet
sta <$39
jsr mgetb
lda #$FE
pha
pha
; Increment object header address
lda $1011
inc <corel
lda $1021
if low(xobject+7)=255
ldy <$36
inc <coreh
lda $5803,y
if smalend
sta <$17
else
sta <$27
endif
if smalend
inc $1011
lda $5803,y
sta <$27
else
ldx $5803,y
stx <$17
endif
endif
; Get low octet
inc $1011
jsr mgetb
bne textwa4
; Store the results
inc $1021
sta <corel
bne textwa4
pla
inc <$36
sta <coreh
textwa4 lsr a
rts
 
; Flag address (<op0l is object, <op1l is flag, A is bit)
flad object_address <op0l,0
lda <op1l
pha
lsr a
lsr a
lsr a
anc #31
lsr a
ora <$09
sta <r0
lda <idxl
clc
adc <r0
sta <idxl
lda <idxh
adc #0
sta <idxh
pla
and #$07
beq flad2
tax
tax
lda #$80
lda zchad,x
flad1 lsr a
dex
bne flad1
flad2 rts
 
; Remove object (<op0l) from its current location
remobj object_address <op0l,4 ; obj.LOC
jsr mgetb
beq flad2 ; rts if object is in nowhere
sta <r0
; Remember and clear obj.NEXT
inc <corel
if low(xobject+4)=255
inc <coreh
endif
jsr mgetb
sta <r1
lda #0
jsr mputb
; Is it the FIRST object?
object_address <r0,6 ; obj.LOC.FIRST
jsr mgetb
cmp <op0l
bne remobj1
; Yes! Set its new FIRST to the old NEXT of the removed object.
lda <r1
jmp mputb
; No! Where is it in the chain?
remobj1 object_address <r1,5 ; r1.NEXT
sta <r1
cmp <op0l
bne remobj1
; Found it
lda <idxl
pha
lda <idxh
pha
pha
object_address <r1,5
jsr mgetb
tax
pla
sta <idxh
pla
sta <idxl
txa
jmp mputb
; Find a property address (<coreh and <corel) and size (A)
; Object is <op0l and property number is <op1l
pfind lda <op0l
jsr ptad
lda #0
sta <idxh
sta <idxl
; Skip the short description string
jsr mgetb
sec
rol a
bcc pfind1
inc <coreh
clc
pfind1 adc <corel
sta <corel
bcc pfind2
inc <coreh
; Skip all properties until the one is found
pfind2 jsr mgetb
beq pfind3
tax
and #$1F
cmp <op1l
beq pfind4
txa
lsr a
lsr a
lsr a
lsr a
lsr a
sec
adc <corel
sta <corel
lda <coreh
adc #0 ; won't pass 64K
sta <coreh
bcc pfind2
; Not found
pfind3 sta <coreh
sta <corel
rts
rts
; Found
textwa1 bit $1020
pfind4 txa
lsr a
lsr a
lsr a
lsr a
lsr a
clc
adc #1
rts
rts


; Do the relative branching using offset in A and <op0h
org $F800
; If the value is 0 or 1, it returns instead of jumps
lda #$FE
rjumppc ldx <op0h
pha
bne jumppc
inc <$39
cmp #2
ldx <$17
bcs jumppc
stx <4
stx <byth
lda <$27
jmp return
asl <4
 
rol a
; Same as above but won't check for returns
asl <4
; (also, the continuation of the above)
jumppc sta <r0
lda <op0h
eor #$80 ; sign conversion
sta <r1
sec
lda <pcl
sbc #$03 ; subtract one extra, since...
sta <pcl
lda <pcm
sbc #$80
sta <pcm
lda <pch
sbc #$00 ; ...carry flag is now set (due to no borrowing)...
sta <pch
lda <pcl
adc <r0 ; ...which causes the one extra to be added back
sta <pcl
lda <pcm
adc <r1
sta <pcm
lda <pch
adc #$00
sta <pch
jmp nxtinst
 
; Deal with branch
; Condition is true if zero flag is set
branch php
jsr pcgetb
sta <r0
pla
lsr a
lsr a
ror a
eor <r0
bmi notjump ; condition flag does not match...
bit <r0
bvs branch1
 
; Long branch
lda <r0
asl a
asl a
asl a
php
php
ror a
plp
ror a
plp
ror a
sta <op0h
jsr pcgetb
jmp rjumppc
 
; Short branch
branch1 lda #0
sta <op0h
lda <r0
and #$3F
jmp rjumppc
 
; Not branching
notjump bit <r0
bvs nxtinst
jsr pcgetb
jmp nxtinst
 
; Return from a subroutine
return dec <dstkcnt
ldy <dstkcnt
ldx $700,y
stx <cstkcnt
ldx $400,y
stx <pcl
ldx $500,y
stx <pcm
ldx $600,y
stx <pch
jsr tostore
; fall through
 
; Next instruction operation
nxtinst jsr pcgetb
sta <r0
bit <r0
bmi nxtins1
 
; 2OP form
sta <r1
lsr <r1
asl a
and #$80
ora <r1
and #$90
ora <r0
eor #$60
ora #$0F
bne nxtins3
 
nxtins1 bvs nxtins2
 
; 1OP or 0OP form
rol a
rol a
asl <4
rol a
rol a
ora #$3F
anc #31
bne nxtins3
ora <$09
 
tax
; EXT form
lda zchad,x
nxtins2 jsr pcgetb
 
; Read operands and call function (using RTS trick)
nxtins3 eor #$FF
sta <argtyp
sta <r1
ldx <r0
romsel opctab
lda opctab,x ; high byte of address
pha
lda opctab+opccnt,x ; low byte of address
pha
pha
ldx #op0l-2
stx <r2
jsr getopr
jsr getopr
jsr getopr
; fall through to read the fourth operand and RTS trick
; Subroutine to read one operand of an instruction
getopr ldx <r2
inx
inx
stx <r2
bit <r1
bvs getopr1 ;bit0=0
bmi getopr2 ;bit1=0
; [11] No operand
getopr0 asl <r1
asl <r1
rts
rts


getopr1 bmi getopr3 ;bit1=0
org $F900
 
lda #$F7
; [10] Variable
sta <$39
jsr pcgetb
lda #$FE
tay
jsr fetch
cpy #0 ; popped from stack
bne getopr4
dec <dstkcnt
jmp getopr4
 
; [01] Short immediate
getopr2 jsr pcgetb
ldx <r2
sta <0,x
lda #0
sta <1,x
beq getopr0
 
; [00] Long immediate
getopr3 jsr pcgetw
getopr4 ldx <r2
sta <0,x
lda <byth
sta <1,x
jmp getopr0
 
 
; ****************************************
 
; Z-code instructions
; Set the zero flag for condition true, clear otherwise
; <byth and A store the value to store to memory
 
; [1] EQUAL? data,cmp1[,cmp2][,cmp3] /PRED
z_equal lda <op0l
cmp <op1l
bne z1equal
lda <op0h
cmp <op1h
bne z1equal
z0equal jmp branch
z1equal lda #$0F
bit <argtyp
beq z9equal
lda <op0l
cmp <op2l
bne z2equal
lda <op0h
cmp <op2h
bne z2equal
jmp branch
z2equal lda #$03
bit <argtyp
beq z9equal
lda <op0l
cmp <op3l
bne z0equal
lda <op0h
cmp <op3h
jmp branch
z9equal asl a
jmp branch
 
; [4] DLESS? var,int /PRED
z_dless lda <op0l
jsr fetch
clc
sbc #0
sta <op0l
pha
pha
bcs z1dless
lda <$17
dec <byth
anc #31
z1dless lda <byth
ora <$09
sta <op0h
tax
lda <op0l
lda zchad,x
jsr dostore
; fall through
 
; [2] LESS? int1,int2 /PRED
z_less lda <op0h
eor #$80 ; do sign conversion
sta <op0h
lda <op1h
eor #$80
cmp <op0h
bne z1less
lda <op0l
cmp <op1l
z1less lda #0
adc #0 ; convert carry flag clear to zero flag set
jmp branch
 
; [5] IGRTR? var,int /PRED
z_dless lda <op0l
jsr fetch
sec
adc #0
sta <op0l
pha
pha
bcc z1dless
rts
inc <byth
z1dless lda <byth
sta <op0h
lda <op0l
jsr dostore
; fall through


; [3] GRTR? int1,int2 /PRED
org $FA00-20
z_grtr lda <op1h
; Text from frequent word
eor #$80 ; do sign conversion
textfw lda #0
sta <op1h
sta <$38
lda <op0h
sta <$29
eor #$80
lda <$0A
cmp <op1h
sta <$0B
bne z1grtr
ldx #$A0
lda <op1l
stx <$09
cmp <op0l
stx <$0A
z1grtr lda #0
lda <$39
adc #0 ; convert carry flag clear to zero flag set
sta <$35
jmp branch


; [6] IN? obj1,obj2 /PRED
org $FA00
z_in object_address <op0l,4
lda <$29
jsr mgetb
bmi textfw1
cmp <op1l
lda #$FB
jmp branch
sta <$39
 
lda #$FE
; [7] BTST data,mask /PRED
z_btst lda <op0h
and <op1h
eor <op1h
beq z1btst
jmp branch
z1btst lda <op0l
and <op1l
eor <op1l
jmp branch
 
; [8] BOR int1,int2 /VAL
z_bor lda <op0h
ora <op1h
sta <byth
lda <op0l
ora <op1l
jsr tostore
jmp nxtinst
 
; [9] BAND int1,int2 /VAL
z_band lda <op0h
and <op1h
sta <byth
lda <op0l
and <op1l
jsr tostore
jmp nxtinst
 
; [10] FSET? obj,flag /PRED
z_ftst jsr flad
sta <r0
jsr mgetb
eor #$FF
and <r0
jmp branch
 
; [11] FSET obj,flag
z_fset jsr flad
sta <r0
jsr mgetb
ora <r0
jsr mputb
jmp nxtinst
 
; [12] FCLEAR obj,flag
z_fclr jsr flad
eor #$FF
sta <r0
jsr mgetb
and <r0
jsr mputb
jmp nxtinst
 
; [13] SET var,value
z_set lda <op1l
pha
pha
lda <op1h
ldy <$37
sta <byth
lda $5803,y
lda <op0l
if smalend
jsr dostore
sta <$19
jmp nxtinst
else
 
sta <$29
; [137] REMOVE obj
endif
z_remov lda #0
inc $1016
sta <op1l
if smalend
beq z_move
lda $5803,y
; keep with next
sta <$29
 
else
; [14] MOVE object,container
ldx $5803,y
; Clear NEXT of object
stx <$19
z1move inc <corel
if low(xobject+4)=255
inc <coreh
endif
endif
jsr mputb ; accumulator is already zero
inc $1016
jmp nxtinst
bne textfw2
; Remove object from its current location
inc $1026
z_move jsr remobj
bne textfw2
; Set LOC of object
inc <$37
object_address <op0l,4
textfw2 lsr a
lda <op1l
lsr a
jsr mputb
anc #31
ora <$09
tax
tax
beq z1move
lda zchad,x
; Remember object address
lda <idxl
sta <r0
lda <idxh
sta <r1
; Get FIRST of container
object_address <op1l,6
jsr mgetb
pha
pha
; Remember container address
rts
lda <idxl
textfw1 bit $1020
lda <$35
sta <$39
lda <$0B
sta <$0A
sta <$09
jmp [$38]
 
org $FB00
lda #$FE
pha
pha
lda <idxh
inc <$39
ldx <$19
stx <4
lda <$29
asl <4
rol a
asl <4
rol a
asl <4
rol a
anc #31
ora <$09
tax
lda zchad,x
pha
pha
; Set NEXT of object
rts
lda <r0
sta <idxl
clc
sbc #0 ; subtract one so it points to NEXT instead of FIRST
lda <r1
sbc #0
sta <idxh
pla
jsr mputb
; Set FIRST of container
pla
sta <idxh
pla
sta <idxl
lda <op0l
jsr mputb
jmp nxtinst
 
; [15] GET table,item /VAL
z_get lda <op0l
sta <corel
lda <op0h
sta <coreh
lda <op1l
sta <idxl
lda <op1h
sta <idxh
jsr mget
jsr tostore
jmp nxtinst
 
; [16] GETB table,item /VAL
z_getb lda #0
sta <byth
lda <op0l
sta <corel
lda <op0h
sta <coreh
lda <op1l
sta <idxl
lda <op1h
sta <idxh
jsr mgetb
jsr tostore
jmp nxtinst
 
; [17] GETP obj,prop /VAL
z_getp jsr pfind
beq z1getp
inc <idxl
lsr a
bcc z2getp
; Byte
jsr mgetb
jsr tostore
jmp nxtinst
; Use default value
z1getp lda #high(object-2)
sta <coreh
lda #low(object-2)
sta <corel
lda <op1l
sta <idxl
; Word
z2getp jsr mget
jsr tostore
jmp nxtinst
 
; [18] GETPT obj,prop /VAL
z_getpt jsr pfind
lda <coreh
sta <byth
lda <corel
jsr tostore
jmp nxtinst
 
; [19] NEXTP obj,prop /VAL
z_nextp lda <op1l
beq z1nextp
jsr pfind
adc #1
sta <idxl
jsr mgetb
jmp z2nextp
; Request first property
z1nextp lda <op0l
jsr ptad
jsr mgetb
sta <idxl
lda #0
sta <idxh
jsr mget
z2nextp and #$1F
ldx #0
stx <byth
jsr tostore
jmp nxtinst


; [20] ADD int1,int2 /VAL
org $FC00
z_add clc
lda #$FA
lda <op0l
sta <$39
adc <op1l
lda #$FE
pha
pha
lda <op0h
lda <$19
adc <op1h
anc #31
sta <byth
ora <$09
pla
tax
jsr tostore
lda zchad,x
jmp nxtinst
 
; [21] SUB int1,int2 /VAL
z_sub sec
lda <op0l
sbc <op1l
pha
pha
lda <op0h
rts
sbc <op1h
sta <byth
pla
jsr tostore
jmp nxtinst


; [22] MUL int1,int2 /VAL
; States can be:
z_mul bankjump multipl
;  0  = Second step of ASCII escape
;  1-3 = Fwords
;  4  = First step of ASCII escape
;  5-7 = Shift states 0,1,2


; [128] ZERO? value /PRED
; These subroutines are entered with X set to the state.
z_zero lda <op0l
; Also has carry flag cleared.
ora <op0h
org $FE01
jmp branch


; [129] NEXT? obj /VAL/PRED
; ** Emit a space
z_next object_address <op0l,5
def_zchars $A0
jsr mgetb
def_zchars $C0
jsr tostore
def_zchars $E0
tax
zch32 jsr space
php
jmp [$38]
pla
and #$02 ; now zero flag is toggled
jmp branch


; [130] FIRST? obj /VAL/PRED
; ** Second escape
z_first object_address <op0l,6
def_zchars $00,$1F
jsr mgetb
txa
jsr tostore
ora <5
tax
beq zch1
php
cmp #32
pla
beq zch32
and #$02 ; now zero flag is toggled
cmp #13
jmp branch
beq zch13
ldx <$30
beq zch1
sta <0,x
inc <$30
lda <$0A
sta <$09
jmp [$38]


; [131] LOC obj /VAL
; ** First escape
z_loc object_address <op0l,4
def_zchars $80,$9F
jsr mgetb
txa
jsr tostore
asl a
jmp nxtinst
asl a
asl a
asl a
asl a
sta <5
anc #0
sta <$09
jmp [$38]


; [132] PTSIZE ptr /VAL
; ** Frequent words
z_ptsiz lda #$FF
def_zchars $20,$7F
sta <idxl
lda fwordsl,x
sta <idxh
sta $1015
lda <op0l
lda fwordsh,x
sta <corel
sta $1025
lda <op0h
lda $5801
sta <coreh
if smalend
jsr mgetb
asl a
lsr a
sta <$16
lsr a
else
lsr a
sta <$26
lsr a
lda #0
lsr a
rol a
sec
sta <$37
endif
inc $1015
bne zfw1
inc $1025
zfw1 lda $5801
if smalend
rol a
sta <$26
else
asl a
sta <$16
rol <$26
endif
lda #0
adc #0
adc #0
jsr tostore
sta <$37
jmp nxtinst
jmp textfw


; [133] INC var
; ** Begin escape
z_inc lda <op0l
def_zchars $E6
jsr fetch
lda #$80
sec
sta <$09
adc #0
jmp [$38]
pha
bcc zincdec
inc <byth
zincdec lda <op0l
jsr dostore
jmp nxtinst
; keep with next


; [134] DEC var
; ** Direct character code
z_dec lda <op0l
def_zchars $A6,$BF
jsr fetch
def_zchars $C6,$DF
clc
def_zchars $E8,$FF
sbc #0
ldy <$30
pha
beq zch1
bcs zincdec
stx <$E0,y
dec <byth ; does not affect the carry flag
inc <$30
bcc zincdec
zch1 lda <$0A
sta <$09
jmp [$38]


; [138] PRINTD obj
; ** Emit a line break
z_prntd lda <op0l
def_zchars $E7
jsr ptad
zch13 jsr bufout
inc <corel ; skip length byte
lda <$31
bne z1prntb
ora #$1F
inc <coreh ; going past 64K is not allowed
sta <$31
bne z1prntb
lda <$0A
; keep with next
sta <$09
jmp [$38]


; [135] PRINTB ptr
; ** Begin frequent words state 0-31
z_prntb lda <op0l
def_zchars $A1
sta <corel
def_zchars $C1
lda <op0h
def_zchars $E1
sta <coreh
lda #$20
z1prntb lda <pcl
sta <$09
pha
jmp [$38]
lda <pcm
pha
lda <pch
pha
lda #0
sta <pch
lda <corel
sta <pcl
lda <coreh
sta <pcm
jsr putstr
pla
sta <pch
pla
sta <pcm
pla
sta <pcl
jmp nxtinst


; [139] RETURN value
; ** Begin frequent words state 32-63
z_ret lda <op0h
def_zchars $A2
sta <byth
def_zchars $C2
lda <op0l
def_zchars $E2
jmp return
lda #$40
sta <$09
jmp [$38]


; [140] JUMP offset
; ** Begin frequent words state 64-95
z_jump lda <op0l
def_zchars $A3
jmp jumppc
def_zchars $C3
def_zchars $E3
lda #$60
sta <$09
jmp [$38]


; [141] PRINT str
; ** Temporary shift 1
z_print lda <pcl
def_zchars $A4
pha
lda #$C0
lda <pcm
sta <$09
pha
jmp [$38]
lda <pch
pha
lda #0
sta <pch
lda <corel
sta <pcl
lda <coreh
sta <pcm
asl <pcl
rol <pcm
rol <pch
jsr putstr
pla
sta <pch
pla
sta <pcm
pla
sta <pcl
jmp nxtinst


; [143] BCOM int /VAL
; ** Temporary shift 2
z_bcom lda <op0h
def_zchars $A5
eor #$FF
lda #$E0
sta <byth
sta <$09
lda <op0l
jmp [$38]
eor #$FF
jsr tostore
jmp nxtinst


; [142] VALUE var /VAL
; ** Permanent shift 1 or 2
z_value lda <op0l
def_zchars $C4
jsr fetch
def_zchars $E5
z1value jsr tostore
and #$F0
jmp nxtinst
sta <$0A
; keep with next
jmp [$38]


; [224] CALL fcn[,arg1][,arg2][,arg3] /VAL
; ** Permanent shift 0
z_call lda #0
def_zchars $C5
cmp <op0l
def_zchars $E4
bne z1call
lda #$A0
sta <byth
sta <$09
cmp <op0h
sta <$0A
beq z1value
jmp [$38]
z1call ldx <cstkcnt
lda <pcl
sta $400,x
lda <pcm
sta $500,x
lda <pch
sta $600,x
lda <dstkcnt
sta <r2 ; remember bottom of local stack frame
sta $700,x
inc <cstkcnt
lsr <pch
lda <op0l
sta <pcl
lda <op0h
sta <pcm
asl <pcl
rol <pcm
rol <pch
; Read values of local variables
jsr pcgetb
sta <r3
z2call lda <r3
beq z3call
dec <r3
jsr pcgetw
ldy <dstkcnt
sta $200,y
lda <byth
sta $300,y
inc <dstkcnt
bne z2call
; Rewrite values of local variables by arguments
z3call lda #$3F
bit <argtyp
beq z9call
ldx <r2
lda <op1l
sta $200,x
lda <op1h
sta $300,x
lda #$0F
bit <argtyp
beq z9call
lda <op2l
sta $201,x
lda <op2h
sta $301,x
lda #$03
bit <argtyp
beq z9call
lda <op3l
sta $202,x
lda <op3h
sta $302,x
z9call jmp nxtinst


; [179] PRINTR (str)
; Reset vector
z_prntr jsr putstr
bank intbank+3
lda #13
org $FFFA
bankcall putchar
dw 0,reset,0
; fall through


; [176] RTRUE
; Pattern tables
z_rtrue lda #0
bank intbank+4
sta <byth
org $0000
lda #1
incbin "pc.chr"
jmp return


z_rfals ; [177] RFALSE
; Cursor icon
lda #0
org $07F0
sta <byth
defchr $00000000, \
jmp return
      $03030300, \
      $00303030, \
      $03030300, \
      $00303030, \
      $03030300, \
      $00303030, \
      $00000000


; [178] PRINTI (str)
; Postprocessor
z_prnti jsr putstr
emu
jmp nxtinst


; [180] NOOP
org $0000
z_noop = nxtinst
lda 0
sta $2012
inc <1
rts


; [181] SAVE /PRED
org $0040
z_save lda #1 ; clear the zero flag (SAVE/RESTORE aren't implemented)
db "0123456789012345"
jmp branch
db "6789012345678901"


; [182] RESTORE /PRED
org $0080
z_rstor = z_save
db "                                "  ; $80-$9F
db "      abcdefghijklmnopqrstuvwxyz"  ; $A0-$BF
db "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"  ; $C0-$DF
db "      **0123456789.,!?_#'\"/\\-:()" ; $E0-$FF


; [183] RESTART
org $8000
z_rest = reset
cld


; [184] RSTACK
; Make duplicates of ASCII characters as Z-characters
z_rstac lda #0
lda #1
jsr fetch
sta $200D
dec <dstkcnt
lda #0
jmp return
sta $200E
lda #8
sta $200F
ldx #$80
pp1 lda #4
sta <2
lda <0,x
asl a
rol <2
asl a
rol <2
asl a
rol <2
asl a
rol <2
sta <1
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
inx
bne pp1


; [189] VERIFY /PRED
; Make duplicate of digits for use with PRINTN
z_vrfy lda #0 ; just fake it for now
ldx #0
jmp branch
stx $200E
stx $200F
pp2 lda #4
sta <2
lda <$40,x
asl a
rol <2
asl a
rol <2
asl a
rol <2
asl a
rol <2
sta <1
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
jsr 0
inx
cpx #32
bne pp2


; [233] POP var
; Finished
z_pop ldx <dstkcnt
hlt
jsr fetch2
pha
lda <op0l
jsr dostore
; fall through


; [185] FSTACK
org $FFFC
z_fstac dec <dstkcnt
dw $8000
jmp nxtinst


; [186] QUIT
code
z_quit jmp z_quit ; just wait forever for the player to push RESET
bank intbank+4
</pre>


; [225] PUT table,item,data
== C program ==
z_put lda <op0l
This program is generating a stub file and story ROM for its use.
sta <corel
<pre>
lda <op0h
/*
sta <coreh
  This file is part of Famizork II and is in the public domain.
lda <op1l
*/
sta <idxl
lda <op1h
sta <idxh
lda <op2h
sta <byth
lda <op2l
jsr mput
jmp nxtinst
 
; [226] PUTB table,item,data
z_putb lda <op0l
sta <corel
lda <op0h
sta <coreh
lda <op1l
sta <idxl
lda <op1h
sta <idxh
lda <op2l
jsr mputb
jmp nxtinst


; [227] PUTP obj,prop,value
#include <stdio.h>
z_putp jsr pfind
#include <stdlib.h>
inc <idxl
#include <string.h>
lsr a
lda <op2h
sta <byth
lda <op2l
bcc z1putp
; Byte
jsr mputb
jmp nxtinst
; Word
z1getp jsr mput
jmp nxtinst


; [187] CRLF
static FILE*fp;
z_crlf lda #13
static int c;
bne z1prntc
static int d;
; keep with next
static int gamesize;
static char endian;
static unsigned char mem[0x20000];
static char buf[256];


; [229] PRINTC char
#define OUTHEADER(x,y) fprintf(fp,"%s\t= %u\n",x,(mem[y*2+endian]<<8)|mem[y*2+1-endian])
z_prntc lda <op0l
z1prntc bankcall putchar
jmp nxtinst


; [230] PRINTN int
int main(int argc,char**argv) {
z_prntn bankjump printn
  if(argc<2) return 1;
 
  fp=fopen(argv[1],"rb");
; [232] PUSH value
  fseek(fp,0,SEEK_END);
z_push inc <dstkcnt
  gamesize=ftell(fp);
lda <op0l
  if(gamesize>0x20000 || gamesize<0) return 1;
pha
  fseek(fp,0,SEEK_SET);
lda <op0h
  fread(mem,1,gamesize,fp);
sta <byth
  fclose(fp);
lda #0
  if(*mem!=3) return 1;
jsr dostore
  sprintf(buf,"%s.asm",argv[1]);
jmp nxtinst
  fp=fopen(buf,"w");
  endian=mem[1]&1;
  mem[1]&=3;
  mem[1]|=16;
  c=(gamesize>0x10000?16:gamesize>0x8000?8:gamesize>0x4000?4:2);
  fprintf(fp,"\tnes2prgram 0,131072\n");
  fprintf(fp,"\tinesprg %d\n",(c>>1)+2);
  fprintf(fp,"intbank\t= %d\n",c);
  fprintf(fp,"smalend\t= %d\n",endian);
  fprintf(fp,"large\t= %d\n",gamesize>=0x10000);
  if(gamesize<0x10000) fprintf(fp,"maxaddr\t= %u\n",gamesize-1);
  OUTHEADER("start",3);
  OUTHEADER("vocab",4);
  OUTHEADER("object",5);
  OUTHEADER("global",6);
  OUTHEADER("purbot",7);
  OUTHEADER("fwords",12);
  fprintf(fp,"\tcode\n\tbank 0\n\tincbin \"%s.rom\"\n\tinclude \"famizork2.asm\"\n",argv[1]);
  fprintf(fp,"\n\tbank %d\n\torg fwordsl\n",c);
  d=(mem[24+endian]<<8)|mem[25-endian];
  for(c=0;c<192;c+=2) fprintf(fp,"\tdb %d\n",(d+c)&255);
  for(c=0;c<192;c+=2) fprintf(fp,"\tdb %d\n",((d+c)>>8)&255);
  fprintf(fp,"\torg multabl\n");
  for(c=0;c<255;c++) fprintf(fp,"\tdb %d\n",((c*c)>>2)&255);
  for(c=0;c<512;c++) fprintf(fp,"\tdb %d\n",((c*c)>>10)&255);
  fprintf(fp,"\tbank intbank+4\n");
  fclose(fp);
  sprintf(buf,"%s.rom",argv[1]);
  fp=fopen(buf,"wb");
  if(gamesize>0x10000) {
    fwrite(mem+0x10000,1,0x10000,fp);
    fwrite(mem,1,0x10000,fp);
  } else {
    fwrite(mem,1,gamesize,fp);
  }
  fclose(fp);
  return 0;
}
</pre>


; [234] SPLIT lines
== Explanation ==
z_split = nxtinst


; [235] SCREEN window
The explanation of the mapper is [[User:Zzo38/Mapper_I]].
z_scrn = nxtinst


; ****************************************
The pattern table is arranged in this way (although $7F is the cursor picture, not shown here):


0123456789012345
6789012345678901
  !"#$%&'()*+,-./
0123456789:;<=>?
@ABCDEFGHIJKLMNO
PQRSTUVWXYZ[\]^_
`abcdefghijklmno
pqrstuvwxyz{|}~
               
               
      abcdefghij
klmnopqrstuvwxyz
      ABCDEFGHIJ
KLMNOPQRSTUVWXYZ
      **01234567
89.,!?_#'"/\-:()


bank 31
As you can see there are many duplicates, in particular each digit occurs five times, except 0 and 1 which occur six times each. Many other characters also occur twice. These will improve the speed of the program, since it does not have to convert Z-characters and numbers into ASCII before displaying them.
org $FE00


; Initialize CPU/APU/PPU at reset
Many things are precomputed at compile-time in order to improve speed (also improves size of the interpreter):
reset ldx #$40
* The mode byte is set to indicate that the status bar is unavailable
stx $4017 ; Disable APU frame IRQ
* Address of objects, global variables, and frequent words table
ldx #$FF
* Starting address of execution of program
txs
* Endianness and various calculations related to it
inx
* The size of the story file, which can be used to determine needed ROM sizes and optimizing of the interpreter
stx $2000
* Self-inserting-breaks
stx $2001
* Stuff to optimize the vocabulary (not yet)
stx $4010
* Multiplication tables


; Initialize MMC5 to act like User:Zzo38/Mapper_D
A custom mapper is used, which bankswitches only one byte at a time. This makes much of the logic for addressing the story file much simpler than it otherwise would be. It also overlaps bankswitching registers with mirrors of the RAM internal to the console, and since they respond to multiple addresses, this means you can save the bankswitched value at the same time as bankswitching, that you can store multiple bank numbers at once (even though the mapper can only remember one at once), and that reading from the RAM mirrors will also bankswitch (allows you to restore a saved bankswitch in four cycles; with other mappers it is usually seven).
stx $5101
stx $5200
stx $5204
inx
stx $5100
stx $5102
inx
stx $5103
lda #$44 ; horizontal arrangement
sta $5105


; Copy ROM to RAM
There is an instruction decoding table, which is one table for all instructions and contains duplicates for the different forms of the instruction (such as EXT forms of 2OP instructions, the different variable/immediate combinations for 2OP, and the different operand types for 1OP). However, a different opcode is used when EQUAL? is encoded as EXT than as 2OP, in order to improve the speed in the 2OP case. The code can just use "jmp nxtinst" to begin decoding the next instruction; it doesn't use return from subroutine.
ldx #0
stx rambank
ldy #0
sty <r1
sty <r3
lda #$5F
sta <r0
lda #$80
sta <r4
jsr rrcp16
jsr rrcp16
jsr rrcp16
jsr rrcp16


; Call other init code
Instruction decoding tables, as well as the Z-character decoding tables, both use the RTS trick, although in the case of Z-character decoding, the table contains only the low byte of the address since the code is small enough in this case.
bankjump reset1


; Copy 16K of ROM to RAM
Also it is using several stable unofficial opcodes.
rrcp16 lda #$7F
sta <r2
jsr rrcopy
; fall through
 
; Copy 8K of ROM to RAM
rrcopy lda <r4
and #$80
sta rombank
inc <r4
rrcopy1 inc <r0
inc <r2
rrcopy2 lda [r2],y
sta [r0],y
iny
bne rrcopy2
lda <r0
and #$1F
ora #$60
sta <r0
lda <r2
and #$1F
eor #$1F
bne rrcopy1
lda <r2
inx
stx rambank
rts
 
; NMI routine
nmi pha
dec <blinker
bne nmi1
bit $2002
lda #$3F
sta $2006
lda #$23
sta <blinker
sta $2006
lda <curspal
eor #$0F
sta <curspal
sta $2007
lda #0
sta $2005
lda <scrolly
sta $2005
pla
rti
nmi1 bit <outrdy
bvc nmi2
jmp sendout ; the correct bank is already selected
nmi2 bit <linrdy
bvc nmi3
jmp sendlf
nmi3 pla
rti
 
; CHR ROM
bank 32
incbin "chicago_oblique.chr"
incbin "chicago_inverse.chr"
</pre>

Latest revision as of 09:31, 20 April 2016

This file contains a copy of the working in progress for the Famicom Z-machine interpreter program.

You are free to review it, question/comment, and even to modify it if you have improvements to make. It is placed here mainly in order to improve reviewing of the software, but you can use it for other purposes too.

The assembler in use is Unofficial MagicKit (a modified version of NESASM).

This program is being written by User:Zzo38, and is using the Famicom keyboard. It is not yet complete (and likely contains errors).

Main file

; Famizork II
; Public domain

debug	= 1  ; change this to 1 to enable breakpoints 0 to disable
	     ; set a breakpoint on opcode $1A in the debugger

	inesmap 380 ; Famizork II mapper
	ineschr 1 ; 8K CHR ROM
	inesmir 3 ; horizontal arrangement with battery

; Zero-page variables:
;   $02 = data stack pointer
;   $03 = call stack pointer
;   $04 = temporary
;   $05 = temporary
;   $06 = temporary
;   $07 = temporary
;   $09 = current temporary shift state
;   $0A = current permanent shift state
;   $0B = saved permanent shift state
;   $0D = number of locals
;   $0E = bit16 of program counter
;   $10 = bit7-bit0 of program counter
;   $11 = low byte of first operand
;   $12 = low byte of second operand
;   $13 = low byte of third operand
;   $14 = low byte of fourth operand
;   $15 = temporary
;   $16 = low byte of text address if inside fword
;   $17 = low byte of packed word
;   $18 = temporary
;   $19 = low byte of packed word if inside fword
;   $20 = bit15-bit8 of program counter
;   $21 = high byte of first operand
;   $22 = high byte of second operand
;   $23 = high byte of third operand
;   $24 = high byte of fourth operand
;   $25 = temporary
;   $26 = high byte of text address if inside fword
;   $27 = high byte of packed word
;   $28 = temporary
;   $29 = high byte of packed word if inside fword
;   $30 = output buffer pointer
;   $31 = low byte of nametable address of cursor
;   $32 = high byte of nametable address of cursor
;   $33 = Y scroll amount
;   $34 = lines to output before <MORE>
;   $35 = saved high byte of return address for text unpacking
;   $36 = bit16 of current text address
;   $37 = bit16 of current text address if inside fword
;   $38-$39 = return address for text unpacking
;   $3A = current background color
;   $3B = current foreground color
;   $3C = remember if battery RAM is present (255=yes 0=no)
;   $3D = ARCFOUR "i" register 
;   $3E = ARCFOUR "j" register
;   $40-$4F = low byte of locals
;   $50-$5F = high byte of locals
;   $E2-$FF = output buffer

	code

datasp	= $02
callsp	= $03
locall	= $40
localh	= $50

dstackl	= $200
dstackh	= $300

cstackl	= $400
cstackm	= $480
cstackh	= $500 ; bit4-bit1=number of locals, bit0=bit16 of PC
cstackx	= $580 ; data stack pointer

arcfour	= $600 ; use for random number generator

	bank intbank+0,"Interpreter"
	bank intbank+1,"Interpreter"
	bank intbank+2,"Interpreter"
	bank intbank+3,"Interpreter"

	bank intbank
	org $8000

	macro breakpoint
	if debug
	db $1A ; unofficial NOP
	endif
	endm

	macro breakpoint2
	if debug
	db $3A ; unofficial NOP
	endif
	endm

	macro make_digit_table
	macset 4,4,0
	macgoto make_digit_table_0
	endm

	macro make_digit_table_0
	db ((\4*\2)/\1)%10
	macset 4,4,\4+1
	macset 5,4,\4=\3
	macgoto make_digit_table_\5
	endm

	macro make_digit_table_1
	; Empty macro
	endm

globodd	= global&1

	macro make_global_table
	macset 2,4,16
	macgoto make_global_table_0
	endm

	macro make_global_table_0
	db \1(global+\2+\2-32)
	macset 2,4,\2+1
	macset 3,4,\2=256
	macgoto make_global_table_\3
	endm

	macro make_global_table_1
	; Empty macro
	endm

	macro make_object_table
	macset 2,4,0
	macgoto make_object_table_0
	endm

	macro make_object_table_0
	db \1(object+(\2*9)+62-9)
	macset 2,4,\2+1
	macset 3,4,\2=256
	macgoto make_object_table_\3
	endm

	macro make_object_table_1
	; Empty macro
	endm

instadl	ds 256
instadh	ds 256

globadl	ds 16
	make_global_table low
globadh	ds 16
	make_global_table high

objadl	make_object_table low
objadh	make_object_table high

multabl	ds 256 ; x*x/4
multabh	ds 512 ; x*x/1024

digit0l	make_digit_table 1,1,256
digit1l	make_digit_table 10,1,256
digit2l	make_digit_table 100,1,256
digit0h	make_digit_table 1,256,128
digit1h	make_digit_table 10,256,128
digit2h	make_digit_table 100,256,128
digit3h	make_digit_table 1000,256,128

bit1tab	db   0,  1,  3,  3,  7,  7,  7,  7, 15, 15, 15, 15, 15, 15, 15, 15
	db  31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31
	db  63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63
	db  63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63
	db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
	db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
	db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
	db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
	db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255

zchad	ds 256

ptsizt	db 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
	db 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2
	db 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3
	db 4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4
	db 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5
	db 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6
	db 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7
	db 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8

flagad	if smalend
	db 1,1,1,1,1,1,1,1
	db 0,0,0,0,0,0,0,0
	db 3,3,3,3,3,3,3,3
	db 2,2,2,2,2,2,2,2
	else
	db 0,0,0,0,0,0,0,0
	db 1,1,1,1,1,1,1,1
	db 2,2,2,2,2,2,2,2
	db 3,3,3,3,3,3,3,3
	endif

fwordsl	= *-32
	ds 96
fwordsh	= *-32
	ds 96

flagbit	db 128,64,32,16,8,4,2,1
	db 128,64,32,16,8,4,2,1
	db 128,64,32,16,8,4,2,1
	db 128,64,32,16,8,4,2,1

flagbic	db 127,191,223,239,247,251,253,254
	db 127,191,223,239,247,251,253,254
	db 127,191,223,239,247,251,253,254
	db 127,191,223,239,247,251,253,254

digit4h	make_digit_table 10000,256,128

	; Z-character-decoding assigning macro
	macro def_zchars
	if \#=1
	macset 2,4,\1
	else
	macset 2,4,\2
	endif
	macset 1,4,\1
	macset 3,4,*
	macset 4,4,?B
	bank bank(zchad)
	macgoto def_zchars_0
	endm

	macro def_zchars_0
	macset 5,4,\1=\2
	org zchad+\1
	db low(\3-1)
	if \3<$FE01
	fail "Z-character routine out of range"
	endif
	if \3>$FF00
	fail "Z-character routine out of range"
	endif
	macset 1,4,\1+1
	macgoto def_zchars_\5
	endm

	macro def_zchars_1
	bank \4
	org \3
	endm

	; Instruction assigning macro
	macro def_inst
	macset 2,4,*
	macset 3,4,?B
	bank bank(instadl)
	org instadl+(\1)
	db low(\2-1)
	org instadh+(\1)
	db high(\2-1)
	bank \3
	org \2
	endm

	macro def_inst_2op
	def_inst (\1)+$00
	def_inst (\1)+$20
	def_inst (\1)+$40
	def_inst (\1)+$60
	def_inst (\1)+$C0
	endm

	macro def_inst_2op_eq
	def_inst (\1)+$00
	def_inst (\1)+$20
	def_inst (\1)+$40
	def_inst (\1)+$60
	endm

	macro def_inst_1op
	def_inst (\1)+$00
	def_inst (\1)+$10
	def_inst (\1)+$20
	endm

	macro def_inst_0op
	def_inst (\1)+$00
	endm

	macro def_inst_ext
	def_inst (\1)+$00
	endm

	; Fetch next byte of program
	; Doesn't affect carry flag and overflow flag
	macro fetch_pc
	inc $1010
	bne n\@
	inc $1020
	if large
	bne n\@
	inc <$0E
n\@	ld\1 <$0E
	\2 $5803,\1
	else
n\@	\2 $5803
	endif
	endm
	; (Bytes of above: 17)
	; (Cycles of above: 16 or 25 or 27)

	; Initialization code
reset	ldx #0
	stx $2000
	stx $2001
	; Wait for frame
	bit $2002
vwait1	bit $2002
	bpl vwait1
	txa
	stx <$0E ; bit16 of program counter
	stx <$0D ; number of locals
	stx <$33 ; Y scroll amount
	stx <$3C ; battery flag
	dex
	stx <$03 ; call stack pointer
	ldy #27
	sty <$34 ; lines before <MORE>
	ldy #$0F
	sty <$3A ; background
	ldy #$20
	sty <$3B ; foreground
	ldy #low(start-1)
	sty <$10
	ldy #$E2
	sty <$30 ; output buffer pointer
	ldy #$61
	sty <$31 ; low byte of cursor nametable address
	ldy #$27
	sty <$32 ; high byte of cursor nametable address
	; Wait for frame
	bit $2002
vwait2	bit $2002
	bpl vwait2
	; Clear the screen
	tax
	lda #32
	sta $2006
	ldx #9
	stx $2006
reset1	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	inx
	bne reset1
	; Initialize palette
	lda #$FF
	sta $2006
	stx $2006
	lda <$3A
	sta $2007
	sta $2007
	ldy <$3B
	sty $2007
	sty $2007
	sta $2007
	sta $2007
	sty $2007
	sty $2007
	sta $2007
	sta $2007
	sty $2007
	sty $2007
	sta $2007
	sta $2007
	sty $2007
	sty $2007
	; Check if F8 is pushed (erases save data)
	ldx #5
	stx $4016
	dex
	stx $4016
	lda $4017
	and #2
	beq reset2
	; Check battery
	ldx #0
	stx $1011
	stx $1021
	lda $5800
	cmp #69
	bne reset2
	inc $1011
	lda $5800
	cmp #105
	beq reset3
	; No save file exists; try to create one
reset2	stx $1011
	lda #69
	sta $5800
	inc $1011
	lda #105
	sta $5800
	inc $1011
	stx $5800
	lda #$FF
	sta $1022
	; Initialize ARCFOUR table
reset2a	txa
	sta arcfour,x
	sta $1012
	sta $5800
	inx
	bne reset2a
	; Copy header from ROM into RAM
	stx $1021
reset2b	stx $1011
	lda $5805
	sta $5803
	inx
	bne reset2b
	; Copy ROM starting from PURBOT into RAM
	lda #high(purbot)
	sta $1021
	lda #low(purbot)
	sta $1011
reset2c	lda $5805
	sta $5803
	inc $1011
	bne reset2c
	inc $1021
	if large=0
	if maxaddr<$FF00
	lda <$21
	cmp #high(maxaddr)+1
	endif
	endif
	bne reset2c
	; Check if save file still exists
	stx $1011
	stx $1021
	lda $5800
	cmp #69
	bne zrest
	inc $1011
	lda $5800
	cmp #105
	beq reset3
	jmp zrest
	; Battery is OK
reset3	lda #255
	sta <$3C
	; Load and permute saved ARCFOUR table
	sta $1021
	ldy #0
reset3a	sty $1011
	lax $5800
	sta arcfour,y
	inx
	stx $5800
	iny
	bne reset3a
	; fall through

	; *** RESTART
	def_inst_0op 183
zrest	ldx #0
	stx <$0E ; bit16 of program counter
	stx <$0D ; number of locals
	stx $1021
	dex
	stx <$03 ; call stack pointer
	; Load data from 64 to PURBOT from ROM into RAM
	lda #64
	sta $1011
zrest1	lda $5805
	sta $5803
	inc $1011
	bne zrest1
	inc $1021
	if purbot<$FF00
	lda <$21
	cmp #high(purbot)+1
	endif
	bne zrest1
	; Initialize program counter
	lda #low(start-1)
	sta <$10
	lda #high(start-1)
	sta $1020
	jmp zcrlf

	; *** USL
	def_inst_0op 188
	; fall through

	; *** SPLIT
	def_inst_ext 234
	; fall through

	; *** SCREEN
	def_inst_ext 235
	; fall through

	; *** NOOP
	def_inst_0op 180
	; fall through

	; Decode the next instruction
	; For EXT instructions, number of operands is in the X register
nxtinst	fetch_pc y,ldx
	lda instadh,x
	pha
	lda instadl,x
	pha
	txa
	bmi not2op

	; It is 2OP
	ldx #0
	asl a
	sta <4
	arr #$C0
	fetch_pc y,lda
	bcc is2op1
	jsr varop0
	fetch_pc y,lda
	bvc is2op2
	jmp is2op3
is2op1	stx <$21
	sta <$11
	bit <4
	fetch_pc y,lda
	bvc is2op3
is2op2	inx
	jmp varop0
is2op3	stx <$22
	sta <$12
	rts

	; It isn't 2OP
not2op	cmp #192
	bcc notext

	; It is EXT
	fetch_pc y,lda
	ldx #0
isext0	sec
	rol a
	bcs isext1
	bmi isext3

	; Long immediate
	sta <4
	fetch_pc y,lda
	if smalend
	sta <$11,x
	else
	sta <$21,x
	endif
	fetch_pc y,lda
	if smalend
	sta <$21,x
	else
	sta <$11,x
	endif
	inx
	lda <4
	sec
	rol a
	jmp isext0

	; Variable or no more operands
isext1	bpl isext2

	; No more operands
	rts

	; Variable
isext2	sta <4
	jsr varop
	inx
	lda <4
	sec
	rol a
	jmp isext0

	; Short immediate
isext3	sta <4
	lda #0
	sta <$21,x
	fetch_pc y,lda
	sta <$11,x
	inx
	lda <4
	sec
	rol a
	jmp isext0

	; It isn't EXT; it is 1OP or 0OP
notext	asl a
	asl a
	asl a
	bcs notext1
	bpl notext2

	; 1OP - short immediate
	fetch_pc y,lda
	ldx #0
	stx <$21
	sta <$11
	rts

notext1	bmi notext3

	; 1OP - variable
	ldx #0
	jmp varop

	; 1OP - long immediate
notext2	fetch_pc y,lda
	if smalend
	sta <$11,x
	else
	sta <$21,x
	endif
	fetch_pc y,lda
	if smalend
	sta <$21,x
	else
	sta <$11,x
	endif
	; fall through

	; 0OP
notext3	rts

zcall0	jmp val8

	; *** CALL
	def_inst_ext 224
	stx <4
	lax <$11
	ora <$21
	beq zcall0 ; calling function zero
	; Save to call stack
	inc <callsp
	ldy <callsp
	lda <$10
	stx <$10
	sta cstackl,y
	lda <$20
	sta cstackm,y
	lsr <$0E
	lax <$0D
	rol a
	sta cstackh,y
	lda <datasp
	sta cstackx,y
	; Save locals
	txa
	beq zcall2
	clc
	adc <datasp
	tay
zcall1	lda <locall,x
	sta dstackl,y
	lda <localh,x
	sta dstackh,y
	dey
	dex
	bne zcall1
	lda <$0D
	adc <datasp
	sta <datasp
	; Read function header (number of locals)
zcall2	asl $1010
	lda <$21
	rol a
	sta $1020
	rol <$0E
	ldy <$0E
	lda $5803,y
	sta <$0D
	; Load initial values of locals
	beq zcall4
	; Load arguments
	ldx <4
	dex
	beq zcall3
	lda <$12
	sta <$41
	lda <$22
	sta <$51
	cpx #1
	beq zcall2a
	lda <$13
	sta <$42
	lda <$23
	sta <$52
	cpx #2
	beq zcall2a
	lda <$14
	sta <$43
	lda <$24
	sta <$53
zcall2a	txa
	asl a ; now clears carry flag
	adc <$10
	sta <$10
	lda #0
	adc <$20
	sta $1020
	if large
	bcc zcall3
	inc <$0E
	endif
	; Load default values
zcall3	fetch_pc y,lda
	if smalend
	sta <locall+1,x
	else
	sta <localh+1,x
	endif
	fetch_pc y,lda
	if smalend
	sta <localh+1,x
	else
	sta <locall+1,x
	endif
	inx
	cpx <$0D
	bne zcall3
zcall4	jmp nxtinst

	; *** RFALSE
	def_inst_0op 177
	lda #0
	; fall through

	; Return a 8-bit value (from A)
ret8	pha
	ldy <callsp
	dec <callsp
	lda cstackx,y
	sta <datasp
	lda cstackl,y
	sta <$10
	lda cstackm,y
	sta $1020
	lda cstackh,y
	lsr a
	sta <$0D
	tax
	rol a
	anc #1
	sta <$0E
	; Restore locals
	txa
	beq ret8b
	adc <datasp
	tay
ret8a	lda dstackl,y
	sta <locall,x
	lda dstackh,y
	sta <localh,x
	dey
	dex
	bne ret8a
ret8b	pla
	; fall through

	; Value of instruction is 8-bits (from A)
val8	fetch_pc y,ldx
	bne val8a
	; Push to stack
	inc <datasp
	ldy <datasp
	sta dstackl,y
	txa
	sta dstackh,y
	jmp nxtinst
val8a	cpx #16
	bcs val8b
	; Local variable
	sta <locall,x
	lda #0
	sta <localh,x
	jmp nxtinst
	; Global variable
val8b	ldy globadl,x
	sty $1014
	ldy globadh,x
	sty $1024
	if smalend
	sta $5801
	else
	ldy #0
	sty $5801
	endif
	inc $1014
	if globodd
	bne val8c
	inc $1024
	endif
val8c	if smalend
	lda #0
	endif
	sta $5801
	lda $1020
	jmp nxtinst

	; Read the variable using as an instruction operand
	; X is operand number (0-3)
varop	fetch_pc y,lda
varop0	bne varop1
	; Pop from stack
	ldy <datasp
	dec <datasp
	lda dstackl,y
	sta <$11,x
	lda dstackh,y
	sta <$21,x
	rts
varop1	cmp #16
	bcs varop2
	; Local variable
	tay
	lda locall,y
	sta <$11,x
	lda localh,y
	sta <$21,x
	rts
	; Global variable
varop2	tay
	lda globadl,y
	sta $1015
	lda globadh,y
	sta $1025
	lda $5801
	if smalend
	sta <$11,x
	else
	sta <$21,x
	endif
	inc $1015
	if globodd
	bne varop3
	inc $1025
	endif
varop3	lda $5801
	if smalend
	sta <$21,x
	else
	sta <$11,x
	endif
	lda $1020
	rts

	; *** RSTACK
	def_inst_0op 184
	ldx <datasp
	lda dstackl,x
	sta <$14
	lda dstackh,x
	jmp ret16

	; *** RETURN
	def_inst_1op 139
	lda <$11
	sta <$14
	lda <$21
ret16	sta <$24
	ldy <callsp
	dec <callsp
	lda cstackx,y
	sta <datasp
	lda cstackl,y
	sta <$10
	lda cstackm,y
	sta $1020
	lda cstackh,y
	lsr a
	sta <$0D
	tax
	rol a
	anc #1
	sta <$0E
	; Restore locals
	txa
	beq ret16b
	adc <datasp
	tay
ret16a	lda dstackl,y
	sta <locall,x
	lda dstackh,y
	sta <localh,x
	dey
	dex
	bne ret16a
ret16b	; fall through

	; Value of instruction is 16-bits (from $x4)
val16	lda <$14
	fetch_pc y,ldx
	bne val16a
	; Push to stack
	inc <datasp
	ldy <datasp
	sta dstackl,y
	lda <$24
	sta dstackh,y
	jmp nxtinst
val16a	cpx #16
	bcs val16b
	; Local variable
	sta <locall,x
	lda <$24
	sta <localh,x
	jmp nxtinst
	; Global variable
val16b	ldy globadl,x
	sty $1015
	ldy globadh,x
	sty $1025
	if smalend
	sta $5801
	else
	ldy <$24
	sty $5801
	endif
	inc $1015
	if globodd
	bne val16c
	inc $1025
	endif
val16c	if smalend
	lda <$24
	endif
	sta $5801
	lda $1020
	jmp nxtinst

	; *** RTRUE
	def_inst_0op 176
	lda #1
	jmp ret8

	; *** EQUAL? (EXT)
	def_inst_ext 193
	lda <$11
	ldy <$21
	cmp <$12
	bne zequal1
	cpy <$22
	beq tpredic
zequal1	cpx #2
	beq fpredic
	cmp <$13
	bne zequal2
	cpy <$23
	beq tpredic
zequal2	cpx #3
	beq fpredic
	cmp <$14
	bne fpredic
	cmp <$24
	beq tpredic
	jmp fpredic

	; *** GRTR?
	def_inst_2op 3
	lda <$12
	cmp <$11
	lda <$22
	sbc <$21
	bvc zgrtr1
	and #128
	jmp predic1
zgrtr1	bmi tpredic
	jmp fpredic

	; *** LESS?
	def_inst_2op 2
	lda <$11
	cmp <$12
	lda <$21
	sbc <$22
	bvc zgrtr1
	and #128
	jmp predic1

	; *** EQUAL? (2OP)
	def_inst_2op_eq 1
	lda <$11
	eor <$21
	bne fpredic
	lda <$12
	eor <$22
	beq predic1
	jmp fpredic

	; *** ZERO?
	def_inst_1op 128
	lda <$11
	ora <$21
	beq tpredic
	; falls through

	; Predicate handling
fpredic	lda #128
	jmp predic1
tpredic	lda #0
predic1	fetch_pc x,eor
	tax
	arr #$C0
	bcs predic8

	; If it should branch
	txa
	bvs predic3

	; Long offset
	eor #$20
	anc #$3F
	adc #$E0
	if large
	bpl predic2
	dec <$0E
	endif
predic2	clc
	adc <$20
	sta $1020
	if large
	bcc predick
	inc <$0E
	endif
predick	fetch_pc y,lax
	jmp predic4

	; Short offset
predic3	and #$3F
	cmp #2
	bcc predicq
predic4	sbc #2
	bcs predic5
	if large
	ldy <$20
	dey
	sty $1020
	cpy #255
	bne predic5
	lsr <$0E
	else
	dec $1020
	endif
predic5	sec
	adc <$10
	sta <$10
	bcc predic9
	inc $1020
	if large
	bne predic9
	inc <$0E
	endif
	jmp nxtinst

	; If should not branch
predic8	bvc predic9
	inc <$10
	bne predic9
	inc $1020
	if large
	bne predic9
	inc <$0E
	endif
predic9	jmp nxtinst

predicq	jmp ret8

	; *** IGRTR?
	def_inst_2op 5
	ldx <$11
	jsr xvalue
	inc <$14
	bne zigrtr2
	inc <$24
zigrtr1	jsr xstore
	lda <$14
	cmp <$11
	lda <$24
	sbc <$21
	bvc zigrtr2
	and #128
	jmp predic1
zigrtr2	bmi zigrtr3
	jmp fpredic
zigrtr3	jmp tpredic

	; *** DLESS?
	def_inst_2op 4
	ldx <$11
	jsr xvalue
	ldy <$14
	dey
	sty <$14
	cpy #255
	bne zdless1
	dec <$24
zdless1	jsr xstore
	lda <$11
	cmp <$14
	lda <$21
	sbc <$24
	bvc zigrtr2
	and #128
	jmp predic1

	; *** PTSIZE
	def_inst_1op 132
	lda $1021
	ora #255
	dcp $1011
	bne zptsz1
	dec $1021
zptsz1	ldx $5801
	lda ptsizt,x
	jmp val8

	; *** PUT
	def_inst_ext 225
	lda <$12
	asl a
	rol <$22
	clc
	adc <$11
	sta $1011
	lda <$22
	adc <$21
	sta $1021
	if smalend
	lda <$13
	else
	lda <$23
	endif
	sta $5801
	inc $1011
	bne zput1
	inc $1021
zput1	ds 0
	if smalend
	lda <$23
	else
	lda <$13
	endif
	sta $5801
	bit $1020
	jmp nxtinst

	; *** PUTB
	def_inst_ext 226
	lda <$12
	clc
	adc <$11
	sta $1011
	lda <$22
	adc <$21
	sta $1021
	lda <$13
	sta $5801
	bit $1020
	jmp nxtinst

	; *** GET
	def_inst_2op 15
	lda <$12
	asl a
	rol <$22
	clc
	adc <$11
	sta $1011
	lda <$22
	adc <$21
	sta $1021
	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	inc $1011
	bne zget1
	inc $1021
zget1	ds 0
	lda $5801
	if smalend
	sta <$24
	else
	sta <$14
	endif
	bit $1020
	jmp val16

	; *** GETB
	def_inst_2op 16
	lda <$12
	clc
	adc <$11
	sta $1011
	lda <$22
	adc <$21
	sta $1021
	lda $5801
	bit $1020
	jmp val8

	; *** ADD
	def_inst_2op 20
	clc
	lda <$11
	adc <$12
	sta <$14
	lda <$21
	adc <$22
	sta <$24
	jmp val16

	; *** SUB
	def_inst_2op 21
	sec
	lda <$11
	sbc <$12
	sta <$14
	lda <$21
	sbc <$22
	sta <$24
	jmp val16

	; *** BAND
	def_inst_2op 9
	lda <$11
	and <$12
	sta <$14
	lda <$21
	and <$22
	sta <$24
	jmp val16

	; *** BOR
	def_inst_2op 8
	lda <$11
	ora <$12
	sta <$14
	lda <$21
	ora <$22
	sta <$24
	jmp val16

	; *** BCOM
	def_inst_1op 143
	lda <$11
	eor #$FF
	sta <$14
	lda <$21
	eor #$FF
	sta <$24
	jmp val16

	; *** BTST
	def_inst_2op 7
	lda <$11
	and <$12
	eor <$12
	sta <4
	lda <$21
	and <$22
	eor <$22
	ora <4
	bne zbtst1
	jmp predic1
zbtst1	jmp fpredic

	; *** MUL
	def_inst_2op 22
	lax <$11
	clc
	adc <$12
	bcc zmul1
	eor #255
	adc #0
zmul1	tay
	txa
	sec
	sbc <$12
	bcs zmul2
	eor #255
	adc #1
	sec
zmul2	tax
	lda multabl,y
	sbc multabl,x
	sta <$14
	php
	lda <$11
	clc
	adc <$12
	tay
	bcc zmul3
	lda multabh+256,y
	jmp zmul4
zmul3	lda multabh,y
zmul4	plp
	sbc multabh,x
	sta <$24
	; low*high
	lax <$11
	clc
	adc <$22
	bcc zmul5
	eor #255
	adc #0
zmul5	tay
	txa
	sec
	sbc <$22
	bcs zmul6
	eor #255
	adc #1
	sec
zmul6	tax
	lda multabl,y
	sbc multabl,x
	clc
	adc <$24
	sta <$24
	; high*low
	lax <$21
	clc
	adc <$12
	bcc zmul7
	eor #255
	adc #0
zmul7	tay
	txa
	sec
	sbc <$12
	bcs zmul8
	eor #255
	adc #1
	sec
zmul8	tax
	lda multabl,y
	sbc multabl,x
	clc
	adc <$24
	sta <$24
	jmp val16

	; *** PUSH
	def_inst_ext 232
	inc <datasp
	ldx <datasp
	lda <$11
	sta dstackl,x
	lda <$21
	sta dstackh,x
	jmp nxtinst

	; *** POP
	def_inst_ext 233
	ldx <datasp
	dec <datasp
	lda dstackl,x
	sta <$12
	lda dstackh,x
	sta <$22
	ldx <$11
	jsr xstore
	jmp nxtinst

	; *** FSTACK
	def_inst_0op 185
	dec <datasp
	jmp nxtinst

	; *** SET
	def_inst_2op 13
	lda <$12
	sta <$14
	lda <$22
	sta <$24
	ldx <$11
	jsr xstore
	jmp nxtinst

	; *** VALUE
	def_inst_1op 142
	ldx <$11
	jsr xvalue
	jmp val16

	; *** INC
	def_inst_1op 133
	ldx <$11
	jsr xvalue
	inc <$14
	bne zinc1
	inc <$24
zinc1	jsr xstore
	jmp nxtinst

	; *** DEC
	def_inst_1op 134
	ldx <$11
	jsr xvalue
	ldy <$14
	dey
	sty <$14
	cpy #255
	bne zinc1
	dec <$24
	jsr xstore
	jmp nxtinst

	; Store value from <$x4 into variable labeled X
xstore	lda <$14
	cpx #0
	bne xstore1
	; Top of stack
	ldy <datasp
	sta dstackl,y
	lda <$24
	sta dstackh,y
	rts
xstore1	cpx #16
	bcs xstore2
	; Local variable
	sta <locall,x
	lda <$24
	sta <localh,x
	rts
	; Global variable
xstore2	ldy globadl,x
	sty $1014
	ldy globadh,x
	sty $1024
	if smalend
	sta $5801
	else
	ldy <$24
	sty $5801
	endif
	inc $1014
	if globodd
	bne xstore3
	inc $1024
	endif
xstore3	if smalend
	lda <$24
	endif
	sta $5801
	lda $1020
	rts

	; Read from variable labeled X into <$x4
xvalue	txa
	bne xvalue1
	; Top of stack
	ldy <datasp
	lda dstackl,y
	sta <$14
	lda dstackh,y
	sta <$24
	rts
xvalue1	cpx #16
	bcs xvalue2
	; Local variable
	lda <locall,x
	sta <$14
	lda <localh,x
	sta <$24
	rts
	; Global vaiable
xvalue2	ldy globadl,x
	sty $1015
	ldy globadh,x
	sty $1025
	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	inc $1015
	if globodd
	bne xvalue3
	inc $1025
	endif
xvalue3	lda $5801
	if smalend
	sta <$24
	else
	sta <$14
	endif
	bit $1020
	rts

	; *** IN?
	def_inst_2op 6
	ldx <$11
	clc
	lda objadl,x
	adc #4
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	bit $1020
	eor <$21
	bne zin1
	jmp predic1
zin1	jmp fpredic

	; *** FSET?
	def_inst_2op 10
	ldx <$11
	ldy <$12
	clc
	lda objadl,x
	adc flagad,y
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	and flagbit,y
	bne zfsetp1
	bit $1020
	jmp predic1
zfsetp1	jmp fpredic

	; *** FSET
	def_inst_2op 11
	ldx <$11
	ldy <$12
	clc
	lda objadl,x
	adc flagad,y
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	ora flagbit,y
	sta $5801
	bit $1020
	jmp nxtinst

	; *** FCLEAR
	def_inst_2op 12
	ldx <$11
	ldy <$12
	clc
	lda objadl,x
	adc flagad,y
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	and flagbic,y
	sta $5801
	bit $1020
	jmp nxtinst

	; *** LOC
	def_inst_1op 131
	ldx <$11
	clc
	lda objadl,x
	adc #4
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	bit $1020
	jmp val8

	; *** FIRST?
	def_inst_1op 130
	ldx <$11
	clc
	lda objadl,x
	adc #6
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	bit $1020
	jmp valp

	; *** NEXT?
	def_inst_1op 129
	ldx <$11
	clc
	lda objadl,x
	adc #5
	sta $5010
	lda objadh,x
	adc #0
	sta $5020
	lda $5801
	bit $1020
	; fall through

	; Value of instruction is 8-bits (from A)
	; Predicate is then if value is nonzero
valp	fetch_pc y,ldx
	bne valpa
	; Push to stack
	inc <datasp
	ldy <datasp
	sta dstackl,y
	sta <4
	txa
	sta dstackh,y
	lda <4
	jmp valpd1
valpa	cpx #16
	bcs valpb
	; Local variable
	sta <locall,x
	ldy #0
	sty <localh,x
	jmp valpd
	; Global variable
valpb	ldy globadl,x
	sty $1014
	ldy globadh,x
	sty $1024
	if smalend
	sta $5801
	else
	ldy #0
	sty $5801
	endif
	inc $1014
	if globodd
	bne valpc
	inc $1024
	endif
valpc	if smalend
	ldy #0
	sty $5801
	else
	sta $5801
	endif
	bit $1020
valpd	tax
valpd1	beq valpe
	jmp fpredic
valpe	jmp tpredic

	; Macro to do one step of ARCFOUR
	; Result is stored in accumulator
	macro do_arcfour
	inc <$3D
	ldx <$3D
	lda arcfour,x
	pha
	clc
	adc <$3E
	sta <$3E
	tay
	sta arcfour,y
	pla
	sta arcfour,x
	clc
	adc arcfour,y
	tax
	lda arcfour,x
	endm

	; *** RANDOM
	def_inst_ext 231
	ldx <$21
	beq zrand1
	lda bit1tab,x
	sta <$23
	lda #$FF
	jmp zrand2
zrand1	ldx <$11
	lda bit1tab,x
zrand2	sta <$13
zrand3	do_arcfour
	and <$23
	sta <$24
	cmp <$21
	beq zrand4 ; exactly equal
	bcs zrand1 ; try again; out of range
	jmp zrand5 ; low byte doesn't need to check
zrand4	do_arcfour
	and <$13
	cmp <$11
	bcs zrand1 ; try again; out of range
	adc #1
	sta <$14
	jmp zrand6
zrand5	do_arcfour
	sec
	adc #0
	sta <$14
zrand6	lda #0
	adc <$24
	sta <$24
	jmp val16

	; *** JUMP
	def_inst_1op 140
	lda <$11
	sec
	sbc #2
	tax
	lda <$21
	sbc #0
	tay
	bpl zjump1
	dec <$0E
zjump1	txa
	clc
	adc <$10
	sta <$10
	tya
	adc <$20
	sta $1020
	bcc zjump2
	inc <$0E
zjump2	jmp nxtinst

	; Macro to find a property, given object and property number
	; Object in <$11, property in <$12, branch to \1 if found
	; If \1 is with # at front then assume always will be found
	; X contains property size only in high 3-bits if found
	; X contains property number if not found
	; Output is $1014 and $1024 with address of property id
	macro propfind
	; Find the property table
	ldx <$11
	clc
	lda objadl,x
	adc #7
	sta $1015
	lda objadh,x
	adc #0
	sta $1025
	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	inc $1015
	bne n\@a
	inc $1025
n\@a	lda $5801
	if smalend
	sta $1014
	bit $1024
	else
	sta $1024
	bit $1014
	endif
	; Skip the short description
	lda $5801
	sec
	rol a
	bcc n\@d
	inc $1024
	clc
n\@d	adc <$14
	sta $1014
	bcc n\@b
	inc $1024
	; Find this property
n\@b	lda $5081
	if '\<1'!='#'
	beq n\@c
	endif
	eor <$12
	tax
	and #$1F
	if '\<1'='#'
	beq n\@c
	else
	beq \1
	endif
	lda ptsizt,x
	sec
	adc <$14
	sta $1014
	bcc n\@b
	inc $1024
	jmp n\@b
n\@c	ds 0
	endm

	; *** GETPT
	def_inst_2op 18
	propfind zgetpt1
	lda $1020
	and #0
	jmp val8
zgetpt1	lda $1020
	inc <$14
	bne zgetpt2
	inc <$24
zgetpt2	jmp val16	

	; *** GETP
	def_inst_2op 17
	propfind zgetp2
	; Use default value
	asl <$11
	rol <$21 ;clears carry
	lda #low(object-2)
	adc <$11
	sta $1015
	lda #high(object-2)
	adc <$21
	sta $1025
	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	inc $1015
	if object&1
	bne zgetp1
	inc $1025
	endif
zgetp1	lda $5801
	if smalend
	sta <$24
	else
	sta <$14
	endif
	bit $1020
	jmp val16
	; Use actual value
zgetp2	inc $1014
	bne zgetp3
	inc $1024
zgetp3	cpx #$20
	bne zgetp5
	; Long property
	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	inc $1014
	bne zgetp4
	inc $1024
zgetp4	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	jmp val16
	; Short property
zgetp5	lda $5801
	bit $1020
	jmp val8

	; *** PUTP
	def_inst_ext 227
	propfind #
	inc $1014
	bne zputp2
	inc $1024
zputp2	cpx #$20
	bne zputp4
	; Long property
	if smalend
	lda <$13
	else
	lda <$23
	endif
	sta $5801
	inc $1014
	bne zputp3
	inc $1024
zputp3	if smalend
	lda <$23
	else
	lda <$13
	endif
	sta $5801
	lda $1020
	jmp nxtinst
	; Short property
zputp4	lda <$13
	sta $5801
	lda $1020
	jmp nxtinst

	; *** NEXTP
	def_inst_2op 19
	ldx <$11
	bne znextp4
	; Find first property
	clc
	lda objadl,x
	adc #7
	sta $1015
	lda objadh,x
	adc #0
	sta $1025
	lda $5801
	if smalend
	sta <$14
	else
	sta <$24
	endif
	inc $1015
	bne znextp1
	inc $1025
znextp1	lda $5801
	if smalend
	sta $1014
	bit $1024
	else
	sta $1024
	bit $1014
	endif
	; Skip the short description
	lda $5801
	sec
	rol a
	bcc znextp2
	inc $1024
	clc
znextp2	adc <$14
	sta $1014
	bcc znextp3
	inc $1024
znextp3	lda $5801
	and #$1F
	bit $1020
	jmp val8
znextp4	propfind #
	lda ptsizt,x
	sec
	adc <$14
	sta $1014
	bcc znextp5
	inc $1024
znextp5	lda $5801
	bit $1020
	and #$1F
	jmp val8

	; *** REMOVE
	def_inst_1op 137
	lda #0
	sta <$12
	; fall through

	; *** MOVE
	def_inst_2op 14
	; Find the LOC of first object, see if need to remove
	ldx <$11
	clc
	lda objadl,x
	adc #4
	sta $1013
	lda objadh,x
	adc #0
	sta $1023
	lda $5801
	ldy <$12
	sty $5801
	tay
	beq zmove2
	; Look at the NEXT slot too
	inc $1013
	bne zmove1
	inc $1023
zmove1	ldy $5801
	ldx #0
	stx $5801
	; Find it in the FIRST-NEXT chain of the parent object
	tax
	lda objadl,x
	adc #6
	sta $1014
	lda objadh,x
	adc #0
	sta $1024
	lax $5801 ; not adjust carry flag
	eor <$11
	bne zmove3
	; It is the first child object
	; Let First(Parent)=Next(Child)
	sty $5801
	jmp zmove2
	; It is not the first child object
zmove3	lda objadl,x
	adc #5
	sta $1014
	lda objadh,x
	adc #0
	sta $1024
	lax $5801
	eor <$11
	bne zmove3
	; It is found
	sty $5801
	; Now insert the object into the new container (if nonzero)
zmove2	ldx <$12
	beq zmove4
	lda objadl,x
	adc #6
	sta $1014
	lda objadh,x
	adc #0
	sta $1024
	ldy $5801
	stx $5801
	bit $1013
	bit $1023
	sty $5801
zmove4	lda $1020
	jmp nxtinst

	; Print a space
space	lda <$30
	cmp #$E2
	bne space1
	lda <$31
	and #$1F
	bne space1
	jsr bufout
	lda <$31
	and #$1F
	bne space2
space1	inc <$31
space2	rts

	; Output and clear the buffer
bufout	lda <$31
	anc #$1F
	adc <$30
	bcc bufout0
	jsr addlin1
bufout0	ldx #0
	lda <$32
	ldy <$31
bufout1	bit $2002
	bpl bufout1
	stx $2001 ; render off
	sta $2006
	sty $2006
	ldx #$E2
	cpx <$30
	beq bufout3
bufout2	lda <0,x
	sta $2007
	inx
	cpx <$30
	bne bufout2
bufout3	tya
	anc #$1F
	bne bufout4
	; Blank the bottom row (just scrolled in)
	lda <5
	sta $2006
	lda <4
	sta $2006
	lda #32
	sta $2007 ;1
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007 ;10
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007 ;20
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007 ;30
bufout4	lda #$F8
	sta $2005
	ldx <$33
	stx $2005
	anc #$08
	sta $2001
	sta $2000
	lda <$30
	sbc #$E1
	clc
	adc <$31
	sta <$31
	lda <$32
	adc #0
	sta <$32
	lda #$E2
	sta <$30
bufout5	rts

	; Skip to the next line
addline	sec
addlin1	lda <$33
	adc #7
	sta <$33
	cmp #$F0
	bcc addlin2
	anc #0
	sta <$33
addlin2	lda <$31
	and #$E0
	adc #$20
	sta <$31
	lda <$32
	adc #0
	sta <$32
	cmp #$27
	bne addlin3
	lda <$31
	cmp #$C0
	bne addlin3
	lda #$24
	sta <$32
	lda #0
	sta <$31
	; Prepare address to blank out the line
addlin3	lax <$31
	clc
	adc #$40
	sta <4
	lda <$32
	adc #0
	sta <5
	cmp #$27
	bcc addlin4
	cpx #$80
	bcc addlin4
	lda #$24
	sax <4
	sta <5
addlin4	dec <$34
	bne addlin5
	lda #27
	sta <$34
	jmp more
addlin5	rts

	; Display the <MORE> prompt
more	ldx #0
	lda <$32
	ldy <$31
more1	bit $2002
	bpl more1
	stx $2001 ; render off
	sta $2006
	sty $2006
	lda #'<'
	sta $2007
	lda #'M'
	sta $2007
	lda #'O'
	sta $2007
	lda #'R'
	sta $2007
	lda #'E'
	sta $2007
	lda #'>'
	sta $2007
	; Blank the bottom row (just scrolled in)
	lda <5
	sta $2006
	lda <4
	sta $2006
	lda #32
	sta $2007 ;1
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007 ;10
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007 ;20
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007 ;30
	; Re-enable rendering
	lda #$F8
	sta $2005
	ldx <$33
	stx $2005
	anc #$08
	sta $2001
	sta $2000
	; Wait for keyboard not pushed
more2	ldx #5
	stx $4016
	dex
	ldy #9
more3	stx $4016
	lda $4017
	ora #$E1
	eor #$FF
	bne more2
	lda #6
	sta $4016
	lda $4017
	ora #$E1
	eor #$FF
	bne more2
	dey
	bne more3
	; Wait for space-bar pushed
	ldx #5
	lda #4
	ldy #6
more4	stx $4016 ;reset
	sta $4016 ;0/0
	sty $4016 ;0/1
	sta $4016 ;1/0
	sty $4016 ;1/1
	sta $4016 ;2/0
	sty $4016 ;2/1
	sta $4016 ;3/0
	sty $4016 ;3/1
	sta $4016 ;4/0
	sty $4016 ;4/1
	sta $4016 ;5/0
	sty $4016 ;5/1
	sta $4016 ;6/0
	sty $4016 ;6/1
	sta $4016 ;7/0
	sty $4016 ;7/1
	sta $4016 ;8/0
	sty $4016 ;8/1
	and $4017
	bne more4
	; Erase <MORE>
	lda #0
	sta $2001
	lda <$32
	sta $2006
	lda <$31
	sta $2006
	lda #32
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	sta $2007
	rts

	; *** PRINTC
	def_inst_ext 229
	lda <$11
	beq zprntc2
	cmp #32
	beq zprntc1
	cmp #13
	beq zcrlf
	ldx <$30
	beq zprntc2
	sta <0,x
	inc <$30
zprntc1	jmp nxtinst
zprntc2	jsr space
	jmp nxtinst

	; *** CRLF
	def_inst_0op 187
zcrlf	jsr bufout
	lda <$31
	ora #$1F
	sta <$31
zcrlf2	jmp nxtinst

	; *** PRINTN
	def_inst_ext 230
	lda <$30
	beq zcrlf2 ; ensure there is room in the buffer
	ldy <$11
	lax <$21
	anc #$FF
	bcc znum01
	eor #$FF
	sta <4
	ldx <$30
	inc <$30
	lda #'-'
	sta <0,x
	tya
	eor #$FF
	tay
	ldx <4
znum01	lda digit0l,y
	adc digit0h,x
	pha
	cmp #10
	lda digit1l,y
	adc digit1h,x
	pha
	cmp #10
	lda digit2l,y
	adc digit2h,x
	pha
	cmp #10
	lda #0
	adc digit3h,x
	pha
	cmp #10
	lda #0
	adc digit4h,x
	ldx <$30
	tay ; make the flag according to accumulator
	beq znum02
	; Five digits
	sta <0,x
	pla
	sta 1,x
	pla
	sta 2,x
	pla
	sta 3,x
	pla
	sta 4,x
	txa
	axs #-5
	stx <$30
	jmp nxtinst
znum02	pla
	beq znum03
	; Four digits
	sta <0,x
	pla
	sta 1,x
	pla
	sta 2,x
	pla
	sta 3,x
	txa
	axs #-4
	stx <$30
	jmp nxtinst
znum03	pla
	beq znum04
	; Three digits
	sta <0,x
	pla
	sta 1,x
	pla
	sta 2,x
	txa
	axs #-3
	stx <$30
	jmp nxtinst
znum04	pla
	beq znum05
	; Two digits
	sta <0,x
	inx
	pla
	sta <0,x
	inx
	stx <$30
	jmp nxtinst
znum05	pla
	; One digit
	sta <0,x
	inc <$30
	jmp nxtinst

	; *** PRINTI
	def_inst_0op 178
	jsr textpc
	jmp nxtinst

	; *** PRINTR
	def_inst_0op 179
	jsr textpc
	jsr bufout
	lda <$31
	ora #$1F
	sta <$31
	lda #1
	jmp ret8

	; *** PRINTB
	def_inst_1op 135
	jsr textba
	jmp nxtinst

	; *** PRINT
	def_inst_1op 141
	asl <$11
	rol <$21
	lda #0
	rol a
	sta <$36
	jsr textwa
	jmp nxtinst

	; *** PRINTD
	def_inst_1op 138
	ldx <$11
	clc
	lda objadl,x
	adc #7
	sta $1012
	lda objadh,x
	adc #0
	sta $1022
	if smalend
	lda $5801
	else
	ldy $5801
	endif
	inc $1012
	bne zprntd1
	inc $1022
zprntd1	if smalend
	adc #1
	sta <$11
	lda $5801
	else
	lda $5801
	adc #1
	sta <$11
	tya
	endif
	adc #0
	sta <$21
	jsr textba
	jmp nxtinst

	; *** VERIFY
	def_inst_0op 189
	jmp tpredic ; there is no disk, so just assume it is OK

	; *** QUIT
	def_inst_0op 186
	jsr bufout
	lda <$31
	ora #$1F
	sta <$31
	jsr bufout
zquit	jmp zquit

	; *** READ
	jsr bufout
	;TODO
zread	jmp zread

	bank intbank+3
	; Z-character decoding
	; high 3-bits = state, low 5-bits = value

	org $F100-12
	; Text starting from program counter
textpc	lda #0
	sta <$38
	sta <$27
	ldx #$A0
	stx <$09
	stx <$0A

	org $F100
	lda <$27
	bmi textpc1
	lda #$F2
	sta <$39
	lda #$FE
	pha
	fetch_pc y,lda
	if smalend
	sta <$17
	else
	sta <$27
	endif
	if smalend
	fetch_pc y,lda
	sta <$27
	else
	fetch_pc y,ldx
	stx <$17
	endif
	lsr a
	lsr a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
textpc1	rts

	org $F200
	lda #$FE
	pha
	inc <$39
	ldx <$17
	stx <4
	lda <$27
	asl <4
	rol a
	asl <4
	rol a
	asl <4
	rol a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $F300
	lda #$F1
	sta <$39
	lda #$FE
	pha
	lda <$17
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $F400-12
	; Text from byte address
textba	lda #0
	sta <$38
	sta <$27
	ldx #$A0
	stx <$09
	stx <$0A

	org $F400
	lda <$27
	bmi textba1
	lda #$F5
	sta <$39
	lda #$FE
	pha
	lda $1011
	lda $1021
	lda $5803
	if smalend
	sta <$17
	else
	sta <$27
	endif
	inc $1011
	bne textba2
	inc $1021
textba2	if smalend
	lda $5803
	sta <$27
	else
	ldx $5803
	stx <$17
	endif
	inc $1011
	bne textba3
	inc $1021
textba3	lsr a
	lsr a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts
textba1	bit $1020
	rts

	org $F500
	lda #$FE
	pha
	inc <$39
	ldx <$17
	stx <4
	lda <$27
	asl <4
	rol a
	asl <4
	rol a
	asl <4
	rol a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $F600
	lda #$F4
	sta <$39
	lda #$FE
	pha
	lda <$17
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $F700-12
	; Text from word address (aligned)
textwa	lda #0
	sta <$38
	sta <$27
	ldx #$A0
	stx <$09
	stx <$0A

	org $F700
	lda <$27
	bmi textwa1
	lda #$F8
	sta <$39
	lda #$FE
	pha
	lda $1011
	lda $1021
	ldy <$36
	lda $5803,y
	if smalend
	sta <$17
	else
	sta <$27
	endif
	if smalend
	inc $1011
	lda $5803,y
	sta <$27
	else
	ldx $5803,y
	stx <$17
	endif
	inc $1011
	bne textwa4
	inc $1021
	bne textwa4
	inc <$36
textwa4	lsr a
	lsr a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts
textwa1	bit $1020
	rts

	org $F800
	lda #$FE
	pha
	inc <$39
	ldx <$17
	stx <4
	lda <$27
	asl <4
	rol a
	asl <4
	rol a
	asl <4
	rol a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $F900
	lda #$F7
	sta <$39
	lda #$FE
	pha
	lda <$17
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $FA00-20
	; Text from frequent word
textfw	lda #0
	sta <$38
	sta <$29
	lda <$0A
	sta <$0B
	ldx #$A0
	stx <$09
	stx <$0A
	lda <$39
	sta <$35

	org $FA00
	lda <$29
	bmi textfw1
	lda #$FB
	sta <$39
	lda #$FE
	pha
	ldy <$37
	lda $5803,y
	if smalend
	sta <$19
	else
	sta <$29
	endif
	inc $1016
	if smalend
	lda $5803,y
	sta <$29
	else
	ldx $5803,y
	stx <$19
	endif
	inc $1016
	bne textfw2
	inc $1026
	bne textfw2
	inc <$37
textfw2	lsr a
	lsr a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts
textfw1	bit $1020
	lda <$35
	sta <$39
	lda <$0B
	sta <$0A
	sta <$09
	jmp [$38]

	org $FB00
	lda #$FE
	pha
	inc <$39
	ldx <$19
	stx <4
	lda <$29
	asl <4
	rol a
	asl <4
	rol a
	asl <4
	rol a
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	org $FC00
	lda #$FA
	sta <$39
	lda #$FE
	pha
	lda <$19
	anc #31
	ora <$09
	tax
	lda zchad,x
	pha
	rts

	; States can be:
	;   0   = Second step of ASCII escape
	;   1-3 = Fwords
	;   4   = First step of ASCII escape
	;   5-7 = Shift states 0,1,2

	; These subroutines are entered with X set to the state.
	; Also has carry flag cleared.
	org $FE01

	; ** Emit a space
	def_zchars $A0
	def_zchars $C0
	def_zchars $E0
zch32	jsr space
	jmp [$38]

	; ** Second escape
	def_zchars $00,$1F
	txa
	ora <5
	beq zch1
	cmp #32
	beq zch32
	cmp #13
	beq zch13
	ldx <$30
	beq zch1
	sta <0,x
	inc <$30
	lda <$0A
	sta <$09
	jmp [$38]

	; ** First escape
	def_zchars $80,$9F
	txa
	asl a
	asl a
	asl a
	asl a
	asl a
	sta <5
	anc #0
	sta <$09
	jmp [$38]

	; ** Frequent words
	def_zchars $20,$7F
	lda fwordsl,x
	sta $1015
	lda fwordsh,x
	sta $1025
	lda $5801
	if smalend
	asl a
	sta <$16
	else
	sta <$26
	lda #0
	rol a
	sta <$37
	endif
	inc $1015
	bne zfw1
	inc $1025
zfw1	lda $5801
	if smalend
	rol a
	sta <$26
	else
	asl a
	sta <$16
	rol <$26
	endif
	lda #0
	adc #0
	sta <$37
	jmp textfw

	; ** Begin escape
	def_zchars $E6
	lda #$80
	sta <$09
	jmp [$38]

	; ** Direct character code
	def_zchars $A6,$BF
	def_zchars $C6,$DF
	def_zchars $E8,$FF
	ldy <$30
	beq zch1
	stx <$E0,y
	inc <$30
zch1	lda <$0A
	sta <$09
	jmp [$38]

	; ** Emit a line break
	def_zchars $E7
zch13	jsr bufout
	lda <$31
	ora #$1F
	sta <$31
	lda <$0A
	sta <$09
	jmp [$38]

	; ** Begin frequent words state 0-31
	def_zchars $A1
	def_zchars $C1
	def_zchars $E1
	lda #$20
	sta <$09
	jmp [$38]

	; ** Begin frequent words state 32-63
	def_zchars $A2
	def_zchars $C2
	def_zchars $E2
	lda #$40
	sta <$09
	jmp [$38]

	; ** Begin frequent words state 64-95
	def_zchars $A3
	def_zchars $C3
	def_zchars $E3
	lda #$60
	sta <$09
	jmp [$38]

	; ** Temporary shift 1
	def_zchars $A4
	lda #$C0
	sta <$09
	jmp [$38]

	; ** Temporary shift 2
	def_zchars $A5
	lda #$E0
	sta <$09
	jmp [$38]

	; ** Permanent shift 1 or 2
	def_zchars $C4
	def_zchars $E5
	and #$F0
	sta <$0A
	jmp [$38]

	; ** Permanent shift 0
	def_zchars $C5
	def_zchars $E4
	lda #$A0
	sta <$09
	sta <$0A
	jmp [$38]

	; Reset vector
	bank intbank+3
	org $FFFA
	dw 0,reset,0

	; Pattern tables
	bank intbank+4
	org $0000
	incbin "pc.chr"

	; Cursor icon
	org $07F0
	defchr $00000000, \
	       $03030300, \
	       $00303030, \
	       $03030300, \
	       $00303030, \
	       $03030300, \
	       $00303030, \
	       $00000000

	; Postprocessor
	emu

	org $0000
	lda 0
	sta $2012
	inc <1
	rts

	org $0040
	db "0123456789012345"
	db "6789012345678901"

	org $0080
	db "                                "   ; $80-$9F
	db "      abcdefghijklmnopqrstuvwxyz"   ; $A0-$BF
	db "      ABCDEFGHIJKLMNOPQRSTUVWXYZ"   ; $C0-$DF
	db "      **0123456789.,!?_#'\"/\\-:()" ; $E0-$FF

	org $8000
	cld

	; Make duplicates of ASCII characters as Z-characters
	lda #1
	sta $200D
	lda #0
	sta $200E
	lda #8
	sta $200F
	ldx #$80
pp1	lda #4
	sta <2
	lda <0,x
	asl a
	rol <2
	asl a
	rol <2
	asl a
	rol <2
	asl a
	rol <2
	sta <1
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	inx
	bne pp1

	; Make duplicate of digits for use with PRINTN
	ldx #0
	stx $200E
	stx $200F
pp2	lda #4
	sta <2
	lda <$40,x
	asl a
	rol <2
	asl a
	rol <2
	asl a
	rol <2
	asl a
	rol <2
	sta <1
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	jsr 0
	inx
	cpx #32
	bne pp2

	; Finished
	hlt

	org $FFFC
	dw $8000

	code
	bank intbank+4

C program

This program is generating a stub file and story ROM for its use. 

/*
  This file is part of Famizork II and is in the public domain.
*/

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

static FILE*fp;
static int c;
static int d;
static int gamesize;
static char endian;
static unsigned char mem[0x20000];
static char buf[256];

#define OUTHEADER(x,y) fprintf(fp,"%s\t= %u\n",x,(mem[y*2+endian]<<8)|mem[y*2+1-endian])

int main(int argc,char**argv) {
  if(argc<2) return 1;
  fp=fopen(argv[1],"rb");
  fseek(fp,0,SEEK_END);
  gamesize=ftell(fp);
  if(gamesize>0x20000 || gamesize<0) return 1;
  fseek(fp,0,SEEK_SET);
  fread(mem,1,gamesize,fp);
  fclose(fp);
  if(*mem!=3) return 1;
  sprintf(buf,"%s.asm",argv[1]);
  fp=fopen(buf,"w");
  endian=mem[1]&1;
  mem[1]&=3;
  mem[1]|=16;
  c=(gamesize>0x10000?16:gamesize>0x8000?8:gamesize>0x4000?4:2);
  fprintf(fp,"\tnes2prgram 0,131072\n");
  fprintf(fp,"\tinesprg %d\n",(c>>1)+2);
  fprintf(fp,"intbank\t= %d\n",c);
  fprintf(fp,"smalend\t= %d\n",endian);
  fprintf(fp,"large\t= %d\n",gamesize>=0x10000);
  if(gamesize<0x10000) fprintf(fp,"maxaddr\t= %u\n",gamesize-1);
  OUTHEADER("start",3);
  OUTHEADER("vocab",4);
  OUTHEADER("object",5);
  OUTHEADER("global",6);
  OUTHEADER("purbot",7);
  OUTHEADER("fwords",12);
  fprintf(fp,"\tcode\n\tbank 0\n\tincbin \"%s.rom\"\n\tinclude \"famizork2.asm\"\n",argv[1]);
  fprintf(fp,"\n\tbank %d\n\torg fwordsl\n",c);
  d=(mem[24+endian]<<8)|mem[25-endian];
  for(c=0;c<192;c+=2) fprintf(fp,"\tdb %d\n",(d+c)&255);
  for(c=0;c<192;c+=2) fprintf(fp,"\tdb %d\n",((d+c)>>8)&255);
  fprintf(fp,"\torg multabl\n");
  for(c=0;c<255;c++) fprintf(fp,"\tdb %d\n",((c*c)>>2)&255);
  for(c=0;c<512;c++) fprintf(fp,"\tdb %d\n",((c*c)>>10)&255);
  fprintf(fp,"\tbank intbank+4\n");
  fclose(fp);
  sprintf(buf,"%s.rom",argv[1]);
  fp=fopen(buf,"wb");
  if(gamesize>0x10000) {
    fwrite(mem+0x10000,1,0x10000,fp);
    fwrite(mem,1,0x10000,fp);
  } else {
    fwrite(mem,1,gamesize,fp);
  }
  fclose(fp);
  return 0;
}

Explanation

The explanation of the mapper is User:Zzo38/Mapper_I.

The pattern table is arranged in this way (although $7F is the cursor picture, not shown here): 

0123456789012345
6789012345678901
 !"#$%&'()*+,-./
0123456789:;<=>?
@ABCDEFGHIJKLMNO
PQRSTUVWXYZ[\]^_
`abcdefghijklmno
pqrstuvwxyz{|}~
                
                
      abcdefghij
klmnopqrstuvwxyz
      ABCDEFGHIJ
KLMNOPQRSTUVWXYZ
      **01234567
89.,!?_#'"/\-:()

As you can see there are many duplicates, in particular each digit occurs five times, except 0 and 1 which occur six times each. Many other characters also occur twice. These will improve the speed of the program, since it does not have to convert Z-characters and numbers into ASCII before displaying them.

Many things are precomputed at compile-time in order to improve speed (also improves size of the interpreter):

  • The mode byte is set to indicate that the status bar is unavailable
  • Address of objects, global variables, and frequent words table
  • Starting address of execution of program
  • Endianness and various calculations related to it
  • The size of the story file, which can be used to determine needed ROM sizes and optimizing of the interpreter
  • Self-inserting-breaks
  • Stuff to optimize the vocabulary (not yet)
  • Multiplication tables

A custom mapper is used, which bankswitches only one byte at a time. This makes much of the logic for addressing the story file much simpler than it otherwise would be. It also overlaps bankswitching registers with mirrors of the RAM internal to the console, and since they respond to multiple addresses, this means you can save the bankswitched value at the same time as bankswitching, that you can store multiple bank numbers at once (even though the mapper can only remember one at once), and that reading from the RAM mirrors will also bankswitch (allows you to restore a saved bankswitch in four cycles; with other mappers it is usually seven).

There is an instruction decoding table, which is one table for all instructions and contains duplicates for the different forms of the instruction (such as EXT forms of 2OP instructions, the different variable/immediate combinations for 2OP, and the different operand types for 1OP). However, a different opcode is used when EQUAL? is encoded as EXT than as 2OP, in order to improve the speed in the 2OP case. The code can just use "jmp nxtinst" to begin decoding the next instruction; it doesn't use return from subroutine.

Instruction decoding tables, as well as the Z-character decoding tables, both use the RTS trick, although in the case of Z-character decoding, the table contains only the low byte of the address since the code is small enough in this case.

Also it is using several stable unofficial opcodes.

Retrieved from "https://www.nesdev.org/w/index.php?title=User:Zzo38/Famicom_Z-machine&oldid=16925"