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

From NESdev Wiki
Jump to navigationJump to search
No edit summary
(Famizork II)
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 does not yet work.
 
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.
 
Unlike many Z-machine interpreters, this one supports permanent shifts even in version 3.
 
<b>Opcode</b>    <b>Status</b>
EQUAL?      OK
LESS?      OK
GRTR?      OK
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. -->
-----


== Main file ==
<pre>
<pre>
; Z-machine interpreter (Z-code versions 1 to 3) for Famicom
; Famizork II
; version 0.0
; Public domain
; Public domain


inesmap 5 ; MMC5 or "User:Zzo38/Mapper D"
debug = 1  ; change this to 1 to enable breakpoints 0 to disable
inesmir 1 ; Horizontal arrangement
    ; set a breakpoint on opcode $1A in the debugger
inesprg 16 ; 256K (bank 0 to 15 for story file, 16 to 31 for interpreter)
ineschr 1 ; 8K


; The C program will read, adjust the header, and then set asm macros, as follows:
inesmap 380 ; Famizork II mapper
;   zver: Z-machine version number.
ineschr 1 ; 8K CHR ROM
;   bytswap: Defined for small endian, undefined for big endian
inesmir 3 ; horizontal arrangement with battery
;  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
; Zero-page variables:
xglobal = global-32 ; Offset for global variables
;  $02 = data stack pointer
xvocab = vocab+sibcnt+4 ; Actual start of vocab
;  $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


; Low RAM usage:
code
;  $0xx = Miscellaneous variables
;  $1xx = 6502 stack
;  $2xx = Bits 7:0 of Z-machine data stack
;  $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
outbuf ds 32 ; The output buffer
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
rombank = $5115 ; 1xxx xxx0


; Mapping ROM address:
datasp = $02
;  Bank = ((A>>13)|128)&254
callsp = $03
;  Address = (A&$3FFF)|$8000
locall = $40
localh = $50


; Mapping RAM address:
dstackl = $200
;  Bank = A>>13
dstackh = $300
;  Address = (A&$1FFF)|$6000


macro romsel
cstackl = $400
lda #128|bank(\1)&254
cstackm = $480
sta rombank
cstackh = $500 ; bit4-bit1=number of locals, bit0=bit16 of PC
endmac
cstackx = $580 ; data stack pointer


macro bankcall
arcfour = $600 ; use for random number generator
ldy #128|bank(\1)&254
sty rombank
jsr \1
endmac


macro bankjump
bank intbank+0,"Interpreter"
ldy #128|bank(\1)&254
bank intbank+1,"Interpreter"
sty rombank
bank intbank+2,"Interpreter"
jmp \1
bank intbank+3,"Interpreter"
endmac


code
bank intbank
 
bank 16
org $8000
org $8000


; Alphabet table row 2
macro breakpoint
if zver=1
if debug
alpha2 db 32, 13, "*****0123456789.,!?_#'", 34, "/", 92, "<-:()"
db $1A ; unofficial NOP
else
alpha2 db " ******", 13, "0123456789.,!?_#'", 34, "/", 92, "-:()"
endif
endif
endm


; Keyboard decoding table (lowercase is necessary)
macro breakpoint2
kbdt db "][", 13, 0, 0, 92, 15, 0
if debug
db ";:@", 0, "^-/_"
db $3A ; unofficial NOP
db "klo", 0, "0p,."
endif
db "jui", 0, "89nm"
endm
db "hgy", 0, "67vb"
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 make_digit_table
sendout inc <outrdy
macset 4,4,0
;TODO
macgoto make_digit_table_0
lda #0
endm
sta <bufptr
pla
rti


; Send a line feed (not using <r0 <r1)
macro make_digit_table_0
sendlf inc <linrdy
db ((\4*\2)/\1)%10
lda #1
macset 4,4,\4+1
sta <cursx
macset 5,4,\4=\3
 
macgoto make_digit_table_\5
; Blank out the next line
endm
lda #$08
sta <r2
lda <scrolly
asl a
rol <r2
asl a
rol <r2
ldx <r2
stx $2006
sta $2006
lda #32
tax
sendlf1 sta $2007
dex
bne sendlf1
 
; Advance scroll position and line position
lda <scrolly
clc
adc #$08
cmp #$F0
bne sendlf2
lda #$00
sendlf2 sta <scrolly
;TODO
 
; Check if [MORE] prompt should be displayed
;TODO


; Return from NMI
macro make_digit_table_1
pla
; Empty macro
rti
endm


; Ready the output buffer for dumping to the screen
globodd = global&1
; And then, wait for the NMI routine to clear it
outdump dec <outrdy
outdum1 bit <outrdy
bvs outdum1
outdum2 rts


; Ready to output a line feed
macro make_global_table
; Wait for NMI routine to clear the flag
macset 2,4,16
lfodump dec <outrdy
macgoto make_global_table_0
lfdump dec <linrdy
endm
lfdump1 bit <linrdy
bvs lfdump1
lfdump2 rts


; Print a character
macro make_global_table_0
putchar cmp #0
db \1(global+\2+\2-32)
beq lfdump2 ; outputting ASCII code 0 has no effect
macset 2,4,\2+1
cmp #13
macset 3,4,\2=256
beq lfodump ; output the buffer and a line break
macgoto make_global_table_\3
cmp #32
endm
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


endword jsr outdump
macro make_global_table_1
cpx #31
; Empty macro
bcs lfdump
endm
bcc putcha1


; Print a signed 16-bit integer (<op0h,<op0l), then nxtinst
macro make_object_table
printn lda <op0h
macset 2,4,0
bit #$80
macgoto make_object_table_0
beq printn1
endm
; Negative number
lda #45
jsr putcha0
; Bitwise complement and increment
lda <op0h
eor #$FF
tax
lda <op0l
eor #$FF
clc
adc #1
sta <op0l
txa
adc #0
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
adc mod100,y
sta <r0
lda ht256,x
ldx divten,y
adc divten,x
ldy <r0
ldx divten,y
adc divten,x
sta <r1
tax
ldy divten,x
lda divten,y
ldx <op0h
adc myr256,x
; Use the carry flag to indicate printing leading zeros or not
jsr digpair
lda <r1
jsr digpair
lda <r0
jsr digpair
bcs printn2
; The value is zero
lda #$30
jsr putchar
printn2 jmp nxtinst


; Print a pair of digits
macro make_object_table_0
digpair tay
db \1(object+(\2*9)+62-9)
lda divten,y
macset 2,4,\2+1
bne digpai1
macset 3,4,\2=256
bcc digpai2
macgoto make_object_table_\3
digpai1 ora #$30
endm
jsr putcha0
sec
digpai2 lda modten,y
bne digpai3
bcc digpai4
digpai3 ora #$30
jsr putcha0
sec
digpai4 rts


; Convert and print a Z-character
macro make_object_table_1
putzch and #$1F
; Empty macro
tay
endm
ora <tshift
tax
lda #$BF
pha
lda zchlut,x
pha
rts


bank 17
instadl ds 256
instadh ds 256


; Myriads of 256 times value (up to 128 only)
globadl ds 16
org $B87F
make_global_table low
myr256 db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0;
globadh ds 16
db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0;
make_global_table high
db 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1;
db 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2;
db 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2;
db 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3;
db 3,3,3,3,3,3,3,3,3


