1220 lines
45 KiB
OpenEdge ABL
1220 lines
45 KiB
OpenEdge ABL
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*)
|