|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 188160 (0x2df00)
Types: TextFile
Names: »hpasc1next«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦this⟧ »hpasc1next«
(* L-*)
(* M20 *)
(* COPYRIGHTED 1980 BY MOTOROLA, INC. *)
PROGRAM direct(output,pcode,object,listing);
(* AUGUST 7, 1980 *)
(* GENERATES S-RECORDS *)
(* 370 VERSION *)
(* LONG ADDRESSES *)
(* DIRECT CODE VERSION *)
(* 01/08/82 @ REPLACED BY ^ *
* (. REPLACED BY Æ *
* .) REPLACED BY Å *
* EXTERNAL REPLACED BY XEXTERNAL *
* FILE OF CHAR REPLACED BY TEXT *
* HENRIK JACOBSEN HC *)
CONST strlength = 64;
linelngth = 133;
bitsperdigit = 8;
ldigit = 3;
topdigit = 255;
maxdigit = 256;
maxlabel = 400;
maxcore = 1044;
stkmax = 32;
ndregs = 5; naregs = 3; (*NBR OF REGS TO BE ALLOCATED FOR STACK*)
TYPE optyps = (op0, opli, opt, op2t, opti, opt2i, opi, optli,
op3i, optl2i, optl, opent, opentb, optv, oplab, endop);
pcodes=(xab, xad, xafi, xand, xarg,
xast, xatn, xchk, xchkf, xclo, xcos, xcsp,
xcspf,xcup, xcupf,xcvb, xcvt, xdas, xdata,xdatb,xdec, xdef, xdif,
xdis, xdv, xeio, xend, xent, xentb,xeof, xeol, xequ, xexi, xexp,
xext, xfjp, xgeq, xget, xgrt, xifd, xinc, xind, xinn, xins, xint,
xior, xisc, xixa, xlab, xlca, xlda, xldc, xleq, xles, xlod, xlog,
xlsc, xlspa,xlta, xlupa,xmod, xmov, xmovv,xmp, xmrk, xmst, xneq,
xnew, xng, xnot, xodd, xpag, xpee, xpok, xpos, xput, xrdb, xrdc,
(*604*) xrde, xrdh, xrdi, xrdj, xrdq, xrdr, xrds, xrdv, xret, xrln, xrls, xrnd,
xrst, xrwt, xsb, xscon,xscop,xsdel,xsee, xsgs, xsin, xsins,xslen,
(*RM*) xspos,xsqr, xsqt, xsto, xstp, xstr, xtrc, xujp, xuni, xvjp, xwln, xwrb,
(*604*) xwrc, xwre, xwrh, xwri, xwrj, xwrq, xwrr, xwrs, xwrv, xxjp, xstc, xnone,
xindv, xlodv, xstrv, xstov, xequv, xneqv, xlesv, xleqv,
xgrtv, xgeqv, xcvtsu, xcvtus, xldcv);
mns = xab .. xnone;
targetop = (tmove, tlink, tunlk, trts , ttst, tbgt, tneg, tsubq,
tbtst, tsnz, tadd, tsub, tand, tor, tmuls, tdivs,
tcmp, tclr, ttrap, tdcnt, tbsr, taddq,tcomp, tlbsr,
tmoveq,tseq, tsne, tslt, tsle, tsgt, tsge, tlea ,
tlbgt, tlbra, tlbne, tlbeq, tlblt, tasl, tblt, tjmp,
(*RM*) tpea, tbset, tbz, tswap, tcmpm, tjsr,
tbnz, tbge, tble, tchk, tlble, tlbge,
(*RM*) tldq, texte, tbra, tbne, tequ, tbeq, teor, tdc );
datatype = (atyp,ityp,jtyp,rtyp,qtyp,vtyp,styp,btyp,
(*RM*) ptyp,notatyp,ctyp,htyp,utyp);
message = PACKED ARRAYÆ1..15Å OF char;
errormessage = PACKED ARRAYÆ1..20Å OF char;
iptr = ^instruction;
instruction = RECORD inuse : boolean;
next : iptr;
(*PREV : IPTR;*)
opcode: mns;
optype: optyps;
dtype,d1type: datatype;
opand1: integer;
opand2: integer;
opand3: integer;
opand4: integer;
opstring: ^vstringv;
(*RM*) opset: ^setr
END;
vstringv = RECORD stringl: 0..strlength;
vstringa: PACKED ARRAY Æ 1..strlengthÅ OF char
END;
lint = ARRAY Æ0..ldigitÅ OF integer; (*MULTIPLE PRECISION*)
address = lint; (*SHOULD BE "RECORD BYTE1,BYTE2,BYTE3:0..255 END"*)
labelref = RECORD coreloc: address;
next: ^labelref
END;
labl = RECORD location: address;
defined: boolean;
refed: boolean;
refchain: ^labelref;
END;
labtable = ARRAYÆ0..maxlabelÅ OF labl;
esd = RECORD name: mns; (*XEXTERNAL SYMBOL DEFINITION LIST*)
reference: address;
next: ^esd
END;
eamode = (none,ddirect,adirect,defer,incr,decr,
(*RM*) based,index, pcindex, stshort,
relative,xexternal,labelled, labimmed,
(*RM*) pimmed,
limmed,
(*RM*) immed,absolute,stlong); (* THIS ORDER IS IMPORTANT *)
register = (dnone,d0,d1,d2,d3,d4,d5,d6,d7,
anone,a0,a1,a2,a3,a4,a5,a6,a7);
regkind = (areg, dreg);
effaddr = RECORD mode: eamode;
reg: register;
xreg: register;
displ: integer
END;
(*RM*) setr = RECORD
(*RM*) setv: PACKED ARRAYÆ1..16Å OF char
(*RM*) END;
VAR
debug: integer; (*DIAGNOTSIC FLAG *)
changed: boolean;
ascii: ARRAYÆcharÅ OF integer;
c: char;
errorwr: boolean;
listing: text;
pcode: text;
object: text;
chcnt,linelen: 1..linelngth;
linebuf: ARRAYÆ1..linelngthÅ OF char;
linecount: integer;
machindex: integer;
size: ARRAYÆdatatypeÅ OF integer;
(*RM*) dname: PACKED ARRAYÆdatatypeÅ OF char;
longtypes: SET OF datatype; (* = ÆPTYP,VTYP,STYPÅ*)
(*RM*) lastlabel: integer; (* LABEL OF LAST LABELLED PCODE *)
firsti, lasti, curri, optimi, tempi : iptr;
(*480*) fakei: iptr; (* DUMMY PCODE *)
optim2,optim3,optim4,optim5 : iptr;
curropcode: mns; curroptype: optyps;
templevel: integer; (*LEVEL OF DISPLAY VECTOR CURRENTLY IN A4*)
commutative, switch: boolean;
opsym: PACKED ARRAYÆ1..4Å OF char;
machcode: PACKED ARRAYÆ1..20Å OF char;
vstring, blanks: PACKED ARRAYÆ1..strlengthÅ OF char;
currlabel, highlabel, labeloffset, defvalue: integer;
toplabel : integer;
labeled, dollar, absol: boolean;
level, alength: integer;
flpc: boolean;
fmn: ARRAYÆ'A'..'Z'Å OF mns;
mn: ARRAYÆmnsÅ OF PACKED ARRAYÆ1..4Å OF char;
ot: ARRAYÆmnsÅ OF optyps;
subtype: ARRAYÆmnsÅ OF 0..255;
rt: ARRAYÆpcodesÅ OF integer; (* ADDRESSES OF RUNTIME ROUTINES*)
fl: ARRAYÆmnsÅ OF boolean;
tmn: ARRAYÆtargetopÅ OF PACKED ARRAYÆ1..5Å OF char;
labeltable, proctable: labtable;
pc: address;
ltemp: lint; (* TEMPORARY FOR LONG ARITHMETIC *)
core: ARRAYÆ1..maxcoreÅ OF integer;
genloc: lint; (* CURRENT CODEGEN ADDRESS *)
genstart: lint; (* FIRST ADDRESS OF CODE *)
gensave: lint; (*TEMP TO SAVE GENLOC *)
exproc: address; (* SLOT TO STORE JUMP TO DISTANT PROC IN *)
corecount: 0..maxcore;
coresave: 0..maxcore;
locount: 0..maxcore;
mainflg: boolean; (* MAIN PROGRAM ENCOUNTERED *)
corebase: address;
progstart: address;
rtjump: address; (* START OF RUNTIME JUMP TABLE *)
stkstart: address; (* START OF STACK *)
heapstart: address; (* START OF HEAP *)
jtsize: integer; (* NUMBER OF JUMP TABLE ELEMENTS *)
firstesd: ^esd;
sp: register;
dalloc,aalloc: 0..8;
dtop,dbot: dnone..d7;
atop,abot: anone..a7;
(*REGISTER ALLOCATION VARIABLES*)
(*VALUE OF -1 MEANS NONE CURRENTLY ASSIGNED*)
regtype: ARRAYÆregisterÅ OF datatype;
typestk: ARRAYÆ-1..stkmaxÅ OF datatype;
kindstk: ARRAYÆ-1..stkmaxÅ OF regkind;
stkptr: -1..stkmax;
dregs: ARRAYÆ0..ndregsÅ OF register;
aregs: ARRAYÆ0..naregsÅ OF register;
eaddir, eaadir, eapop, eapush, eaimmed, eaincr,
(*RM*) ealimm, earel, ealab, eapset, ealong,
eabased, eanone, eadefer: effaddr;
aalloccnt, dalloccnt, dpushcnt, apushcnt, dpopcnt, apopcnt: integer;
tempesd: ^esd;
templabref: ^labelref;
(*RM*) hexdata: PACKED ARRAYÆ1..16Å OF char;
FUNCTION succibm(ch:char):char; (* HANDLES EBCDIC ALPHABET *)
BEGIN
IF ch = 'I' THEN succibm := 'J'
ELSE IF ch ='R' THEN succibm := 'S'
ELSE succibm := succ(ch)
END (* SUCCIBM *) ;
FUNCTION hexbin(i: integer): integer; (* CONVERT HEX CHAR TO BINARY *)
BEGIN
IF i >= 65
THEN hexbin := i - 55
ELSE hexbin := i - 48
END; (* HEXBIN *)
PROCEDURE error(msg: errormessage);
BEGIN errorwr:=true;writeln(listing,'**ERROR** ',msg) END; (* ERROR *)
(*480*) FUNCTION nextpcod (pcode: iptr) : iptr;
(*480*) (* GIVEN A PCODE, FIND NEXT ACTIVE ONE; IF NONE, RETURN FAKE ONE *)
(*480*) BEGIN
(*480*) REPEAT
(*480*) pcode := pcode^.next;
(*480*) IF pcode = NIL THEN pcode := fakei
(*480*) UNTIL pcode^.inuse;
(*480*) nextpcod := pcode
(*480*) END; (*NEXTPCOD *)
FUNCTION conditional(inst:iptr):integer;
(* IF CONDITIONAL P-CODE, RETURN NUMBER, ELSE RETURN 0 *)
BEGIN
WITH inst^ DO
BEGIN
conditional := 0;
IF opcode = xneq THEN conditional := 1 ELSE
IF opcode = xequ THEN conditional := 2 ELSE
IF opcode = xles THEN conditional := 3 ELSE
IF opcode = xleq THEN conditional := 4 ELSE
IF opcode = xgrt THEN conditional := 5 ELSE
IF opcode = xgeq THEN conditional := 6
END (*WITH*)
END; (*CONDITIONAL*)
FUNCTION gethex:boolean;
VAR i: integer;
BEGIN
gethex := false;
WHILE (linebufÆchcntÅ=' ') AND (chcnt<linelen) DO chcnt := chcnt + 1;
IF linebufÆchcntÅ <> ' '
THEN BEGIN
gethex := true;
FOR i := 0 TO 3 DO
BEGIN
ltempÆiÅ := 16 * hexbin(asciiÆlinebufÆchcntÅÅ) +
hexbin(asciiÆlinebufÆchcnt + 1ÅÅ);
chcnt := chcnt + 2
END
END;
IF linebufÆchcntÅ <> ' ' THEN gethex := false;
END ; (*GETHEX*)
PROCEDURE getstring;
BEGIN
WHILE (linebufÆchcntÅ = ' ') AND (chcnt < linelen) DO
chcnt := chcnt + 1;
IF linebufÆchcntÅ <> '''' THEN
BEGIN error('STRING EXPECTED ');
vstring := blanks END
ELSE BEGIN
alength := 0;
REPEAT
REPEAT
chcnt := chcnt + 1;
alength := alength + 1;
IF alength <= strlength THEN
vstringÆalengthÅ := linebufÆchcntÅ;
UNTIL (linebufÆchcntÅ = '''') OR (chcnt = linelen);
chcnt := chcnt + 1
UNTIL linebufÆchcntÅ <> '''';
IF alength > strlength
THEN alength := strlength
ELSE alength := alength - 1;
END
END; (*GETSTRING*)
FUNCTION getinteger :integer;
VAR i: integer;
ch: char;
minus: boolean;
BEGIN
WHILE (linebufÆchcntÅ = ' ') AND (chcnt < linelen) DO
chcnt := chcnt + 1;
i := 0;
minus := linebufÆchcntÅ = '-';
IF minus THEN chcnt := chcnt + 1;
WHILE (linebufÆchcntÅ <> ' ') AND (chcnt < linelen) DO
BEGIN
ch := linebufÆchcntÅ;
IF (ch >= '0') AND (ch <= '9')
THEN i := i*10 + ord(ch)-ord('0')
(*RM*) ELSE IF linebufÆchcntÅ <> ',' THEN error('MALFORMED INTEGER ');
chcnt := chcnt + 1
END;
IF minus THEN getinteger := -1*i ELSE getinteger := i
END; (*GETINTEGER*)
PROCEDURE buildaddr (VAR addr: effaddr; kmode: eamode;
kreg, kxreg: register; kdispl: integer);
BEGIN WITH addr DO BEGIN
mode := kmode;
reg := kreg;
xreg := kxreg;
displ:= kdispl
END END; (*BUILDADDR*)
(*----------------------------------------------------------------------
MULTIPLE PRECISION ARITHMETIC ROUTINES
-----------------------------------------------------------------------*)
PROCEDURE plint(VAR fil:text; x:lint); (* WRITE LONG VALUE *)
VAR i: integer;
BEGIN
FOR i := 0 TO ldigit DO
write(fil,hexdataÆ(xÆiÅ DIV 16) + 1Å:1,
hexdataÆ(xÆiÅ MOD 16) + 1Å:1);
END; (*PLINT*)
FUNCTION sdv(VAR x: lint; s: integer): integer; (*DIVIDE LONG BY INTEGER *)
(* X := X / S (UNSIGNED) *)
VAR
i, carry: integer;
z: lint;
BEGIN
FOR i := ldigit DOWNTO 0 DO zÆiÅ := 0;
IF s > 0 THEN
BEGIN
carry := 0;
FOR i := 0 TO ldigit DO
BEGIN
carry := carry * maxdigit + xÆiÅ;
WHILE carry >= s DO
BEGIN
zÆiÅ := zÆiÅ + 1;
carry := carry - s;
END;
END;
END;
FOR i := ldigit DOWNTO 0 DO xÆiÅ := zÆiÅ;
sdv := carry;
END; (*SDV*)
FUNCTION short(VAR x:lint):boolean; (* DETERMINE IF LINT IS SHORT*)
VAR
i: integer;
BEGIN
short := false;
IF ((xÆ0Å=0) AND (xÆ1Å=0) AND (xÆ2Å<128))
OR ((xÆ0Å=255) AND (xÆ1Å=255) AND (xÆ2Å>127))
THEN short := true
END; (*SHORT*)
PROCEDURE clr(VAR x: lint); (* CLEAR LONG VALUE *)
(* X := 0 *)
VAR
i: integer;
BEGIN
FOR i := ldigit DOWNTO 0 DO xÆiÅ := 0;
END; (*CLR*)
PROCEDURE lsb(VAR x: lint; y: lint); (* SUBTRACT LONG FROM LONG *)
VAR
i, b: integer;
BEGIN
b := 0; (* SET BORROW TO 0 *)
FOR i := ldigit DOWNTO 0 DO
BEGIN
xÆiÅ := xÆiÅ - yÆiÅ - b;
b := 0; (* RESET CARRY *)
IF xÆiÅ < 0
THEN
BEGIN
xÆiÅ := xÆiÅ + 256;
b := 1
END (*THEN*)
END (*FOR*)
END; (*LSB*)
PROCEDURE ssb(VAR x: lint; s: integer); FORWARD;
PROCEDURE sad(VAR x: lint; s: integer); (* ADD INTEGER TO LONG *)
(* X := X + S *)
VAR
i,carry: integer;
z: lint;
BEGIN
IF s < 0
THEN ssb(x, -s)
ELSE
BEGIN
carry := s;
FOR i := ldigit DOWNTO 0 DO
BEGIN
zÆiÅ := xÆiÅ + carry;
IF zÆiÅ > topdigit
THEN
BEGIN
carry := zÆiÅ DIV maxdigit;
zÆiÅ := zÆiÅ MOD maxdigit;
END
ELSE carry := 0;
END;
FOR i := ldigit DOWNTO 0 DO xÆiÅ := zÆiÅ;
END
END; (*SAD*)
PROCEDURE ssb(* (VAR X: LINT; S: INTEGER) *); (* SUBTRACT INTEGER FROM LONG *)
(* X := X - S *)
VAR
i,borrow: integer;
z: lint;
BEGIN
(*0321D*) IF (s<0) AND (-s > 0) (* CHECKS FOR -32768 *)
THEN sad(x, -s)
ELSE
BEGIN
borrow := s;
FOR i := ldigit DOWNTO 0 DO
BEGIN
zÆiÅ := xÆiÅ - borrow;
IF zÆiÅ < 0
THEN
BEGIN
borrow := - (zÆiÅ DIV maxdigit);
zÆiÅ := zÆiÅ MOD maxdigit;
IF zÆiÅ < 0
THEN
BEGIN
borrow := borrow + 1;
zÆiÅ := zÆiÅ + maxdigit;
END; (*BEGIN*)
END (*THEN*)
ELSE borrow := 0;
END; (*FOR*)
FOR i := ldigit DOWNTO 0 DO xÆiÅ := zÆiÅ;
END (*ELSE*)
END; (*SSB*)
PROCEDURE lasgn(VAR x: integer; y: lint); (* MOVE LONG TO SHORT*)
VAR
i, j: integer;
BEGIN
j := yÆldigit -1Å;
IF j > 127 THEN j := j - 256;
x := 256 * j + yÆldigitÅ
END; (* LASGN *)
PROCEDURE asgn(VAR x: lint; y: lint); (* MOVE LONG TO LONG *)
(* X := Y *)
BEGIN
x := y;
END; (*ASGN*)
PROCEDURE sasgn(VAR x: lint; y: integer); (* MOVE INTEGER TO LONG *)
(* X := LINT Y *)
VAR
i: integer;
BEGIN
clr(x);
IF y > 0
THEN sad(x,y)
ELSE IF y < 0
THEN ssb(x,-y);
END; (*ASGN*)
PROCEDURE shl(VAR x: lint; s: integer); (* SHIFT LONG LEFT INTEGER TIMES*)
(* X := X SHIFTED LEFT BY S BITS *)
VAR
i,j,carry: integer;
z: lint;
BEGIN
FOR i := ldigit DOWNTO 0 DO zÆiÅ := xÆiÅ;
FOR j := 1 TO s DIV bitsperdigit DO
BEGIN
FOR i := 0 TO ldigit - 1 DO zÆiÅ := zÆi + 1Å;
zÆldigitÅ := 0;
END;
FOR j := 1 TO s MOD bitsperdigit DO
BEGIN
carry := 0;
FOR i := ldigit DOWNTO 0 DO
BEGIN
zÆiÅ := 2 * zÆiÅ + carry;
IF zÆiÅ > topdigit
THEN
BEGIN
zÆiÅ := zÆiÅ - maxdigit;
carry := 1;
END (*THEN*)
ELSE carry := 0;
END (*FOR*)
END; (*FOR*)
FOR i := ldigit DOWNTO 0 DO xÆiÅ := zÆiÅ;
END; (*SHL*)
(*-------------------------------------------------------------------------
CODE GENERATION SECTION
-------------------------------------------------------------------------*)
(*604*) PROCEDURE pcprint;
(*604*) BEGIN
(*604*) IF odd(debug)
(*604*) THEN
(*604*) BEGIN
(*604*) plint(listing,pc);
(*604*) write(listing,' ':21)
(*604*) END
(*604*) END; (* PCPRINT*)
PROCEDURE emitcode;
VAR
ii, i, j, hi, md, lo, chksum: integer;
save: lint;
PROCEDURE emitbyte(data: integer); (*EXPAND BYTE INTO TWO HEX DIGITS*)
VAR
hi, lo: integer;
ch: char;
BEGIN (*EMITBYTE*)
chksum := chksum + data;
hi := data DIV 16;
lo := data MOD 16;
IF hi < 10
THEN ch := chr(ord('0') + hi)
ELSE ch := chr(ord('A') + hi - 10);
write(object,ch);
IF lo < 10
THEN ch := chr(ord('0') + lo)
ELSE ch := chr(ord('A') + lo - 10);
write(object,ch);
END; (*EMITBYTE*)
BEGIN (*EMITCODE*)
IF (corecount>0)
THEN
BEGIN
i := locount;
WHILE i <= corecount DO
BEGIN
chksum := 0;
IF corecount - i >= 31
THEN j := i + 31
ELSE j := corecount;
asgn(save,genloc);
(* LO := GENLOCÆLDIGITÅ; *)
(* MD := GENLOCÆLDIGIT-1Å; *)
(* HI := GENLOCÆLDIGIT-2Å; *)
lo := sdv(genloc,256);
md := sdv(genloc,256);
hi := sdv(genloc,256);
asgn(genloc,save);
IF hi = 0
THEN BEGIN
write(object,'S1');
emitbyte(j-i+4)
END
ELSE BEGIN
write(object,'S2');
emitbyte(j-i+5)
END;
IF hi <> 0
THEN emitbyte(hi);
emitbyte(md);
emitbyte(lo); (* EMIT ADDRESS FIELD *)
FOR ii := i TO j DO
BEGIN
IF (coreÆiiÅ < 0) OR (coreÆiiÅ > 256)
THEN
BEGIN
error('BAD EMIT DATA ');
writeln(listing,'VALUE ',coreÆiiÅ,' AT ',ii,
' PC=') ;
plint(listing,pc)
END; (*THEN*)
emitbyte(coreÆiiÅ);
END; (*FOR*)
emitbyte(255-(chksum MOD 256));
writeln(object,' ');
sad(genloc,j-i+1);
i := j + 1;
END; (*WHILE*)
corecount := 0;
IF locount = 1 THEN corebase := pc;
END; (*THEN*)
END; (*EMITCODE*)
PROCEDURE emitend;
BEGIN
writeln(object,'S9030000FC');
END; (*EMITEND*)
PROCEDURE flush; (*CURRENTLY CALLED AT END OF EACH BASIC BLOCK*)
(*I.E. ONLY LOCAL OPTIMIZATION IS BEING DONE*)
PROCEDURE generate(instr: iptr);
VAR source, dest: effaddr;
tempesd: ^esd;
k: integer;
opcde: targetop;
PROCEDURE resetlabel;
VAR i: integer;
BEGIN
FOR i:= 0 TO highlabel DO
BEGIN labeltableÆiÅ.defined :=false;
labeltableÆiÅ.refchain := NIL;
labeltableÆiÅ.refed :=false
END;
IF toplabel < highlabel THEN toplabel := highlabel;
(*#*) labeloffset := labeloffset + highlabel; highlabel := 0;
END;
PROCEDURE genx(op: targetop; size: integer; ea1,ea2: effaddr); FORWARD;
(*RM*) PROCEDURE vstringimmed(startch,count: integer);
(*RM*) VAR k: integer;
(*RM*) BEGIN
WITH instr^ DO BEGIN
write(listing,'''':1);
k := startch;
(*RM*) WHILE k < startch + count DO BEGIN
eaimmed.displ := asciiÆopstring^.vstringaÆkÅÅ;
genx(tdc,1,eaimmed,eanone);
(*RM*) IF opstring^.vstringaÆkÅ = '''' THEN write(listing,'''''':2)
(*RM*) ELSE write(listing,opstring^.vstringaÆkÅ:1);
(*RM*) k := k + 1
(*RM*) END;
(*RM*) write(listing,'''':1)
(*RM*) END (* WITH *)
(*RM*) END; (* VSTRINGIMMED *)
(*RM*) PROCEDURE hexvstring(k:integer);
(*RM*) VAR i:integer;
ch:char;
(*RM*) BEGIN
(*RM*) WITH instr^ DO BEGIN
(*RM*) FOR i := 1 TO 8 DO
BEGIN
ch:=opset^.setvÆ k + 1 Å;
(*RM*) write(listing, ch :1) ;
IF NOT odd(i)
THEN BEGIN
eaimmed.displ := 16 *
hexbin(asciiÆopset^.setvÆk + i - 1ÅÅ) +
hexbin(asciiÆopset^.setvÆk + iÅÅ);
genx(tdc,1,eaimmed,eanone);
END; (*IF*)
(*RM*) END (*FOR*)
END; (*WITH*)
(*RM*) END; (* HEXVSTRING *)
PROCEDURE genx (* (OP:TARGETOP; SIZE: INTEGER; EA1,EA2: EFFADDR) *) ;
VAR i, subop, opc, opi: integer;
PROCEDURE printinstruction;
VAR bytes: integer;
PROCEDURE printea(ea: effaddr);
VAR ar: integer;
BEGIN WITH ea DO
BEGIN
ar := ord(reg)-ord(a0);
CASE mode OF
none: ;
ddirect: write(listing, 'D',ord(reg)-ord(d0):1);
adirect: write(listing, 'A', ar:1);
defer: write(listing, '(A', ar:1, ')');
incr: write(listing, '(A', ar:1,')+');
decr: write(listing, '-(A', ar:1,')');
based: write(listing, displ:1, '(A', ar:1,
')');
index: write(listing, displ:1,
'(A', ar:1, ',', 'D', ord(xreg)-ord(d0):1,')');
absolute: write(listing,displ:1);
immed: write(listing,'#',displ:1);
relative: BEGIN
write(listing,'*');
IF displ> 0 THEN
write(listing,'+',displ:1)
ELSE IF displ< 0 THEN write(listing,displ:1)
END;
labelled: IF curropcode = xcup
THEN write(listing,'USER':4,displ:1)
ELSE write(listing,
'L',displ + labeloffset:1);
labimmed: BEGIN
IF displ <0 THEN write(listing,'#-L',-displ:1)
ELSE write(listing,'#L',displ + labeloffset:1)
END;
(*RM*) pimmed: BEGIN
(*RM*) write(listing,'#$':2);
(*RM*) hexvstring(displ)
(*RM*) END;
(*RM*) stshort: BEGIN
(*RM*) write(listing,'#':1);
(*RM*) vstringimmed(displ,2)
(*RM*) END;
(*RM*) stlong : BEGIN
(*RM*) write(listing,'#':1);
(*RM*) vstringimmed(displ,4)
(*RM*) END;
limmed: BEGIN
WITH instr^ DO BEGIN
write(listing,'#$');
write(listing,hexdataÆopand1 DIV 16 + 1Å);
write(listing,hexdataÆopand1 MOD 16 + 1Å);
write(listing,hexdataÆopand2 DIV 16 + 1Å);
write(listing,hexdataÆopand2 MOD 16 + 1Å);
write(listing,hexdataÆopand3 DIV 16 + 1Å);
write(listing,hexdataÆopand3 MOD 16 + 1Å);
write(listing,hexdataÆopand4 DIV 16 + 1Å);
write(listing,hexdataÆopand4 MOD 16 + 1Å);
END
END;
(*RM*) xexternal: BEGIN write(listing,'X',mnÆinstr^.opcodeÅ:3);
IF instr^.d1type <> notatyp THEN
write(listing,dnameÆinstr^.d1typeÅ:1);
IF instr^.dtype <> notatyp THEN
write(listing,dnameÆinstr^.dtypeÅ:1);
END; (* XEXTERNAL *)
pcindex: BEGIN write(listing,'***PCINDEX***') END;
END END;
END; (*PRINTEA*)
BEGIN (*PRINTINSTRUCTION*)
write(listing, ' ':10);
FOR bytes:=1 TO 5 DO IF tmnÆop,bytesÅ<>' ' THEN write
(listing, tmnÆop,bytesÅ);
IF size = 1 THEN write(listing,'.B ')
ELSE IF size >= 4 THEN write(listing,'.L ')
ELSE write(listing,' ');
printea(ea1);
IF ea2.mode <> none THEN BEGIN
write(listing,',');
printea(ea2);
END;
IF flpc THEN
BEGIN
write(listing,' ':2,'***** FLUSH ',
mnÆinstr^.opcodeÅ);
flpc := false
END;
IF ea1.reg = a3
THEN write(listing,' ',mnÆinstr^.opcodeÅ:3,
dnameÆinstr^.d1typeÅ:1,
dnameÆinstr^.dtypeÅ:1);
writeln(listing,' ');
END; (*PRINTINSTRUCTION*)
PROCEDURE buffer(valu: lint; size: integer); (* PUT LONG VALUE IN CORE*)
VAR
i,b: integer;
v: lint;
PROCEDURE hexwrite(data: integer); (*WRITE CONTENTS OF CORE CELL*)
VAR hi, lo: integer;
ch: char;
BEGIN
IF (data < 0) OR (data > 256)
THEN error('BAD DATA IN HEXWRITE');
hi := data DIV 16;
lo := data MOD 16;
IF hi < 10
THEN ch := chr(ord('0') + hi)
ELSE ch := chr(ord('A') + hi - 10);
IF odd(debug) AND (op <> tdc) THEN
BEGIN
machcodeÆmachindexÅ := ch;
machindex := machindex + 1
END;
IF lo < 10
THEN ch := chr(ord('0') + lo)
ELSE ch := chr(ord('A') + lo - 10);
IF odd(debug) AND (op <> tdc) THEN
BEGIN
machcodeÆmachindexÅ := ch;
machindex := machindex + 1
END;
END; (*HEXWRITE*)
BEGIN (* BUFFER *)
IF size + corecount > maxcore - 22
THEN emitcode;
FOR i := 1 TO size DO
coreÆcorecount + iÅ := valuÆldigit - size + iÅ;
FOR i := 1 TO size DO hexwrite(coreÆcorecount + iÅ );
corecount := corecount + size;
sad(pc, size);
IF odd(debug) AND (op <> tdc) THEN machindex := machindex + 1;
END; (*BUFFER *)
PROCEDURE gen8(a: integer);
VAR
l: lint;
BEGIN
sasgn(l, a);
buffer(l, 1);
END; (* GEN8*)
PROCEDURE gen16(a: integer);
VAR
l: lint;
BEGIN
sasgn(l, a);
buffer(l, 2);
END; (*GEN16*)
PROCEDURE gen448(a,b,c: integer);
VAR
l: lint;
BEGIN
IF c < 0 THEN c := c + 256; (* ADJUST TO ONE BYTE *)
sasgn(l, a);
shl(l, 4); sad(l, b);
shl(l, 8); sad(l, c);
buffer(l, 2)
END; (*GEN448*)
PROCEDURE gen43333(a,b,c,d,e: integer);
VAR
l: lint;
BEGIN
sasgn(l, a);
shl(l, 3); sad(l, b);
shl(l, 3); sad(l, c);
shl(l, 3); sad(l, d);
shl(l, 3); sad(l, e);
buffer(l, 2);
END; (*GEN43333*)
PROCEDURE gen4318(a,b,c,d: integer);
VAR
l: lint;
BEGIN
IF d < 0 THEN d := d + 256; (* ADJUST LENGTH OF OPERAND *)
sasgn(l, a);
shl(l, 3); sad(l, b);
shl(l, 1); sad(l, c);
shl(l, 8); sad(l, d);
buffer(l, 2);
END; (*GEN4318*)
PROCEDURE gennull; (* WRITE SOME SPACES*)
BEGIN
END; (*GENNULL*)
PROCEDURE geneaext(e: effaddr);
VAR
r: integer;
k: lint;
BEGIN
IF e.mode >= based
THEN IF (e.mode=index) OR (e.mode=pcindex)
THEN
BEGIN
IF e.displ < 0 THEN e.displ := e.displ + 256;
IF e.xreg < anone
THEN r := ord(e.xreg) - ord(d0)
ELSE r := ord(e.xreg) - ord(a0) + 8;
sasgn(k, r);
shl(k, 1);
IF NOT(regtypeÆe.xregÅ IN Æityp,btyp,ctyp,htypÅ)
THEN sad(k, 1);
shl(k, 11); sad(k, e.displ);
buffer(k, 2);
END
ELSE
BEGIN
IF e.mode = relative THEN e.displ := e.displ - 2;
sasgn(k, e.displ);
IF (e.mode = immed) AND (size = 4) THEN buffer(k,4) ELSE
IF NOT ( e.mode IN Æpimmed, stshort, stlong,limmedÅ ) THEN
buffer(k, 2) (* 4 INSTEAD OF 2 FOR ABS/IMMED LONG*)
ELSE IF e.mode = limmed
THEN BEGIN
WITH instr^ DO BEGIN
kÆ0Å := opand1;
kÆ1Å := opand2;
kÆ2Å := opand3;
kÆ3Å := opand4;
buffer(k,4)
END
END
END
ELSE IF op <> tmove
THEN gennull
END; (*GENEAEXT*)
FUNCTION reg(ea: effaddr): integer;
(* GENERATE CODED VALUE OF REG FIELD FOR GIVEN EFFECTIVE ADDRESS *)
BEGIN
IF ea.mode < stshort
THEN IF (ea.reg = dnone) OR (ea.reg = anone)
THEN error('A/DNONE IN SUBR REG ')
ELSE IF ea.reg < anone
THEN reg := ord(ea.reg) - ord(d0)
ELSE reg := ord(ea.reg) - ord(a0)
ELSE CASE ea.mode OF
absolute: reg := 0;
relative: reg := 2;
pcindex: reg := 3;
immed: reg := 4;
limmed: reg := 4;
labelled: reg := 2; (*?*)
labimmed: reg := 4; (*?*)
pimmed: reg := 4;
stshort: reg := 4;
stlong: reg := 4;
xexternal: reg := 2;
END (*CASE*)
END; (*REG*)
FUNCTION mode(ea: effaddr): integer;
(* GENERATE CODED VALUE OF MODE FIELD FOR GIVEN EFFECTIVE ADDRESS*)
BEGIN
CASE ea.mode OF
ddirect: mode := 0;
adirect: mode := 1;
defer: mode := 2;
incr: mode := 3;
decr: mode := 4;
based: mode := 5;
index: mode := 6;
pcindex: mode := 7;
absolute:mode := 7;
immed: mode := 7;
limmed: mode := 7;
relative:mode := 7;
labelled:mode := 7; (*?*)
labimmed:mode := 7; (*?*)
none: mode := 7;
pimmed: mode := 7;
stshort: mode := 7;
stlong: mode := 7;
xexternal:mode := 7;
END (* CASE*)
END; (*MODE*)
BEGIN (*GENX*)
IF ea1.mode = limmed
THEN WITH instr^ DO
IF opand1 + opand2 + opand3 + opand4 = 0
THEN BEGIN
IF (op=tmove) OR (op=tcmp)
THEN BEGIN
ea1.mode := immed;
ea1.displ := 0
END
END
ELSE IF opand1 + opand2 + opand3 = 0
THEN BEGIN
IF (op=tadd) OR (op=tsub)
AND (opand4 > 0) AND (opand4 <= 8)
THEN BEGIN
ea1.mode := immed;
ea1.displ := opand4
END
ELSE
IF (op=tmove)
AND (opand4 > 0) AND (opand4 < 128)
THEN BEGIN
ea1.mode := immed;
ea1.displ := opand4
END
END
ELSE
IF (opand1 + opand2 + opand3 = 765)
AND (op=tmove)
AND (opand4 > 127) AND (opand4 < 256)
THEN BEGIN
ea1.mode := immed;
ea1.displ := opand4 -256
END;
(* CHECK FOR MOVEQ, ADDQ, SUBQ *)
IF op = tmove
THEN
BEGIN
IF ((ea1.mode=immed) AND (ea1.displ=0) AND (ea2.mode<>adirect))
THEN
BEGIN
ea1 := ea2;
ea2 := eanone;
op := tclr;
END
ELSE
(*0423A*) IF (ea2.mode = ddirect) AND (ea1.displ > -128)
AND (ea1.displ < 128)
AND (ea1.mode = immed)
THEN
BEGIN
op := tmoveq;
size := 4
END; (*THEN*)
END; (* THEN*)
IF (op = tadd) OR (op = tsub)
THEN
BEGIN
IF (ea1.mode=immed) AND (ea1.displ > 0) AND (ea1.displ<=8)
THEN
BEGIN
IF op = tadd
THEN op := taddq
ELSE op := tsubq
END (*THEN*)
END; (*THEN*)
(* CHECK FOR CMP THAT CAN BE TST *)
IF op = tcmp
THEN
BEGIN
IF ((ea1.mode=immed) AND (ea1.displ = 0) AND (ea2.mode<>adirect))
THEN
BEGIN
ea1 := ea2;
ea2 := eanone;
op := ttst
END
END;
IF odd(debug) AND (op <> tdc) AND (op<>tequ) THEN BEGIN plint(listing,pc);
write(listing,' ')
END ;
CASE op OF
tmove: BEGIN
CASE size OF 1: i:=1;
2: i:=3;
(*RM*) 4: i:=2
END; (*CASE*)
gen43333(i, reg(ea2), mode(ea2), mode(ea1), reg(ea1));
geneaext(ea1); geneaext(ea2);
IF (ea1.mode < based) AND (ea2.mode < based)
THEN gennull
END; (*TMOVE*)
tlink: BEGIN
gen43333(4,7,1,2,ord(ea1.reg)-ord(a0));
geneaext(ea2)
END; (*TLINK*)
tunlk: BEGIN
gen43333(4,7,1,3,ord(ea1.reg)-ord(a0));
gennull
END;
trts : BEGIN
gen43333(4,7,1,6,5);
gennull
END;
ttst, tclr, tneg, tcomp:
BEGIN
IF size = 1
THEN i := 0
ELSE IF size = 4
THEN i := 2
ELSE i := 1;
CASE op OF ttst: subop := 5;
tclr: subop := 1;
tneg: subop := 2;
tcomp: subop := 3
END (*CASE*);
gen43333(4,subop,i,mode(ea1),reg(ea1));
geneaext(ea1);
END; (*TTST*)
tbtst, tbset:
BEGIN
IF op = tbtst
THEN subop := 0 (*BTST*)
ELSE subop := 3; (*BSET*)
IF ea1.mode = immed
THEN
BEGIN
gen43333(0,4,subop,mode(ea2),reg(ea2));
geneaext(ea2);
geneaext(ea1) (* BIT NUMBER *)
END
ELSE
BEGIN
gen43333(0,reg(ea1),4+subop,mode(ea2),reg(ea2));
geneaext(ea2);
END
END; (*TBTST*)
tor, teor, tsub, tand, tadd, tcmp:
BEGIN
IF size = 1
THEN i := 0
ELSE IF size = 4
THEN i := 2
ELSE i := 1;
CASE op OF
tor: BEGIN opc := 8; opi := 0 END;
teor:BEGIN opc := 11; opi := 5 END;
tsub: BEGIN opc := 9; opi := 2 END;
tcmp: BEGIN opc := 11; opi := 6 END;
tand: BEGIN opc := 12; opi := 1 END;
tadd: BEGIN opc := 13; opi := 3 END
END; (*CASE*)
IF (ea1.mode IN Æimmed,labelled,labimmed,limmed,
pimmed,stshort,stlongÅ) AND (ea2.mode <> adirect)
THEN
BEGIN
gen43333(0,opi,i,mode(ea2),reg(ea2));
geneaext(ea1);
IF ea2.mode >= based
THEN geneaext(ea2);
END (*THEN*)
ELSE
IF ea2.mode = adirect
THEN
BEGIN
IF i = 2
THEN subop := 7
ELSE subop := 3;
gen43333(opc,reg(ea2),subop,mode(ea1),reg(ea1));
geneaext(ea1)
END (*THEN*)
ELSE
IF (ea2.mode=ddirect) AND (op<>teor)
THEN
BEGIN
gen43333(opc,reg(ea2),i,
mode(ea1),reg(ea1));
geneaext(ea1)
END (*THEN*)
ELSE
IF ea1.mode = ddirect
THEN
BEGIN
IF op = tcmp
THEN
error('TO MEMORY COMPARE ');
gen43333(opc,reg(ea1),4+i,
mode(ea2),reg(ea2));
geneaext(ea2)
END (*THEN*)
ELSE error('MEMORY/MEMORY +-ETC ')
END; (*TOR*)
tmuls, tdivs:
BEGIN
CASE op OF
tmuls: opc := 12;
tdivs: opc := 8
END; (*CASE*)
gen43333(opc,reg(ea2),7,mode(ea1),reg(ea1));
geneaext(ea1)
END; (*TMULS*)
ttrap: BEGIN
gen448(4,14,64 + ea1.displ);
gennull
END; (*TTRAP*)
tseq, tsne, tslt, tsnz, tsle, tsgt, tsge:
BEGIN
CASE op OF
tseq: subop := 7;
tsne: subop := 6;
tsnz: subop := 6;
tslt: subop := 13;
tsle: subop := 15;
tsgt: subop := 14;
tsge: subop := 12;
END; (*CASE*)
gen43333(5,subop DIV 2,4*(subop MOD 2) + 3,mode(ea1),reg(ea1));
geneaext(ea1)
END; (*TSEQ*)
tjmp, tjsr: BEGIN
CASE op OF
tjmp: subop := 3;
tjsr: subop := 2
END; (*CASE*)
gen43333(4,7,subop,mode(ea1),reg(ea1));
geneaext(ea1)
END; (*TJMP*)
tbra, tbne, tbnz, tbgt, tbge, tbsr, tbeq, tbz, tblt, tble:
BEGIN
CASE op OF
tbra: subop := 0;
tbsr: subop := 1;
tbne: subop := 6;
tbnz: subop := 6;
tbeq: subop := 7;
tbz: subop := 7;
tbge: subop := 12;
tblt: subop := 13;
tbgt: subop := 14;
tble: subop := 15
END; (*CASE*)
i := ea1.displ;
IF ea1.mode = relative
THEN i := i -2
ELSE IF ea1.mode = labelled
THEN IF ((labeltableÆiÅ.defined)
AND (curropcode <> xcup))
OR ((proctableÆiÅ.defined)
AND (curropcode = xcup))
THEN
BEGIN
IF curropcode = xcup
THEN ltemp := proctableÆiÅ.location
ELSE ltemp := labeltableÆiÅ.location;
lsb(ltemp, pc);
ssb(ltemp, 2);
lasgn(i, ltemp)
END
ELSE i := 0; (* FORWARD REFERENCE*)
gen448(6,subop,i);
gennull
END; (*TBRA*)
tmoveq, tldq: BEGIN
gen4318(7,reg(ea2),0,ea1.displ);
gennull
END; (*TMOVEQ*)
taddq, tsubq:
BEGIN
IF size = 1
THEN i := 0
ELSE IF size = 4
THEN i := 2
ELSE i := 1;
IF op = taddq
THEN subop := 0
ELSE subop := 4; (* SUBQ*)
IF ea1.displ = 8 THEN ea1.displ := 0; (* ADJUST FOR IMMED 8 *)
gen43333(5,ea1.displ,subop+i,mode(ea2),reg(ea2));
IF ea1.displ = 0 THEN ea1.displ := 8; (*REPAIR IMMED 8*)
geneaext(ea2)
END; (*TADDQ*)
tlea, tchk:
BEGIN
IF op = tlea
THEN subop := 7
ELSE subop := 6; (*CHK*)
gen43333(4,reg(ea2),subop,mode(ea1),reg(ea1));
geneaext(ea1)
END; (*TLEA*)
tpea: BEGIN
gen43333(4,4,1,mode(ea1),reg(ea1));
geneaext(ea1)
END; (*TPEA*)
tdc: BEGIN
IF size = 1
THEN gen8(ea1.displ);
IF size = 2
THEN gen16(ea1.displ);
END; (*TDC*)
tlbsr, tlblt, tlbeq, tlbra, tlbgt, tlbne, tlble, tlbge:
BEGIN
CASE op OF
tlbra: subop := 0;
tlbsr: subop := 1;
tlbne: subop := 6;
tlbeq: subop := 7;
tlbge: subop := 12;
tlblt: subop := 13;
tlbgt: subop := 14;
tlble: subop := 15;
END; (*CASE*)
i := ea1.displ;
IF ea1.mode = relative
THEN i := i
ELSE IF ea1.mode = labelled
THEN IF (labeltableÆiÅ.defined
AND (curropcode <> xcup))
OR (proctableÆiÅ.defined
AND (curropcode = xcup))
THEN
BEGIN
IF curropcode = xcup
THEN ltemp := proctableÆiÅ.location
ELSE ltemp := labeltableÆiÅ.location;
lsb(ltemp, pc);
ssb(ltemp, 2);
lasgn(i, ltemp)
END
ELSE i := 0 (*FORWARD REF*)
ELSE IF ea1.mode = xexternal
THEN i := -(i );
gen448(6,subop,0);
subop := ea1.displ;
ea1.displ := i;
geneaext(ea1);
ea1.displ := subop;
END; (*TLBSR*)
tswap: BEGIN
gen43333(4,4,1,0,reg(ea1));
gennull
END; (*TSWAP*)
texte: BEGIN
IF size = 4
THEN i := 3
ELSE i := 2;
gen43333(4,4,i,0,reg(ea1));
gennull
END; (*TEXTE*)
tcmpm: BEGIN
CASE size OF
1: i := 4;
2: i := 5;
4: i := 6
END; (*CASE*)
gen43333(11,reg(ea2),i,1,reg(ea1));
gennull
END; (*TCMPM*)
tdcnt: BEGIN (* WARNING: THIS IS OLD DCNT *)
gen4318(7,reg(ea1),1,256 - ea2.displ);
gennull
END (*TDCNT*) ;
tasl: writeln(listing,'****ASL NOT SUPPORTED YET***');
tequ: ;
END; (*CASE*)
IF op <> tdc THEN
BEGIN
IF (op <> tequ) AND odd(debug) THEN write(listing,machcode);
machcode := ' ';
machindex := 1;
printinstruction
END;
END; (*GENX*)
PROCEDURE pushdreg;
VAR k: integer;
BEGIN IF dalloc <= 0 THEN error('NO D REG TO PUSH ')
ELSE BEGIN k := sizeÆregtypeÆdbotÅÅ;
(*1204B*) IF k = 8 THEN k := 4; (* POWERSETS*)
eaddir.reg := dbot;
genx(tmove,k,eaddir,eapush);
stkptr:=stkptr + 1;
IF stkptr > stkmax THEN error('TOO MANY REG PUSHES ');
kindstkÆstkptrÅ := dreg;
typestkÆstkptrÅ := regtypeÆdbotÅ;
dalloc := dalloc - 1;
IF dalloc = 0 THEN
BEGIN
dbot := dnone;
dtop := dnone
END
ELSE
dbot := dregsÆ(ord(dbot)-ord(d0)+1) MOD ndregsÅ;
END
END; (*PUSHDREG*)
PROCEDURE pushareg;
VAR k: integer;
BEGIN IF aalloc <= 0 THEN error('NO A REG TO PUSH ')
ELSE BEGIN k := sizeÆregtypeÆabotÅÅ;
eaadir.reg := abot;
genx(tmove,k,eaadir,eapush);
stkptr:=stkptr + 1;
IF stkptr > stkmax THEN error('TOO MANY REG PUSHES ');
kindstkÆstkptrÅ := areg;
typestkÆstkptrÅ := regtypeÆabotÅ;
aalloc := aalloc -1;
IF aalloc = 0 THEN BEGIN abot := anone; atop := anone END
ELSE
abot := aregsÆ(ord(abot)-ord(a0) + 1) MOD naregsÅ;
END
END; (*PUSHAREG*)
PROCEDURE pushalld;
BEGIN WHILE dalloc > 0 DO pushdreg END;
PROCEDURE pushall;
BEGIN WHILE aalloc > 0 DO pushareg;
WHILE dalloc > 0 DO pushdreg
END;
PROCEDURE freeall;
BEGIN
dalloc := 0; dtop := dnone; dbot := dnone;
aalloc := 0; atop := anone; abot := anone
END; (*FREEALL*)
PROCEDURE popreg(kind: regkind);
PROCEDURE popd;
VAR k: integer;
(*RM*) BEGIN
(*RM*) IF dbot = dnone THEN
(*RM*) BEGIN
(*RM*) dbot := d0;
(*RM*) dtop := d0
(*RM*) END ELSE
dbot :=
dregsÆ (ord(dbot)-ord(d0)-1+ndregs) MOD ndregsÅ;
dalloc := dalloc + 1;
IF stkptr < 0 THEN error('POPPING EMPTY STACK ')
ELSE BEGIN
k := sizeÆtypestkÆstkptrÅÅ;
(*1204B*) IF k = 8 THEN k := 4; (*POWERSETS*)
eaddir.reg := dbot;
genx(tmove,k,eapop, eaddir);
regtypeÆdbotÅ := typestkÆstkptrÅ;
IF stkptr >= 0 THEN stkptr := stkptr -1;
dpopcnt := dpopcnt + 1;
END
END; (*POPD*)
PROCEDURE popa;
VAR k: integer;
(*RM*) BEGIN IF abot = anone THEN
(*RM*) BEGIN
(*RM*) abot := a0;
(*RM*) atop := a0
(*RM*) END
ELSE abot :=
aregsÆ (ord(abot)-ord(a0)-1+naregs) MOD naregsÅ;
aalloc := aalloc + 1;
IF stkptr < 0 THEN error('POPPING EMPTY STACK ')
ELSE BEGIN
k := sizeÆtypestkÆstkptrÅÅ;
eaadir.reg := abot;
genx(tmove,k,eapop, eaadir);
regtypeÆabotÅ := typestkÆstkptrÅ;
IF stkptr >= 0 THEN stkptr := stkptr -1;
apopcnt := apopcnt + 1;
END
END; (*POPA*)
BEGIN IF kind = dreg THEN
BEGIN WHILE kindstkÆstkptrÅ <> dreg DO popa;
(*RM*) IF stkptr >= 0 THEN popd
ELSE error('NO D REG TO POP ')
END
ELSE
BEGIN WHILE kindstkÆstkptrÅ <> areg DO popd;
(*RM*) IF stkptr >= 0 THEN popa
ELSE error('NO A REG TO POP ')
END
END;
FUNCTION previous(r:register):register;
BEGIN
previous := dregsÆ(ord(r)-ord(d0)-1+ndregs) MOD ndregsÅ
END; (* PREVIOUS *)
PROCEDURE allocdreg;
BEGIN
dalloccnt := dalloccnt + 1;
IF dalloc >= ndregs THEN BEGIN pushdreg;
dpushcnt:=dpushcnt+1
END;
dalloc := dalloc + 1;
dtop := dregsÆ(ord(dtop)-ord(d0)+1) MOD ndregsÅ;
IF dbot = dnone THEN dbot := dtop;
regtypeÆdtopÅ := instr^.dtype;
END; (*ALLOCDREG*)
PROCEDURE allocareg;
BEGIN
aalloccnt := aalloccnt + 1;
IF aalloc >= naregs THEN BEGIN pushareg;
apushcnt:=apushcnt+1
END;
aalloc := aalloc + 1;
atop := aregsÆ(ord(atop)-ord(a0)+1) MOD naregsÅ;
IF abot = anone THEN abot := atop;
(*1011*) regtypeÆatopÅ := atyp;
END; (*ALLOCAREG*)
PROCEDURE freedreg;
BEGIN IF dalloc > 1 THEN BEGIN
dalloc := dalloc -1;
dtop := dregsÆ(ord(dtop)-ord(d0)+ndregs-1) MOD ndregsÅ
(*-1 AND WRAPAROUND*)
END
ELSE IF dalloc = 1 THEN BEGIN
dalloc := 0;
(*RM*) dbot := dnone;
dtop := dnone
END
ELSE error('FREE NONALLOC''D DREG')
END; (*FREEDREG*)
PROCEDURE freeareg;
BEGIN IF aalloc > 1 THEN BEGIN
aalloc := aalloc -1;
atop := aregsÆ(ord(atop)-ord(a0)+naregs-1) MOD naregsÅ
(*-1 AND WRAPAROUND*)
END
ELSE IF aalloc = 1 THEN BEGIN
aalloc := 0;
(*RM*) abot := anone;
atop := anone
END
ELSE error('FREE NONALLOC''D AREG')
END; (*FREEAREG*)
PROCEDURE effaddress(instr: iptr; VAR opaddr: effaddr);
(*USED BY LOD, LDA, STR, TAKES LEVEL, OFFSET
IN OPAND1 AND OPAND2 AND RETURNS MODE,
REGISTER, AND DISPLACEMENT OF CORRESPONDING
68000 ADDRESS*)
VAR src: effaddr;
BEGIN WITH instr^ DO
BEGIN IF opand1 (*LEVEL*) = 0 THEN (*GLOBAL ACCESS*)
opaddr.reg := a5 (*GLOBAL BASE REGISTER*)
ELSE IF opand1 = level THEN (*LOCAL ACCESS*)
opaddr.reg := a6 (*FRAME POINTER*)
ELSE BEGIN
IF templevel <> opand1 THEN
BEGIN
eaadir.reg := a4;
buildaddr(src,based,a5,anone,4*opand1 + 8);
genx(tmove,4,src,eaadir);
templevel := opand1
(*SAVE LEVEL OF DISPLAY ENTRY
CURRENTLY HELD IN A4*)
END;
opaddr.reg := a4; (*TEMPORARY INTERMEDIATE PTR*)
END;
opaddr.mode := based;
opaddr.displ := opand2; (*OFFSET*)
IF (opaddr.reg = a4) OR (opaddr.reg = a6) THEN
IF opand2 >= 0 THEN opaddr.displ := opand2 + 12;
IF opaddr.displ = 0 THEN opaddr.mode := defer
END;
END; (*EFFADDRESS*)
PROCEDURE doubleop(VAR src, dst:effaddr; commutative: boolean;
VAR switch: boolean);
(*RM*) BEGIN
(*RM*) IF instr^.dtype = atyp THEN BEGIN
(*RM*) IF NOT commutative OR (aalloc>=2) THEN
(*RM*) BEGIN
(*RM*) WHILE aalloc <= 1 DO popreg(areg);
(*RM*) buildaddr(src,adirect,atop,anone,0);
(*RM*) freeareg;
(*RM*) buildaddr(dst,adirect,atop,anone,0);
(*RM*) switch := false
(*RM*) END ELSE
(*RM*) BEGIN
(*RM*) IF aalloc < 1 THEN popreg(areg);
(*RM*) (*AALLOC = 1 AT THIS POINT *)
(*RM*) buildaddr(dst,adirect,atop,anone,0);
(*RM*) buildaddr(src,incr,sp,anone,0);
(*RM*) switch := true;
(*RM*) IF NOT (instr^.dtype IN longtypes) THEN stkptr := stkptr -1;
(*RM*) END
(*RM*) END ELSE
BEGIN IF NOT commutative OR (dalloc >= 2) THEN
BEGIN
WHILE dalloc <= 1 DO popreg(dreg);
buildaddr(src,ddirect,dtop,anone,0);
freedreg;
buildaddr(dst,ddirect,dtop,anone,0);
switch := false
END
ELSE BEGIN
IF dalloc < 1 THEN popreg(dreg);
(*DALLOC = 1 AT THIS POINT*)
buildaddr(dst,ddirect,dtop,anone,0);
buildaddr(src,incr,sp,anone,0);
switch := true;
(*RM*) IF NOT (instr^.dtype IN longtypes) THEN stkptr := stkptr -1;
END
(*RM*) END
(*RM*) END;
PROCEDURE singleop(VAR src:effaddr);
(*RM*) BEGIN
(*RM*) IF instr^.dtype = atyp THEN
(*RM*) BEGIN IF aalloc = 0 THEN popreg(areg);
(*RM*) buildaddr(src,adirect,atop,anone,0)
(*RM*) END ELSE
BEGIN IF dalloc = 0 THEN popreg(dreg);
buildaddr(src,ddirect,dtop,anone,0);
(*RM*) END
END;
PROCEDURE loadbig(addr: effaddr; bytes: integer);
(* PROCEDURE TO LOAD POWERSETS ONTO STACK *)
BEGIN
allocdreg;
eaddir.reg := dtop;
genx(tmove,4,addr,eaddir);
IF addr.mode = based
THEN addr.displ := addr.displ + 4
ELSE IF addr.mode=defer
THEN BEGIN
addr.mode := based;
addr.displ := 4
END
ELSE error('LOADBIG W/BAD MODE ');
allocdreg;
eaddir.reg := dtop;
genx(tmove,4,addr,eaddir);
END; (*LOADBIG*)
PROCEDURE storebig(addr: effaddr; bytes: integer);
(* PROCEDURE TO STORE POWERSETS OFF THE STACK *)
BEGIN
eaddir.reg := previous(dtop);
genx(tmove,4,eaddir,addr);
IF addr.mode = based
THEN addr.displ := addr.displ + 4
ELSE IF addr.mode = defer
THEN BEGIN
addr.mode := based;
addr.displ := 4
END
ELSE error('STOREBIG W/BAD MODE ');
eaddir.reg := dtop;
freedreg;
genx(tmove,4,eaddir,addr);
freedreg
END; (*STOREBIG*)
PROCEDURE storelittle; (*GEN CODE TO MOVE TOP DATA ITEM TO MEMORY*)
BEGIN IF dalloc > 0 THEN
BEGIN eaddir.reg := dtop;
genx(tmove,sizeÆinstr^.dtypeÅ,eaddir,source);
freedreg;
END
ELSE BEGIN genx(tmove,sizeÆinstr^.dtypeÅ,eapop,source);
stkptr := stkptr - 1;
END
END; (*STORELITTLE*)
PROCEDURE referencelabel(labl: integer; where: address);
(* CALLED TO SAVE FORWARD REFERENCE INFO *)
BEGIN
new(templabref);
WITH templabref^ DO
BEGIN
IF instr^.opcode=xcup
THEN next := proctableÆlablÅ.refchain
ELSE next := labeltableÆlablÅ.refchain;
coreloc := where
END; (*WITH*)
IF instr^.opcode=xcup
THEN BEGIN
proctableÆlablÅ.refchain := templabref;
proctableÆlablÅ.refed := true;
clr (proctableÆlablÅ.location);
proctableÆlablÅ.locationÆ0Å := 1
END (*ELSE*)
ELSE BEGIN
labeltableÆlablÅ.refchain := templabref ;
labeltableÆlablÅ.refed := true;
IF instr^.opcode = xent
THEN sasgn(labeltableÆlablÅ.location, -1)
ELSE clr(labeltableÆlablÅ.location);
END; (*ELSE*)
END; (*REFERENCELABEL*)
PROCEDURE longbsr; (* RUNTIME ROUTINE BRANCH CALCULATION *)
VAR
i: integer;
rtname: pcodes;
BEGIN
WITH instr^ DO
BEGIN
rtname := opcode;
IF dtype = vtyp
THEN BEGIN
IF rtname = xind THEN rtname := xindv
ELSE IF rtname = xlod THEN rtname := xlodv
ELSE IF rtname = xstr THEN rtname := xstrv
ELSE IF rtname = xsto THEN rtname := xstov
ELSE IF rtname = xequ THEN rtname := xequv
ELSE IF rtname = xneq THEN rtname := xneqv
ELSE IF rtname = xles THEN rtname := xlesv
ELSE IF rtname = xleq THEN rtname := xleqv
ELSE IF rtname = xgrt THEN rtname := xgrtv
ELSE IF rtname = xgeq THEN rtname := xgeqv
ELSE IF rtname = xldc THEN rtname := xldcv
END
ELSE IF rtname = xcvt
THEN IF (d1type=styp) AND (dtype=utyp)
THEN rtname := xcvtsu
ELSE IF (d1type=utyp) AND (dtype=styp)
THEN rtname := xcvtus;
clr(ltemp);
lsb(ltemp,rtjump);
sad(ltemp,rtÆrtnameÅ);
ssb(ltemp,4096);
lasgn(source.displ,ltemp);
buildaddr(source,based,a3,anone,source.displ);
genx(tjsr,2,source,eanone)
END (*WITH*)
END; (*LONGBSR*)
PROCEDURE main;
BEGIN
IF instr^.opand1 = 0 THEN
BEGIN
progstart := pc;
mainflg := true;
writeln(listing,'MAIN',' ':6,'EQU *');
END
ELSE writeln(listing,'USER':4,currlabel:1,' EQU *')
END ; (* MAIN *)
PROCEDURE genxxjp;
BEGIN
(*0421B*) IF dalloc = 0 THEN popreg(dreg);
eaddir.reg := dtop;
ealimm.displ := instr^.opand1 + 1;
genx(tcmp,2,ealimm,eaddir);
ltemp := pc;
ssb(ltemp, 2);
referencelabel(ealimm.displ,ltemp);
(*RM*) earel.displ := 20;
genx(tbgt,2,earel,eanone);
ealimm.displ := instr^.opand1;
genx(tsub,2,ealimm,eaddir);
ltemp := pc;
ssb(ltemp, 2);
referencelabel(ealimm.displ,ltemp);
(*RM*) earel.displ := 14;
genx(tblt,2,earel,eanone);
ealab.displ := instr^.opand1 + 2;
allocareg;
eaadir.reg := atop;
genx(tlea,2,ealab,eaadir);
ltemp := pc;
ssb(ltemp, 2);
referencelabel(ealab.displ,ltemp);
genx(tadd,2,eaddir,eaddir);
buildaddr(source,index,atop,dtop,0);
genx(tadd,2,source,eaadir);
eadefer.reg := atop;
genx(tjmp,2,eadefer,eanone);
freedreg; freeareg
END (* GENXXJP *) ;
(*RM*) PROCEDURE loadpset;
(*RM*) BEGIN
(*RM*) WITH instr^ DO BEGIN
(*RM*) allocdreg;
(*RM*) eaddir.reg := dtop;
(*RM*) eapset.displ := 0;
(*RM*) genx(tmove,4,eapset,eaddir);
(*RM*) allocdreg;
(*RM*) eaddir.reg := dtop;
(*RM*) eapset.displ := 8;
(*RM*) genx(tmove,4,eapset,eaddir)
(*RM*) END
(*RM*) END; (* LOADPSET *)
PROCEDURE setops;
BEGIN
WITH instr^ DO BEGIN
WHILE dalloc < 4 DO popreg(dreg);
IF opcode = xdif THEN BEGIN
eaddir.reg := dtop;
(*1324A*) genx(tcomp,4,eaddir,eanone);
eaddir.reg := previous(dtop);
(*1324A*) genx(tcomp,4,eaddir,eanone);
END;
IF opcode = xuni THEN opcde := tor
ELSE opcde := tand;
buildaddr(source,ddirect,dtop,dnone,0);
eaddir.reg := previous(previous(dtop));
genx(opcde,4,source,eaddir);
source.reg := previous(dtop);
eaddir.reg := previous(previous(previous(dtop)));
genx(opcde,4,source,eaddir);
freedreg;freedreg;
END
END; (* SETOPS *)
PROCEDURE pxlab;
BEGIN WITH instr^ DO BEGIN
IF opand1 = 0 THEN opand1 := -1;
(*604*) pcprint;
write(listing,'L',opand1 + labeloffset:1);
buildaddr(source,relative,anone,anone,0);
genx(tequ,0,source,eanone)
END;
END; (* PXLAB *)
PROCEDURE pxend;
VAR i: integer;
BEGIN
emitcode;
IF mainflg THEN BEGIN
genloc := genstart;
write(listing,' RORG $');
plint(listing,genstart);
ltemp := pc;
writeln(listing,' ');
lsb(ltemp,genstart);
ssb(ltemp,20);
gensave := pc;
pc := genstart;
(* LOAD STACK *)
write(listing,' ':39,'MOVE.L $');
plint(listing,stkstart);
writeln(listing,',A7');
eaimmed.displ := 11900; (* TMOVE 2E7C *)
genx(tdc,2,eaimmed,eanone);
eaimmed.displ := stkstartÆ0Å;
genx(tdc,1,eaimmed,eanone);
eaimmed.displ := stkstartÆ1Å;
genx(tdc,1,eaimmed,eanone);
eaimmed.displ := stkstartÆ2Å;
genx(tdc,1,eaimmed,eanone);
eaimmed.displ := stkstartÆ3Å;
genx(tdc,1,eaimmed,eanone);
(* LEA 11EA,A3 *)
write(listing,' ':39,'LEA $');
ltemp := rtjump;
sad(ltemp,4096);
plint(listing,ltemp);
writeln(listing,',A3');
eaimmed.displ := 18425; (* LEA 47F9 *)
genx(tdc,2,eaimmed,eanone);
eaimmed.displ := ltempÆ0Å;
genx(tdc,1,eaimmed,eanone);
eaimmed.displ := ltempÆ1Å;
genx(tdc,1,eaimmed,eanone);
eaimmed.displ := ltempÆ2Å;
genx(tdc,1,eaimmed,eanone);
eaimmed.displ := ltempÆ3Å;
genx(tdc,1,eaimmed,eanone);
(* JSR -490(A3) INITIALIZE ENVIRONMENT *)
longbsr;
IF (heapstartÆ0Å=255) AND (heapstartÆ1Å=255)
AND (heapstartÆ2Å=255) AND (heapstartÆ3Å=255)
THEN BEGIN
heapstart := gensave;
sad(heapstart,10)
END;
write(listing,' ':10,'DC.L ':7,'$':1);
plint(listing,heapstart);
writeln(listing,' ');
FOR i := 0 TO 3 DO
BEGIN
eaimmed.displ := heapstartÆiÅ;
genx(tdc,1,eaimmed,eanone)
END;
(* BRA OR JSR TO MAIN *)
ltemp := progstart;
lsb(ltemp,pc);
IF short(ltemp) THEN BEGIN
lasgn(earel.displ, ltemp);
genx(tlbra,2,earel,eanone);
END ELSE
BEGIN
eadefer.reg := a3;
ssb(ltemp,2);
genx(tjsr,2,eadefer,eanone);
write(listing,' ':10,'DC.L ':7,'$':1);
plint(listing,ltemp);
writeln(listing,' ');
FOR i := 0 TO 3 DO
BEGIN
eaimmed.displ := ltempÆiÅ;
genx(tdc,1,eaimmed,eanone)
END
END;
pc := gensave;
emitcode;
END; (*BEGIN*)
emitend
;writeln(listing,' END');
END; (*PXEND*)
PROCEDURE pxdef;
BEGIN WITH instr^ DO BEGIN
IF labeled AND NOT dollar THEN
BEGIN
IF opand1= 0 THEN opand1 := 1-labeloffset;
(*604*) pcprint;
write(listing,'L',opand1 + labeloffset:1);
buildaddr(source,absolute,anone,anone,opand2);
genx(tequ,0,source,eanone)
END;
IF labeled AND dollar THEN
BEGIN getstring;
write(output,'***** REFERENCE TO EXTERNAL PROCEDURE ',
vstring:alength,' AT LOCATION ');
ltemp := exproc;
ssb(ltemp,10);
plint(output,ltemp);
writeln(output,' ');
END
ELSE IF NOT labeled THEN
error('DEF WITH NO LABEL ')
END;
END; (*PXDEF*)
PROCEDURE pxent; (* OPAND1 IS NEW LEVEL*)
BEGIN WITH instr^ DO BEGIN
(*OPAND2 IS LABEL WHICH GIVES LOCAL DATA SZ*)
(*VSTRING IS NEW PROC/FUNC NAME*)
emitcode;
resetlabel;
main;
level := opand1;
IF templevel = level THEN templevel := -1;
(*INVALIDATE A4 (POINTER TO INTERMEDIATE
LEXICAL LEVEL) IF DISPLAY ENTRY CHANGES*)
IF level = 1 THEN
BEGIN
write(output,'*****ENTRY TO PROCEDURE ':25,
vstring:alength,' AT LOCATION ');
plint(output,pc);
writeln(output,' ')
END;
(*1212A*) IF level = 0 THEN
(*1212A*) BEGIN
(*1212A*) eaadir.reg := a7;
(*1212A*) ealimm.displ := -opand2;
(*1212A*) genx(tadd,0,ealimm,eaadir);
ltemp := pc;
ssb(ltemp, 2);
(*1212A*) referencelabel(opand2 - labeloffset,ltemp)
(*1212A*) END
(*1212A*) ELSE BEGIN
buildaddr(source,based,a5,anone,8+4*level);
(*DISPLAY IS ^A5(6)*)
genx(tmove,4,source,eapush);
eaadir.reg := a6; (*FRAME POINTER*)
ealimm.displ := -opand2 ;
genx(tlink,0,eaadir,ealimm) ;
ltemp := pc;
ssb( ltemp, 2);
referencelabel(opand2 - labeloffset,ltemp);
genx(tmove,4,eaadir,source);
(*1212A*) END;
END;
END; (* PXENT *)
PROCEDURE pxret;
BEGIN WITH instr^ DO BEGIN
IF opand1 <> level THEN
error('ENT/RET LEVELS NOT =');
eaadir.reg := a6; (*FRAME POINTER*)
genx(tunlk,0,eaadir,eanone);
buildaddr(source,based,a5,anone,8+4*level);
genx(tmove,4,eapop,source);
(*RM*) (* CODE TO FLUSH ARGUMENTS FROM STACK *)
(*RM*) IF opand2 <> 0 THEN
(*RM*) BEGIN
(*RM*) allocareg;
(*RM*) eaadir.reg := atop;
(*RM*) genx(tmove,4,eapop,eaadir);
(*RM*) eaimmed.displ := opand2;
(*RM*) eaadir.reg := sp;
(*RM*) genx(tadd,4,eaimmed,eaadir);
(*RM*) eadefer.reg := atop;
(*RM*) genx(tjmp,0,eadefer,eanone);
(*RM*) freeareg
(*RM*) END ELSE
genx(trts,0,eanone,eanone)
END;
END; (*PXRET*)
(*604*) PROCEDURE pxad; FORWARD;
PROCEDURE pxab;
BEGIN WITH instr^ DO BEGIN
singleop(source);
(*RM*) k := sizeÆdtypeÅ;
CASE subtypeÆopcodeÅ OF
(*604*) 1 (*AB *): BEGIN genx(ttst,k,source,eanone);
(*RM*) earel.displ := 4;
genx(tbgt,0,earel,eanone);
(*604*) genx(tneg,k,source,eanone)
END;
(*604*) 2 (*NG *): genx(tneg,k,source,eanone);
(*RM*) 3 (*DEC*): BEGIN eaimmed.displ := opand1;
genx(tsub,k,eaimmed,source)
(*RM*) END;
(*RM*) 4 (*INC*): BEGIN eaimmed.displ := opand1;
(*480*) IF dtype = atyp THEN k := 2;
(*RM*) genx(tadd,k,eaimmed,source) END;
5 (*NOT*): BEGIN
optimi := nextpcod(instr);
IF optimi^.opcode=xfjp
THEN BEGIN
optimi^.opand3 := 102; (*BEQ TO FJP*)
END
ELSE BEGIN
(*RM*) eaimmed.displ := 1;
(*RM*) genx(teor,1,eaimmed,source)
END
(*RM*) END;
(*0421C*) 6 (*ODD*): BEGIN eaimmed.displ := 1;(*BIT # = 0*)
(*0421C*) genx(tand,1,eaimmed,source);
(*0421C*) regtypeÆdtopÅ := btyp;
END;
(*RM*) 7 (*SQR*): (*CHECK SIZES??*)
(*604*) IF dtype = jtyp
(*604*) THEN BEGIN
(*604*) IF dalloc < 1
(*604*) THEN popreg(dreg);
(*604*) eaddir.reg := dtop;
(*604*) allocdreg;
(*604*) buildaddr(dest,ddirect,
(*604*) dtop,anone,0);
(*604*) genx(tmove,4,eaddir,dest);
(*604*) opcode := xmp;
(*604*) pxad;
(*604*) END ELSE
(*604*) BEGIN
(*604*) IF dtype = htyp
(*604*) THEN BEGIN
(*604*) IF dalloc<1 THEN popreg(dreg);
(*604*) buildaddr(source,ddirect,dtop,
(*604*) anone,0);
(*604*) genx(texte,2,source,eanone)
(*604*) END;
(*RM*) genx(tmuls,2,source,source);
(*604*) END;
(* CHECK OVFL
MOV.W TO TEMP
EXT.L TEMP
CMP TEMP WITH SOURCE
BNE *+2
TRAP OVFL *)
END
END;
END; (*PXAB*)
PROCEDURE pxad;
BEGIN WITH instr^ DO BEGIN
CASE subtypeÆopcodeÅ OF
(*604*) 1,3,4: commutative := true;
(*604*) 5: IF dtype IN Æjtyp,htypÅ THEN commutative := false
(*604*) ELSE commutative := true;
2,6,7: commutative := false
END;
doubleop(source,dest,commutative,switch);
k := sizeÆdtypeÅ;
IF dtype = notatyp THEN k := 1; (* ASSUME BOOLEAN*)
(*604*) IF (dtype = jtyp)
(*604*) AND (subtypeÆopcodeÅ IN Æ5,6,7Å)
(*604*) THEN BEGIN
(*604*) longbsr;
(*604*) eaimmed.displ := ord(dest.reg) - ord(d0);
(*604*) pcprint;
(*604*) writeln(listing,' ':10,'DC.W ',
(*604*) eaimmed.displ:0);
(*604*) genx(tdc,2,eaimmed,eanone);
(*604*) END ELSE
CASE subtypeÆopcodeÅ OF
1 (*ADD*): genx(tadd,k,source, dest);
2 (*SB *): genx(tsub,k,source, dest);
3 (*AND*): genx(tand,k,source, dest);
4 (*IOR*): genx(tor, k,source, dest);
(*604*) 5 (*MP *): BEGIN
(***CHECK OVFL; SEE CODE FOR SQR*)
(*604*) IF dtype = htyp
(*604*) THEN genx(texte,2,source,eanone);
(*604*) IF (dtype = htyp)
(*604*) THEN genx(texte,2,dest,eanone);
(*604*) genx(tmuls,2,source,dest)
END;
(*604*) 6 (*DV *): BEGIN
(*604*) IF dtype = htyp
(*604*) THEN BEGIN
(*604*) genx(texte,2,source,eanone);
(*604*) genx(texte,2,dest,eanone)
(*604*) END;
(*604*) genx(texte,4,dest,eanone);
(*RM*) genx(tdivs,2,source,dest)
END;
(*604*) 7 (*MOD*): BEGIN
(*604*) IF dtype = htyp
(*604*) THEN BEGIN
(*604*) genx(texte,2,source,eanone);
(*604*) genx(texte,2,dest,eanone)
(*604*) END;
(*604*) genx(texte,4,dest,eanone);
(*RM*) genx(tdivs,2,source,dest);
(*RM*) genx(tswap,2,dest,eanone)
END;
END
END;
END; (*PXAD*)
PROCEDURE pxclo;
VAR i:integer;
BEGIN WITH instr^ DO BEGIN
IF short(firstesd^.reference)
AND (firstesd^.referenceÆ2Å=0)
AND (firstesd^.referenceÆ3Å=0) THEN
BEGIN tempesd:= firstesd;
new(firstesd); firstesd^.next:=tempesd;
END;
ltemp := pc;
sad(ltemp, 2);
firstesd^.reference := ltemp;
firstesd^.name := opcode;
IF (opcode=xwrb) OR (opcode=xwrc) OR (opcode=xwri)
(*604*) OR (opcode=xwrh) OR (opcode=xwrj)
THEN BEGIN
(*0610B*) IF opcode=xwrc THEN dtype := ctyp
(*0610B*) ELSE IF opcode=xwri THEN dtype := ityp
(*0610B*) ELSE IF opcode=xwrh THEN dtype := htyp
(*0610B*) ELSE IF opcode=xwrj THEN dtype := jtyp;
IF dalloc + aalloc = 0
THEN BEGIN
eaddir.reg := d1;
genx(tmove,2,eapop,eaddir);
eaddir.reg := d0;
(*0610B*) genx(tmove,sizeÆdtypeÅ,eapop,eaddir);
eaadir.reg := a0;
genx(tmove,4,eapop,eaadir);
stkptr := stkptr - 3;
dpopcnt := dpopcnt + 3;
END
ELSE IF (dalloc=1) AND (aalloc=0)
THEN BEGIN
buildaddr(source,ddirect,dtop,anone,0);
eaddir.reg := d1;
genx(tmove,2,source,eaddir);
eaddir.reg := d0;
(*0610B*) genx(tmove,sizeÆdtypeÅ,eapop,eaddir);
eaadir.reg := a0;
genx(tmove,4,eapop,eaadir);
stkptr := stkptr -2;
dpopcnt := dpopcnt +2;
(*1015E*) END
(*1015E*) ELSE IF (dalloc=2) AND (aalloc=0)
(*1015E*) THEN BEGIN
(*1015E*) eaadir.reg := a0;
(*1015E*) genx(tmove,4,eapop,eaadir);
(*1015E*) stkptr := stkptr -1;
(*1015E*) dpopcnt := dpopcnt +1;
(*1015E*) END;
END;
IF (opcode=xwrv) OR (opcode=xwrs)
(*1205B*) THEN BEGIN pushalld; stkptr := stkptr -2 END;
(*1207C*) IF opcode = xwrv THEN stkptr := stkptr - 1;
IF (opcode=xpee)
THEN
BEGIN
IF aalloc = 0 THEN popreg(areg)
END;
(*MAKE SURE PARAMETERS ARE IN RIGHT PLACE?*)
dtype := notatyp;
(*RM*) IF opcode <> xeio THEN longbsr
ELSE IF aalloc = 0 THEN BEGIN
(* REMOVE FILE POINTER FROM STACK *)
eaimmed.displ := 4;
eaadir.reg := sp;
genx(tadd,2,eaimmed,eaadir)
END;
(*RM*) freeall ;
(*1031A*) IF (opcode=xeol) OR (opcode=xeof) OR (opcode=xpos)
(*1031A*) THEN
(*1031A*) BEGIN
(*1031A*) allocdreg;
(*1031A*) IF opcode=xpos
(*1031A*) THEN regtypeÆdtopÅ := ityp
(*1031A*) ELSE regtypeÆdtopÅ := btyp;
(*1031A*) END
(*RM*) ELSE IF (opcode <> xeio) AND (opcode<>xclo) AND (opcode<>xifd)
(*RM*) AND (opcode<>xsee) AND (opcode<>xrst) AND (opcode<>xrwt)
(*RM*) AND (opcode<>xrln) AND (opcode<>xwln)
(*1023A*) AND (opcode<>xget) AND (opcode<>xput)
(*1206A*) AND (opcode<>xpag)
(*RM*) THEN allocareg;
(*1207H*) IF opcode = xafi THEN stkptr := stkptr - 1;
END;
END (*PXCLO*) ;
PROCEDURE pxlod;
BEGIN WITH instr^ DO BEGIN
effaddress(instr,source);
CASE subtypeÆopcodeÅ OF
1 (*LOD*): BEGIN IF dtype = atyp THEN
BEGIN
optimi := nextpcod(instr);
IF optimi^.opcode=xarg
THEN BEGIN genx(tmove,4,source,eapush);
optimi^.inuse := false END
ELSE IF ( optimi^.opcode=xstr)
AND ((optimi^.opand1=level)
OR (optimi^.opand1=0)
OR (optimi^.opand1=opand1))
THEN BEGIN
effaddress(optimi,dest);
optimi^.inuse := false;
genx(tmove,4,source,dest)
END
ELSE
BEGIN allocareg;
eaadir.reg := atop;
genx(tmove,4,source,eaadir);
END;
END
ELSE IF NOT (dtype IN longtypes) THEN
BEGIN
optimi := nextpcod(instr);
eaddir.reg := dtop;
optimi^.inuse := false;
optim2 := nextpcod(optimi);
IF ((optimi^.opcode=xad)
OR (optimi^.opcode=xsb)
OR (optimi^.opcode=xand)
OR (optimi^.opcode=xior))
AND (dtop<>dnone)
THEN BEGIN
CASE subtypeÆoptimi^.opcodeÅ OF
1: opcde := tadd;
2: opcde := tsub;
3: opcde := tand;
4: opcde := tor;
END; (*CASE*)
genx(opcde,sizeÆdtypeÅ,source,eaddir);
END
ELSE IF (optimi^.opcode = xldc)
AND (conditional(optim2)>0)
THEN BEGIN
eaimmed.displ := optimi^.opand1;
IF dtype = ctyp
THEN eaimmed.displ :=
asciiÆoptimi^.opstring^.vstringaÆ1ÅÅ;
IF optimi^.dtype=jtyp
THEN BEGIN
opand1 := optimi^.opand1;
opand2 := optimi^.opand2;
opand3 := optimi^.opand3;
opand4 := optimi^.opand4;
genx(tcmp,4,ealong,source);
END
ELSE
IF eaimmed.displ = 0
THEN genx(ttst,sizeÆdtypeÅ,
source,eanone)
ELSE genx(tcmp,sizeÆdtypeÅ,
eaimmed,source);
optim2^.opand3 := 200; (*FLAG SET*)
END
ELSE IF optimi^.opcode=xarg
THEN genx(tmove,sizeÆdtypeÅ,source,eapush)
ELSE IF optimi^.opcode=xsto
THEN BEGIN
eadefer.reg := atop;
genx(tmove,sizeÆdtypeÅ,source,eadefer)
;freeareg
END
ELSE IF (optimi^.opcode = xstr)
AND ((optimi^.opand1 = level)
OR (optimi^.opand1 = 0)
OR (optimi^.opand1 = opand1))
THEN BEGIN
eabased.displ :=optimi^.opand2;
IF (eabased.displ >=0) AND
(optimi^.opand1=level)
THEN eabased.displ := eabased.displ+12;
IF optimi^.opand1 = 0
THEN eabased.reg := a5
ELSE IF optimi^.opand1 = level
THEN eabased.reg := a6
ELSE eabased.reg := a4;
genx(tmove,sizeÆdtypeÅ,source,eabased)
END
ELSE IF (((optimi^.opcode=xinc)
OR (optimi^.opcode=xdec))
AND ((optim2^.opcode=xstr)
AND (optim2^.opand1=opand1)
AND (optim2^.opand2=opand2)))
THEN BEGIN
optim2^.inuse := false;
IF optimi^.opcode = xdec
THEN opcde := tsub
ELSE opcde := tadd;
eaimmed.displ := optimi^.opand1;
genx(opcde,sizeÆdtypeÅ,eaimmed,source)
END
ELSE IF ( conditional(optimi) > 0)
AND (dtop<>dnone)
THEN BEGIN
genx(tcmp,sizeÆdtypeÅ,source,eaddir);
optimi^.opand3 := 100; (*SET FLAG *)
optimi^.inuse := true
END
ELSE BEGIN
allocdreg;
eaddir.reg := dtop;
genx(tmove,sizeÆdtypeÅ,
source,eaddir) ;
optimi^.inuse:= true
END
END
ELSE (*LONG TYPE: P, S, OR V*)
(*RM*) BEGIN IF dtype = ptyp THEN opand3:=8;
IF dtype IN Æstyp,vtypÅ THEN BEGIN
(*1015D*) pushall;
eaadir.reg := a0;
genx(tlea,2,source,eaadir);
IF (aalloc<>0) OR (dalloc<>0)
THEN error
('REGISTERS NOT EMPTY ');
freeall;
longbsr;
IF dtype = vtyp THEN BEGIN
(*604*) pcprint;
writeln(listing,' ':10,
'DC.W ',opand3:0);
eaimmed.displ := opand3;
genx(tdc,2,eaimmed,eanone);
END
END ELSE
loadbig(source,opand3 (*SIZE*))
(*RM*) END
END;
2 (*LDA*): BEGIN
(*480*) optimi := nextpcod(instr);
IF (optimi^.opcode=xarg) OR (optimi^.opcode=xmst)
(*480*) OR (((optimi^.opcode=xldc) OR (optimi^.opcode=xlod)
(*480*) OR (optimi^.opcode=xind))
(*480*) AND (optimi^.dtype IN Æstyp,vtypÅ))
THEN BEGIN
optimi^.inuse := false;
(*480*) IF (optimi^.opcode<>xmst)AND(optimi^.opcode<>xarg)
(*480*) THEN optimi^.inuse := true;
(*480*) IF optimi^.opcode <> xarg
THEN BEGIN
pushall;
stkptr := stkptr + 1;
kindstkÆstkptrÅ := areg;
typestkÆstkptrÅ := atyp;
END;
genx(tpea,2,source,eanone)
END ELSE BEGIN
allocareg;
eaadir.reg := atop;
genx(tlea,2,source,eaadir)
END
END;
3 (*STR*): BEGIN IF dtype = atyp THEN
BEGIN IF aalloc > 0 THEN
BEGIN eaadir.reg := atop;
genx(tmove,4,eaadir,source);
freeareg
END
ELSE BEGIN
genx(tmove,4,eapop,source);
stkptr := stkptr - 1;
END
END ELSE (*DTYPE <> ATYP*)
IF NOT (dtype IN longtypes) THEN
storelittle
(*RM*) ELSE BEGIN
(*RM*) IF dtype = ptyp THEN opand3:=8;
IF dtype IN Æstyp,vtypÅ THEN BEGIN
eaddir.reg := d0;
eaimmed.displ := opand3;
IF dtype = styp THEN
genx(tmove,4,eaimmed,eaddir);
eaadir.reg := a0;
genx(tlea,2,source,eaadir);
IF (aalloc<>0) OR (dalloc<>0)
THEN error
('REGISTERS NOT EMPTY ');
freeall;
longbsr;
IF dtype = vtyp THEN BEGIN
pcprint;
writeln(listing,' ':10,'DC.W ',
opand3:0);
genx(tdc,2,eaimmed,eanone)
END
END ELSE
(*RM*) storebig(source,opand3)
(*RM*) END
END
END
END;
END; (*PXLOD*)
PROCEDURE pxixa;
BEGIN WITH instr^ DO BEGIN
(*T <- T' + T * OPAND1; WHERE T' IS ADDR AND T IS DATA*)
IF dalloc <= 0 THEN popreg(dreg);
eaddir.reg := dtop;
IF opand1 = 2 THEN
genx(tadd,2,eaddir,eaddir)
(***MORE OPTIMIZATION POSSIBLE FOR SMALL OPAND1'S*)
ELSE BEGIN eaimmed.displ := opand1;
(*OP*) IF opand1 <> 1 THEN
genx(tmuls,2,eaimmed,eaddir) END;
IF aalloc <= 0 THEN popreg(areg);
eaadir.reg := atop;
(*OP*) eaddir.reg := dtop;
(*OP*) genx(tadd,2,eaddir,eaadir);
freedreg;
END;
END; (*PXIXA*)
PROCEDURE pxind;
BEGIN WITH instr^ DO BEGIN
(*T <- MEMÆT + OPAND1Å*)
IF aalloc <= 0 THEN popreg(areg);
buildaddr(source,based,atop,anone,opand1);
IF opand1 = 0 THEN source.mode := defer;
IF dtype = atyp
THEN
BEGIN
optimi := nextpcod(instr);
IF optimi^.opcode = xstr
THEN
BEGIN
effaddress(optimi,dest);
optimi^.inuse := false;
genx(tmove,4,source,dest)
;freeareg
END
ELSE
BEGIN
eaadir.reg := atop;
genx(tmove,4,source,eaadir)
END
END
ELSE BEGIN
IF NOT (dtype IN longtypes) THEN
BEGIN
optimi := nextpcod(instr);
optimi^.inuse := false;
(*0610A*) IF (dtop=dnone) AND ((optimi^.opcode=xad)
(*0610A*) OR (optimi^.opcode=xsb) OR
(*0610A*) (optimi^.opcode=xand) OR
(*0610A*) (optimi^.opcode=xior))
(*0610A*) THEN popreg(dreg);
eaddir.reg := dtop;
freeareg;
optim2 := nextpcod(optimi);
IF optimi^.opcode = xarg
THEN genx(tmove,sizeÆdtypeÅ,
source,eapush)
ELSE
IF optimi^.opcode=xad
THEN genx(tadd,sizeÆdtypeÅ,source,eaddir)
ELSE IF optimi^.opcode=xsb
THEN genx(tsub,sizeÆdtypeÅ,source,eaddir)
ELSE IF optimi^.opcode=xand
THEN genx(tand,sizeÆdtypeÅ,source,eaddir)
ELSE IF optimi^.opcode=xior
THEN genx(tor,sizeÆdtypeÅ,source,eaddir)
ELSE IF optimi^.opcode = xstr
THEN
BEGIN
effaddress(optimi,dest);
genx(tmove,sizeÆdtypeÅ,
source,dest)
END
ELSE IF (optimi^.opcode = xldc)
AND (conditional(optim2)>0)
THEN
BEGIN
eaimmed.displ :=
optimi^.opand1;
IF dtype = ctyp
THEN eaimmed.displ :=
asciiÆoptimi^.opstring^.vstringaÆ1ÅÅ;
IF optimi^.dtype=jtyp
THEN BEGIN
opand1 := optimi^.opand1;
opand2 := optimi^.opand2;
opand3 := optimi^.opand3;
opand4 := optimi^.opand4;
genx(tcmp,4,ealong,source);
END
ELSE
IF eaimmed.displ = 0
THEN genx(ttst,sizeÆdtypeÅ
,source,eanone)
ELSE genx(tcmp,sizeÆdtypeÅ
,eaimmed,source);
optim2^.opand3 :=200
END
ELSE BEGIN
optimi^.inuse := true;
allocdreg;
eaddir.reg := dtop;
genx(tmove,sizeÆdtypeÅ,source,eaddir);
END;
END
ELSE BEGIN IF dtype = ptyp THEN opand2 :=8;
IF dtype IN Æstyp,vtypÅ THEN BEGIN
freeareg;
pushall;
eaadir.reg := a0;
genx(tlea,2,source,eaadir);
longbsr;
IF dtype = vtyp THEN BEGIN
(*604*) pcprint;
writeln(listing,' ':10,
'DC.W ',opand2:0);
eaimmed.displ := opand2;
genx(tdc,2,eaimmed,eanone)
END
END ELSE BEGIN (*PTYP*)
loadbig(source,opand2);
(*1207E*) IF dtype = ptyp THEN freeareg;
END;
END;
END
END;
END ; (*PXIND*)
PROCEDURE pxsto;
BEGIN WITH instr^ DO BEGIN
(* MEMÆT'Å <- T *)
IF dtype IN Æstyp,vtypÅ THEN BEGIN
IF (aalloc<>0) OR (dalloc<>0) THEN
error('REGISTERS NOT EMPTY ');
freeall;
IF dtype = styp THEN BEGIN
allocdreg;
eaimmed.displ := opand1;
eaddir.reg := dtop;
genx(tmove,2,eaimmed,eaddir);
END;
longbsr;
IF dtype = vtyp THEN BEGIN
(*604*) pcprint;
writeln(listing,'DC.W ',opand1:0);
eaimmed.displ := opand1;
genx(tdc,2,eaimmed,eanone)
END ELSE
freedreg;
(*1207D*) stkptr := stkptr - 1;
END ELSE
IF dtype = ptyp THEN BEGIN
WHILE dalloc<2 DO popreg(dreg);
IF aalloc < 1 THEN popreg(areg);
(*1303A*) buildaddr(source,defer,atop,anone,0);
storebig(source,8);
freeareg;
END ELSE
IF dtype = atyp THEN
BEGIN WHILE aalloc < 2 DO popreg(areg);
eaadir.reg := atop;
freeareg;
buildaddr(source,defer,atop,anone,0);
genx(tmove,4,eaadir,source);
freeareg
END
ELSE BEGIN IF dalloc < 1 THEN popreg(dreg);
IF aalloc < 1 THEN popreg(areg);
buildaddr(source,defer,atop,anone,0);
storelittle;
freeareg;
END
END;
END; (*PXSTO *)
PROCEDURE pxldc;
VAR j,k: integer;
BEGIN WITH instr^ DO BEGIN
IF dtype = atyp THEN
BEGIN allocareg;
eaadir.reg := atop;
(*604*) genx(tmove,4,ealong,eaadir) (* LOAD 4 CONSTS *)
END ELSE
(*604*) IF dtype = jtyp
(*604*) THEN BEGIN
(*604*) allocdreg;
(*604*) eaddir.reg := dtop;
(*604*) genx(tmove,4,ealong,eaddir)
(*604*) END ELSE
(*480*) IF dtype IN Æstyp,vtypÅ THEN
BEGIN
(*480*) IF dtype = vtyp THEN
(*480*) BEGIN
(*480*) k := opstring^.stringl; (* STRING LEN*)
(*480*) (*IF STC THRU HERE *) IF opcode = xldc THEN opand3:=opand1;
(*480*) opstring^.stringl := opand3; (*VEC *)
(*480*) IF k < opand3
(*480*) THEN FOR j := k + 1 TO opand3 DO
(*480*) opstring^.vstringaÆjÅ := ' '
(*480*) END;
pushall;
longbsr;
k := opstring^.stringl;
eaimmed.displ := k;
IF odd(k) THEN k := k + 1;
(*604*) pcprint;
writeln(listing,' ':10,'DC.W ',
eaimmed.displ:0);
genx(tdc,2,eaimmed,eanone);
(*604*) pcprint;
write(listing,' ':10,'DC.W ');
vstringimmed(1,k);
writeln(listing,' ');
END
ELSE
(*RM*) IF dtype = ptyp THEN
(*RM*) loadpset
(*RM*) ELSE
BEGIN
IF dtype = ctyp THEN
eaimmed.displ := asciiÆopstring^.vstringaÆ1ÅÅ
ELSE
eaimmed.displ := opand1;
optimi := nextpcod(instr);
optimi^.inuse := false;
IF (optimi^.opcode=xarg) OR (optimi^.opcode=xexi)
OR (optimi^.opcode=xwrs) OR (optimi^.opcode=xwrv)
THEN BEGIN
IF (optimi^.opcode=xwrs) OR (optimi^.opcode=xwrv)
THEN pushalld;
IF optimi^.opcode<>xarg THEN BEGIN
optimi^.inuse := true;
optimi^.dtype := dtype
(*1205B*) ;
(*1205B*) IF optimi^.opcode<>xexi THEN BEGIN
(*1205B*) stkptr := stkptr +1;
(*1205B*) typestkÆstkptrÅ := dtype;
(*1205B*) kindstkÆstkptrÅ := dreg;
(*1205B*) END END;
genx(tmove,sizeÆoptimi^.dtypeÅ,eaimmed,eapush)
; optimi^.dtype := notatyp
END
ELSE IF optimi^.opcode=xsto
THEN BEGIN
eadefer.reg := atop;
genx(tmove,sizeÆoptimi^.dtypeÅ,eaimmed,eadefer)
;freeareg
END
ELSE IF (optimi^.opcode = xstr)
AND ((optimi^.opand1 = level)
OR (optimi^.opand1 = 0))
THEN BEGIN
eabased.displ := optimi^.opand2;
IF (eabased.displ>=0) AND (optimi^.opand1=level)
THEN eabased.displ := eabased.displ+12;
IF optimi^.opand1 = 0
THEN eabased.reg := a5
ELSE eabased.reg := a6;
genx(tmove,sizeÆoptimi^.dtypeÅ,eaimmed,eabased)
END
ELSE IF (conditional(optimi) > 0)
AND (dtop<>dnone)
THEN BEGIN
eaddir.reg := dtop;
IF eaimmed.displ=0 THEN
genx(ttst,sizeÆdtypeÅ,eaddir,eanone)
ELSE
genx(tcmp,sizeÆdtypeÅ,eaimmed,eaddir);
optimi^.opand3 := 100; (* SET FLAG *)
optimi^.inuse := true
END
ELSE IF optimi^.opcode=xixa
THEN BEGIN
eaimmed.displ := opand1 * optimi^.opand1;
eaadir.reg := atop;
genx(tadd,2,eaimmed,eaadir)
END
ELSE
BEGIN
allocdreg;
optimi^.inuse := true;
eaddir.reg := dtop;
genx(tmove ,2,eaimmed,eaddir);
END
END
END;
END; (*PXLDC*)
(*480*) PROCEDURE pxstc;
(*480*) BEGIN WITH instr^ DO BEGIN
(*480*) effaddress(instr,source);
(*480*) pushall;
(*480*) eaadir.reg := a0;
(*480*) genx(tlea,2,source,eaadir);
(*480*) pxldc (* LET LOAD CONSTANT PROCESSOR DO REST *)
(*480*) END (* WITH *)
(*480*) END; (*PXSTC*)
PROCEDURE pxlta;
BEGIN WITH instr^ DO BEGIN
allocareg;
eaadir.reg := sp;
buildaddr(source,defer,atop,anone,0);
genx(tmove,4,eaadir,source)
END;
END; (*PXLTA*)
PROCEDURE pxlca;
BEGIN
;(*LEAVE INDICATION TO ALLOCATE STORAGE AT END
OF THIS BLOCK; GEN LEA ATOP WITH PC^(DISPL)*)
END; (* PXLCA*)
PROCEDURE pxisc;
BEGIN WITH instr^ DO BEGIN
eaimmed.displ := 1;
eadefer.reg := a5;
genx(tadd,4,eaimmed,eadefer) (*'SC' IS ^A5*)
END;
END; (*PXISC*)
PROCEDURE pxlsc;
BEGIN WITH instr^ DO BEGIN
eaimmed.displ := opand1;
eadefer.reg := a5;
genx(tmove,4,eaimmed,eadefer) (*'SC' IS ^A5*)
END;
END; (*PXLSC*)
PROCEDURE pxequ;
VAR flag: boolean; (* TRUE MEANS NO DREG WAS ALLOC YET *)
BEGIN WITH instr^ DO BEGIN
flag := false;
IF opand3 = 200
THEN BEGIN
flag := true;
opand3 := 100
END;
IF dtype IN Æstyp,vtypÅ THEN BEGIN
longbsr;
IF dtype = vtyp
THEN
BEGIN
eaimmed.displ := opand1; (* VEC LEN *)
(*604*) pcprint;
IF debug <> 0 THEN
writeln(listing,' ':10,'DC.W ',
opand1:0);
genx(tdc,2,eaimmed,eanone)
(*604*) END;
IF (aalloc<>0) OR (dalloc<>0) THEN
error('REGISTERS NOT EMPTY ');
freeall;
allocdreg;
(*0326A*) regtypeÆdtopÅ := btyp;
END ELSE IF dtype = ptyp THEN BEGIN
WHILE dalloc < 4 DO popreg(dreg);
(*THE BELOW SHOULD BE OPTIMIZED FOR THE CASE
WHEN ONE ARGUMENT IS A CONSTANT*)
CASE subtypeÆopcodeÅ OF
1 (*EQU*) : opcde := teor;
2 (*NEQ*) : opcde := teor;
4 (*LEQ*) : BEGIN
opcde := tand;
eaddir.reg := dtop;
genx(tcomp,4,eaddir,eanone);
eaddir.reg := previous(dtop);
genx(tcomp,4,eaddir,eanone);
END;
6 (*GEQ*) : BEGIN
opcde := tand;
eaddir.reg :=
previous(previous(dtop));
genx(tcomp,4,eaddir,eanone);
eaddir.reg :=
previous(previous(previous(dtop)));
genx(tcomp,4,eaddir,eanone);
END;
END; (*CASE*)
buildaddr(source,ddirect,dtop,anone,0);
freedreg;
buildaddr(dest,ddirect,previous(dtop),anone,0);
genx(opcde,4,source,dest);
source.reg := dtop;
freedreg;
dest.reg := previous(dtop);
genx(opcde,4,source,dest);
source.reg := dtop;
freedreg;
dest.reg := dtop;
genx(tor,4,source,dest);
switch := false;
IF opcode <> xneq THEN opcode := xequ;
END ELSE BEGIN
optimi := nextpcod(instr);
switch := false;
IF opand3<>100 THEN BEGIN (*CMP ALREADY DONE*)
doubleop(source,dest,true(*COMMUTATIVITY*),switch);
k := sizeÆdtypeÅ;
genx(tcmp,k,source,dest);
(*1207A*) IF dtype = atyp THEN freeareg;
END
END;
IF dtype <> styp THEN BEGIN
eaddir.reg := dtop;
CASE subtypeÆopcodeÅ OF
1 (*EQU*) : opcde:=tseq;
2 (*NEQ*) : opcde:=tsne;
3 (*LES*) : IF switch THEN
opcde:=tsgt
ELSE opcde:=tslt;
4 (*LEQ*) : IF switch THEN
opcde:=tsge
ELSE opcde:=tsle;
5 (*GRT*) : IF switch THEN
opcde:=tslt
ELSE opcde:=tsgt;
6 (*GEQ*) : IF switch THEN
opcde:=tsle
ELSE opcde:=tsge;
END;
(*RM*) IF dtype = atyp THEN BEGIN
(*RM*) allocdreg;
(*RM*) eaddir.reg := dtop
(*RM*) END;
IF optimi = NIL THEN optimi:=instr; (*FORCE NOTEQ*)
IF optimi^.opcode = xfjp
THEN
BEGIN
optimi^.opand3 := 100 + conditional(instr)
;IF flag
THEN optimi^.opand3 := optimi^.opand3 + 100
END
ELSE BEGIN
IF flag
THEN BEGIN
allocdreg;
eaddir.reg := dtop
END;
IF dtype <> vtyp
THEN
BEGIN
genx(opcde,2,eaddir,eanone);
regtypeÆdtopÅ := btyp;
genx(tneg,1,eaddir,eanone)
END
END
END;
END;
END; (*PXEQU*)
PROCEDURE pxstp;
BEGIN WITH instr^ DO BEGIN
pushall;
(*PUSH ZERO ARGUMENT ON STACK*)
genx(tclr,2,eapush,eanone);
eaimmed.displ := 14;
genx(ttrap,2,eaimmed,eanone);
eaimmed.displ := 3;
genx(tdc,2,eaimmed,eanone);
END;
END; (*PXSTP*)
PROCEDURE pxexi;
BEGIN WITH instr^ DO BEGIN
pushall;
(*EXIT ARGUMENT ALREADY ON STACK*)
eaimmed.displ := 14;
genx(ttrap,2,eaimmed,eanone);
eaimmed.displ := opand1 + 3;
genx(tdc,2,eaimmed,eanone);
END;
END; (*PXEXI*)
PROCEDURE pxdis;
BEGIN WITH instr^ DO BEGIN
IF aalloc < 1 THEN popreg(areg);
(*604*) longbsr;
(*604*) eaimmed.displ := opand1;
(*604*) pcprint;
(*604*) writeln(listing,' ':10,'DC.W ',opand1:0);
(*604*) genx(tdc,2,eaimmed,eanone);
freeareg;
END;
END; (*PXDIS*)
PROCEDURE pxnew;
BEGIN WITH instr^ DO BEGIN
(*RM*) (*HEAP POINTER IS ^A5(4) *)
IF aalloc < 1 THEN popreg(areg);
(*604*) longbsr;
(*604*) eaimmed.displ := opand1; (* LENGTH TO ALLOC *)
(*604*) pcprint;
(*604*) writeln(listing,' ':10,'DC.W ',opand1:0);
(*604*) genx(tdc,2,eaimmed,eanone);
(*604*) freeareg;
END;
END; (*PXNEW*)
PROCEDURE pxmrk;
BEGIN WITH instr^ DO BEGIN
IF aalloc < 1 THEN popreg(areg);
(*604*) longbsr;
freeareg;
END;
END; (*PXMRK*)
PROCEDURE pxrls;
BEGIN WITH instr^ DO BEGIN
(*604*) IF aalloc < 1 THEN popreg(areg);
(*604*) longbsr;
(*604*) freeareg;
END;
END; (*PXRLS*)
PROCEDURE pxmst;
BEGIN
pushall;
END; (*PXMST*)
PROCEDURE pxarg;
BEGIN WITH instr^ DO BEGIN
(*604*) IF opand1 <> 0 THEN BEGIN
(*RM*) IF (dalloc=2) AND (dtype=ptyp) THEN
(*1205A*) BEGIN
(*1205A*) eaddir.reg := dtop;
(*1205A*) genx(tmove,4,eaddir,eapush);
(*1205A*) eaddir.reg := dbot;
(*1205A*) genx(tmove,4,eaddir,eapush);
(*1205A*) freedreg;freedreg
(*1205A*) END;
(*1205G*) IF (NOT (dtype IN longtypes)) AND (dalloc=0) AND (aalloc=0)
(*1205G*) THEN stkptr := stkptr -1;
(*RM*) IF aalloc = 1 THEN BEGIN pushareg;
stkptr:=stkptr-1 END;
(*RM*) IF dalloc = 1 THEN BEGIN pushdreg;
stkptr := stkptr -1 END;
IF (dalloc <> 0) OR (aalloc <> 0)
THEN error('STK NONEMPTY IN ARG ')
(*604*) END
END;
END; (*PXARG*)
PROCEDURE pxast;
BEGIN WITH instr^ DO BEGIN
(*ASSUMES PREVIOUS 'MST' HAS DONE PUSHALL*)
IF odd(opand1) THEN opand1:=opand1+1;
eaimmed.displ := opand1;(*SHOULD BE LONG #*)
eaadir.reg := sp;
genx(tsub,4,eaimmed,eaadir);
(*0416A*) IF NOT (dtype IN longtypes) THEN BEGIN
stkptr := stkptr +1;
IF stkptr>stkmax THEN
error('TOO MANY REG PUSHES ');
IF opand1=4 THEN kindstkÆstkptrÅ
:= areg ELSE kindstkÆstkptrÅ
:= dreg;
IF opand1=4 THEN typestkÆstkptrÅ:=atyp
ELSE IF opand1=2 THEN typestkÆstkptrÅ:=ityp
ELSE IF opand1=1 THEN typestkÆstkptrÅ:=btyp
ELSE IF opand1=8 THEN typestkÆstkptrÅ:=ptyp
ELSE typestkÆstkptrÅ:=vtyp;
IF dtype <> notatyp THEN BEGIN
typestkÆstkptrÅ:=dtype;
IF dtype = atyp
THEN kindstkÆstkptrÅ := areg
ELSE kindstkÆstkptrÅ := dreg;
END;
(*0416A*) END; (* LONGTYPES CODE *)
END;
END; (*PXAST*)
PROCEDURE pxmov;
BEGIN WITH instr^ DO BEGIN
WHILE aalloc < 2 DO popreg(areg);
IF opcode = xmov THEN
BEGIN allocdreg;
eaimmed.displ := opand1;
eaddir.reg := dtop;
genx(tmove,2,eaimmed,eaddir)
END
ELSE IF dalloc < 1 THEN popreg(dreg);
(*BYTE COUNT IS NOW IN DTOP*)
buildaddr(source,incr,atop,anone,0);
freeareg;
buildaddr(dest,incr,atop,anone,0);
(*RM*) genx(tmove,1,source,dest);
(*ONLY MOVES BYTE AT A TIME NOW*)(*FIX LIKE '_BIG'*)
eaddir.reg := dtop;
(*RM*) eaimmed.displ := 1;
(*RM*) genx(tsub,2,eaimmed,eaddir);
(*RM*) earel.displ := -4;
(*RM*) genx(tbne,0,earel,eanone);
freeareg;freedreg;
END;
END; (*PXMOV*)
PROCEDURE pxcup;
BEGIN WITH instr^ DO BEGIN
IF NOT proctableÆcurrlabelÅ.defined THEN
BEGIN
ltemp := pc;
sad(ltemp, 2);
referencelabel(currlabel,ltemp)
END;
proctableÆcurrlabelÅ.refed := true;
pushall;
ltemp := proctableÆcurrlabelÅ.location ;
lsb(ltemp, pc);
IF short(ltemp) THEN BEGIN
lasgn(earel.displ, ltemp);
IF (earel.displ >-128) AND (earel.displ < 127) THEN
BEGIN
ealab.displ := currlabel;
genx(tbsr, 2,ealab,eanone) ;
END
ELSE BEGIN
ealab.displ := currlabel;
genx(tlbsr,2,ealab,eanone);
END;
END ELSE
BEGIN
eadefer.reg := a3;
genx(tjsr,2,eadefer,eanone);
(*604*) pcprint;
write(listing,' ':10,'DC.L ':7,'$':1);
ssb(ltemp,2);
plint(listing,ltemp);
writeln(listing,' ');
FOR k := 0 TO 3 DO
BEGIN
eaimmed.displ := ltempÆkÅ;
genx(tdc,1,eaimmed,eanone)
END
END
END;
END; (*PXCUP*)
PROCEDURE pxvjp;
BEGIN WITH instr^ DO BEGIN
(*604*) pcprint;
(*RM*) writeln(listing,' ':10,'DC.W L',
(*RM*) opand1 + labeloffset:0,'-L',
(*RM*) lastlabel + labeloffset:0); (* GENX!!*)
IF labeltableÆopand1Å.defined
THEN
BEGIN
ltemp := labeltableÆopand1Å.location;
lsb(ltemp,labeltableÆlastlabelÅ.location);
lasgn(eaimmed.displ, ltemp)
END
ELSE
BEGIN
ltemp := labeltableÆlastlabel-1Å.location;
lsb(ltemp,labeltableÆlastlabel-2Å.location);
sad(ltemp,1);
shl(ltemp,1); (*TIMES 2*)
(*0401A*)
lasgn(eaimmed.displ,ltemp)
END;
genx(tdc,2,eaimmed,eanone);
(*RM*) END;
END; (*PXVJP*)
PROCEDURE pxujp;
VAR flag: boolean; (* INDICATES THAT CMP ALREADY DONE *)
BEGIN WITH instr^ DO BEGIN
flag := opand3 >= 200;
IF flag THEN opand3 := opand3 - 100;
IF labeltableÆopand1Å.defined = true
THEN
BEGIN
ltemp := labeltableÆopand1Å.location;
lsb(ltemp, pc);
ssb(ltemp,2);
lasgn(k, ltemp)
END
ELSE k := 200;
CASE subtypeÆopcodeÅ OF
1 (*UJP*) : BEGIN opcde := tbra;
IF (k<-127) OR (k>127) THEN opcde := tlbra END;
2 (*FJP*) : BEGIN opcde := tbeq ;
IF (k<-127) OR (k>127) THEN opcde := tlbeq ;
IF (dalloc = 0) AND (opand3 < 100)
THEN popreg(dreg);
END
END;
buildaddr(source,labelled,anone,anone,opand1);
IF opand3 >100
THEN BEGIN
opand3 := opand3 - 100;
IF switch THEN
BEGIN
IF (opand3=3) OR (opand3=4) THEN opand3:=opand3+2
ELSE IF (opand3=5) OR (opand3=6) THEN opand3:=opand3-2;
END ;
CASE opand3 OF
1: ; (* NEQ ALREADY TURNED AROUND *)
2: IF opcde = tbeq THEN opcde := tbne
ELSE opcde := tlbne;
3: IF opcde = tbeq THEN opcde := tbge
ELSE opcde := tlbge;
4: IF opcde = tbeq THEN opcde := tbgt
ELSE opcde := tlbgt;
5: IF opcde = tbeq THEN opcde := tble
ELSE opcde := tlble;
6: IF opcde = tbeq THEN opcde := tblt
ELSE opcde := tlblt;
END; (*CASE*)
END;
genx(opcde,0,source,eanone) ;
IF labeltableÆopand1Å.defined = false THEN
BEGIN
ltemp := pc;
ssb(ltemp, 2);
referencelabel(opand1,ltemp);
END;
IF (opcode = xfjp) AND (NOT flag) THEN freedreg;
END;
END; (*PXUJP*)
PROCEDURE pxdif;
BEGIN
(*THE BELOW SHOULD BE OPTIMIZED FOR THE CASE
WHEN ONE ARGUMENT IS A CONSTANT *)
setops;
END; (*PXDIF*)
(*604*) PROCEDURE pxspos;
(*604*) BEGIN
(*604*) WITH instr^ DO
(*604*) BEGIN
(*604*) longbsr;
(*604*) IF opcode <> xscon
THEN BEGIN
dtype := ityp;
allocdreg
END
(*604*) END
(*604*) END; (* PXSPOS *)
PROCEDURE pxsdel;
BEGIN
WITH instr^ DO
BEGIN
IF dalloc = 0
THEN BEGIN
eaddir.reg := d1;
genx(tmove,2,eapop,eaddir);
eaddir.reg := d0;
genx(tmove,2,eapop,eaddir);
stkptr := stkptr - 2;
dpopcnt := dpopcnt + 2
END ELSE
IF dalloc = 1
THEN BEGIN
buildaddr(source,ddirect,dtop,anone,0);
eaddir.reg := d1;
genx(tmove,2,source,eaddir);
eaddir.reg := d0;
genx(tmove,2,eapop,eaddir);
stkptr := stkptr - 1;
dpopcnt := dpopcnt + 1
END;
longbsr
END;
freedreg;freedreg
END; (* PXSDEL *)
(*604*) PROCEDURE pxsins;
BEGIN
WITH instr^ DO
BEGIN
IF dalloc = 0 THEN popreg(dreg);
IF dtop <> d0
THEN BEGIN
buildaddr(source,ddirect,dtop,anone,0);
eaddir.reg := d0;
genx(tmove,2,source,eaddir)
END;
longbsr;
freedreg;
END
END; (* PXSINS *)
PROCEDURE pxinn;
BEGIN WITH instr^ DO BEGIN
WHILE dalloc < 3 DO popreg(dreg);
(* THE BELOW SHOULD BE OPTIMIZED FOR THE CASE
WHERE ONE ARGUMENT IS A CONSTANT*)
(*RM*) eaddir.reg := previous(previous(dtop));
eaimmed.displ := 32;
(*RM*) genx(tcmp,1,eaimmed,eaddir);
(*RM*) earel.displ := 6;
(*RM*) genx(tblt,0,earel,eanone);
buildaddr(dest,ddirect,previous(dtop),dnone,0);
genx(tbtst,0,eaddir,dest);
(*RM*) earel.displ := 4;
(*RM*) genx(tbra,0,earel,eanone);
(*RM*) buildaddr(dest,ddirect,dtop,dnone,0);
genx(tbtst,0,eaddir,dest);
freedreg; freedreg;
eaddir.reg := dtop;
(*RM*) genx(tsne,0,eaddir,eanone);
(*1015A*) genx(tneg,1,eaddir,eanone);
(*1323A*) regtypeÆdtopÅ := btyp;
END;
END; (*PXINN*)
PROCEDURE pxsgs;
BEGIN WITH instr^ DO BEGIN
IF dalloc < 1 THEN popreg(dreg);
(*THE BELOW SHOULD BE OPTIMIZED FOR THE CASE
WHEN ONE ARGUMENT IS A CONSTANT*)
(*RM*) allocdreg;allocdreg;
(*RM*) eaddir.reg := dtop;
(*RM*) genx(tclr,4,eaddir,eanone);
(*RM*) eaddir.reg := previous(dtop);
(*RM*) genx(tclr,4,eaddir,eanone);
(*RM*) eaddir.reg := previous(previous(dtop));
(*RM*) eaimmed.displ := 32;
(*RM*) genx(tcmp,1,eaimmed,eaddir);
(*RM*) earel.displ := 6;
(*1204A*) genx(tbge,0,earel,eanone);
(*RM*) buildaddr(dest,ddirect,previous(dtop),dnone,0);
(*RM*) genx(tbset,0,eaddir,dest);
(*RM*) earel.displ := 4;
(*RM*) genx(tbra,0,earel,eanone);
(*RM*) buildaddr(dest,ddirect,dtop,dnone,0);
(*RM*) genx(tbset,0,eaddir,dest);
(*1204A*) genx(tmove,4,dest,eaddir);
(*1204A*) freedreg;
END;
END; (*PXSGS*)
PROCEDURE pxchk;
BEGIN
WITH instr^ DO
BEGIN
eaddir.reg := d7; (* USE D7 FOR CHECKING *)
source := eaddir;
(*604*) IF ((dtype<>atyp) AND (dtop=dnone)) OR ((dtype=atyp) AND (atop=anone))
THEN BEGIN
source.reg := a7;
source.mode := defer
END
(*604*) ELSE IF dtype=atyp THEN BEGIN
(*604*) source.reg := atop;
(*604*) source.mode := adirect
(*604*) END
(*604*) ELSE source.reg := dtop;
(*604*) genx(tmove,sizeÆdtypeÅ,source,eaddir);
IF sizeÆdtypeÅ = 1
THEN genx(texte,2,eaddir,eanone);
(*604*) IF dtype IN Æatyp,jtypÅ
(*604*) THEN BEGIN opand1:=1; opand2:=1 END; (* FAKE OUT NEXT INSTRS*)
IF opand2 = 0
THEN BEGIN
genx(tneg,2,eaddir,eanone);
eaimmed.displ := -opand1
END;
IF opand1 = 0 THEN eaimmed.displ := opand2;
IF (opand1=0) OR (opand2=0)
THEN genx(tchk,2,eaimmed,eaddir)
ELSE
(*604*) IF NOT (dtype IN Æjtyp,atypÅ)
(*604*) THEN BEGIN
sasgn(ltemp,opand2);
IF opand1 > 0
THEN sad (ltemp,opand1)
ELSE ssb(ltemp,opand1);
IF short(ltemp)
THEN BEGIN
eaimmed.displ := opand1;
genx(tsub,2,eaimmed,eaddir);
eaimmed.displ := opand2 - opand1;
genx(tchk,2,eaimmed,eaddir)
END
ELSE BEGIN
eaimmed.displ := opand1;
genx(tcmp,2,eaimmed,eaddir);
earel.displ := 8;
genx(tblt,0,earel,eanone);
eaimmed.displ := opand2;
genx(tcmp,2,eaimmed,eaddir);
earel.displ := 2;
genx(tble,0,earel,eanone);
eaimmed.displ := 13;
genx(ttrap,2,eaimmed,eanone)
END
END
(*604*) ELSE IF dtype=jtyp THEN BEGIN (*JTYP*)
(*604*) eapset.displ := 0;
(*604*) genx(tcmp,4,eapset,eaddir);
(*604*) earel.displ := 10;
(*604*) genx(tblt,0,earel,eanone);
(*604*) eapset.displ := 8;
(*604*) genx(tcmp,4,eapset,eaddir);
(*604*) earel.displ := 4;
(*604*) genx(tble,0,earel,eanone);
(*604*) eaimmed.displ := 13;
(*604*) genx(ttrap,2,eaimmed,eanone)
(*604*) END
(*604*) ELSE BEGIN (*ATYP*)
(*604*) eabased.displ := 368;
(*604*) eabased.reg := a5;
(*604*) genx(tcmp,4,eabased,eaddir);
(*604*) earel.displ := 6;
(*604*) genx(tblt,0,earel,eanone);
(*604*) eabased.displ := 4;
(*604*) genx(tcmp,4,eabased,eaddir);
(*604*) earel.displ := 4;
(*604*) genx(tble,0,earel,eanone);
(*604*) eaimmed.displ := 13;
(*604*) genx(ttrap,2,eaimmed,eanone)
(*604*) END
END (* WITH *)
END; (*PXCHK*)
(*RM*) PROCEDURE pxcvb;
BEGIN WITH instr^ DO BEGIN
(*604*) IF (NOT (dtype IN longtypes))
(*604*) THEN BEGIN
(*604*) IF dalloc < 1 THEN popreg(dreg);
(*604*) IF opcode = xcvb
(*604*) THEN BEGIN
(*604*) IF dalloc < 2 THEN popreg(dreg);
(*604*) eaddir.reg := previous(dtop)
(*604*) END
(*604*) ELSE eaddir.reg := dtop;
(*604*) regtypeÆeaddir.regÅ := dtype;
(*604*) IF (d1type=htyp) AND (dtype=jtyp)
(*604*) THEN genx(texte,2,eaddir,eanone);
(*604*) IF sizeÆdtypeÅ > sizeÆd1typeÅ
(*604*) THEN genx(texte,sizeÆdtypeÅ,eaddir,eanone);
(*604*) END;
(*604*) IF (d1type=ctyp) AND (dtype=styp)
(*604*) THEN BEGIN
(*604*) IF dalloc<1 THEN popreg(dreg);
(*604*) eaddir.reg := dtop;
(*604*) freedreg;
pushall;
genx(tmove,1,eaddir,eapush);
(*604*) eaimmed.displ := 1;
(*604*) genx(tmove,2,eaimmed,eapush)
(*604*) END;
(*RM*) IF ((d1type=vtyp) AND (dtype=styp)) THEN BEGIN
(*RM*) eaimmed.displ := opand1;
(*RM*) genx(tmove,2,eaimmed,eapush);
(*RM*) END;
(*RM*) IF ((d1type=styp) AND (dtype=vtyp))
(*RM*) OR ((d1type=styp) AND (dtype=utyp))
(*RM*) OR ((d1type=utyp) AND (dtype=styp)) THEN BEGIN
(*RM*) allocdreg;
(*RM*) eaddir.reg := dtop;
(*RM*) eaimmed.displ := opand1;
(*RM*) genx(tmove,4,eaimmed,eaddir);
(*RM*) freedreg;
longbsr;
(*RM*) END
(*RM*) END;
END; (*PXCVB*)
BEGIN (* GENERATE *)
CASE instr^.opcode OF
xatn,xcos,xsin,xexp,xsqt,xlog,xrnd,xtrc:
error('REAL NOT IMPLEMENTED');
(*604*) xscon,xspos,xslen: pxspos;
(*604*) xsins : pxsins;
xsdel,xscop : pxsdel;
xlab: pxlab;
(*RM*) xend: pxend;
xdef: pxdef;
xent,xentb: pxent;
xret: pxret;
xab,xng,xsqr,xnot,xdec,xinc,xodd: pxab;
xad,xsb,xmp,xdv,xmod,xior,xand: pxad;
xclo,xifd,xafi,xeol,xeof,xget,xput,xpos,xsee,xpee,xpok,
(*604*) xrdh, xwrh,
xrst,xrwt,xrln,xwln,xpag,xeio,
xrdb,xrdc,xrde,xrdi,xrdj,xrdq,xrdr,xrds,xrdv,
xwrb,xwrc,xwre,xwri,xwrj,xwrq,xwrr,xwrs,xwrv: pxclo;
xlod,xlda,xstr: pxlod;
xixa: pxixa;
xind: pxind;
xsto: pxsto;
(*480*) xstc: pxstc;
xldc: pxldc;
xlta: pxlta;
xlca: pxlca;
xisc: pxisc;
xlsc: pxlsc;
xequ,xneq,xles,xleq,xgrt,xgeq: pxequ;
xstp: pxstp;
xexi: pxexi;
xdis: pxdis;
xnew: pxnew;
xmrk: pxmrk;
xrls: pxrls;
xmst: pxmst;
xarg: pxarg;
xast: pxast;
xmov,xmovv: pxmov;
xcup: pxcup;
xxjp: genxxjp;
xvjp: pxvjp;
xujp,xfjp: pxujp;
xdif,xint,xuni: pxdif;
xinn: pxinn;
xsgs: pxsgs;
xchk:pxchk ;
xcvb,xcvt: pxcvb;
xchkf,xdas,xext,xins,xlupa,xlspa,xcsp,xcspf,xcupf,xdata,xdatb: ;
(*NOT CURRENTLY GEN'ED BY COMPILER*)
xnone: ;
END (*CASES*)
END; (*GENERATE*)
BEGIN (*FLUSH*)
optimi := firsti;
changed := false;
WHILE optimi <> NIL DO
BEGIN
WITH optimi^ DO
BEGIN
(*480*) IF inuse AND ((opcode = xldc) OR (opcode = xinc)
(*480*) OR (opcode = xlda))
THEN
BEGIN
CASE opcode OF
(*480*) xlda: BEGIN
(*480*) IF NOT (dtype IN longtypes)
(*480*) THEN
(*480*) BEGIN
(*480*) optim2 := nextpcod(optimi);
(*480*) optim3 := nextpcod(optim2);
(*480*) IF (optim2^.opcode=xldc)
(*480*) AND (optim2^.dtype=ityp)
(*480*) AND(optim3^.opcode=xixa)
(*480*) THEN BEGIN
(*480*) optim2^.inuse :=false;
(*480*) optim3^.inuse := false;
(*480*) optimi^.opand2 :=
(*480*) optimi^.opand2 +
(*480*) optim2^.opand1 *
(*480*) optim3^.opand1;
(*480*) changed := true
(*480*) END
(*480*) ELSE IF ((optim2^.opcode=xldc)
(*480*) OR (optim2^.opcode=xlod))
(*480*) AND (optim3^.opcode=xsto)
(*480*) THEN BEGIN
(*480*) inuse := false;
(*480*) changed := true;
(*480*) optim3^.opand3 :=
(*480*) optim3^.opand1;
(*480*) optim3^.opand1:=opand1;
(*480*) optim3^.opand2:=opand2;
(*480*) optim3^.opcode:=xstr
(*480*) END
(*480*) ELSE IF optim2^.opcode=xind
(*480*) THEN BEGIN
(*480*) optim2^.inuse :=false;
(*480*) changed := true;
(*480*) optimi^.opcode := xlod;
(*480*) optimi^.dtype :=
(*480*) optim2^.dtype;
(*480*) optimi^.optype := optli;
(*480*) optimi^.opand2 :=
(*480*) optimi^.opand2 +
(*480*) optim2^.opand1;
(*480*) optimi^.opand3 :=
(*480*) optim2^.opand2;
(*480*) END
(*480*) END
(*480*) END; (* XLDA*)
xldc: BEGIN
IF NOT (dtype IN longtypes)
AND (dtype <> jtyp) AND (dtype<>atyp)
THEN
BEGIN
changed := true; (*ASSUME*)
(*480*) tempi := nextpcod(optimi);
IF tempi^.opcode=xdec
THEN
BEGIN
opand1:=opand1
- tempi^.opand1;
tempi^.inuse:=false;
END (*THEN*)
ELSE IF tempi^.opcode=xinc
THEN BEGIN
opand1:=opand1+
tempi^.opand1;
tempi^.inuse:=false
END
ELSE IF tempi^.opcode=xad
THEN BEGIN
opcode := xinc;
tempi^.inuse:=false
END
ELSE IF tempi^.opcode=xsb
THEN BEGIN
opcode:= xdec;
tempi^.inuse := false
END
(*480*) ELSE IF tempi^.opcode=xng
(*480*) THEN BEGIN
(*480*) opand1 := -opand1;
(*480*) tempi^.inuse:=false
(*480*) END
ELSE IF (opand1=0)
AND (tempi^.opcode=xixa)
THEN BEGIN
inuse := false;
tempi^.inuse:=false
END
(*480*) ELSE IF (tempi^.opcode=xcvt)
(*480*) AND (tempi^.d1type=ctyp)
(*480*) AND (tempi^.dtype=ityp)
(*480*) THEN BEGIN
(*480*) tempi^.inuse := false;
(*480*) dtype := ityp;
(*480*) opand1 :=asciiÆ
(*480*) opstring^.
(*480*) vstringaÆ1ÅÅ
(*480*) END
ELSE changed := false;
END (*THEN*)
(*480*) ELSE
(*480*) BEGIN (* S OR V *)
(*480*) changed := true;
(*480*) optim2 := nextpcod(optimi);
(*480*) IF (optim2^.opcode=xcvt)
(*480*) AND (dtype = styp)
(*480*) AND (optim2^.d1type=styp)
(*480*) AND (optim2^.dtype=vtyp)
AND (optim2^.opand1<=strlength)
(*480*) THEN BEGIN
(*480*) optim2^.inuse := false;
(*480*) opand1 := optim2^.opand1;
(*480*) dtype := vtyp;
(*480*) END
(*480*) ELSE IF (optim2^.opcode=xstr)
(*480*) AND (optim2^.dtype=vtyp)
(*480*) AND(dtype = vtyp)
AND (opand1<=strlength)
(*480*) THEN BEGIN
(*480*) optim2^.inuse := false;
(*480*) opcode := xstc;
(*480*) opand3 := opand1;
(*480*) opand1:=optim2^.opand1;
(*480*) opand2:=optim2^.opand2
(*480*) END
(*480*) ELSE changed := false
(*480*) END (* S OR V *)
END; (*XLDC*)
xinc: BEGIN
IF NOT (dtype IN longtypes)
AND (dtype<>jtyp) AND (dtype <> atyp)
THEN BEGIN
tempi := nextpcod(optimi);
IF tempi^.opcode=xdec
THEN BEGIN
opand1:=opand1
- tempi^.opand1;
tempi^.inuse:=false;
IF opand1 = 0
THEN inuse := false
ELSE changed :=true;
END
END
END; (*XINC*)
END; (*CASE*)
END; (*THEN*)
END; (*WITH*)
IF NOT changed THEN optimi := optimi^.next ELSE optimi:=firsti;
changed := false;
END; (*WHILE*)
tempi := firsti;
WHILE tempi <> NIL DO
BEGIN
IF tempi^.inuse THEN BEGIN
IF odd(debug DIV 2) THEN flpc := true;
generate(tempi);
tempi^.inuse := false END;
tempi := tempi^.next
END;
lasti := firsti;
templevel := -1; (*INVALIDATE A4 (POINTER TO INTERMED LEXICAL LEVEL*)
END; (*FLUSH*)
(*-------------------------------------------------------------------------
INPUT SCANNER SECTION
-------------------------------------------------------------------------*)
PROCEDURE nextline ;
VAR i: integer ;
BEGIN
IF eof(pcode) THEN writeln(output,'**** EOF ENCOUNTERED':24) ;
(* HALT NEEDED INSIDE THIS 'THEN' *)
REPEAT
linelen := 1 ;
WHILE NOT eoln(pcode) AND (linelen < linelngth) DO
BEGIN
read(pcode,linebufÆlinelenÅ);
linelen := linelen + 1
END;
readln(pcode);
linebufÆlinelenÅ := ' ' ;
IF linebufÆ1Å = '.' THEN linecount := linecount+1 ;
IF (odd(debug DIV 8) AND (linebufÆ1Å='.'))
OR (odd(debug DIV 4) AND (linebufÆ1Å<>'.'))
THEN BEGIN
write(listing, '*' );
FOR i:=1 TO linelen DO write(listing, linebufÆiÅ) ;
IF linebufÆ1Å = '.'
THEN write(listing,' ':(95 - linelen),linecount:6);
writeln(listing,' ')
END;
UNTIL (linebufÆ1Å <> '.') OR eof(pcode);
chcnt := 1 ;
END (* NEXTLINE *) ;
PROCEDURE getheader;
VAR
i: integer;
okval: boolean;
BEGIN
nextline;
linebufÆlinelen+1Å := ' ';
IF linebufÆ3Å<>'2'
THEN writeln(output,' ***** INPUT NOT M68000 PCODES!',
' COMPILER PHASE 2 ABORTING. *****');
chcnt := 5;
getstring; (* MODULE NAME *)
mainflg := linebufÆ17Å <> 'S'; (* MAIN OR SUBPROGRAM *)
chcnt := 18; (* POINT BEYOND OPTIONS *)
okval := gethex;
IF okval THEN exproc := ltemp; (* NUMBER OF ENTRIES IN JUMP TABLE *)
jtsize := getinteger; (* NUMBER OF ENTRIES IN JUMP TABLE *)
pc := exproc;
sad(pc,jtsize * 10);
okval := gethex;
IF okval THEN heapstart := ltemp;
okval := gethex;
IF okval THEN stkstart := ltemp;
genstart := pc;
IF mainflg THEN sad(pc,24); (* LEAVE ROOM FOR INIT CODE *)
genloc := pc;
corebase := pc;
END; (* GETHEADER *)
PROCEDURE scan;
VAR xexternal: boolean;
(*RM*) i: integer; (* COUNTER FOR SET INIT *)
PROCEDURE getopcode; (*PROCESS INPUT LINE FOR A LEGAL OPCODE, LOOK
IT UP IN 'MN', SET CURROPCODE, CURROPTYPE *)
VAR i: integer;
j: mns;
BEGIN
WHILE (linebufÆchcntÅ = ' ') AND (chcnt < linelen) DO
chcnt := chcnt + 1;
i := 1;
WHILE (linebufÆchcntÅ <> ' ') AND (i<5) AND (chcnt < linelen) DO
BEGIN
opsymÆiÅ := linebufÆchcntÅ;
chcnt := chcnt + 1; i := i + 1;
END;
WHILE i < 5 DO BEGIN opsymÆiÅ := ' '; i := i + 1 END;
curropcode := xnone;
IF (opsymÆ1Å<>'Y') AND (opsymÆ1Å<>'Z') THEN
FOR j := fmnÆopsymÆ1ÅÅ TO pred(fmnÆsuccibm(opsymÆ1Å)Å) DO
IF mnÆjÅ = opsym THEN curropcode := j;
IF curropcode = xnone THEN BEGIN error('ILLEGAL OPCODE ');
curroptype := op0
END
ELSE curroptype := otÆcurropcodeÅ;
END; (*GETOPCODE*)
PROCEDURE gettype;
BEGIN
WHILE (linebufÆchcntÅ = ' ') AND (chcnt < linelen) DO
chcnt := chcnt + 1;
WITH curri^ DO BEGIN
dtype := notatyp;
IF (linebufÆchcntÅ>='A') AND (linebufÆchcntÅ<='V') THEN
CASE linebufÆchcntÅ OF
'D','E','F','G','K','L','M','N','O','T': ;
'A': dtype := atyp;
(*RM*) 'H': dtype := htyp;
'I': dtype := ityp;
'J': dtype := jtyp;
'R': dtype := rtyp;
'Q': dtype := qtyp;
(*RM*) 'U': dtype := utyp;
'V': dtype := vtyp;
'S': dtype := styp;
'B': dtype := btyp;
'C': dtype := ctyp;
'P': dtype := ptyp
END;
END;
chcnt := chcnt + 1;
END; (*GETTYPE*)
PROCEDURE getlabel;
BEGIN
WHILE (linebufÆchcntÅ = ' ') AND (chcnt < linelen) DO
chcnt := chcnt + 1;
IF linebufÆchcntÅ = 'L' THEN dollar := false
ELSE IF linebufÆchcntÅ = '$' THEN dollar := true
ELSE error('LABEL EXPECTED ');
chcnt := chcnt + 1;
IF dollar THEN currlabel := getinteger
ELSE BEGIN currlabel := getinteger - labeloffset ;
IF currlabel<0 THEN currlabel:= 0; (* NEEDED IF OLD PCODES *)
IF currlabel > highlabel THEN highlabel:= currlabel
END
END; (*GETLABEL*)
PROCEDURE definelabel( absol: boolean);
PROCEDURE fixup(absol: boolean);
VAR addr1: ^labelref; addr2: lint;
addr3: integer;
i: integer;
BEGIN
addr1 := labeltableÆcurrlabelÅ.refchain;
REPEAT
addr2 := addr1^.coreloc ;
ltemp := addr2;
lsb(ltemp,corebase);
sad(ltemp,1);
lasgn(i, ltemp);
IF i <= 0
THEN
BEGIN
gensave := genloc;
genloc := addr2;
locount := maxcore - 20;
coresave := corecount;
corecount := maxcore - 19;
END;
IF NOT absol
THEN BEGIN
ltemp := pc;
lsb(ltemp, addr2);
lasgn(i,ltemp);
IF locount <> 1
THEN addr3 := locount
ELSE
BEGIN
ltemp := addr2;
lsb(ltemp, corebase);
sad(ltemp, 1);
lasgn(addr3,ltemp)
END;
coreÆaddr3Å := i DIV 256;
coreÆaddr3+1Å := i MOD 256
END ELSE
BEGIN
IF locount <> 1
THEN addr3 := locount
ELSE
BEGIN
ltemp := addr2;
lsb(ltemp,corebase);
sad (ltemp,1);
lasgn(addr3,ltemp)
END;
lasgn(i, labeltableÆcurrlabelÅ.location);
coreÆaddr3Å := defvalue DIV 256;
coreÆaddr3+1Å := defvalue MOD 256;
IF (defvalue < 0) OR (i < 0)
THEN BEGIN
coreÆaddr3Å := abs(coreÆaddr3Å);
coreÆaddr3+1Å:=abs(coreÆaddr3+1Å);
coreÆaddr3Å := 255 - coreÆaddr3Å;
coreÆaddr3+1Å := 256 - coreÆaddr3+1Å;
IF coreÆaddr3+1Å = 256
THEN BEGIN
coreÆaddr3+1Å := 0;
coreÆaddr3Å := coreÆaddr3Å + 1;;
IF coreÆaddr3Å = 256
THEN coreÆaddr3Å := 0;
END;
END
END ;
IF locount <> 1
THEN
BEGIN
emitcode;
genloc := gensave;
locount := 1;
corecount := coresave;
END;
addr1 := addr1^.next;
UNTIL addr1 = NIL;
END; (*FIXUPLABEL*)
BEGIN (*DEFINELABEL*)
flush;
WITH labeltableÆcurrlabelÅ DO BEGIN
IF defined THEN error ('DOUBLY DEFINED LABEL')
ELSE IF refed THEN fixup(absol);
defined := true;
IF NOT absol THEN location := pc
ELSE sasgn(location, defvalue)
END
END; (*DEFINELABEL*)
PROCEDURE defineproc(absol: boolean);
PROCEDURE fixupproc;
VAR
addr1:^labelref; addr2: lint; i: integer;
BEGIN
gensave := genloc;
coresave := corecount;
addr1 := proctableÆcurrlabelÅ.refchain;
REPEAT
locount := maxcore - 20;
corecount := maxcore - 17; (* DATA IS IN -20 TO -17 *)
addr2 := addr1^.coreloc;
IF curropcode = xdef
THEN BEGIN
ltemp := exproc;
lsb(ltemp, addr2)
END
ELSE BEGIN
ltemp := pc;
lsb(ltemp, addr2)
END;
FOR i := 0 TO 3 DO
coreÆlocount + iÅ := ltempÆiÅ;
genloc := addr2;
emitcode;
addr1 := addr1^.next;
UNTIL addr1 = NIL;
genloc := gensave;
locount := 1;
corecount := coresave;
END; (*FIXUPPROC*)
BEGIN
flush;
WITH proctableÆcurrlabelÅ DO BEGIN
IF curropcode = xent THEN emitcode;
IF defined THEN error('DOUBLY DEFINED LABEL')
ELSE IF refed THEN fixupproc;
defined := true;
IF NOT absol THEN location := pc
ELSE sasgn(location, defvalue);
IF curropcode=xdef
THEN BEGIN
location := exproc;
sad(exproc,10);
END
END
END; (*DEFINEPROC*)
PROCEDURE quai(VAR newi: iptr);(*"QUAI" IS "QUEUE UP ANOTHER INSTRUCTION"*)
BEGIN IF lasti^.inuse THEN
IF lasti^.next = NIL THEN
BEGIN new(tempi);
tempi^.opstring := NIL;
tempi^.opset := NIL;
tempi^.next := NIL;
lasti^.next := tempi;
lasti := tempi
END
ELSE lasti := lasti^.next;
newi := lasti
END; (*QUAI*)
BEGIN (*SCAN*)
nextline;
IF linebufÆ1Å <> ' ' THEN BEGIN labeled := true; (*COLLECT LABEL*)
(*RM*) getlabel; lastlabel := currlabel
END
ELSE labeled := false;
getopcode;
IF curropcode = xdef
THEN IF NOT dollar
THEN
BEGIN
defvalue := getinteger;
absol := true
END
ELSE absol := false
ELSE absol := false;
IF labeled THEN IF dollar THEN defineproc(absol)
ELSE definelabel(absol);
quai(curri); (*GET A QUEUE SLOT FOR A NEW INSTRUCTION *)
WITH curri^ DO BEGIN
inuse := true; dtype := notatyp; d1type := notatyp;
opcode := curropcode; optype := curroptype;
opand1 := 0; opand2 := 0; opand3 := 0;
CASE optype OF
endop, op0: BEGIN
opand1 := currlabel;
IF curropcode = xdef THEN
IF NOT dollar THEN opand2 := defvalue
END;
opli: BEGIN opand1 := getinteger; opand2 := getinteger;
dtype := atyp END;
opt: BEGIN gettype;
IF dtype IN longtypes THEN opand1 := getinteger
END;
oplab: BEGIN getlabel; opand1 := currlabel END;
(*RM*) op2t: BEGIN gettype; d1type := dtype; gettype;
(*RM*) IF d1type IN Æstyp,utyp,vtypÅ THEN
(*RM*) opand1 := getinteger END;
opti: BEGIN gettype;
IF dtype = notatyp THEN chcnt := chcnt - 1;
opand1 := getinteger;
IF (opand1=0) AND (opcode = xarg)
THEN BEGIN
opcode := xnone;
inuse := false
END;
IF dtype IN longtypes THEN opand2 := getinteger
END;
opt2i: BEGIN
gettype;
IF dtype <> jtyp
THEN BEGIN opand1 := getinteger;
opand2 := getinteger
END
ELSE BEGIN
IF opset = NIL THEN new(opset);
WITH opset^ DO BEGIN
FOR i := 1 TO 8 DO BEGIN
opand1 := getinteger;
setvÆi*2-1Å :=
hexdataÆopand1 DIV 16 + 1Å;
setvÆi*2Å :=
hexdataÆopand1 MOD 16 + 1Å
END
END;
opand1 := 1;
END
END;
opi: opand1 := getinteger;
op3i: BEGIN opand1 := getinteger;
opand2 := getinteger;
opand3 := getinteger
END;
optli: BEGIN gettype; opand1 := getinteger;
opand2 := getinteger;
IF dtype IN longtypes THEN opand3 := getinteger
END;
optl2i: BEGIN gettype; opand1 := getinteger;
opand2 := getinteger;
opand3 := getinteger END;
optv: BEGIN gettype;
(*604*) IF dtype IN Æityp,htypÅ THEN opand1 := getinteger
(*604*) ELSE IF (dtype=atyp) AND (opcode<>xldc)
(*604*) THEN opand1 := getinteger
ELSE IF dtype IN Æ styp,ctypÅ THEN BEGIN
IF opstring = NIL THEN new(opstring);
getstring;
IF dtype = ctyp THEN alength := 1;
opstring^.stringl := alength;
opstring^.vstringa := vstring
END
ELSE IF dtype = btyp THEN BEGIN
opand1 := getinteger
END
(*604*) ELSE IF dtype = ptyp THEN BEGIN
(*RM*) IF opset = NIL THEN new(opset);
(*RM*) WITH opset^ DO BEGIN
(*RM*) FOR i := 1 TO 8 DO BEGIN
(*RM*) opand1 := getinteger;
(*RM*) setvÆi*2-1Å := hexdataÆopand1 DIV 16+1Å;
(*RM*) setvÆi*2Å := hexdataÆopand1 MOD 16 + 1Å;
(*RM*) END
(*RM*) END;
opand1 := 0
END ELSE IF dtype IN Æatyp,jtypÅ
THEN BEGIN
opand1 := getinteger;
opand2 := getinteger;
opand3 := getinteger;
opand4 := getinteger
(*RM*) END ELSE ; (* R NOT IMPLEMENTED *)
END;
opent: BEGIN opand1 := getinteger;
opand2 := getinteger; (*SEGSIZE LABEL*)
getstring; (*OPTIONS(IGNORED)*)
IF (vstringÆ1Å>='0') AND(vstringÆ1Å<='9')
THEN debug := ord(vstringÆ1Å)-ord('0');
IF (vstringÆ2Å>='0') AND (vstringÆ2Å<='9')
THEN debug := debug * 10 +
ord(vstringÆ2Å)-ord('0');
getstring; (*NAME*)
END;
opentb: (*NOT CURRENTLY IMPLEMENTED*)
END (*CASE*)
END (*WITH*)
END; (*SCAN*)
(*-------------------------------------------------------------------------
INITIALIZATION SECTION
-------------------------------------------------------------------------*)
PROCEDURE init;
VAR i: integer;
j: mns;
r: register;
BEGIN
errorwr := false;
writeln(listing,' ':10,'LLEN',' ':3,'120');
stkptr := -1;
flpc := false;
dalloc := 0; aalloc := 0;
dtop := dnone; atop := anone;
dbot := dnone; abot := anone;
sp := a7;
dalloccnt := 0; aalloccnt := 0;
dpushcnt := 0; apushcnt := 0;
dpopcnt := 0; apopcnt := 0;
longtypes := Æptyp,vtyp,styp,utypÅ;
sasgn(pc,12388);
debug := 9;
genloc := pc;
corecount := 0;
genstart := pc;
locount := 1;
corebase := pc;
clr(progstart);
mainflg := false;
linecount := -1;
sasgn(rtjump,490);
stkstartÆ0Å := 0; stkstartÆ1Å := 0; stkstartÆ2Å := 127;
stkstartÆ3Å := 254;
heapstartÆ0Å := 255; heapstartÆ1Å := 255; heapstartÆ2Å := 255;
heapstartÆ3Å := 255; (* INITIALIZE HEAPSTART TO HEX FFFFFFFF *)
jtsize := 10;
level := 0;
templevel := -1; (*-1 WHENEVER A4 NOT POINTING TO A VALID DISPLAY LEVEL*)
highlabel := 0; labeloffset := 0;
toplabel := 0;
absol := false;
FOR i:= 0 TO maxlabel DO BEGIN proctableÆiÅ.defined :=false;
proctableÆiÅ.refed :=false;
proctableÆiÅ.refchain := NIL;
labeltableÆiÅ.refchain := NIL;
labeltableÆiÅ.defined :=false;
labeltableÆiÅ.refed :=false
END;
new(firstesd); WITH firstesd^ DO BEGIN name := xnone;
next := NIL;
sasgn(reference, 0);
END;
sizeÆatypÅ := 4;
sizeÆitypÅ := 2;
sizeÆjtypÅ := 4;
sizeÆrtypÅ := 4;
sizeÆqtypÅ := 8;
sizeÆvtypÅ := 4;
sizeÆstypÅ := 4;
sizeÆbtypÅ := 1;
sizeÆptypÅ := 8;
sizeÆnotatypÅ := 0;
sizeÆctypÅ := 1;
(*RM*) sizeÆhtypÅ := 1;
(*RM*) sizeÆutypÅ := 4;
(*480*) new(fakei);
(*480*) WITH fakei^ DO
(*480*) BEGIN
(*480*) opcode := xnone; next := NIL; opand1 := 0; inuse := true;
(*480*) optype := op0; dtype := notatyp; d1type := notatyp;
(*480*) opand2 := 0; opand3 := 0; opstring := NIL; opset := NIL
(*480*) END;
new(firsti); lasti := firsti; firsti^.next := NIL; firsti^.inuse := false;
firsti^.opstring := NIL; firsti^.opset := NIL;
FOR i := 1 TO strlength DO blanksÆiÅ := ' ';
mnÆxab Å :='AB '; mnÆxad Å :='AD ';
mnÆxafi Å :='AFI '; mnÆxand Å :='AND ';
mnÆxarg Å :='ARG ';
mnÆxast Å :='AST '; mnÆxatn Å :='ATN ';
mnÆxchk Å :='CHK '; mnÆxchkfÅ :='CHKF';
mnÆxclo Å :='CLO ';
mnÆxcos Å :='COS '; mnÆxcsp Å :='CSP ';
mnÆxcspfÅ :='CSPF'; mnÆxcup Å :='CUP ';
mnÆxcupfÅ :='CUPF'; mnÆxcvb Å :='CVB ';
mnÆxcvt Å :='CVT '; mnÆxdas Å :='DAS ';
mnÆxdataÅ :='DATA'; mnÆxdatbÅ :='DATB';
mnÆxdec Å :='DEC '; mnÆxdef Å :='DEF ';
mnÆxdif Å :='DIF '; mnÆxdis Å :='DIS ';
mnÆxdv Å :='DV '; mnÆxeio Å :='EIO ';
mnÆxend Å :='END ';
mnÆxent Å :='ENT '; mnÆxentbÅ :='ENTB';
mnÆxeof Å :='EOF ';
mnÆxeol Å :='EOL '; mnÆxequ Å :='EQU ';
(*1015B*) mnÆxexi Å :='EXIT'; mnÆxexp Å :='EXP ';
mnÆxext Å :='EXT '; mnÆxfjp Å :='FJP ';
mnÆxgeq Å :='GEQ '; mnÆxget Å :='GET ';
mnÆxgrt Å :='GRT '; mnÆxifd Å :='IFD ';
mnÆxinc Å :='INC '; mnÆxind Å :='IND ';
mnÆxinn Å :='INN '; mnÆxins Å :='INS ';
mnÆxint Å :='INT '; mnÆxior Å :='IOR ';
mnÆxisc Å :='ISC '; mnÆxixa Å :='IXA ';
mnÆxlab Å :='LAB '; mnÆxlca Å :='LCA ';
mnÆxlda Å :='LDA '; mnÆxldc Å :='LDC ';
mnÆxleq Å :='LEQ '; mnÆxles Å :='LES ';
mnÆxlod Å :='LOD '; mnÆxlog Å :='LOG ';
mnÆxlsc Å :='LSC '; mnÆxlspaÅ :='LSPA';
mnÆxlta Å :='LTA '; mnÆxlupaÅ :='LUPA';
mnÆxmod Å :='MOD '; mnÆxmov Å :='MOV ';
mnÆxmovvÅ :='MOVV'; mnÆxmp Å :='MP ';
mnÆxmrk Å :='MRK '; mnÆxmst Å :='MST ';
mnÆxneq Å :='NEQ ';
mnÆxnew Å :='NEW '; mnÆxng Å :='NG ';
mnÆxnot Å :='NOT '; mnÆxodd Å :='ODD ';
mnÆxpag Å :='PAG '; mnÆxpee Å :='PEE ';
mnÆxpok Å :='POK '; mnÆxpos Å :='POS ';
mnÆxput Å :='PUT '; mnÆxrdb Å :='RDB ';
mnÆxrdc Å :='RDC '; mnÆxrde Å :='RDE ';
mnÆxrdi Å :='RDI '; mnÆxrdj Å :='RDJ ';
(*604*) mnÆxrdh Å := 'RDH '; mnÆxwrh Å := 'WRH ';
mnÆxrdq Å :='RDQ '; mnÆxrdr Å :='RDR ';
mnÆxrds Å :='RDS '; mnÆxrdv Å :='RDV ';
mnÆxret Å :='RET ';
mnÆxrln Å :='RLN '; mnÆxrls Å :='RLS ';
mnÆxrnd Å :='RND ';
mnÆxrst Å :='RST '; mnÆxrwt Å :='RWT ';
mnÆxsb Å :='SB '; mnÆxsconÅ :='SCON';
mnÆxscopÅ :='SCOP'; mnÆxsdelÅ :='SDEL';
mnÆxsee Å :='SEE '; mnÆxsgs Å :='SGS ';
mnÆxsin Å :='SIN '; mnÆxsinsÅ :='SINS';
mnÆxslenÅ :='SLEN'; mnÆxsposÅ :='SPOS';
mnÆxsqr Å :='SQR '; mnÆxsqt Å :='SQT ';
mnÆxstc Å :='STC ';
mnÆxsto Å :='STO '; mnÆxstp Å :='STP ';
mnÆxstr Å :='STR '; mnÆxtrc Å :='TRC ';
mnÆxujp Å :='UJP '; mnÆxuni Å :='UNI ';
(*RM*) mnÆxvjp Å :='VJP ';
mnÆxwln Å :='WLN '; mnÆxwrb Å :='WRB ';
mnÆxwrc Å :='WRC '; mnÆxwre Å :='WRE ';
mnÆxwri Å :='WRI '; mnÆxwrj Å :='WRJ ';
mnÆxwrq Å :='WRQ '; mnÆxwrr Å :='WRR ';
mnÆxwrs Å :='WRS '; mnÆxwrv Å :='WRV ';
mnÆxxjp Å :='XJP ';
mnÆxnoneÅ :=' ';
fmnÆ'A'Å :=xab ; fmnÆ'B'Å :=xchk;
fmnÆ'C'Å :=xchk; fmnÆ'D'Å :=xdas;
fmnÆ'E'Å :=xeio; fmnÆ'F'Å :=xfjp;
fmnÆ'G'Å :=xgeq; fmnÆ'H'Å :=xifd;
fmnÆ'I'Å :=xifd; fmnÆ'J'Å :=xlab;
fmnÆ'K'Å :=xlab; fmnÆ'L'Å :=xlab;
fmnÆ'M'Å :=xmod; fmnÆ'N'Å :=xneq;
fmnÆ'O'Å :=xodd; fmnÆ'P'Å :=xpag;
fmnÆ'Q'Å :=xrdb; fmnÆ'R'Å :=xrdb;
fmnÆ'S'Å :=xsb ; fmnÆ'T'Å :=xtrc;
(*RM*) fmnÆ'U'Å :=xujp; fmnÆ'V'Å :=xvjp;
fmnÆ'W'Å :=xwln; fmnÆ'X'Å :=xxjp;
fmnÆ'Y'Å :=xnone;fmnÆ'Z'Å :=xnone;
tmnÆtmove Å :='MOVE '; tmnÆtlink Å :='LINK '; tmnÆtunlk Å :='UNLK ';
tmnÆtrts Å :='RTS '; tmnÆttst Å :='TST '; tmnÆtbgt Å :='BGT.S';
tmnÆtneg Å :='NEG '; tmnÆtsubq Å :='SUB '; tmnÆtbtst Å :='BTST ';
tmnÆtsnz Å :='SNZ '; tmnÆtadd Å :='ADD '; tmnÆtsub Å :='SUB ';
tmnÆtand Å :='AND '; tmnÆtor Å :='OR '; tmnÆtmuls Å :='MULS ';
tmnÆtdivs Å :='DIVS '; tmnÆtcmp Å :='CMP '; tmnÆtclr Å :='CLR ';
tmnÆttrap Å :='TRAP '; tmnÆtdcnt Å :='DCNT '; tmnÆtbsr Å :='BSR.S';
tmnÆtaddq Å :='ADD '; tmnÆtcomp Å :='NOT '; tmnÆtlbsr Å :='BSR ';
tmnÆtmoveqÅ :='MOVE '; tmnÆtseq Å :='SEQ '; tmnÆtsne Å :='SNE ';
tmnÆtsge Å :='SGE '; tmnÆtslt Å :='SLT '; tmnÆtsgt Å :='SGT ';
tmnÆtsle Å :='SLE '; tmnÆtlea Å :='LEA '; tmnÆtldq Å :='MOVE ';
tmnÆtbraÅ :='BRA.S'; tmnÆtbne Å :='BNE.S'; tmnÆtequ Å :='EQU ';
tmnÆtbeqÅ :='BEQ.S';
tmnÆtlbgtÅ :='BGT '; tmnÆtlbra Å :='BRA ';
tmnÆtlbneÅ :='BNE '; tmnÆtlbeqÅ :='BEQ ';
tmnÆtlbltÅ :='BLT '; tmnÆtasl Å := 'ASL ';
tmnÆtblt Å :='BLT.S'; tmnÆtjmpÅ := 'JMP ';
tmnÆtpea Å :='PEA '; tmnÆtbsetÅ := 'BSET ';
tmnÆtbz Å :='BEQ '; tmnÆtjsr Å := 'JSR ';
(*RM*) tmnÆteor Å :='EOR ';
(*RM*) tmnÆtexte Å := 'EXT '; tmnÆtswapÅ :='SWAP ';
tmnÆtcmpm Å := 'CMPM ';
tmnÆtbnz Å := 'BNE.S'; tmnÆtbge Å := 'BGE.S';
tmnÆtble Å := 'BLE.S'; tmnÆtchk Å := 'CHK ';
tmnÆtdc Å := 'DC '; (*DUMMY INSTR*)
tmnÆtlbleÅ := 'BLE '; tmnÆtlbgeÅ := 'BGE ';
(*RM*) dnameÆatypÅ := 'A'; dnameÆitypÅ := 'I'; dnameÆjtypÅ := 'J';
(*RM*) dnameÆrtypÅ := 'R'; dnameÆqtypÅ := 'Q'; dnameÆvtypÅ := 'V';
(*RM*) dnameÆstypÅ := 'S'; dnameÆbtypÅ := 'B'; dnameÆptypÅ := 'P';
(*RM*) dnameÆnotatypÅ :=' '; dnameÆctypÅ := 'C'; dnameÆhtypÅ :='H';
(*RM*) dnameÆutypÅ := 'U';
FOR j := xab TO xxjp DO otÆjÅ := op0;
otÆxab Å := opt ; otÆxad Å := opt ;
(*604*) otÆxarg Å := opti ; (* CHANGE FOR 6809 CHIPS STUFF *)
otÆxast Å := opti ; otÆxatn Å := opt ;
(*604*) otÆxchk Å := opt2i ; otÆxchkfÅ := opt ;
otÆxcos Å := opt ; otÆxcsp Å := oplab ;
otÆxcup Å := oplab ;
otÆxcvb Å := op2t ;
otÆxcvt Å := op2t ; otÆxdas Å := opi ;
(*DATA,DATB*)
otÆxdec Å := opti ;
otÆxdis Å := opi ;
otÆxdv Å := opt ; otÆxend Å := endop ;
otÆxent Å := opent ; otÆxentbÅ := opentb;
otÆxequ Å := opt ;
otÆxexi Å := opi ;
otÆxexp Å := opt ;
otÆxext Å := optl2i; otÆxfjp Å := oplab ;
otÆxgeq Å := opt ;
otÆxgrt Å := opt ;
otÆxinc Å := opti ; otÆxind Å := opti ;
otÆxins Å := op3i ;
otÆxixa Å := opi ;
otÆxlca Å := optv ;
otÆxlda Å := opli ; otÆxldc Å := optv ;
otÆxleq Å := opt ; otÆxles Å := opt ;
otÆxlod Å := optli ; otÆxlog Å := opt ;
otÆxlsc Å := opi ; otÆxlspaÅ := opi ;
otÆxlupaÅ := opi ;
otÆxmod Å := opt ; otÆxmov Å := opi ;
otÆxmp Å := opt ;
otÆxneq Å := opt ;
otÆxnew Å := opi ; otÆxng Å := opt ;
otÆxodd Å := opt ;
otÆxret Å := opli ;
otÆxrnd Å := opt ;
otÆxsb Å := opt ;
otÆxsin Å := opt ;
otÆxsqr Å := opt ; otÆxsqt Å := opt ;
otÆxsto Å := opt ;
otÆxstr Å := optli ; otÆxtrc Å := opt ;
otÆxujp Å := oplab ;
(*RM*) otÆxvjp Å := oplab;
otÆxxjp Å := oplab ;
FOR j := xab TO xnone DO flÆjÅ := true;
flÆxab Å := false; flÆxad Å := false; flÆxand Å := false;
flÆxast Å := false; flÆxcvb Å := false; flÆxcvt Å := false;
flÆxdas Å := false;
flÆxdataÅ := false; flÆxdatbÅ := false; flÆxdec Å := false;
flÆxdif Å := false; flÆxdv Å := false; flÆxequ Å := false;
flÆxext Å := false;
flÆxgeq Å := false; flÆxgrt Å := false; flÆxinc Å := false;
flÆxind Å := false; flÆxinn Å := false; flÆxins Å := false;
flÆxint Å := false;
flÆxior Å := false;
flÆxixa Å := false; flÆxlca Å := false; flÆxlda Å := false;
flÆxldc Å := false; flÆxleq Å := false; flÆxles Å := false;
flÆxlod Å := false; flÆxlspaÅ := false; flÆxlta Å := false;
flÆxlupaÅ := false;
flÆxmod Å := false; flÆxmov Å := false; flÆxmp Å := false;
flÆxneq Å := false; flÆxng Å := false; flÆxnot Å := false;
flÆxodd Å := false; flÆxsb Å := false; flÆxsqr Å := false;
flÆxuni Å := false; flÆxnoneÅ := false;
FOR j := xab TO xxjp DO subtypeÆjÅ := 0;
subtypeÆxab Å := 1; subtypeÆxad Å := 1;
subtypeÆxng Å := 2; subtypeÆxsb Å := 2;
subtypeÆxdec Å := 3; subtypeÆxand Å := 3;
subtypeÆxinc Å := 4; subtypeÆxior Å := 4;
subtypeÆxnot Å := 5; subtypeÆxmp Å := 5;
subtypeÆxodd Å := 6; subtypeÆxdv Å := 6;
subtypeÆxsqr Å := 7; subtypeÆxmod Å := 7;
subtypeÆxlod Å := 1; subtypeÆxequ Å := 1;
subtypeÆxlda Å := 2; subtypeÆxneq Å := 2;
subtypeÆxstr Å := 3; subtypeÆxles Å := 3;
subtypeÆxleq Å := 4;
subtypeÆxgrt Å := 5;
subtypeÆxgeq Å := 6;
subtypeÆxujp Å := 1;
subtypeÆxfjp Å := 2;
buildaddr(eanone,none,anone,anone,0);
buildaddr(eaddir,ddirect,anone,anone,0);
buildaddr(eaadir,adirect,anone,anone,0);
buildaddr(eaimmed,immed,anone,anone,0);
buildaddr(eadefer,defer,anone,anone,0);
buildaddr(eaincr,incr,anone,anone,0);
buildaddr(eapop,incr,sp,anone,0);
buildaddr(eapush,decr,sp,anone,0);
buildaddr(ealimm,labimmed,anone,anone,0);
buildaddr(earel,relative,anone,anone,0);
buildaddr(ealab,labelled,anone,anone,0);
(*RM*) buildaddr(eapset,pimmed,anone,anone,0);
buildaddr(eabased,based,anone,anone,0);
buildaddr(ealong,limmed,anone,anone,0);
FOR r := dnone TO a7 DO regtypeÆrÅ := notatyp;
r := d0;
FOR i:= 0 TO ndregs DO BEGIN dregsÆiÅ := r;
r := succ(r)
END;
r := a0;
FOR i:= 0 TO naregs DO BEGIN aregsÆiÅ := r;
r := succ(r)
END;
machcode := ' ';
machindex := 1;
hexdata := '0123456789ABCDEF';
sasgn(exproc,12288); (* HEX 3000 *)
FOR c := chr(0) TO chr(127) DO asciiÆcÅ := 32; (*BLANK*)
asciiÆ'a'Å:=97; asciiÆ'b'Å:=98; asciiÆ'c'Å:=99; asciiÆ'd'Å:=100;
asciiÆ'e'Å:=101;asciiÆ'f'Å:=102;asciiÆ'g'Å:=103;asciiÆ'h'Å:=104;
asciiÆ'i'Å:=105;asciiÆ'j'Å:=106;asciiÆ'k'Å:=107;asciiÆ'l'Å:=108;
asciiÆ'm'Å:=109;asciiÆ'n'Å:=110;asciiÆ'o'Å:=111;asciiÆ'p'Å:=112;
asciiÆ'q'Å:=113;asciiÆ'r'Å:=114;asciiÆ's'Å:=115;asciiÆ't'Å:=116;
asciiÆ'u'Å:=117;asciiÆ'v'Å:=118;asciiÆ'w'Å:=119;asciiÆ'x'Å:=120;
asciiÆ'y'Å:=121;asciiÆ'z'Å:=122;
asciiÆ'A'Å:=65; asciiÆ'B'Å:=66; asciiÆ'C'Å:=67; asciiÆ'D'Å:=68;
asciiÆ'E'Å:=69; asciiÆ'F'Å:=70; asciiÆ'G'Å:=71; asciiÆ'H'Å:=72;
asciiÆ'I'Å:=73; asciiÆ'J'Å:=74; asciiÆ'K'Å:=75; asciiÆ'L'Å:=76;;
asciiÆ'M'Å:=77; asciiÆ'N'Å:=78; asciiÆ'O'Å:=79; asciiÆ'P'Å:=80;
asciiÆ'Q'Å:=81; asciiÆ'R'Å:=82; asciiÆ'S'Å:=83; asciiÆ'T'Å:=84;
asciiÆ'U'Å:=85; asciiÆ'V'Å:=86; asciiÆ'W'Å:=87; asciiÆ'X'Å:=88;
asciiÆ'Y'Å:=89; asciiÆ'Z'Å:=90;
asciiÆ'0'Å:=48; asciiÆ'1'Å:=49; asciiÆ'2'Å:=50; asciiÆ'3'Å:=51;
asciiÆ'4'Å:=52; asciiÆ'5'Å:=53; asciiÆ'6'Å:=54; asciiÆ'7'Å:=55;
asciiÆ'8'Å:=56; asciiÆ'9'Å:=57;
asciiÆ' 'Å:=32; asciiÆ'*'Å:=42; asciiÆ'>'Å:=62;
asciiÆ'!'Å:=33; asciiÆ'+'Å:=43; asciiÆ'?'Å:=63;
asciiÆ'"'Å:=34; asciiÆ','Å:=44; asciiÆ'^'Å:=64;
asciiÆ'#'Å:=35; asciiÆ'-'Å:=45;
asciiÆ'$'Å:=36; asciiÆ'.'Å:=46; asciiÆ'Ø'Å:=92;
asciiÆ'%'Å:=37; asciiÆ'/'Å:=47;
asciiÆ'&'Å:=38; asciiÆ':'Å:=58; asciiÆ'!'Å:=94;
asciiÆ''''Å:=39;asciiÆ';'Å:=59;
asciiÆ'('Å:=40; asciiÆ'<'Å:=60;
asciiÆ')'Å:=41; asciiÆ'='Å:=61;
asciiÆ'Æ'Å:=91; asciiÆ'Å'Å:=93;
asciiÆ'_'Å:=95; asciiÆ'æ'Å:=123; asciiÆ'å'Å:=125;
asciiÆ'`'Å:=96; asciiÆ'ø'Å:=124; asciiÆ'^'Å:=126;
rtÆxcvbÅ := 4228; rtÆxafiÅ := 4112; rtÆxcloÅ := 4116;
rtÆxdisÅ := 4104; rtÆxeofÅ := 4120; rtÆxeolÅ := 4124;
rtÆxequÅ := 4268; rtÆxexiÅ := 4096; rtÆxgeqÅ := 4288;
rtÆxendÅ := 4096;
rtÆxgetÅ := 4128; rtÆxgrtÅ := 4284; rtÆxifdÅ := 4132;
rtÆxindÅ := 4264; rtÆxleqÅ := 4280; rtÆxlesÅ := 4276;
rtÆxlodÅ := 4264; rtÆxneqÅ := 4272; rtÆxnewÅ := 4108;
rtÆxpagÅ := 4136; rtÆxpeeÅ := 4140; rtÆxpokÅ := 4144;
rtÆxposÅ := 4148; rtÆxputÅ := 4152; rtÆxrdbÅ := 4176;
rtÆxrdcÅ := 4180; rtÆxrdiÅ := 4184; rtÆxrdsÅ := 4188;
rtÆxrdvÅ := 4212; rtÆxrlnÅ := 4156; rtÆxrstÅ := 4160;
rtÆxrwtÅ := 4164; rtÆxsconÅ:= 4232; rtÆxscopÅ:= 4236;
rtÆxsdelÅ:= 4240; rtÆxseeÅ := 4168; rtÆxsinsÅ := 4244;
rtÆxslenÅ:= 4248; rtÆxsposÅ:= 4252; rtÆxstoÅ := 4260;
rtÆxstpÅ := 4100; rtÆxstrÅ := 4256; rtÆxwlnÅ := 4172;
rtÆxwrbÅ := 4192; rtÆxwrcÅ := 4196; rtÆxwriÅ := 4200;
rtÆxwrsÅ := 4204; rtÆxwrvÅ := 4208; rtÆxcvtÅ := 4220;
rtÆxcvtsuÅ := 4216; rtÆxcvtusÅ := 4224; rtÆxldcÅ := 4292;
rtÆxstrvÅ := 4296; rtÆxstovÅ := 4300; rtÆxindvÅ := 4304;
rtÆxlodvÅ := 4304; rtÆxequvÅ := 4308; rtÆxneqvÅ := 4312;
rtÆxlesvÅ := 4316; rtÆxleqvÅ := 4320; rtÆxgrtvÅ := 4324;
rtÆxgeqvÅ := 4328; rtÆxldcvÅ := 4332; rtÆxstcÅ := 4336;
rtÆxmpÅ := 4340; rtÆxdvÅ := 4344; rtÆxmodÅ := 4348;
rtÆxrlsÅ := 4148; rtÆxmrkÅ := 4144; rtÆxrdhÅ := 4528;
rtÆxrdjÅ := 4532; rtÆxwrhÅ := 4520; rtÆxwrjÅ := 4524;
END; (*INIT*)
(*-------------------------------------------------------------------------
SUMMARY PROCEDURE
-------------------------------------------------------------------------*)
PROCEDURE summarize;
BEGIN writeln(listing,'*D REGISTERS: ',dalloccnt,' ALLOCATIONS, REQUIRING ',
dpushcnt,' PUSHES');
writeln(listing,'* AND ', dpopcnt,' POPS');
writeln(listing,'*A REGISTERS: ',aalloccnt,' ALLOCATIONS, REQUIRING ',
apushcnt,' PUSHES');
writeln(listing,'* AND ', apopcnt,' POPS');
writeln(listing,'*');
write(listing,'*TOTAL OF ');
ltemp := pc;
lsb(ltemp,genstart);
plint(listing,ltemp);
writeln(listing,' BYTES GENERATED.');
write(output,' CODE GENERATOR PRODUCED ');
plint(output,ltemp);
writeln(output,' BYTES OF CODE.');
writeln(output,' LABELS USED:',toplabel:4);
IF errorwr THEN writeln(output,' ***** ERROR(S) DETECTED *****')
ELSE writeln(output,' NO ERRORS DETECTED.');
writeln(output,'STACKPTR = ',stkptr:5);
page(listing)
END;
(*-------------------------------------------------------------------------
MAIN PROGRAM
-------------------------------------------------------------------------*)
BEGIN
rewrite(listing);
writeln(listing,'* M68000 PASCAL COMPILER PHASE TWO VERSION 1.10 08/07/80 ');
reset(pcode);
rewrite(object);
writeln(output,' M68000 PASCAL COMPILER PHASE TWO VERSION 1.10');
writeln(output,' COPYRIGHTED 1980 BY MOTOROLA, INC.');
writeln(listing,' ');
init;
getheader;
IF linebufÆ3Å = '2' THEN
REPEAT
scan;
(*WITH CURRI^ DO
WRITELN(LISTING,'* ',MNÆOPCODEÅ,ORD(OPTYPE),OPAND1,OPAND2,OPAND3);*)
IF flÆcurri^.opcodeÅ THEN flush;
UNTIL curri^.optype = endop;
summarize;
END.
▶EOF◀