; Modulo by one hundred
objadl make_object_table low
org $B900
objadh make_object_table high
mod100 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,56,57,58,59
db 60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79
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,56,57,58,59
db 60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79
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
multabl ds 256 ; x*x/4
org $BA00
multabh ds 512 ; x*x/1024
ot256 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,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,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
digit0l make_digit_table 1,1,256
org $BB00
digit1l make_digit_table 10,1,256
ht256 db 0,2,5,7,10,12,15,17,20,23,25,28,30,33,35,38,40,43,46,48;
digit2l make_digit_table 100,1,256
db 51,53,56,58,61,64,66,69,71,74,76,79,81,84,87,89,92,94,97,99;
digit0h make_digit_table 1,256,128
db 2,4,7,10,12,15,17,20,22,25,28,30,33,35,38,40,43,45,48,51;
digit1h make_digit_table 10,256,128
db 53,56,58,61,63,66,68,71,74,76,79,81,84,86,89,92,94,97,99,2;
digit2h make_digit_table 100,256,128
db 4,7,9,12,15,17,20,22,25,27,30,32,35,38,40,43,45,48,50,53;
digit3h make_digit_table 1000,256,128
db 56,58,61,63,66,68,71,73,76,79,81,84,86,89,91,94,96,99,2,4;
db 7,9,12,14,17,20,22,25,27,30,32,35,37,40,43,45,48,50,53,55;
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
bit1tab db   0, 1,  3,  3,  7, 7, 7, 7, 15, 15, 15, 15, 15, 15, 15, 15
org $BC00
db  31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31, 31
divten db 0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1
db  63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63
db 2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3
db  63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63, 63
db 4,4,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 6,6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,7,7,7,7
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 8,8,8,8,8,8,8,8,8,8,9,9,9,9,9,9,9,9,9,9
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 10,10,10,10,10,10,10,10,10,10,11,11,11,11,11,11,11,11,11,11
db 127,127,127,127,127,127,127,127,127,127,127,127,127,127,127,127
db 12,12,12,12,12,12,12,12,12,12,13,13,13,13,13,13,13,13,13,13
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 14,14,14,14,14,14,14,14,14,14,15,15,15,15,15,15,15,15,15,15
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 16,16,16,16,16,16,16,16,16,16,17,17,17,17,17,17,17,17,17,17
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 18,18,18,18,18,18,18,18,18,18,19,19,19,19,19,19,19,19,19,19
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 20,20,20,20,20,20,20,20,20,20,21,21,21,21,21,21,21,21,21,21
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 22,22,22,22,22,22,22,22,22,22,23,23,23,23,23,23,23,23,23,23
db 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255
db 24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25
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


; Modulo by ten
zchad ds 256
org $BD00
modten 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
db 0,1,2,3,4,5,6,7,8,9,0,1,2,3,4,5,6,7,8,9 ;100
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
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
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
org $BE00
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


zchlut ;    0    1    2    3    4    5    6    7    8    9  10  11  12  13  14  15
flagad if smalend
;    16  17  18  19  20  21  22  23  24  25  26  27  28  29  30  31
db 1,1,1,1,1,1,1,1
if zver=1
db 0,0,0,0,0,0,0,0
db zza2,zza2,zzt1,zzt2,zzp1,zzp2,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
db 3,3,3,3,3,3,3,3
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
db 2,2,2,2,2,2,2,2
db zza2,zza2,zzt2,zzt0,zzp2,zzp0,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
else
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
db 0,0,0,0,0,0,0,0
db zza2,zza2,zzt0,zzt1,zzp0,zzp1,zzes,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
db 1,1,1,1,1,1,1,1
db zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2
db 2,2,2,2,2,2,2,2
endif
db 3,3,3,3,3,3,3,3
if zver=2
db zza2,zzfw,zzt1,zzt2,zzp1,zzp2,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
db zza2,zzfw,zzt2,zzt0,zzp2,zzp0,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
db zza2,zzfw,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
if zver=3
db zza2,zzfw,zzfw,zzfw,zzt1,zzt2,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;0
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
db zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal,zzal ;1
db zza2,zzfw,zzfw,zzfw,zzp0,zzp2,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
db zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe ;HIGH ESCAPE
db zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe,zzhe ;HIGH ESCAPE
db zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle ;LOW ESCAPE
db zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle,zzle ;LOW ESCAPE
db zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs ;FWORDS
db zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs,zzfs ;FWORDS


; Subroutines for dealing with specific Z-characters below
fwordsl = *-32
org $BF01
ds 96
fwordsh = *-32
ds 96


; Alphabet row 0 and 1 [11]
flagbit db 128,64,32,16,8,4,2,1
zzal = *-1
db 128,64,32,16,8,4,2,1
lda <pshift
db 128,64,32,16,8,4,2,1
sta <tshift
db 128,64,32,16,8,4,2,1
tya
clc
adc #59
jmp putcha0


; Alphabet row 2 (and spaces and carriage return) [10]
flagbic db 127,191,223,239,247,251,253,254
zza2 = *-1
db 127,191,223,239,247,251,253,254
lda <pshift
db 127,191,223,239,247,251,253,254
sta <tshift
db 127,191,223,239,247,251,253,254
lda alpha2,y
jmp putchar


; Escape character [5]
digit4h make_digit_table 10000,256,128
zzes = *-1
lda #$60
sta <tshift
rts


; High escape [17]
; Z-character-decoding assigning macro
zzhe = *-1
macro def_zchars
sty <chroff
if \#=1
asl <chroff
macset 2,4,\1
asl <chroff
else
asl <chroff
macset 2,4,\2
asl <chroff
endif
asl <chroff
macset 1,4,\1
lda #$80
macset 3,4,*
sta <tshift
macset 4,4,?B
rts
bank bank(zchad)
macgoto def_zchars_0
endm


; Low escape [10]
macro def_zchars_0
zzle = *-1
macset 5,4,\1=\2
lda <pshift
org zchad+\1
sta <tshift
db low(\3-1)
tya
if \3<$FE01
ora <chroff
fail "Z-character routine out of range"
jmp putchar
endif
if \3>$FF00
fail "Z-character routine out of range"
endif
macset 1,4,\1+1
macgoto def_zchars_\5
endm


; Temporary shift to row 0 [5]
macro def_zchars_1
zzt0 = *-1
bank \4
lda #$00
org \3
sta <tshift
endm
rts


; Temporary shift to row 1 [5]
; Instruction assigning macro
zzt1 = *-1
macro def_inst
lda #$20
macset 2,4,*
sta <tshift
macset 3,4,?B
rts
bank bank(instadl)
org instadl+(\1)
db low(\2-1)
org instadh+(\1)
db high(\2-1)
bank \3
org \2
endm


; Temporary shift to row 2 [5]
macro def_inst_2op
zzt2 = *-1
def_inst (\1)+$00
lda #$40
def_inst (\1)+$20
sta <tshift
def_inst (\1)+$40
rts
def_inst (\1)+$60
def_inst (\1)+$C0
endm


; Permament shift to row 0 [7]
macro def_inst_2op_eq
zzp0 = *-1
def_inst (\1)+$00
lda #$00
def_inst (\1)+$20
sta <tshift
def_inst (\1)+$40
sta <pshift
def_inst (\1)+$60
rts
endm


; Permament shift to row 1 [7]
macro def_inst_1op
zzp1 = *-1
def_inst (\1)+$00
lda #$20
def_inst (\1)+$10
sta <tshift
def_inst (\1)+$20
sta <pshift
endm
rts


; Permament shift to row 2 [7]
macro def_inst_0op
zzp2 = *-1
def_inst (\1)+$00
lda #$40
endm
sta <tshift
sta <pshift
rts


; Start fwords [17]
macro def_inst_ext
zzfw = *-1
def_inst (\1)+$00
sty <chroff
endm
asl <chroff
asl <chroff
asl <chroff
asl <chroff
asl <chroff
lda #$A0
sta <tshift
rts


; Print fwords [63]
; Fetch next byte of program
zzfs = *-1
; Doesn't affect carry flag and overflow flag
tya
macro fetch_pc
ora <chroff
inc $1010
sta <idxl
bne n\@
lda #0
inc $1020
sta <idxh
if large
lda #low(fwords-64)
bne n\@
sta <corel
inc <$0E
lda #high(fwords-64)
n\@ ld\1 <$0E
sta <coreh
\2 $5803,\1
lda <pshift
else
pha
n\@ \2 $5803
lda <pch
endif
pha
endm
lda <pcm
; (Bytes of above: 17)
pha
; (Cycles of above: 16 or 25 or 27)
lda <pcl
pha
jsr mget
asl a
sta <pcl
lda <byth
rol a
sta <pcm
lda #0
rol a
sta <pch
jsr putstr
pla
sta <pcl
pla
sta <pcm
pla
sta <pch
pla
sta <pshift
sta <tshift
rts


