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

1221 lines
45 KiB
OpenEdge ABL
Raw Permalink Normal View History

Initial revision
1988-10-04 10:56:50 +00:00
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*)
Reference in a new issue Copy permalink