github.com/erkyrath.infocom-zcode-terps
1
0
Fork 0
mirror of https://github.com/erkyrath/infocom-zcode-terps.git synced 2026-02-10 02:00:22 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
2915fa943b2ff6a0449cd3b7aae496eac645e2d6
erkyrath.infocom-zcode-terps/apple/xzip/ops012.asm
Andrew Plotkin b642da811e Initial commit.
2023-11-16 18:19:54 -05:00

1112 lines
20 KiB
NASM
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
PAGE
STTL "--- 0-OPS ---"
; -----
; RTRUE
; -----
; SIMULATE A "RETURN 1"
ZRTRUE: LDX #1
ZRT0: LDA #0
ZRT1: STX ARG1+LO ; GIVE TO
STA ARG1+HI ; [ARG1]
JMP ZRET ; AND DO THE RETURN
; ------
; RFALSE
; ------
; SIMULATE A "RETURN 0"
ZRFALS: LDX #0
BEQ ZRT0
; ------
; PRINTI
; ------
; PRINT Z-STRING FOLLOWING THE OPCODE
ZPRI: LDX #5 ;MOVE ZPC INTO MPC
ZPRI1:
LDA ZPC,X
STA MPC,X
DEX
BPL ZPRI1 ;NO NEED TO VALIDATE AS ZPC WAS VALID ANYWAY
JSR PZSTR ; PRINT THE Z-STRING AT [MPC]
LDX #5 ; COPY STATE OF [MPC]
ZPRI2: LDA MPC,X ; INTO [ZPC]
STA ZPC,X
DEX
BPL ZPRI2
RTS
; ------
; PRINTR
; ------
; DO A "PRINTI," FOLLOWED BY "CRLF" AND "RTRUE"
ZPRR: JSR ZPRI
JSR ZZCRLF
JMP ZRTRUE
; ------
; RSTACK
; ------
; "RETURN" WITH VALUE ON STACK
ZRSTAK: JSR POPVAL ; GET VALUE INTO [X/A]
JMP ZRT1 ; AND GIVE IT TO "RETURN"
; -----
; CATCH
; -----
ZCATCH: LDX OLDZSP+HI ; RETURN ZSTACK POINTER AS
LDA OLDZSP+LO ; ZRET WILL NEED IT
JMP PUTBYT
; ---------
; ORIGINAL?
; ---------
; COPY PROTECTION DEVICE, RETURNS TRUE FOR NOW
ZORIG: JMP PREDS
PAGE
STTL "--- 1-OPS ---"
; -----
; ZERO?
; -----
; [ARG1] = 0?
ZZERO: LDA ARG1+LO
ORA ARG1+HI
BEQ PFINE
PYUCK: JMP PREDF
; -----
; NEXT?
; -----
; RETURN "NEXT" POINTER IN OBJECT [ARG1] ;
; FAIL IF LAST AND RETURN ZERO
ZNEXT: LDA ARG1+LO
LDX ARG1+HI ; (EZIP)
JSR OBJLOC ; GET OBJECT ADDR INTO [I]
LDY #8 ; POINT TO "NEXT" SLOT (EZIP)
BNE FIRST1 ; JMP
; ------
; FIRST?
; ------
; RETURN "FIRST" POINTER IN OBJECT [ARG1] ;
; FAIL IF LAST AND RETURN ZERO
; (EZIP ALTERATIONS)
ZFIRST: LDA ARG1+LO
LDX ARG1+HI
JSR OBJLOC ; GET OBJECT ADDR INTO [I]
LDY #10 ; POINT TO "FIRST" SLOT
FIRST1: LDA (I),Y ; GET CONTENTS OF SLOT
TAX
INY
LDA (I),Y ; INTO A,X
JSR PUTBYT ; PASS IT TO VARIABLE
LDA VALUE+LO ; EXAMINE THE VALUE JUST "PUT"
BNE PFINE
LDA VALUE+HI
BEQ PYUCK ; FAIL IF IT WAS ZERO
PFINE: JMP PREDS ; ELSE REJOICE
; ---
; LOC
; ---
; RETURN THE OBJECT CONTAINING OBJECT [ARG1] ;
; RETURN ZERO IF NONE
; (EZIP ALTERED)
ZLOC: LDA ARG1+LO
LDX ARG1+HI
JSR OBJLOC ; GET ADDR OF OBJECT INTO [I]
LDY #6 ; POINT TO "LOC" SLOT
LDA (I),Y ; GET THE WORD
TAX
INY
LDA (I),Y
JMP PUTBYT ; AND SHIP IT OUT
; ------
; PTSIZE
; ------
; RETURN LENGTH OF PROP TABLE [ARG1] IN BYTES
ZPTSIZ: LDA ARG1+HI ; MOVE ABS ADDR OF
CLC ; THE PROP TABLE
ADC ZCODE ; INTO [I]
STA I+HI
LDA ARG1+LO ; DECREMENT THE
SEC ; ADDRESS
SBC #1 ; WHILE MOVING LSB
STA I+LO
BCS PTZ0
DEC I+HI
PTZ0: LDY #0 ; GET THE LENGTH
LDA (I),Y ; OF PROPERTY AT [I] INTO [A]
BMI PTZ2 ; BIT 7 = 1, LENGTH > 2 BYTES
AND #%01000000
BEQ PTZ1 ; BIT 6 = 0, LENGTH = 1
LDA #2 ; BIT 6 = 1, LENGTH = 2
BNE PTZ3 ; JMP
PTZ1: LDA #1
BNE PTZ3 ; JMP
PTZ2: AND #%00111111 ; ELSE PICK UP SIZE > 2
PTZ3: LDX #0 ; CLEAR FOR PUTBYT
JMP PUTBYT
; ---
; INC
; ---
; INCREMENT VARIABLE [ARG1]
ZINC: LDA ARG1+LO
JSR VARGET ; FETCH VARIABLE INTO [VALUE]
INC VALUE+LO
BNE ZINC1
INC VALUE+HI
ZINC1: JMP ZD0
; ---
; DEC
; ---
; DECREMENT VARIABLE [ARG1]
ZDEC: LDA ARG1+LO
JSR VARGET ; FETCH VAR INTO [VALUE]
LDA VALUE+LO
SEC
SBC #1
STA VALUE+LO
LDA VALUE+HI
SBC #0
STA VALUE+HI
ZD0: LDA ARG1+LO ; PUT RESULT BACK
JMP VARPUT ; INTO THE SAME VARIABLE
; ------
; PRINTB
; ------
; PRINT Z-STRING AT [ARG1]
ZPRB: LDA ARG1+LO
STA I+LO
LDA ARG1+HI
STA I+HI
JSR SETWRD ; MOVE Z-ADDR TO [MPC]
JMP PZSTR ; AND PRINT
; ------
; REMOVE
; ------
; MOVE OBJECT [ARG1] INTO PSEUDO-OBJECT #0
; (EZIP CHANGES - 1) OBJLOC NEEDS HI & LO
; 2) MOVES AND COMPARES 2 BYTES)
ZREMOV:
LDA ARG1+LO ; GET SOURCE OBJECT ADDR
LDX ARG1+HI
JSR OBJLOC ; INTO [I]
LDA I+LO ; COPY THE SOURCE ADDR
STA J+LO ; INTO [J]
LDA I+HI ; FOR LATER REFERENCE
STA J+HI
LDY #7 ; POINT TO "LOC" SLOT
LDA (I),Y ; GET THE DATA
STA K ; HOLD IT
DEY
LDA (I),Y
TAX ; X = HI
LDA K ; A = LO
ORA (I),Y ; COMPARE BYTES
BEQ REMVEX ; SCRAM IF NO OBJECT
LDA K ; PICK UP, DESTROYED BY ORA
JSR OBJLOC ; ELSE GET ADDR OF OBJECT [A] INTO [I]
LDY #10 ; POINT TO "FIRST" SLOT
LDA (I),Y ; GRAB DATA
TAX
INY
LDA (I),Y ; A=LO, X=HI
CMP ARG1+LO ; IS THIS THE FIRST?
BNE REMVC1 ; NO, KEEP SEARCHING
CPX ARG1+HI ; HM?
BNE REMVC1
LDY #8 ; ELSE COPY SOURCE'S "NEXT" SLOT
LDA (J),Y
INY ; INTO DEST'S "FIRST" SLOT ([Y] = 10)
INY
STA (I),Y
DEY ; BACK UP TO GET >BYTE
LDA (J),Y
INY
INY
STA (I),Y
BNE REMVC2 ; BRANCH ALWAYS
REMVC1:
JSR OBJLOC
LDY #8 ; GET "NEXT"
LDA (I),Y
TAX
INY
LDA (I),Y
CMP ARG1+LO ; FOUND IT?
BNE REMVC1 ; NO, KEEP TRYING
CPX ARG1+HI
BNE REMVC1
LDY #8 ; WHEN FOUND
LDA (J),Y ; MOVE "NEXT" SLOT OF SOURCE (THIS OBJECT)
STA (I),Y ; TO "NEXT" SLOT OF DEST
;(OBJECT THAT REFERENCED THIS ONE)
INY
LDA (J),Y
STA (I),Y
REMVC2: LDA #0
LDY #6 ; CLEAR "LOC"
STA (J),Y
INY
STA (J),Y
INY ; AND "NEXT" SLOTS ([Y] = 5)
STA (J),Y ; OF SOURCE OBJECT (ARG1)
INY
STA (J),Y
REMVEX:
RTS
; ------
; PRINTD
; ------
; PRINT SHORT DESCRIPTION OF OBJECT [ARG1]
ZPRD: LDA ARG1+LO
LDX ARG1+HI ; (EZIP)
; ENTRY POINT FOR "USL"
PRNTDC: JSR OBJLOC ; GET ADDR OF OBJECT INTO [I]
LDY #12 ; GET PROP TABLE POINTER (EZIP)
LDA (I),Y ; FETCH MSB
TAX ; SAVE IT HERE
INY
LDA (I),Y ; FETCH LSB
STA I+LO ; STORE LSB
STX I+HI ; AND MSB
INC I+LO ; POINT PAST THE
BNE PDC0 ; LENGTH BYTE
INC I+HI
PDC0: JSR SETWRD ; CALC Z-STRING ADDR
JMP PZSTR ; AND PRINT IT
; ------
; RETURN
; ------
; RETURN FROM "CALL" WITH VALUE [ARG1]
ZRET:
LDA OLDZSP+LO ; RE-SYNC THE
STA ZSP+LO ; Z-STACK POINTER
LDA OLDZSP+HI
STA ZSP+HI
JSR POPVAL ; POP # LOCALS INTO [X/A]
STX I+HI ; SAVE HERE
JSR POPVAL ; now we need number of args
STA ASSVLU ; for ASSIGNED?
LDX I+HI ; see how many locals
BEQ RET2 ; SKIP IF NOT
; RESTORE PUSHED LOCALS
DEX ; ZERO-ALIGN
TXA ; AND
ASL A ; WORD-ALIGN # LOCALS
STA I+LO ; FOR USE AS A STORAGE INDEX
RET1: JSR POPVAL ; POP A LOCAL INTO [X/A]
LDY I+LO ; RETRIEVE STORAGE INDEX
STA LOCALS+HI,Y ; STORE MSB OF LOCAL
TXA ; MOVE LSB
STA LOCALS+LO,Y ; AND STORE THAT TOO
DEC I+LO
DEC I+LO ; UPDATE STORAGE INDEX
DEC I+HI ; AND LOCALS COUNT
BNE RET1 ; POP TILL NO MORE LOCALS
; RESTORE OTHER VARIABLES
RET2:
JSR POPVAL ; POP [ZPCH] AND [ZPCM]
STX ZPCM
STA ZPCH
JSR POPVAL ; POP AND RESTORE
STX IRET
STA ZPCL
JSR POPVAL
STX OLDZSP+LO
STA OLDZSP+HI
LDA ZPCL ; check for zero zpc
BNE RETj ; which means we are returning to
LDA ZPCM ; an internal call
BNE RETj ; rather than just a normal
LDA ZPCH ; return
BNE RETj ; but so far it isn't
JSR A12VAL ; MOVE [ARG1] TO [VALUE]
JMP ZIRET ; so then do internal return
RETj:
JSR VLDZPC ; MAKE VALID
LDA IRET ; CHECK IF SHOULD RETURN A VALUE
BEQ RETYES ; (0 = RET, 1 = NO RETURN)
RTS ; NO, SO JUST GET OUT OF HERE
RETYES:
JSR A12VAL ; MOVE [ARG1] TO [VALUE]
JMP PUTVAL ; AND RETURN IT
; ----
; JUMP
; ----
; JUMP TO Z-LOCATION IN [ARG1]
ZJUMP: JSR A12VAL ; MOVE [ARG1] TO [VALUE]
JMP PREDB3 ; A BRANCH THAT ALWAYS SUCCEEDS
; -----
; PRINT
; -----
; PRINT Z-STRING AT WORD (QUAD) POINTER [ARG1]
ZPRINT: LDA ARG1+LO
STA I+LO
LDA ARG1+HI
STA I+HI
JSR SETSTR ; CALC STRING ADDRESS
JMP PZSTR ; AND PRINT IT
; -----
; VALUE
; -----
; RETURN VALUE OF VARIABLE [ARG1]
ZVALUE: LDA ARG1+LO
JSR VARGET ; GET THE VALUE
JMP PUTVAL ; EASY ENOUGH
PAGE
STTL "--- 2-OPS ---"
; -----
; LESS?
; -----
; [ARG1] < [ARG2]?
ZLESS:
JSR A12VAL ; MOVE [ARG1] TO [VALUE]
JMP DLS0 ; MOVE [ARG2] TO [I] & COMPARE
; ------
; DLESS?
; ------
; DECREMENT [ARG1] ; SUCCEED IF < [ARG2]
ZDLESS:
JSR ZDEC ; MOVES ([ARG1]-1) TO [VALUE]
DLS0: LDA ARG2+LO ; MOVE [ARG2] TO [I]
STA I+LO
LDA ARG2+HI
STA I+HI
JMP COMPAR ; COMPARE & RETURN
; -----
; GRTR?
; -----
; [ARG1] < [ARG2]?
ZGRTR: LDA ARG1+LO ; MOVE [ARG1] TO [I]
STA I+LO
LDA ARG1+HI
STA I+HI
JMP A2VAL ; MOVE [ARG2] TO [VALUE] & COMPARE
; ------
; IGRTR?
; ------
; INCREMENT [ARG1] ; SUCCEED IF GREATER THAN [ARG2]
ZIGRTR: JSR ZINC ; GET ([ARG1]+1) INTO [VALUE]
LDA VALUE+LO ; MOVE [VALUE] TO [I]
STA I+LO
LDA VALUE+HI
STA I+HI
A2VAL: LDA ARG2+LO ; MOVE [ARG2] TO [VALUE]
STA VALUE+LO
LDA ARG2+HI
STA VALUE+HI
; -----------------
; SIGNED COMPARISON
; -----------------
; ENTRY: VALUES IN [VALUE] AND [I]
;
; IS [VALUE] > [I]
;
COMPAR:
LDA I+HI
EOR VALUE+HI
BPL SCMP
LDA I+HI
CMP VALUE+HI
BCC PGOOD
JMP PREDF
SCMP: LDA VALUE+HI
CMP I+HI
BNE SCEX
LDA VALUE+LO
CMP I+LO
SCEX: BCC PGOOD
JMP PREDF
; ---
; IN?
; ---
; IS OBJECT [ARG1] CONTAINED IN OBJECT [ARG2]?
ZIN: LDA ARG1+LO
LDX ARG1+HI
JSR OBJLOC ; GET ADDR OF TARGET OBJECT INTO [I]
LDY #6 ; POINT TO "LOC" SLOT
LDA (I),Y ; GET DATA
CMP ARG2+HI ; IS IT THERE?
BNE PBAD ; NO
INY
LDA (I),Y
CMP ARG2+LO
BEQ PGOOD ; YES, SUCCEED
PBAD: JMP PREDF ; TOO BAD, CHUM ...
; ----
; BTST
; ----
; IS EVERY "ON" BIT IN [ARG1]
; ALSO "ON" IN [ARG2]?
ZBTST: LDA ARG2+LO ; FIRST CHECK LSBS
AND ARG1+LO
CMP ARG2+LO ; LSBS MATCH?
BNE PBAD ; NO, EXIT NOW
LDA ARG2+HI ; ELSE CHECK MSBS
AND ARG1+HI
CMP ARG2+HI ; MATCHED?
BNE PBAD ; SORRY ...
PGOOD:
JMP PREDS
; ---
; BOR
; ---
; RETURN [ARG1] "OR" [ARG2]
ZBOR: LDA ARG1+LO
ORA ARG2+LO
TAX
LDA ARG1+HI
ORA ARG2+HI
; FALL THROUGH ...
; ---------------------
; RETURN VALUE IN [X/A]
; ---------------------
VEXIT: STX VALUE+LO
STA VALUE+HI
JMP PUTVAL
; ----
; BAND
; ----
; RETURN [ARG1] "AND" [ARG2]
ZBAND: LDA ARG1+LO
AND ARG2+LO
TAX
LDA ARG1+HI
AND ARG2+HI
JMP VEXIT
; -----
; FSET?
; -----
; IS FLAG [ARG2] SET IN OBJECT [ARG1]?
ZFSETP: JSR FLAGSU ; GET BITS INTO [K] AND [J]
LDA K+HI ; DO MSBS
AND J+HI
STA K+HI
LDA K+LO ; DO LSBS
AND J+LO
ORA K+HI ; ANY BITS ON?
BNE PGOOD ; TARGET BIT MUST BE ON
JMP PREDF
; ----
; FSET
; ----
; SET FLAG [ARG2] IN OBJECT [ARG1]
ZFSET: JSR FLAGSU ; GET BITS INTO [K] & [J], ADDR IN [I]
LDY #0
LDA K+HI ; FIRST DO MSBS
ORA J+HI
STA (I),Y
INY
LDA K+LO ; THEN LSBS
ORA J+LO
STA (I),Y
RTS
; ------
; FCLEAR
; ------
; CLEAR FLAG [ARG2] IN OBJECT [ARG1]
ZFCLR: JSR FLAGSU ; GETS BITS INTO [J] & [K], ADDR IN [I]
LDY #0
LDA J+HI ; FETCH MSB
EOR #$FF ; COMPLEMENT IT
AND K+HI ; RUB OUT FLAG
STA (I),Y
INY
LDA J+LO ; SAME FOR LSB
EOR #$FF
AND K+LO
STA (I),Y
RTS
; ---
; SET
; ---
; SET VARIABLE [ARG1] EQUAL TO [ARG2]
ZSET: LDA ARG2+LO ; MOVE THE VALUE
STA VALUE+LO ; INTO [VALUE]
LDA ARG2+HI
STA VALUE+HI
LDA ARG1+LO ; GET VARIABLE ID
JMP VARPUT ; AND CHANGE THE VARIABLE
; ----
; MOVE
; ----
; MOVE OBJECT [ARG1] INTO OBJECT [ARG2]
; (EZIP - EXPANDED FROM BYTE OBJECTS TO WORD OBJECTS)
ZMOVE: JSR ZREMOV ; REMOVE FIRST - CUT ARG1 OUT OF WHERE IT IS
; NOW, IF IT IS ANYWHERE
LDA ARG1+LO
LDX ARG1+HI
JSR OBJLOC ; GET SOURCE OBJECT ADDR INTO [I]
LDA I+LO ; COPY SOURCE (ARG1) ADDRESS
STA J+LO ; INTO [J]
LDA I+HI
STA J+HI
LDA ARG2+HI ; GET DEST OBJECT ID
LDY #6 ; POINT TO "LOC" SLOT OF SOURCE
STA (I),Y ; AND MOVE IT IN
TAX ; (MOVE ARG2 INTO PARENT SLOT OF ARG1)
LDA ARG2+LO
INY
STA (I),Y ; X/A (HI/LO) SET FOR OBJLOC
JSR OBJLOC ; GET ADDR OF DEST OBJECT INTO [I] (GET PARENT)
; NOW SWAP IN NEW VALUE
LDY #10 ; POINT TO "FIRST" SLOT
LDA (I),Y ; OF PARENT (ARG2)
STA K+HI ; SAVE HERE FOR A MOMENT
LDA ARG1+HI ; GET SOURCE OBJECT ID
STA (I),Y ; MAKE IT "FIRST" OF PARENT
INY
LDA (I),Y
TAX
LDA ARG1+LO
STA (I),Y
TXA
ORA K+HI ; CHECK OLD "FIRST" OF DEST/PARENT
BEQ ZMVEX ; SCRAM IF ZERO
TXA ; GET LO BYTE AGAIN
LDY #9 ; MAKE OLD "FIRST" OF PARENT
STA (J),Y ; THE "NEXT" (SIBLING) OF THIS OBJECT (ARG1)
DEY ; I.E. ADD THIS ONE AT THE TOP OF LIST
LDA K+HI ; & GET >BYTE
STA (J),Y
ZMVEX:
RTS
; ---
; GET
; ---
; RETURN ITEM [ARG2] IN WORD-TABLE [ARG1]
ZGET: JSR WCALC ; CALC ADDRESS
JSR GETBYT ; GET 1ST BYTE (MSB)
DOGET: STA VALUE+HI ; SAVE MSB
JSR GETBYT ; GET LSB
STA VALUE+LO ; SAVE AND
JMP PUTVAL ; HAND IT OVER
; ----
; GETB
; ----
; RETURN ITEM [ARG2] IN BYTE-TABLE AT [ARG1]
ZGETB: JSR BCALC
LDA #0
BEQ DOGET ; [A] = 0, SO CLEAR MSB OF [VALUE]
; --------------------
; CALC TABLE ADDRESSES
; --------------------
; WORD-ALIGNED ENTRY
WCALC: ASL ARG2+LO ; WORD-ALIGN FOR
ROL ARG2+HI ; WORD ACCESS
; BYTE-ALIGNED ENTRY
BCALC: LDA ARG2+LO ; ADD BASE ADDR OF TABLE
CLC ; TO ITEM
ADC ARG1+LO ; INDEX
STA MPCL
LDA ARG2+HI ; SAME FOR MSBS
ADC ARG1+HI
STA MPCM
LDA #0
ADC #0 ; PICK UP CARRY FROM MPCM
STA MPCH ; TO GET TOP BIT
JMP VLDMPC
; ----
; GETP
; ----
; RETURN PROPERTY [ARG2] OF OBJECT [ARG1] ;
; IF NO PROP [ARG2], RETURN [ARG2]'TH ELEMENT OF OBJECT #0
ZGETP: JSR PROPB
GETP1: JSR PROPN ; GET ADDR OF PROP TBL
CMP ARG2+LO ; GET PROP ID
BEQ GETP3 ; FOUND IT
BCC GETP2 ; NOT THERE
JSR NEXTPI ; GET NEXT PROP, ALIGN [I] TO IT (EZIP)
JMP GETP1 ; TRY AGAIN WITH NEXT PROP
; PROPERTY NOT THERE, GET DEFAULT
GETP2: LDA ARG2+LO ; GET PROPERTY #
SEC ; ZERO-ALIGN IT
SBC #1
ASL A ; WORD-ALIGN IT
TAY ; USE AS AN INDEX
LDA (OBJTAB),Y ; GET MSB OF PROPERTY
STA VALUE+HI
INY
LDA (OBJTAB),Y ; DO SAME WITH LSB
STA VALUE+LO
JMP PUTVAL ; RETURN DEFAULT IN [VALUE]
GETP3: JSR PROPL ; GET LENGTH OF PROP INTO [A]
INY ; MAKE [Y] POINT TO 1ST BYTE OF PROP
CMP #1 ; IF LENGTH =1
BEQ GETPB ; GET A BYTE PROPERTY
CMP #2 ; IF LENGTH = 2
BEQ GETPW ; GET A WORD PROPERTY
; *** ERROR #7: PROPERTY LENGTH ***
LDA #7
JMP ZERROR
; GET A 1-BYTE PROPERTY
GETPB: LDA (I),Y ; GET LSB INTO [A]
LDX #0 ; CLEAR MSB IN [X]
BEQ ETPEX
; GET A 2-BYTE PROPERTY
GETPW: LDA (I),Y ; GET MSB
TAX ; INTO [X]
INY ; POINT TO LSB
LDA (I),Y ; GET IT INTO [A]
ETPEX: STA VALUE+LO ; STORE LSB
STX VALUE+HI ; AND MSB
JMP PUTVAL
; -----
; GETPT
; -----
; RETURN POINTER TO PROP TABLE [ARG2]
; IN OBJECT [ARG1]
ZGETPT: LDA ARG1+LO
LDX ARG1+HI ; (EZIP)
JSR OBJLOC
LDY #12 ; (EZIP)
LDA (I),Y ; GET MSB OF P-TABLE ADDRESS
CLC
ADC ZCODE ; MAKE IT ABSOLUTE
TAX ; AND SAVE HERE
INY
LDA (I),Y ; NOW GET LSB
STA I+LO
STX I+HI ; [I] NOW POINTS TO PROP TABLE
LDY #0
LDA (I),Y ; GET LENGTH OF SHORT DESC
ASL A ; WORD-ALIGN IT
TAY ; EXPECTED HERE
INY ; POINT JUST PAST THE DESCRIPTION
GETPT1: LDA (I),Y
AND #%00111111 ; MASK OUT LENGTH BITS (EZIP)
CMP ARG2+LO ; CHECK ID
BEQ GETPT2
BCS DDD
JMP DORET ; BEYOND IT, SO NOT THERE
DDD: LDA (I),Y ; CHECK LENGTH FLAGS
AND #%10000000 ; TEST BIT 7
BEQ SHORT0 ; OFF, SO 1 OR 2 BYTES
INY
LDA (I),Y ; NEXT BYTE HAS LENGTH
AND #%00111111 ; MASK OFF EXTRA BITS
JMP AAA
SHORT0: LDA (I),Y ; PICK UP BYTE AGAIN
AND #%01000000 ; BIT 6
BEQ ONE0
LDA #2 ; BIT 6 = 1, LENGTH =2
JMP AAA
ONE0: LDA #1 ; BIT 6 = 0, LENGTH =1
AAA: TAX ; SAVE HERE
PPPX: INY ; LOOP UNTIL
BNE PPPY
INC I+HI
PPPY: DEX ; [Y] POINTS TO
BNE PPPX ; START OF NEXT PROP
INY ; CORRECT ALIGNMENT
TYA ; ADD OFFSET TO NEXT PROP
CLC ; TO [I] SO I POINTS DIRECTLY
ADC I+LO ; AT IT
STA I+LO
BCC CCCC1
INC I+HI ; ADD IN CARRY
CCCC1: LDY #0 ; CLEAR [Y] AS IT IS USED AS AN INDEX
JMP GETPT1
GETPT2: LDA (I),Y ; CHECK LENGTH FLAGS
AND #%10000000 ; TEST BIT 7
BEQ SHORT1 ; OFF, SO 1 OR 2 BYTES
INY
LDA (I),Y ; NEXT BYTE HAS LENGTH
AND #%00111111 ; MASK OFF EXTRA BITS
JMP BBB
SHORT1: LDA (I),Y ; PICK UP BYTE AGAIN
AND #%01000000 ; BIT 6
BEQ ONE1
LDA #2 ; BIT 6 = 1, LENGTH =2
JMP BBB
ONE1: LDA #1 ; BIT 6 = 0, LENGTH =1
BBB: INY ; INC TO POINT AT PROPERTY VALUE (EZIP)
GETPT3: TYA ; FETCH OFFSET
CLC
ADC I+LO ; ADD LSB OF TABLE ADDRESS
STA VALUE+LO
LDA I+HI ; AND MSB
ADC #0
SEC ; STRIP OFF
SBC ZCODE ; RELATIVE POINTER
STA VALUE+HI
JMP PUTVAL ; AND RETURN
DORET: JMP RET0 ; ELSE RETURN A ZERO
; -----
; NEXTP
; -----
; RETURN INDEX # OF PROP FOLLOWING PROP [ARG2] IN OBJECT [AR
; RETURN ZERO IF LAST ; RETURN FIRST IF [ARG2]=0; ERROR IF NO
ZNEXTP: JSR PROPB ; ALIGN [I] AT PROPERTY TBL'S 1ST ENTRY
LDA ARG2+LO ; IF [ARG2]=0
BEQ NXTP3 ; RETURN "FIRST" SLOT
NXTP1: JSR PROPN ; FETCH PROPERTY #
CMP ARG2+LO ; COMPARE TO TARGET #
BEQ NXTP2 ; FOUND IT!
BCC DORET ; LAST PROP, SO RETURN ZERO
JSR NEXTPI ; ELSE TRY NEXT PROPERTY (EZIP)
JMP NXTP1
NXTP2: JSR PROPNX ; POINT TO FOLLOWING PROPERTY
NXTP3: JSR PROPN ; GET THE PROPERTY #
LDX #0 ; FOR PUTBYT (EZIP)
JMP PUTBYT ; AND RETURN IT
; ---
; ADD
; ---
; RETURN [ARG1] + [ARG2]
ZADD: LDA ARG1+LO ; ADD LSBS
CLC
ADC ARG2+LO
TAX ; SAVE LSB HERE
LDA ARG1+HI ; ADD MSBS
ADC ARG2+HI
JMP VEXIT
; ---
; SUB
; ---
; RETURN [ARG1] - [ARG2]
ZSUB: LDA ARG1+LO ; SUBTRACT LSBS
SEC
SBC ARG2+LO
TAX ; SAVE LSB HERE
LDA ARG1+HI ; SUBTRACT MSBS
SBC ARG2+HI
JMP VEXIT ; EXIT WITH [X]=LSB, [A]=MSB
; ---
; MUL
; ---
; RETURN [ARG1] * [ARG2]
ZMUL: JSR MINIT ; INIT THINGS
ZMLOOP: ROR MTEMP+HI
ROR MTEMP+LO
ROR ARG2+HI
ROR ARG2+LO
BCC ZMNEXT
LDA ARG1+LO
CLC
ADC MTEMP+LO
STA MTEMP+LO
LDA ARG1+HI
ADC MTEMP+HI
STA MTEMP+HI
ZMNEXT: DEX
BPL ZMLOOP
LDX ARG2+LO ; PUT LSB OF PRODUCT
LDA ARG2+HI ; AND MSB
JMP VEXIT ; WHERE "VEXIT" EXPECTS THEM
; ---
; DIV
; ---
; RETURN QUOTIENT OF [ARG1] / [ARG2]
ZDIV: JSR DIVIDE
LDX QUOT+LO
LDA QUOT+HI
JMP VEXIT
; ---
; MOD
; ---
; RETURN REMAINDER OF [ARG1] / [ARG2]
ZMOD: JSR DIVIDE
LDX REMAIN+LO ; FETCH THE REMAINDER
LDA REMAIN+HI ; IN [REMAIN]
JMP VEXIT ; AND RETURN IT
; ---------------
; SIGNED DIVISION
; ---------------
; ENTRY: DIVIDEND IN [ARG1], DIVISOR IN [ARG2]
; EXIT: QUOTIENT IN [QUOT], REMAINDER IN [REMAIN]
DIVIDE:
LDA ARG1+HI ; SIGN OF REMAINDER
STA RSIGN ; IS THE SIGN OF THE DIVIDEND
EOR ARG2+HI ; SIGN OF QUOTIENT IS POSITIVE
STA QSIGN ; IF SIGNS OF TERMS ARE THE SAME
LDA ARG1+LO ; MOVE [ARG1] TO [QUOT]
STA QUOT+LO
LDA ARG1+HI
STA QUOT+HI ; IF DIVIDEND IS POSITIVE
BPL ABSDIV ; MOVE DIVISOR
JSR ABQUOT ; ELSE CALC ABS(DIVIDEND) FIRST
ABSDIV: LDA ARG2+LO
STA REMAIN+LO
LDA ARG2+HI
STA REMAIN+HI ; IF REMAINDER IS POSITIVE
BPL GODIV ; WE'RE READY TO DIVIDE
JSR ABREM ; ELSE CALC ABS(DIVISOR)
GODIV: JSR UDIV ; DO UNSIGNED DIVIDE
LDA QSIGN ; SHOULD QUOTIENT BE FLIPPED?
BPL RFLIP ; NO, TEST REMAINDER
JSR ABQUOT ; ELSE GET ABSOLUTE VALUE
RFLIP: LDA RSIGN ; SHOULD EMAINDER BE FLIPPED?
BPL DIVEX ; NO, WE'RE DONE
; ELSE FALL THROUGH ...
; ----------------
; CALC ABS(REMAIN)
; ----------------
ABREM: LDA #0
SEC
SBC REMAIN+LO
STA REMAIN+LO
LDA #0
SBC REMAIN+HI
STA REMAIN+HI
DIVEX: RTS
; --------------
; CALC ABS(QUOT)
; --------------
ABQUOT: LDA #0
SEC
SBC QUOT+LO
STA QUOT+LO
LDA #0
SBC QUOT+HI
STA QUOT+HI
RTS
; -----------------
; UNSIGNED DIVISION
; -----------------
; ENTRY: DIVIDEND IN [QUOT], DIVISOR IN [REMAIN]
; EXIT: QUOTIENT IN [QUOT], REMAINDER IN [REMAIN]
UDIV:
LDA REMAIN+LO ; CHECK [REMAIN]
ORA REMAIN+HI ; BEFORE PROCEEDING
BEQ DIVERR ; CAN'T DIVIDE BY ZERO!
JSR MINIT ; SET IT ALL UP
UDLOOP: ROL QUOT+LO
ROL QUOT+HI
ROL MTEMP+LO
ROL MTEMP+HI
LDA MTEMP+LO
SEC
SBC REMAIN+LO
TAY ; SAVE HERE
LDA MTEMP+HI
SBC REMAIN+HI
BCC UDNEXT
STY MTEMP+LO
STA MTEMP+HI
UDNEXT: DEX
BNE UDLOOP
ROL QUOT+LO ; SHIFT LAST CARRY FOR QUOTIENT
ROL QUOT+HI
LDA MTEMP+LO ; MOVE REMAINDER
STA REMAIN+LO ; INTO [REMAIN]
LDA MTEMP+HI
STA REMAIN+HI
RTS
; *** ERROR #8: DIVISION BY ZERO ***
DIVERR: LDA #8
JMP ZERROR
; ---------
; MATH INIT
; ---------
MINIT: LDX #16 ; INIT LOOPING INDEX
LDA #0
STA MTEMP+LO ; CLEAR TEMP
STA MTEMP+HI ; REGISTER
CLC ; AND CARRY
RTS
; -----
; THROW
; -----
ZTHROW: LDA ARG2+LO ; SET ZSTACK POINTER
STA OLDZSP+LO ; UP FOR ZRET
LDA ARG2+HI
STA OLDZSP+HI
JMP ZRET
END

Reference in New Issue View Git Blame Copy Permalink