bank 18
; Initialization code
org $8000
reset ldx #0
 
stx $2000
; More reset initialization codes
stx $2001
reset1 bit $2002
; Wait for frame
vblw1 bit $2002
bit $2002
bpl vblw1
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
dex
inx
stx <$03 ; call stack pointer
vblw2 bit $2002
ldy #27
bpl vblw2
sty <$34 ; lines before <MORE>
; Zero some variables
ldy #$0F
lda #0
sty <$3A ; background
sta <mapad+1
sta <outrdy
sta <linrdy
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
stx $2007
stx $2007
sta $2007
stx <curspal
; Clear CIRAM
ldy #$20
ldy #$20
sty <lladh
sty <$3B ; foreground
sty $2006
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
sta $2006
tax
ldx #9
reset2 sta $2007
stx $2006
reset1 sta $2007
sta $2007
sta $2007
sta $2007
sta $2007
Line 694: Line 375:
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
sta $2007
sta $2007
ldy <$3B
sty $2007
sty $2007
sta $2007
sta $2007
sta $2007
sta $2007
sty $2007
sty $2007
sta $2007
sta $2007
sta $2007
sta $2007
sty $2007
sty $2007
sta $2007
sta $2007
sta $2007 ;16
sta $2007
sta $2007
sta $2007
sty $2007
sta $2007
sty $2007
sta $2007
; Check if F8 is pushed (erases save data)
sta $2007
ldx #5
sta $2007
stx $4016
sta $2007
dex
sta $2007
stx $4016
sta $2007
lda $4017
sta $2007
and #2
sta $2007
beq reset2
sta $2007
; Check battery
sta $2007
ldx #0
sta $2007
stx $1011
sta $2007
stx $1021
sta $2007 ;32
lda $5800
sta $2007
cmp #69
sta $2007
bne reset2
sta $2007
inc $1011
sta $2007
lda $5800
sta $2007
cmp #105
sta $2007
beq reset3
sta $2007
; No save file exists; try to create one
sta $2007
reset2 stx $1011
sta $2007
lda #69
sta $2007
sta $5800
sta $2007
inc $1011
sta $2007
lda #105
sta $2007
sta $5800
sta $2007
inc $1011
sta $2007
stx $5800
sta $2007 ;48
lda #$FF
sta $2007
sta $1022
sta $2007
; Initialize ARCFOUR table
sta $2007
reset2a txa
sta $2007
sta arcfour,x
sta $2007
sta $1012
sta $2007
sta $5800
sta $2007
inx
sta $2007
bne reset2a
sta $2007
; Copy header from ROM into RAM
sta $2007
stx $1021
sta $2007
reset2b stx $1011
sta $2007
lda $5805
sta $2007
sta $5803
sta $2007
sta $2007
sta $2007 ;64
inx
inx
bne reset2
bne reset2b
; Initialize variables
; Copy ROM starting from PURBOT into RAM
lda #low(start)
lda #high(purbot)
sta <pcl
sta $1021
lda #high(start)
lda #low(purbot)
sta <pcm
sta $1011
lda #(8*27)
reset2c lda $5805
sta <scrolly
sta $5803
lda #25
inc $1011
sta <linecnt
bne reset2c
; Begin program
inc $1021
jmp nxtinst
if large=0
 
if maxaddr<$FF00
; Instruction decoding table
lda <$21
opccnt = 236
cmp #high(maxaddr)+1
 
macro opcode
org opctab+(\1)
db high((\2)-1) ; Subtracting 1 so that RTS trick will be used
org opctab+(\1)+opccnt
db low((\2)-1)
if (\1)<$20
opcode (\1)+$20, \2
opcode (\1)+$40, \2
opcode (\1)+$60, \2
opcode (\1)+$C0, \2
endif
endif
if ((\1)>$7F)&((\1)<$90)
opcode (\1)+$10, \2
opcode (\1)+$20, \2
endif
endif
endmac
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


opctab ds opccnt*2
; *** RESTART
opcode 1, z_equal
def_inst_0op 183
opcode 2, z_less
zrest ldx #0
opcode 3, z_grtr
stx <$0E ; bit16 of program counter
opcode 4, z_dless
stx <$0D ; number of locals
opcode 5, z_igrtr
stx $1021
opcode 6, z_in
dex
opcode 7, z_btst
stx <$03 ; call stack pointer
opcode 8, z_bor
; Load data from 64 to PURBOT from ROM into RAM
opcode 9, z_band
lda #64
opcode 10, z_ftst
sta $1011
opcode 11, z_fset
zrest1 lda $5805
opcode 12, z_fclr
sta $5803
opcode 13, z_set
inc $1011
opcode 14, z_move
bne zrest1
opcode 15, z_get
inc $1021
opcode 16, z_getb
if purbot<$FF00
opcode 17, z_getp
lda <$21
opcode 18, z_getpt
cmp #high(purbot)+1
opcode 19, z_nextp
endif
opcode 20, z_add
bne zrest1
opcode 21, z_sub
; Initialize program counter
opcode 22, z_mul
lda #low(start-1)
opcode 23, z_div
sta <$10
opcode 24, z_mod
lda #high(start-1)
opcode 128, z_zero
sta $1020
opcode 129, z_next
jmp zcrlf
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
; *** USL
; [...W ...X ...Y ...Z]
def_inst_0op 188
multipl ;
; fall through


; Z*Z
; *** SPLIT
lda <op1l
def_inst_ext 234
and #$0F
; fall through
sta <r0
lda <op0l
asl a
asl a
asl a
asl a
sta <r3 ; used later
ora <r0
tax
lda multab,x
sta <r1


; Y*Z
; *** SCREEN
lda <op0l
def_inst_ext 235
and #$F0
; fall through
sta <r4 ; used later
ora <r0
tax
lda multabl,x
clc
adc <r1
sta <r1
lda multabr,x
adc #0
sta <byth


; X*Z
; *** NOOP
lda <op0h
def_inst_0op 180
asl a
; fall through
asl a
asl a
asl a
ora <r0
tax
lda multab,x
clc
adc <byth
sta <byth


; W*Z
; Decode the next instruction
lda <op0h
; For EXT instructions, number of operands is in the X register
and #$F0
nxtinst fetch_pc y,ldx
ora <r0
lda instadh,x
tax
pha
lda multabl,x
lda instadl,x
clc
pha
adc <byth
txa
sta <byth
bmi not2op


; Z*Y
; It is 2OP
lda <op1l
ldx #0
and #$F0
asl a
sta <r0
sta <4
lda <op0l
arr #$C0
and #$0F
fetch_pc y,lda
ora <r0
bcc is2op1
tax
jsr varop0
lda multabl,x
fetch_pc y,lda
clc
bvc is2op2
adc <r1
jmp is2op3
sta <r1
is2op1 stx <$21
lda multabr,x
sta <$11
adc <byth
bit <4
sta <byth
fetch_pc y,lda
bvc is2op3
is2op2 inx
jmp varop0
is2op3 stx <$22
sta <$12
rts


; Y*Y
; It isn't 2OP
lda <op0l
not2op cmp #192
lsr a
bcc notext
lsr a
lsr a
lsr a
ora <r0
tax
lda multab,x
clc
adc <byth
sta <byth


; X*Y
; It is EXT
lda <op0h
fetch_pc y,lda
and #$0F
ldx #0
ora <r0
isext0 sec
tax
rol a
lda multabl,x
bcs isext1
clc
bmi isext3
adc <byth
sta <byth


; Z*X
; Long immediate
lda <op1h
sta <4
and #$0F
fetch_pc y,lda
sta <r0
if smalend
ora <r3
sta <$11,x
tax
else
lda multab,x
sta <$21,x
clc
endif
adc <byth
fetch_pc y,lda
sta <byth
if smalend
sta <$21,x
else
sta <$11,x
endif
inx
lda <4
sec
rol a
jmp isext0


