70000              (*    COPYRIGHT 1983 C.H.LINDSEY,  UNIVERSITY OF MANCHESTER  *)
70010 (*+85()
70020 (**)
70030                 (*SEMANTIC ROUTINES*)
70040                 (*******************)
70050 (**)
70060 PROCEDURE INITSR;
70070   (*FUNCTION: PERFORM PER-COMPILATION INITIALIZATION REQUIRED BY SEMANTIC ROUTINES*)
70080     BEGIN
70090      SCPUSH(MDERROR);
70100     RTSTACK := NIL;
70110     RGINFO := [];
70120     RGSTATE := 16;
70130     RGLEV := 0;
70140     DCIL := NIL;
70150     DCLMODE := MDABSENT;
70160     DCLPRVMODE := MDABSENT;
70170     PSCOUNT := 0;
70180     NEW(RANGEL); RANGEL^.RGRTSTACK := RTSTACK;
70190     BALFLAG := FALSE;
70200     NEW(ROUTNL); WITH ROUTNL^ DO
70210 (*-02() BEGIN RNLEVEL := 0; (*AND MAYBE SOME OTHERS*) END;  ()-02*)
70220 (*+02() BEGIN RNLEVEL := 255; (*AND MAYBE SOME OTHERS*) END;  ()+02*)
70230     CURLEB := 0;
70240     SRSUBP := 0;
70250     SRSEMP := -1;
70260     RTSTKDEPTH := 0;
70270     DCLDEFN := [];
70280     END;
70290 (**)
70300 FUNCTION MAKESUBSTACK (N:INTEGER; M:MODE):PSB;
70310   (*PLACES A SEMBLOCK (FOR A RESULT) WITH SBMODE=M, TOGETHER WITH A SUBSTACK MARKER
70320     N LEVEL BELOW SRSEMP*)
70330   VAR I : INTEGER;
70340       SBB:PSB;
70350   BEGIN
70360   FOR I := 0 TO N-1 DO SRSTK[SRSEMP+2-I].SB:=SRSTK[SRSEMP-I].SB;
70370   SRSEMP:=SRSEMP-N;
70380   MAKESUBSTACK:=PUSHSB(M); UNSTACKSB;
70390   SUBSAVE;
70400   SRSEMP:=SRSEMP+N
70410   END;
70420 (**)
70430 FUNCTION ALLOC(N: OFFSETR): OFFSETR;
70440 (*FUNCTION: ALLOCATES A BLOCK OF N WORDS ON THE CURRENT INVOCATION BLOCK;
70450     RETURNS THE OFFSET OF THE FIRST WORD.
70460 *)
70470     BEGIN
70480     WITH ROUTNL^ DO
70490       BEGIN
70510 (*-41() ALLOC := CURID; CURID := CURID+N; ()-41*)
70520 (*+41() CURID := CURID+N; ALLOC := CURID; ()+41*)
70530       IF ABS(RNLENIDS)<ABS(CURID) THEN RNLENIDS := CURID;
70540       END
70550     END;
70560 (**)
70570 (**)
70580 FUNCTION FINDSTATE: STATE;
70590 (*FUNCTION: DETERMINES THE STATE IMPLIED BY THE DEFINITION CURRENTLY BEING PROCESSED*)
70600   VAR S: STATE;
70610     BEGIN
70620     WITH DCLMODE^ DO
70630       BEGIN
70640       IF (DCLDEFN=[STINIT (*FOR STDIDTY*)]) OR (DCLPARM IN RGINFO) THEN
70650         S := DLASCR
70660       ELSE IF MDV.MDID=MDIDROW THEN
70670         S := DLMULT
70680       ELSE IF MDV.MDID=MDIDSTRUCT THEN
70690         S := DLSTRUCT
70700       ELSE S := DLASCR;
70710       IF S<>DLASCR THEN (*VARIABLE STRUCTS OR ROWS*)
70720         BEGIN
70730         IF DCLDEFN=[STINIT, STVAR] THEN S := S+4;
70740         IF MDV.MDRECUR THEN S := S+1
70750         END
70760       ELSE
70770         BEGIN
70780         IF DCLDEFN=[STVAR] THEN S := DLVAREMPTY;
70790         IF (STINIT IN DCLDEFN) AND (MDV.MDID=MDIDPROC) THEN S:= 15
70800         ELSE IF (MDV.MDID=MDIDREF) AND NOT(DCLPARM IN RGINFO) THEN S := S+2
70810         ELSE IF MDV.MDPILE THEN S := S+1
70820         END;
70830       FINDSTATE := S
70840       END
70850     END;
70860 (* VALUES OF STATES:
70870               0
70880    DLVAREMPTY 1 NONSTOWED VAR NOT INIT
70890               2 NONSTOWED PILE
70900               3 NONSTOWED .REF MODE
70910    DLSTRUCT=
70920    DLACTION   4 .STRUCT VAR
70930               5 .STRUCT VAR RECURSIVE
70940    DLMULT     6 MULT VAR
70950               7 MULT VAR RECURSIVE
70960    DLUNITS    8 .STRUCT VAR INITIALIZED
70970               9 .STRUCT VAR INITIALIZED RECURSIVE
70980    DLBNDS    10 MULT VAR INITIALIZED
70990    DLDESC    11 MULT VAR INITIALIZED RECURSIVE
71000    DLASCR    12 IDENTITY OR NONSTOWED VAR INITIALIZED
71010              13 DITTO PILE
71020              14 DITTO .REF MODE
71030              15 PROCEDURES
71040   ANY STATE >= 16 REPRESENTS THAT STATE MOD 16 WITH RGNEXTFREE SET CORRECTLY.
71050 *)
71060 (**)
71070 (**)
71080 FUNCTION ALLOCIND(M: MODE): OFFSETR;
71090 (*FUNCTION: ALLOCATES STACK SPACE FOR A NEWLY DECLARED INDICATOR
71100     AND ATTENDS TO ITS INITIALIZATION.
71110 *)
71120   VAR NEWSTATE: STATE;
71130       LEN: 0..MAXSIZE;
71140     BEGIN
71150     IF M^.MDV.MDPILE THEN LEN := SZADDR ELSE LEN := M^.MDV.MDLEN;
71160     WITH DCLMODE^ DO
71170       BEGIN
71180       IF (PSCOUNT=0) OR (MDV.MDPILE<>(DCLPILE IN RGINFO)) THEN
71190         BEGIN (*START OF A NEW GROUP OF DECLARATIONS ALL ON OR ALL OFF THE PILE*)
71200         BRKASCR;
71210         IF RGSTATE IN [DLASCR..15] THEN CGFIXRG;
71220         IF DCLMODE^.MDV.MDPILE THEN RGINFO := RGINFO+[DCLPILEDECS];
71230         IF MDV.MDPILE THEN RGINFO := RGINFO+[DCLPILE] ELSE RGINFO := RGINFO-[DCLPILE]
71240         END;
71250       NEWSTATE := FINDSTATE;
71260       IF (NEWSTATE<>(RGSTATE MOD 16)) OR ((MDV.MDID=MDIDSTRUCT) AND (DCLMODE<>DCLPRVMODE)) THEN
71270         BEGIN (*TIDY UP PREVIOUS DECLARATIONS*)
71280         IF (DCLMODE=DCLPRVMODE) AND ((RGSTATE MOD 16) IN [6,7,10,11]) AND (NEWSTATE IN [6,7,10,11]) THEN
71290           RGINFO := RGINFO+[DCLSAVEDESC];
71300         BRKASCR;
71310         IF RGSTATE>=16 THEN RGSTATE := NEWSTATE + 16 (*PRESERVE CODING *)
71320         ELSE               RGSTATE := NEWSTATE;
71330         RGINFO := RGINFO-[DCLSAVEDESC];
71340         END;
71350       PSCOUNT := PSCOUNT+LEN;
71360       TODOCOUNT := TODOCOUNT+LEN;
71370       DCLPRVMODE := DCLMODE;
71380       ALLOCIND := ALLOC(LEN);
71390       END;
71400     END;
71410 (**)
71420 (**)
71430 PROCEDURE DISALLOCIND;
71440   BEGIN
71450   (*INITIALISE STBLOCK *)
71460   WITH DCIL^,SRSTK[SRSEMP].SB^ DO
71470      BEGIN
71480      IF SBTYP IN [SBTPROC,SBTRPROC] THEN
71490         BEGIN
71500         STPTR:=SBXPTR;
71510         STLEVEL:=SBLEVEL;
71520         END
71530      ELSE
71540         STVALUE:=SBLEX;
71550      STDEFTYP:=STDEFTYP+[STCONST]-[STRCONST];
71560    (* UNDO PREVIOUS ALLOCIND *)
71570      PSCOUNT := PSCOUNT-SBLEN;
71580      TODOCOUNT := TODOCOUNT-SBLEN;
71590      CURID:=CURID-SBLEN;
71600      END;
71610    UNSTACKSB;
71620   END;
71630 (**)
71640 (**)
71650 PROCEDURE LOCRNGE;
71660 (*FUNCTION: TO MAKE THE CURRENT RANGE INTO A LOCAL RANGE*)
71670   VAR DUMMY: INTEGER;
71680     BEGIN
71690     IF NOT (DCLLOCRNG IN RGINFO) THEN
71700       WITH RANGEL^ DO
71710         BEGIN
71720         RGINFO := RGINFO+[DCLLOCRNG];  RGLEB:=CURLEB;
71730         IF DCLPARM IN RGINFO THEN
71740           CURLEB:=SIZIBBASE
71750         ELSE
71760           BEGIN
71770           CGFIXRG;
71780           CURLEB:=CURID;
71790           DUMMY := ALLOC(SIZLEBBASE);
71800           END;
71810         RGDEFN := DCLDEFN;
71820         RGMODE := DCLMODE;
71830         RGPRVMODE := DCLPRVMODE;
71840         RGTODOCOUNT := TODOCOUNT ;
71850         WITH ROUTNL^ DO RNLOCRG := RNLOCRG+1;
71860         IF DCLPARM IN RGINFO THEN
71870           BEGIN RGPSCOUNT := PSCOUNT; PSCOUNT := 0; END
71880         ELSE BEGIN
71890           IF DCLLOCGEN IN RGINFO THEN SEMERR(ESE+05);
71900           CGRGN;
71920           END;
71930         END
71940     END;
71950 (**)
71960 (**)
71970 PROCEDURE RANGENT;
71980 (*FUNCTION: CREATE RANGE BLOCK FOR NEW RANGE*)
71990   VAR R: PRANGE;
72000     BEGIN
72010     NEW(R);
72020     WITH R^ DO
72030       BEGIN
72040       RGLINK := RANGEL; RANGEL := R;
72050       RGINF := RGINFO; RGINFO := [];
72060       RGSTAT := RGSTATE;
72062       RGSTATE :=16;
72070       RGDCIL := DCIL; DCIL := NIL;
72080       RGLEV := RGLEV+1;
72082       IF RGLEV=2 THEN LOCRNGE;
72084         (*GLOBAL RANGE OF PROGRAM MUST ALWAYS BE LOCAL, BECAUSE STANDIN ETC. ARE EFFECTIVELY WITHIN IT*)
72090       RGRTSTACK := RTSTACK;
72100       END
72110     END;
72120 (**)
72130 (**)
72140 PROCEDURE INCROUTN(R: PROUTN; STB: PSTB);
72150 (*FUNCTION ADD ROUTN R TO ROUTNCHAIN STARTING AT STROUTN OF THE LABEL STB*)
72160   VAR PTR,TEMP: PROUTNCHAIN;
72170     BEGIN
72180       WITH R^ DO RNNONIC := RNNONIC+1;
72190       NEW(PTR);
72200       WITH PTR^ DO
72210         BEGIN LINK := NIL; DATA := R END;
72212       IF STB^.STROUTN=NIL THEN STB^.STROUTN := PTR
72214       ELSE
72216       BEGIN
72218         TEMP := STB^.STROUTN;
72220         WHILE TEMP^.LINK<>NIL DO
72222           TEMP:=TEMP^.LINK;
72224         TEMP^.LINK := PTR
72226       END
72228     END;
72230 (**)
72240 (**)
72250 PROCEDURE DECROUTN(R: PROUTN; MUSTFIX: BOOLEAN);
72260 (*FUNCTION: DISPOSE OF ROUTN, BUT ONLY AFTER ITS RNNONIC HAS REACHED ZERO*)
72270     BEGIN
72280     WITH R^ DO
72290       BEGIN RNNONIC := RNNONIC-1;
72300       IF RNNONIC<=0 THEN
72310         BEGIN
72320         IF MUSTFIX THEN CGRTE(R);
72330         DISPOSE(R)
72340         END
72350       END
72360     END;
72370 (**)
72380 (**)
72390 PROCEDURE ROUTNNT;
72400 (*FUNCTION: CREATE ROUTN BLOCK FOR NEW ROUTINE*)
72410   VAR R: PROUTN;
72420       DUMMY: INTEGER;
72430       IDLEX: PLEX;
72440     BEGIN
72450     NEW(R);
72460     WITH R^ DO
72470       BEGIN
72480         RNLEVEL := ROUTNL^.RNLEVEL+1; RNNECLEV := 0;
72490       RNLINK := ROUTNL; ROUTNL := R;
72500       RNLENSTK := 0; RNLENIDS := 0;
72510       RNLOCRG := 0; RNNECLOCRG := 0;
72520       RNSTKDEPTH := RTSTKDEPTH; RTSTKDEPTH := 0;
72530       RNRTSTACK := RTSTACK;
72540       RTSTACK := NIL;
72550       RNNONIC := 1;
72560       RNCURID := CURID; CURID := 0;
72570       RANGENT;
72580       RGINFO := RGINFO+[DCLPARM];
72590       LOCRNGE
72600       END
72610     END;
72620 (**)
72630 (**)
72640 PROCEDURE NECENV(STB: PSTB);
72650 (*FUNCTION: ADJUST THE NECESSARY ENVIRON OF THE CURRENT ROUTINES TO ALLOW FOR STB*)
72660   VAR R: PROUTN;
72670     BEGIN
72680     R := ROUTNL;
72690     WITH STB^ DO
72700       WHILE STLEVEL<R^.RNLEVEL DO WITH R^ DO
72710         BEGIN
72720         IF RNNECLEV<STLEVEL THEN
72730           BEGIN RNNECLEV := STLEVEL; RNNECLOCRG := STLOCRG END
72740         ELSE IF (RNNECLEV=STLEVEL) AND (RNNECLOCRG<STLOCRG) THEN
72750           RNNECLOCRG := STLOCRG;
72760         R := RNLINK;
72770         END
72780     END;
72790 (**)
72800 (**)
72810 PROCEDURE NECLAB(STB: PSTB);
72820 (*FUNCTION: ADJUST THE NECESSARY ENVIRONS OF ALL ROUTNS ON THE STROUTN CHAIN OF STB*)
72830   VAR PTR, PTR1: PROUTNCHAIN;
72840       SAVROUTN: PROUTN;
72850     BEGIN
72860     SAVROUTN := ROUTNL; PTR := STB^.STROUTN;
72870     WHILE PTR<>NIL DO
72880       BEGIN
72890       ROUTNL := PTR^.DATA;
72900       NECENV(STB);
72910       DECROUTN(ROUTNL, ROUTNL^.RNADDRESS<>0);
72920       PTR1 := PTR; PTR := PTR^.LINK; DISPOSE(PTR1)
72930       END;
72940     ROUTNL := SAVROUTN
72950     END;
72960 (**)
72970 (**)
72980 PROCEDURE RANGEXT;
72990 (*FUNCTION: DEALS WITH ALL STBLOCKS THREADED ON DCIL AND
73000     DISPOSES OF CURRENT RANGE
73010 *)
73020   VAR STB, CURDCL, T: PSTB;
73030       TRYPREVRANGE: BOOLEAN;
73040       R: PRANGE;
73050       PTR: PROUTNCHAIN;
73060       SB: PSB;
73070       SEMP: -1..SRSTKSIZE;
73080       FLADSET, FLADNEEDED, REDOJUMPS: BOOLEAN;
73082       DUMMY: LABL;
73090     BEGIN
73100     WITH RANGEL^ DO
73110       BEGIN
73120       IF BALFLAG THEN FLADNEEDED := FALSE
73130       ELSE  BEGIN (*YIELD OF RANGE IS ON RTSTACK*)
73140         FLADNEEDED := (RTSTACK^.SBMODE<>MDJUMP);
73150         SB := RTSTACK; UNSTACKSB; (*PRETEND WE ARE IN VOID CONTEXT OUTSIDE THE RANGE*)
73160         END;
73170       FLADSET := FALSE;
73180       STB := DCIL;
73190       WHILE STB<>NIL DO WITH STB^ DO
73200         BEGIN
73210         IF (STBLKTYP=STBDEFLAB) AND (STROUTN<>NIL) THEN (*LABEL WAS JUMPED TO OUT OF A ROUTINE*)
73220           BEGIN
73230           IF NOT FLADSET AND FLADNEEDED THEN BEGIN CGFLADJUMP; FLADSET := TRUE END;
73250           CGLABE(STB, ROUTNL^.RNLEVEL, CURLEB(*+41()+SIZLEBBASE()+41*)); (*GET OUT*)
73280           NECLAB(STB)
73290           END;
73300         STB := STTHREAD
73310         END;
73320       IF FLADSET THEN BEGIN ASSIGNFLAD; FLADSET := FALSE END;
73330     (*LOCRNGEXT - TO UNDO THE EFFECTS OF LOCRNGE*)
73340       IF DCLLOCRNG IN RGINFO THEN
73350         BEGIN
73380         IF DCLPARM IN RGINFO THEN PSCOUNT := RGPSCOUNT
73390         ELSE CGFIXRG;
73400         WITH ROUTNL^ DO RNLOCRG := RNLOCRG-1;
73410         IF DCLDELAY IN RGINFO THEN
73420           BEGIN
73430           IF BALFLAG THEN SEMP := SRSUBP+1 ELSE SEMP := SRSEMP;
73440           WHILE SEMP<=SRSEMP DO
73450             BEGIN
73460             WITH SRSTK[SEMP].SB^ DO
73462               BEGIN
73464               SBDELAYS :=SBDELAYS+1;
73466               IF DCLLOCGEN IN RGINFO THEN
73468                 SBINF := SBINF+[SBLOCGEN];
73470               IF DCLPILEDECS IN RGINFO THEN
73472                 SBINF := SBINF+[SBPILEDECS]
73476               END;
73478             SEMP := SEMP+1
73480             END
73490           END
73492         ELSE
73493           WITH SB^ DO BEGIN
73494             IF DCLLOCGEN IN RGINFO THEN
73496               SBINF := SBINF+[SBLOCGEN];
73498             IF DCLPILEDECS IN RGINFO THEN
73500               SBINF := SBINF+[SBPILEDECS];
73506             STACKSB(SB); CGRGXB(SB); UNSTACKSB
73508           END;
73510 (*-42() IF NOT FLADSET AND FLADNEEDED THEN BEGIN CGFLADJUMP; FLADSET := TRUE END; ()-42*)
73520 (*+42() IF DATASTATE=ENDDATA THEN DATASTATE := STARTDATA; ()+42*)
73530         CURID := CURLEB ; CURLEB := RGLEB;
73540         TODOCOUNT := RGTODOCOUNT;
73550         DCLDEFN := RGDEFN;
73560         DCLMODE := RGMODE;
73570         DCLPRVMODE := RGPRVMODE;
73580         END
73590       ELSE IF DCLLOCGEN IN RGINFO THEN
73600         RGINF := RGINF+[DCLLOCGEN];
73610       STB := DCIL;
73612       DUMMY := FIXUPM; (*TO FORCE ALIGNMENT OF RGIDBLK*)
73620       WHILE STB<>NIL DO WITH STB^ DO
73630         BEGIN
73640         IF STBLKTYP<=STBDEFOP THEN
73650           BEGIN (*DEFINING OCCURRENCE*)
73660           IF STLINK=NIL (*NO PREVIOUS INCARNATION*) THEN
73670             IF STBLKTYP=STBDEFMI THEN
73680               STLEX^.LXV := LXVTAB
73690             ELSE IF STBLKTYP=STBDEFPRIO THEN STLEX^.LXV := LXVTAB;
73700           IF DCLLOCRNG IN RGINFO THEN CGRGID(STB);
73710           END;
73720         STB := STTHREAD
73730         END;
73740       IF DCLLOCRNG IN RGINFO THEN IF DCLPARM IN RGINFO THEN ROUTNL^.RNIDBLK := FIXUPM ELSE FIXUPF(RGIDBLK);
73760       REDOJUMPS := ([DCLLOCRNG, DCLLOOP]*RGINFO<>[]) OR (RGLINK^.RGRTSTACK<>RTSTACK);
73770       RGLEV := RGLEV-1;
73780       R := RANGEL; RANGEL := RGLINK; (*CONSIDER OURSELVES TO BE OUTSIDE RANGE NOW*)
73790       STB := DCIL; CURDCL := RGDCIL;
73800       IF CURDCL=NIL THEN DCIL := NIL
73810       ELSE DCIL := CURDCL^.STTHREAD;  (*LEAVE THE FIRST BEAD ON THE THREAD FOR NOW*)
73820       WHILE STB<>NIL DO WITH STB^ DO
73830         BEGIN
73840         IF STBLKTYP>STBDEFOP THEN
73850           BEGIN (*APPLIED OCCURRENCE*)
73860           TRYPREVRANGE := STLINK=NIL;  (*IT WAS A LABEL NOT YET DEFINED*)
73870           IF NOT TRYPREVRANGE THEN
73880             TRYPREVRANGE := STLINK^.STRANGE<RGLEV;  (*IT WAS NOT SEEN IN PREVIOUS RANGE*)
73890           IF TRYPREVRANGE THEN
73900             BEGIN (*THREAD STB INTO PREVIOUS RANGE*)
73910             STRANGE := STRANGE-1;
73920             T := STTHREAD; STTHREAD := DCIL; DCIL := STB;
73930             END;
73940           IF STBLKTYP=STBAPPLAB THEN
73950             BEGIN
73960             IF REDOJUMPS THEN
73962               BEGIN
73964               IF STXPTR[0]<>0 THEN
73970                 BEGIN
73980                 IF NOT FLADSET AND FLADNEEDED THEN BEGIN CGFLADJUMP; FLADSET := TRUE END;
73990                 CGLABB(STB, 0); (*LABEL FOR EXISTING JUMP*)
74000                 IF (DCLLOCRNG IN RGINFO) THEN CGRGXA(DCLLOCGEN IN RGINFO); (*RANGE EXIT*)
74010                 IF DCLLOOP IN RGINFO THEN CGLPG;
74020                 IF TRYPREVRANGE THEN CGLABC(STB, ORD(DCLPARM IN RGINFO))
74030                 ELSE CGLABC(STB^.STLINK, ORD(DCLPARM IN RGINFO));
74040                 END
74041 (*-01() (*-02() (*FOR SYSTEMS WHICH CANNOT JUMP INTO OTHER ROUTINES - SEE ALSO CHANGES IN CGLABC*)
74042               ELSE IF (STXPTR[1]<>0) AND (DCLPARM IN RGINFO) THEN
74043                 BEGIN
74044                 CGLABB(STB, 1); (*LABEL FOR EXISTING JUMP*)
74045                 IF TRYPREVRANGE THEN CGLABC(STB, ORD(DCLPARM IN RGINFO))
74046                 ELSE CGLABC(STB^.STLINK, ORD(DCLPARM IN RGINFO));
74047                 END
74048 ()-02*) ()-01*)
74049               END;
74050             IF NOT TRYPREVRANGE THEN CGLABD(STB);
74060             IF DCLPARM IN RGINFO (*RANGE IS A ROUTINE*) THEN
74070               BEGIN
74080               INCROUTN(ROUTNL, STB);  (*ADD ROUTNL TO ITS STROUTN CHAIN*)
74090               STCURID := ROUTNL^.RNCURID
74100               END
74110             ELSE
74120               IF DCLLOCRNG IN RGINFO THEN STCURID := CURID; (*FOR CATCHING JUMPS OVER DECLARATIONS*)
74130             IF NOT TRYPREVRANGE THEN
74140               WITH STLINK^ (*OCCURRENCE IN PREVIOUS RANGE*) DO
74150                 IF STBLKTYP IN [STBDEFID,STBAPPID] THEN
74160                   SEMERRP(ESE+07, STLEX)
74170                 ELSE (*PRESENT STROUTN CHAIN TO PREVIOUS OCCURRENCE*)
74180                   IF STROUTN<>NIL THEN
74190                     BEGIN
74200                     PTR := STROUTN;
74210                     WHILE PTR^.LINK<>NIL DO PTR := PTR^.LINK;
74220                     PTR^.LINK := STB^.STROUTN;
74230                     END
74240                   ELSE STROUTN := STB^.STROUTN;
74250             END;
74260           END
74270         ELSE TRYPREVRANGE := FALSE;
74280         IF TRYPREVRANGE THEN STB := T
74290         ELSE
74300           BEGIN
74310         (*FREESTB*)
74320           STLEX^.LXV.LXPSTB := STLINK;
74330           T := STB; STB := STTHREAD;
74340           DISPOSE(T)
74350           END
74360         END;
74370       IF CURDCL<>NIL THEN
74380         BEGIN CURDCL^.STTHREAD := DCIL; DCIL := CURDCL END; (*DEAL WITH THAT FIRST BEAD*)
74390           (*DCIL IS NOW AS BEFORE THE RANGENT*)
74400       IF FLADSET THEN ASSIGNFLAD;
74410       IF NOT BALFLAG THEN STACKSB(SB); (*STOP PRETENDING*)
74420       RGINFO := RGINF; RGSTATE := RGSTAT;
74430       DISPOSE(R)
74440       END
74450     END;
74460 (**)
74470 (**)
74480 PROCEDURE ROUTNXT;
74490 (*FUNCTION: EXIT FROM ROUTINE. CALLS DECROUTN.*)
74500   VAR R: PROUTN;
74510     BEGIN
74520     WITH ROUTNL^ DO
74530       BEGIN
74540       RTSTACK := RNRTSTACK;
74550       RTSTKDEPTH := RNSTKDEPTH;
74560       CURID := RNCURID;
74570       R := ROUTNL; ROUTNL := RNLINK;
74580       DECROUTN(R, FALSE)
74590       END
74600     END;
74610 (**)
74620 (**)
74630 FUNCTION GETSTB(LEX: PLEX; DEF: DEFTYP; BLK: BLKTYP): PSTB;
74640 (*FUNCTION: CREATE A NEW STBLOCK FOR LEX*)
74650   VAR STB: PSTB;
74660     BEGIN
74670     NEW(STB); WITH STB^, LEX^.LXV, ROUTNL^ DO
74680       BEGIN
74690       STLINK := LXPSTB; LXPSTB := STB;
74700       STLEX := LEX;
74710       STTHREAD := DCIL; DCIL := STB;
74720       STDEFTYP := DEF; STBLKTYP := BLK;
74730       STRANGE := RGLEV;
74740       STLEVEL := RNLEVEL; STLOCRG := RNLOCRG;
74750       STMODE := NIL;
74760       GETSTB := STB
74770       END
74780     END;
74790 (**)
74800 (**)
74810 PROCEDURE FILLSTB(STB: PSTB);
74820 (*FUNCTION: SETS THE MODE AND OFFSET FIELDS OF THE STBLOCK STB*)
74830   CONST STDIDTY=STINIT;
74840     BEGIN WITH STB^ DO
74850       BEGIN
74860       STOFFSET := ALLOCIND(DCLMODE);
74870       IF DCLDEFN=[STDIDTY] THEN STMODE := DCLMODE
74880       ELSE STMODE := FINDREF(DCLMODE);
74890       END
74900     END;
74910 (**)
74920 (**)
74930 FUNCTION GETPRIO(LEX: PLEX): PSTB;
74940 (*FUNCTION: CREATE AND INITIALIZE A PRIORITY STBLOCK*)
74950   VAR STB,STB1: PSTB;
74960     BEGIN
74970     STB := GETSTB(LEX, [STCONST], STBDEFPRIO); WITH STB^, LEX^ DO
74980       BEGIN
74990       STSTDOP := 0; STUSERLEX := NIL;
75000       STB1 := LXV.LXPSTB; LXV := LXVOPR; LXV.LXPSTB := STB1;
75010       STDYPRIO := 11; (*FOR UNDECLARED OPS*)
75020       GETPRIO := STB
75030       END
75040     END;
75050 (**)
75060 (**)
75070 FUNCTION TESTSTB(LEX: PLEX): BLKTYP;
75080 (*FUNCTION: LOOKS FOR A DEFINITION OR APPLICATION IN THE CURRENT RANGE OF THE SYMBOL
75090     CORRESPONDING TO LEX. IF NONE IS FOUND, IT RETURNS STBNONE; IF ONE IS FOUND, IT RETURNS ITS BLKTYP
75100 *)
75110     BEGIN WITH LEX^.LXV DO
75120       IF LXPSTB=NIL THEN TESTSTB := STBNONE
75130       ELSE WITH LXPSTB^ DO
75140         IF STRANGE<>RGLEV THEN TESTSTB := STBNONE
75150         ELSE TESTSTB := STBLKTYP
75160     END;
75170 (**)
75180 (**)
75190 PROCEDURE NOLABELS;
75200 (*FUNCTION: COMPLAINS IF LABELS HAVE BEEN ENCOUNTERED IN THE CURRENT RANGE*)
75210     BEGIN
75220     IF DCLLABEL IN RGINFO THEN SEMERR(ESE+04)
75230     END;
75240 (**)
75250 (**)
75260 PROCEDURE DEFID(LEX: PLEX);
75270 (*FUNCTION: MAKE STBLOCK FOR DEFINING-IDENTIFIER*)
75280   VAR BLK: BLKTYP;
75290     BEGIN
75300     NOLABELS; LOCRNGE;
75310     BLK := TESTSTB(LEX);
75320     IF BLK=STBAPPID THEN SEMERRP(ESE+08, LEX);
75330     IF BLK<STBNONE THEN  (*STBDEFID OR STBDEF/APPLAB*)
75340       IF BLK=STBDEFID THEN SEMERRP(ESE+09, LEX)
75350       ELSE SEMERRP(ESE+15, LEX);
75360     FILLSTB(GETSTB(LEX, DCLDEFN, STBDEFID))
75370     END;
75380 (**)
75390 (**)
75400 (**)
75410 FUNCTION APPID(LEX: PLEX): PSTB;
75420 (*FUNCTION: CREATE STBLOCK FOR APPLIED-IDENTIFIER UNLESS ALREADY APPLIED IN CURRENT RANGE.
75430     RETURNS POINTER TO THE DEFINING OCCURRENCE
75440 *)
75450   VAR STB, NEWSTB: PSTB;
75460       BLK: BLKTYP;
75470     BEGIN
75480     STB := LEX^.LXV.LXPSTB;
75490     IF STB=NIL THEN
75500       BEGIN SEMERRP(ESE+16, LEX); STB := GETSTB(LEX, [STINIT], STBDEFID); STB^.STMODE := MDERROR END;
75510     WITH STB^ DO
75520       BEGIN
75530       BLK := STBLKTYP;
75540       IF BLK=STBAPPID THEN STB := STDEFPTR
75550       ELSE IF BLK<>STBDEFID THEN
75560         BEGIN SEMERRP(ESE+15, LEX); STB := GETSTB(LEXALEPH, [STINIT], STBDEFID); STB^.STMODE := MDERROR END;
75570       IF TESTSTB(LEX)=STBNONE (*NOT YET ENCOUNTERED IN CURRENT RANGE*) THEN
75580         BEGIN NEWSTB := GETSTB(LEX, [], STBAPPID); NEWSTB^.STDEFPTR := STB END;
75590       NECENV(STB)
75600       END;
75610     STB^.STDEFTYP:=STB^.STDEFTYP+[STUSED];
75620     APPID := STB
75630     END;
75640 (**)
75650 (**)
75660 PROCEDURE DEFLAB(LEX: PLEX);
75670 (*FUNCTION: MAKE STBLOCK FOR DEFINING-LABEL*)
75680   VAR STB: PSTB;
75690       BLK: BLKTYP;
75700     BEGIN
75710     RGINFO := RGINFO+[DCLLABEL];
75720     CGFIXRG;
75730     BLK := TESTSTB(LEX);
75740     IF BLK=STBAPPLAB THEN
75750       BEGIN
75760       STB := LEX^.LXV.LXPSTB; WITH STB^, ROUTNL^ DO
75770         BEGIN
75780         IF STCURID<CURID THEN SEMERRP(ESE+61, LEX);
75790         STDEFTYP := [STCONST]; STBLKTYP := STBDEFLAB;
75800         STLEVEL := RNLEVEL;
75810         CGLABB(STB, 0); CGLABA(STB) (*LABEL-DEFINITION WITH PREVIOUS APPLIED OCCURRENCES*)
75820         END
75830       END
75840     ELSE IF BLK=STBNONE THEN
75850       BEGIN
75860       STB := GETSTB(LEX, [STCONST], STBDEFLAB); WITH STB^ DO
75870         BEGIN STXPTR[1] := 0; STROUTN := NIL END;
75880       CGLABA(STB) (*LABEL-DEFINITION WITH NO PREVIOUS APPLIED OCCURRENCE*)
75890       END
75900     ELSE IF BLK=STBDEFLAB THEN SEMERRP(ESE+13, LEX)
75910     ELSE SEMERRP(ESE+07, LEX);
75920     WITH STB^, ROUTNL^ DO
75930       IF DCLLOCRNG IN RGINFO THEN STLOCRG := RNLOCRG
75940       ELSE STLOCRG := RNLOCRG+1;
75950     END;
75960 (**)
75970 (**)
75980 FUNCTION APPLAB(LEX: PLEX): PSTB;
75990 (*FUNCTION: CREATE STBLOCK FOR APPLIED-LABEL IF NO DEFINING OCCURRENCE YET EXISTS.
76000     RETURNS POINTER TO MOST RECENT OCCURRENCE (APPLIED OR DEFINING).
76010 *)
76020   VAR STB: PSTB;
76030       BLK: BLKTYP;
76040     BEGIN
76050     BLK := TESTSTB(LEX);
76060     IF BLK<>STBNONE THEN
76070       BEGIN
76080       STB := LEX^.LXV.LXPSTB;
76090       IF (BLK<>STBDEFLAB) AND (BLK<>STBAPPLAB) THEN SEMERRP(ESE+07, LEX)
76100       END
76110     ELSE
76120       BEGIN
76130       STB := GETSTB(LEX, [], STBAPPLAB); WITH STB^ DO
76140         BEGIN
76150         STCURID := CURID;
76160         STXPTR[0] := 0; STXPTR[1] := 0; STROUTN := NIL;
76170         END
76180      END;
76190     CGLABC(STB, 0);
76200     APPLAB := STB
76210     END;
76220 (**)
76230 (**)
76240 PROCEDURE DEFMI(LEX: PLEX);
76250 (*FUNCTION: MAKE STBLOCK FOR DEFINING-MODE-INDICATION*)
76260   VAR STB: PSTB;
76270       BLK: BLKTYP;
76280     BEGIN
76290     NOLABELS; LOCRNGE;
76300     BLK := TESTSTB(LEX);
76310     IF BLK=STBAPPMI THEN SEMERRP(ESE+12, LEX);
76320     IF BLK<STBNONE THEN SEMERRP(ESE+11, LEX)
76330     ELSE BEGIN
76340       LEX^.LXV := LXVMDIND;
76350       STB := GETSTB(LEX, [STINIT (*FOR STDIDTY*) (* , STDNONREC*)], STBDEFMI); STB^.STMODE := NIL;
76360       STB^.STOFFSET := 0
76370       END
76380     END;
76390 (**)
76400 (**)
76410 FUNCTION APPMI(LEX: PLEX): PSTB;
76420 (*FUNCTION: CREATE STBLOCK FOR APPLIED-MODE-INDICATION UNLESS ALREADY APPLIED IN CURRENT RANGE.
76430     RETURNS POINTER TO THE DEFINING OCCURRENCE.
76440 *)
76450   VAR STB, NEWSTB: PSTB;
76460       I: INTEGER; LXIO: LXIOTYPE; SAFE: SET OF (YIN, YANG);
76470     BEGIN
76480     STB := LEX^.LXV.LXPSTB;
76490     IF STB=NIL THEN BEGIN DEFMI(LEX); STB := LEX^.LXV.LXPSTB; STB^.STMODE := MDERROR; SEMERRP(ESE+46, LEX) END;
76500     WITH STB^ DO IF STBLKTYP=STBAPPMI THEN STB := STDEFPTR;
76510     IF TESTSTB(LEX)=STBNONE THEN WITH STB^ DO
76520       BEGIN
76530       IF STMODE=NIL THEN
76540         BEGIN SEMERRP(ESE+46, LEX); STMODE := MDERROR END;
76550       NEWSTB := GETSTB(LEX, [], STBAPPMI);
76560       NEWSTB^.STDEFPTR := STB
76570       END
76580     ELSE WITH STB^ DO
76590       IF STMODE=NIL THEN
76600         BEGIN
76610         STDEFTYP := [STINIT (*FOR STDIDTY*), STRECUR];
76620       (*WELLFORMED*)
76630         SAFE := []; I := PLSTKP+1;
76640         WHILE (SAFE<>[YIN, YANG]) AND (I<SRPLSTKSIZE) DO WITH SRPLSTK[I]^.LXV DO
76650           BEGIN
76660           IF (LXIO=LXIOREF) OR (LXIO=LXIOPROC) THEN
76670             SAFE := SAFE+[YIN]
76680           ELSE IF (LXIO=LXIOOPEN) OR (LXIO=LXIOSTRUCT) THEN
76690             SAFE := SAFE+[YANG]
76700           ELSE IF LXIO=LXIOMDIND THEN
76710             BEGIN SEMERR(ESE+03); SAFE := [YIN, YANG] END;
76720           I := I+1
76730           END;
76740         END;
76750     APPMI := STB
76760     END;
76770 (**)
76780 (**)
76790 PROCEDURE DEFPRIO(LEX, PRIO: PLEX);
76800 (*FUNCTION: MAKE STBLOCK FOR PRIORITY-DEFINITION*)
76810   VAR STB, OLDSTB: PSTB;
76820     BEGIN
76830     NOLABELS;
76840     OLDSTB := LEX^.LXV.LXPSTB;
76850     IF OLDSTB<>NIL THEN
76860       IF OLDSTB^.STDYPRIO<>10 THEN SEMERRP(ESE+42, LEX);
76870     WITH PRIO^ DO
76880       IF (LXDENMD<>MDINT) OR (LXDENRP<=0) OR (LXDENRP>9) THEN SEMERR(ESE+41)
76890       ELSE
76900         BEGIN
76910         STB := GETPRIO(LEX); WITH STB^ DO
76920           BEGIN
76930           IF OLDSTB<>NIL THEN
76940             BEGIN STSTDOP := OLDSTB^.STSTDOP; STUSERLEX := OLDSTB^.STUSERLEX END;
76950           STDYPRIO := (*-04() LXDENRP ()-04*)(*+04() SHRINK(LXDENRP) ()+04*)
76960           END
76970         END
76980     END;
76990 (**)
77000 (**)
77010 PROCEDURE DEFOP(LEX: PLEX);
77020 (*FUNCTION: MAKE STBLOCK FOR USER OPERATION-DEFINITION*)
77030   VAR STB: PSTB;
77040       LX: PLEX;
77050     BEGIN
77060     NOLABELS; LOCRNGE;
77070     WITH LEX^.LXV DO
77080       IF LXPSTB=NIL THEN (*NO PRIORITY-DEFINITION EXISTS*)
77090         BEGIN STB := GETPRIO(LEX); STB^.STDYPRIO := 10 (*FOR MONADICS*) END
77100       ELSE STB := LXPSTB;
77110     WITH STB^ DO
77120       BEGIN
77130       IF STUSERLEX=NIL THEN (*NO PREVIOUS OPERATION-DEFINITION*)
77140         BEGIN
77150         ENEW(LX, LEX1SIZE); STUSERLEX := LX; (*CREATE DUMMY LEXEME*)
77160         STUSERLEX^.LXV := LXVOPR; STUSERLEX^.LINK := LEX;
77170         END;
77180       FILLSTB(GETSTB(STUSERLEX, [STINIT](*FOR STDIDTY*), STBDEFOP))
77190       END
77200     END;
77210 (**)
77220 (**)
77230 FUNCTION APPOP(STB: PSTB): PSTB;
77240 (*FUNCTION: HANDLE APPLIED-OPERATOR; NO NEED TO CREATE AN APPLIED STBLOCK IN THE SUBLANGUAGE*)
77250     BEGIN
77260     NECENV(STB);
77270     STB^.STDEFTYP := STB^.STDEFTYP + [STUSED] ;
77280     APPOP := STB
77290     END;
77300 (**)
77310 (**)
77320 PROCEDURE PUTDEN(LEX: PLEX);
77330 (*FUNCTION: CREATES A SEMANTIC BLOCK FOR A DENOTATION*)
77340   VAR SB: PSB;
77350     BEGIN WITH LEX^  DO
77360       BEGIN
77370       IF LXV.LXIO=LXIOBOOLDEN THEN SB := PUSHSB(MDBOOL)
77380       ELSE SB := PUSHSB(LXDENMD);
77390       WITH SB^ DO
77400         BEGIN
77410         SBLEX := LEX;
77420         SBINF := [SBMORF,SBVOIDWARN]; SBTYP := SBTDEN
77430         END
77440       END
77450     END;
77460 (**)
77470 (**)
77480 PROCEDURE PUTIND(STB: PSTB);
77490 (*FUNCTION: CREATES A SEMANTIC BLOCK FOR AN APPLIED-INDICATOR*)
77500   VAR SB: PSB;
77510     BEGIN
77520     WITH STB^ DO
77530       BEGIN
77540       IF STBLKTYP<>STBDEFMI THEN
77550         SB := PUSHSB(STMODE)
77560       ELSE IF STMODE^.MDV.MDID=MDIDROW THEN
77570         SB := PUSHSB(PRCBNDS)
77580       ELSE SB := PUSHSB(MDABSENT);
77590       WITH SB^ DO
77600         BEGIN
77610         IF NOT (STCONST IN STDEFTYP) THEN
77620            BEGIN SBLEVEL := STLEVEL; SBOFFSET := STOFFSET; SBLOCRG := STLOCRG ;
77630            IF NOT (STVAR IN STDEFTYP) THEN
77640               SBTYP := SBTID
77650            ELSE WITH SBMODE^.MDPRRMD^ DO
77660               IF (MDV.MDID=MDIDSTRUCT) OR (MDV.MDID=MDIDROW) THEN
77670                  SBTYP := SBTIDV
77680               ELSE SBTYP := SBTVAR;
77690            END
77700         ELSE
77710            IF (STMODE^.MDV.MDID=MDIDPROC) OR (STBLKTYP=STBDEFMI) THEN
77720               BEGIN
77730               IF STRCONST IN STDEFTYP THEN SBTYP := SBTRPROC
77740               ELSE  SBTYP:=SBTPROC;
77750               SBLEVEL:=STLEVEL;
77760               SBOFFSET:=0;
77770               SBXPTR:=STPTR;
77780               END
77790            ELSE
77800               BEGIN
77810               SBLEX:=STVALUE;
77820               SBTYP := SBTDEN;
77830               END;
77840         SBINF := [SBMORF,SBVOIDWARN];
77850         END
77860       END
77870     END;
77880 (**)
77890 (**)
77900 PROCEDURE PUTLOOP(LEX: PLEX);
77910 (*FUNCTION: CREATES A SEMANTIC BLOCK FOR A LOOP*)
77920   VAR SB: PSB;
77930     BEGIN
77940     SB := MAKESUBSTACK(0, MDINT);
77950     SB^.SBLEX := LEX;
77960     END;
77970 (**)
77980 (**)
77990 (**)
78000 PROCEDURE ELABMI(LEX: PLEX);
78010 (*FUNCTION: ELABORATE MODE-INDICATION*)
78020   VAR STB: PSTB;
78030     BEGIN WITH LEX^ DO
78040       BEGIN
78050       STB := LXV.LXPSTB;
78060       WITH STB^ DO IF STBLKTYP=STBAPPMI THEN STB := STDEFPTR;
78070       NECENV(STB);
78080       PUTIND(STB);
78090       WITH SRSTK[SRSEMP] DO BEGIN CGDEPROC(SB); SB^.SBMODE:=MDBNDS END;
78100       SRSEMP := SRSEMP+1; SRSTK[SRSEMP].MD := STB^.STMODE
78110       END
78120     END;
78130 (**)
78140 (**)
78150 PROCEDURE PARMSC;
78160 (*FUNCTION: PUT MODE OF NEXT ACTUAL-PARAMETER ONTO SCCHAIN*)
78170   VAR SB: PSB;
78180     BEGIN
78190     SB := SRSTK[SRSUBP+1].SB;
78200     WITH SB^ DO
78210       WITH SBMODE^ DO
78220         BEGIN
78230         IF SBCNT>=MDV.MDCNT THEN
78240           BEGIN
78250           SCPUSH(MDERROR);
78260           IF SBCNT=MDV.MDCNT THEN MODERR(SBMODE, ESE+30);
78270           END
78280         ELSE SCPUSH(MDPRCPRMS[SBCNT]);
78290         SBCNT := SBCNT+1
78300         END
78310     END;
78320 (**)
78330 (**)
78340 PROCEDURE OPDSAVE(M: MODE);
78350 (*FUNCTION: SAVES MODE OF OPERAND AND BALFLAG ON SRSTACK*)
78360   VAR SB: PSB;
78370     BEGIN
78380     SB := PUSHSB(M); WITH SB^ DO
78390       BEGIN
78400       RTSTACK := SBRTSTK;
78410       IF BALFLAG THEN SBBALSTR := BALSTR
78420       ELSE SBBALSTR := STRNONE;
78430       BALFLAG := FALSE
78440       END
78450     END;
78460 (**)
78470 (**)
78480 FUNCTION OPDREST: MODE;
78490 (*FUNCTION: RESTORES MODE AND BALFLAG FROM SRSTACK*)
78500   VAR SB: PSB;
78510     BEGIN
78520     SB := SRSTK[SRSEMP].SB; SRSEMP := SRSEMP-1; WITH SB^ DO
78530       BEGIN OPDREST := SBMODE; BALFLAG := SBBALSTR<>STRNONE; DISPOSE(SB) END
78540     END;
78550 (**)
78560 (**)
78570 PROCEDURE BALOPR;
78580 (*FUNCTION: PERFORMS COERCION OF OPERANDS*)
78590   VAR SBLH,SBRH: PSB;
78600       LHM,M: MODE;
78610     BEGIN
78620     M := COERCE(OPDREST); (*COERCE RH OPERAND*)
78630     IF LHFIRM=MDABSENT THEN (*MONADIC OPERATOR*)
78640       CGOPDA (*TOTAL RH OPERAND*)
78650     ELSE (*DYADIC OPERATOR*)
78660       BEGIN
78670       IF SRSTK[SRSEMP-1].SB^.SBBALSTR<>STRNONE THEN (*LH OPERAND WAS BALANCED OR DELAYED*)
78680         BEGIN
78690         (*CONTENTS OF SRSTK:
78700             RH OPERAND (COERCED AND TOTALLED); = RTSTACK.
78710             LOCUM TENENS REPRESENTING LH OPERAND AFTER COERCION AND AFTER RH CODE; ON RTSTACK.
78720             SUBSTACK CONTAINING CONSTITUENTS (MAYBE ONLY 1) OF LH BALANCE
78730         *)
78740         CGOPDD; (*JUMP OVER LH COERCION*)
78750         UNSTACKSB; SBRH := SRSTK[SRSEMP].SB; SRSEMP := SRSEMP-1; (*FORGET RH RESULTS TEMPORARILY*)
78760         LHM := OPDREST; (*BALFLAG IS NOW SET*)
78770         UNSTACKSB; SBLH := SRSTK[SRSEMP].SB; SRSEMP := SRSEMP-1; (*FORGET LOCUM TENENS*)
78780         M := COERCE(COFIRM(SRSTK[SRSEMP].SB^.SBMODE, LHM)); (*COERCE LH BALANCE FIRMLY*)
78790         CGOPDE(SBLH); (*JUMP BACK TO RH CODE; SET LABEL FOR RH EXIT*)
78800         DISPOSE(SBLH);
78810         STACKSB(SBRH);
78820         M := COERCE(LHM); (*WIDEN RESULT OF LH BALANCE, IF REQUIRED*)
78830         SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SB := SBRH; (*REMEMBER RH RESULTS AGAIN*)
78840         END
78850       ELSE
78860         BEGIN
78870         CGOPDA; (*TOTAL RH OPERAND*)
78880         SBRH := SRSTK[SRSEMP].SB; SRSEMP := SRSEMP-1;
78890         M := COERCE(OPDREST); (*COERCE LH OPERAND*)
78900         SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SB := SBRH
78910         END;
78920       END;
78930     END;
78940 (**)
78950 (**)
78960 (*
78970             LHOPBAL                                BALOPR
78980            1------!           !--------------------------------------------!
78990              CGOPDC                    CGOPDD                CGOPDE
79000               !--!                     !----!                !----!
79010              --------------->---------------
79020              !                             !
79030              !                          ---+---------->-----------
79040              !                          !  !                     !
79050   COMPUTE LH--  ->COMPUTE RH  COERCE RH--  ->FIRMLY COERCE LH--  ->WIDEN LH  CGOPR/CGOPAB
79060                 !                                             !
79070                 ------------------------<----------------------
79080 *)
79090 (**)
79100 (**)
79110 PROCEDURE LHOPBAL(M: MODE);
79120 (*FOR LH OPERAND WHICH IS BALANCED OR DELAYED*)
79130   VAR SB: PSB;
79140     BEGIN
79150     IF NOT BALFLAG THEN
79160       BEGIN
79170       SB := SRSTK[SRSEMP].SB; SRSEMP := SRSEMP-1; SUBSAVE; SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SB := SB;
79180       CGIBAL; BALFLAG := TRUE
79190       END;
79200     SB := PUSHSB(M); (*PUT LOCUM TENENS; M HAS THE LARGEST POSSIBLE LEN (BAR WIDENING) FOR THE LH MODE*)
79210     CGOPDC (*LABEL FOR START OF RH CODE; PUSHES LOCUM TENENS TO REPRESENT LH DURING RH CODE*)
79220     END;
79230 (**)
79240 (**)
79250 PROCEDURE PUTMD(LHM,RHM: MODE);
79260 (*FUNCTION: SETS A POSTERIORI MODES OF OPERANDS*)
79270     BEGIN
79280     SRSTK[SRSEMP].SB^.SBMODE := RHM;
79290     IF LHFIRM<>MDABSENT THEN (*NOT MONADIC OPERATOR*)
79300       IF SRSTK[SRSEMP].SB^.SBBALSTR<>STRNONE THEN
79310         SRSTK[SRSUBP-1].SB^.SBMODE := LHM
79320       ELSE SRSTK[SRSEMP-2].SB^.SBMODE := LHM
79330     END;
79340 (**)
79350 (**)
79360 FUNCTION OPIDSTD(STB: PSTB): BOOLEAN;
79370 (*FUNCTION: RETURNS TRUE IF OPERATOR STB CAN BE IDENTIFIED AS A STANDARD OPERATOR*)
79380   VAR FOUND: BOOLEAN;
79390       LHX, RHX: XTYPE;
79400     BEGIN OPBLK := STB^.STSTDOP-1;
79410     IF OPBLK<0 THEN OPIDSTD := FALSE
79420     ELSE
79430       BEGIN
79440       REPEAT OPBLK := OPBLK+1; WITH OPTABL[OPBLK] DO
79450         BEGIN
79460         CASE OPIDNDX OF
79470           IDAA:  (*REQUIRES L AND R WITHIN GIVEN RANGE*)
79480             BEGIN LHX := TX(LHFIRM); RHX := TX(RHFIRM);
79490             IF LHX>RHX THEN COMMX := LHX ELSE COMMX := RHX;
79500             FOUND := (LHX>=OPMIN) AND (RHX>=OPMIN) AND (LHX<=OPMAX) AND (RHX<=OPMAX)
79510 (*+61()       AND ((COMMX>XLCOMPL) OR (ODD(LHX)=ODD(RHX))) ()+61*)  (*SAME LENGTH*)
79520             END;
79530           IDAAL:  (*REQUIRES L AND R WITHIN GIVEN RANGE*)
79540             BEGIN LHX := TX(LHFIRM); RHX := TX(RHFIRM);
79550 (*-61()     COMMX := OPMAX-1; ()-61*)
79560 (*+61()     IF ODD(LHX) THEN COMMX := OPMAX ELSE COMMX := OPMAX-1; ()+61*)
79570             FOUND := (LHX>=OPMIN) AND (RHX>=OPMIN) AND (LHX<=OPMAX) AND (RHX<=OPMAX)
79572 (*+61()       AND ((COMMX>XLCOMPL) OR (ODD(LHX)=ODD(RHX))) ()+61*)  (*SAME LENGTH*)
79580             END;
79590           IDRA:  (*REQUIRES L WITHIN L AND R <= GIVEN RANGE*)
79600             BEGIN LHX := TX(LHFIRM); RHX := TX(RHFIRM);
79610             COMMX := LHX;
79620             FOUND := (LHX>=OPMIN) AND (LHX<=OPMAX) AND (LHX>=RHX)
79630           (*      AND (ODD(LHX)=ODD(RHX)) *)  (*SAME LENGTH*)
79640             END;
79650           IDBB:  (*REQUIRES L AND R WITHIN GIVEN RANGE, AND L=R*)
79660             BEGIN LHX := TX(LHFIRM); RHX := TX(RHFIRM);
79670             COMMX := LHX;
79680             FOUND := (LHX=RHX) AND (COMMX>=OPMIN) AND (COMMX<=OPMAX)
79690             END;
79700           IDBI,IDSI:  (*REQUIRES L WITHIN RANGE ANDR=INT*)
79710             BEGIN COMMX := TX(LHFIRM);
79720             FOUND := (RHFIRM=MDINT) AND (COMMX>=OPMIN) AND (COMMX<=OPMAX)
79730             END;
79740           IDIB:  (*REQUIRES L=INT AND R WITHIN RANGE*)
79750             BEGIN COMMX := TX(RHFIRM);
79760             FOUND := (LHFIRM=MDINT) AND (COMMX>=OPMIN) AND (COMMX<=OPMAX)
79770             END;
79780           IDSC:  (*REQUIRES L=STRNG AND R WITHIN RANGE*)
79790             BEGIN COMMX := TX(RHFIRM);
79800             FOUND := (LHFIRM=MDSTRNG) AND (COMMX>=OPMIN) AND (COMMX<=OPMAX)
79810             END;
79820           IDCS:  (*REQUIRES L WITHIN RANGE AND R=STRNG*)
79830             BEGIN COMMX := TX(LHFIRM);
79840             FOUND := (RHFIRM=MDSTRNG) AND (COMMX>=OPMIN) AND (COMMX<=OPMAX)
79850             END;
79860           IDMON,IDMONL:  (*MONADIC OPERATORS*)
79870             BEGIN COMMX := TX(RHFIRM);
79880             FOUND := (LHFIRM=MDABSENT) AND (COMMX>=OPMIN) AND (COMMX<=OPMAX)
79890             END;
79900           IDIBR, IDIBRM:  (*.LWB AND .UPB*)
79910             BEGIN LHX := TX(LHFIRM); COMMX := LHX;
79920             FOUND := ((RHFIRM^.MDV.MDID=MDIDROW) OR (RHFIRM=MDROWS))
79930                  AND (LHX>=OPMIN) AND (LHX<=OPMAX)
79940                  AND ((LHX<>-1) OR (LHFIRM=MDABSENT))
79950             END;
79960           END;
79970         END;
79980       UNTIL FOUND OR (NOT OPTABL[OPBLK].OPMORE);
79990       OPIDSTD := FOUND
80000       END
80010     END;
80020 (**)
80030 (**)
80040 PROCEDURE OPDOSTD;
80050 (*FUNCTION: GENERATES CODE FOR APPLICATION OF STANDARD OPERATOR*)
80060   VAR RESMODE: MODE;
80070       LENGS: INTEGER;
80080     BEGIN WITH OPTABL[OPBLK] DO
80090       BEGIN
80100       CASE OPIDNDX OF
80110         IDAA:
80120           BEGIN RESMODE := XMODES[COMMX];
80130           PUTMD(RESMODE, RESMODE);
80140           IF OPMODE<>MDABSENT THEN RESMODE := OPMODE
80150           END;
80160         IDAAL:
80170           BEGIN
80180 (*+61()   IF ODD(COMMX) THEN LENGS := 1 ELSE LENGS := 0; ()+61*)
80190           RESMODE := XMODES[COMMX];
80200           PUTMD(RESMODE, RESMODE);
80210           RESMODE := (*-61() OPMODE ()-61*)(*+61() LENGTHEN(OPMODE, LENGS) ()+61*);
80220           END;
80230         IDRA:
80240           BEGIN RESMODE := FINDREF(XMODES[COMMX]);
80250           PUTMD(RESMODE, XMODES[COMMX])
80260           END;
80270         IDBI:
80280           BEGIN IF OPMODE=MDABSENT THEN RESMODE := XMODES[COMMX] ELSE RESMODE := OPMODE;
80290           PUTMD(XMODES[COMMX], MDINT)
80300           END;
80310         IDBB,IDIB:
80320           BEGIN IF OPMODE=MDABSENT THEN RESMODE := XMODES[COMMX] ELSE RESMODE := OPMODE;
80330           PUTMD(LHFIRM, RHFIRM)
80340           END;
80350         IDSI:
80360           BEGIN RESMODE := OPMODE;
80370           PUTMD(REFSTRNG, RHFIRM)
80380           END;
80390         IDSC:
80400           BEGIN RESMODE := OPMODE;
80410           PUTMD(REFSTRNG, MDSTRNG)
80420           END;
80430         IDCS:
80440           BEGIN RESMODE := OPMODE;
80450           PUTMD(MDSTRNG, REFSTRNG)
80460           END;
80470         IDMON:
80480           BEGIN IF OPMODE=MDABSENT THEN RESMODE := XMODES[COMMX] ELSE RESMODE := OPMODE;
80490           PUTMD(NIL, RHFIRM)
80500           END;
80510         IDMONL:
80520           BEGIN IF ODD(COMMX) THEN LENGS := 1 ELSE LENGS := 0;
80530           RESMODE := LENGTHEN(OPMODE, LENGS);
80540           PUTMD(NIL, RHFIRM)
80550           END;
80560         IDIBR, IDIBRM:
80570           BEGIN RESMODE := OPMODE;
80580           PUTMD(LHFIRM, MDROWS)
80590           END;
80600         END;
80610       BALOPR;
80620       IF (OPIDNDX=IDRA) AND NOT(COMMX IN [XCOMPL,XLCOMPL]) (*NOT COMPLEX*) THEN
80630         CGOPAB(OPOPCOD-COMMX+OPMIN, RESMODE)
80640       ELSE CGOPR(OPOPCOD-COMMX+OPMIN, RESMODE, OPIDNDX>IDMONL);
80650       IF OPIDNDX>IDMONL THEN (*DYADIC*)
80660         BEGIN DISPOSE(SRSTK[SRSEMP].SB); SRSEMP := SRSEMP-1 END;
80670       WITH SRSTK[SRSEMP].SB^ DO
80680         IF OPIDNDX IN [IDRA,IDSI,IDCS,IDSC] THEN SBINF := SBINF+[SBMORF]-[SBVOIDWARN]
80690         ELSE SBINF := SBINF+[SBMORF,SBVOIDWARN];
80700       END
80710     END;
80720 (**)
80730 (**)
80740 (**)
80750 FUNCTION OPIDUSER(STB: PSTB): BOOLEAN;
80760 (*FUNCTION: RETURNS TRUE IF OPERATOR STB CAN BE IDENTIFIED AS A USER OPERATOR*)
80770   LABEL 9;
80780   VAR PROCM: MODE;
80790     BEGIN WHILE STB<>NIL DO
80800       BEGIN
80810       PROCM := STB^.STMODE; GETOPDM(PROCM);
80820       IF (LHFIRM=COFIRM(LHMODE,NIL)) AND (RHFIRM=COFIRM(RHMODE,NIL)) THEN
80830         BEGIN OPCOD := APPOP(STB); OPIDUSER := TRUE; GOTO 9 END;
80840       STB := STB^.STLINK
80850       END;
80860     OPIDUSER := FALSE;
80870  9: END;
80880 (**)
80890 (**)
80900 (**)
80910 (**)
80920 PROCEDURE OPDOUSER;
80930 (*FUNCTION: GENERATES CODE FOR APPLICATION OF USER-DEFINED OPERATOR*)
80940   VAR SB:PSB;
80942       ADIC: 1..2;
80944 (*+05() OFFST, I: INTEGER; ()+05*)
80950     BEGIN
80952     ADIC := 1+ORD(LHFIRM<>MDABSENT);
80960     PUTMD(LHMODE, RHMODE);
80970     BALOPR;
80972     SB := MAKESUBSTACK(ADIC, OPCOD^.STMODE^.MDPRRMD);
80974 (*+05()
80975     OFFST := 0;
80976     FOR I := 0 TO ADIC-1 DO WITH OPCOD^.STMODE^.MDPRCPRMS[I]^ DO
80978       IF MDV.MDPILE THEN OFFST := OFFST+SZADDR ELSE OFFST := OFFST+MDV.MDLEN;
80979     CLEAR(RTSTACK);
80980     ADJUSTSP := 0; HOIST(SUBSTLEN([SBTSTK..SBTDL]), OFFST, FALSE);
80981     IF ADJUSTSP<>0 THEN
80982       BEGIN
80983       FOR I := 0 TO ADIC-1 DO
80984         BEGIN SRSTK[SRSEMP+1-I] := SRSTK[SRSEMP-I]; UNSTACKSB END;
80985       SRSEMP := SRSEMP-ADIC; FILL(SBTSTK, PUSHSB(MDINT));
80986       SRSEMP := SRSEMP+ADIC;
80987       FOR I := ADIC-1 DOWNTO 0 DO STACKSB(SRSTK[SRSEMP-I].SB);
80988       END;
80989 ()+05*)
80990     PUTIND(OPCOD); CGOPCALL; POPUNITS;
81000     WITH SB^ DO SBINF := SBINF+[SBMORF]-[SBVOIDWARN];
81010     END;
81020 (**)
81030 (**)
81040 PROCEDURE OPIDENT(MONADIC: BOOLEAN);
81050 (*FUNCTION: IDENTIFIES APPLIED-OPERATOR AND ELABORATES FORMULA*)
81060   LABEL 9;
81070   VAR STB: PSTB;
81080       LEX: PLEX;
81090     BEGIN
81100     RHFIRM := SRSTK[SRSEMP].SB^.SBMODE;
81110     IF MONADIC THEN LHFIRM := MDABSENT
81120     ELSE IF SRSTK[SRSEMP].SB^.SBBALSTR<>STRNONE THEN
81130       LHFIRM := SRSTK[SRSUBP-1].SB^.SBMODE
81140     ELSE
81150       LHFIRM := SRSTK[SRSEMP-2].SB^.SBMODE;
81160     LEX := SRPLSTK[PLSTKP+1];
81170     STB := LEX^.LXV.LXPSTB;
81180     IF STB=NIL THEN STB := GETPRIO(LEX);
81190     IF OPIDSTD(STB) THEN OPDOSTD
81200     ELSE WITH STB^ DO
81210       BEGIN
81220         IF STUSERLEX<>NIL THEN
81230           IF OPIDUSER(STUSERLEX^.LXV.LXPSTB) THEN GOTO 9;
81240         IF MONADIC THEN
81250           BEGIN IF RHFIRM<>MDERROR THEN SEMERRP(ESE+23, LEX); OPCOD := MONADUMMY END
81260         ELSE
81270           BEGIN IF (LHFIRM<>MDERROR) AND (RHFIRM<>MDERROR) THEN SEMERRP(ESE+24, LEX); OPCOD := DYADUMMY END;
81280         GETOPDM(OPCOD^.STMODE);
81290    9: OPDOUSER
81300       END;
81310     END;
81320 (**)
81330 (**)
81340 PROCEDURE DEFOPM(OP: PSTB; M: MODE);
81350 (*FUNCTION: PROVIDES MODE FOR STBLOCK CREATED IN DEFOP*)
81360   VAR PRIO: PSTB;
81370     BEGIN
81380     WITH M^ DO IF (MDV.MDCNT<=0) OR (MDV.MDCNT>2) THEN
81390       BEGIN SEMERR(ESE+54); M := MONADUMMY^.STMODE END;
81400     GETOPDM(M);
81410     LHFIRM := COFIRM(LHMODE,NIL); RHFIRM := COFIRM(RHMODE,NIL);
81420     PRIO := OP^.STLEX^.LINK^.LXV.LXPSTB;
81430     IF (LHFIRM<>MDABSENT) AND (PRIO^.STDYPRIO=0) THEN SEMERR(ESE+55);
81440     OP^.STMODE := M;
81450     IF OPIDSTD(PRIO) OR OPIDUSER(OP^.STLINK) THEN SEMERR(ESE+56)
81460     END;
81470 (**)
81480 (**)
81490 PROCEDURE COLLSC(SB: PSB);
81500 (*PUTS MODE OF NEXT UNIT OF DISPLAY ON SC CHAIN*)
81510     BEGIN
81520     WITH SB^ DO WITH SBMODE^ DO
81530       BEGIN
81540       IF MDV.MDID=MDIDROW THEN
81550         SCPUSH(FINDROW(MDPRRMD, MDV.MDCNT-1))
81560       ELSE IF MDV.MDID=MDIDSTRUCT THEN
81570         BEGIN
81580         IF SBLEVEL>=MDV.MDCNT THEN
81590           BEGIN SEMERR(ESE+59); SCPUSH(MDERROR) END
81600         ELSE SCPUSH(MDSTRFLDS[SBLEVEL].MDSTRFMD)
81610         END
81620       ELSE SCPUSH(MDERROR);
81630       SBLEVEL := SBLEVEL+1
81640       END
81650     END;
81660 (**)
81670 (**)
81680 (**)
81690 (**)
81700 ()+85*)