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)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 STLEVELNIL 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^.STRANGE0 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 BLKSTBDEFID 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 STCURIDSTBNONE 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[YIN, YANG]) AND (INIL 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*)