; Y*X
; Variable or no more operands
lda <r0
isext1 bpl isext2
ora <r4
tax
lda multabl,x
clc
adc <byth
sta <byth


; Z*W
; No more operands
lda <op0l
rts
and #$0F
sta <r0
lda <op1h
and #$F0
ora <r0
tax
lda multabl,x
clc
adc <byth
sta <byth


; Finished multiplication
; Variable
lda <r1
isext2 sta <4
jsr tostore
jsr varop
jmp nxtinst
inx
lda <4
sec
rol a
jmp isext0


bank 19
; 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


org $BD00
; It isn't EXT; it is 1OP or 0OP
; Muliplication table shifted right
notext asl a
;  0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
asl a
multabr db $0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0  ; 0
asl a
db $0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0  ; 1
bcs notext1
db $0,$0,$0,$0,$0,$0,$0,$0,$1,$1,$1,$1,$1,$1,$1,$1  ; 2
bpl notext2
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
; 1OP - short immediate
; Multiplication table shifted left
fetch_pc y,lda
;  0  1  2  3  4  5  6  7  8  9  A  B  C  D  E  F
ldx #0
multabl db $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00  ; 0
stx <$21
db $00,$10,$20,$30,$40,$50,$60,$70,$80,$90,$A0,$B0,$C0,$D0,$E0,$F0  ; 1
sta <$11
db $00,$20,$40,$60,$80,$A0,$C0,$E0,$00,$20,$40,$60,$80,$A0,$C0,$E0  ; 2
rts
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
notext1 bmi notext3
; 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
; 1OP - variable
org $C000
ldx #0
jmp varop


; Macro for object address (35 bytes)
; 1OP - long immediate
macro object_address
notext2 fetch_pc y,lda
lda #low(xobject+\2)
if smalend
sta <corel
sta <$11,x
lda #high(xobject+\2)
else
sta <coreh
sta <$21,x
lda #0
endif
sta <idxh
fetch_pc y,lda
sta <byth
if smalend
lda \1
sta <$21,x
asl a
else
rol <idxh
sta <$11,x
asl a
endif
rol <idxh
; fall through
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
; 0OP
putstr lda #0
notext3 rts
sta <pshift
sta <tshift
putstr1 jsr pcgetw
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


; Read a word from instruction pointer
zcall0 jmp val8
pcgetw jsr pcgetb
sta <byth
; falls through


; Read a byte from instruction pointer, write to A
; *** CALL
; (clobbers X, Y, and flags)
def_inst_ext 224
pcgetb ldy <pcl ; To use later
stx <4
lda <pch
lax <$11
bne pcgetbh ; In high memory; it is greater than 64K
ora <$21
; It is in core memory (always 64K in this program)
beq zcall0 ; calling function zero
lax <pcm
; Save to call stack
and #$1F
inc <callsp
ora #$60
ldy <callsp
sta <mapad
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
lsr a
beq zcall2
lsr a
clc
lsr a
adc <datasp
lsr a
tay
lsr a
zcall1 lda <locall,x
sta rambank
sta dstackl,y
lda [mapad],y
lda <localh,x
jmp pcinc
sta dstackh,y
pcgetbh ; 0000 0001 xxyy yyyy zzzz zzzz -> bank=1000 1xx0, mem=10yy yyyy
dey
lax <pcm
dex
and #$3F
bne zcall1
ora #$80
lda <$0D
sta <mapad
adc <datasp
txa
sta <datasp
lsr a
; Read function header (number of locals)
lsr a
zcall2 asl $1010
lsr a
lda <$21
lsr a
rol a
lsr a
sta $1020
and #$06
rol <$0E
ora #$88
ldy <$0E
sta rombank
lda $5803,y
lda [mapad],y
sta <$0D
pcinc inc <pcl
; Load initial values of locals
bne pcirts
beq zcall4
inc <pcm
; Load arguments
bne pcirts
ldx <4
inc <pch
dex
pcirts rts
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


; Deal with reading a register (as VALUE)
; *** RFALSE
; Register in A, result in <byth and A
def_inst_0op 177
fetch cmp #16
bcc fetch1
; Global variables
sta <idxl
lda #0
lda #0
sta <idxh
; fall through
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
fetch2 lda $1FF,x
sta <byth
lda $2FF,x
rts


; Deal with store (uses A and <byth as value; instruction as dest)
; Return a 8-bit value (from A)
; The value A will remain there once stored
ret8 pha
tostore pha
ldy <callsp
jsr pcgetb
dec <callsp
cmp #0
lda cstackx,y
bne dostore
sta <datasp
inc <dstkcnt
lda cstackl,y
; 'dostore' uses A as the register number, the the value on the stack
sta <$10
; and <byth. It also omits pushing to the stack (cf. SET, INC, DEC)
lda cstackm,y
dostore cmp #16
sta $1020
bcc store1
lda cstackh,y
; Global variables
lsr a
sta <idxl
sta <$0D
lda #0
sta <idxh
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
rol a
sta $1FF,x
anc #1
ldy <byth
sta <$0E
sty $2FF,x
; Restore locals
rts
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


; Calculate the current RAM bank and offset given <core* and <idx*
; Value of instruction is 8-bits (from A)
macro memory_address
val8 fetch_pc y,ldx
lda <corel
bne val8a
clc
; Push to stack
adc <idxl
inc <datasp
tay
ldy <datasp
lda <coreh
sta dstackl,y
adc <idxh
tax
and #$1F
ora #$60
sta <mapad
txa
txa
lsr a
sta dstackh,y
lsr a
jmp nxtinst
lsr a
val8a cpx #16
lsr a
bcs val8b
lsr a
; Local variable
sta rambank
sta <locall,x
endmac
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


; Implement GET/GETB
; Read the variable using as an instruction operand
; <corel=low addr, <coreh=high addr
; X is operand number (0-3)
; <idxl=low index, <idxh=high index
varop fetch_pc y,lda
; A=low data, <byth=high data
varop0 bne varop1
mget asl <idxl
; Pop from stack
rol <idxh
ldy <datasp
jsr mgetb
dec <datasp
sta <byth
lda dstackl,y
inc <idxl
sta <$11,x
bne mgetb
lda dstackh,y
inc <idxh
sta <$21,x
mgetb memory_address
lda [mapad],y
rts
rts
 
varop1 cmp #16
; Implment PUT/PUTB
bcs varop2
; <corel=low addr, <coreh=high addr
; Local variable
; <idxl=low index, <idxh=high index
tay
; A=low data, <byth=high data
lda locall,y
mput pha
sta <$11,x
mput1 asl <idxl
lda localh,y
rol <idxh
sta <$21,x
lda <byth
jsr mputb
sta <byth
inc <idxl
bne mputb
inc <idxh
pla
mputb pha
memory_address
pla
sta [mapad],y
rts
rts
 
; Global variable
; Figure out property table address of object A
varop2 tay
; Store ressults to <coreh and <corel
lda globadl,y
ptad sta <mapad
sta $1015
object_address <mapad,7
lda globadh,y
; Get high octet
sta $1025
jsr mgetb
lda $5801
pha
if smalend
; Increment object header address
sta <$11,x
inc <corel
else
if low(xobject+7)=255
sta <$21,x
inc <coreh
endif
inc $1015
if globodd
bne varop3
inc $1025
endif
varop3 lda $5801
if smalend
sta <$21,x
else
sta <$11,x
endif
endif
; Get low octet
lda $1020
jsr mgetb
; Store the results
sta <corel
pla
sta <coreh
rts
rts


; Flag address (<op0l is object, <op1l is flag, A is bit)
; *** RSTACK
flad object_address <op0l,0
def_inst_0op 184
lda <op1l
ldx <datasp
pha
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
lsr a
lsr a
sta <$0D
lsr a
sta <r0
lda <idxl
clc
adc <r0
sta <idxl
lda <idxh
adc #0
sta <idxh
pla
and #$07
beq flad2
tax
tax
lda #$80
rol a
flad1 lsr 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
dex
bne flad1
bne ret16a
flad2 rts
ret16b ; fall through


