User:Zzo38/Famicom Z-machine
From NESdev Wiki
Jump to navigationJump to search
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. 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.
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.
Opcode Status 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 X GETPT X NEXTP X ADD OK SUB OK MUL X 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 X CALL OK PUT OK PUTB OK PUTP X 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)
; Z-machine interpreter (Z-code versions 1 to 3) for Famicom ; version 0.0 ; Public domain inesmap 5 ; MMC5 or "User:Zzo38/Mapper D" inesmir 1 ; Horizontal arrangement 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: ; zver: Z-machine version number. ; bytswap: Defined for small endian, undefined for big endian ; 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 xglobal = global-32 ; Offset for global variables xvocab = vocab+sibcnt+4 ; Actual start of vocab ; Low RAM usage: ; $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 nr0 ds 1 ; Temporary registers for NMI routine nr1 ds 1 nr2 ds 1 nr3 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: ; Bank = ((A>>13)|128)&254 ; Address = (A&$3FFF)|$8000 ; Mapping RAM address: ; Bank = A>>13 ; Address = (A&$1FFF)|$6000 macro romsel lda #128|bank(\1)&254 sta rombank endmac macro bankcall ldy #128|bank(\1)&254 sty rombank jsr \1 endmac macro bankjump ldy #128|bank(\1)&254 sty rombank jmp \1 endmac code bank 16 org $8000 ; Alphabet table row 2 if zver=1 alpha2 db 32, 13, "*****0123456789.,!?_#'", 34, "/", 92, "<-:()" else alpha2 db " ******", 13, "0123456789.,!?_#'", 34, "/", 92, "-:()" endif ; Keyboard decoding table (lowercase is necessary) kbdt db "][", 13, 0, 0, 92, 15, 0 db ";:@", 0, "^-/_" db "klo", 0, "0p,." db "jui", 0, "89nm" 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 sendout inc <outrdy ;TODO lda #0 sta <bufptr pla rti ; Send a line feed sendlf inc <linrdy lda #1 sta <cursx ;TODO pla rti ; Ready the output buffer for dumping to the screen ; 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 ; Wait for NMI routine to clear the flag lfodump dec <outrdy lfdump dec <linrdy lfdump1 bit <linrdy bvs lfdump1 lfdump2 rts ; Print a character putchar cmp #0 beq lfdump2 ; outputting ASCII code 0 has no effect cmp #13 beq lfodump ; output the buffer and a line break cmp #32 beq endword ; output a word and a space putcha0 ldx <cursx cpx #31 bcc putcha1 jsr lfdump putcha1 ldx <bufptr sta <outbuf,x inc <bufptr rts endword jsr outdump cpx #31 bcs lfdump bcc putcha1 ; Print a signed 16-bit integer (<op0h,<op0l), then nxtinst printn lda <op0h bit #$80 beq printn1 ; 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 digpair tay lda divten,y bne digpai1 bcc digpai2 digpai1 ora #$30 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 putzch and #$1F tay ora <tshift tax lda #$BF pha lda zchlut,x pha rts bank 17 ; Myriads of 256 times value (up to 128 only) org $B87F myr256 db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0; db 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0; 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 org $B900 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 org $BA00 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 org $BB00 ht256 db 0,2,5,7,10,12,15,17,20,23,25,28,30,33,35,38,40,43,46,48; db 51,53,56,58,61,64,66,69,71,74,76,79,81,84,87,89,92,94,97,99; db 2,4,7,10,12,15,17,20,22,25,28,30,33,35,38,40,43,45,48,51; db 53,56,58,61,63,66,68,71,74,76,79,81,84,86,89,92,94,97,99,2; db 4,7,9,12,15,17,20,22,25,27,30,32,35,38,40,43,45,48,50,53; 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 org $BC00 divten db 0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1 db 2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3 db 4,4,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5 db 6,6,6,6,6,6,6,6,6,6,7,7,7,7,7,7,7,7,7,7 db 8,8,8,8,8,8,8,8,8,8,9,9,9,9,9,9,9,9,9,9 db 10,10,10,10,10,10,10,10,10,10,11,11,11,11,11,11,11,11,11,11 db 12,12,12,12,12,12,12,12,12,12,13,13,13,13,13,13,13,13,13,13 db 14,14,14,14,14,14,14,14,14,14,15,15,15,15,15,15,15,15,15,15 db 16,16,16,16,16,16,16,16,16,16,17,17,17,17,17,17,17,17,17,17 db 18,18,18,18,18,18,18,18,18,18,19,19,19,19,19,19,19,19,19,19 db 20,20,20,20,20,20,20,20,20,20,21,21,21,21,21,21,21,21,21,21 db 22,22,22,22,22,22,22,22,22,22,23,23,23,23,23,23,23,23,23,23 db 24,24,24,24,24,24,24,24,24,24,25,25,25,25,25,25 ; Modulo by ten 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 org $BE00 zchlut ; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ; 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 if zver=1 db zza2,zza2,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,zza2,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,zza2,zzt0,zzt1,zzp0,zzp1,zzes,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2 db zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2,zza2 ;2 endif 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 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 org $BF01 ; Alphabet row 0 and 1 [11] zzal = *-1 lda <pshift sta <tshift tya clc adc #59 jmp putcha0 ; Alphabet row 2 (and spaces and carriage return) [10] zza2 = *-1 lda <pshift sta <tshift lda alpha2,y jmp putchar ; Escape character [5] zzes = *-1 lda #$60 sta <tshift rts ; High escape [17] zzhe = *-1 sty <chroff asl <chroff asl <chroff asl <chroff asl <chroff asl <chroff lda #$80 sta <tshift rts ; Low escape [10] zzle = *-1 lda <pshift sta <tshift tya ora <chroff jmp putchar ; Temporary shift to row 0 [5] zzt0 = *-1 lda #$00 sta <tshift rts ; Temporary shift to row 1 [5] zzt1 = *-1 lda #$20 sta <tshift rts ; Temporary shift to row 2 [5] zzt2 = *-1 lda #$40 sta <tshift rts ; Permament shift to row 0 [7] zzp0 = *-1 lda #$00 sta <tshift sta <pshift rts ; Permament shift to row 1 [7] zzp1 = *-1 lda #$20 sta <tshift sta <pshift rts ; Permament shift to row 2 [7] zzp2 = *-1 lda #$40 sta <tshift sta <pshift rts ; Start fwords [17] zzfw = *-1 sty <chroff asl <chroff asl <chroff asl <chroff asl <chroff asl <chroff lda #$A0 sta <tshift rts ; Print fwords [63] zzfs = *-1 tya ora <chroff sta <idxl lda #0 sta <idxh lda #low(fwords-64) sta <corel lda #high(fwords-64) sta <coreh lda <pshift pha lda <pch pha lda <pcm pha 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 org $8000 ; More reset initialization codes reset1 bit $2002 vblw1 bit $2002 bpl vblw1 dex inx vblw2 bit $2002 bpl vblw2 lda #0 sta <mapad+1 sta <outrdy ;TODO ; Instruction decoding table opccnt = 236 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 if ((\1)>$7F)&((\1)<$90) opcode (\1)+$10, \2 opcode (\1)+$20, \2 endif endmac opctab ds opccnt*2 opcode 1, z_equal opcode 2, z_less opcode 3, z_grtr opcode 4, z_dless opcode 5, z_igrtr opcode 6, z_in opcode 7, z_btst opcode 8, z_bor opcode 9, z_band opcode 10, z_ftst opcode 11, z_fset opcode 12, z_fclr opcode 13, z_set opcode 14, z_move opcode 15, z_get opcode 16, z_getb opcode 17, z_getp opcode 18, z_getpt opcode 19, z_nextp opcode 20, z_add opcode 21, z_sub opcode 22, z_mul opcode 23, z_div opcode 24, z_mod opcode 128, z_zero opcode 129, z_next opcode 130, z_first opcode 131, z_loc opcode 132, z_ptsiz opcode 133, z_inc opcode 134, z_dec opcode 135, z_prntb opcode 137, z_remov opcode 138, z_prntd opcode 139, z_ret opcode 140, z_jump opcode 141, z_print opcode 142, z_value opcode 143, z_bcom opcode 176, z_rtrue opcode 177, z_rfals opcode 178, z_prnti opcode 179, z_prntr opcode 180, z_noop opcode 181, z_save opcode 182, z_rstor opcode 183, z_rest opcode 184, z_rstac opcode 185, z_fstac opcode 186, z_quit opcode 187, z_crlf opcode 188, z_usl opcode 189, z_vrfy opcode 224, z_call opcode 225, z_put opcode 226, z_putb opcode 227, z_putp opcode 228, z_read opcode 229, z_prntc opcode 230, z_prntn opcode 231, z_randm opcode 232, z_push opcode 233, z_pop opcode 234, z_split opcode 235, z_scrn org opctab+(opccnt*2) bank 30 org $C000 ; Macro for object address (35 bytes) macro object_address lda #low(xobject+\2) sta <corel lda #high(xobject+\2) sta <coreh lda #0 sta <idxh sta <byth lda \1 asl a rol <idxh asl a rol <idxh asl a rol <idxh ; now carry flag is clear, have 8x value adc \1 ; add the object number so you have 9x in total sta <idxl lda <idxh adc #0 ; carry out if applicable sta <idxh endmac ; Print a string putstr lda #0 sta <pshift sta <tshift putstr1 jsr pcgetw pha 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 pcgetw jsr pcgetb sta <byth ; falls through ; Read a byte from instruction pointer, write to A ; (clobbers X, Y, and flags) pcgetb ldy <pcl ; To use later lda <pch bne pcgetbh ; In high memory; it is greater than 64K ; It is in core memory (always 64K in this program) lax <pcm and #$1F ora #$60 sta <mapad txa lsr a lsr a lsr a lsr a lsr a sta rambank lda [mapad],y jmp pcinc pcgetbh ; 0000 0001 xxyy yyyy zzzz zzzz -> bank=1000 1xx0, mem=10yy yyyy lax <pcm and #$3F ora #$80 sta <mapad txa lsr a lsr a lsr a lsr a lsr a and #$06 ora #$88 sta romback lda [mapad],y pcinc inc <pcl bne pcirts inc <pcm bne pcirts inc <pch pcirts rts ; Deal with reading a register (as VALUE) ; Register in A, result in <byth and A fetch cmp #16 bcc fetch1 ; Global variables sta <idxl lda #0 sta <idxh lda #low(xglobal) sta <corel lda #high(xglobal) sta <coreh jmp mget fetch1 cmp #0 bne fetch3 ldx <dstkcnt bne fetch2 fetch3 ; Local variables ldx <cstkcnt ldy $6FF,x sty <r3 adc <r3 ; Carry flag is already cleared tax fetch2 lda $1FF,x sta <byth lda $2FF,x rts ; Deal with store (uses A and <byth as value; instruction as dest) ; The value A will remain there once stored tostore pha jsr pcgetb cmp #0 bne dostore inc <dstkcnt ; 'dostore' uses A as the register number, the the value on the stack ; and <byth. It also omits pushing to the stack (cf. SET, INC, DEC) dostore cmp #16 bcc store1 ; Global variables sta <idxl 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 store2 pla sta $1FF,x ldy <byth sty $2FF,x rts ; Implement GET/GETB ; <corel=low addr, <coreh=high addr ; <idxl=low index, <idxh=high index ; A=low data, <byth=high data mget asl <idxl rol <idxh jsr mgetb sta <byth inc <idxl bne mgetb inc <idxh mgetb lda <coreh clc adc <idxh tax and #$1F ora #$60 sta <mapad txa lsr a lsr a lsr a lsr a lsr a sta rambank ldy <corel clc adc <idxl lda [mapad],y rts ; Implment PUT/PUTB ; <corel=low addr, <coreh=high addr ; <idxl=low index, <idxh=high index ; A=low data, <byth=high data mput pha mput1 asl <idxl rol <idxh lda <byth jsr mgetb sta <byth inc <idxl bne mgetb inc <idxh pla mputb pha lda <coreh clc adc <idxh tax and #$1F ora #$60 sta <mapad txa lsr a lsr a lsr a lsr a lsr a sta rambank ldy <corel clc adc <idxl pla sta [mapad],y rts ; Figure out property table address of object A ; Store ressults to <coreh and <corel ptad sta <mapad object_address <mapad,7 ; Get high octet jsr mgetb pha ; Increment object header address inc <corel if low(xobject+7)=255 inc <coreh endif ; Get low octet jsr mgetb ; Store the results sta <corel pla sta <coreh rts ; Flag address (<op0l is object, <op1l is flag, A is bit) flad object_address <op0l,0 lda <op1l pha lsr a lsr a lsr a sta <r0 lda <idxl clc adc <r0 sta <idxl lda <idxh adc #0 sta <idxh pla and #$07 beq flad2 tax lda #$80 flad1 lsr a dex bne flad1 flad2 rts ; Remove object (<op0l) from its current location remobj object_address <op0l,4 ; obj.LOC jsr mgetb beq flad2 ; rts if object is in nowhere sta <r0 ; Remember and clear obj.NEXT inc <corel if low(xobject+4)=255 inc <coreh endif jsr mgetb sta <r1 lda #0 jsr mputb ; Is it the FIRST object? object_address <r0,6 ; obj.LOC.FIRST jsr mgetb cmp <op0l bne remobj1 ; Yes! Set its new FIRST to the old NEXT of the removed object. lda <r1 jmp mputb ; No! Where is it in the chain? remobj1 object_address <r1,5 ; r1.NEXT sta <r1 cmp <op0l bne remobj1 ; Found it lda <idxl pha lda <idxh pha object_address <r1,5 jsr mgetb tax pla sta <idxh pla sta <idxl txa jmp mputb ; Do the relative branching using offset in A and <op0h ; If the value is 0 or 1, it returns instead of jumps rjumppc ldx <op0h bne jumppc cmp #2 bcs jumppc stx <byth jmp return ; Same as above but won't check for returns ; (also, the continuation of the above) jumppc sta <r0 lda <op0h eor #$80 ; sign conversion sta <r1 sec lda <pcl sbc #$03 ; subtract one extra, since... sta <pcl lda <pcm sbc #$80 sta <pcm lda <pch sbc #$00 ; ...carry flag is now set (due to no borrowing)... sta <pch lda <pcl adc <r0 ; ...which causes the one extra to be added back sta <pcl lda <pcm adc <r1 sta <pcm lda <pch adc #$00 sta <pch jmp nxtinst ; Deal with branch ; Condition is true if zero flag is set branch php jsr pcgetb sta <r0 pla lsr a lsr a ror a eor <r0 bmi notjump ; condition flag does not match... bit <r0 bvs branch1 ; Long branch lda <r0 asl a asl a asl a php php ror a plp ror a plp ror a sta <op0h jsr pcgetb jmp rjumppc ; Short branch branch1 lda #0 sta <op0h lda <r0 and #$3F jmp rjumppc ; Not branching notjump bit <r0 bvs nxtinst jsr pcgetb jmp nxtinst ; Return from a subroutine return dec <dstkcnt ldy <dstkcnt ldx $700,y stx <cstkcnt ldx $400,y stx <pcl ldx $500,y stx <pcm ldx $600,y stx <pch jsr tostore ; fall through ; Next instruction operation nxtinst jsr pcgetb sta <r0 bit <r0 bmi nxtins1 ; 2OP form sta <r1 lsr <r1 asl a and #$80 ora <r1 and #$90 ora <r0 eor #$60 ora #$0F bne nxtins3 nxtins1 bvs nxtins2 ; 1OP or 0OP form rol a rol a ora #$3F bne nxtins3 ; EXT form nxtins2 jsr pcgetb ; Read operands and call function (using RTS trick) nxtins3 eor #$FF sta <argtyp sta <r1 ldx <r0 romsel opctab lda opctab,x ; high byte of address pha lda opctab+opccnt,x ; low byte of address pha ldx #op0l-2 stx <r2 jsr getopr jsr getopr jsr getopr ; fall through to read the fourth operand and RTS trick ; Subroutine to read one operand of an instruction getopr ldx <r2 inx inx stx <r2 bit <r1 bvs getopr1 ;bit0=0 bmi getopr2 ;bit1=0 ; [11] No operand getopr0 asl <r1 asl <r1 rts getopr1 bmi getopr3 ;bit1=0 ; [10] Variable jsr pcgetb tay jsr fetch cpy #0 ; popped from stack bne getopr4 dec <dstkcnt jmp getopr4 ; [01] Short immediate getopr2 jsr pcgetb ldx <r2 sta <0,x lda #0 sta <1,x beq getopr0 ; [00] Long immediate getopr3 jsr pcgetw getopr4 ldx <r2 sta <0,x lda <byth sta <1,x jmp getopr0 ; **************************************** ; Z-code instructions ; Set the zero flag for condition true, clear otherwise ; <byth and A store the value to store to memory ; [1] EQUAL? data,cmp1[,cmp2][,cmp3] /PRED z_equal lda <op0l cmp <op1l bne z1equal lda <op0h cmp <op1h bne z1equal z0equal jmp branch z1equal lda #$0F bit <argtyp beq z9equal lda <op0l cmp <op2l bne z2equal lda <op0h cmp <op2h bne z2equal jmp branch z2equal lda #$03 bit <argtyp beq z9equal lda <op0l cmp <op3l bne z0equal lda <op0h cmp <op3h jmp branch z9equal asl a jmp branch ; [4] DLESS? var,int /PRED z_dless lda <op0l jsr fetch clc sbc #0 sta <op0l pha bcs z1dless dec <byth z1dless lda <byth sta <op0h lda <op0l jsr dostore ; fall through ; [2] LESS? int1,int2 /PRED z_less lda <op0h eor #$80 ; do sign conversion sta <op0h lda <op1h eor #$80 cmp <op0h bne z1less lda <op0l cmp <op1l z1less lda #0 adc #0 ; convert carry flag clear to zero flag set jmp branch ; [5] IGRTR? var,int /PRED z_dless lda <op0l jsr fetch sec adc #0 sta <op0l pha bcc z1dless inc <byth z1dless lda <byth sta <op0h lda <op0l jsr dostore ; fall through ; [3] GRTR? int1,int2 /PRED z_grtr lda <op1h eor #$80 ; do sign conversion sta <op1h lda <op0h eor #$80 cmp <op1h bne z1grtr lda <op1l cmp <op0l z1grtr lda #0 adc #0 ; convert carry flag clear to zero flag set jmp branch ; [6] IN? obj1,obj2 /PRED z_in object_address <op0l,4 jsr mgetb cmp <op1l jmp branch ; [7] BTST data,mask /PRED z_btst lda <op0h and <op1h eor <op1h beq z1btst jmp branch z1btst lda <op0l and <op1l eor <op1l jmp branch ; [8] BOR int1,int2 /VAL z_bor lda <op0h ora <op1h sta <byth lda <op0l ora <op1l jsr tostore jmp nxtinst ; [9] BAND int1,int2 /VAL z_band lda <op0h and <op1h sta <byth lda <op0l and <op1l jsr tostore jmp nxtinst ; [10] FSET? obj,flag /PRED z_ftst jsr flad sta <r0 jsr mgetb eor #$FF and <r0 jmp branch ; [11] FSET obj,flag z_fset jsr flad sta <r0 jsr mgetb ora <r0 jsr mputb jmp nxtinst ; [12] FCLEAR obj,flag z_fclr jsr flad eor #$FF sta <r0 jsr mgetb and <r0 jsr mputb jmp nxtinst ; [13] SET var,value z_set lda <op1l pha lda <op1h sta <byth lda <op0l jsr dostore jmp nxtinst ; [137] REMOVE obj z_remov lda #0 sta <op1l beq z_move ; keep with next ; [14] MOVE object,container ; Clear NEXT of object z1move inc <corel if low(xobject+4)=255 inc <coreh endif jsr mputb ; accumulator is already zero jmp nxtinst ; Remove object from its current location z_move jsr remobj ; Set LOC of object object_address <op0l,4 lda <op1l jsr mputb tax beq z1move ; Remember object address lda <idxl sta <r0 lda <idxh sta <r1 ; Get FIRST of container object_address <op1l,6 jsr mgetb pha ; Remember container address lda <idxl pha lda <idxh pha ; Set NEXT of object lda <r0 sta <idxl clc sbc #0 ; subtract one so it points to NEXT instead of FIRST lda <r1 sbc #0 sta <idxh pla jsr mputb ; Set FIRST of container pla sta <idxh pla sta <idxl lda <op0l jsr mputb jmp nxtinst ; [15] GET table,item /VAL z_get lda <op0l sta <corel lda <op0h sta <coreh lda <op1l sta <idxl lda <op1h sta <idxh jsr mget jsr tostore jmp nxtinst ; [16] GETB table,item /VAL z_getb lda #0 sta <byth lda <op0l sta <corel lda <op0h sta <coreh lda <op1l sta <idxl lda <op1h sta <idxh jsr mgetb jsr tostore jmp nxtinst ; [20] ADD int1,int2 /VAL z_add clc lda <op0l adc <op1l pha lda <op0h adc <op1h sta <byth pla jsr tostore jmp nxtinst ; [21] SUB int1,int2 /VAL z_sub sec lda <op0l sbc <op1l pha lda <op0h sbc <op1h sta <byth pla jsr tostore jmp nxtinst ; [128] ZERO? value /PRED z_zero lda <op0l ora <op0h jmp branch ; [129] NEXT? obj /VAL/PRED z_next object_address <op0l,5 jsr mgetb jsr tostore tax php pla and #$02 ; now zero flag is toggled jmp branch ; [130] FIRST? obj /VAL/PRED z_first object_address <op0l,6 jsr mgetb jsr tostore tax php pla and #$02 ; now zero flag is toggled jmp branch ; [131] LOC obj /VAL z_loc object_address <op0l,4 jsr mgetb jsr tostore jmp nxtinst ; [132] PTSIZE ptr /VAL z_ptsiz lda #$FF sta <idxl sta <idxh lda <op0l sta <corel lda <op0h sta <coreh jsr mgetb lsr a lsr a lsr a lsr a lsr a sec adc #0 jsr tostore jmp nxtinst ; [133] INC var z_inc lda <op0l jsr fetch sec adc #0 pha bcc zincdec inc <byth zincdec lda <op0l jsr dostore jmp nxtinst ; keep with next ; [134] DEC var z_dec lda <op0l jsr fetch clc sbc #0 pha bcs zincdec dec <byth ; does not affect the carry flag bcc zincdec ; [138] PRINTD obj z_prntd lda <op0l jsr ptad inc <corel ; skip length byte bne z1prntb inc <coreh ; going past 64K is not allowed bne z1prntb ; keep with next ; [135] PRINTB ptr z_prntb lda <op0l sta <corel lda <op0h sta <coreh z1prntb lda <pcl pha lda <pcm pha lda <pch pha lda #0 sta <pch lda <corel sta <pcl lda <coreh sta <pcm jsr putstr pla sta <pch pla sta <pcm pla sta <pcl jmp nxtinst ; [139] RETURN value z_ret lda <op0h sta <byth lda <op0l jmp return ; [140] JUMP offset z_jump lda <op0l jmp jumppc ; [141] PRINT str z_print lda <pcl pha lda <pcm pha lda <pch pha lda #0 sta <pch lda <corel sta <pcl lda <coreh sta <pcm asl <pcl rol <pcm rol <pch jsr putstr pla sta <pch pla sta <pcm pla sta <pcl jmp nxtinst ; [143] BCOM int /VAL z_bcom lda <op0h eor #$FF sta <byth lda <op0l eor #$FF jsr tostore jmp nxtinst ; [142] VALUE var /VAL z_value lda <op0l jsr fetch z1value jsr tostore jmp nxtinst ; keep with next ; [224] CALL fcn[,arg1][,arg2][,arg3] /VAL z_call lda #0 cmp <op0l bne z1call sta <byth cmp <op0h beq z1value z1call ldx <cstkcnt lda <pcl sta $400,x lda <pcm sta $500,x lda <pch sta $600,x lda <dstkcnt sta <r2 ; remember bottom of local stack frame sta $700,x inc <cstkcnt lsr <pch lda <op0l sta <pcl lda <op0h sta <pcm asl <pcl rol <pcm rol <pch ; Read values of local variables jsr pcgetb sta <r3 z2call lda <r3 beq z3call dec <r3 jsr pcgetw ldy <dstkcnt sta $200,y lda <byth sta $300,y inc <dstkcnt bne z2call ; Rewrite values of local variables by arguments z3call lda #$3F bit <argtyp beq z9call ldx <r2 lda <op1l sta $200,x lda <op1h sta $300,x lda #$0F bit <argtyp beq z9call lda <op2l sta $201,x lda <op2h sta $301,x lda #$03 bit <argtyp beq z9call lda <op3l sta $202,x lda <op3h sta $302,x z9call jmp nxtinst ; [179] PRINTR (str) z_prntr jsr putstr lda #13 bankcall putchar ; fall through ; [176] RTRUE z_rtrue lda #0 sta <byth lda #1 jmp return z_rfals ; [177] RFALSE lda #0 sta <byth jmp return ; [178] PRINTI (str) z_prnti jsr putstr jmp nxtinst ; [180] NOOP z_noop = nxtinst ; [181] SAVE /PRED z_save lda #1 ; clear the zero flag (SAVE/RESTORE aren't implemented) jmp branch ; [182] RESTORE /PRED z_rstor = z_save ; [183] RESTART z_rest = reset ; [184] RSTACK z_rstac lda #0 jsr fetch dec <dstkcnt jmp return ; [233] POP var z_pop ldx <dstkcnt jsr fetch2 pha lda <op0l jsr dostore ; fall through ; [185] FSTACK z_fstac dec <dstkcnt jmp nxtinst ; [186] QUIT z_quit jmp z_quit ; just wait forever for the player to push RESET ; [225] PUT table,item,data z_put lda <op0l sta <corel lda <op0h sta <coreh lda <op1l sta <idxl lda <op1h sta <idxh lda <op2h sta <byth lda <op2l jsr mput jmp nxtinst ; [226] PUTB table,item,data z_putb lda <op0l sta <corel lda <op0h sta <coreh lda <op1l sta <idxl lda <op1h sta <idxh lda <op2l jsr mputb jmp nxtinst ; [187] CRLF z_crlf lda #13 bne z1prntc ; keep with next ; [229] PRINTC char z_prntc lda <op0l z1prntc bankcall putchar jmp nxtinst ; [230] PRINTN int z_prntn bankjump printn ; [232] PUSH value z_push inc <dstkcnt lda <op0l pha lda <op0h sta <byth lda #0 jsr dostore jmp nxtinst ; [234] SPLIT lines z_split = nxtinst ; [235] SCREEN window z_scrn = nxtinst ; **************************************** bank 31 org $FE00 ; Initialize CPU/APU/PPU at reset reset ldx #$40 stx $4017 ; Disable APU frame IRQ ldx #$FF txs inx stx $2000 stx $2001 stx $4010 ; Initialize MMC5 to act like User:Zzo38/Mapper_D stx $5101 stx $5200 stx $5204 inx stx $5100 stx $5102 inx stx $5103 lda #$50 sta $5105 ; Call other init code bankjump reset1 ; NMI routine nmi pha dec <blinker bne nmi1 bit $2002 lda #$3F sta $2006 lda #$23 sta <blinker sta $2006 lda <curspal eor <#$0F sta <curspal sta $2007 lda #0 sta $2005 lda <scrolly sta $2005 nmi1 bit <outrdy bvc nmi2 jmp sendout nmi2 bit <linrdy bvc nmi3 jmp sendlf nmi3 pla rti ; CHR ROM bank 32 incbin "chicago_oblique.chr" incbin "chicago_inverse.chr"
