;-----------------------------------------------------------------
; MesacROM.Mu - Jumps, Load/Store, Read/Write, Binary/Unary/Stack Operators
; Last modified by Levin - August 14, 1978 5:02 PM
;-----------------------------------------------------------------
;-----------------------------------------------------------------
; J u m p s
;-----------------------------------------------------------------
; The following requirements are assumed:
; 1) J2-J9, JB are usable (in that order) as subroutine
; returns (by JEQx and JNEx).
; 2) since J2-J9 and JB are opcode entry points,
; they must meet requirements set by opcode dispatch.
;-----------------------------------------------------------------
; Jn - jump PC-relative
;-----------------------------------------------------------------
!1,2,JnA,Jbranchf;
J2: L←ONE, :JnA;
J3: L←2, :JnA;
J4: L←3, :JnA;
J5: L←4, :JnA;
J6: L←5, :JnA;
J7: L←6, :JnA;
J8: L←7, :JnA;
J9: L←10, :JnA;
JnA: L←M-1, :Jbranchf; A-aligned - adjust distance
;-----------------------------------------------------------------
; JB - jump PC-relative by alpha, assuming:
; JB is A-aligned
; Note: JEQB and JNEB come here with branch (1) pending
;-----------------------------------------------------------------
!1,1,JBx; shake JEQB/JNEB branch
!1,1,Jbranch; must be odd (shakes IR← below)
JB: T←ib, :JBx;
JBx: L←400 OR T; ←DISP will do sign extension
IR←M; 400 above causes branch (1)
L←DISP-1, :Jbranch; L: ib (sign extended) - 1
;-----------------------------------------------------------------
; JW - jump PC-relative by alphabeta, assuming:
; if JW is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after JW
;-----------------------------------------------------------------
JW: IR←sr1, :FetchAB; returns to JWr
JWr: L←ALLONES+T, :Jbranch; L: alphabeta-1
;-----------------------------------------------------------------
; Jump destination determination
; L has (signed) distance from even byte of word addressed by mpc+1
;-----------------------------------------------------------------
!1,2,Jforward,Jbackward;
!1,2,Jeven,Jodd;
Jbranch: T←0+1, SH<0; dispatch fwd/bkwd target
Jbranchf: SINK←M, BUSODD, TASK, :Jforward; dispatch even/odd target
Jforward: temp←L RSH 1, :Jeven; stash positive word offset
Jbackward: temp←L MRSH 1, :Jeven; stash negative word offset
Jeven: T←temp+1, :NOOP; fetch and execute even byte
Jodd: T←temp+1, :nextXB; fetch and execute odd byte
;-----------------------------------------------------------------
; JZEQB - if TOS (popped) = 0, jump PC-relative by alpha, assuming:
; stack has precisely one element
; JZEQB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
!1,2,JZEQBne,JZEQBeq;
JZEQB: SINK←stk0, BUS=0; test TOS = 0
L←stkp-1, TASK, :JZEQBne;
JZEQBne: stkp←L, :nextA; no branch, alignment => nextA
JZEQBeq: stkp←L, :JB; branch, pick up alpha
;-----------------------------------------------------------------
; JZNEB - if TOS (popped) ~= 0, jump PC-relative by alpha, assuming:
; stack has precisely one element
; JZNEB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
!1,2,JZNEBne,JZNEBeq;
JZNEB: SINK←stk0, BUS=0; test TOS = 0
L←stkp-1, TASK, :JZNEBne;
JZNEBne: stkp←L, :JB; branch, pick up alpha
JZNEBeq: stkp←L, :nextA; no branch, alignment => nextA
;-----------------------------------------------------------------
; JEQn - if TOS (popped) = TOS (popped), jump PC-relative by n, assuming:
; stack has precisely two elements
;-----------------------------------------------------------------
!1,2,JEQnB,JEQnA;
!7,1,JEQNEcom; shake IR← dispatch
JEQ2: IR←sr0, L←T, :JEQnB; returns to J2
JEQ3: IR←sr1, L←T, :JEQnB; returns to J3
JEQ4: IR←sr2, L←T, :JEQnB; returns to J4
JEQ5: IR←sr3, L←T, :JEQnB; returns to J5
JEQ6: IR←sr4, L←T, :JEQnB; returns to J6
JEQ7: IR←sr5, L←T, :JEQnB; returns to J7
JEQ8: IR←sr6, L←T, :JEQnB; returns to J8
JEQ9: IR←sr7, L←T, :JEQnB; returns to J9
;-----------------------------------------------------------------
; JEQB - if TOS (popped) = TOS (popped), jump PC-relative by alpha, assuming:
; stack has precisely two elements
; JEQB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
JEQB: IR←sr10, :JEQnA; returns to JB
;-----------------------------------------------------------------
; JEQ common code
;-----------------------------------------------------------------
!1,2,JEQcom,JNEcom; return points from JEQNEcom
JEQnB: temp←L RSH 1, L←T, :JEQNEcom; temp:0, L:1 (for JEQNEcom)
JEQnA: temp←L, L←T, :JEQNEcom; temp:1, L:1 (for JEQNEcom)
!1,2,JEQne,JEQeq;
JEQcom: L←stkp-T-1, :JEQne; L: old stkp - 2
JEQne: SINK←temp, BUS, TASK, :Setstkp; no jump, reset stkp
JEQeq: stkp←L, IDISP, :JEQNExxx; jump, set stkp, then dispatch
;
; JEQ/JNE common code
;
; !7,1,JEQNEcom; appears above with JEQn
; !1,2,JEQcom,JNEcom; appears above with JEQB
JEQNEcom: T←stk1;
L←stk0-T, SH=0; dispatch EQ/NE
T←0+1, SH=0, :JEQcom; test outcome and return
JEQNExxx: SINK←temp, BUS, :J2; even/odd dispatch
;-----------------------------------------------------------------
; JNEn - if TOS (popped) ~= TOS (popped), jump PC-relative by n, assuming:
; stack has precisely two elements
;-----------------------------------------------------------------
!1,2,JNEnB,JNEnA;
JNE2: IR←sr0, L←T, :JNEnB; returns to J2
JNE3: IR←sr1, L←T, :JNEnB; returns to J3
JNE4: IR←sr2, L←T, :JNEnB; returns to J4
JNE5: IR←sr3, L←T, :JNEnB; returns to J5
JNE6: IR←sr4, L←T, :JNEnB; returns to J6
JNE7: IR←sr5, L←T, :JNEnB; returns to J7
JNE8: IR←sr6, L←T, :JNEnB; returns to J8
JNE9: IR←sr7, L←T, :JNEnB; returns to J9
;-----------------------------------------------------------------
; JNEB - if TOS (popped) = TOS (popped), jump PC-relative by alpha, assuming:
; stack has precisely two elements
; JNEB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
JNEB: IR←sr10, :JNEnA; returns to JB
;-----------------------------------------------------------------
; JNE common code
;-----------------------------------------------------------------
JNEnB: temp←L RSH 1, L←0, :JEQNEcom; temp:0, L:0
JNEnA: temp←L, L←0, :JEQNEcom; temp:1, L:0
!1,2,JNEne,JNEeq;
JNEcom: L←stkp-T-1, :JNEne; L: old stkp - 2
JNEne: stkp←L, IDISP, :JEQNExxx; jump, set stkp, then dispatch
JNEeq: SINK←temp, BUS, TASK, :Setstkp; no jump, reset stkp
;-----------------------------------------------------------------
; JrB - for r in {L,LE,G,GE,UL,ULE,UG,UGE}
; if TOS (popped) r TOS (popped), jump PC-relative by alpha, assuming:
; stack has precisely two elements
; JrB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
; The values loaded into IR are not returns but encoded actions:
; Bit 12: 0 => branch if carry zero
; 1 => branch if carry one (mask value: 10)
; Bit 15: 0 => perform add-complement before testing carry
; 1 => perform subtract before testing carry (mask value: 1)
; (These values were chosen because of the masks available for use with ←DISP
; in the existing constants ROM. Note that IR← causes no dispatch.)
JLB: IR←10, :Jscale; adc, branch if carry one
JLEB: IR←11, :Jscale; sub, branch if carry one
JGB: IR←ONE, :Jscale; sub, branch if carry zero
JGEB: IR←0, :Jscale; adc, branch if carry zero
JULB: IR←10, :Jnoscale; adc, branch if carry one
JULEB: IR←11, :Jnoscale; sub, branch if carry one
JUGB: IR←ONE, :Jnoscale; sub, branch if carry zero
JUGEB: IR←0, :Jnoscale; adc, branch if carry zero
;-----------------------------------------------------------------
; Comparison "subroutine":
;-----------------------------------------------------------------
!1,2,Jadc,Jsub;
!1,2,Jcz,Jco;
!1,2,Jnobz,Jbz;
!1,2,Jbo,Jnobo;
Jscale: T←77777, :Jadjust;
Jnoscale: T←ALLONES, :Jadjust;
Jadjust: L←stk1+T+1; L:stk1 + (0 or 100000)
temp←L;
SINK←DISP, BUSODD; dispatch ADC/SUB
T←stk0+T+1, :Jadc;
Jadc: L←temp-T-1, :Jcommon; perform add complement
Jsub: L←temp-T, :Jcommon; perform subtract
Jcommon: T←ONE; warning: not T←0+1
L←stkp-T-1, ALUCY; test ADC/SUB outcome
SINK←DISP, SINK←lgm10, BUS=0, TASK, :Jcz; dispatch on encoded bit 12
Jcz: stkp←L, :Jnobz; carry is zero (stkp←stkp-2)
Jco: stkp←L, :Jbo; carry is one (stkp←stkp-2)
Jnobz: L←mpc+1, TASK, :nextAput; no jump, alignment=>nextAa
Jbz: T←ib, :JBx; jump
Jbo: T←ib, :JBx; jump
Jnobo: L←mpc+1, TASK, :nextAput; no jump, alignment=>nextAa
;-----------------------------------------------------------------
; JIB - see Principles of Operation for description
; assumes:
; stack contains precisely two elements
; if JIB is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after JIB
;-----------------------------------------------------------------
!1,1,JIcom;
JIB: IR←msr0, :JIcom;
!1,2,JIBr,JIWr;
!1,2,JIBe,JIBo;
JIBr: temp←L RSH 1;
XMAR←temp+T; fetch <<cp>+alphabeta+X/2>
SINK←stk0, BUSODD; test which byte we want
T←377, :JIBe; byte mask
JIBe: L←MD AND NOT T, TASK; save left byte
temp←L LCY 8; swap halves
L←temp-1, :Jbranchf;
JIBo: L←MD AND T, :JnA; save right byte
;-----------------------------------------------------------------
; JIW - see Principles of Operation for description
; assumes:
; stack contains precisely two elements
; if JIW is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after JIW
;-----------------------------------------------------------------
JIW: IR←sr1, :JIcom;
JIWr: XMAR←M+T; fetch <<cp>+alphabeta+X>
NOP;
L←MD-1, :Jbranchf; L has offset now
;-----------------------------------------------------------------
; JI common code
; assumes only 2 callers
;-----------------------------------------------------------------
!1,2,JIuge,JIul;
JIcom: L←stkp-T-1, TASK, :JIcomx; stkp←stkp-2
JIcomx: stkp←L;
T←stk0;
L←XMAR←mpc+1; load alphabeta
mpc←L;
L←stk1-T-1; do unsigned compare
ALUCY;
T←MD, :JIuge;
JIuge: L←mpc+1, TASK, :nextAput; out of bounds - to 'nextA'
JIul: L←cp+T, TASK;
temp←L;
T←temp, IDISP;
L←stk0, :JIBr;
;-----------------------------------------------------------------
; L o a d s
;-----------------------------------------------------------------
; Note: These instructions keep track of their parity
!1,2,LLyB,LLyA; keep ball 1 in air
!1,2,LGyB,LGyA; keep ball 1 in air
!1,2,LI0xB,LI0xA; keep ball 1 in air
;-----------------------------------------------------------------
; LLn - push <<lp>+n>
;-----------------------------------------------------------------
; Note: lp is offset by 2, hence the adjustments below
LL0: MAR←lp-T-1, :pushMD;
LL1: MAR←lp-1, :pushMD;
LL2: MAR←lp, :pushMD;
LL3: MAR←lp+1, :pushMD;
LL4: MAR←lp+T+1, :pushMD;
LL5: T←3, :LLyB;
LL6: T←4, :LLyB;
LL7: T←5, :LLyB;
LLyB: MAR←lp+T, :pushMD;
LLyA: MAR←lp+T, :pushMDA;
;-----------------------------------------------------------------
; LLB - push <<lp>+alpha>
;-----------------------------------------------------------------
LLB: IR←sr4, :Getalpha; returns to LLBr
LLBr: T←nlpoffset+T+1, :LLyB; to undiddle lp
;-----------------------------------------------------------------
; LLDB - push <<lp>+alpha>, push <<lp>+alpha+1>
; LLDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
LLDB: T←lp;
T←nlpoffset+T+1, :Dpush;
;-----------------------------------------------------------------
; LGn - push <<gp>+n>
;-----------------------------------------------------------------
; Note: gp is offset by 1, hence the adjustments below
LG0: MAR←gp-1, :pushMD;
LG1: MAR←gp, :pushMD;
LG2: MAR←gp+1, :pushMD;
LG3: MAR←gp+T+1, :pushMD;
LG4: T←3, :LGyB;
LG5: T←4, :LGyB;
LG6: T←5, :LGyB;
LG7: T←6, :LGyB;
LGyB: MAR←gp+T, :pushMD;
LGyA: MAR←gp+T, :pushMDA;
;-----------------------------------------------------------------
; LGB - push <<gp>+alpha>
;-----------------------------------------------------------------
LGB: IR←sr5, :Getalpha; returns to LGBr
LGBr: T←ngpoffset+T+1, :LGyB; to undiddle gp
;-----------------------------------------------------------------
; LGDB - push <<gp>+alpha>, push <<gp>+alpha+1>
; LGDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
LGDB: T←gp;
T←ngpoffset+T+1, :Dpush;
;-----------------------------------------------------------------
; LIn - push n
;-----------------------------------------------------------------
; Note: all BUS dispatches use old stkp value, not incremented one
LI0: L←stkp+1, BUS, :LI0xB;
LI1: L←stkp+1, BUS, :pushT1B;
LI2: T←2, :pushTB;
LI3: T←3, :pushTB;
LI4: T←4, :pushTB;
LI5: T←5, :pushTB;
LI6: T←6, :pushTB;
LI0xB: stkp←L, L←0, TASK, :push0;
LI0xA: stkp←L, BUS=0, L←0, TASK, :push0; BUS=0 keeps branch pending
;-----------------------------------------------------------------
; LIN1 - push -1
;-----------------------------------------------------------------
LIN1: T←ALLONES, :pushTB;
;-----------------------------------------------------------------
; LIB - push alpha
;-----------------------------------------------------------------
LIB: IR←sr2, :Getalpha; returns to pushTB
; Note: pushT1B will handle
; any pending branch
;-----------------------------------------------------------------
; LINB - push (alpha OR 377B8)
;-----------------------------------------------------------------
LINB: IR←sr26, :Getalpha; returns to LINBr
LINBr: T←177400 OR T, :pushTB;
;-----------------------------------------------------------------
; LIW - push alphabeta, assuming:
; if LIW is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after LIW
;-----------------------------------------------------------------
LIW: IR←msr0, :FetchAB; returns to LIWr
LIWr: L←stkp+1, BUS, :pushT1A; duplicates pushTA, but
; because of overlapping
; return points, we
; can't use it
;-----------------------------------------------------------------
; S t o r e s
;-----------------------------------------------------------------
;-----------------------------------------------------------------
; SLn - <<lp>+n>←TOS (popped)
;-----------------------------------------------------------------
!1,2,SLxB,SLxA; keep ball 1 in air
; Note: lp is offset by 2, hence the adjustments below
SL0: MAR←lp-T-1, :StoreB;
SL1: MAR←lp-1, :StoreB;
SL2: MAR←lp, :StoreB;
SL3: MAR←lp+1, :StoreB;
SL4: MAR←lp+T+1, :StoreB;
SL5: T←3, :SLxB;
SL6: T←4, :SLxB;
SL7: T←5, :SLxB;
SLxB: MAR←lp+T, :StoreB;
SLxA: MAR←lp+T, :StoreA;
;-----------------------------------------------------------------
; SLB - <<lp>+alpha>←TOS (popped)
;-----------------------------------------------------------------
SLB: IR←sr6, :Getalpha; returns to SLBr
SLBr: T←nlpoffset+T+1, :SLxB;
;-----------------------------------------------------------------
; SLDB - <<lp>+alpha+1>←TOS (popped), <<lp>+alpha>←TOS (popped), assuming:
; SLDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
SLDB: T←lp;
T←nlpoffset+T+1, :Dpop;
;-----------------------------------------------------------------
; SGn - <<gp>+n>←TOS (popped)
;-----------------------------------------------------------------
; Note: gp is offset by 1, hence the adjustments below
SG0: MAR←gp-1, :StoreB;
SG1: MAR←gp, :StoreB;
SG2: MAR←gp+1, :StoreB;
SG3: MAR←gp+T+1, :StoreB;
;-----------------------------------------------------------------
; SGB - <<gp>+alpha>←TOS (popped)
;-----------------------------------------------------------------
!1,1,SGBx; drop ball 1
SGB: IR←sr7, :Getalpha; returns to SGBr
SGBr: T←ngpoffset+T+1, :SGBx;
SGBx: MAR←gp+T, :StoreB;
;-----------------------------------------------------------------
; SGDB - <<gp>+alpha+1>←TOS (popped), <<gp>+alpha>←TOS (popped), assuming:
; SGDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
SGDB: T←gp;
T←ngpoffset+T+1, :Dpop;
;-----------------------------------------------------------------
; B i n a r y o p e r a t i o n s
;-----------------------------------------------------------------
; Warning! Before altering this list, be certain you understand the additional addressing
; requirements imposed on some of these return locations! However, it is safe to add new
; return points at the end of the list.
!37,40,ADDr,SUBr,ANDr,ORr,XORr,MULr,DIVr,LDIVr,SHIFTr,EXCHr,RSTRr,WSTRr,WSBr,WS0r,WSFr,WFr,
WSDBrb,WFSrb,,,,,,,,,,,,,,;
;-----------------------------------------------------------------
; Binary operations common code
; Entry conditions:
; Both IR and T hold return number. (More precisely, entry at
; 'BincomB' requires return number in IR, entry at 'BincomA' requires
; return number in T.)
; Exit conditions:
; left operand in L (M), right operand in T
; stkp positioned for subsequent push (i.e. points at left operand)
; dispatch pending (for push0) on return
; if entry occurred at BincomA, IR has been modified so
; that mACSOURCE will produce 1
;-----------------------------------------------------------------
; dispatches on stkp-1, so Binpop1 = 1 mod 20B
!17,20,Binpop,Binpop1,Binpop2,Binpop3,Binpop4,Binpop5,Binpop6,Binpop7,,,,,,,,;
!1,2,BincomB,BincomA;
!4,1,Bincomx; shake IR← in BincomA
BincomB: L←T←stkp-1, :Bincomx; value for dispatch into Binpop
Bincomx: stkp←L, L←T;
L←M-1, BUS, TASK; L:value for push dispatch
Bincomd: temp2←L, :Binpop; stash briefly
BincomA: L←2000 OR T; make mACSOURCE produce 1
Binpop: IR←M, :BincomB;
Binpop1: T←stk1;
L←stk0, :Binend;
Binpop2: T←stk2;
L←stk1, :Binend;
Binpop3: T←stk3;
L←stk2, :Binend;
Binpop4: T←stk4;
L←stk3, :Binend;
Binpop5: T←stk5;
L←stk4, :Binend;
Binpop6: T←stk6;
L←stk5, :Binend;
Binpop7: T←stk7;
L←stk6, :Binend;
Binend: SINK←DISP, BUS; perform return dispatch
SINK←temp2, BUS, :ADDr; perform push dispatch
;-----------------------------------------------------------------
; ADD - replace <TOS> with sum of top two stack elements
;-----------------------------------------------------------------
ADD: IR←T←ret0, :BincomB;
ADDr: L←M+T, mACSOURCE, TASK, :push0; M addressing unaffected
;-----------------------------------------------------------------
; ADD01 - replace stk0 with <stk0>+<stk1>
;-----------------------------------------------------------------
!1,1,ADD01x; drop ball 1
ADD01: T←stk1-1, :ADD01x;
ADD01x: T←stk0+T+1, SH=0; pick up ball 1
L←stkp-1, :pushT1B; no dispatch => to push0
;-----------------------------------------------------------------
; SUB - replace <TOS> with difference of top two stack elements
;-----------------------------------------------------------------
SUB: IR←T←ret1, :BincomB;
SUBr: L←M-T, mACSOURCE, TASK, :push0; M addressing unaffected
;-----------------------------------------------------------------
; AND - replace <TOS> with AND of top two stack elements
;-----------------------------------------------------------------
AND: IR←T←ret2, :BincomB;
ANDr: L←M AND T, mACSOURCE, TASK, :push0; M addressing unaffected
;-----------------------------------------------------------------
; OR - replace <TOS> with OR of top two stack elements
;-----------------------------------------------------------------
OR: IR←T←ret3, :BincomB;
ORr: L←M OR T, mACSOURCE, TASK, :push0; M addressing unaffected
;-----------------------------------------------------------------
; XOR - replace <TOS> with XOR of top two stack elements
;-----------------------------------------------------------------
XOR: IR←T←ret4, :BincomB;
XORr: L←M XOR T, mACSOURCE, TASK, :push0; M addressing unaffected
;-----------------------------------------------------------------
; MUL - replace <TOS> with product of top two stack elements
; high-order bits of product recoverable by PUSH
;-----------------------------------------------------------------
!7,1,MULDIVcoma; shakes stack dispatch
!1,2,GoROMMUL,GoROMDIV;
!7,2,MULx,DIVx; also shakes bus dispatch
MUL: IR←T←ret5, :BincomB;
MULr: AC1←L, L←T, :MULDIVcoma; stash multiplicand
MULDIVcoma: AC2←L, L←0, :MULx; stash multiplier or divisor
MULx: AC0←L, T←0+1, :MULDIVcomb; AC0←0 keeps ROM happy
DIVx: AC0←L, T←0, BUS=0, :MULDIVcomb; BUS=0 => GoROMDIV
MULDIVcomb: L←MULDIVretloc+T, SWMODE, :GoROMMUL; prepare return address
GoROMMUL: PC←L, :ROMMUL; go to ROM multiply
GoROMDIV: PC←L, :ROMDIV; go to ROM divide
MULDIVret: :MULDIVret1; No divide - someday a trap
; perhaps, but garbage now.
MULDIVret1: T←AC1; Normal return
L←stkp+1;
L←T, SINK←M, BUS;
T←AC0, :dpush; Note! not a subroutine
; call, but a direct
; dispatch.
;-----------------------------------------------------------------
; DIV - push quotient of top two stack elements (popped)
; remainder recoverable by PUSH
;-----------------------------------------------------------------
DIV: IR←T←ret6, :BincomB;
DIVr: AC1←L, L←T, BUS=0, :MULDIVcoma; BUS=0 => DIVx
;-----------------------------------------------------------------
; LDIV - push quotient of <TOS-1>,,<TOS-2>/<TOS> (all popped)
; remainder recoverable by PUSH
;-----------------------------------------------------------------
LDIV: IR←sr27, :Popsub; get divisor
LDIVf: AC2←L; stash it
IR←T←ret7, :BincomB; L:low bits, T:high bits
LDIVr: AC1←L, L←T, IR←0, :DIVx; stash low part of dividend
; and ensure mACSOURCE of 0.
;-----------------------------------------------------------------
; SHIFT - replace <TOS> with <TOS-1> shifted by <TOS>
; <TOS> > 0 => left shift, <TOS> < 0 => right shift
;-----------------------------------------------------------------
!7,1,SHIFTx; shakes stack dispatch
!1,2,Lshift,Rshift;
!1,2,DoShift,Shiftdone;
!1,2,DoRight,DoLeft;
!1,1,Shiftdonex;
SHIFT: IR←T←ret10, :BincomB;
SHIFTr: temp←L, L←T, TASK, :SHIFTx; L: value, T: count
SHIFTx: count←L;
L←T←count;
L←0-T, SH<0; L: -count, T: count
IR←sr1, :Lshift; IR← causes no branch
Lshift: L←37 AND T, TASK, :Shiftcom; mask to reasonable size
Rshift: T←37, IR←37; equivalent to IR←msr0
L←M AND T, TASK, :Shiftcom; mask to reasonable size
Shiftcom: count←L, :Shiftloop;
Shiftloop: L←count-1, BUS=0; test for completion
count←L, IDISP, :DoShift;
DoShift: L←temp, TASK, :DoRight;
DoRight: temp←L RSH 1, :Shiftloop;
DoLeft: temp←L LSH 1, :Shiftloop;
Shiftdone: SINK←temp2, BUS, :Shiftdonex; dispatch to push result
Shiftdonex: L←temp, TASK, :push0;
;-----------------------------------------------------------------
; D o u b l e - P r e c i s i o n A r i t h m e t i c
;-----------------------------------------------------------------
!1,2,DAStail,DCOMPr; returns from DSUBsub
;-----------------------------------------------------------------
; DADD - add two double-word quantities, assuming:
; stack contains precisely 4 elements
;-----------------------------------------------------------------
!1,1,DADDx; shake B/A dispatch
!1,2,DADDnocarry,DADDcarry;
DADD: T←stk2, :DADDx; T:low bits of right operand
DADDx: L←stk0+T; L:low half of sum
stk0←L, ALUCY; stash, test carry
T←stk3, :DADDnocarry; T:high bits of right operand
DADDnocarry: L←stk1+T, TASK, :DASCtail; L:high half of sum
DADDcarry: L←stk1+T+1, TASK, :DASCtail; L:high half of sum
DASCtail: stk1←L, :DAStail; high-order carry is lost
DAStail: T←2; adjust stack pointer
Dsetstkp: L←stkp-T, TASK, :Setstkp;
;-----------------------------------------------------------------
; DSUB - subtract two double-word quantities, assuming:
; stack contains precisely 4 elements
;-----------------------------------------------------------------
!1,1,DSUBsub; shake B/A dispatch
DSUB: IR←msr0, :DSUBsub;
;-----------------------------------------------------------------
; DCOMP - compare two double-word quantities, assuming:
; stack contains precisely 4 elements
; result left on stack is -1, 0, or +1 (single-precision)
; (i.e. result = sign(stk1,,stk0 DSUB stk3,,stk2) )
;-----------------------------------------------------------------
!1,2,DCOMPnz,DCOMPz;
!1,2,DCOMPpos,DCOMPdone;
DCOMP: IR←sr1, :DSUBsub; perform subtract first
DCOMPr: L←stk1, BUS=0; test high word = 0
L←0-1, SH<0, :DCOMPnz; test high word < 0
DCOMPnz: T←3, :DCOMPpos; non-zero, pending branch +, -
DCOMPz: L←stk0, BUS=0, :DCOMPnz; zero, test low word = 0
DCOMPpos: L←0+1, :DCOMPdone; positive
DCOMPdone: stk0←L, :Dsetstkp; stash result
;-----------------------------------------------------------------
; Double-precision subtract subroutine
;-----------------------------------------------------------------
!1,2,DSUBborrow,DSUBnoborrow;
DSUBsub: T←stk2, :DSUBx; T:low bits of right operand
DSUBx: L←stk0-T; L:low half of difference
stk0←L, ALUCY; borrow = ~carry
T←stk3, :DSUBborrow; T:high bits of right operand
DSUBborrow: L←stk1-T-1, IDISP, TASK, :DASCtail; L:high half of difference
DSUBnoborrow: L←stk1-T, IDISP, TASK, :DASCtail; L:high half of difference
;-----------------------------------------------------------------
; R e a d s
;-----------------------------------------------------------------
; Note: RBr must be odd!
;-----------------------------------------------------------------
; Rn - TOS←<<TOS>+n>
;-----------------------------------------------------------------
R0: T←0, SH=0, :RBr;
R1: T←ONE, SH=0, :RBr;
R2: T←2, SH=0, :RBr;
R3: T←3, SH=0, :RBr;
R4: T←4, SH=0, :RBr;
;-----------------------------------------------------------------
; RB - TOS←<<TOS>+alpha>, assuming:
;-----------------------------------------------------------------
!1,2,ReadB,ReadA; keep ball 1 in air
RB: IR←sr15, :Getalpha; returns to RBr
RBr: L←stkp-1, BUS, :ReadB;
ReadB: stkp←L, :MAStkT; to pushMD
ReadA: stkp←L, BUS=0, :MAStkT; to pushMDA
;-----------------------------------------------------------------
; RDB - temp←<TOS>+alpha, push <<temp>>, push <<temp>+1>, assuming:
; RDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
RDB: IR←sr30, :Popsub; returns to Dpush
;-----------------------------------------------------------------
; RD0 - temp←<TOS>, push <<temp>>, push <<temp>+1>
;-----------------------------------------------------------------
RD0: IR←sr32, :Popsub; returns to RD0r
RD0r: L←0, :Dpusha;
;-----------------------------------------------------------------
; RILP - push <<<lp>+alpha[0-3]>+alpha[4-7]>
;-----------------------------------------------------------------
RILP: L←ret0, :Splitalpha; get two 4-bit values
RILPr: T←lp, :RIPcom; T:address of local 2
;-----------------------------------------------------------------
; RIGP - push <<<gp>+alpha[0-3]>+alpha[4-7]>
;-----------------------------------------------------------------
!3,1,IPcom; shake IR← at WILPr
RIGP: L←ret1, :Splitalpha; get two 4-bit values
RIGPr: T←gp+1, :RIPcom; T:address of global 2
RIPcom: IR←msr0, :IPcom; set up return to pushMD
IPcom: T←-3+T+1; T:address of local or global 0
MAR←lefthalf+T; start memory cycle
L←righthalf;
IPcomx: T←MD, IDISP; T:local/global value
MAR←M+T, :pushMD; start fetch/store
;-----------------------------------------------------------------
; RIL0 - push <<<lp>>>
;-----------------------------------------------------------------
!1,2,RILxB,RILxA;
RIL0: MAR←lp-T-1, :RILxB; fetch local 0
RILxB: IR←msr0, L←0, :IPcomx; to pushMD
RILxA: IR←sr1, L←sr1 AND T, :IPcomx; to pushMDA, L←0(!)
;-----------------------------------------------------------------
; RXLP - TOS←<<TOS>+<<lp>+alpha[0-3]>+alpha[4-7]>
;-----------------------------------------------------------------
RXLP: L←ret3, :Splitalpha; will return to RXLPra
RXLPra: IR←sr34, :Popsub; fetch TOS
RXLPrb: L←righthalf+T, TASK; L:TOS+alpha[4-7]
righthalf←L, :RILPr; now act like RILP
;-----------------------------------------------------------------
; W r i t e s
;-----------------------------------------------------------------
;-----------------------------------------------------------------
; Wn - <<TOS> (popped)+n>←<TOS> (popped)
;-----------------------------------------------------------------
!1,2,WnB,WnA; keep ball 1 in air
W0: T←0, :WnB;
W1: T←ONE, :WnB;
W2: T←2, :WnB;
WnB: IR←sr2, :Wsub; returns to StoreB
WnA: IR←sr3, :Wsub; returns to StoreA
;-----------------------------------------------------------------
; Write subroutine:
;-----------------------------------------------------------------
!7,1,Wsubx; shake IR← dispatch
Wsub: L←stkp-1, BUS, :Wsubx;
Wsubx: stkp←L, IDISP, :MAStkT;
;-----------------------------------------------------------------
; WB - <<TOS> (popped)+alpha>←<TOS-1> (popped)
;-----------------------------------------------------------------
WB: IR←sr16, :Getalpha; returns to WBr
WBr: :WnB; branch may be pending
;-----------------------------------------------------------------
; WSB - act like WB but with stack values reversed, assuming:
; WSB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
!7,1,WSBx; shake stack dispatch
WSB: IR←T←ret14, :BincomA; alignment requires BincomA
WSBr: T←M, L←T, :WSBx;
WSBx: MAR←ib+T, :WScom;
WScom: temp←L;
WScoma: L←stkp-1;
MD←temp;
mACSOURCE, TASK, :Setstkp;
;-----------------------------------------------------------------
; WS0 - act like WSB but with alpha value of zero
;-----------------------------------------------------------------
!7,1,WS0x; shake stack dispatch
WS0: IR←T←ret15, :BincomB;
WS0r: T←M, L←T, :WS0x;
WS0x: MAR←T, :WScom;
;-----------------------------------------------------------------
; WILP - <<lp>+alpha[0-3]>+alpha[4-7] ← <TOS> (popped)
;-----------------------------------------------------------------
WILP: L←ret2, :Splitalpha; get halves of alpha
WILPr: IR←sr2; IPcom will exit to StoreB
T←lp, :IPcom; prepare to undiddle
;-----------------------------------------------------------------
; WXLP - <TOS>+<<lp>+alpha[0-3]>+alpha[4-7] ← <TOS-1> (both popped)
;-----------------------------------------------------------------
WXLP: L←ret4, :Splitalpha; get halves of alpha
WXLPra: IR←sr35, :Popsub; fetch TOS
WXLPrb: L←righthalf+T, TASK; L:TOS+alpha[4-7]
righthalf←L, :WILPr; now act like WILP
;-----------------------------------------------------------------
; WDB - temp←alpha+<TOS> (popped), pop into <temp>+1 and <temp>, assuming:
; WDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
WDB: IR←sr31, :Popsub; returns to Dpop
;-----------------------------------------------------------------
; WD0 - temp←<TOS> (popped), pop into <temp>+1 and <temp>
;-----------------------------------------------------------------
WD0: L←ret6, TASK, :Xpopsub; returns to WD0r
WD0r: L←0, :Dpopa;
;-----------------------------------------------------------------
; WSDB - like WDB but with address below data words, assuming:
; WSDB is A-aligned (also ensures no pending branch at entry)
;-----------------------------------------------------------------
!7,1,WSDBx;
WSDB: IR←sr24, :Popsub; get low data word
WSDBra: saveret←L; stash it briefly
IR←T←ret20, :BincomA; alignment requires BincomA
WSDBrb: T←M, L←T, :WSDBx; L:high data, T:address
WSDBx: MAR←T←ib+T+1; start store of low data word
temp←L, L←T; temp:high data
temp2←L, TASK; temp2:updated address
MD←saveret; stash low data word
MAR←temp2-1, :WScoma; start store of high data word
;-----------------------------------------------------------------
; U n a r y o p e r a t i o n s
;-----------------------------------------------------------------
;-----------------------------------------------------------------
; INC - TOS ← <TOS>+1
;-----------------------------------------------------------------
INC: IR←sr14, :Popsub;
INCr: T←0+T+1, :pushTB;
;-----------------------------------------------------------------
; NEG - TOS ← -<TOS>
;-----------------------------------------------------------------
NEG: L←ret11, TASK, :Xpopsub;
NEGr: L←0-T, :Untail;
;-----------------------------------------------------------------
; DBL - TOS ← 2*<TOS>
;-----------------------------------------------------------------
DBL: IR←sr25, :Popsub;
DBLr: L←M+T, :Untail;
;-----------------------------------------------------------------
; Unary operation common code
;-----------------------------------------------------------------
Untail: T←M, :pushTB;
;-----------------------------------------------------------------
; S t a c k a n d M i s c e l l a n e o u s O p e r a t i o n s
;-----------------------------------------------------------------
;-----------------------------------------------------------------
; PUSH - add 1 to stack pointer
;-----------------------------------------------------------------
!1,1,PUSHx;
PUSH: L←stkp+1, BUS, :PUSHx; BUS checks for overflow
PUSHx: SINK←ib, BUS=0, TASK, :Setstkp; pick up ball 1
;-----------------------------------------------------------------
; POP - subtract 1 from stack pointer
;-----------------------------------------------------------------
POP: L←stkp-1, SH=0, TASK, :Setstkp; L=0 <=> branch 1 pending
; need not check stkp=0
;-----------------------------------------------------------------
; DUP - temp←<TOS> (popped), push <temp>, push <temp>
;-----------------------------------------------------------------
!1,1,DUPx;
DUP: IR←sr2, :DUPx; returns to pushTB
DUPx: L←stkp, BUS, TASK, :Popsuba; don't pop stack
;-----------------------------------------------------------------
; EXCH - exchange top two stack elements
;-----------------------------------------------------------------
!1,1,EXCHx; drop ball 1
EXCH: IR←ret11, :EXCHx;
EXCHx: L←stkp-1; dispatch on stkp-1
L←M+1, BUS, TASK, :Bincomd; set temp2←stkp
EXCHr: T←M, L←T, :dpush; Note: dispatch using temp2
;-----------------------------------------------------------------
; LADRB - push alpha+lp (undiddled)
;-----------------------------------------------------------------
!1,1,LADRBx; shake branch from Getalpha
LADRB: IR←sr10, :Getalpha; returns to LADRBr
LADRBr: T←nlpoffset+T+1, :LADRBx;
LADRBx: L←lp+T, :Untail;
;-----------------------------------------------------------------
; GADRB - push alpha+gp (undiddled)
;-----------------------------------------------------------------
!1,1,GADRBx; shake branch from Getalpha
GADRB: IR←sr11, :Getalpha; returns to GADRBr
GADRBr: T←ngpoffset+T+1, :GADRBx;
GADRBx: L←gp+T, :Untail;
;-----------------------------------------------------------------
; S t r i n g O p e r a t i o n s
;-----------------------------------------------------------------
!7,1,STRsub; shake stack dispatch
!1,2,STRsubA,STRsubB;
!1,2,RSTRrx,WSTRrx;
STRsub: L←stkp-1; update stack pointer
stkp←L;
L←ib+T; compute index and offset
SINK←M, BUSODD, TASK;
count←L RSH 1, :STRsubA;
STRsubA: L←177400, :STRsubcom; left byte
STRsubB: L←377, :STRsubcom; right byte
STRsubcom: T←temp; get string address
MAR←count+T; start fetch of word
T←M; move mask to more useful place
SINK←DISP, BUSODD; dispatch to caller
mask←L, SH<0, :RSTRrx; dispatch B/A, mask for WSTR
;-----------------------------------------------------------------
; RSTR - push byte of string using base (<TOS-1>) and index (<TOS>)
; assumes RSTR is A-aligned (no pending branch at entry)
;-----------------------------------------------------------------
!1,2,RSTRB,RSTRA;
RSTR: IR←T←ret12, :BincomB;
RSTRr: temp←L, :STRsub; stash string base address
RSTRrx: L←MD AND T, TASK, :RSTRB; isolate good bits
RSTRB: temp←L, :RSTRcom;
RSTRA: temp←L LCY 8, :RSTRcom; right-justify byte
RSTRcom: T←temp, :pushTA; go push result byte
;-----------------------------------------------------------------
; WSTR - pop <TOS-2> into string byte using base (<TOS-1>) and index (<TOS>)
; assumes WSTR is A-aligned (no pending branch at entry)
;-----------------------------------------------------------------
!1,2,WSTRB,WSTRA;
WSTR: IR←T←ret13, :BincomB;
WSTRr: temp←L, :STRsub; stash string base
WSTRrx: L←MD AND NOT T, :WSTRB; isolate good bits
WSTRB: temp2←L, L←ret0, TASK, :Xpopsub; stash them, return to WSTRrB
WSTRA: temp2←L, L←ret0+1, TASK, :Xpopsub; stash them, return to WSTRrA
WSTRrA: taskhole←L LCY 8; move new data to odd byte
T←taskhole, :WSTRrB;
WSTRrB: T←mask.T;
L←temp2 OR T;
T←temp; retrieve string address
MAR←count+T;
TASK;
MD←M, :nextA;
;-----------------------------------------------------------------
; F i e l d I n s t r u c t i o n s
;-----------------------------------------------------------------
; temp2 is coded as follows:
; 0 - RF, RFS
; 1 - WF, WSF, WFS
; 2 - RFC
%1,3,2,RFrr,WFrr; returns from Fieldsub
!7,1,Fieldsub; shakes stack dispatch
; !7,1,WFr; (required by WSFr) is implicit in ret17 (!)
;-----------------------------------------------------------------
; RF - push field specified by beta in word at <TOS> (popped) + alpha
; if RF is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after RF
;-----------------------------------------------------------------
RF: IR←sr12, :Popsub;
RFr: L←ret0, :Fieldsub;
RFrr: T←mask.T, :pushTA; alignment requires pushTA
;-----------------------------------------------------------------
; WF - pop data in <TOS-1> into field specified by beta in word at <TOS> (popped) + alpha
; if WF is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after WF
;-----------------------------------------------------------------
; !1,2,WFnzct,WFret; - see location-specific definitions
WF: IR←T←ret17, :BincomB; L:new data, T:address
WFr: newfield←L, L←ret0+1, :Fieldsub; (actually, L←ret1)
WFrr: T←mask;
L←M AND NOT T; set old field bits to zero
temp←L; stash result
T←newfield.T; save new field bits
L←temp OR T, TASK; merge old and new
CYCOUT←L; stash briefly
T←index, BUS=0; get position, test for zero
L←WFretloc, :WFnzct; get return address from ROM
WFnzct: PC←L; stash return
L←20-T, SWMODE; L:remaining count to cycle
T←CYCOUT, :RAMCYCX; go cycle remaining amount
WFret: MAR←frame; start memory
L←stkp-1; pop remaining word
MD←CYCOUT, TASK, :JZNEBeq; stash data, go update stkp
;-----------------------------------------------------------------
; WSF - like WF, but with top two stack elements reversed
; if WSF is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after WSF
;-----------------------------------------------------------------
WSF: IR←T←ret16, :BincomB; L:address, T:new data
WSFr: L←T, T←M, :WFr;
;-----------------------------------------------------------------
; RFS - like RF, but with a word containing alpha and beta on top of stack
; if RFS is A-aligned, B byte is irrelevant
;-----------------------------------------------------------------
RFS: L←ret12, TASK, :Xpopsub; get alpha and beta
RFSra: temp←L; stash for WFSa
L←ret13, TASK, :Xpopsub; T:address
RFSrb: L←ret0, BUS=0, :Fieldsub; returns quickly to WFSa
;-----------------------------------------------------------------
; WFS - like WF, but with a word containing alpha and beta on top of stack
; if WFS is A-aligned, B byte is irrelevant
;-----------------------------------------------------------------
!1,2,Fieldsuba,WFSa;
WFS: L←ret14, TASK, :Xpopsub; get alpha and beta
WFSra: temp←L; stash temporarily
IR←T←ret21, :BincomB; L:new data, T:address
WFSrb: newfield←L, L←ret0+1, BUS=0, :Fieldsub; returns quickly to WFSa
WFSa: frame←L; stash address
T←177400; to separate alpha and beta
L←temp AND T, T←temp, :Getalphab; L:alpha, T:both
; returns to Fieldra
;-----------------------------------------------------------------
; RFC - like RF, but uses <cp>+<alpha>+<TOS> as address
; if RFC is A-aligned, B byte is irrelevant
; alpha in B byte, beta in A byte of word after RF
;-----------------------------------------------------------------
RFC: L←ret16, TASK, :Xpopsub; get index into code segment
RFCr: L←cp+T;
T←M; T:address
L←ret2, :Fieldsub; returns to RFrr
;-----------------------------------------------------------------
; Field instructions common code
; Entry conditions:
; L holds return offset
; T holds base address
; Exit conditions:
; mask: right-justified mask
; frame: updated address, including alpha
; index: left cycles needed to right-justify field [0-15]
; L,T: data word from location <frame> cycled left <index> bits
;-----------------------------------------------------------------
%2,3,1,NotCodeSeg,IsCodeSeg;
Fieldsub: temp2←L, L←T, IR←msr0, TASK, :Fieldsuba; stash return
Fieldsuba: frame←L, :GetalphaA; stash base address
; T: beta, ib: alpha
Fieldra: L←ret5;
saveret←L, :Splitcomr; get two halves of beta
Fieldrb: T←righthalf; index for MASKTAB
MAR←MASKTAB+T; start fetch of mask
T←lefthalf+T+1; L:left-cycle count
L←17 AND T; mask to 4 bits
index←L; stash position
L←MD, TASK; L:mask for caller's use
mask←L; stash mask
SINK←temp2, BUS; temp2=2 <=> RFC
T←frame, :NotCodeSeg; get base address
NotCodeSeg: L←MAR←ib+T, :StashFieldLoc; add alpha
IsCodeSeg: XMAR←ib+T, :DoCycle; add alpha
StashFieldLoc: frame←L, :DoCycle; stash updated address for WF
DoCycle: L←Fieldretloc; return location from RAMCYCX
PC←L;
T←MD, SWMODE; data word into T for cycle
L←index, :RAMCYCX; count to cycle, go do it
Fieldrc: SINK←temp2, BUSODD; return dispatch
L←T←CYCOUT, :RFrr; cycled data word in L and T