; Remove object (<op0l) from its current location
; Value of instruction is 16-bits (from $x4)
remobj object_address <op0l,4 ; obj.LOC
val16 lda <$14
jsr mgetb
fetch_pc y,ldx
beq flad2 ; rts if object is in nowhere
bne val16a
sta <r0
; Push to stack
; Remember and clear obj.NEXT
inc <datasp
inc <corel
ldy <datasp
if low(xobject+4)=255
sta dstackl,y
inc <coreh
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
endif
jsr mgetb
inc $1015
sta <r1
if globodd
lda #0
bne val16c
jsr mputb
inc $1025
; Is it the FIRST object?
endif
object_address <r0,6 ; obj.LOC.FIRST
val16c if smalend
jsr mgetb
lda <$24
cmp <op0l
endif
bne remobj1
sta $5801
; Yes! Set its new FIRST to the old NEXT of the removed object.
lda $1020
lda <r1
jmp nxtinst
jmp mputb
 
; No! Where is it in the chain?
; *** RTRUE
remobj1 object_address <r1,5 ; r1.NEXT
def_inst_0op 176
sta <r1
lda #1
cmp <op0l
jmp ret8
bne remobj1
 
; Found it
; *** EQUAL? (EXT)
lda <idxl
def_inst_ext 193
pha
lda <$11
lda <idxh
ldy <$21
pha
cmp <$12
object_address <r1,5
bne zequal1
jsr mgetb
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
tax
pla
arr #$C0
sta <idxh
bcs predic8
pla
 
sta <idxl
; If it should branch
txa
txa
jmp mputb
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


; Find a property address (<coreh and <corel) and size (A)
; *** GET
; Object is <op0l and property number is <op1l
def_inst_2op 15
pfind lda <op0l
lda <$12
jsr ptad
asl a
lda #0
rol <$22
sta <idxh
sta <idxl
; Skip the short description string
jsr mgetb
sec
rol a
bcc pfind1
inc <coreh
clc
clc
pfind1 adc <corel
adc <$11
sta <corel
sta $1011
bcc pfind2
lda <$22
inc <coreh
adc <$21
; Skip all properties until the one is found
sta $1021
pfind2 jsr mgetb
lda $5801
beq pfind3
if smalend
tax
sta <$14
and #$1F
else
cmp <op1l
sta <$24
beq pfind4
endif
txa
inc $1011
lsr a
bne zget1
lsr a
inc $1021
lsr a
zget1 ds 0
lsr a
lda $5801
lsr a
if smalend
sec
sta <$24
adc <corel
else
sta <corel
sta <$14
lda <coreh
endif
adc #0 ; won't pass 64K
bit $1020
sta <coreh
jmp val16
bcc pfind2
 
; Not found
; *** GETB
pfind3 sta <coreh
def_inst_2op 16
sta <corel
lda <$12
rts
; Found
pfind4 txa
lsr a
lsr a
lsr a
lsr a
lsr a
clc
clc
adc #1
adc <$11
rts
sta $1011
lda <$22
adc <$21
sta $1021
lda $5801
bit $1020
jmp val8


; Do the relative branching using offset in A and <op0h
; *** ADD
; If the value is 0 or 1, it returns instead of jumps
def_inst_2op 20
rjumppc ldx <op0h
clc
bne jumppc
lda <$11
cmp #2
adc <$12
bcs jumppc
sta <$14
stx <byth
lda <$21
jmp return
adc <$22
sta <$24
jmp val16


; Same as above but won't check for returns
; *** SUB
; (also, the continuation of the above)
def_inst_2op 21
jumppc sta <r0
lda <op0h
eor #$80 ; sign conversion
sta <r1
sec
sec
lda <pcl
lda <$11
sbc #$03 ; subtract one extra, since...
sbc <$12
sta <pcl
sta <$14
lda <pcm
lda <$21
sbc #$80
sbc <$22
sta <pcm
sta <$24
lda <pch
jmp val16
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
; *** BAND
; Condition is true if zero flag is set
def_inst_2op 9
branch php
lda <$11
jsr pcgetb
and <$12
sta <r0
sta <$14
pla
lda <$21
lsr a
and <$22
lsr a
sta <$24
ror a
jmp val16
eor <r0
bmi notjump ; condition flag does not match...
bit <r0
bvs branch1


; Long branch
; *** BOR
lda <r0
def_inst_2op 8
asl a
lda <$11
asl a
ora <$12
asl a
sta <$14
php
lda <$21
php
ora <$22
ror a
sta <$24
plp
jmp val16
ror a
plp
ror a
sta <op0h
jsr pcgetb
jmp rjumppc


; Short branch
; *** BCOM
branch1 lda #0
def_inst_1op 143
sta <op0h
lda <$11
lda <r0
eor #$FF
and #$3F
sta <$14
jmp rjumppc
lda <$21
eor #$FF
sta <$24
jmp val16


; Not branching
; *** BTST
notjump bit <r0
def_inst_2op 7
bvs nxtinst
lda <$11
jsr pcgetb
and <$12
jmp nxtinst
eor <$12
sta <4
lda <$21
and <$22
eor <$22
ora <4
bne zbtst1
jmp predic1
zbtst1 jmp fpredic


; Return from a subroutine
; *** MUL
return dec <dstkcnt
def_inst_2op 22
ldy <dstkcnt
lax <$11
ldx $700,y
clc
stx <cstkcnt
adc <$12
ldx $400,y
bcc zmul1
stx <pcl
eor #255
ldx $500,y
adc #0
stx <pcm
zmul1 tay
ldx $600,y
txa
stx <pch
sec
jsr tostore
sbc <$12
; fall through
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


; Next instruction operation
; *** PUSH
nxtinst jsr pcgetb
def_inst_ext 232
sta <r0
inc <datasp
bit <r0
ldx <datasp
bmi nxtins1
lda <$11
sta dstackl,x
lda <$21
sta dstackh,x
jmp nxtinst


; 2OP form
; *** POP
sta <r1
def_inst_ext 233
lsr <r1
ldx <datasp
asl a
dec <datasp
and #$80
lda dstackl,x
ora <r1
sta <$12
and #$90
lda dstackh,x
ora <r0
sta <$22
eor #$60
ldx <$11
ora #$0F
jsr xstore
bne nxtins3
jmp nxtinst


nxtins1 bvs nxtins2
; *** FSTACK
def_inst_0op 185
dec <datasp
jmp nxtinst


; 1OP or 0OP form
; *** SET
rol a
def_inst_2op 13
rol a
lda <$12
ora #$3F
sta <$14
bne nxtins3
lda <$22
sta <$24
ldx <$11
jsr xstore
jmp nxtinst


; EXT form
; *** VALUE
nxtins2 jsr pcgetb
def_inst_1op 142
ldx <$11
jsr xvalue
jmp val16


; Read operands and call function (using RTS trick)
; *** INC
nxtins3 eor #$FF
def_inst_1op 133
sta <argtyp
ldx <$11
sta <r1
jsr xvalue
ldx <r0
inc <$14
romsel opctab
bne zinc1
lda opctab,x ; high byte of address
inc <$24
pha
zinc1 jsr xstore
lda opctab+opccnt,x ; low byte of address
jmp nxtinst
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
; *** DEC
getopr ldx <r2
def_inst_1op 134
inx
ldx <$11
inx
jsr xvalue
stx <r2
ldy <$14
bit <r1
dey
bvs getopr1 ;bit0=0
sty <$14
bmi getopr2 ;bit1=0
cpy #255
bne zinc1
dec <$24
jsr xstore
jmp nxtinst


; [11] No operand
; Store value from <$x4 into variable labeled X
getopr0 asl <r1
xstore lda <$14
asl <r1
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


getopr1 bmi getopr3 ;bit1=0
; 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


