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 ' IS PRODUCED ON EACH LINE *) 33483 (* IN THE +24 MACHINE 'CON ...' 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 HI0 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^.SBTYPNIL 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*)