|
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: 192000 (0x2ee00)
Types: TextFile
Names: »mpasc1«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »mpasc1«
(*$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 *)
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; (*EXTERNAL SYMBOL DEFINITION LIST*)
REFERENCE: ADDRESS;
NEXT: @ESD
END;
EAMODE = (NONE,DDIRECT,ADIRECT,DEFER,INCR,DECR,
(*RM*) BASED,INDEX, PCINDEX, STSHORT,
RELATIVE,EXTERNAL,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: FILE OF CHAR;
PCODE: FILE OF CHAR;
OBJECT: FILE OF CHAR;
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;
(*RM*) BEGIN
(*RM*) WITH INSTR@ DO BEGIN
(*RM*) FOR I := 1 TO 8 DO
BEGIN
(*RM*) WRITE(LISTING,OPSET@.SETV(. K + I .):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*) EXTERNAL: 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; (* EXTERNAL *)
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;
EXTERNAL: 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;
EXTERNAL: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 = EXTERNAL
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 EXTERNAL: 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◀