; [10] Variable
; *** IN?
jsr pcgetb
def_inst_2op 6
tay
ldx <$11
jsr fetch
clc
cpy #0 ; popped from stack
lda objadl,x
bne getopr4
adc #4
dec <dstkcnt
sta $5010
jmp getopr4
lda objadh,x
adc #0
sta $5020
lda $5801
bit $1020
eor <$21
bne zin1
jmp predic1
zin1 jmp fpredic


; [01] Short immediate
; *** FSET?
getopr2 jsr pcgetb
def_inst_2op 10
ldx <r2
ldx <$11
sta <0,x
ldy <$12
lda #0
clc
sta <1,x
lda objadl,x
beq getopr0
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


; [00] Long immediate
; *** FSET
getopr3 jsr pcgetw
def_inst_2op 11
getopr4 ldx <r2
ldx <$11
sta <0,x
ldy <$12
lda <byth
clc
sta <1,x
lda objadl,x
jmp getopr0
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


; Z-code instructions
; *** FIRST?
; Set the zero flag for condition true, clear otherwise
def_inst_1op 130
; <byth and A store the value to store to memory
ldx <$11
 
clc
; [1] EQUAL? data,cmp1[,cmp2][,cmp3] /PRED
lda objadl,x
z_equal lda <op0l
adc #6
cmp <op1l
sta $5010
bne z1equal
lda objadh,x
lda <op0h
adc #0
cmp <op1h
sta $5020
bne z1equal
lda $5801
z0equal jmp branch
bit $1020
z1equal lda #$0F
jmp valp
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
; *** NEXT?
z_dless lda <op0l
def_inst_1op 129
jsr fetch
ldx <$11
clc
clc
sbc #0
lda objadl,x
sta <op0l
adc #5
pha
sta $5010
bcs z1dless
lda objadh,x
dec <byth
adc #0
z1dless lda <byth
sta $5020
sta <op0h
lda $5801
lda <op0l
bit $1020
jsr dostore
; fall through
; fall through


; [2] LESS? int1,int2 /PRED
; Value of instruction is 8-bits (from A)
z_less lda <op0h
; Predicate is then if value is nonzero
eor #$80 ; do sign conversion
valp fetch_pc y,ldx
sta <op0h
bne valpa
lda <op1h
; Push to stack
eor #$80
inc <datasp
cmp <op0h
ldy <datasp
bne z1less
sta dstackl,y
lda <op0l
sta <4
cmp <op1l
txa
z1less lda #0
sta dstackh,y
adc #0 ; convert carry flag clear to zero flag set
lda <4
jmp branch
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


; [5] IGRTR? var,int /PRED
; Macro to do one step of ARCFOUR
z_dless lda <op0l
; Result is stored in accumulator
jsr fetch
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
sec
adc #0
adc #0
sta <op0l
sta <$14
pha
zrand6 lda #0
bcc z1dless
adc <$24
inc <byth
sta <$24
z1dless lda <byth
jmp val16
sta <op0h
 
lda <op0l
; *** JUMP
jsr dostore
def_inst_1op 140
; fall through
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


; [3] GRTR? int1,int2 /PRED
; Macro to find a property, given object and property number
z_grtr lda <op1h
; Object in <$11, property in <$12, branch to \1 if found
eor #$80 ; do sign conversion
; If \1 is with # at front then assume always will be found
sta <op1h
; X contains property size only in high 3-bits if found
lda <op0h
; X contains property number if not found
eor #$80
; Output is $1014 and $1024 with address of property id
cmp <op1h
macro propfind
bne z1grtr
; Find the property table
lda <op1l
ldx <$11
cmp <op0l
clc
z1grtr lda #0
lda objadl,x
adc #0 ; convert carry flag clear to zero flag set
adc #7
jmp branch
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


; [6] IN? obj1,obj2 /PRED
; *** GETPT
z_in object_address <op0l,4
def_inst_2op 18
jsr mgetb
propfind zgetpt1
cmp <op1l
lda $1020
jmp branch
and #0
jmp val8
zgetpt1 lda $1020
inc <$14
bne zgetpt2
inc <$24
zgetpt2 jmp val16


; [7] BTST data,mask /PRED
; *** GETP
z_btst lda <op0h
def_inst_2op 17
and <op1h
propfind zgetp2
eor <op1h
; Use default value
beq z1btst
asl <$11
jmp branch
rol <$21 ;clears carry
z1btst lda <op0l
lda #low(object-2)
and <op1l
adc <$11
eor <op1l
sta $1015
jmp branch
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


; [8] BOR int1,int2 /VAL
; *** PUTP
z_bor lda <op0h
def_inst_ext 227
ora <op1h
propfind #
sta <byth
inc $1014
lda <op0l
bne zputp2
ora <op1l
inc $1024
jsr tostore
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
jmp nxtinst


; [9] BAND int1,int2 /VAL
; *** NEXTP
z_band lda <op0h
def_inst_2op 19
and <op1h
ldx <$11
sta <byth
bne znextp4
lda <op0l
; Find first property
and <op1l
clc
jsr tostore
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
jmp nxtinst


; [10] FSET? obj,flag /PRED
; Print a space
z_ftst jsr flad
space lda <$30
sta <r0
cmp #$E2
jsr mgetb
bne space1
eor #$FF
lda <$31
and <r0
and #$1F
jmp branch
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


; [11] FSET obj,flag
; Skip to the next line
z_fset jsr flad
addline sec
sta <r0
addlin1 lda <$33
jsr mgetb
adc #7
ora <r0
sta <$33
jsr mputb
cmp #$F0
jmp nxtinst
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


; [12] FCLEAR obj,flag
; Display the <MORE> prompt
z_fclr jsr flad
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
eor #$FF
sta <r0
bne more2
jsr mgetb
dey
and <r0
bne more3
jsr mputb
; Wait for space-bar pushed
jmp nxtinst
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


; [13] SET var,value
; *** PRINTC
z_set lda <op1l
def_inst_ext 229
pha
lda <$11
lda <op1h
beq zprntc2
sta <byth
cmp #32
lda <op0l
beq zprntc1
jsr dostore
cmp #13
beq zcrlf
ldx <$30
beq zprntc2
sta <0,x
inc <$30
zprntc1 jmp nxtinst
zprntc2 jsr space
jmp nxtinst
jmp nxtinst


; [137] REMOVE obj
; *** CRLF
z_remov lda #0
def_inst_0op 187
sta <op1l
zcrlf jsr bufout
beq z_move
lda <$31
; keep with next
ora #$1F
sta <$31
zcrlf2 jmp nxtinst


; [14] MOVE object,container
; *** PRINTN
; Clear NEXT of object
def_inst_ext 230
z1move inc <corel
lda <$30
if low(xobject+4)=255
beq zcrlf2 ; ensure there is room in the buffer
inc <coreh
ldy <$11
endif
lax <$21
jsr mputb ; accumulator is already zero
anc #$FF
jmp nxtinst
bcc znum01
; Remove object from its current location
eor #$FF
z_move jsr remobj
sta <4
; Set LOC of object
ldx <$30
object_address <op0l,4
inc <$30
lda <op1l
lda #'-'
jsr mputb
sta <0,x
tax
tya
beq z1move
eor #$FF
; Remember object address
tay
lda <idxl
ldx <4
sta <r0
znum01 lda digit0l,y
lda <idxh
adc digit0h,x
sta <r1
pha
; Get FIRST of container
cmp #10
object_address <op1l,6
lda digit1l,y
jsr mgetb
adc digit1h,x
pha
pha
; Remember container address
cmp #10
lda <idxl
lda digit2l,y
adc digit2h,x
pha
pha
lda <idxh
cmp #10
lda #0
adc digit3h,x
pha
pha
; Set NEXT of object
cmp #10
lda <r0
lda #0
sta <idxl
adc digit4h,x
clc
ldx <$30
sbc #0 ; subtract one so it points to NEXT instead of FIRST
tay ; make the flag according to accumulator
lda <r1
beq znum02
sbc #0
; Five digits
sta <idxh
sta <0,x
pla
sta 1,x
pla
pla
jsr mputb
sta 2,x
; Set FIRST of container
pla
pla
sta <idxh
sta 3,x
pla
pla
sta <idxl
sta 4,x
lda <op0l
txa
jsr mputb
axs #-5
stx <$30
jmp nxtinst
jmp nxtinst
 
