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

From Nesdev wiki
Jump to navigationJump to search
(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;
}