d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
ack/lang/a68s/aem/a68s1cg.p

1349 lines
54 KiB
OpenEdge ABL
Raw Normal View History

Initial revision
1988-10-04 10:56:50 +00:00
50000 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
50010 (*+84() FUNCTION COERCE(M:MODE):MODE; FORWARD; ()+84*)
50020 (*+86()
50030 (**)
50040 (*CODE GENERATOR*)
50050 (****************)
50060 (**)
50070 PROCEDURE MARK(L: LABL);
50080 (*FUNCTION: PUSHES A BRAND NEW LABEL ONTO MARKCHAIN*)
50090 VAR NEWM: PMARKCHAIN;
50100 BEGIN NEW(NEWM); WITH NEWM^ DO
50110 BEGIN MKXPTR := L; LINK := MARKPTR; MARKPTR := NEWM END
50120 END;
50130 (**)
50140 (**)
50150 FUNCTION POPMARK: LABL;
50160 (*FUNCTION: POPS LABEL FROM MARKCHAIN*)
50170 VAR OLDM: PMARKCHAIN;
50180 BEGIN OLDM := MARKPTR; WITH OLDM^ DO
50190 BEGIN MARKPTR := LINK; POPMARK := MKXPTR; DISPOSE(OLDM) END
50200 END;
50210 (**)
50220 (**)
50230 PROCEDURE GENFLAD;
50240 (*FUNCTION: EMITS PJMP WITH FORWARD REFERENCE TO LABEL IN MARKCHAIN*)
50250 VAR NEWM: PMARKCHAIN;
50260 BEGIN
50270 NEW(NEWM); WITH NEWM^ DO
50280 BEGIN
50290 MKXPTR := GETNEXTLABEL; LINK := MARKPTR; MARKPTR := NEWM;
50300 EMITX1(PJMP, OCVFREF, MKXPTR)
50310 END
50320 END;
50330 (**)
50340 (**)
50350 PROCEDURE GENFLIF(OPCOD:POP; SB:PSB);
50360 VAR NEWM : PMARKCHAIN;
50370 BEGIN
50380 NEW(NEWM); WITH NEWM^ DO
50390 BEGIN
50400 MKXPTR := GETNEXTLABEL; LINK := MARKPTR; MARKPTR := NEWM;
50410 EMITX2(OPCOD,OCVSB,ORD(SB),OCVFREF,MKXPTR)
50420 END
50430 END;
50440 (**)
50450 (**)
50460 PROCEDURE ASSIGNFLAD;
50470 (*FUNCTION: FILLS IN FORWARD REFERENCE TO LABEL IN MARKCHAIN*)
50480 BEGIN (*+42() SETTEXTSTATE; ()+42*) FIXUPF(POPMARK) END;
50490 (**)
50500 (**)
50510 PROCEDURE STARTCHAIN;
50520 (*FUNCTION: PUSHES A MARKER (ZERO) ONTO MARKCHAIN*)
50530 VAR NEWM: PMARKCHAIN;
50540 BEGIN NEW(NEWM); WITH NEWM^ DO
50550 BEGIN MKXPTR := 0; LINK := MARKPTR; MARKPTR := NEWM END
50560 END;
50570 (**)
50580 (**)
50590 PROCEDURE ASSIGNCHAIN;
50600 (*FUNCTION: FILLS IN FORWARD REFERENCES TO LABELS IN TOP SECTION OF MARKCHAIN*)
50610 VAR PTR: LABL;
50620 BEGIN PTR := POPMARK;
50622 (*+42() SETTEXTSTATE; ()+42*)
50630 WHILE PTR<>0 DO
50640 BEGIN FIXUPF(PTR); PTR := POPMARK END
50650 END;
50660 (**)
50670 (**)
50680 (**)
50690 FUNCTION PUSHSB (PARAM:MODE) :PSB;
50700 VAR SB : PSB;
50710 BEGIN NEW(SB);
50720 WITH SB^ DO BEGIN
50730 SBDELAYS := 0; SBINF := [] (*NOT COERCEND*);
50740 SBTYP := SBTVOID; SBMODE := PARAM;
50750 IF PARAM^.MDV.MDPILE THEN SBLEN := SZADDR ELSE SBLEN := PARAM^.MDV.MDLEN;
50760 (*GUESS THE EVENTUAL SBLEN; GUESS ONLY USED IN UNITEDBAL*)
50770 SBRTSTK := RTSTACK; RTSTACK := SB END;
50780 SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SB := SB;
50790 PUSHSB := SB
50800 END;
50810 (**)
50820 (**)
50830 PROCEDURE STACKSB (*-01() (SB: PSB) ()-01*);
50840 (*FUNCTION: PUTS THE YIELD OF SB ONTO THE CONCEPTUAL RTSTACK.IN FACT, NO CODE
50850 IS GENERATED AT THIS POINT (AND IF SB IS SUBSEQUENTLY VOIDED, IT NEVER WILL BE.
50860 *)
50870 BEGIN WITH SB^ DO
50880 BEGIN
50890 SBRTSTK := RTSTACK; RTSTACK := SB;
50900 (*+01() REGSINUSE := REGSINUSE+REGISTERS[SBTYP]; ()+01*)
50910 IF SBTYP IN [SBTSTK..SBTDL] THEN RTSTKDEPTH := RTSTKDEPTH+SBLEN
50920 (*+05() ELSE WITH REGSINUSE DO
50924 BEGIN
50930 IF SBTYP IN [SBTE,SBTER0] THEN ECOUNT := ECOUNT+1;
50940 IF SBTYP IN [SBTER0..SBTFPR3] THEN FPR := FPR+[SBTYP];
50946 END;
50950 ()+05*)
50960 END
50970 END;
50980 (**)
50990 (**)
51000 PROCEDURE UNSTACKSB;
51010 (*FUNCTION: REDUCES THE CONCEPTUAL RTSTACK BY ONE.*)
51020 VAR SB: PSB;
51030 BEGIN SB := RTSTACK; WITH SB^ DO
51040 BEGIN
51050 RTSTACK := SBRTSTK;
51060 (*+01() REGSINUSE := REGSINUSE-REGISTERS[SBTYP]; ()+01*)
51070 IF SBTYP IN [SBTSTK..SBTDL] THEN RTSTKDEPTH:=RTSTKDEPTH-SBLEN
51080 (*+05() ELSE WITH REGSINUSE DO
51084 BEGIN
51090 IF SBTYP IN [SBTE,SBTER0] THEN ECOUNT := ECOUNT-1;
51100 IF SBTYP IN [SBTER0..SBTFPR3] THEN FPR := FPR-[SBTYP];
51104 END;
51110 ()+05*)
51120 END;
51130 END;
51140 (**)
51150 (**)
51160 PROCEDURE POPUNITS;
51170 (*FUNCTION: DISPOSE OF ALL THE UNITS (PARAMETERS OR BOUNDS) ON THE SUBSTACK*)
51180 BEGIN
51190 WHILE SRSEMP<>SRSUBP DO
51200 BEGIN
51210 DISPOSE(SRSTK[SRSEMP].SB); SRSEMP := SRSEMP-1 END;
51220 SUBREST
51230 END;
51240 (**)
51241 (**)
51242 PROCEDURE GETTOTCMN(SB: PSB);
51243 BEGIN
51244 WITH SB^ DO
51245 IF SBNOREF IN SBINF THEN
51246 EMITX2(PGETTOTCMN+ORD(SBNAKROW IN SBINF), OCVSB, ORD(SB), OCVRES, ORD(SB))
51247 ELSE EMITX2(PGETTOTCMN+2, OCVSB, ORD(SB), OCVRES, ORD(SB));
51248 END;
51249 (**)
51250 (**)
51260 PROCEDURE GETTOTAL(SB: PSB);
51270 (*ENSURES THAT SB IS NOT NAKED*)
51280 VAR OPCOD : POP;
51290 SB1 : PSB;
51300 BEGIN
51310 WITH SB^ DO
51320 IF SBNAKED IN SBINF THEN
51330 BEGIN
51340 OPCOD:=PGETTOTAL;
51350 GENOP(OPCOD, SBMODE, OLIST1, SB);
51360 IF SBWEAKREF IN SBINF THEN
51370 EMITX3(OPCOD, OCVSB, ORD(SB), GENDPOCV, GENDPVAL, OCVRES, ORD(SB))
51380 ELSE
51390 BEGIN
51400 GETTOTCMN(SB);
51410 IF GENDPOCV=OCVNONE THEN
51420 EMITX2(OPCOD, OCVSB, ORD(SB), OCVRES, ORD(SB))
51430 ELSE EMITX3(OPCOD, OCVSB, ORD(SB), GENDPOCV, GENDPVAL, OCVRES, ORD(SB));
51440 END;
51450 SBINF := SBINF-[SBWEAKREF,SBNOREF,SBNAKED,SBNAKROW];
51452 END
51454 ELSE IF SBSLN IN SBINF THEN
51456 BEGIN
51464 EMITX2(PGETMULT+ORD(SBWEAKREF IN SBINF), OCVSB, ORD(SB), OCVRES, ORD(SB));
51465 SBINF := SBINF-[SBWEAKREF,SBSLN];
51469 END;
51470 END;
51480 (**)
51490 (**)
51500 PROCEDURE LOADTOTAL(SB:PSB);
51510 BEGIN
51520 IF SBNAKED IN SB^.SBINF THEN GETTOTAL(SB);
51530 IF SB<>RTSTACK THEN TWIST;
51540 (*+32() ASERT(NOT(RTSTACK<>SB),'LOADTOTAL '); ()+32*)
51550 LOAD(NORMAL(SB),SB)
51560 END;
51570 (**)
51580 (**)
51590 PROCEDURE ALLOWNAK(SB:PSB);
51600 (*FUNCTION: DOES GETTOTAL IF ABSOLUTELY NECESSARY*)
51610 BEGIN WITH SB^ DO
51620 IF ((SBMODE^.MDV.MDID=MDIDREF) AND NOT(SBWEAKREF IN SBINF)) OR (SBSLN IN SBINF) THEN
51630 GETTOTAL(SB)
51640 END;
51650 (**)
51660 (**)
51670 PROCEDURE COMBINE;
51680 (*COMBINES TOP TWO ITEMS ON RTSTACK INTO ONE WITH THE SUM OF THEIR SBLENS
51690 DESTROYING WHICHEVER OF THEM IS AT SRSTK[SRSEMP]*)
51700 VAR SB1: PSB;
51710 BEGIN
51720 WITH SRSTK[SRSEMP] DO
51730 BEGIN
51740 IF SB=RTSTACK THEN SB1 := RTSTACK^.SBRTSTK ELSE SB1 := RTSTACK;
51750 UNSTACKSB; UNSTACKSB;
51760 SB1^.SBLEN := SB1^.SBLEN+SB^.SBLEN; STACKSB(SB1);
51770 DISPOSE(SB); SRSEMP := SRSEMP-1;
51780 END;
51790 END;
51800 (**)
51810 (**)
51820 PROCEDURE CGFIRM;
51830 (*MARKS SRSTK[SRSEMP] FOR DELAYED LOADING NEXT TIME*)
51840 BEGIN
51850 WITH SRSTK[SRSEMP] DO WITH SB^ DO
51860 BEGIN
51870 GETTOTAL(SB);
51880 IF RTSTACK<>SB THEN TWIST;
51890 (*-02() SBINF := SBINF+[SBSTKDELAY]; ()-02*)
51892 (*+02() LOADSTK(SB); ()+02*)
51900 END;
51902 (*+05() ADJUSTSP := 0; ()+05*)
51906 (*-02()
51910 WITH RTSTACK^ DO
51920 IF SBRTSTK<>NIL THEN
51930 IF SBSTKDELAY IN SBRTSTK^.SBINF THEN
51940 BEGIN LOADSTK(SBRTSTK); SBRTSTK^.SBINF:=SBRTSTK^.SBINF-[SBSTKDELAY] END
51944 ELSE CLEAR(SBRTSTK);
51950 ()-02*)
51951 END;
51952 (**)
51953 (**)
51955 FUNCTION STKMAP(ROUTN: PSB): (*-02()A68INT()-02*)(*+02()LONG()+02*);
51956 (*YIELDS BIT PATTERN FOR STATE OF WORKING STACK DOWN TO CURRENT ROUTN OR RANGE*)
51962 VAR MAP: BITMAP;
51963 MASKINC: (*-02()A68INT()-02*)(*+02()LONG()+02*);
51964 SB, RANGSTOP: PSB;
51965 I, BIGMASK: INTEGER;
51966 FLAG: BOOLEAN;
51967 BEGIN WITH MAP DO
51968 BEGIN INT := 0; BIGMASK := 0;
51969 (*-01() MASKINC := -32000-768; ()-01*)
51970 (*+01() MASKINC := 20000B; ()+01*)
51971 SB := RTSTACK;
51972 IF ORD(ROUTN)<>0 THEN
51973 BEGIN RANGSTOP := NIL; FLAG := FALSE END
51974 ELSE
51975 BEGIN RANGSTOP := RANGEL^.RGRTSTACK; FLAG := TRUE END;
51976 WHILE (SB<>NIL) AND (SB<>RANGSTOP) DO WITH SB^ DO
51977 BEGIN
51978 IF SBTYP IN [SBTSTK..SBTSTKN] THEN
51979 BEGIN
51980 COUNT := COUNT+SBLEN;
51981 IF COUNT>=15*SZWORD THEN
51982 OUTERR(ESE+62, WARNING, NIL);
51983 BIGMASK := BIGMASK DIV 2; IF BIGMASK<0 THEN BIGMASK := BIGMASK-MASKINC;
51984 IF NOT FLAG THEN FLAG := SB=ROUTN; (*SEE IF ABLE TO START*)
51985 IF ((SBMODE^.MDV.MDPILE) OR (SBNAKED IN SBINF)) AND FLAG THEN
51986 BIGMASK := BIGMASK+MASKINC;
51987 FOR I := 1 TO (SBLEN DIV SZWORD)-1 DO
51988 BEGIN BIGMASK := BIGMASK DIV 2; IF BIGMASK<0 THEN BIGMASK := BIGMASK-MASKINC END;
51989 END;
51990 SB := SBRTSTK
51992 END;
51993 MASK := BIGMASK;
51994 STKMAP := INT;
51995 END;
51996 END;
51997 (**)
51998 (**)
51999 FUNCTION SUBSTLEN(SBTS: SBTTYPSET): INTEGER;
52000 VAR LEN: INTEGER;
52010 PTR,STOP: PSB;
52020 BEGIN
52030 LEN := 0; PTR := RTSTACK; STOP := SRSTK[SRSUBP+1].SB^.SBRTSTK;
52040 WHILE PTR<>STOP DO WITH PTR^ DO
52050 BEGIN
52055 IF SBTYP IN SBTS THEN
52056 (*+02() IF SBTYP=SBTPRR THEN LEN := LEN+LENOF(PTR) ELSE ()+02*)
52057 LEN := LEN+SBLEN;
52058 PTR := SBRTSTK;
52059 END;
52060 SUBSTLEN := LEN;
52070 END;
52080 (**)
52090 (**)
52100 PROCEDURE CGFLINE;
52102 (*+33()VAR L: LABL; ()+33*)
52104 BEGIN
52110 PREVLINE := LEXLINE; EMITX1(PLINE, OCVIMMED, LEXLINE);
52111 (*+33()
52112 L := GETNEXTLABEL;
52113 WRITELN(LGO[ROUTNL^.RNLEVEL], 'STAB "",8#104,0,', LEXLINE:1, ',LL', L:1);
52114 WRITELN(LGO[ROUTNL^.RNLEVEL], 'LL', L:1, ':');
52115 ()+33*)
52116 END;
52120 (**)
52130 (**)
52140 PROCEDURE CGACTBNDS(SB:PSB; N: CNTR);
52150 BEGIN
52160 EMITX3(PBOUNDS, OCVSBS,ORD(SRSTK[SRSEMP].SB), OCVIMMED,N, OCVRES,ORD(SB));
52170 SB^.SBLOCRG:= N
52180 END;
52190 (**)
52200 (**)
52210 PROCEDURE CGASSIGN;
52220 VAR M:MODE;
52230 TOFFSET: INTEGER;
52240 OPCOD: POP; OLIST: OLSTTYP;
52250 SCOPECASE: BOOLEAN;
52260 SSB,DSB: PSB; (*SOURCE, DESTINATION SEMBLKS*)
52270 BEGIN
52280 SSB := SRSTK[SRSEMP].SB; DSB := SRSTK[SRSEMP-1].SB;
52290 WITH DSB^ DO
52300 BEGIN
52310 M := SBMODE^.MDPRRMD;
52320 IF SBTYP=SBTVAR THEN
52330 BEGIN
52340 SCOPECASE := FALSE;
52350 IF SSB^.SBTYP IN [SBTVAR, SBTIDV] THEN
52360 IF (SSB^.SBLEVEL>SBLEVEL) OR ((SSB^.SBLEVEL=SBLEVEL) AND (SSB^.SBLOCRG>SBLOCRG)) THEN SEMERR(ESE+14)
52370 ELSE
52380 ELSE IF M^.MDV.MDSCOPE THEN SCOPECASE := TRUE;
52390 GETTOTAL(SSB);
52400 IF SCOPECASE THEN
52410 BEGIN
52420 OPCOD := PSCOPEVAR;
52430 TOFFSET := GENLCLGBL(OPCOD, DSB);
52440 EMITX3(OPCOD, OCVSB, ORD(SSB), OCVIMMED, SBLOCRG, OCVLCLGBL, TOFFSET)
52450 END
52460 ELSE BEGIN
52470 OPCOD := PASGVART+GETCASE(M, OLIST2, SSB);
52480 TOFFSET := GENLCLGBL(OPCOD, DSB);
52490 EMITX2(OPCOD, OCVSB, ORD(SSB), OCVLCLGBL, TOFFSET);
52500 END
52510 END
52520 ELSE
52530 BEGIN
52540 IF M^.MDV.MDID=MDIDSTRUCT THEN ALLOWNAK(SSB) ELSE GETTOTAL(SSB);
52542 IF SBNAKED IN SSB^.SBINF THEN GETTOTCMN(SSB);
52550 CASE ORD(SBNAKED IN SSB^.SBINF)*4
52560 +ORD(SBNAKED IN SBINF)*2
52570 +ORD(M^.MDV.MDSCOPE) OF
52580 0: BEGIN OPCOD:=PASSIGTT;OLIST:=OLIST3 END;
52590 1: BEGIN OPCOD:=PSCOPETT;OLIST:=OLIST3 END;
52600 2: BEGIN OPCOD:=PASSIGNT;OLIST:=OLIST1 END;
52610 3: BEGIN OPCOD:=PSCOPENT;OLIST:=OLIST1 END;
52620 4: BEGIN OPCOD:=PASSIGTN;OLIST:=OLIST5 END;
52630 5: BEGIN OPCOD:=PSCOPETN;OLIST:=OLIST5 END;
52640 6: BEGIN OPCOD:=PASSIGNN;OLIST:=OLIST5 END;
52650 7: BEGIN OPCOD:=PSCOPENN;OLIST:=OLIST5 END
52660 END;
52670 GENOP(OPCOD,M,OLIST,SSB);
52680 IF GENDPOCV=OCVNONE THEN
52690 EMITX3(OPCOD, OCVSB, ORD(DSB), OCVSB, ORD(SSB), OCVRES, ORD(DSB))
52700 ELSE EMITX4(OPCOD,OCVSB,ORD(DSB),OCVSB,ORD(SSB),GENDPOCV,GENDPVAL,OCVRES,ORD(DSB))
52710 END;
52720 END
52730 END;
52740 (**)
52750 (**)
52760 (*CGBALB IS TO BE FOUND AFTER CGCOERCE*)
52770 (**)
52780 (**)
52790 PROCEDURE CGBALC;
52800 (*END OF BALANCE*)
52810 BEGIN ASSIGNCHAIN;
52820 WITH SRSTK[SRSEMP] DO
52830 (*SRSTK[SRSEMP] IS ALREADY CORRECT FROM CGBALB*)
52840 FILL(NORMAL(SB), SB);
52850 END;
52860 (**)
52870 (**)
52880 PROCEDURE CGCALL(SB, SBR: PSB);
52890 (*ROUTINE CALL*)
52900 VAR OFFSET: INTEGER;
52910 OPCOD: POP;
52920 OCVFIX: OPDTYP;
52922 SB1: PSB;
52930 BEGIN
52932 (*-01()
52933 SB1 := PUSHSB(MDLINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := STKMAP(SB^.SBRTSTK); CGFIRM;
52934 SB1 := PUSHSB(MDINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := ROUTNL^.RNLOCRG+1; CGFIRM;
52938 ()-01*)
52960 IF SB^.SBTYP IN [SBTPROC,SBTRPROC] THEN
52970 BEGIN
52980 IF SB^.SBTYP = SBTPROC THEN OCVFIX := OCVMEM
52990 ELSE (* SBTRPROC *) OCVFIX := OCVFREF ;
52992 ADJUSTSP := 0;
53020 OPCOD := PCALLA;
53030 OFFSET := GENLCLGBL(OPCOD,SB);
53032 (*-01() EMITX3(OPCOD, OCVSBS,ORD(RTSTACK), ()-01*)
53040 (*+01() EMITX5(OPCOD, OCVSBS,ORD(RTSTACK),OCVIMMLONG,STKMAP(SB^.SBRTSTK),OCVIMMED,ROUTNL^.RNLOCRG+1, ()+01*)
53050 OCVFIX,SB^.SBXPTR,OCVLCLGBL,(*-02()OFFSET()-02*)(*+02()-SZADDR()+02*));
53060 END
53070 ELSE
53080 BEGIN
53082 LOADSTK(RTSTACK); (*TO ENSURE THAT SUBSTLEN WORKS*)
53090 EMITX1(PGETPROC, OCVIMMED, -SUBSTLEN([SBTSTK..SBTDL])(*+05()+ORD((RTSTKDEPTH MOD 4)<>0)*SZWORD()+05*));
53100 ADJUSTSP :=0;
53102 (*+02() ADJUSTSP := ADJUSTSP+2*SZADDR; (*ROUTN*) ()+02*)
53110 (*+05() ADJUSTSP := ADJUSTSP+2*SZWORD; ()+05*)
53112 (*-01() EMITX1(PCALL, OCVSBS,ORD(RTSTACK)); ()-01*)
53120 (*+01() EMITX3(PCALL, OCVSBS,ORD(RTSTACK),
53130 OCVIMMLONG,ORD(STKMAP(SB^.SBRTSTK)), OCVIMMED,ROUTNL^.RNLOCRG+1); ()+01*)
53140 END;
53150 EMITX1(PASP,OCVIMMED,ADJUSTSP);
53155 (*+02()CGFLINE;()+02*)
53160 (*-02()FILL(NORMAL(SBR), SBR);()-02*)
53162 (*+02()FILL(SBTPRR,SBR); ()+02*)
53164 SBR^.SBRTSTK := RTSTACK; RTSTACK := SBR;
53170 END;
53180 (**)
53190 (**)
53200 PROCEDURE CGCOLLUNIT;
53210 (*AT EACH UNIT OF DISPLAY*)
53220 VAR OPCOD : POP;
53230 BEGIN
53240 WITH SRSTK[SRSEMP] DO WITH SB^ DO
53250 IF NOT (SBUNION IN SBINF) THEN (*NOT DATA LIST*)
53260 BEGIN
53270 IF NOT (SBCOLL IN SBINF) THEN
53280 BEGIN
53290 IF SBMODE^.MDV.MDID=MDIDSTRUCT THEN ALLOWNAK(SB) ELSE GETTOTAL(SB);
53300 IF SBNAKED IN SBINF THEN
53310 BEGIN OPCOD:=PCOLLNAKED; GENOP(OPCOD, SBMODE, OLIST5, SB); GETTOTCMN(SB) END
53320 ELSE
53330 BEGIN OPCOD:=PCOLLTOTAL; GENOP(OPCOD, SBMODE, OLIST6, SB) END;
53340 WITH RTSTACK^ DO
53350 IF GENDPOCV=OCVNONE THEN
53360 EMITX4(OPCOD,OCVSB,ORD(SBRTSTK),OCVSB,ORD(SB),OCVIMMED,SBRTSTK^.SBOFFSET,OCVRES,ORD(SBRTSTK))
53370 ELSE EMITX5(OPCOD,OCVSB,ORD(SBRTSTK),OCVSB,ORD(SB),
53380 GENDPOCV,GENDPVAL,OCVIMMED,SBRTSTK^.SBOFFSET,OCVRES,ORD(SBRTSTK));
53390 WITH RTSTACK^ DO SBOFFSET := SBOFFSET+SB^.SBMODE^.MDV.MDLEN;
53400 (*FOR A MULT, MDLEN=0, SO COLLTM ADVANCES POINTER AT RUN TIME *)
53410 END
53420 ELSE IF RTSTACK=SB THEN WITH SRSTK[SRSUBP-1] DO
53430 BEGIN SB^.SBTYP := RTSTACK^.SBTYP; SB^.SBOFFSET := RTSTACK^.SBOFFSET; UNSTACKSB; STACKSB(SB) END;
53440 DISPOSE(SB); SRSEMP := SRSEMP-1
53450 END
53460 END;
53470 (**)
53480 (**)
53490 PROCEDURE CGCASA;
53500 (*BEFORE .IN*)
53510 BEGIN
53520 GENFLIF(PCASE,SRSTK[SRSEMP].SB);
53530 STARTCHAIN;
53540 MARK(FIXUPM)
53550 END;
53560 (**)
53570 (**)
53580 PROCEDURE CGCASC;
53590 (*AT END OF .CASE, TO FORM JUMP TABLE*)
53600 VAR COUNT: INTEGER;
53602 FIRSTMARK: LABL;
53610 PROCEDURE CASECHAIN(L: LABL);
53622 VAR COUNTCOPY: INTEGER;
53630 BEGIN
53650 IF L<>0 THEN
53660 BEGIN
53670 COUNT := COUNT+1;
53672 COUNTCOPY := COUNT;
53680 CASECHAIN(POPMARK);
53690 (*+01() UPPER; ()+01*)
53700 (*-02() EMITX1(PCASJMP+ORD(COUNTCOPY=1), OCVMEM, L); ()-02*)
53702 (*+02() IF COUNTCOPY<>1 THEN EMITXWORD(OCVFREF(*FORCE INSTR. LABEL*), L); ()+02*)
53710 END
53720 ELSE
53730 BEGIN
53732 (*+02() IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA; ()+02*)
53740 FIXUPF(POPMARK);
53750 (*-02() (*-05() EMITXWORD(OCVIMMED, COUNT); ()-05*) ()-02*)
53751 (*+02()
53752 EMITXWORD(OCVFREF(*FORCE INSTR. LABEL*), FIRSTMARK);
53754 EMITXWORD(OCVIMMED, 1); (*LWB*)
53756 EMITXWORD(OCVIMMED, COUNT-2); (*UPB-LWB*)
53757 ()+02*)
53758 (*+05() EMITX1(PCASCOUNT, OCVIMMED, COUNT-1); ()+05*)
53760 END
53770 END; (* OF CASECHAIN *)
53780 BEGIN
53790 COUNT := 0;
53792 FIRSTMARK := POPMARK;
53800 CASECHAIN(FIRSTMARK);
53810 END; (* OF CGCASC *)
53820 (**)
53830 (**)
53840 PROCEDURE CGPASC(SB, SBR: PSB);
53850 VAR SPACE: INTEGER;
53860 ORD1,ORD2: ADDRINT;
53870 BEGIN
53880 ORD1 := ORD(RTSTACK^.SBRTSTK); ORD2 := ORD(SB^.SBLEX);
53890 WITH SB^.SBMODE^.MDV DO
53900 BEGIN
53910 IF MDCNT=0 THEN SPACE := 0
53920 ELSE SPACE := SUBSTLEN([SBTID..SBTXN])-SZPROC; (*DON'T COUNT THE PROCEDURE AT SRSUBP+1*)
53930 (*+05() ADJUSTSP := 0; HOIST(SUBSTLEN([SBTSTK..SBTDL]), SPACE, FALSE); SPACE := SPACE+ADJUSTSP; ()+05*)
53940 (*+01()
53950 IF (SPACE=MDCNT) AND (MDCNT<3) THEN CASE MDCNT OF
53960 0: BEGIN UNSTACKSB; SBR^.SBTYP := SBTVOID; CLEAR(RTSTACK);
53970 EMITX2(PPASC, OCVEXT, ORD2, OCVRES, ORD(SBR)) END;
53980 1: BEGIN CLEAR(RTSTACK^.SBRTSTK);
53990 EMITX3(PPASC+1, OCVSBS, ORD(RTSTACK), OCVEXT, ORD2, OCVRES, ORD(SBR)) END;
54000 (*IN THE REMAINING CASES, CGFIRM WILL ALREADY HAVE DONE A SUITABLE CLEAR*)
54010 2: EMITX4(PPASC+2,OCVSBS,ORD1,OCVSB,ORD(RTSTACK),OCVEXT,ORD2,OCVRES,ORD(SBR));
54020 END
54030 ELSE ()+01*)
54040 IF RTSTACK^.SBTYP=SBTDL THEN (*CALL TO TRANSPUT*)
54050 BEGIN
54060 EMITX3(PPASC, OCVSBS, ORD(RTSTACK), OCVEXT, ORD2, OCVRES, ORD(SBR));
54064 (*-02() EMITX1(PASP, OCVIMMED, SPACE); ()-02*)
54070 (*+02() EMITX1(PASP, OCVIMMED, SPACE+SZADDR+SZADDR); (*SPACE+SPACE FOR FILE+STATIC LINK*) ()+02*)
54080 END
54090 ELSE (*NON-TRANSPUT*)
54100 (*+01() EMITX4(PPASC+3, OCVSBS, ORD(RTSTACK), OCVIMMED, SPACE, OCVEXT, ORD2, OCVRES, ORD(SBR)); ()+01*)
54120 (*-01() BEGIN
54130 EMITX3(PPASC+1, OCVSBS, ORD(RTSTACK), OCVEXT, ORD2, OCVRES, ORD(SBR));
54140 (*+02() EMITX1(PASP, OCVIMMED, SPACE+SZADDR); (*SPACE+STATIC LINK*)()+02*)
54142 (*-02() EMITX1(PASP, OCVIMMED, SPACE); ()-02*)
54150 END;
54155 (*-02()FILL(NORMAL(SBR),SBR); (*WHY IS THIS HERE?*) ()-02*)
54158 ()-01*)
54162 END;
54166 END;
54180 (**)
54190 (**)
54200 PROCEDURE CGFIXRG;
54210 (* PURPOSE: SETS RGNEXTFREE TO ITS CORRECT VALUE IF NECESSARY *)
54220 BEGIN
54222 (*+02()CLEAR(RTSTACK); (*IN CASE ANYTHING IN PRR*) ()+02*)
54230 IF (RGSTATE<16) AND NOT(DCLPARM IN RGINFO) THEN (*RGNEXTFREE NOT OK *)
54240 BEGIN
54250 EMITX1(PFIXRG,OCVIMMED,CURID-TODOCOUNT);
54260 EMITX1(PFIXRG+1,OCVIMMED,CURLEB+RGOFFSET);
54270 RGSTATE := RGSTATE + 16;
54280 END;
54290 END;
54300 (**)
54310 (**)
54320 PROCEDURE BRKASCR;
54322 LABEL 99;
54330 VAR I: INTEGER;
54340 SB1: PSB;
54350 PTR: PSTB;
54352 PILE: BOOLEAN;
54360 BEGIN
54370 (*THE UNITS TO BE ASCRIBED ARE ON THE SUBSTACK (SUBSAVE IN S-34)*)
54390 IF ((RGSTATE MOD 16) IN [1..DLACTION -1]) AND (PSCOUNT <> 0) THEN
54400 BEGIN
54410 IF NOT (DCLPARM IN RGINFO) THEN
54420 BEGIN
54421 I := CURID-PSCOUNT;
54436 PILE := DCLPRVMODE^.MDV.MDPILE;
54438 EMITX0(PDCLINIT+ORD(PILE));
54440 I := CURID-PSCOUNT;
54450 WHILE I<>CURID DO
54460 BEGIN EMITX1(PDCLINIT+2+ORD(PILE), OCVIMMED,I);
54462 I := I+SZINT (*+19()+(SZADDR-SZINT)*ORD(PILE)()+19*) END;
54464 (*+02() EMITX1(PASP, OCVIMMED, SZINT (*+19()+(SZADDR-SZINT)*ORD(PILE)()+19*) ); ()+02*)
54470 END;
54480 RGSTATE := RGSTATE MOD 16;
54490 END;
54500 IF ((RGSTATE MOD 16)>=DLACTION) AND NOT (DCLPARM IN RGINFO) THEN
54510 (*SOME SORT OF INITIALISATION NEEDED *)
54520 BEGIN
54530 IF ((RGSTATE MOD 16)<DLUNITS) AND NOT(DCLACTDR IN RGINFO) THEN (*UNINITIALIZED MULT OR STRUCT*)
54540 BEGIN
54550 RGINFO := RGINFO+[DCLACTDR];
54560 GENDP(DCLPRVMODE);
54570 IF DCLPRVMODE^.MDV.MDID=MDIDROW THEN
54580 EMITX3(PACTDRMULT, OCVSB, ORD(RTSTACK), GENDPOCV, GENDPVAL, OCVRES, ORD(RTSTACK))
54590 ELSE
54600 BEGIN
54610 SB1 := PUSHSB(MDBNDS); UNSTACKSB;
54620 EMITX2(PACTDRSTRUCT, GENDPOCV, GENDPVAL, OCVRES, ORD(SB1));
54630 END;
54640 END;
54642 I := 0 ;
54650 IF (RGSTATE MOD 16) > 11 THEN (*NOT STOWED VARIABLE-DECLARATIONS*)
54660 IF TODOCOUNT=0 THEN (* NO ACTION *)
54670 ELSE IF ((RGSTATE MOD 16)<>12) AND (TODOCOUNT=SZADDR) THEN
54675 EMITX2(PDCLSP+1, OCVSBS, ORD(RTSTACK), OCVIMMED, CURID-TODOCOUNT)
54676 ELSE IF TODOCOUNT=SZWORD THEN
54680 EMITX2(PDCLSP, OCVSBS, ORD(RTSTACK), OCVIMMED, CURID-TODOCOUNT)
54690 ELSE
54700 EMITX3(PDCLSP+2+ORD((RGSTATE MOD 16)<>12),OCVSBS,ORD(RTSTACK),OCVIMMED,TODOCOUNT,OCVIMMED,CURID-TODOCOUNT)
54710 ELSE WHILE I<TODOCOUNT DO
54720 BEGIN
54730 IF (RGSTATE MOD 16) IN [4, 5] THEN (*UNINITIALIZED STRUCT*)
54740 IF (DCLSAVEDESC IN RGINFO) OR (TODOCOUNT-I>SZADDR) THEN (*ACTDR WILL BE NEEDED AGAIN*)
54750 BEGIN
54760 SB1 := PUSHSB(RTSTACK^.SBMODE); UNSTACKSB;
54770 EMITX2(PDUP1PILE, OCVSBP, ORD(RTSTACK), OCVRES, ORD(SB1));
54780 END
54790 ELSE (*NO ACTION*)
54800 ELSE IF (RGSTATE MOD 16) IN [10, 11] THEN (*INITIALIZED MULT*)
54810 BEGIN
54820 SB1 := PUSHSB(RTSTACK^.SBMODE); UNSTACKSB;
54830 EMITX3(PDUP2PILE, OCVSBP, ORD(RTSTACK^.SBRTSTK), OCVSBP, ORD(RTSTACK), OCVRES, ORD(SB1));
54834 WITH RTSTACK^.SBRTSTK^ DO SBINF := SBINF-[SBSTKDELAY];
54840 EMITX3(PCHECKDESC, OCVSB, ORD(RTSTACK^.SBRTSTK), OCVSB, ORD(RTSTACK), OCVRES, ORD(RTSTACK));
54860 END;
54870 EMITX2(PCREATEREF + RGSTATE MOD 4, OCVSB, ORD(RTSTACK), OCVRES, ORD(RTSTACK));
54871 IF ((DCLSAVEDESC IN RGINFO) OR (TODOCOUNT-I>SZADDR)) AND ((RGSTATE MOD 16) IN [6, 7]) THEN
54872 BEGIN (*UNINITIALIZED MULT*)
54874 SB1 := PUSHSB(RTSTACK^.SBMODE); UNSTACKSB;
54876 EMITX2(PDUP1PILE, OCVSBP, ORD(RTSTACK), OCVRES, ORD(SB1));
54878 END;
54880 EMITX2(PDCLSP+1, OCVSB, ORD(RTSTACK), OCVIMMED, CURID -I -SZADDR);
54900 I := I+SZADDR
54910 END;
54920 IF NOT(DCLSAVEDESC IN RGINFO) AND ((RGSTATE MOD 16) IN [10, 11]) THEN
54930 EMITX1(PVARLISTEND+ORD(DCLACTDR IN RGINFO), OCVSB, ORD(RTSTACK));
54940 IF NOT(DCLSAVEDESC IN RGINFO) THEN RGINFO := RGINFO-[DCLACTDR];
54950 WHILE (SRSTK[SRSEMP].SB<>RTSTACK (*IN CASE DCLSAVEDESC*) ) AND (SRSEMP<>SRSUBP) DO
54960 BEGIN DISPOSE(SRSTK[SRSEMP].SB); SRSEMP := SRSEMP-1 END;
54970 IF (RGSTATE MOD 16) <> 15 THEN
54980 BEGIN
54990 PTR := DCIL;
55000 WHILE TRUE DO
55002 IF PTR=NIL THEN GOTO 99
55004 ELSE WITH PTR^ DO
55010 BEGIN
55020 IF NOT(STCONST IN PTR^.STDEFTYP) AND (PTR^.STMODE<>NIL) THEN
55022 IF STOFFSET(*-41()<()-41*)(*+41()<=()+41*)CURID-TODOCOUNT THEN GOTO 99
55040 ELSE IF STUSED IN STDEFTYP THEN SEMERRP(ESE+63,STLEX);
55050 PTR := PTR^.STTHREAD;
55060 END;
55070 99: END;
55080 RGSTATE := 0 ;
55090 END;
55100 IF (RGSTATE IN [DLASCR..15]) THEN CGFIXRG;
55110 PSCOUNT := 0;
55120 TODOCOUNT := 0;
55130 IF RGSTATE <16 THEN RGSTATE := 0
55140 ELSE RGSTATE := 16 (* RGNEXTFREE OK *)
55150 END;
55160 (**)
55170 (**)
55180 (**)
55190 (**)
55200 (**)
55210 PROCEDURE CGDEPROC (SB:PSB);
55220 VAR OFFSET: INTEGER;
55230 OPCOD: POP;
55240 OCVFIX: OPDTYP;
55242 SB1: PSB;
55244 I: INTEGER;
55250 BEGIN
55252 (*-01()
55253 IF SB<>RTSTACK THEN TWIST;
55254 SB1 := PUSHSB(MDLINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := STKMAP(SB^.SBRTSTK); LOADSTK(SB1); TWIST;
55256 SB1 := PUSHSB(MDINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := ROUTNL^.RNLOCRG+1; LOADSTK(SB1); TWIST;
55258 ()-01*)
55260 IF SB^.SBTYP IN [SBTPROC,SBTRPROC] THEN
55270 BEGIN
55280 IF SB^.SBTYP = SBTPROC THEN OCVFIX := OCVMEM
55290 ELSE (*SBTRPROC *) OCVFIX := OCVFREF;
55300 (*-01() ADJUSTSP := 0; ()-01*)
55310 OPCOD := PCALLA ;
55320 OFFSET := GENLCLGBL(OPCOD,SB) ;
55330 (*+01() CGFIRM; (* TO FORCE ANY DELAYED STUFF TO BE LOADED *) ()+01*)
55340 UNSTACKSB;
55342 (*+05() HOIST(0, 0, FALSE);
55344 IF ADJUSTSP<>0 THEN FILL(SBTSTK, PUSHSB(MDINT));
55348 ()+05*)
55349 (*-01() EMITX2(OPCOD, ()-01*)
55350 (*+01() EMITX4(OPCOD,OCVIMMLONG,STKMAP(RTSTACK),OCVIMMED,ROUTNL^.RNLOCRG+1, ()+01*)
55360 OCVFIX,SB^.SBXPTR,OCVLCLGBL,(*-02()OFFSET()-02*)(*+02()-SZADDR()+02*));
55365 (*-01() ADJUSTSP:=ADJUSTSP+SZLONG+SZWORD; (*BITP & LOCRG*) ()-01*)
55370 END
55380 ELSE
55390 BEGIN
55400 EMITX1(PGETPROC+1, OCVSB, ORD(SB));
55410 (*-01() ADJUSTSP := 0; ()-01*)
55412 (*+02() ADJUSTSP := ADJUSTSP+SZLONG+SZWORD+2*SZADDR; (*BITP, LOCRG & ROUTN*) ()+02*)
55420 (*+05() HOIST(0, 0, FALSE);
55422 IF ADJUSTSP<>0 THEN FILL(SBTSTK, PUSHSB(MDINT));
55426 ADJUSTSP := ADJUSTSP+4*SZWORD;
55428 ()+05*)
55429 (*-01() EMITX0(PCALL); ()-01*)
55430 (*+01() EMITX2(PCALL, OCVIMMLONG,ORD(STKMAP(RTSTACK)), OCVIMMED,ROUTNL^.RNLOCRG+1); ()+01*)
55440 END;
55450 (*-01() EMITX1(PASP, OCVIMMED, ADJUSTSP); ()-01*)
55451 (*+02() CGFLINE; ()+02*)
55452 (*-01() FOR I := 1 TO 2 (*+05() +ORD((ADJUSTSP MOD 4)<>0) ()+05*) DO
55454 BEGIN UNSTACKSB; DISPOSE(SRSTK[SRSEMP].SB); SRSEMP := SRSEMP-1 END;
55456 ()-01*)
55460 (*-02()FILL(NORMAL(SB), SB);()-02*)
55462 (*+02()FILL(SBTPRR, SB); ()+02*)
55464 SB^.SBRTSTK := RTSTACK; RTSTACK := SB;
55470 END;
55480 (**)
55490 PROCEDURE CGDEST;
55500 (*DESTINATION OF ASSIGNATION*)
55510 BEGIN ALLOWNAK(SRSTK[SRSEMP].SB) END;
55520 (**)
55530 (**)
55540 PROCEDURE CGFINCOLL(DEPTH: INTEGER);
55550 (*AT END OF DISPLAY*)
55560 VAR SB1: PSB;
55570 I, SPACE: INTEGER;
55580 NDL: BOOLEAN;
55590 BEGIN
55600 NDL := TRUE;
55610 WITH SRSTK[SRSUBP-1] DO WITH SB^ DO WITH SBMODE^ DO
55620 BEGIN
55630 IF MDV.MDID=MDIDROW THEN
55640 IF MDPRRMD^.MDV.MDID IN [MDIDOUT..MDIDINB] THEN
55650 BEGIN (*DATA LIST*)
55660 NDL := FALSE;
55670 (*+05() IF (RTSTKDEPTH MOD 4)<>0 THEN
55680 BEGIN SB1 := PUSHSB(MDINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := TX(MDVOID); LOADSTK(SB1) END;
55690 ()+05*)
55700 SPACE := SUBSTLEN([SBTSTK..SBTDL]);
55710 SBLEN := SPACE+SZDL;
55720 EMITX3(PDATALIST, OCVSBS, ORD(RTSTACK), OCVIMMED, SPACE, OCVRES, ORD(SB));
55730 POPUNITS;
55740 END
55750 ELSE
55760 IF SBLEFTCOLL IN SBINF THEN
55770 BEGIN FIXUPFIM(SBXPTR, SBLEVEL); SBXPTR := SBXPTR-1 END
55780 ELSE EMITX4(PCOLLCHECK,OCVSB,ORD(RTSTACK),OCVIMMED,DEPTH,OCVIMMED,SBLEVEL,OCVRES,ORD(RTSTACK));
55790 IF NDL THEN
55800 BEGIN
55810 SUBREST;
55820 IF DEPTH=0 THEN
55830 BEGIN
55840 EMITX2(PNAKEDPTR, OCVSB,ORD(SB), OCVRES,ORD(SB)); (*NOT NEEDED ON PDP11*)
55850 SBINF := SBINF-[SBNAKED,SBCOLL]
55860 END
55870 END
55880 END
55890 END;
55900 (**)
55910 (**)
55920 PROCEDURE CGFLADJUMP;
55930 BEGIN GENFLAD END;
55940 (**)
55950 (**)
55960 PROCEDURE CGIBAL;
55970 (*AFTER INNER UNIT OF A BALANCE (SEE INNERBAL)*)
55980 BEGIN WITH SRSTK[SRSEMP] DO WITH SB^ DO
55990 IF SBMODE<>MDJUMP THEN
56000 BEGIN
56010 CLEAR(RTSTACK^.SBRTSTK);
56020 IF RTSTACK^.SBTYP=SBTPROC THEN LOAD(NORMAL(RTSTACK),RTSTACK);
56030 SBXPTR := GETNEXTLABEL;
56040 EMITX1(PJMP, OCVFREF, SBXPTR)
56050 (*POSTPONES ELABORATION TO POINT WHERE A POSTERIORI MODE IS KNOWN*)
56060 END;
56070 UNSTACKSB
56080 END;
56090 (**)
56100 (**)
56110 PROCEDURE CGIFA;
56120 (*BEFORE .THEN*)
56130 BEGIN GENFLIF(PJMPF,SRSTK[SRSEMP].SB) END;
56140 (**)
56150 (**)
56160 PROCEDURE CGINIT;
56170 BEGIN
56180 PREVLINE := 0;
56190 MARKPTR := NIL;
56200 (*+01() REGSINUSE := []; ()+01*)
56210 EMITBEG
56220 END;
56230 (**)
56240 (**)
56250 (**)
56260 (**)
56270 (**)
56280 PROCEDURE CGLABA(P: PSTB);
56290 (*NEW LABEL TO JUMP BACK TO*)
56300 BEGIN CLEAR(RTSTACK); (*+42() SETTEXTSTATE; ()+42*) P^.STXPTR[0] := FIXUPM END;
56310 (**)
56320 (**)
56330 PROCEDURE CGLABB(P: PSTB; WHICH: INTEGER);
56340 (*NEW LABEL WITH OUTSTANDING FORWARD JUMP*)
56350 BEGIN
56360 WITH P^ DO
56362 IF STXPTR[WHICH]<>0 THEN
56370 BEGIN CLEAR(RTSTACK); (*+42() SETTEXTSTATE; ()+42*) FIXUPF(STXPTR[WHICH]); STXPTR[WHICH] := 0 END
56380 END;
56390 (**)
56400 (**)
56410 PROCEDURE CGLABC(P: PSTB; WHICH: INTEGER);
56420 (*JUMP*)
56430 VAR MAP: BITMAP;
56440 BEGIN
56450 CLEAR(RTSTACK);
56460 MAP.INT := STKMAP(ASPTR(0));
56470 IF MAP.MASK<>0 THEN EMITX1(PGBSTK, OCVIMMLONG, MAP.INT);
56472 IF MAP.COUNT<>0 THEN EMITX1(PASP, OCVIMMED, MAP.COUNT);
56474 IF WHICH=1 THEN (*JUMP OUT OF ROUTINE*) WITH P^ DO
56476 BEGIN
56480 STXPTR[1] := GETNEXTLABEL;
56481 (*-01() (*-02() (*FOR SYSTEMS WHICH CANNOT JUMP INTO OTHER ROUTINES - SEE ALSO CHANGES IN RANGEXT*)
56482 EMITX2(POUTJUMP, OCVMEM, ROUTNL^.RNLINK^.RNADDRESS, OCVFREF, STXPTR[1]);
56483 (*JUMP INTO IMMEDIATELY SURROUDING ROUTINE*)
56484 ()-02*) ()-01*)
56485 (*+01() EMITX1(PJMP, OCVFREF, STXPTR[1]); ()+01*)
56486 (*+02() EMITX1(POUTJUMP, OCVFREF, STXPTR[1]); ()+02*)
56487 END
56488 ELSE
56490 WITH P^ DO
56500 IF STBLKTYP=STBAPPLAB THEN
56510 BEGIN IF STXPTR[WHICH]=0 THEN STXPTR[WHICH] := GETNEXTLABEL; EMITX1(PJMP, OCVFREF, STXPTR[WHICH]) END
56520 ELSE EMITX1(PJMP, OCVMEM, STXPTR[WHICH])
56530 END;
56540 (**)
56550 (**)
56560 PROCEDURE CGLABD(P: PSTB);
56570 (*TRANSFER JUMP TO STB TO BE JUMP TO STB^.STLINK*)
56580 VAR I: INTEGER;
56582 BEGIN
56590 WITH P^ DO FOR I := 0 TO 1 DO
56600 IF STXPTR[I]<>0 THEN
56610 IF STLINK^.STXPTR[I]<>0 THEN BEGIN (*+42() SETTEXTSTATE; ()+42*)
56620 FIXLABL(STXPTR[I], STLINK^.STXPTR[I], (STLINK^.STBLKTYP=STBDEFLAB) AND (I=0)) END
56630 ELSE STLINK^.STXPTR[I] := STXPTR[I];
56640 END;
56650 (**)
56660 (**)
56670 PROCEDURE CGLABE(P: PSTB; LEVEL: DEPTHR; LEB: OFFSETR);
56680 (*JUMP OUT OF ROUTINE*)
56682 VAR PR: PRANGE;
56684 COUNT: INTEGER;
56685 LL: LABL;
56686 (*+05() SAVE: DEPTHR; ()+05*)
56687 BEGIN
56688 (*-02() LL := P^.STXPTR[1]; ()-02*)
56689 (*+02()
56690 IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA;
56691 FIXUPF(P^.STXPTR[1]); (*LABEL FOR GTO DESCRIPTOR*)
56692 LL := GETNEXTLABEL; EMITXWORD(OCVFREF, LL);
56693 EMITXWORD(OCVIMMPTR, 0); EMITXWORD(OCVIMMPTR, 0);
56694 SETTEXTSTATE;
56695 ()+02*)
56696 FIXUPF(LL); (*LABL TO WHICH ROUTINES ACTUALLY JUMP*)
56697 PR := RANGEL;
56698 COUNT := 0;
56699 WHILE DCLLOOP IN PR^.RGINF DO
56700 BEGIN COUNT := COUNT+1; PR := PR^.RGLINK^.RGLINK END;
56701 (*+05() SAVE := RTSTKDEPTH; RTSTKDEPTH := 0; ()+05*)
56702 EMITX4(PGETOUT, OCVIMMED, LEVEL, OCVIMMED, LEB, OCVIMMLONG, STKMAP(RTSTACK), OCVIMMED, COUNT);
56710 (*ABOVE RETURNS IB PTR FOR TARGET RN*)
56720 EMITX0(PSETIB);
56722 (*+05() RTSTKDEPTH := SAVE;
56724 IF (RTSTKDEPTH MOD 4)<>0 THEN EMITX1(PASP, OCVIMMED, 2); (*BECAUSE SETIB CAN ONLY LEAVE SF QUAD-ALIGNED*)
56726 ()+05*)
56729 EMITX1(PJMP, OCVMEM, P^.STXPTR[0]); (*JUMP TO GENUINE LABEL*)
56730 END;
56740 (**)
56750 (**)
56760 PROCEDURE CGLEFTCOLL(SB: PSB);
56770 (*AT START OF DISPLAY*)
56780 VAR COLLM: MODE;
56790 ROWCOUNT: CNTR;
56800 XPTR: LABL;
56810 I: INTEGER;
56820 SB1: PSB;
56830 BEGIN
56840 WITH SRSTK[SRSEMP].SB^ DO IF NOT (SBUNION IN SBINF) THEN
56850 BEGIN
56855 WITH SB^ DO SBINF := SBINF+[SBNAKED];
56860 IF SBCOLL IN SBINF THEN
56870 SB^.SBXPTR := SBXPTR
56880 ELSE BEGIN
56890 COLLM := SCL^.SCMODE;
56900 GENDP(COLLM);
56910 IF COLLM^.MDV.MDID<>MDIDROW THEN (*INCLUDING ERRONEOUS COLLM*)
56920 EMITX2(PPREPSTRDISP, GENDPOCV,GENDPVAL, OCVRES,ORD(SB))
56930 ELSE WITH SBMODE^ DO
56940 BEGIN
56950 ROWCOUNT := COLLM^.MDV.MDCNT;
56960 IF MDV.MDID=MDIDROW THEN BEGIN ROWCOUNT := ROWCOUNT-MDV.MDCNT; LOADSTK(RTSTACK) END
56970 ELSE CLEAR(RTSTACK); (*BECAUSE OF THE PPUSHIMS WHICH FOLLOW*)
56980 SUBSAVE;
56990 FOR I := 1 TO ROWCOUNT DO
57000 BEGIN
57010 SB1 := PUSHSB(MDINT); UNSTACKSB;
57020 XPTR := GETNEXTLABEL;
57030 EMITX2(PPUSHIM(*+02()+3()+02*), OCVFIM, XPTR, OCVRES, ORD(SB1)) (*INSERT ABOVE TOP ITEM OF RTSTACK*)
57040 END;
57050 SB^.SBXPTR := XPTR;
57060 EMITX4(PPREPROWDISP+ORD(MDV.MDID=MDIDROW), OCVSBS, ORD(SB1),
57070 OCVIMMED, ROWCOUNT, GENDPOCV, GENDPVAL, OCVRES, ORD(SB));
57080 POPUNITS;
57090 (*STACK IS NOW TWISTED*)
57100 END;
57110 TWIST; (*UNTWIST*)
57120 SB^.SBOFFSET := 0;
57130 END;
57150 END;
57160 WITH SB^ DO
57170 SBINF := SBINF+[SBLEFTCOLL]
57180 END;
57190 (**)
57200 (**)
57210 PROCEDURE CGLEAPGEN(HEAP: BOOLEAN);
57220 VAR XCOD: POP;
57230 BEGIN WITH SRSTK[SRSEMP] DO WITH SB^.SBMODE^ DO
57240 BEGIN
57250 GENDP(MDPRRMD);
57260 WITH MDPRRMD^, ROUTNL^ DO
57270 BEGIN
57280 XCOD := ORD(HEAP)+2*ORD(MDV.MDRECUR AND NOT HEAP)+3*ORD(MDV.MDID=MDIDROW);
57290 CASE XCOD OF
57300 0,2: EMITX3(PLEAPGEN+XCOD, GENDPOCV, GENDPVAL, OCVIMMED, RNLOCRG, OCVRES, ORD(SB));
57310 1: EMITX2(PLEAPGEN+XCOD, GENDPOCV, GENDPVAL, OCVRES, ORD(SB));
57320 3,5: EMITX4(PLEAPGEN+XCOD, OCVSB, ORD(SB), GENDPOCV, GENDPVAL, OCVIMMED, RNLOCRG, OCVRES, ORD(SB));
57330 4: EMITX3(PLEAPGEN+XCOD, OCVSB, ORD(SB), GENDPOCV, GENDPVAL, OCVRES, ORD(SB));
57340 END;
57350 END;
57360 END
57370 END;
57380 (**)
57390 (**)
57400 (**)
57410 (**)
57420 PROCEDURE CGLPA(SB: PSB);
57430 (*LABEL AT START OF LOOP*)
57440 BEGIN CLEAR(RTSTACK); (*+42() SETTEXTSTATE; ()+42*) SB^.SBXPTR := FIXUPM END;
57450 (**)
57460 (**)
57470 PROCEDURE CGLPB(SB: PSB);
57480 (*START OF COUNTING LOOP*)
57490 BEGIN
57500 WITH SB^ DO
57510 BEGIN
57520 EMITX3(PLPINIT+ORD(SBEMPTYBY IN SBINF), OCVSBS, ORD(SRSTK[SRSEMP].SB), OCVIMMPTR, SBOFFSET, OCVRES, ORD(SB));
57525 (*+02()LOADSTK(SB);()+02*) (*FORCE RESULT FROM PRR TO THE STACK*)
57530 SBXPTR := FIXUPM;
57540 (*NOTE THAT SB MUST BE SET CONSISTENTLY IN CGLPE*)
57550 GENFLIF(PLPTEST, SB)
57560 END
57570 END;
57580 (**)
57590 (**)
57600 PROCEDURE CGLPC(SB: PSB);
57610 (*START OF NON-COUNTING LOOP*)
57620 BEGIN
57630 WITH SB^ DO
57640 EMITX2(PLPINIT+2+ORD(SBEMPTYBY IN SBINF), OCVSBS, ORD(SRSTK[SRSEMP].SB), OCVIMMED, SBOFFSET);
57650 CGLPA(SB);
57660 (*ON A PURE STACK MACHINE, THE RESULT OF PLPINCR MAY HAVE TO BE POPPED HERE*)
57670 END;
57680 (**)
57690 (**)
57700 PROCEDURE CGLPD;
57710 (*AFTER WHILE-PART*)
57720 BEGIN GENFLIF(PJMPF, SRSTK[SRSEMP].SB) END;
57730 (**)
57740 (**)
57750 PROCEDURE CGLPE;
57760 (*END OF LOOP*)
57770 BEGIN WITH SRSTK[SRSEMP] DO WITH SB^ DO
57780 BEGIN
57790 IF [DCLLOCRNG,DCLLOOP]*RGINFO=[DCLLOCRNG] THEN EMITX0(PRANGEXT); (*END OF WHILE LOOP*)
57800 IF SBLEX<>NIL THEN (*COUNTING*)
57810 BEGIN
57811 IF SBEMPTYBY IN SBINF THEN
57812 EMITX2(PLPINCR+1, OCVIMMED, SBOFFSET(*-41()+SZWORD()-41*)(*+41()-SZINT()+41*), OCVRES, ORD(SB))
57814 ELSE EMITX2(PLPINCR, OCVIMMED, SBOFFSET, OCVRES, ORD(SB));
57816 (*+02() LOADSTK(SB); ()+02*)
57820 UNSTACKSB; SBTYP := SBTVOID; (*BUT REAPPEARS IN CGLPB*)
57830 END;
57840 EMITX1(PJMP, OCVMEM, SBXPTR)
57850 END
57860 END;
57870 (**)
57880 (**)
57890 PROCEDURE CGLPG;
57900 (*TO RESET LOOPCOUNT AFTER LOOP*)
57910 VAR P: PRANGE;
57920 COUNT: INTEGER;
57930 BEGIN
57940 P := RANGEL^.RGLINK;
57950 COUNT := 0;
57960 WHILE DCLLOOP IN P^.RGINF DO
57970 BEGIN COUNT := COUNT+1; P := P^.RGLINK^.RGLINK END;
57980 EMITX1(PDECM, OCVIMMED, COUNT);
57990 EMITX1(PDECM+1, OCVIMMED, CURLEB+LOOPOFFSET);
58000 END;
58010 (**)
58020 PROCEDURE CGOPCALL;
58030 (*CALL ROUTINE FOR USER DEFINED OPERATOR*)
58040 VAR SB,SB1,SB2: PSB;
58050 SPACE,OFFSET: INTEGER;
58060 OPCOD: POP;
58070 OCVFIX: OPDTYP;
58080 BEGIN
58090 SB := SRSTK[SRSEMP].SB;
58100 WITH SB^.SBMODE^ DO WITH MDV DO
58110 BEGIN
58120 UNSTACKSB; SRSEMP := SRSEMP-1; (*PRETEND ROUTINE ISNT STACKED YET*)
58130 IF MDCNT = 1 THEN SB1 := SB^.SBRTSTK^.SBRTSTK
58140 ELSE
58150 BEGIN
58160 SB1 := SB^.SBRTSTK^.SBRTSTK^.SBRTSTK;
58170 GETTOTAL(SRSTK[SRSEMP-1].SB); (*LH OPERAND*)
58180 IF RTSTACK=SRSTK[SRSEMP].SB THEN (*STACK IS NOT TWISTED*)
58190 LOADSTK(SRSTK[SRSEMP-1].SB)
58200 END;
58210 CGFIRM; (*FOR THE RH OPERAND - TWISTS IF NECESSARY*)
58212 (*-01()(*-02() LOADSTK(RTSTACK); ()-02*)()-01*)
58220 SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SB := SB; STACKSB(SB); (*STOP PRETENDING*)
58222 (*-01()
58224 SB2 := PUSHSB(MDLINT); SB2^.SBTYP := SBTLIT; SB2^.SBVALUE := STKMAP(SB1); LOADSTK(SB2); TWIST;
58226 SB2 := PUSHSB(MDINT); SB2^.SBTYP := SBTLIT; SB2^.SBVALUE := ROUTNL^.RNLOCRG+1; LOADSTK(SB2); TWIST;
58228 ()-01*)
58230 IF SB^.SBTYP IN [SBTPROC,SBTRPROC] THEN
58240 BEGIN
58250 IF SB^.SBTYP=SBTPROC THEN OCVFIX := OCVMEM
58260 ELSE (* SBTRPROC *) OCVFIX := OCVFREF;
58270 ADJUSTSP := 0;
58280 OPCOD := PCALLA;
58290 OFFSET := GENLCLGBL(OPCOD,SB);
58291 UNSTACKSB;
58292 (*-01() EMITX3(OPCOD, OCVSBS,ORD(RTSTACK), ()-01*)
58300 (*+01() EMITX5(OPCOD, OCVSBS,ORD(RTSTACK),OCVIMMLONG,STKMAP(SB1),OCVIMMED,ROUTNL^.RNLOCRG+1, ()+01*)
58310 OCVFIX,SB^.SBXPTR,OCVLCLGBL,(*-02()OFFSET()-02*)(*+02()-SZADDR()+02*));
58320 END
58330 ELSE
58340 BEGIN
58380 EMITX1(PGETPROC+1, OCVSB, ORD(SB));
58390 ADJUSTSP := 0;
58392 (*+02() ADJUSTSP := ADJUSTSP+2*SZADDR; (*ROUTN*) ()+02*)
58400 (*+05() ADJUSTSP := ADJUSTSP+2*SZWORD; ()+05*)
58402 (*-01() EMITX1(PCALL, OCVSBS,ORD(RTSTACK)); ()-01*)
58410 (*+01() EMITX3(PCALL, OCVSBS,ORD(RTSTACK), OCVIMMLONG,ORD(STKMAP(SB1)),
58420 OCVIMMED,ROUTNL^.RNLOCRG+1); ()+01*)
58430 END;
58440 EMITX1(PASP, OCVIMMED, ADJUSTSP);
58445 (*+02()CGFLINE; ()+02*)
58450 END;
58460 WITH SRSTK[SRSUBP-1] DO
58470 BEGIN
58472 (*-02() FILL(NORMAL(SB), SB);()-02*)
58474 (*+02() FILL(SBTPRR, SB); ()+02*)
58476 SB^.SBRTSTK := RTSTACK; RTSTACK := SB
58478 END;
58480 END;
58490 (**)
58500 PROCEDURE CGOPDA;
58510 (*DELAYED OPERAND*)
58520 BEGIN GETTOTAL(SRSTK[SRSEMP].SB) END;
58530 (**)
58540 (**)
58550 PROCEDURE CGOPDC;
58560 (*ORGANIZES SEMANTIC STACK FOR LH OPERAND POSTPONED BY CGIBAL*)
58570 BEGIN WITH SRSTK[SRSEMP] (*THE LOCUM TENENS*) DO
58580 BEGIN (*ASSERT: NO REGISTERS ON RTSTACK*)
58582 (*+42() SETTEXTSTATE; ()+42*)
58590 SB^.SBXPTR := FIXUPM;
58600 (*WE SHALL JUMP HERE FROM CGOPDE AFTER COERCING LH OPERAND*)
58610 FILL(NORMAL(SB),SB); (*THE LH OPERAND AS IT WILL HAVE BEEN LOADED BY CGOPDE*)
58620 END
58630 END;
58640 (**)
58650 (**)
58660 PROCEDURE CGOPDD;
58670 (*RH OPERAND WHEN LH OPERAND WAS BALANCED*)
58680 BEGIN
58690 LOADTOTAL(SRSTK[SRSEMP].SB);
58700 GENFLAD
58710 END;
58720 (**)
58730 (**)
58740 PROCEDURE CGOPDE(SBLH: PSB);
58750 (*LH OPERAND POSTPONED*)
58760 VAR M: MODE;
58770 LEN: 0..MAXSIZE;
58780 BEGIN (*ASSERT: SRSTK[SRSEMP].SB IS LOADTOTALED, ON ACCOUNT OF PRECEDING BALANCED COERCION*)
58790 WITH SRSTK[SRSEMP] DO WITH SB^ DO
58800 BEGIN
58810 M := SBMODE; LEN := SBLEN; (*ITS TRUE MODE AND LENGTH*)
58820 SBMODE := SBLH^.SBMODE; (*THE MODE GUESSED FOR THE LOCUM TENENS IN LHOPBAL*)
58830 LOADTOTAL(SB); (*MAY ENLARGE ITS SBLEN TO THAT ANTICIPATED IN CGOPDC*)
58840 EMITX1(PJMP, OCVMEM, SBLH^.SBXPTR); (*JUMP BACK TO RH CODE*)
58850 ASSIGNFLAD;
58860 SBMODE := M; (*ITS TRUE MODE AGAIN*)
58870 SBTYP := SBLH^.SBTYP; (*LOCATION OF LH AFTER RH CODE & COERCION*)
58880 IF LEN<SBLEN THEN
58890 LOADSTK(SBLH); (*SHRINK ITS SBLEN AGAIN; THE STACK IS PROBABLY THE BEST PLACE FOR IT,
58900 SINCE EITHER CGOPBAL OR CGOPAB IS MOST LIKELY TO COME NEXT*)
58910 END;
58920 END;
58930 (**)
58940 (**)
58950 PROCEDURE CGOPR(OPCOD: POP; RESMODE: MODE; DYADIC: BOOLEAN);
58960 VAR SBLH, SBRH: PSB;
58970 BEGIN (*ASSERT: RH OPERAND IS TOTAL, BUT MAYBE TWISTED*)
58980 IF DYADIC THEN
58990 BEGIN
59000 SBLH := SRSTK[SRSEMP-1].SB;
59010 SBRH := SRSTK[SRSEMP].SB;
59020 GETTOTAL(SBLH);
59030 EMITX3(OPCOD, OCVSB, ORD(SBLH), OCVSB, ORD(SBRH), OCVRES, ORD(SBLH));
59040 END
59050 ELSE EMITX2(OPCOD, OCVSB, ORD(RTSTACK), OCVRES, ORD(RTSTACK));
59060 RTSTACK^.SBMODE := RESMODE;
59070 END;
59080 (**)
59090 (**)
59100 PROCEDURE CGOPAB(OPCOD: POP; RESMODE: MODE);
59110 VAR SB, SBLH1, SBLH2, SBRH: PSB;
59120 M: MODE;
59130 BEGIN (*ASSERT: RH OPERAND IS TOTAL, BUT MAYBE TWISTED*)
59140 SBLH1 := SRSTK[SRSEMP-1].SB; SBRH := SRSTK[SRSEMP].SB;
59150 NEW(SBLH2); SRSTK[SRSEMP].SB := SBLH2; SBLH2^ := SBLH1^;
59160 WITH SBLH1^ DO IF SBTYP>=SBTSTK THEN (*IT MUST BE DUPLICATED*)
59170 BEGIN
59180 SBLH2^.SBTYP := SBTVOID;
59190 IF SBRH^.SBTYP<SBTSTK THEN
59200 BEGIN
59210 UNSTACKSB; UNSTACKSB; STACKSB(SBLH1); (*SBRH IS UNSTACKED TEMPORARILY*)
59220 EMITX2(PDUP1ST+ORD(SBLH1^.SBLEN<>SZINT), OCVSBP, ORD(SBLH1), OCVRES, ORD(SBLH2));
59230 STACKSB(SBRH);
59240 END
59250 ELSE EMITX3(PDUP2ND+ORD(SBLH1^.SBLEN<>SZINT)+2*ORD(SBRH^.SBLEN<>SZINT),
59260 OCVSBP, ORD(SBLH1), OCVSBP, ORD(SBRH), OCVRES, ORD(SBLH2))
59270 END
59280 ELSE
59290 BEGIN UNSTACKSB; UNSTACKSB; STACKSB(SBLH1); STACKSB(SBRH); STACKSB(SBLH2) END;
59300 M := COERCE(SBLH2^.SBMODE^.MDPRRMD);
59310 GETTOTAL(SBLH2);
59320 EMITX3(OPCOD, OCVSB, ORD(SBLH2), OCVSB, ORD(SBRH), OCVRES, ORD(SBLH2));
59330 RTSTACK^.SBMODE := RESMODE^.MDPRRMD;
59332 (*ASSERT: NOT(SBSLN IN SBLH1^.SBINF)*)
59340 CGASSIGN;
59350 END;
59360 (**)
59370 (**)
59380 PROCEDURE CGRGID(STB: PSTB);
59390 (*ADD ENTRY TO RANGE IDBLOCK*)
59400 VAR IDBLOCK: BIGALFA;
59402 LALF: ALFA;
59470 LX: PLEX;
59490 M: MODE;
59500 BEGIN WITH STB^, IDBLOCK DO
59510 IF NOT(STCONST IN STDEFTYP) THEN
59520 BEGIN WITH STLEX^ DO IF LXV.LXIO=LXIOOPR THEN LX := LINK ELSE LX := STLEX;
59530 LEXALF(LX, LALF);
59540 ALF := LALF;
59550 IF STVAR IN STDEFTYP THEN
59560 BEGIN M := STMODE^.MDPRRMD; XMODE := TX(M)+17 END
59570 ELSE BEGIN M := STMODE; XMODE := TX(M)+1 END;
59580 IF M^.MDV.MDPILE THEN IDSIZE := 0
59590 ELSE IDSIZE := M^.MDV.MDLEN;
59600 EMITALF(IDBLOCK);
59610 END
59620 END;
59630 (**)
59640 (**)
59650 PROCEDURE CGRGN;
59660 (*RANGE ENTRY*)
59670 BEGIN
59680 CLEAR(RTSTACK);
59690 WITH RANGEL^ DO
59700 BEGIN
59710 RGIDBLK := GETNEXTLABEL;
59720 EMITX3(PRANGENT, OCVFREF, RGIDBLK, OCVIMMED, ROUTNL^.RNLOCRG, OCVIMMED, CURLEB(*+41()+SIZLEBBASE()+41*));
59730 END
59740 END;
59750 (**)
59760 (**)
59770 PROCEDURE CGRGXA(LOCRNG: BOOLEAN);
59780 (*SPECIAL RANGE EXIT, FOR JUMPS*)
59790 BEGIN IF LOCRNG THEN EMITX0(PRECGEN); EMITX0(PRANGEXT); END;
59800 (**)
59810 (**)
59820 PROCEDURE CGRGXB(SB: PSB);
59830 (*RANGE EXIT*)
59840 (*SB^.SBDELAYS=0 => RGINFO IS THE RANGE BEING EXITED; OTHERWISE,
59850 IT IS THE RANGE BEING EXITED TO*)
59860 BEGIN WITH SB^ DO
59870 BEGIN
59880 IF SBTYP IN [SBTVAR, SBTIDV] THEN
59890 IF SBLOCRG>ROUTNL^.RNLOCRG THEN SEMERR(ESE+14)
59900 ELSE (*NO ACTION*)
59910 ELSE WITH SBMODE^.MDV DO
59920 BEGIN
59930 IF MDSCOPE THEN
59940 IF NOT(DCLPARM IN RGINFO) OR (SBDELAYS<>0) (*NOT RANGE EXIT AT END OF ROUTINE*)
59950 OR (DCLLOCGEN IN RGINFO) OR (MDID=MDIDPROC) (*CHECK THESE EVEN AT END OF ROUTINE*) THEN
59960 BEGIN GETTOTAL(SB); EMITX2(PSCOPEEXT, OCVSB, ORD(SB), OCVRES, ORD(SB)) END;
59970 IF ((SBTYP=SBTID) AND (SBLOCRG>ROUTNL^.RNLOCRG)) OR (SBNAKED IN SBINF) THEN LOADTOTAL(SB);
59980 END;
59981 (*+02() CLEAR(RTSTACK); (*IN CASE ANYTHING IN PRR*) ()+02*)
59982 IF SBLOCGEN IN SBINF THEN EMITX0(PRECGEN);
59990 IF (SBPILEDECS IN SBINF) AND (SBTYP>=SBTSTK) AND SBMODE^.MDV.MDPILE THEN
60000 EMITX2(PRANGEXT+2, OCVSB, ORD(SB), OCVRES, ORD(SB) )
60010 ELSE IF SBPILEDECS IN SBINF THEN EMITX0(PRANGEXT)
60020 ELSE IF NOT(DCLPARM IN RGINFO) OR (SBDELAYS<>0) THEN EMITX0(PRANGEXT+1)
60030 (* ELSE DO NOT WASTE TIME FIXING RANGE STRUCTURE AT END OF ROUTINE*)
60040 END
60050 END;
60060 (**)
60070 (**)
60080 PROCEDURE CGRTA;
60090 VAR L: LABL;
60100 BEGIN WITH ROUTNL^ DO
60110 BEGIN
60120 (*-02() (*-05() GENFLAD; (*WILL BE MATCHED IN CGRTD*) ()-05*) ()-02*)
60130 RNADDRESS := EMITRTNHEAD;
60140 RNPROCBLK := GETNEXTLABEL ;
60150 (*-02() L := GETNEXTLABEL; MARK(L); (*MATCHED IN CGRTC*)
60160 (*-05() EMITX1(PRNSTART, OCVFIM, L); ()-05*) ()-02*)
60165 (*+02() EMITX0(PRNSTART); ()+02*)
60170 (*+05() EMITX2(PRNSTART, OCVNONE, 0, OCVFIM, L); ()+05*)
60180 (*-02() (*-04() (*-05() RNREGSINUSE := REGSINUSE; REGSINUSE := []; ()-05*) ()-04*) ()-02*)
60190 (*+05() RNREGSINUSE := REGSINUSE; WITH REGSINUSE DO
60200 BEGIN ECOUNT := 0; EEXTRA := 0; FPR := [] END;
60210 ()+05*)
60220 END
60230 END;
60240 (**)
60250 (**)
60260 PROCEDURE CGRTB;
60270 (*ROUTINE EXIT*)
60280 BEGIN WITH ROUTNL^, SRSTK[SRSEMP] DO WITH SB^ DO
60290 BEGIN
60300 GETTOTAL(SB);
60310 (*-02() EMITX1(PRETURN,OCVSB,ORD(SB)); ()-02*)
60315 (*+02() EMITX2(PRETURN,OCVSB,ORD(SB),OCVIMMED,LENOF(SB)); ()+02*)
60320 STACKSB(SB);
60330 END
60340 END;
60342 (**)
60344 (**)
60346 PROCEDURE CGRTE(R: PROUTN);
60348 (*OUTPUT PROCBLOCK*)
60350 VAR ROUTNAME: BIGALFA;
60351 LALF: ALFA;
60352 BEGIN WITH R^ DO
60354 BEGIN
60356 (*+42() IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA; ()+42*)
60358 FIXUPF(RNPROCBLK);
60359 RNPROCBLK := FIXUPM;
60360 (*-02() (*-05()EMITXWORD()-05*)(*+05()EMITXPROC()+05*)(OCVMEM, RNADDRESS); ()-02*)
60361 (*+02() EMITXPROC (OCVEXT,RNADDRESS); ()+02*)
60362 RNADDRESS := 0; (*TO SHOW THAT PROCBLOCK HAS BEEN MADE*)
60363 EMITXWORD(OCVIMMED, RNLEVEL);
60364 EMITXWORD(OCVIMMED, RNNECLOCRG(*SCOFFSET*));
60366 EMITXWORD(OCVIMMED, RNNECLEV(*SCOPELEVEL*));
60368 EMITXWORD(OCVIMMED, (*RNLENSTK+*) RNLENIDS+SIZIBTOP); (*OBSOLETE*)
60370 EMITXWORD(OCVIMMED,RNPARAMS);
60372 LEXALF(RNLEX, LALF);
60373 ROUTNAME.ALF := LALF; (*-01() ROUTNAME.IDSIZE := 0; ROUTNAME.XMODE := 0; ()-01*)
60374 EMITALF(ROUTNAME);
60376 EMITXWORD(OCVMEM, RNIDBLK);
60378 END
60380 END;
60382 (**)
60384 (**)
60386 PROCEDURE CGRTC;
60390 BEGIN WITH ROUTNL^ DO
60400 BEGIN
60410 (*-02()(*-04() REGSINUSE := RNREGSINUSE; ()-04*)()-02*)
60420 (*+05() IF (RNLENIDS MOD 4)<>0 THEN RNLENIDS := RNLENIDS+SZWORD; ()+05*)
60430 (*-02() FIXUPFIM(POPMARK, (*+41()-()+41*)(RNLENIDS+SIZIBTOP)); ()-02*)
60470 IF (RNNONIC=1) OR (RGLEV=2) THEN
60500 CGRTE(ROUTNL);
60510 (*+02() EMITRNTAIL(RNLENIDS+SIZIBTOP+(RNLEVEL-RNNECLEV)*SZADDR); ()+02*)
60620 END;
60630 END;
60640 (**)
60650 (**)
60660 PROCEDURE CGRTD(PROCPTR: LABL);
60670 BEGIN
60680 (*-02() (*-05() ASSIGNFLAD; ()-05*) ()-02*)
60690 EMITX2(PLOADRT, OCVFREF, PROCPTR, OCVRES, ORD(SRSTK[SRSEMP].SB))
60700 END;
60710 (**)
60820 (**)
60830 PROCEDURE CGSELECT(OFFST: OFFSETR; M: MODE; SECDRY: INTEGER);
60832 VAR OPCOD: POP;
60840 BEGIN WITH SRSTK[SRSEMP] DO
60850 BEGIN
60860 ALLOWNAK(SB);
60870 IF SECDRY>=2 THEN
60880 BEGIN
60890 GENDP(M);
60900 EMITX4(PSELECTROW, OCVSB, ORD(SB), GENDPOCV, GENDPVAL, OCVIMMED, OFFST, OCVRES, ORD(SB))
60910 END
60920 ELSE WITH SRSTK[SRSEMP].SB^ DO
60930 BEGIN
60932 IF SBNAKED IN SBINF THEN OPCOD := PSELECT+2
60934 ELSE OPCOD := PSELECT+1-ORD(ODD(SECDRY));
60940 EMITX3(OPCOD, OCVSB, ORD(SB), OCVIMMED, OFFST, OCVRES, ORD(SB));
60950 IF ODD(SECDRY) THEN SBINF := SBINF+[SBWEAKREF,SBNAKED]
60960 ELSE SBINF := SBINF+[SBNOREF,SBNAKED];
60970 END
60980 END
60990 END;
61000 (**)
61010 (**)
61020 PROCEDURE CGEND;
61030 BEGIN EMITEND END;
61040 (**)
61050 (**)
61060 PROCEDURE CGSLICE(SB: PSB; REFED: BOOLEAN);
61070 VAR PTR, PTR1: PTRIMCHAIN;
61080 SB1: PSB;
61090 SPACE, I: INTEGER;
61100 (*+05() ALIGN: INTEGER; ()+05*)
61110 BEGIN
61120 SB1 := RTSTACK^.SBRTSTK;
61130 WITH SB^ DO
61140 BEGIN
61150 IF SBMODE=MDSTRNG THEN
61160 IF SBSLICEDIM=0 THEN EMITX3(PSTRNGSLICE, OCVSB, ORD(SB1), OCVSB, ORD(RTSTACK), OCVRES, ORD(SB))
61170 ELSE EMITX3(PSTRNGSLICE+1, OCVSBS, ORD(RTSTACK), OCVIMMED, SBTRIMS^.TRTYPE, OCVRES, ORD(SB))
61180 ELSE IF SBSLICEDIM=0 THEN
61190 BEGIN
61200 IF SBPRIMDIM=1 THEN EMITX3(PSLICE1, OCVSB, ORD(SB1), OCVSB, ORD(RTSTACK), OCVRES, ORD(SB))
61210 ELSE IF SBPRIMDIM=2 THEN EMITX3(PSLICE2, OCVSBS, ORD(SB1), OCVSB, ORD(RTSTACK), OCVRES, ORD(SB))
61220 ELSE EMITX3(PSLICEN, OCVSBS, ORD(RTSTACK), OCVIMMED, SBPRIMDIM, OCVRES, ORD(SB));
61230 IF REFED THEN SBINF := SBINF+[SBWEAKREF,SBNAKED,SBNAKROW]
61240 ELSE SBINF := SBINF+[SBNOREF,SBNAKED,SBNAKROW]
61250 END
61260 ELSE
61270 BEGIN
61280 LOADSTK(RTSTACK);
61290 (*+05() ALIGN := ORD((RTSTKDEPTH MOD 4)<>0)*SZWORD; ()+05*)
61300 EMITX2(PSTARTSLICE, OCVIMMED, SBSLICEDIM, OCVIMMED, SBUNITS*SZINT(*+05()+ALIGN()+05*));
61310 PTR := SBTRIMS;
61320 (*+05() ALIGN := ORD((RTSTKDEPTH MOD 4)=0)*SZWORD; ()+05*)
61330 SPACE := 0;
61340 WHILE PTR<>NIL DO
61350 BEGIN
61360 EMITX1(PTRIM+PTR^.TRTYPE, OCVIMMED, SPACE(*+05()+ALIGN()+05*));
61370 WITH PTR^ DO
61380 SPACE := SPACE+(ORD(ODD(TRTYPE))+ORD(ODD(TRTYPE DIV 2))+ORD(ODD(TRTYPE DIV 4)))*SZINT;
61390 PTR1 := PTR;
61400 PTR := PTR^.LINK;
61410 DISPOSE(PTR1);
61420 END;
61425 EMITX1(PASP, OCVIMMED, SPACE);
61428 WHILE RTSTACK<>SRSTK[SRSUBP+1].SB DO UNSTACKSB;
61430 EMITX2(PENDSLICE, OCVSB, ORD(RTSTACK), OCVRES, ORD(SB));
61440 IF REFED THEN
61442 SBINF := SBINF+[SBWEAKREF,SBSLN]
61450 ELSE SBINF := SBINF+[SBSLN];
61460 END;
61470 END
61480 END;
61490 PROCEDURE CGPARM(VAR PTR:PSTB);
61500 BEGIN
61510 WITH PTR^ DO
61530 IF STMODE^.MDV.MDPILE THEN
61550 EMITX1(PPARM,OCVIMMED,STOFFSET);
61580 END;
61590 (**)
61600 ()+86*)
Reference in a new issue Copy permalink