znum02 pla
; [15] GET table,item /VAL
beq znum03
z_get lda <op0l
; Four digits
sta <corel
sta <0,x
lda <op0h
pla
sta <coreh
sta 1,x
lda <op1l
pla
sta <idxl
sta 2,x
lda <op1h
pla
sta <idxh
sta 3,x
jsr mget
txa
jsr tostore
axs #-4
stx <$30
jmp nxtinst
jmp nxtinst
 
znum03 pla
; [16] GETB table,item /VAL
beq znum04
z_getb lda #0
; Three digits
sta <byth
sta <0,x
lda <op0l
pla
sta <corel
sta 1,x
lda <op0h
pla
sta <coreh
sta 2,x
lda <op1l
txa
sta <idxl
axs #-3
lda <op1h
stx <$30
sta <idxh
jsr mgetb
jsr tostore
jmp nxtinst
jmp nxtinst
 
znum04 pla
; [17] GETP obj,prop /VAL
beq znum05
z_getp jsr pfind
; Two digits
beq z1getp
sta <0,x
inc <idxl
inx
lsr a
pla
bcc z2getp
sta <0,x
; Byte
inx
jsr mgetb
stx <$30
jsr tostore
jmp nxtinst
jmp nxtinst
; Use default value
znum05 pla
z1getp lda #high(object-2)
; One digit
sta <coreh
sta <0,x
lda #low(object-2)
inc <$30
sta <corel
lda <op1l
sta <idxl
; Word
z2getp jsr mget
jsr tostore
jmp nxtinst
jmp nxtinst


; [18] GETPT obj,prop /VAL
; *** PRINTI
z_getpt jsr pfind
def_inst_0op 178
lda <coreh
jsr textpc
sta <byth
lda <corel
jsr tostore
jmp nxtinst
jmp nxtinst


; [19] NEXTP obj,prop /VAL
; *** PRINTR
z_nextp lda <op1l
def_inst_0op 179
beq z1nextp
jsr textpc
jsr pfind
jsr bufout
adc #1
lda <$31
sta <idxl
ora #$1F
jsr mgetb
sta <$31
jmp z2nextp
lda #1
; Request first property
jmp ret8
z1nextp lda <op0l
 
jsr ptad
; *** PRINTB
jsr mgetb
def_inst_1op 135
sta <idxl
jsr textba
lda #0
sta <idxh
jsr mget
z2nextp and #$1F
ldx #0
stx <byth
jsr tostore
jmp nxtinst
jmp nxtinst


; [20] ADD int1,int2 /VAL
; *** PRINT
z_add clc
def_inst_1op 141
lda <op0l
asl <$11
adc <op1l
rol <$21
pha
lda #0
lda <op0h
rol a
adc <op1h
sta <$36
sta <byth
jsr textwa
pla
jsr tostore
jmp nxtinst
jmp nxtinst


; [21] SUB int1,int2 /VAL
; *** PRINTD
z_sub sec
def_inst_1op 138
lda <op0l
ldx <$11
sbc <op1l
clc
pha
lda objadl,x
lda <op0h
adc #7
sbc <op1h
sta $1012
sta <byth
lda objadh,x
pla
adc #0
jsr tostore
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
jmp nxtinst


; [22] MUL int1,int2 /VAL
; *** VERIFY
z_mul bankjump multipl
def_inst_0op 189
jmp tpredic ; there is no disk, so just assume it is OK


; [128] ZERO? value /PRED
; *** QUIT
z_zero lda <op0l
def_inst_0op 186
ora <op0h
jsr bufout
jmp branch
lda <$31
ora #$1F
sta <$31
jsr bufout
zquit jmp zquit


; [129] NEXT? obj /VAL/PRED
; *** READ
z_next object_address <op0l,5
jsr bufout
jsr mgetb
;TODO
jsr tostore
zread jmp zread
tax
php
pla
and #$02 ; now zero flag is toggled
jmp branch


; [130] FIRST? obj /VAL/PRED
bank intbank+3
z_first object_address <op0l,6
; Z-character decoding
jsr mgetb
; high 3-bits = state, low 5-bits = value
jsr tostore
tax
php
pla
and #$02 ; now zero flag is toggled
jmp branch


; [131] LOC obj /VAL
org $F100-12
z_loc object_address <op0l,4
; Text starting from program counter
jsr mgetb
textpc lda #0
jsr tostore
sta <$38
jmp nxtinst
sta <$27
ldx #$A0
stx <$09
stx <$0A


; [132] PTSIZE ptr /VAL
org $F100
z_ptsiz lda #$FF
lda <$27
sta <idxl
bmi textpc1
sta <idxh
lda #$F2
lda <op0l
sta <$39
sta <corel
lda #$FE
lda <op0h
pha
sta <coreh
fetch_pc y,lda
jsr mgetb
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
lsr a
anc #31
lsr a
ora <$09
lsr a
tax
sec
lda zchad,x
adc #0
pha
jsr tostore
textpc1 rts
jmp nxtinst


; [133] INC var
org $F200
z_inc lda <op0l
lda #$FE
jsr fetch
pha
sec
inc <$39
adc #0
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
pha
bcc zincdec
rts
inc <byth
zincdec lda <op0l
jsr dostore
jmp nxtinst
; keep with next


; [134] DEC var
org $F300
z_dec lda <op0l
lda #$F1
jsr fetch
sta <$39
clc
lda #$FE
sbc #0
pha
lda <$17
anc #31
ora <$09
tax
lda zchad,x
pha
pha
bcs zincdec
rts
dec <byth ; does not affect the carry flag
bcc zincdec


; [138] PRINTD obj
org $F400-12
z_prntd lda <op0l
; Text from byte address
jsr ptad
textba lda #0
inc <corel ; skip length byte
sta <$38
bne z1prntb
sta <$27
inc <coreh ; going past 64K is not allowed
ldx #$A0
bne z1prntb
stx <$09
; keep with next
stx <$0A


; [135] PRINTB ptr
org $F400
z_prntb lda <op0l
lda <$27
sta <corel
bmi textba1
lda <op0h
lda #$F5
sta <coreh
sta <$39
z1prntb lda <pcl
lda #$FE
pha
pha
lda <pcm
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
pha
lda <pch
rts
textba1 bit $1020
rts
 
org $F500
lda #$FE
pha
pha
lda #0
inc <$39
sta <pch
ldx <$17
lda <corel
stx <4
sta <pcl
lda <$27
lda <coreh
asl <4
sta <pcm
rol a
jsr putstr
asl <4
pla
rol a
sta <pch
asl <4
pla
rol a
sta <pcm
anc #31
pla
ora <$09
sta <pcl
tax
jmp nxtinst
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


; [139] RETURN value
org $F700-12
z_ret lda <op0h
; Text from word address (aligned)
sta <byth
textwa lda #0
lda <op0l
sta <$38
jmp return
sta <$27
ldx #$A0
stx <$09
stx <$0A


; [140] JUMP offset
org $F700
z_jump lda <op0l
lda <$27
jmp jumppc
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


; [141] PRINT str
org $F800
z_print lda <pcl
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
pha
lda <pcm
rts
 
org $F900
lda #$F7
sta <$39
lda #$FE
pha
pha
lda <pch
lda <$17
anc #31
ora <$09
tax
lda zchad,x
pha
pha
lda #0
rts
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
org $FA00-20
z_bcom lda <op0h
; Text from frequent word
eor #$FF
textfw lda #0
sta <byth
sta <$38
lda <op0l
sta <$29
eor #$FF
lda <$0A
jsr tostore
sta <$0B
jmp nxtinst
ldx #$A0
stx <$09
stx <$0A
lda <$39
sta <$35


