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*)
