d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
ack/lang/a68s/aem/a68s1ce.p
ceriel 04e2dac8e7 replaced some BSS by CON; The order in memory is important! 
Adapted to our installation
1989-02-08 09:23:46 +00:00

2127 lines
82 KiB
OpenEdge ABL
Raw Blame History

30000 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
30010 (*+84() FUNCTION TX(M: MODE): XTYPE; FORWARD; ()+84*)
30020 (*+86() PROCEDURE STACKSB (SB:PSB); FORWARD; ()+86*)
30030 (*+86() PROCEDURE UNSTACKSB ; FORWARD; ()+86*)
30040 (*+87()
30050 (**)
30060 (*CODE EMITTER*)
30070 (**************)
30080 (**)
30090 (*+01() (*$T-+) ()+01*)
30110 (*-05()
30120 PROCEDURE LOAD (WHERE:SBTTYP; SB:PSB); FORWARD;
30130 PROCEDURE EMITEND; FORWARD;
30140 PROCEDURE EMITX1 (OPCOD:POP;TYP1:OPDTYP;OPND1:ADDRINT); FORWARD;
30150 PROCEDURE EMITX2 (OPCOD:POP;TYP1:OPDTYP;OPND1:ADDRINT;TYP2:OPDTYP;OPND2:ADDRINT); FORWARD;
30160 FUNCTION GENLCLGBL (VAR OPCOD:POP; SB:PSB):OFFSETR; FORWARD;
30170 PROCEDURE FIXUPF(ALABL:LABL);FORWARD;
30180 FUNCTION FIXUPM: LABL; FORWARD;
30200 PROCEDURE CLEAR (SB:PSB); FORWARD;
30210 PROCEDURE UNSTKP1(TYP:OPDTYP; OPND:PSB); FORWARD;
30220 ()-05*)
30230 PROCEDURE EMITOP (OPCOD:POP); FORWARD;
30240 PROCEDURE GENDENOT (OPCOD:POP; SB:PSB); FORWARD;
30250 PROCEDURE EMITCONST (OPERAND:A68INT); FORWARD;
30260 FUNCTION GETNEXTLABEL: LABL;
30270 BEGIN GETNEXTLABEL := NEXTLABEL; NEXTLABEL := NEXTLABEL+1 END;
30280 (**)
30290 (**)
30300 (*+32()
30310 (*-01() (*-02() PROCEDURE HALT; VAR I,K: INTEGER; BEGIN I:=0;K := K DIV I END; ()-02*) ()-01*)
30320 PROCEDURE ASERT (ASERTION:BOOLEAN; REASON:ALFA);
30330 BEGIN
30340 IF NOT (ASERTION) THEN
30350 BEGIN
30360 WRITELN(OUTPUT,' ASSERT FAILED ',REASON);
30370 (*+01() PUTSEG(OUTPUT); ()+01*)
30380 EMITEND;
30390 HALT
30400 END
30410 END;
30420 (**)
30430 ()+32*)
30440 (*-24()
30450 PROCEDURE TAKELINE;
30460 BEGIN
30462 (*+23()WRITELN(LSTFILE);()+23*)
30470 (*+02()WRITELN(LGO); ()+02*)
30480 (*+23()LSTCNT:=LSTCNT+1;
30490 IF LSTCNT > LINESPERPAGE THEN CHECKPAGE
30492 ()+23*)
30500 END;
30510 ()-24*)
30520 (*+23()
30530 PROCEDURE EMITOP (* (OPCOD:POP) *);
30540 VAR FLAG,I: INTEGER;
30550 NAME: ALFA;
30560 BEGIN
30570 FLAG := 0;
30580 NAME := CODETABLE[OPCOD].ROUTINE;
30590 WHILE NAME = ' ' DO
30600 BEGIN
30610 IF OPCOD >= 0 THEN
30620 BEGIN OPCOD := OPCOD-1; FLAG := FLAG+1 END
30630 ELSE BEGIN OPCOD := OPCOD+1; FLAG := FLAG-1 END;
30640 NAME := CODETABLE[OPCOD].ROUTINE
30650 END;
30660 IF NUMPARAMS=0 THEN WRITE(LSTFILE,' ':25);
30670 FOR I:=3 DOWNTO NUMPARAMS+1 DO WRITE(LSTFILE,' ':20);
30680 WRITE (LSTFILE,NAME);
30690 IF FLAG >0 THEN WRITELN (LSTFILE,'+',FLAG:2)
30700 ELSE IF FLAG < 0 THEN WRITELN (LSTFILE,FLAG:3)
30710 ELSE WRITELN (LSTFILE);
30720 NUMPARAMS:=0;
30730 END;
30740 (**)
30750 PROCEDURE WRITEOPERAND (TYP:OPDTYP; OPERAND:ADDRINT);
30760 VAR REC: RECORD CASE SEVERAL OF
30770 1: (INT: INTEGER);
30780 2: (LEX: PLEX ) ;
30790 3,4,5,6,7,8,9,10: () ;
30800 END;
30810 BEGIN
30820 IF NUMPARAMS=1 THEN WRITE(LSTFILE,' ':25);
30830 CASE TYP OF
30840 OCVIMMED: WRITE (LSTFILE,' IMMED',OPERAND:10,', ');
30850 OCVMEM : WRITE (LSTFILE,' MEM',OPERAND:10,', ');
30860 OCVEXT : BEGIN REC.INT := OPERAND; WRITE(LSTFILE,' EXT ');
30870 WRITE(LSTFILE,REC.LEX^.S10)
30880 END;
30890 OCVFREF : WRITE (LSTFILE,' FREF',OPERAND:10,', ');
30900 OCVFIM : WRITE (LSTFILE,' FIM',OPERAND:10,', ')
30910 END
30920 END;
30930 (**)
30940 PROCEDURE UPPER;
30950 BEGIN WRITELN(LSTFILE,' UPPER.') END;
30960 PROCEDURE FILL(WHERE:SBTTYP;SB:PSB);
30970 BEGIN
30980 WITH SB^ DO
30990 BEGIN
31000 IF NOT (WHERE IN [SBTSTKN,SBTDL,SBTXN]) THEN SBLEN:=SZWORD;
31010 IF WHERE IN [SBTSTK..SBTSTKN] THEN
31020 BEGIN
31030 RTSTKDEPTH:=RTSTKDEPTH+SBLEN;
31040 WITH ROUTNL^ DO
31050 IF RTSTKDEPTH > RNLENSTK THEN RNLENSTK:=RTSTKDEPTH;
31060 END;
31070 SBTYP:=WHERE;
31080 END;
31090 END;
31100 (**)
31110 FUNCTION SETINLINE(OPCOD:POP):BOOLEAN;
31120 BEGIN
31130 SETINLINE:=TRUE;
31140 END;
31150 (**)
31160 FUNCTION NORMAL(SB:PSB) : SBTTYP;
31170 BEGIN
31180 WITH SB^ DO WITH SBMODE^.MDV DO
31190 IF(NOT(SBUNION IN SBINF)) AND (NOT MDPILE) AND (MDLEN=0) THEN
31200 NORMAL:=SBTVOID
31210 ELSE
31220 NORMAL:=SBTSTK;
31230 END;
31240 (**)
31250 PROCEDURE LOADSTK(SB: PSB);
31260 VAR LEN: INTEGER;
31270 BEGIN
31280 WITH SB^ DO WITH SBMODE^.MDV DO
31290 IF SBUNION IN SBINF THEN LEN:=SZWORD ELSE IF MDPILE THEN LEN:=SZADDR ELSE LEN:=MDLEN;
31300 IF LEN=0 THEN LOAD(SBTVOID,SB)
31310 ELSE LOAD(SBTSTK,SB);
31320 END;
31330 (**)
31340 PROCEDURE TWIST;
31350 VAR TEMPPTR:PSB;
31360 BEGIN
31370 WITH RTSTACK^ DO
31380 BEGIN
31390 IF (SBTYP >= SBTSTK) AND (SBRTSTK^.SBTYP >= SBTSTK) THEN
31400 BEGIN TAKELINE; EMITOP(PSWAP); END;
31410 TEMPPTR:=SBRTSTK;
31420 SBRTSTK:=TEMPPTR^.SBRTSTK;
31430 TEMPPTR^.SBRTSTK:=RTSTACK;
31440 RTSTACK:=TEMPPTR;
31450 END;
31460 END;
31470 (**)
31480 PROCEDURE LOAD (*+05() (WHERE: SBTTYP; SB: PSB) ()+05*);
31490 VAR TEMPOP:POP;
31500 TOFFSET:INTEGER;
31510 TEMPTYP:SBTTYP;
31520 TWISTED:BOOLEAN;
31530 SB1: PSB;
31540 BEGIN
31550 WITH SB^ DO
31560 BEGIN
31570 IF SBRTSTK <> NIL THEN
31580 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN
31590 BEGIN
31600 LOADSTK(SBRTSTK);
31610 SBRTSTK^.SBINF:=SBRTSTK^.SBINF-[SBSTKDELAY];
31620 END;
31630 TWISTED:=FALSE;
31640 IF (WHERE IN [SBTVOID,SBTSTK..SBTXN]) AND (SBTYP IN [SBTID..SBTRPROC]) THEN
31650 BEGIN
31660 SB1 := RTSTACK;
31670 WHILE (SB1^.SBTYP IN [SBTID..SBTRPROC]) AND (SB1<>SB) DO
31680 SB1 := SB1^.SBRTSTK;
31690 IF SB1<>SB THEN
31700 BEGIN TWISTED:=TRUE; TWIST;
31710 (*+32() ASERT (RTSTACK =SB,'LOAD-A '); ()+32*)
31720 END;
31730 CASE SBTYP OF
31740 SBTVAR:BEGIN
31750 TEMPOP:=PLOADVAR;
31760 TOFFSET:=GENLCLGBL(TEMPOP,SB);
31770 EMITX2(TEMPOP,OCVIMMED,SBLOCRG,OCVLCLGBL,TOFFSET);
31780 END;
31790 SBTID,SBTIDV:BEGIN
31800 TEMPOP:=PPUSH;
31810 TOFFSET:=GENLCLGBL(TEMPOP,SB);
31820 EMITX1(TEMPOP,OCVLCLGBL,TOFFSET);
31830 END;
31840 SBTLIT:EMITX1(PPUSHIM,OCVIMMED,SBVALUE);
31850 SBTDEN:GENDENOT(PPUSHIM,SB);
31860 END; (*OF CASE*)
31870 END;
31880 END;
31890 FILL(WHERE,SB);
31900 IF TWISTED THEN TWIST;
31910 END;
31920 (**)
31930 PROCEDURE PROC1OP(OPCOD:POP;TYP:OPDTYP;OPND:ADDRINT;NOTINL:BOOLEAN);
31940 VAR SB:PSB;
31950 BEGIN
31960 SB:=ASPTR(OPND);
31970 IF RTSTACK<>SB THEN TWIST;
31980 LOADSTK(SB);
31990 UNSTKP1(TYP,SB);
32000 END;
32010 (**)
32020 PROCEDURE PROC2OP(OPCOD:POP;TYP1:OPDTYP;OPND1:ADDRINT;TYP2:OPDTYP;OPND2:ADDRINT;NOTINL:BOOLEAN);
32030 VAR SB1,SB2:PSB;
32040 BEGIN
32050 SB1:=ASPTR(OPND1);
32060 SB2:=ASPTR(OPND2);
32070 LOADSTK(SB1);
32080 LOADSTK(SB2);
32090 IF SB2<>RTSTACK THEN TWIST;
32100 UNSTKP1(TYP2,SB2);
32110 UNSTKP1(TYP1,SB1);
32120 END;
32130 (**)
32140 PROCEDURE PARAM(TYP:OPDTYP;OPND:ADDRINT;OPCOD:POP);
32150 BEGIN
32180 IF TYP <> OCVNONE THEN
32190 BEGIN
32200 NUMPARAMS:=NUMPARAMS+1;
32210 WRITEOPERAND(TYP,OPND);
32220 END;
32230 END;
32240 (**)
32250 (**)
32260 PROCEDURE FIXUPF (*+05() (ALABL:LABL) ()+05*);
32270 BEGIN
32280 TAKELINE;
32290 WRITELN (LSTFILE,' ':20,ALABL:6,':')
32300 END;
32310 (**)
32320 FUNCTION FIXUPM (*+05(): LABL()+05*);
32330 VAR L: LABL;
32340 BEGIN
32350 TAKELINE;
32360 L := GETNEXTLABEL;
32370 FIXUPM := L;
32380 WRITELN (LSTFILE,' ':20,L:6,':')
32390 END;
32400 (**)
32410 PROCEDURE EMITXWORD (TYP:OPDTYP; OPERAND:A68INT);
32420 BEGIN
32430 TAKELINE;
32440 WRITE(LSTFILE,' ':25);
32450 WRITEOPERAND (TYP,OPERAND);
32460 WRITELN (LSTFILE)
32470 END;
32480 (**)
32490 PROCEDURE EMITALF(OPERAND: ALFA);
32500 VAR I: INTEGER;
32510 BEGIN
32520 TAKELINE;
32530 WRITE(LSTFILE, ' ':25, '''');
32540 FOR I := 1 TO 10 DO WRITE(LSTFILE, OPERAND[I]);
32550 WRITELN(LSTFILE, '''');
32560 END;
32570 (**)
32580 PROCEDURE FIXUPFIM (ALABL:LABL; VALUE:A68INT);
32590 BEGIN
32600 TAKELINE;
32610 WRITELN (LSTFILE,' ':20,ALABL:6,': EQU ',VALUE:8)
32620 END;
32630 (**)
32640 PROCEDURE FIXLABL (OLDLABL, NEWLABL: LABL; KNOWN: BOOLEAN);
32650 BEGIN
32660 TAKELINE;
32670 WRITELN (LSTFILE,' ':20,OLDLABL:6, ' EQU ', NEWLABL:8,':')
32680 END;
32690 (**)
32700 ()+23*)
32710 (* EM-1 CODE EMITTER *)
32720 (*********************)
32730 (*+02()
32740 PROCEDURE PARAM(TYP:OPDTYP; OPND:ADDRINT; OPCOD: POP); FORWARD;
32750 (*-24()
32760 PROCEDURE WRITEBYTE(B:INTEGER); BEGIN WRITE(LGO,B:5) END;
32770 PROCEDURE WRITEINSTN(INST:COMPACT);
32775 VAR COUNT:INTEGER;
32780 BEGIN IF INST=EOOPNDS THEN TAKELINE
32782 ELSE BEGIN
32783 WRITE(LGO,' ');
32784 FOR COUNT:=1 TO 3 DO
32785 BEGIN
32787 WRITE(LGO,CHR(ORD(INST[COUNT])+32)); (*TRANSLATE TO LOWER CASE*)
32788 END;
32789 END;
32790 END;
32792 PROCEDURE WRITECON(COMMON, SIZE: INTEGER; OPERAND: ADDRINT);
32793 BEGIN WRITE(LGO,' ',OPERAND);
32794 IF SIZE<>SZWORD THEN
32796 WRITE(LGO, 'I', SIZE:1);
32799 END;
32800 PROCEDURE WRITELABEL(GLOBAL:BOOLEAN;OPERAND:INTEGER);
32810 BEGIN
32821 IF GLOBAL THEN WRITE(LGO,'.'); WRITE(LGO,OPERAND:0); TAKELINE; END;
32841 PROCEDURE WRITEOFFSET(L:LABL;OFFSET:INTEGER);
32842 BEGIN WRITE(LGO,' .',L:0);
32843 IF OFFSET<>0 THEN
32844 BEGIN IF OFFSET>0 THEN WRITE(LGO,'+');
32845 WRITE(LGO,OFFSET:0);
32846 END;
32848 END;
32850 ()-24*)
32860 (*+24()
32870 PROCEDURE WRITEBYTE(B:BYTE);
32880 (*PROCEDURE TO WRITE A BYTE OF COMPACT ASSEMBLER CODE *)
32890 BEGIN
32900 WRITE(LGO,B);
32910 END;
32920 (**)
32930 PROCEDURE WRITEINSTN(INST:COMPACT);
32940 BEGIN WRITE(LGO,INST) END;
32950 (**)
32960 PROCEDURE WRITECON(COMMON,SIZE:INTEGER;OPERAND:ADDRINT);
32970 (* WRITES A POSITIVE INTEGER IN BASE 256,OR AS AN OFFSET FROM 120 *)
32980 VAR I,COUNT,T:INTEGER;
32982 OUTSTR:PACKED ARRAY[1..10] OF CHAR;
32990 BEGIN
33000 IF (OPERAND < 120) AND (OPERAND >= -120) AND (COMMON=CPACTCONS) AND (SIZE=SZWORD) THEN
33010 WRITEBYTE(OPERAND+120)
33020 ELSE
33030 BEGIN
33040 COUNT := 1;
33050 CASE COMMON OF
33060 CPACTLCL:BEGIN
33070 (*+32() ASERT(OPERAND<65536,'WRITECON-A'); ()+32*)
33075 COUNT := 2;
33080 END;
33090 CPACTGBL:BEGIN
33100 (*+32() ASERT(OPERAND < 32768 ,'WRITECON-B'); ()+32*)
33110 IF OPERAND > 255 THEN BEGIN COMMON := COMMON+1; COUNT := 2 END
33120 END;
33130 CPACTCONS:BEGIN
33140 COUNT := 2;
33170 IF OPERAND > 32767 THEN BEGIN COMMON := COMMON+1; COUNT := 4 END;
33180 END;
33191 END;
33193 IF SIZE<>SZWORD THEN
33194 BEGIN
33195 T := 1;
33196 REPEAT
33197 OUTSTR[T] := CHR((OPERAND MOD 10)+ORD('0'));
33198 OPERAND := OPERAND DIV 10; T := T+1;
33199 UNTIL OPERAND=0;
33200 WRITEBYTE(CPACTUNS);
33201 WRITECON(CPACTCONS,SZWORD,SIZE);
33202 T := T-1;
33203 WRITEBYTE(120+T);
33204 FOR I := T DOWNTO 1 DO
33208 WRITEBYTE(ORD(OUTSTR[I]))
33209 END
33212 ELSE
33213 BEGIN
33214 WRITEBYTE(COMMON);
33220 FOR I := 1 TO COUNT DO
33230 BEGIN
33232 T := OPERAND MOD 256;
33244 WRITEBYTE(T);
33250 OPERAND := (OPERAND-T) DIV 256;
33260 END;
33265 END;
33270 END;
33280 END;
33290 (**)
33300 PROCEDURE WRITELABEL(GLOBAL:BOOLEAN;OPERAND:INTEGER);
33310 BEGIN
33320 IF GLOBAL THEN WRITECON(CPACTGBL, SZWORD, OPERAND) ELSE WRITECON(CPACTLCL, SZWORD, OPERAND);
33330 END;
33340 (**)
33350 (**)
33401 PROCEDURE WRITEOFFSET(L:LABL;OFFSET:INTEGER);
33402 BEGIN
33403 IF OFFSET<>0 THEN WRITEBYTE(CPACTLBL);
33404 WRITECON(CPACTGBL,SZWORD,L);
33407 IF OFFSET <>0 THEN WRITECON(CPACTCONS,SZWORD,OFFSET);
33408 END;
33409 (**)
33410 ()+24*)
33411 PROCEDURE SETTEXTSTATE;
33412 BEGIN
33413 IF DATASTATE=INDATA THEN WRITEINSTN(EOOPNDS);
33414 DATASTATE := ENDDATA
33415 END;
33416 (**)
33420 PROCEDURE EMITXWORD(TYP:OPDTYP;OPERAND:ADDRINT);
33430 VAR REC: RECORD CASE SEVERAL OF
33440 1: (INT:ADDRINT);
33450 2: (LEX:PLEX);
33455 3,4,5,6,7,8,9,10: ();
33460 END;
33470 I,K,STRLEN,HI:INTEGER;
33471 (*-24()J:CHAR;()-24*)
33480 BEGIN
33482 (* IN THE -24 MACHINE 'CON <DATA>' IS PRODUCED ON EACH LINE *)
33483 (* IN THE +24 MACHINE 'CON <DATA> <DATA> <DATA> ...' IS PRODUCED *)
33485 IF (DATASTATE=STARTDATA) (*-24() OR (DATASTATE=INDATA) ()-24*) THEN
33486 BEGIN
33487 WRITEINSTN(CON);DATASTATE:=INDATA;
33488 END;
33490 CASE TYP OF
33500 OCVIMMED: WRITECON(CPACTCONS, SZWORD, OPERAND);
33502 OCVIMMLONG: WRITECON(CPACTCONS, SZLONG, OPERAND);
33504 OCVIMMPTR: WRITECON(CPACTCONS, SZADDR, OPERAND);
33510 (*+24()OCVFREF: WRITELABEL(FALSE,OPERAND);
33520 OCVMEM,OCVFIM: WRITELABEL(TRUE,OPERAND); ()+24*)
33530 (*-24()OCVFREF: BEGIN
33532 WRITE(LGO,' *',OPERAND:0);
33533 END;
33540 OCVMEM,OCVFIM: BEGIN
33542 WRITE(LGO,' .',OPERAND:0);
33543 END; ()-24*)
33550 OCVEXT: BEGIN
33560 REC.INT := OPERAND;
33562 STRLEN:=REC.LEX^.LXCOUNT*SZWORD;
33563 HI := 1;
33564 WHILE (HI<=RTNLENGTH) AND (REC.LEX^.S10[HI]<>' ') DO HI := HI+1;
33566 HI := HI-1;
33570 (*+24() WRITEBYTE(CPACTPNAM);
33575 WRITECON(CPACTCONS,SZWORD,HI);
33591 FOR I := 1 TO HI DO
33600 WRITEBYTE(ORD(REC.LEX^.S10[I]));
33604 ()+24*)
33610 (*-24() WRITE(LGO,' $');
33611 FOR I:=1 TO HI DO
33612 BEGIN
33613 J:=REC.LEX^.S10[I];
33616 WRITE(LGO,J);
33617 END;
33619 IF HI<RTNLENGTH THEN
33620 FOR K:=I+1 TO RTNLENGTH DO
33624 WRITE(LGO,' ');
33626 ()-24*)
33628 END
33630 END;
33632 (*-24()IF DATASTATE=INDATA THEN WRITEINSTN(EOOPNDS); ()-24*)
33640 END;
33650 (**)
33652 PROCEDURE EMITXPROC (TYP:OPDTYP;OPERAND:ADDRINT);
33654 VAR
33656 TEMP :PLEX;
33658 DIGIT,INDEX :INTEGER;
33660 ADDRESS :LABL;
33662 BEGIN
33664 ENEW (TEMP, LEX1SIZE+ (9*CHARPERWORD) DIV CHARPERWORD * SZWORD);
33666 WITH TEMP^ DO
33668 BEGIN
33670 S10:=' ';
33672 S10[1]:='R';
33674 DIGIT:=OPERAND;
33676 INDEX:=1;
33678 WHILE DIGIT>0 DO BEGIN DIGIT:=DIGIT DIV 10; INDEX:=INDEX+1; END;
33680 DIGIT:=OPERAND;
33682 WHILE DIGIT>0 DO
33684 BEGIN
33686 S10[INDEX]:= CHR ((DIGIT MOD 10) + ORD('0')); (*ONLY WORKS FOR NUMBERS THEN RUN CONTIGUOUSLY*)
33688 DIGIT:=DIGIT DIV 10; INDEX := INDEX-1;
33690 END;
33691 LXCOUNT:= (9*CHARPERWORD) DIV CHARPERWORD * SZWORD;
33692 END;
33693 EMITXWORD(OCVEXT,ORD(TEMP));
33694 EDISPOSE(TEMP, LEX1SIZE+ (9*CHARPERWORD) DIV CHARPERWORD * SZWORD);
33695 END;
33696 PROCEDURE EMITALF(ALF: BIGALFA);
33697 VAR I,L: INTEGER;
33702 BEGIN
33703 (*+24() IF DATASTATE=STARTDATA THEN WRITEINSTN(CON);
33704 WRITEBYTE(CPACTSTRING);
33706 WRITECON(CPACTCONS,SZWORD,10); FOR I := 1 TO 10 DO WRITEBYTE(ORD(ALF.ALF[I]));
33707 WRITECON(CPACTCONS,1,ALF.IDSIZE); WRITECON(CPACTCONS,1,ALF.XMODE); ()+24*)
33708 (*-24() WRITEINSTN(CON);
33709 WRITE(LGO, ' '''); FOR I := 1 TO 8 DO WRITE(LGO, ALF.ALF[I]);
33710 WRITE(LGO,''',',ALF.IDSIZE:1,'U1,',ALF.XMODE:1,'U1'); WRITEINSTN(EOOPNDS); ()-24*)
33711 DATASTATE:=INDATA;
33712 END;
33713 (**)
33714 PROCEDURE EMITRNTAIL (LEN :INTEGER);
33715 BEGIN
33716 SETTEXTSTATE;
33717 WRITEINSTN(EEND);EMITXWORD(OCVIMMED,LEN);(*-24() WRITEINSTN(EOOPNDS); ()-24*)
33718 END;
33719 (**)
33720 FUNCTION STKSPACE (INSTR:COMPACT;PARAM:INTEGER) :INTEGER;
33722 (*FUNCTION CALCULATES HOW MANY WORDS WILL BE PUT ON THE STACK*)
33723 (*BY THE INSTRUCTION INSTR*)
33730 BEGIN
33731 (*+32() ASERT(INSTR<>LOS,'STKSPACE-A'); ()+32*)
33735 IF (INSTR=LFR)OR(INSTR=LOI)OR(INSTR=DUP) THEN STKSPACE:=PARAM
33737 ELSE IF (INSTR=LDC)OR(INSTR=LDL)OR(INSTR=LDE)OR(INSTR=LDF) THEN STKSPACE:=SZWORD+SZWORD
33738 ELSE IF (INSTR=ADP)OR(INSTR=LAL)OR(INSTR=LAE)OR(INSTR=LXL)OR(INSTR=LXA)OR(INSTR=LOR) THEN STKSPACE:=SZADDR
33739 ELSE STKSPACE:=SZWORD;
33740 END;
33743 (**)
33744 (**)
33745 PROCEDURE EMITOP (* (OPCOD:POP) *);
33747 CONST MAXLABL = 2; (* MAXIMUM NUMBER OF OVERLAPPING LABELS *)
33748 (*-24() NOP='NOP'; ()-24*)
33750 VAR I,TEMPCNT,STRWLEN:INTEGER; TEMPLABL:LABL; TEMP:PLEX;
33760 COUNT : ARRAY [1..MAXLABL] OF INTEGER;
33765 JUMPOVER : ARRAY [1..MAXLABL] OF LABL;
33770 PARAMNOTUSED: BOOLEAN;
33772 SAVOPRAND: ADDRINT;
33780 BEGIN
33790 SETTEXTSTATE;
33810 PARAMNOTUSED := TRUE;
33811 FOR I:=1 TO MAXLABL DO COUNT[I]:=0;
33812 IF OCV=OCVLCLGBL THEN
33813 BEGIN
33814 IF LCLGBL<>0 THEN
33815 BEGIN CLEAR(RTSTACK); (*IN CASE ANYTHING IN PRR*)
33816 SAVOPRAND := OPRAND;
33817 EMITX1(PENVCHAIN+ORD(OPRAND>0),OCVIMMED,LCLGBL);
33818 OPRAND := SAVOPRAND;
33819 END;
33820 OCV := OCVIMMED;
33821 PARAMNOTUSED := FALSE; (*SPECIAL FIDDLE FOR PLOADRTA AND PCALLA*)
33822 END;
33824 WHILE OPCOD <> 0 DO WITH CODETABLE[OPCOD] DO
33830 BEGIN
33835 (*+21()WRITELN(OUTPUT,'EMITTING P-OP',OPCOD,' ADJUSTSP=',ADJUSTSP);()+21*)
33840 IF INLINE THEN
33850 BEGIN
33860 IF EMCOD<>NOP THEN WRITEINSTN(EMCOD);
33870 CASE PARTYP OF
33880 ACP,ANP,WOP,WNP : (* OPERAND SUPPLIED BY,AND NEGATION DONE BY,CODETABLE*)
33890 WRITECON(CPACTCONS, SZWORD, PARM);
33892 WLB,ACB : (*OPERAND SUPPLIED BY CODETABLE, GLOBAL LABEL OFFSET*)
33894 WRITEOFFSET(HOLTOP,PARM);
33900 OPX,ACX : (* OPERAND IS SUPPLIED BY CODE GENERATOR *)
33910 BEGIN IF OCV<=OCVIMMPTR THEN WRITECON(CPACTCONS, SZWORD, OPRAND+PARM)
33912 ELSE EMITXWORD(OCV, OPRAND+PARM); PARAMNOTUSED := FALSE END;
33920 ONX,ANX : (* NEGATIVE OF OPERAND SUPPLIED BY CODE GENERATOR *)
33930 BEGIN IF OCV<=OCVIMMPTR THEN WRITECON(CPACTCONS, SZWORD, -(OPRAND+PARM))
33932 ELSE EMITXWORD(OCV, -(OPRAND+PARM)); PARAMNOTUSED := FALSE END;
33933 OPL,ACL : (*OPERAND (SUPPLIED BY CODE GEN) IS A GLOBAL LABEL OFFSET*)
33934 BEGIN WRITEOFFSET(HOLTOP,OPRAND+PARM); PARAMNOTUSED:=FALSE; END;
33937 ONL,ANL : (*AS ABOVE BUT NEGATE OPERAND FIRST*)
33939 BEGIN WRITEOFFSET(HOLTOP,-(OPRAND+PARM));PARAMNOTUSED:=FALSE; END;
33940 JMP : (* P-OP GENERATES ITS OWN LABELS FOR LOOPS ETC. *)
33950 BEGIN
33960 TEMPCNT := PARM;
33970 TEMPLABL := GETNEXTLABEL;
33980 EMITXWORD(OCVFREF,TEMPLABL);
33990 IF TEMPCNT < 0 THEN (* A BACKWARD JUMP IS REQUIRED,USE THE EXC COMMAND *)
34000 BEGIN
34005 WRITELABEL(FALSE,TEMPLABL);
34007 WRITEINSTN(EXC); WRITECON(CPACTCONS, SZWORD, -TEMPCNT);
34010 WRITECON(CPACTCONS, SZWORD, 1); (*-24() WRITEINSTN(EOOPNDS); ()-24*)
34015 END
34017 ELSE
34018 BEGIN (*FORWARD JUMP SO STORE IN ARRAYS*)
34020 I:=0;
34022 REPEAT I:=I+1; (*+32()ASERT(I<=MAXLABL,'EMITOP-A ');()+32*) UNTIL COUNT[I] = 0;
34024 COUNT[I]:=TEMPCNT; JUMPOVER[I]:=TEMPLABL;
34026 END;
34028 END;
34030 NON : ;
34040 GBX : (* GLOBAL LABEL EXPECTED *)
34050 BEGIN
34055 WRITEOFFSET(OPRAND, PARM);
34056 PARAMNOTUSED:=FALSE; END;
34060 LCX : (* INSTRUCTION LABEL EXPECTED *)
34070 (*+24() BEGIN WRITELABEL(FALSE,OPRAND); PARAMNOTUSED := FALSE END; ()+24*)
34072 (*-24() BEGIN WRITE(LGO,' *',OPRAND:0);
34073 PARAMNOTUSED:=FALSE; END; ()-24*)
34074 MOR : (* LONG (2-BYTE) OPERAND SUPPLIED BY CODETABLE *)
34076 EMITXWORD(OCVIMMED,PARM);
34080 END; (* OF CASE *)
34085 (*-24() TAKELINE; ()-24*)
34087 IF PARTYP>= ACP THEN
34090 BEGIN
34092 CASE PARTYP OF
34093 ANP,ACP: ADJUSTSP:=ADJUSTSP+STKSPACE(EMCOD,PARM(*-24()-120()-24*));
34094 ACX: ADJUSTSP:=ADJUSTSP+STKSPACE(EMCOD,OPRAND+PARM);
34095 ANX: ADJUSTSP:=ADJUSTSP+STKSPACE(EMCOD,-(OPRAND+PARM));
34096 ACB,ACL,ANL: ADJUSTSP:=ADJUSTSP+STKSPACE(EMCOD,0);
34097 END;
34099 END;
34100 OPCOD := NEXT;
34110 END
34120 ELSE
34130 BEGIN
34140 IF PARAMNOTUSED THEN PARAM(OCVNONE, 0, OPCOD);
34190 WRITEINSTN(LXL); WRITECON(CPACTCONS, SZWORD, 0); (*-24() TAKELINE; ()-24*) (*STATIC LINK*)
34200 WRITEINSTN(CAL);
34205 STRWLEN:=(RTNLENGTH+CHARPERWORD) DIV CHARPERWORD *SZWORD;
34210 ENEW(TEMP,LEX1SIZE+STRWLEN);
34220 WITH TEMP^ DO
34230 BEGIN
34240 FOR I:=1 TO RTNLENGTH DO S10[I]:=ROUTINE[I];
34250 LXCOUNT:=STRWLEN;
34260 END;
34262 EMITXWORD(OCVEXT,ORD(TEMP));
34264 EDISPOSE(TEMP,LEX1SIZE+STRWLEN);
34266 (*-24() TAKELINE ; ()-24*)
34270 OPCOD := 0;
34280 WRITEINSTN(ASP); WRITECON(CPACTCONS, SZWORD, ADJUSTSP+SZADDR);
34300 (*-24() TAKELINE ; ()-24*)
34310 END;
34312 FOR I:=1 TO MAXLABL DO
34320 IF COUNT[I] > 0 THEN (* ONE OF P-OPS REQUIRES A LABEL *)
34322 BEGIN
34330 IF COUNT[I] = 1 THEN WRITELABEL(FALSE,JUMPOVER[I]) ;
34340 COUNT[I] := COUNT[I]-1;
34342 END;
34350 END;
34360 END;
34370 (**)
34380 PROCEDURE FIXUPF (* (ALABL:LABL) *);
34390 BEGIN
34392 IF DATASTATE <> ENDDATA THEN BEGIN
34394 (*+24() IF DATASTATE=INDATA THEN BEGIN DATASTATE:=STARTDATA; WRITEINSTN(EOOPNDS) END; ()+24*)
34396 WRITELABEL(TRUE,ALABL); END
34398 ELSE
34400 WRITELABEL(FALSE,ALABL);
34410 END;
34420 (**)
34430 FUNCTION FIXUPM (* :LABL *);
34440 VAR L:LABL;
34450 BEGIN
34455 L := GETNEXTLABEL;
34456 FIXUPM := L;
34460 IF DATASTATE <> ENDDATA THEN (*GLOBAL DATA*)
34470 BEGIN
34480 (*+24() IF DATASTATE=INDATA THEN BEGIN DATASTATE:=STARTDATA; WRITEINSTN(EOOPNDS) END; ()+24*)
34500 WRITELABEL(TRUE,L);
34510 END
34520 ELSE
34530 BEGIN
34560 WRITELABEL(FALSE,L);
34570 END;
34580 END;
34590 (**)
34600 PROCEDURE FIXUPFIM(ALABL:LABL;VALUE:A68INT);
34610 BEGIN
34620 WRITELABEL(TRUE,ALABL); WRITEINSTN(CON);
34630 WRITECON(245, SZWORD, VALUE);
34640 WRITEINSTN(EOOPNDS);
34650 END;
34660 (**)
34670 PROCEDURE FIXLABL(OLDLABL,NEWLABL:LABL; KNOWN:BOOLEAN);
34680 VAR JUMPOVER: LABL;
34690 BEGIN
34700 JUMPOVER := GETNEXTLABEL;
34710 WRITEINSTN(BRA); (*+24() WRITELABEL(FALSE,JUMPOVER); ()+24*)
34712 (*-24()WRITE(LGO,' *',JUMPOVER:0); TAKELINE; ()-24*)
34720 WRITELABEL(FALSE,OLDLABL);
34730 WRITEINSTN(BRA); (*+24() WRITELABEL(FALSE,NEWLABL); ()+24*)
34732 (*-24()WRITE(LGO,' *',NEWLABL:0); TAKELINE; ()-24*)
34740 WRITELABEL(FALSE,JUMPOVER);
34750 (*-24() TAKELINE; ()-24*)
34760 END;
34770 (**)
34780 FUNCTION NORMAL(SB: PSB): SBTTYP;
34790 (*RETURNS THE SBTTYP IN WHICH VALUES OF MODE SB^.SBMODE SHOULD BE STORED DURING BALANCES*)
34800 BEGIN WITH SB^ DO WITH SBMODE^.MDV DO
34810 IF SBTYP=SBTDL THEN NORMAL := SBTDL
34820 ELSE IF SBUNION IN SBINF THEN NORMAL := SBTSTKN
34825 ELSE IF SBNAKED IN SBINF THEN NORMAL := SBTSTK4
34830 ELSE IF MDPILE THEN NORMAL := SBTSTK(*+19()2()+19*)
34840 ELSE CASE MDLEN OF
34850 0: NORMAL := SBTVOID;
34860 SZWORD: NORMAL := SBTSTK;
34870 (*+19() SZADDR: NORMAL := SBTSTK2; ()+19*)
34880 SZREAL: NORMAL := SBTSTK4;
34890 END;
34900 END;
34910 (**)
34920 FUNCTION LENOF(SB: PSB): INTEGER;
34930 BEGIN
34940 WITH SB^,SBMODE^.MDV DO
34950 IF (SBUNION IN SBINF) OR (SBTYP=SBTDL) THEN LENOF := SBLEN
34952 ELSE IF SBNAKED IN SBINF THEN LENOF := SZNAKED
34954 ELSE IF MDPILE THEN LENOF := SZADDR
34956 ELSE LENOF := MDLEN;
34960 END;
34970 (**)
34980 PROCEDURE LOADSTK(SB: PSB);
34990 BEGIN
34995 IF NOT(SB^.SBTYP IN [SBTSTKN,SBTDL]) THEN
35000 CASE LENOF(SB) OF
35010 0: LOAD(SBTVOID, SB);
35020 SZINT: LOAD(SBTSTK, SB);
35030 (*+19() SZADDR: LOAD(SBTSTK2, SB);
35032 6: LOAD(SBTSTK2A, SB); ()+19*)
35040 SZREAL: LOAD(SBTSTK4, SB);
35050 END;
35060 END;
35070 (**)
35080 PROCEDURE TWIST;
35090 VAR TEMPPTR : PSB;
35095 L1, L2, SAVE: INTEGER;
35100 BEGIN
35110 WITH RTSTACK^ DO BEGIN
35120 IF (SBRTSTK^.SBTYP IN [SBTSTK..SBTDL]) AND (SBTYP IN [SBTSTK..SBTPRR]) THEN
35121 BEGIN
35122 IF SBTYP=SBTPRR THEN LOADSTK(RTSTACK);
35123 SAVE := ADJUSTSP;
35124 L1:=LENOF(RTSTACK);L2:=LENOF(SBRTSTK);
35126 IF L1=L2 THEN
35128 CASE L1 OF
35130 SZWORD: EMITOP(PSWAP);
35132 (*+19() SZADDR: EMITOP(PSWAP+1); ()+19*)
35134 SZREAL: EMITOP(PSWAP+2);
35136 END
35138 ELSE (*STACK OBJECTS TO BE SWAPPED ARE NOT THE SAME SIZE*)
35140 EMITX2(PSWAP+3,OCVIMMED,L1,OCVIMMED,L2);
35141 ADJUSTSP := SAVE;
35142 END;
35144 TEMPPTR := SBRTSTK;
35150 SBRTSTK := TEMPPTR^.SBRTSTK;
35160 TEMPPTR^.SBRTSTK := RTSTACK;
35170 RTSTACK := TEMPPTR;
35180 END
35190 END;
35200 (**)
35210 PROCEDURE PROC1OP(OPCOD:POP;TYP:OPDTYP;OPND:ADDRINT;NOTINL:BOOLEAN);
35220 VAR SB:PSB;
35230 BEGIN
35240 SB:=ASPTR(OPND);
35250 IF RTSTACK<>SB THEN TWIST;
35255 IF NOTINL THEN CLEAR (RTSTACK^.SBRTSTK);
35260 LOAD(CODETABLE[OPCOD].P1,SB);
35270 UNSTKP1(TYP,SB);
35280 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
35290 END;
35300 (**)
35310 PROCEDURE PROC2OP(OPCOD:POP;TYP1:OPDTYP;OPND1:ADDRINT;TYP2:OPDTYP;OPND2:ADDRINT;NOTINL:BOOLEAN);
35320 VAR SB1,SB2:PSB;
35330 BEGIN
35340 SB1:=ASPTR(OPND1);
35350 SB2:=ASPTR(OPND2);
35360 IF RTSTACK<>SB2 THEN TWIST;
35365 IF NOTINL THEN CLEAR (RTSTACK^.SBRTSTK^.SBRTSTK);
35370 WITH CODETABLE[OPCOD] DO
35380 BEGIN
35390 IF NOT (SB2^.SBTYP IN [SBTSTK..SBTSTKN,SBTVAR]) THEN
35400 BEGIN LOAD(P1,SB1); LOAD(P2,SB2) END
35410 ELSE BEGIN LOAD(P2,SB2); LOAD(P1,SB1); LOAD(P2,SB2) END;
35420 END;
35430 UNSTKP1(TYP2,SB2);
35440 UNSTKP1(TYP1,SB1);
35450 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
35460 END;
35470 (**)
35480 PROCEDURE FILL (WHERE:SBTTYP; SB:PSB);
35490 BEGIN
35500 WITH SB^ DO
35510 BEGIN
35515 IF SBTYP IN [SBTSTK..SBTDL] THEN RTSTKDEPTH:=RTSTKDEPTH-SBLEN;
35520 IF NOT(WHERE IN [SBTSTKN,SBTDL,SBTPRR,SBTXN]) THEN SBLEN := LENARRAY[WHERE];
35522 (*ELSE IF WHERE=SBTPRR THEN IT GET IT WRONG - SEE FIX IN SUBSTLEN*)
35530 IF WHERE IN [SBTSTK..SBTDL] THEN
35540 BEGIN
35550 RTSTKDEPTH := RTSTKDEPTH+SBLEN;
35560 WITH ROUTNL^ DO
35570 IF RTSTKDEPTH>RNLENSTK THEN RNLENSTK:=RTSTKDEPTH
35580 END;
35590 SBTYP:=WHERE;
35600 END
35610 END;
35620 (**)
35630 FUNCTION SETINLINE (OPCOD:POP):BOOLEAN;
35640 VAR INL:BOOLEAN;
35650 BEGIN
35660 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
35670 REPEAT WITH CODETABLE[OPCOD] DO
35680 BEGIN
35690 INL := INLINE;
35700 OPCOD := NEXT
35710 END
35720 UNTIL NOT(INL) OR (OPCOD=0);
35730 SETINLINE := INL
35740 END;
35750 (**)
35760 (**)
35770 PROCEDURE LOAD (* (WHERE:SBTTYP; SB:PSB) *);
35780 (*EMITS CODE TO MOVE SB TO WHERE: CALLS FILL TO RECORD THE MOVE*)
35790 VAR TEMPOP: POP;
35800 TOFFSET: OFFSETR;
35810 TEMPTYP: SBTTYP;
35812 OCVFIX: OPDTYP;
35820 TWISTED: BOOLEAN;
35830 SB1 :PSB;
35840 SAVE:INTEGER;
35850 BEGIN
35855 (*+21() WRITELN(OUTPUT,'LOAD ',ORD(SB),ORD(SB^.SBTYP):3,' TO ',ORD(WHERE):3, SB=RTSTACK); ()+21*)
35860 WITH SB^ DO
35870 BEGIN
35880 (*IF (SB=RTSTACK) AND (SBRTSTK<>NIL) THEN
35890 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN
35900 BEGIN LOADSTK(SBRTSTK); SBRTSTK^.SBINF:=SBRTSTK^.SBINF-[SBSTKDELAY] END; *)
35902 IF WHERE IN [SBTSTK..SBTDL] THEN CLEAR(SBRTSTK);
35910 TWISTED := FALSE;
35930 IF WHERE IN [SBTSTKN,SBTPR1,SBTPR2] THEN
35940 LOADSTK(SB)
35950 ELSE IF WHERE=SBTXN THEN LOAD(NORMAL(SB),SB)
35960 ELSE
35970 IF (WHERE<>SBTVOID) AND (WHERE<>SBTYP) THEN
35980 BEGIN
35990 SB1 := RTSTACK;
36000 WHILE (SB1^.SBTYP IN [SBTID..SBTRPROC]) AND (SB1<>SB) DO
36010 SB1 := SB1^.SBRTSTK;
36020 IF SB1<>SB THEN
36030 BEGIN TWISTED:=TRUE; TWIST;
36032 IF WHERE IN [SBTSTK..SBTDL] THEN CLEAR(SBRTSTK);
36040 (*+32() ASERT (RTSTACK =SB,'LOAD-B '); ()+32*)
36050 END;
36080 IF WHERE IN [SBTPR1..SBTPRR] THEN TEMPOP := POPARRAY[NORMAL(SB),SBTYP]
36090 ELSE TEMPOP := POPARRAY[WHERE,SBTYP];
36100 (*+32() ASERT(TEMPOP<>PNONE,'LOAD-C '); ()+32*)
36110 IF TEMPOP<>PNOOP THEN
36120 CASE SBTYP OF
36130 SBTPROC,SBTRPROC,SBTVAR: BEGIN
36140 SAVE := ADJUSTSP;
36150 IF WHERE <> SBTPRR THEN BEGIN LOAD(SBTPRR,SB); LOAD(WHERE,SB) END
36160 ELSE BEGIN TOFFSET:=GENLCLGBL(TEMPOP,SB);
36162 IF SBTYP=SBTVAR THEN
36170 EMITX2(TEMPOP,OCVIMMED,SBLOCRG,OCVLCLGBL,TOFFSET)
36172 ELSE BEGIN (*SBTYP=SBTPROC OR SBTRPROC*)
36174 IF SBTYP=SBTPROC THEN OCVFIX := OCVMEM
36176 ELSE (* SBTRPROC *) OCVFIX := OCVFREF;
36177 EMITX2(TEMPOP,OCVFIX,SBXPTR,OCVLCLGBL,-SZADDR(*ANYTHING -VE*));
36178 END;
36179 END;
36180 ADJUSTSP := SAVE;
36190 END;
36200 (**)
36210 SBTID,SBTIDV: BEGIN TOFFSET:=GENLCLGBL(TEMPOP,SB);EMITX1(TEMPOP,OCVLCLGBL,TOFFSET) END;
36220 SBTLIT: EMITX1(TEMPOP, OCVIMMED, SBVALUE);
36230 SBTDEN: GENDENOT(TEMPOP,SB);
36240 SBTPR1,SBTPR2,SBTPRR,
36250 SBTSTK,SBTSTK2,SBTDL,SBTSTK4: EMITOP(TEMPOP);
36260 END;
36270 FILL(WHERE,SB);
36280 END;
36290 IF TWISTED THEN TWIST;
36300 END;
36310 END;
36320 (**)
36330 PROCEDURE PARAM (*(TYP:OPDTYP; OPND:ADDRINT; OPCOD: POP)*);
36340 VAR TEMPOP:POP;
36350 OPERANDUSED, INL: BOOLEAN;
36360 BEGIN
36370 IF OCV<>OCVNONE THEN
36380 BEGIN
36390 TEMPOP := PPUSHIM;
36392 (*+19()IF OCV = OCVIMMLONG THEN TEMPOP:=TEMPOP+2 ELSE
36395 IF OCV = OCVIMMPTR THEN TEMPOP:=TEMPOP+2 ELSE ()+19*)
36400 IF OCV IN [OCVMEM,OCVFIM,OCVFREF] THEN TEMPOP:=TEMPOP+1; (*NOT FOR OCVFIM*)
36410 EMITOP(TEMPOP);ADJUSTSP:=ADJUSTSP+STKSPACE(CODETABLE[TEMPOP].EMCOD,0)
36420 END;
36450 IF TYP<>OCVNONE THEN
36460 BEGIN OPRAND:=OPND; OCV := TYP END;
36470 END;
36480 (**)
36490 ()+02*)
36500 (**)
36510 (*+01() (*+31() (*$T+ +) ()+31+) ()+01*)
36530 (**)
36540 (**)
36550 (* CYBER CODE EMITTER *)
36560 (**********************)
36570 (*-23()
36580 (*+01()
36590 PROCEDURE PUTLINK(OPCOD: POP);
36600 (*EMITS LINK TABLE FOR LINKINS CHAIN OF OPCOD*)
36610 VAR TABLEWORD: PACKED RECORD CASE INTEGER OF
36620 1: (INT: INTEGER);
36630 2: (ENTRY: PACKED ARRAY [1..7] OF CHAR; FILLER: 0..777777B);
36640 END;
36650 APFILLCHAIN, BPFILLCHAIN: PFILLCHAIN;
36660 SEQWORD, C: INTEGER;
36670 BEGIN WITH TABLEWORD, CODETABLE[OPCOD] DO
36680 BEGIN
36690 WRITE(LGO, 44000002000000000000B+(LINKINS^.COUNT DIV 2)*1000000000000B); (*LINK TABLE*)
36700 INT := 0;
36710 FOR C := 1 TO 7 DO
36720 IF ROUTINE[C]<>' ' THEN ENTRY[C] := ROUTINE[C];
36730 WRITE(LGO, INT);
36740 SEQWORD := 0;
36750 APFILLCHAIN := LINKINS;
36760 C := 1;
36770 REPEAT
36780 WITH APFILLCHAIN^ DO
36790 BEGIN
36800 SEQWORD := SEQWORD*10000000000B+(7-FFOUR)*1000000000B+1000000B+FSEGLOC;
36810 C := C+1;
36820 IF ODD(C) THEN BEGIN WRITE(LGO, SEQWORD); SEQWORD := 0 END;
36830 BPFILLCHAIN := APFILLCHAIN; APFILLCHAIN := LINK; DISPOSE(BPFILLCHAIN)
36840 END
36850 UNTIL APFILLCHAIN=NIL;
36860 IF NOT ODD(C) THEN
36870 BEGIN SEQWORD := SEQWORD*10000000000B; WRITE(LGO, SEQWORD) END;
36880 LINKINS := NIL
36890 END
36900 END;
36910 (**)
36920 PROCEDURE PLANTWORD;
36930 (*CALLED WHENEVER A COMPLETE WORD OF 15 OR 30 BIT INSTRUCTIONS IS COMPLETE*)
36940 VAR I: INTEGER;
36950 BEGIN
36960 WITH XSEG DO
36970 BEGIN
36980 FOUR := 1;
36990 IF FIFTEEN<15 THEN
37000 FIFTEEN := FIFTEEN+1
37010 ELSE
37020 BEGIN
37030 SEGLOC := SEGLOC+15;
37040 WITH BUFFER[LAST] DO CODEWORD := CODEWORD+RELOCATION; RELOCATION := 0;
37050 LAST := (LAST+16) MOD 128;
37060 FIFTEEN := 1;
37070 IF LAST=FIRST THEN WITH HEADERWORD DO
37080 BEGIN
37090 WRITE(LGO, WORD);
37100 FOR I := FIRST TO FIRST+15 DO
37110 WRITE(LGO, BUFFER[I].CODEWORD);
37120 FIRST := (FIRST+16) MOD 128;
37130 S := S+15
37140 END;
37150 BUFFER[LAST].CODEWORD := 0 (*NEXT RELOCATION*)
37160 END;
37170 BUFFER[LAST+FIFTEEN].CODEWORD := 0
37180 END
37190 END;
37200 (**)
37210 (**)
37220 PROCEDURE UPPER;
37230 (*FORCES NEXT INSTRUCTION TO BE AT START OF A WORD*)
37240 CONST SHIFT1=100000B; SHIFT2=10000000000B; SHIFT3=1000000000000000B;
37250 NOOP1=46000B; NOOP2=4600046000B; NOOP3=460004600046000B;
37260 BEGIN WITH XSEG DO WITH BUFFER[LAST+FIFTEEN] DO
37270 CASE FOUR OF
37280 1: (*NO ACTION*);
37290 2: BEGIN
37300 CODEWORD := CODEWORD*SHIFT3+NOOP3;
37310 RELOCATION := RELOCATION*8;
37320 PLANTWORD
37330 END;
37340 3: BEGIN
37350 CODEWORD := CODEWORD*SHIFT2+NOOP2;
37360 RELOCATION := RELOCATION*4;
37370 PLANTWORD
37380 END;
37390 4: BEGIN
37400 CODEWORD := CODEWORD*SHIFT1+NOOP1;
37410 RELOCATION := RELOCATION*2;
37420 PLANTWORD
37430 END
37440 END
37450 END;
37460 (**)
37470 (**)
37480 PROCEDURE DOFREF(OPERAND: INTEGER);
37490 VAR APFCHAIN: PFCHAIN;
37500 BEGIN NEW(APFCHAIN); WITH XSEG, APFCHAIN^ DO
37510 BEGIN
37520 FLAST := LAST; FFIFTEEN := FIFTEEN; FFOUR := FOUR;
37530 FSEGLOC := SEGLOC; FLABL := OPERAND;
37540 LINK := TPFCHAIN^.LINK; TPFCHAIN^.LINK := APFCHAIN
37550 END
37560 END;
37570 (**)
37580 (**)
37590 PROCEDURE EMITXWORD(TYP: OPDTYP; OPERAND: INTEGER);
37600 BEGIN
37610 UPPER;
37620 WITH XSEG DO WITH BUFFER[LAST+FIFTEEN] DO
37630 CASE TYP OF
37640 OCVIMMED:
37650 BEGIN CODEWORD := OPERAND; RELOCATION := RELOCATION*16 END;
37660 OCVMEM:
37670 BEGIN CODEWORD := OPERAND; RELOCATION := RELOCATION*16+2 END;
37680 OCVFIM,OCVFREF:
37690 BEGIN CODEWORD := 0; RELOCATION := RELOCATION*16; FOUR := 3; DOFREF(OPERAND) END;
37700 END;
37710 PLANTWORD
37720 END;
37730 (**)
37740 (**)
37750 PROCEDURE EMITALF(OPERAND: BIGALFA);
37760 VAR ALFWD: RECORD CASE SEVERAL OF
37770 1: (INT: INTEGER);
37780 2: (ALF: BIGALFA);
37790 END;
37800 BEGIN
37810 ALFWD.ALF := OPERAND;
37820 EMITXWORD(OCVIMMED, ALFWD.INT);
37830 END;
37840 (**)
37850 (**)
37860 (**)
37870 (**)
37880 PROCEDURE FILL (WHERE:SBTTYP; SB:PSB);
37890 BEGIN
37900 WITH SB^ DO
37910 BEGIN
37920 IF NOT(WHERE IN [SBTSTKN,SBTDL,SBTXN]) THEN SBLEN := LENARRAY[WHERE];
37930 IF WHERE IN [SBTSTK..SBTDL] THEN
37940 BEGIN
37950 RTSTKDEPTH := RTSTKDEPTH+SBLEN;
37960 WITH ROUTNL^ DO
37970 IF RTSTKDEPTH>RNLENSTK THEN RNLENSTK:=RTSTKDEPTH
37980 END
37990 (*+32()ELSE ASERT(REGISTERS[WHERE]*(REGSINUSE-REGISTERS[SBTYP])=[],'FILL-A ') ()+32*);
38000 IF SBTYP IN [SBTSTK..SBTDL] THEN RTSTKDEPTH:=RTSTKDEPTH-SBLEN+ORD(WHERE=SBTDL);
38010 REGSINUSE:=REGSINUSE-REGISTERS[SBTYP]+REGISTERS[WHERE];
38020 SBTYP:=WHERE
38030 END
38040 END;
38050 (**)
38060 FUNCTION SETINLINE (OPCOD:POP):BOOLEAN;
38070 VAR INL:BOOLEAN;
38080 BEGIN
38090 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
38100 REPEAT WITH CODETABLE[OPCOD] DO
38110 BEGIN
38120 INL := INLINE;
38130 OPCOD := NEXT
38140 END
38150 UNTIL NOT(INL) OR (OPCOD=0);
38160 SETINLINE := INL
38170 END;
38180 (**)
38190 FUNCTION NORMAL(SB: PSB): SBTTYP;
38200 (*RETURNS THE SBTTYP IN WHICH VALUES OF MODE SB^.SBMODE SHOULD BE STORED DURING BALANCES*)
38210 BEGIN WITH SB^ DO WITH SBMODE^.MDV DO
38220 IF SBTYP=SBTDL THEN NORMAL := SBTDL
38230 ELSE IF SBUNION IN SBINF THEN NORMAL := SBTSTKN
38240 ELSE IF MDPILE THEN NORMAL := SBTX1
38250 ELSE CASE MDLEN OF
38260 0: NORMAL := SBTVOID;
38270 1: NORMAL := SBTX1;
38280 (*+61() 2: NORMAL := SBTX12; ()+61*)
38290 END;
38300 END;
38310 (**)
38320 (**)
38330 (**)
38340 PROCEDURE LOADSTK(SB: PSB);
38350 VAR LEN: 0..MAXSIZE;
38360 BEGIN
38370 WITH SB^ DO WITH SBMODE^.MDV DO
38380 BEGIN
38390 IF SBUNION IN SBINF THEN LEN := SBLEN ELSE IF MDPILE THEN LEN:=SZADDR ELSE LEN := MDLEN;
38400 IF SBTYP<>SBTDL THEN
38410 CASE LEN OF
38420 0: LOAD(SBTVOID, SB);
38430 1: LOAD(SBTSTK, SB);
38440 2: (*+61() LOAD(SBTSTK2, SB);
38450 3: ()+61*) (*LEAVE IT WHERE IT IS*);
38460 END;
38470 END;
38480 END;
38490 ()+01*)
38500 ()-23*)
38510 (**)
38520 PROCEDURE CLEAR (* (SB:PSB) *);
38530 (*ENSURES THAT NOTHING ON RTSTACK FROM SB DOWNWARDS IS IN A REGISTER*)
38540 VAR TEMPPTR:PSB; BOOL:BOOLEAN;
38550 BEGIN
38560 TEMPPTR:=SB;
38570 BOOL := TRUE;
38580 IF TEMPPTR<>NIL THEN IF TEMPPTR^.SBTYP<SBTSTK THEN
38590 REPEAT
38600 BEGIN
38610 TEMPPTR:=TEMPPTR^.SBRTSTK;
38620 IF TEMPPTR<>NIL THEN IF TEMPPTR^.SBTYP>SBTSTKN THEN BOOL:=FALSE;
38630 END
38640 UNTIL NOT(BOOL) OR (TEMPPTR=NIL);
38650 IF TEMPPTR<>NIL THEN IF TEMPPTR^.SBTYP>SBTSTKN THEN LOADSTK(TEMPPTR);
38660 END;
38670 (**)
38680 (*-23()
38690 (*+01()
38700 (**)
38710 PROCEDURE TWIST;
38720 VAR TEMPPTR : PSB;
38730 BEGIN
38740 WITH RTSTACK^ DO BEGIN
38750 IF (SBRTSTK^.SBTYP IN [SBTSTK..SBTSTKN])AND(SBTYP>=SBTSTK) THEN (*PHYSICAL UNTWISTING NEEDED*)
38760 BEGIN
38770 (*+32() ASERT(SBTYP>SBTDL, 'TWIST-A '); ()+32*)
38780 LOAD(NORMAL(SBRTSTK),SBRTSTK);
38790 END;
38800 TEMPPTR := SBRTSTK;
38810 SBRTSTK := TEMPPTR^.SBRTSTK;
38820 TEMPPTR^.SBRTSTK := RTSTACK;
38830 RTSTACK := TEMPPTR;
38840 END
38850 END;
38860 (**)
38870 PROCEDURE LOAD (* (WHERE:SBTTYP; SB:PSB) *);
38880 (*EMITS CODE TO MOVE SB TO WHERE: CALLS FILL TO RECORD THE MOVE*)
38890 VAR TEMPOP: POP;
38900 TOFFSET: OFFSETR;
38910 TEMPTYP: SBTTYP;
38920 OCVFIX: OPDTYP;
38930 BEGIN
38940 WITH SB^ DO
38950 BEGIN
38960 (*+21() WRITELN('LOAD',ORD(SB):6 OCT,ORD(SB^.SBTYP):3,ORD(WHERE):3);()+21*)
38970 IF SBRTSTK<>NIL THEN
38980 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN
38990 BEGIN LOADSTK(SBRTSTK); SBRTSTK^.SBINF:=SBRTSTK^.SBINF-[SBSTKDELAY] END;
39000 IF WHERE IN [SBTSTK..SBTDL] THEN CLEAR(SBRTSTK)
39010 ELSE
39020 BEGIN (*WHERE IS SOME REGISTER*)
39030 (*+32()ASERT((SB=RTSTACK)OR(SB=RTSTACK^.SBRTSTK)OR(SBTYP IN [SBTVAR,SBTPROC,SBTRPROC]),'LOAD-A '); ()+32*)
39040 IF SB=RTSTACK^.SBRTSTK THEN (*SB IS SECOND ON RTSTACK*) WITH RTSTACK^ DO
39050 BEGIN
39060 IF REGISTERS[WHERE]*REGISTERS[SBTYP]<>[] THEN
39070 IF WHERE IN [SBTX1,SBTX5(*+61(),SBTX12,SBTX45()+61*)] THEN
39080 IF (SB^.SBTYP IN [SBTX1,SBTX5]) AND (SBTYP IN [SBTX1,SBTX5]) THEN
39090 BEGIN EMITOP(PSWAP); TEMPTYP := SBTYP; SBTYP := SB^.SBTYP; SB^.SBTYP := TEMPTYP END
39100 ELSE IF SBTYP=SBTX1 THEN LOAD(SBTX5,RTSTACK)
39110 (*+61() ELSE IF SBTYP=SBTX12 THEN LOAD(SBTX45,RTSTACK)
39120 ELSE IF SBTYP=SBTX45 THEN LOAD(SBTX12,RTSTACK)
39130 ()+61*)
39140 ELSE LOAD(SBTX1,RTSTACK)
39150 ELSE IF REGISTERS[WHERE]*(REGSINUSE-REGISTERS[SB^.SBTYP])<>[] THEN CLEAR(SBRTSTK)
39160 END
39170 ELSE (*SB IS FIRST ON RTSTACK*)
39180 IF REGISTERS[WHERE]*(REGSINUSE-REGISTERS[SBTYP])<>[] THEN
39190 IF REGISTERS[SBRTSTK^.SBTYP]*REGISTERS[WHERE]<>[] THEN CLEAR(SBRTSTK)
39200 ELSE CLEAR(SBRTSTK^.SBRTSTK)
39210 END;
39220 IF WHERE = SBTXN THEN
39230 LOAD(NORMAL(SB), SB)
39240 ELSE IF WHERE = SBTSTKN THEN
39250 LOADSTK(SB)
39260 ELSE
39270 BEGIN
39280 IF WHERE<>SBTVOID THEN
39290 BEGIN
39300 TEMPOP := POPARRAY[WHERE,SBTYP];
39310 (*+32()ASERT(TEMPOP<>PNONE,'LOAD-C '); ()+32*)
39320 IF TEMPOP<>PNOOP THEN
39330 BEGIN
39340 CASE SBTYP OF
39350 SBTRPROC,SBTPROC,SBTVAR: IF WHERE<>SBTX6 THEN
39360 BEGIN LOAD(SBTX6, SB); LOAD(WHERE, SB) END
39370 ELSE BEGIN TOFFSET:=GENLCLGBL(TEMPOP,SB);
39380 IF SBTYP=SBTVAR THEN
39390 EMITX2(TEMPOP,OCVIMMED,SBLOCRG,OCVLCLGBL,TOFFSET)
39400 ELSE BEGIN (*SBTYP=SBTPROC OR SBTRPROC*)
39410 IF SBTYP=SBTPROC THEN OCVFIX := OCVMEM
39420 ELSE (* SBTRPROC *) OCVFIX := OCVFREF;
39430 EMITX2(TEMPOP,OCVFIX,SBXPTR,OCVLCLGBL,TOFFSET);
39440 END
39450 END;
39460 (**)
39470 SBTID,SBTIDV: BEGIN TOFFSET:=GENLCLGBL(TEMPOP,SB);EMITX1(TEMPOP,OCVLCLGBL,TOFFSET) END;
39480 SBTLIT: EMITX1(TEMPOP, OCVIMMED, SBVALUE);
39490 SBTDEN: GENDENOT(TEMPOP,SB);
39500 SBTSTK,SBTDL,(*+61()SBTSTK2,SBTX12,SBTX45,()+61*)SBTX5,SBTX6,SBTX0,SBTX1: EMITOP(TEMPOP)
39510 END;
39520 END
39530 END;
39540 FILL(WHERE,SB);
39550 END;
39560 END
39570 END;
39580 (**)
39590 (**)
39600 ()+01*)
39610 ()-23*)
39620 PROCEDURE UNSTKP1 (*+05() (TYP:OPDTYP; OPND:PSB) ()+05*);
39630 BEGIN
39640 IF TYP = OCVSBS THEN
39650 (*ASSERT: OPND = RTSTACK*)
39660 REPEAT
39670 OPND := RTSTACK;
39680 UNSTACKSB;
39690 IF OPND^.SBTYP IN [SBTSTK..SBTDL] THEN ADJUSTSP := ADJUSTSP+OPND^.SBLEN;
39700 OPND^.SBTYP := SBTVOID;
39710 UNTIL OPND^.SBRTSTK =SRSTK[SRSUBP+1].SB^.SBRTSTK
39720 ELSE IF TYP <> OCVSBP THEN
39730 BEGIN UNSTACKSB;
39740 IF OPND^.SBTYP IN [SBTSTK..SBTDL] THEN ADJUSTSP := ADJUSTSP+OPND^.SBLEN;
39750 OPND^.SBTYP:=SBTVOID;
39760 END
39770 (*+02() ELSE (*TYP=OCVSBP*) ADJUSTSP := ADJUSTSP-LENOF(OPND); ()+02*)
39780 END;
39790 (**)
39800 (*-23()
39810 (*+01()
39820 (**)
39830 PROCEDURE PROC1OP (OPCOD:POP; TYP:OPDTYP; OPND:INTEGER; NOTINL:BOOLEAN);
39840 VAR SB:PSB;
39850 BEGIN
39860 SB := ASPTR(OPND);
39870 WITH CODETABLE[OPCOD] DO
39880 BEGIN
39890 (*+32()ASERT((P1<>SBTVOID)AND(P2=SBTVOID),'PROC1OP-A '); ()+32*)
39900 IF RTSTACK<>SB THEN TWIST;
39910 (*+32()ASERT(RTSTACK=SB,'PROC1OP-B '); ()+32*)
39920 LOAD(P1,SB);
39930 IF NOTINL THEN CLEAR(RTSTACK^.SBRTSTK);
39940 NEXTREG := ORD(P1 IN [SBTX0,SBTX1]);
39950 UNSTKP1(TYP,SB);
39960 END;
39970 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
39980 END;
39990 (**)
40000 PROCEDURE PROC2OP (OPCOD:POP; TYP1:OPDTYP;OPND1:INTEGER; TYP2:OPDTYP;OPND2:INTEGER; NOTINL:BOOLEAN);
40010 VAR SB1,SB2:PSB;
40012 TEMP:PSB;
40020 BEGIN
40030 SB1 := ASPTR(OPND1);
40040 SB2 := ASPTR(OPND2);
40050 WITH CODETABLE[OPCOD] DO
40060 BEGIN
40070 (*+32()ASERT((P1 <>SBTVOID)AND(P2<>SBTVOID),'PROC2OP-A '); ()+32*)
40080 IF RTSTACK<>SB2 THEN TWIST;
40090 (*+32()ASERT(RTSTACK=SB2,'PROC2OP-B '); ()+32*)
40100 IF NOT (SB2^.SBTYP IN [SBTSTK..SBTSTKN,SBTVAR,SBTPROC]) THEN
40110 BEGIN LOAD(P1,SB1); LOAD(P2,SB2) END
40120 ELSE BEGIN LOAD(P2,SB2); LOAD(P1,SB1); LOAD(P2,SB2) (*IN CASE SB1^.SBTYP WAS SBTVAR*) END;
40130 IF NOTINL THEN CLEAR(RTSTACK^.SBRTSTK^.SBRTSTK);
40140 NEXTREG:= ORD(P1 IN [SBTX0,SBTX1])+ ORD(P2 IN [SBTX0,SBTX1]);
40150 (*+32()ASERT((TYP1=OCVSBP)OR NOT(TYP2 IN[OCVSBP,OCVSBS]),'PROC2OP-C '); ()+32*)
40160 UNSTKP1(TYP2,SB2);
40170 UNSTKP1(TYP1,SB1)
40180 END;
40190 OCV := OCVNONE; (*FOR 1ST CALL OF PARAM*)
40200 END;
40210 (**)
40220 PROCEDURE PARAM (TYP:OPDTYP; OPND:INTEGER; OPCOD: POP);
40230 VAR TEMPOP:POP;
40240 TEMPREG: INTEGER;
40250 BEGIN
40260 IF OCV<>OCVNONE THEN
40270 BEGIN
40280 CASE NEXTREG OF
40290 0: TEMPOP := PLOADX0IM;
40300 1: TEMPOP := PLOADX1IM;
40310 2: TEMPOP := PLOADX2IM;
40320 3: TEMPOP := PLOADX3IM;
40330 4: TEMPOP := PLOADX4IM
40340 END;
40350 NEXTREG := NEXTREG+1;
40360 IF (OPRAND<400000B)AND(OPRAND>-400000B) THEN EMITOP(TEMPOP)
40370 ELSE BEGIN
40380 TEMPREG := NEXTREG;
40390 EMITCONST(OPRAND);
40400 NEXTREG := TEMPREG;
40410 OCV := OCVMEM; OPRAND := FIXUPM-1;
40420 EMITOP(TEMPOP+1)
40430 END
40440 END;
40470 OPRAND:=OPND; OCV := TYP;
40480 END;
40490 (**)
40500 PROCEDURE EMITOP (* (OPCOD: POP) *) ;
40510 LABEL 11;
40520 CONST NOOP1=46000B; NOOP2=4600046000B; SETX7=7170000000B; EQ=0400000000B;
40530 SHIFT1=100000B; SHIFT2=10000000000B;
40540 VAR LINKP: PFILLCHAIN; APFCHAIN: PFCHAIN;
40550 ALFWD: RECORD CASE SEVERAL OF
40560 1: (INT: INTEGER);
40570 2: (LEX: PLEX)
40580 END;
40590 I: INTEGER;
40600 FMIJKCOPY: 0..7777777777B;
40610 FORCOUNT, COUNT: INTEGER; FORLABL: LABL;
40620 VP1, VP2 : SBTTYP;
40630 PARAMNOTUSED: BOOLEAN;
40640 BEGIN
40650 (*SEMCLKS := SEMCLKS+1;
40660 EMITCLK := EMITCLK-CLOCK;*)
40670 COUNT := 0; FORCOUNT := 0; PARAMNOTUSED := TRUE;
40671 IF OCV=OCVLCLGBL THEN
40672 BEGIN
40673 IF LCLGBL<>0 THEN
40674 FOR I := 1 TO LCLGBL DO
40675 IF I=1 (*FIRST CASE*) THEN EMITX0(PENVCHAIN)
40676 ELSE EMITX0(PENVCHAIN+1);
40677 OCV := OCVIMMED;
40678 END;
40680 WHILE OPCOD<>0 DO WITH XSEG, CODETABLE[OPCOD] DO
40690 BEGIN
40700 IF INLINE THEN
40710 BEGIN
40720 11: WITH BUFFER[LAST+FIFTEEN] DO
40730 BEGIN
40740 CASE LEN OF
40750 F0:
40760 FORLABL := FIXUPM;
40770 F15:
40780 BEGIN
40790 CODEWORD := CODEWORD*SHIFT1+FMIJK;
40800 FOUR := FOUR+1; RELOCATION := RELOCATION*2
40810 END;
40820 F30:
40830 IF FOUR<4 THEN
40840 BEGIN
40850 IF REL >= 0 THEN
40860 BEGIN
40870 IF REL > 0 THEN
40880 BEGIN FORCOUNT:=COUNT+REL; FORLABL:=GETNEXTLABL;
40890 DOFREF(FORLABL) END;
40900 CODEWORD := CODEWORD*SHIFT2+FMIJK;
40910 FOUR := FOUR+2; RELOCATION := RELOCATION*4
40920 END
40930 ELSE IF REL < 0 THEN
40940 BEGIN
40950 CODEWORD := CODEWORD+SHIFT2+FMIJK+FORLABL;
40960 RELOCATION := RELOCATION*4+2
40970 END;
40980 END
40990 ELSE
41000 BEGIN
41010 CODEWORD := CODEWORD*SHIFT1+NOOP1;
41020 RELOCATION := RELOCATION*2;
41030 PLANTWORD; GOTO 11
41040 END;
41050 F30K:
41060 IF FOUR<4 THEN
41070 BEGIN
41080 IF ODD(FMIJK) THEN
41090 BEGIN
41100 (*+32() ASERT(OCV IN [OCVIMMED,OCVIMMLONG], 'EMITOP-A '); ()+32*)
41110 FMIJKCOPY := FMIJK-1; OPRAND := -OPRAND;
41120 END
41130 ELSE FMIJKCOPY := FMIJK;
41140 CASE OCV OF
41150 OCVIMMED,OCVIMMLONG,OCVIMMPTR:
41160 BEGIN
41170 IF OPRAND<0 THEN OPRAND := OPRAND+777777B;
41180 CODEWORD := CODEWORD*SHIFT2+FMIJKCOPY+OPRAND;
41190 RELOCATION := RELOCATION*4
41200 END;
41210 OCVMEM:
41220 BEGIN
41230 CODEWORD := CODEWORD*SHIFT2+FMIJKCOPY+OPRAND;
41240 RELOCATION := RELOCATION*4+2
41250 END;
41260 OCVEXT:
41270 BEGIN
41280 CODEWORD := CODEWORD*SHIFT2+FMIJKCOPY;
41290 RELOCATION := RELOCATION*4;
41300 NEW(LINKP); WITH LINKP^, ALFWD, CODETABLE[PPOP] DO
41310 BEGIN
41320 FSEGLOC := SEGLOC+FIFTEEN-1; FFOUR := FOUR;
41330 COUNT := 0;
41340 LINK := NIL;
41350 INT := OPRAND;
41360 FOR I := 1 TO 7 DO
41370 WITH LEX^ DO
41380 IF S10[I]=' ' THEN ROUTINE[I] := ':' ELSE ROUTINE[I] := S10[I];
41390 LINKINS := LINKP; PUTLINK(PPOP)
41400 END
41410 END;
41420 OCVFIM, OCVFREF:
41430 BEGIN
41440 CODEWORD := CODEWORD*SHIFT2+FMIJKCOPY;
41450 RELOCATION := RELOCATION*4;
41460 DOFREF(OPRAND);
41470 END
41480 END;
41490 FOUR := FOUR+2;
41500 PARAMNOTUSED := FALSE;
41510 END
41520 ELSE
41530 BEGIN
41540 CODEWORD := CODEWORD*SHIFT1+NOOP1;
41550 RELOCATION := RELOCATION*2;
41560 PLANTWORD; GOTO 11
41570 END
41580 END;
41590 IF FOUR>4 THEN PLANTWORD;
41600 OPCOD := NEXT
41610 END
41620 END
41630 ELSE
41640 BEGIN
41650 IF PARAMNOTUSED THEN PARAM(OCVNONE, 0, OPCOD);
41660 EMITOP(PSTATICLINK);
41670 UPPER;
41680 NEW(LINKP); WITH LINKP^ DO
41690 BEGIN
41700 FSEGLOC := SEGLOC+FIFTEEN-1; FFOUR := 3;
41710 IF LINKINS=NIL THEN COUNT :=0 ELSE COUNT := LINKINS^.COUNT+1;
41720 LINK := LINKINS; LINKINS := LINKP;
41730 IF COUNT=31 THEN PUTLINK(OPCOD)
41740 END;
41750 BUFFER[LAST+FIFTEEN].CODEWORD := (SETX7+SEGLOC+FIFTEEN)*SHIFT2+EQ;
41760 RELOCATION := RELOCATION*16+8;
41770 PLANTWORD;
41780 OPCOD := 0;
41790 IF ADJUSTSP<>0 THEN EMITX1(PASP, OCVIMMED, ADJUSTSP);
41800 END;
41810 COUNT := COUNT+1;
41820 IF COUNT=FORCOUNT THEN FIXUPF(FORLABL)
41830 END;
41840 (*EMITCLK := EMITCLK+CLOCK;
41850 EMITCLKS := EMITCLKS+1*)
41860 END;
41870 (**)
41880 ()+01*)
41890 ()-23*)
41900 (**)
41910 PROCEDURE EMITX0(OPCOD: POP);
41920 BEGIN IF NOT SETINLINE(OPCOD) THEN BEGIN ADJUSTSP := 0; CLEAR(RTSTACK) END;
41930 (*+05() PARAM(OCVNONE,0,OPCOD,EVEN,NOT SETINLINE(OPCOD)); ()+05*)
41940 EMITOP(OPCOD);
41950 END;
41960 (**)
41970 (**)
41980 PROCEDURE EMITX1 (*+05() (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT) ()+05*);
41990 VAR SB1:PSB; NOTINL:BOOLEAN;
42000 BEGIN
42010 (*-24()(*+23() TAKELINE; ()+23*) ()-24*)
42020 IF TYP1 = OCVRES THEN
42030 BEGIN
42040 SB1 := ASPTR(OPND1);
42050 EMITX0 (OPCOD);
42060 (*+32() ASERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX1-A ');
42070 ASERT(SB1^.SBTYP=SBTVOID,'EMITX1-B '); ()+32*)
42080 FILL(CODETABLE[OPCOD].PR,SB1);
42090 SB1^.SBRTSTK:=RTSTACK; RTSTACK:=SB1;
42100 END
42110 ELSE
42120 BEGIN
42130 NOTINL := NOT(SETINLINE(OPCOD));
42140 IF NOTINL THEN ADJUSTSP := 0;
42150 IF TYP1 >= OCVSB THEN
42160 PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),ODDD()+05*))
42170 ELSE
42180 BEGIN
42190 IF NOTINL THEN CLEAR(RTSTACK);
42200 (*+01() NEXTREG := 0; ()+01*)
42210 PARAM(TYP1,OPND1,OPCOD(*+05(),ODDD,NOTINL()+05*));
42220 END;
42230 EMITOP(OPCOD)
42240 END
42250 END;
42260 (**)
42270 (**)
42280 PROCEDURE EMITX2 (*+05() (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT;
42290 TYP2:OPDTYP; OPND2:ADDRINT) ()+05*);
42300 VAR SB2:PSB; NOTINL:BOOLEAN;
42310 BEGIN
42320 (*+23() TAKELINE; ()+23*)
42330 IF TYP2 = OCVRES THEN
42340 BEGIN
42350 SB2 := ASPTR(OPND2);
42360 EMITX1 (OPCOD, TYP1,OPND1);
42370 (*+32() ASERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX2-A ');
42380 ASERT(SB2^.SBTYP=SBTVOID,'EMITX2-B '); ()+32*)
42390 FILL(CODETABLE[OPCOD].PR,SB2);
42400 SB2^.SBRTSTK:=RTSTACK; RTSTACK:=SB2;
42410 END
42420 ELSE
42430 BEGIN
42440 NOTINL := NOT(SETINLINE(OPCOD));
42450 IF NOTINL THEN ADJUSTSP := 0;
42460 IF TYP1 >= OCVSB THEN
42470 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),EVEN()+05*))
42480 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),EVEN()+05*));
42490 PARAM(TYP2,OPND2,OPCOD(*+05(),ODDD,FALSE()+05*)) END
42500 ELSE
42510 BEGIN
42520 IF NOTINL THEN CLEAR(RTSTACK);
42530 (*+01() NEXTREG:=0; ()+01*)
42540 PARAM(TYP1,OPND1,OPCOD(*+05(),EVEN,NOTINL()+05*));
42550 PARAM(TYP2,OPND2,OPCOD(*+05(),ODDD,FALSE()+05*))
42560 END;
42570 EMITOP(OPCOD)
42580 END
42590 END;
42600 (**)
42610 (**)
42620 PROCEDURE EMITX3 (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT; TYP2:OPDTYP;OPND2:ADDRINT;
42630 TYP3:OPDTYP; OPND3:ADDRINT);
42640 VAR SB3:PSB; NOTINL:BOOLEAN;
42650 BEGIN
42660 (*+23() TAKELINE; ()+23*)
42670 IF TYP3 = OCVRES THEN
42680 BEGIN
42690 SB3 := ASPTR(OPND3);
42700 EMITX2 (OPCOD, TYP1,OPND1, TYP2,OPND2);
42710 (*+32() ASERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX3-A ');
42720 ASERT(SB3^.SBTYP=SBTVOID,'EMITX3-B '); ()+32*)
42730 FILL(CODETABLE[OPCOD].PR,SB3);
42740 SB3^.SBRTSTK:=RTSTACK; RTSTACK:=SB3;
42750 END
42760 ELSE
42770 BEGIN
42780 NOTINL := NOT(SETINLINE(OPCOD));
42790 IF NOTINL THEN ADJUSTSP := 0;
42800 IF TYP1 >= OCVSB THEN
42810 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),ODDD()+05*))
42820 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),ODDD()+05*));
42830 PARAM(TYP2,OPND2,OPCOD(*+05(),EVEN,FALSE()+05*)) END
42840 ELSE
42850 BEGIN
42860 IF NOTINL THEN CLEAR(RTSTACK);
42870 (*+01() NEXTREG:=0; ()+01*)
42880 PARAM(TYP1,OPND1,OPCOD(*+05(),ODDD,NOTINL()+05*));
42890 PARAM(TYP2,OPND2,OPCOD(*+05(),EVEN,FALSE()+05*))
42900 END;
42910 PARAM(TYP3,OPND3,OPCOD(*+05(),ODDD,FALSE()+05*));
42920 EMITOP(OPCOD)
42930 END
42940 END;
42950 (**)
42960 (**)
42970 PROCEDURE EMITX4 (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT; TYP2:OPDTYP;OPND2:ADDRINT;
42980 TYP3:OPDTYP; OPND3:ADDRINT; TYP4:OPDTYP;OPND4:ADDRINT);
42990 VAR SB4:PSB; NOTINL:BOOLEAN;
43000 BEGIN
43010 (*+23() TAKELINE; ()+23*)
43020 IF TYP4 = OCVRES THEN
43030 BEGIN
43040 SB4 := ASPTR(OPND4);
43050 EMITX3 (OPCOD, TYP1,OPND1, TYP2,OPND2, TYP3,OPND3);
43060 (*+32() ASERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX4-A ');
43070 ASERT(SB4^.SBTYP=SBTVOID,'EMITX4-B '); ()+32*)
43080 FILL(CODETABLE[OPCOD].PR,SB4);
43090 SB4^.SBRTSTK:=RTSTACK; RTSTACK:=SB4;
43100 END
43110 ELSE
43120 BEGIN
43130 NOTINL := NOT(SETINLINE(OPCOD));
43140 IF NOTINL THEN ADJUSTSP := 0;
43150 IF TYP1 >= OCVSB THEN
43160 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),EVEN()+05*))
43170 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),EVEN()+05*));
43180 PARAM(TYP2,OPND2,OPCOD(*+05(),ODDD,FALSE()+05*)) END
43190 ELSE
43200 BEGIN
43210 IF NOTINL THEN CLEAR(RTSTACK);
43220 (*+01() NEXTREG:=0; ()+01*)
43230 PARAM(TYP1,OPND1,OPCOD(*+05(),EVEN,NOTINL()+05*));
43240 PARAM(TYP2,OPND2,OPCOD(*+05(),ODDD,FALSE()+05*))
43250 END;
43260 PARAM(TYP3,OPND3,OPCOD(*+05(),EVEN,FALSE()+05*));
43270 PARAM(TYP4,OPND4,OPCOD(*+05(),ODDD,FALSE()+05*));
43280 EMITOP(OPCOD)
43290 END
43300 END;
43310 (**)
43320 (**)
43330 PROCEDURE EMITX5 (OPCOD:POP; TYP1:OPDTYP;OPND1:ADDRINT; TYP2:OPDTYP;OPND2:ADDRINT;
43340 TYP3:OPDTYP;OPND3:ADDRINT;TYP4:OPDTYP;OPND4:ADDRINT;TYP5:OPDTYP;OPND5:ADDRINT);
43350 VAR SB5:PSB; NOTINL:BOOLEAN;
43360 BEGIN
43370 (*+23() TAKELINE; ()+23*)
43380 IF TYP5 = OCVRES THEN
43390 BEGIN
43400 SB5 := ASPTR(OPND5);
43410 EMITX4 (OPCOD, TYP1,OPND1, TYP2,OPND2, TYP3,OPND3,TYP4,OPND4);
43420 (*+32() ASERT(CODETABLE[OPCOD].PR<>SBTVOID,'EMITX5-A ');
43430 ASERT(SB5^.SBTYP=SBTVOID,'EMITX5-B '); ()+32*)
43440 FILL(CODETABLE[OPCOD].PR,SB5);
43450 SB5^.SBRTSTK:=RTSTACK; RTSTACK:=SB5;
43460 END
43470 ELSE
43480 BEGIN
43490 NOTINL := NOT(SETINLINE(OPCOD));
43500 IF NOTINL THEN ADJUSTSP := 0;
43510 IF TYP1 >= OCVSB THEN
43520 IF TYP2 >= OCVSB THEN PROC2OP(OPCOD,TYP1,OPND1,TYP2,OPND2,NOTINL(*+05(),ODDD()+05*))
43530 ELSE BEGIN PROC1OP(OPCOD,TYP1,OPND1,NOTINL(*+05(),ODDD()+05*));
43540 PARAM(TYP2,OPND2,OPCOD(*+05(),EVEN,FALSE()+05*)) END
43550 ELSE
43560 BEGIN
43570 IF NOTINL THEN CLEAR(RTSTACK);
43580 (*+01() NEXTREG:=0; ()+01*)
43590 PARAM(TYP1,OPND1,OPCOD(*+05(),ODDD,NOTINL()+05*));
43600 PARAM(TYP2,OPND2,OPCOD(*+05(),EVEN,FALSE()+05*))
43610 END;
43620 PARAM(TYP3,OPND3,OPCOD(*+05(),ODDD,FALSE()+05*));
43630 PARAM(TYP4,OPND4,OPCOD(*+05(),EVEN,FALSE()+05*));
43640 PARAM(TYP5,OPND5,OPCOD(*+05(),ODDD,FALSE()+05*));
43650 EMITOP(OPCOD)
43660 END
43670 END;
43680 (**)
43690 (**)
43700 PROCEDURE EMITCONST (*OPERAND: A68INT*);
43710 VAR JUMPOVER: LABL;
43720 BEGIN JUMPOVER := GETNEXTLABEL;
43730 EMITX1(PJMP, OCVFREF, JUMPOVER);
43740 EMITXWORD(OCVIMMED, OPERAND);
43750 FIXUPF(JUMPOVER)
43760 END;
43770 (**)
43780 (*-23()
43790 (*+01()
43800 (**)
43810 PROCEDURE FIXUPFORW(ALABL: LABL; VALUE, NFOUR: INTEGER);
43820 CONST SHIFT1=100000B;
43830 VAR APFCHAIN, BPFCHAIN: PFCHAIN;
43840 I: INTEGER;
43850 TABLEWORD: PACKED RECORD CASE INTEGER OF
43860 1: (INT: INTEGER);
43870 2: (ENTRY: PACKED ARRAY [1..7] OF CHAR; FILLER: 0..777777B);
43880 END;
43890 TVALUE, TNFOUR: INTEGER;
43900 BEGIN
43910 TABLEWORD.INT := 0;
43920 APFCHAIN := TPFCHAIN;
43930 WHILE APFCHAIN^.LINK<>NIL DO
43940 BEGIN
43950 IF APFCHAIN^.LINK^.FLABL=ALABL THEN
43960 BEGIN WITH XSEG, APFCHAIN^.LINK^ DO
43970 IF FSEGLOC>=HEADERWORD.S THEN (*CODE TO BE ALTERED IS STILL IN BUFFER*)
43980 BEGIN
43990 TVALUE := VALUE; TNFOUR := NFOUR;
44000 IF FSEGLOC+FFIFTEEN=SEGLOC+FIFTEEN THEN UPPER; (*CAN ONLY HAPPEN FROM CGLABD*)
44010 FOR I := 2-FFOUR DOWNTO 0 DO
44020 BEGIN TNFOUR := TNFOUR*2; TVALUE := TVALUE*SHIFT1 END;
44030 WITH BUFFER[FLAST+FFIFTEEN] DO
44040 CODEWORD := CODEWORD+TVALUE;
44050 FOR I := 14-FFIFTEEN DOWNTO 0 DO
44060 TNFOUR := TNFOUR*16;
44070 WITH BUFFER[FLAST] DO
44080 CODEWORD := CODEWORD+TNFOUR
44090 END
44100 ELSE WITH TABLEWORD DO
44110 BEGIN
44120 IF INT=0 THEN
44130 BEGIN
44140 WRITE(LGO, 36000002000000000000B); (*ENTR TABLE*)
44150 FOR I := 1 TO 7 DO
44160 BEGIN ENTRY[I] := CHR(ORD('A') + FLABL MOD 10); FLABL := FLABL DIV 10 END;
44170 WRITE(LGO, INT);
44180 WRITE(LGO, VALUE+ORD(NFOUR<>0)*1000000B);
44190 END;
44200 WRITE(LGO, 44000002000000000000B); (*LINK TABLE*)
44210 WRITE(LGO, INT);
44220 WRITE(LGO, ((7-FFOUR)*1000000000B+1000000B+FSEGLOC+FFIFTEEN-1)*10000000000B)
44230 END;
44240 WITH APFCHAIN^ DO
44250 BEGIN
44260 BPFCHAIN := LINK;
44270 LINK := LINK^.LINK;
44280 DISPOSE(BPFCHAIN)
44290 END
44300 END
44310 ELSE APFCHAIN := APFCHAIN^.LINK
44320 END
44330 END;
44340 (**)
44350 (**)
44360 PROCEDURE FIXUPF (* (ALABL: LABL) *);
44370 BEGIN UPPER; WITH XSEG DO FIXUPFORW(ALABL, SEGLOC+FIFTEEN-1, 2) END;
44380 (**)
44390 (**)
44400 PROCEDURE FIXUPFIM(ALABL: LABL; VALUE: INTEGER);
44410 BEGIN WITH XSEG DO FIXUPFORW(ALABL, VALUE, 0) END;
44420 (**)
44430 (**)
44440 FUNCTION FIXUPM(*: LABL *);
44450 BEGIN
44460 UPPER;
44470 WITH XSEG DO
44480 FIXUPM := SEGLOC+FIFTEEN-1
44490 END;
44500 (**)
44510 (**)
44520 PROCEDURE FIXLABL(OLDLABL, NEWLABL: LABL; KNOWN: BOOLEAN);
44530 (*IF KNOWN, NEWLABL IS THE ACTUAL VALUE TO BE GIVEN TO OLDLABEL;
44540 OTHERWISE, IT IS JUST ANOTHER LABL TO BE FIXED UP LATER*)
44550 VAR APFCHAIN: PFCHAIN;
44560 BEGIN
44570 IF KNOWN THEN
44580 FIXUPFORW(OLDLABL, NEWLABL, 2)
44590 ELSE
44600 BEGIN
44610 APFCHAIN := TPFCHAIN^.LINK;
44620 WHILE APFCHAIN<>NIL DO WITH APFCHAIN^ DO
44630 BEGIN
44640 IF FLABL=OLDLABL THEN FLABL := NEWLABL;
44650 APFCHAIN := LINK
44660 END
44670 END
44680 END;
44690 (**)
44700 ()+01*)
44710 ()-23*) (* MORE EM-1 DEPENDENT ROUTINES *)
44720 (**) (********************************)
44730 (*+02()
44732 FUNCTION EMITRTNHEAD :LABL;
44734 VAR
44740 ADDRESS :LABL;
44742 BEGIN
44750 (*+42() DATASTATE:=ENDDATA; ()+42*)
44760 ADDRESS:=GETNEXTLABEL;
44770 WRITEINSTN(PRO);EMITXPROC(OCVEXT,ADDRESS);
44771 WRITEINSTN(EOOPNDS);
44774 DATASTATE := STARTDATA;
44776 EMITXWORD(OCVMEM, HOLBOTTOM); (*DUMMY TO LOAD BSS BLOCKS IN CORRECT ORDER ON VAX*)
44778 EMITRTNHEAD:=ADDRESS;
44780 END;
44784 PROCEDURE EMITBEG;
44786 VAR TEMP : PLEX;
44788 BEGIN
44790 REWRITE(LGO);
44791 (*+24() WRITEBYTE(173); WRITEBYTE(0); ()+24*)
44792 (*-24() TAKELINE; ()-24*)
44794 NEXTLABEL := 500;
44795 LCLGBL := 0; (*SO AS TO BE DEFINED ON FIRST USE*)
44796 DATASTATE := ENDDATA;
44800 ADJUSTSP := 0;
44810 WRITEINSTN(MES); (* DECLARE WORD,POINTER SIZES *)
44820 EMITXWORD(OCVIMMED,2); (*-24() WRITE(LGO,','); ()-24*)
44830 EMITXWORD(OCVIMMED,SZWORD);(*-24() WRITE(LGO,',');()-24*)
44840 EMITXWORD(OCVIMMED,SZADDR);
44850 WRITEINSTN(EOOPNDS);
44900 ENEW(TEMP,LEX1SIZE + (9+CHARPERWORD) DIV CHARPERWORD * SZWORD);
44908 WITH TEMP^ DO
44909 BEGIN
44910 S10 := 'M_A_I_N ';
44911 S10[1]:=CHR(109); (*M*) (*THIS IS IN ASCII*)
44912 S10[3]:=CHR(97); (*A*)
44913 S10[5]:=CHR(105); (*I*)
44914 S10[7]:=CHR(110); (*N*)
44915 LXCOUNT:=(9+CHARPERWORD) DIV CHARPERWORD * SZWORD;
44916 END;
44920 WRITEINSTN(EXP);EMITXWORD(OCVEXT,ORD(TEMP)); (*-24() WRITEINSTN(EOOPNDS); ()-24*)
44930 WRITEINSTN(PRO);EMITXWORD(OCVEXT,ORD(TEMP));
44935 (*-24()WRITE(LGO,','); ()-24*)
44940 EMITXWORD(OCVIMMED,0);(*-24() WRITEINSTN(EOOPNDS); ()-24*)
44950 EDISPOSE(TEMP,LEX1SIZE + (9+CHARPERWORD) DIV CHARPERWORD * SZWORD);
44951 HOLTOP:=GETNEXTLABEL;HOLBOTTOM:=GETNEXTLABEL;
44957 DATASTATE := STARTDATA;
44958 EMITXWORD(OCVMEM, HOLBOTTOM); (*DUMMY TO LOAD BSS BLOCKS IN CORRECT ORDER ON VAX*)
44960 EMITX0(PPBEGIN); (*CALL ESTART0*)
44970 WRITEINSTN(LAE); (*LOAD NEW ADDRESS OF M_A_I_N*)
44971 WRITEOFFSET(HOLTOP,-FIRSTIBOFFSET); (*-24() WRITEINSTN(EOOPNDS); ()-24*)
44972 WRITEINSTN(STR); (*PLACE IN LB*)
44973 EMITXWORD(OCVIMMED,0); (*-24() WRITEINSTN(EOOPNDS); ()-24*)
44974 EMITX0(PPBEGIN+1); (*CALL START68, AND THUS ESTART_*)
44979 END;
44980 (**)
44981 PROCEDURE EMITEND;
44982 VAR I: INTEGER;
44990 BEGIN
44991 IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA;
44992 EMITXWORD(OCVIMMED, 0); WRITEINSTN(EOOPNDS); (*TO ENSURE THAT ANY OUTSTANDING DATA LABELS SEE CON RATHER THAN BSS*)
44995 WRITELABEL(TRUE,HOLBOTTOM);
44996 I := ROUTNL^.RNLENIDS+SIZIBTOP+SZWORD+FIRSTIBOFFSET;
45000 REPEAT
45010 WRITEINSTN(CON);
45015 WRITECON(CPACTCONS, SZWORD, 0);
45020 I := I - SZWORD;
45021 WRITEINSTN(EOOPNDS);
45022 UNTIL I <= 0;
45024 WRITELABEL(TRUE,HOLTOP);
45026 WRITEINSTN(CON); WRITECON(CPACTCONS, SZWORD, 0); WRITEINSTN(EOOPNDS);
45034 WRITEINSTN(HOL); (*DUMMY HOL FOR RUNTIME AND FILE ACCESS*)
45036 EMITXWORD(OCVIMMED,SZWORD);(*-24() WRITE(LGO,','); ()-24*)
45038 EMITXWORD(OCVIMMED,-32000-768); (*-24() WRITE(LGO,','); ()-24*)
45040 EMITXWORD(OCVIMMED,0);(*-24() WRITEINSTN(EOOPNDS); ()-24*)
45041 DATASTATE := ENDDATA;
45042 EMITX0(PPEND);
45045 WRITEINSTN(RET);EMITXWORD(OCVIMMED,0); (*-24() WRITEINSTN(EOOPNDS); ()-24*)
45046 WRITEINSTN(EEND);EMITXWORD(OCVIMMED,0);(*-24() WRITEINSTN(EOOPNDS); ()-24*)
45048 END;
45050 PROCEDURE GENDENOT (* (OPCOD: POP; SB: PSB) *) ;
45060 VAR I,J: INTEGER;
45065 THING: OBJECTP;
45066 MAP : RECORD CASE BOOLEAN OF
45067 TRUE : (OPTR: OBJECTP);
45068 FALSE: (IPTR: ^INTEGER);
45069 END;
45070 ALABL: LABL;
45080 BEGIN WITH SB^ DO
45090 WITH SBLEX^ (*A LEXEME*) DO
45100 IF SBMODE^.MDV.MDID IN [MDIDCHAN,MDIDPASC] THEN
45110 EMITX1(OPCOD, OCVEXT, ORD(SBLEX))
45120 ELSE IF SBLEX=LEXFALSE THEN
45130 EMITX1(OPCOD, OCVIMMED, 0)
45140 ELSE IF SBLEX=LEXTRUE THEN
45150 EMITX1(OPCOD, OCVIMMED, TRUEVALUE)
45160 ELSE IF ((LXDENMD=MDINT) OR (LXDENMD=MDBITS) OR (LXDENMD=MDCHAR))
45170 AND (LXTOKEN=TKDENOT) THEN
45180 EMITX1(OPCOD, OCVIMMED, LXDENRP)
45190 ELSE
45200 BEGIN
45210 IF LXV.LXPYPTR=0 THEN
45220 BEGIN
45230 IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA; ALABL := FIXUPM;
45240 LXV.LXPYPTR := ALABL;
45250 IF LXDENMD^.MDV.MDPILE THEN
45251 BEGIN
45255 NEW(THING);
45256 WITH THING^ DO
45257 BEGIN
45258 FIRSTWORD:=0; (*+13() DBLOCK:=NIL; ANCESTOR:=NIL; IHEAD:=NIL; DUMMY:=0; ()+13*)
45259 SORT:=0;PCOUNT:=255;LENGTH:=LXDENRP;
45260 MAP.OPTR:=THING;
45261 (*IF PACKING CHANGES THEN THIS FORMULA WILL HAVE TO AS WELL*)
45262 (* THIS IS (PCOUNT)+(SCOPE,SORT)+(LENGTH) *)
45263 FOR I:=1 TO (SZWORD+SZWORD+SZWORD(*+13() +SZWORD+SZWORD ()+13*)) DIV SZWORD DO
45264 BEGIN
45267 EMITXWORD(OCVIMMED,MAP.IPTR^);
45268 MAP.IPTR:=INCPTR(MAP.IPTR,SZWORD);
45269 END;
45271 (*-24() WRITEINSTN(CON); ()-24*)
45272 J:=(((SZADDR+SZINT) DIV SZINT) * CHARPERWORD) + 1;
45273 (*+24() WRITEBYTE(CPACTSTRNG);WRITECON(CPACTCONS,SZWORD,LXDENRP);
45280 FOR I:=J TO LXDENRP+J-1 DO
45290 WRITEBYTE(ORD(STRNG[I])); ()+24*)
45300 (*-24() WRITE(LGO,' ','''');
45310 FOR I:=J TO LXDENRP+J-1 DO
45311 BEGIN
45312 IF STRNG[I]='''' THEN
45313 WRITE(LGO, '\');
45315 WRITE(LGO,STRNG[I]);
45317 END;
45320 WRITE(LGO,'''');()-24*)
45325 WRITEINSTN(EOOPNDS);
45326 END; (* OF WITH *)
45330 DISPOSE(THING);
45336 END
45340 ELSE
45342 BEGIN
45343 J := (((SZADDR+SZREAL) DIV SZINT) * CHARPERWORD) + 1;
45345 (*+24() IF DATASTATE=STARTDATA THEN
45346 BEGIN WRITEINSTN(CON); DATASTATE := INDATA END;
45347 WRITEBYTE(CPACTFLOAT);
45348 WRITECON(CPACTCONS,SZWORD,SZREAL);
45349 WRITECON(CPACTCONS,SZWORD,LXDENRP);
45350 FOR I:=J TO LXDENRP+J-1 DO
45351 WRITEBYTE(ORD(STRNG[I])); ()+24*)
45352 (*-24() WRITEINSTN(CON);
45353 FOR I:=J TO LXDENRP+J-1 DO
45354 WRITE(LGO,STRNG[I]);
45355 WRITE(LGO,'F',SZREAL:1); ()-24*)
45356 WRITEINSTN(EOOPNDS);
45358 END;
45360 END;
45365 DATASTATE:=ENDDATA;
45370 EMITX1(OPCOD+1, OCVMEM, LXV.LXPYPTR)
45380 END;
45390 END;
45400 (**)
45410 PROCEDURE GENDP(M: MODE);
45420 (*FUNCTION: RETURNS THE ADDRESS OF THE DBLOCK FOR MODE M, OR THE VALULENGTH,
45430 IN GLOBAL VARIABLE GENDPVAL, WITH CORRESPONDING OPDTYP IN GENDPOCV.
45440 *)
45450 VAR OFFSET: 0..127;
45460 PROCEDURE DBLOCK(M: MODE);
45470 VAR I, J: INTEGER;
45480 BEGIN WITH M^ DO
45490 FOR I := 0 TO MDV.MDCNT-1 DO
45500 WITH MDSTRFLDS[I] DO WITH MDSTRFMD^.MDV DO
45510 IF MDDRESSED THEN
45520 BEGIN EMITXWORD(OCVIMMED, OFFSET); OFFSET := OFFSET+MDLEN END
45530 ELSE IF MDID=MDIDSTRUCT THEN
45540 DBLOCK(MDSTRFMD)
45550 ELSE OFFSET := OFFSET+MDLEN
45560 END;
45570 PROCEDURE DBLOCKM(M: MODE);
45580 VAR I: INTEGER; X: XTYPE;
45590 BEGIN WITH M^ DO
45600 FOR I := 0 TO MDV.MDCNT-1 DO
45610 WITH MDSTRFLDS[I] DO
45620 BEGIN X := TX(MDSTRFMD);
45630 IF X=12 THEN DBLOCKM(MDSTRFMD)
45640 ELSE EMITXWORD(OCVIMMED, X+1)
45650 END
45660 END;
45670 BEGIN WITH M^ DO
45680 IF MDV.MDID=MDIDROW THEN GENDP(MDPRRMD)
45690 ELSE IF MDV.MDID=MDIDSTRUCT THEN
45700 BEGIN
45710 IF MDSTRSDB=0 THEN (*DBLOCK MUST BE CREATED*)
45720 BEGIN
45730 IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA; MDSTRSDB := FIXUPM;
45740 EMITXWORD(OCVIMMED, MDV.MDLEN);
45750 OFFSET := 0; DBLOCK(M);
45760 EMITXWORD(OCVIMMED, -1);
45770 DBLOCKM(M);
45780 END;
45790 GENDPOCV := OCVMEM; GENDPVAL :=MDSTRSDB
45800 END
45810 ELSE IF MDV.MDDRESSED THEN
45820 BEGIN GENDPVAL:=0; GENDPOCV:=OCVIMMPTR END
45830 ELSE
45840 BEGIN GENDPVAL := MDV.MDLEN; GENDPOCV := OCVIMMPTR END;
45850 END;
45860 (**)
45870 (**)
45880 ()+02*)
45890 (*+01()
45900 (**)
45910 PROCEDURE EMITBEG;
45920 VAR I: INTEGER;
45930 TEMP: PLEX;
45940 BEGIN
45950 NEXTLABEL := 1;
45960 REWRITE(LGO);
45970 (*-23()
45980 WITH XSEG DO
45990 BEGIN
46000 BUFFER[3].ALFWORD := DAT; BUFFER[4].ALFWORD := TIM;
46010 (*WITH BUFFER[16] DO (*THIS WAS INTENDED TO IMPLEMENT THE SPACE PRAGMAT, BUT IT DOESN'T WORK
46020 BEGIN ALFWORD := ' :::'; CODEWORD := CODEWORD+WORDS END; *)
46030 FOR I := 1 TO BUFFER[0].CODEWORD DO
46040 WRITE(LGO, BUFFER[I].CODEWORD);
46050 END;
46060 NEW(TPFCHAIN); TPFCHAIN^.LINK := NIL;
46070 WITH XSEG DO
46080 BEGIN
46090 FIRST := 0; LAST := 0; SEGLOC := 0;
46100 BUFFER[FIRST].CODEWORD := 0; RELOCATION := 0;
46110 FOUR := 1; FIFTEEN := 1;
46120 BUFFER[LAST+FIFTEEN].CODEWORD := 0;
46130 HEADERWORD.WORD := 40000020000001000000B
46140 END;
46150 ENEW(TEMP,LEX1SIZE+5);
46160 TEMP^.S10 := 'PDERR '; (* ENTRY POINT FOR PASCAL DETECTED ERRORS *)
46170 EMITX1(PJMP, OCVEXT, ORD(TEMP));
46180 EMITX1(PJMP, OCVIMMED, OUTPUTEFET);
46190 EMITXWORD(OCVIMMED,01414320221707000000B); EMITXWORD(OCVIMMED,0);
46200 TEMP^.S10 := 'P.INIT ';
46210 EMITX1 (PPBEGIN,OCVEXT,ORD(TEMP));
46220 EDISPOSE(TEMP,LEX1SIZE+5);
46230 ()-23*)
46240 WITH ROUTNL^ DO BEGIN
46250 RNPROCBLK := GETNEXTLABEL;
46260 EMITX1 (PPBEGIN+1,OCVFIM,RNPROCBLK) END
46270 END;
46280 (**)
46290 (**)
46300 PROCEDURE EMITEND;
46310 VAR I: INTEGER;
46320 BEGIN
46330 FIXUPFIM(ROUTNL^.RNPROCBLK,ROUTNL^.RNLENIDS+SIZIBTOP+SZWORD+FIRSTIBOFFSET);
46340 EMITOP (PPEND);
46350 (*-23()
46360 UPPER; WHILE XSEG.FIFTEEN<>1 DO EMITXWORD( OCVIMMED, 0);
46370 WITH XSEG DO WITH HEADERWORD DO
46380 WHILE FIRST<>LAST DO
46390 BEGIN
46400 WRITE(LGO, WORD);
46410 FOR I := FIRST TO FIRST+15 DO
46420 WRITE(LGO, BUFFER[I].CODEWORD);
46430 FIRST := (FIRST+16) MOD 128; S := S+15
46440 END;
46450 FOR I := PNONE TO PLAST DO
46460 WITH CODETABLE[I] DO IF NOT INLINE THEN IF LINKINS<>NIL THEN PUTLINK(I);
46470 ()-23*)
46480 END;
46490 (**)
46500 (**)
46510 FUNCTION EMITRTNHEAD: LABL;
46520 BEGIN EMITRTNHEAD := FIXUPM END;
46530 ()+01*)
46540 (**)
46550 (**)
46560 (*-01() (*-02() (*-05()
46570 (*MODEL EMITBEG AND EMITEND FOR THOSE WHO HAVE NOT WRITTEN THEIR OWN YET*)
46580 PROCEDURE EMITBEG;
46590 BEGIN
46600 NEXTLABEL := 1;
46610 REWRITE(LGO);
46620 (*NOW INITIALIZE YOUR CODE BUFFER, OR WHATEVER, AND EMIT INIAL CODE*)
46630 END;
46640 (**)
46650 (**)
46660 PROCEDURE EMITEND;
46670 BEGIN
46680 (*EMIT YOUR FINAL CODE*)
46690 (*FLUSH YOUR CODE BUFFER, OR WHATEVER*)
46700 END;
46710 ()-05*) ()-02*) ()-01*)
46720 (**)
46730 (**)
47110 (*-02() (*-05()
47120 (**)
47130 PROCEDURE GENDP(M: MODE);
47140 (*FUNCTION: RETURNS THE ADDRESS OF THE DBLOCK FOR MODE M, OR THE VALULENGTH,
47150 IN GLOBAL VARIABLE GENDPVAL, WITH CORRESPONDING OPDTYP IN GENDPOCV.
47160 *)
47170 VAR JUMPOVER: LABL;
47180 OFFSET: 0..127;
47190 PROCEDURE DBLOCK(M: MODE);
47200 VAR I, J: INTEGER;
47210 BEGIN WITH M^ DO
47220 FOR I := 0 TO MDV.MDCNT-1 DO
47230 WITH MDSTRFLDS[I] DO WITH MDSTRFMD^.MDV DO
47240 IF MDDRESSED THEN
47250 BEGIN EMITXWORD(OCVIMMED, OFFSET); OFFSET := OFFSET+MDLEN END
47260 ELSE IF MDID=MDIDSTRUCT THEN
47270 DBLOCK(MDSTRFMD)
47280 ELSE OFFSET := OFFSET+MDLEN
47290 END;
47300 PROCEDURE DBLOCKM(M: MODE);
47310 VAR I: INTEGER; X: XTYPE;
47320 BEGIN WITH M^ DO
47330 FOR I := 0 TO MDV.MDCNT-1 DO
47340 WITH MDSTRFLDS[I] DO
47350 BEGIN X := TX(MDSTRFMD);
47360 IF X=12 THEN DBLOCKM(MDSTRFMD)
47370 ELSE EMITXWORD(OCVIMMED, X+1)
47380 END
47390 END;
47400 BEGIN WITH M^ DO
47410 IF MDV.MDID=MDIDROW THEN GENDP(MDPRRMD)
47420 ELSE IF MDV.MDID=MDIDSTRUCT THEN
47430 BEGIN
47440 IF MDSTRSDB=0 THEN (*DBLOCK MUST BE CREATED*)
47450 BEGIN
47460 JUMPOVER := GETNEXTLABEL; EMITX1(PJMP, OCVFREF, JUMPOVER);
47470 MDSTRSDB := FIXUPM;
47480 EMITXWORD(OCVIMMED, MDV.MDLEN);
47490 OFFSET := 0; DBLOCK(M);
47500 EMITXWORD(OCVIMMED, -1);
47510 DBLOCKM(M);
47520 FIXUPF(JUMPOVER)
47530 END;
47540 GENDPOCV := OCVMEM; GENDPVAL :=MDSTRSDB
47550 END
47560 ELSE IF MDV.MDDRESSED THEN
47570 BEGIN GENDPVAL:=0; GENDPOCV:=OCVIMMED END
47580 ELSE
47590 BEGIN GENDPVAL := MDV.MDLEN; GENDPOCV := OCVIMMED END
47600 END;
47610 (**)
47620 ()-05*) ()-02*)
47630 (**)
47640 FUNCTION GETCASE(M: MODE; OLST: OLSTTYP; SB: PSB): STATE;
47650 (*FUNCTION: COMPUTES AN ADDITION TO SOME OPCOD.
47660 THE SB HERE AND IN RELATED PLACES IS A TEMPORARY KLUDGE ??????
47670 *)
47680 VAR WHICH: STATE;
47690 WEAKREF: BOOLEAN;
47700 BEGIN WITH M^ DO
47710 BEGIN
47720 IF SB<>NIL THEN WEAKREF:=(SBWEAKREF IN SB^.SBINF) ELSE WEAKREF:=FALSE;
47730 IF NOT MDV.MDPILE THEN
47740 IF MDV.MDLEN=SZINT THEN WHICH := 0 ELSE WHICH := 1
47750 ELSE IF WEAKREF THEN WHICH:=2
47760 ELSE IF MDV.MDID=MDIDROW THEN WHICH:=3
47770 ELSE IF MDV.MDDRESSED THEN WHICH:=4
47780 ELSE WHICH:=5;
47790 NEEDDP := OLST[WHICH].DP;
47800 GETCASE := OLST[WHICH].OVAL
47810 END
47820 END;
47830 (**)
47840 (**)
47850 PROCEDURE GENOP(VAR OPCOD: POP; M: MODE; VAR OLIST: OLSTTYP; SB: PSB);
47860 (*USES GETCASE TO MODIFY OPCOD AND DOES GENDP IF NECESSARY*)
47870 BEGIN
47880 OPCOD := OPCOD+GETCASE(M, OLIST, SB);
47890 IF NEEDDP THEN
47900 BEGIN
47910 IF SB<>NIL THEN
47920 IF SBWEAKREF IN SB^.SBINF THEN M := M^.MDPRRMD;
47930 GENDP(M);
47940 END
47950 ELSE BEGIN GENDPOCV:=OCVNONE; GENDPVAL:=0 END
47960 END;
47970 (**)
47980 (**)
47990 FUNCTION GENLCLGBL (*+05() (VAR OPCOD: POP; SB: PSB):INTEGER ()+05*) ;
48000 VAR I,X: INTEGER;
48010 VP : SBTTYP;
48030 BEGIN WITH SB^ DO
48040 BEGIN
48050 (*-41() GENLCLGBL:=SBOFFSET; ()-41*)
48060 (*+41() GENLCLGBL:=-SBOFFSET; ()+41*)
48062 LCLGBL := 0;
48070 IF (SBLEVEL = 0) (*+05() AND (SBLEVEL<>ROUTNL^.RNLEVEL) ()+05*) THEN (*GLOBAL*)
48080 BEGIN X:=1;
48086 (*-05() (*-41() GENLCLGBL:=SBOFFSET+FIRSTIBOFFSET; ()-41*)
48087 (*+41() GENLCLGBL:=-(SBOFFSET+FIRSTIBOFFSET); ()+41*) ()-05*)
48090 (*+05() GENLCLGBL:=256-SBOFFSET ()+05*) END
48100 ELSE
48110 BEGIN
48120 IF SBLEVEL=ROUTNL^.RNLEVEL THEN(*LOCAL*) X:=0
48130 ELSE
48140 BEGIN (*INTERMEDIATE*)
48150 X:=2;
48152 LCLGBL := ROUTNL^.RNLEVEL-SBLEVEL;
48240 END
48250 END;
48260 OPCOD := OPCOD+X;
48270 END
48280 END;
48290 (**)
48300 (**)
48310 (*-02() (*-05()
48320 PROCEDURE GENDENOT (* (OPCOD: POP; SB: PSB) *) ;
48330 VAR THING: OBJECT; I: INTEGER;
48340 JUMPOVER: LABL;
48350 BEGIN WITH SB^ DO
48360 WITH SBLEX^ (*A LEXEME*) DO
48370 IF SBMODE^.MDV.MDID IN [MDIDCHAN,MDIDPASC] THEN
48380 EMITX1(OPCOD, OCVEXT, ORD(SBLEX))
48390 ELSE IF SBLEX=LEXFALSE THEN
48400 EMITX1(OPCOD, OCVIMMED, 0)
48410 ELSE IF ((LXDENMD=MDINT) OR (LXDENMD=MDBITS) OR (LXDENMD=MDCHAR))
48420 (*+01() AND (LXDENRP<400000B) ()+01*) AND (LXTOKEN=TKDENOT) THEN
48430 EMITX1(OPCOD, OCVIMMED, LXDENRP)
48440 ELSE
48450 BEGIN
48460 IF LXV.LXPYPTR=0 THEN
48470 BEGIN
48480 JUMPOVER := GETNEXTLABEL; EMITX1(PJMP, OCVFREF, JUMPOVER);
48490 LXV.LXPYPTR := FIXUPM;
48500 IF SBLEX=LEXTRUE THEN
48510 EMITXWORD(OCVIMMED, TRUEVALUE)
48520 ELSE IF LXDENMD^.MDV.MDPILE THEN WITH THING DO
48530 BEGIN FIRSTWORD := 0; PCOUNT := 255;
48540 LENGTH := (*-04() LXDENRP; ()-04*)(*+04() SHRINK(LXDENRP); ()+04*)
48550 EMITXWORD(OCVIMMED, FIRSTWORD);
48560 FOR I := 3 TO LXCOUNT DO
48570 EMITXWORD(OCVIMMED, INTEGERS[I])
48580 END
48590 ELSE EMITXWORD(OCVIMMED, LXDENRP);
48600 FIXUPF(JUMPOVER)
48610 END;
48620 IF LXTOKEN=TKDENOT THEN (*NOT LEXTRUE*)
48630 IF LXDENMD^.MDV.MDPILE THEN OPCOD := OPCOD-1;
48640 EMITX1(OPCOD+1, OCVMEM, LXV.LXPYPTR)
48650 END
48660 END;
48670 ()-05*) ()-02*)
48680 ()+87*)
Reference in a new issue View git blame Copy permalink