; [142] VALUE var /VAL
org $FA00
z_value lda <op0l
lda <$29
jsr fetch
bmi textfw1
z1value jsr tostore
lda #$FB
jmp nxtinst
sta <$39
; keep with next
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]


; [224] CALL fcn[,arg1][,arg2][,arg3] /VAL
org $FB00
z_call lda #0
lda #$FE
cmp <op0l
pha
bne z1call
inc <$39
sta <byth
ldx <$19
cmp <op0h
stx <4
beq z1value
lda <$29
z1call ldx <cstkcnt
asl <4
lda <pcl
rol a
sta $400,x
asl <4
lda <pcm
rol a
sta $500,x
asl <4
lda <pch
rol a
sta $600,x
anc #31
lda <dstkcnt
ora <$09
sta <r2 ; remember bottom of local stack frame
tax
sta $700,x
lda zchad,x
inc <cstkcnt
pha
lsr <pch
rts
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)
org $FC00
z_prntr jsr putstr
lda #$FA
lda #13
sta <$39
bankcall putchar
lda #$FE
; fall through
pha
lda <$19
anc #31
ora <$09
tax
lda zchad,x
pha
rts


; [176] RTRUE
; States can be:
z_rtrue lda #0
;  0   = Second step of ASCII escape
sta <byth
;  1-3 = Fwords
lda #1
;  4  = First step of ASCII escape
jmp return
;  5-7 = Shift states 0,1,2


z_rfals ; [177] RFALSE
; These subroutines are entered with X set to the state.
lda #0
; Also has carry flag cleared.
sta <byth
org $FE01
jmp return


; [178] PRINTI (str)
; ** Emit a space
z_prnti jsr putstr
def_zchars $A0
jmp nxtinst
def_zchars $C0
def_zchars $E0
zch32 jsr space
jmp [$38]


; [180] NOOP
; ** Second escape
z_noop = nxtinst
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]


; [181] SAVE /PRED
; ** First escape
z_save lda #1 ; clear the zero flag (SAVE/RESTORE aren't implemented)
def_zchars $80,$9F
jmp branch
txa
asl a
asl a
asl a
asl a
asl a
sta <5
anc #0
sta <$09
jmp [$38]


; [182] RESTORE /PRED
; ** Frequent words
z_rstor = z_save
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


; [183] RESTART
; ** Begin escape
z_rest = reset
def_zchars $E6
lda #$80
sta <$09
jmp [$38]


; [184] RSTACK
; ** Direct character code
z_rstac lda #0
def_zchars $A6,$BF
jsr fetch
def_zchars $C6,$DF
dec <dstkcnt
def_zchars $E8,$FF
jmp return
ldy <$30
beq zch1
stx <$E0,y
inc <$30
zch1 lda <$0A
sta <$09
jmp [$38]


; [189] VERIFY /PRED
; ** Emit a line break
z_vrfy lda #0 ; just fake it for now
def_zchars $E7
jmp branch
zch13 jsr bufout
lda <$31
ora #$1F
sta <$31
lda <$0A
sta <$09
jmp [$38]


; [233] POP var
; ** Begin frequent words state 0-31
z_pop ldx <dstkcnt
def_zchars $A1
jsr fetch2
def_zchars $C1
pha
def_zchars $E1
lda <op0l
lda #$20
jsr dostore
sta <$09
; fall through
jmp [$38]


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


; [186] QUIT
; ** Begin frequent words state 64-95
z_quit jmp z_quit ; just wait forever for the player to push RESET
def_zchars $A3
def_zchars $C3
def_zchars $E3
lda #$60
sta <$09
jmp [$38]


; [225] PUT table,item,data
; ** Temporary shift 1
z_put lda <op0l
def_zchars $A4
sta <corel
lda #$C0
lda <op0h
sta <$09
sta <coreh
jmp [$38]
lda <op1l
sta <idxl
lda <op1h
sta <idxh
lda <op2h
sta <byth
lda <op2l
jsr mput
jmp nxtinst


; [226] PUTB table,item,data
; ** Temporary shift 2
z_putb lda <op0l
def_zchars $A5
sta <corel
lda #$E0
lda <op0h
sta <$09
sta <coreh
jmp [$38]
lda <op1l
sta <idxl
lda <op1h
sta <idxh
lda <op2l
jsr mputb
jmp nxtinst


; [227] PUTP obj,prop,value
; ** Permanent shift 1 or 2
z_putp jsr pfind
def_zchars $C4
inc <idxl
def_zchars $E5
lsr a
and #$F0
lda <op2h
sta <$0A
sta <byth
jmp [$38]
lda <op2l
bcc z1putp
; Byte
jsr mputb
jmp nxtinst
; Word
z1getp jsr mput
jmp nxtinst


; [187] CRLF
; ** Permanent shift 0
z_crlf lda #13
def_zchars $C5
bne z1prntc
def_zchars $E4
; keep with next
lda #$A0
sta <$09
sta <$0A
jmp [$38]


; [229] PRINTC char
; Reset vector
z_prntc lda <op0l
bank intbank+3
z1prntc bankcall putchar
org $FFFA
jmp nxtinst
dw 0,reset,0


; [230] PRINTN int
; Pattern tables
z_prntn bankjump printn
bank intbank+4
org $0000
incbin "pc.chr"


; [232] PUSH value
; Cursor icon
z_push inc <dstkcnt
org $07F0
lda <op0l
defchr $00000000, \
pha
      $03030300, \
lda <op0h
      $00303030, \
sta <byth
      $03030300, \
lda #0
      $00303030, \
jsr dostore
      $03030300, \
jmp nxtinst
      $00303030, \
      $00000000


; [234] SPLIT lines
; Postprocessor
z_split = nxtinst
emu


; [235] SCREEN window
org $0000
z_scrn = nxtinst
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


bank 31
org $8000
org $FE00
cld


; Initialize CPU/APU/PPU at reset
; Make duplicates of ASCII characters as Z-characters
reset ldx #$40
lda #1
stx $4017 ; Disable APU frame IRQ
sta $200D
ldx #$FF
lda #0
txs
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
inx
stx $2000
bne pp1
stx $2001
stx $4010


; Initialize MMC5 to act like User:Zzo38/Mapper_D
; Make duplicate of digits for use with PRINTN
stx $5101
ldx #0
stx $5200
stx $200E
stx $5204
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
inx
stx $5100
cpx #32
stx $5102
bne pp2
inx
 
stx $5103
; Finished
lda #$44 ; horizontal arrangement
hlt
sta $5105
 
org $FFFC
dw $8000


; Copy ROM to RAM
code
ldx #0
bank intbank+4
stx rambank
</pre>
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
== C program ==
bankjump reset1
This program is generating a stub file and story ROM for its use.
<pre>
/*
  This file is part of Famizork II and is in the public domain.
*/


; Copy 16K of ROM to RAM
#include <stdio.h>
rrcp16 lda #$7F
#include <stdlib.h>
sta <r2
#include <string.h>
jsr rrcopy
; fall through


; Copy 8K of ROM to RAM
static FILE*fp;
rrcopy lda <r4
static int c;
and #$80
static int d;
sta rombank
static int gamesize;
inc <r4
static char endian;
rrcopy1 inc <r0
static unsigned char mem[0x20000];
inc <r2
static char buf[256];
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
#define OUTHEADER(x,y) fprintf(fp,"%s\t= %u\n",x,(mem[y*2+endian]<<8)|mem[y*2+1-endian])
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
int main(int argc,char**argv) {
bank 32
  if(argc<2) return 1;
incbin "chicago_oblique.chr"
  fp=fopen(argv[1],"rb");
incbin "chicago_inverse.chr"
  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;
}
</pre>
</pre>

Revision as of 04:45, 1 November 2015

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 does not yet work.

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;
}
Retrieved from "https://www.nesdev.org/w/index.php?title=User:Zzo38/Famicom_Z-machine&oldid=16919"