63000 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *) 63010 (**) 63020 (*+84() 63030 (**) 63040 (**) 63050 (*MODE HANDLING*) 63060 (***************) 63070 (**) 63080 FUNCTION LENGTHEN(M: MODE; COUNT: INTEGER): MODE; 63090 (*FUNCTION: RETURNS A LONG OR SHORT MODE DERIVED FROM M*) 63100 BEGIN 63110 LENGTHEN := M; (*DEFAULT*) 63120 IF COUNT<0 THEN 63130 SEMERR(ESE+06) (*NO SHORT MODES IMPLEMENTED*) 63140 ELSE BEGIN 63150 (*WHEN LONG MODES ARE IMPLEMENTED, SPECIFIC TESTS MUST BE MADE HERE 63160 FOR MDINT, MDREAL AND MDCOMPL, AND THE APPROPRIATE LONG VERSIONS RETURNED*) 63170 IF COUNT>0 THEN 63180 (*+61() IF (COUNT=1) AND (M=MDREAL) THEN LENGTHEN := MDLREAL 63190 ELSE IF (COUNT=1) AND (M=MDCOMPL) THEN LENGTHEN := MDLCOMPL 63200 ELSE ()+61*) 63210 SEMERR(ESE+19) 63220 END; 63230 END; 63240 (**) 63250 (**) 63260 FUNCTION TX (*-01() (M: MODE): XTYPE ()-01*); 63270 BEGIN 63280 IF M=MDCOMPL THEN TX := 4 63290 (*+61() ELSE IF M=MDLCOMPL THEN TX := 5 ()+61*) 63300 ELSE TX := MODEID[M^.MDV.MDID] 63310 END; 63320 (**) 63330 (**) 63340 PROCEDURE THIPMD(HIP, M: MODE); 63350 (*FUNCTION: ENSURES THAT THE MODE M IS SUITABLE FOR HIPPING LIKE HIP*) 63360 BEGIN WITH HIP^.MDV DO 63370 IF MDID IN [MDIDSKIP,MDIDJUMP,MDIDNIL] THEN 63380 BEGIN 63390 IF MDID=MDIDJUMP THEN 63400 IF M^.MDV.MDID=MDIDPROC THEN SEMERR(ESE+40) ELSE (*NO ACTION*) 63410 ELSE IF MDID=MDIDNIL THEN 63420 IF M^.MDV.MDID<>MDIDREF THEN SEMERR(ESE+21); 63430 IF M^.MDV.MDID IN [MDIDCOVER,MDIDBNDS,MDIDABSENT] THEN SEMERR(ESE+33) 63440 (*TO CATCH NOSEY PARKERS WHO TRY TO MANUFACTURE .FILES*) 63450 END 63460 END; 63470 (**) 63480 (**) 63490 FUNCTION TUNITED(M: MODE): BOOLEAN; 63500 (*FUNCTION: TESTS WHETHER M IS A UNITED MODE*) 63510 BEGIN WITH M^ DO 63520 IF MDV.MDID=MDIDROW THEN 63530 TUNITED := TUNITED(MDPRRMD) 63540 ELSE 63550 TUNITED := (MDV.MDID>=MDIDOUT) AND (MDV.MDID<=MDIDROWS) 63560 END; 63570 (**) 63580 (**) 63590 PROCEDURE TCOLL; 63600 (*FUNCTION: ENSURES THAT NO UNIT ON THE SUBSTACK IS A COLLATERAL*) 63610 VAR SEMP: -1..SRSTKSIZE; 63620 BEGIN 63630 IF BALFLAG THEN SEMP := SRSUBP+1 ELSE SEMP := SRSEMP; 63640 WHILE SEMP<=SRSEMP DO 63650 BEGIN 63660 IF SBCOLL IN SRSTK[SEMP].SB^.SBINF THEN SEMERR(ESE+18); 63670 SEMP := SEMP+1 63680 END 63690 END; 63700 (**) 63710 (**) 63720 FUNCTION DEPASCAL(PASC: MODE): MODE; 63730 VAR TEMPM: MODE; 63740 I: INTEGER; 63750 BEGIN WITH PASC^ DO BEGIN 63760 ENEW(TEMPM, MDV.MDCNT*SZADDR + MODE1SIZE); 63770 FOR I := 1 TO (MDV.MDCNT*SZADDR+MODE1SIZE) DIV SZWORD DO 63780 TEMPM^.MDWORDS[I] := MDWORDS[I]; 63790 WITH TEMPM^ DO 63800 BEGIN 63810 MDV := MDVPROC; 63820 MDV.MDCNT := PASC^.MDV.MDCNT; 63830 MDLINK := PROCL 63840 END; 63850 PROCL := TEMPM; 63860 FIND(PROCL, FALSE, MDV.MDCNT*SZADDR); 63870 DEPASCAL := PROCL; 63880 END 63890 END; 63900 (**) 63910 (**) 63920 PROCEDURE CGCSUPP(SB: PSB; M: MODE; ROWCOUNT: INTEGER); 63930 (*FUNCTION: GENERATES CODE TO COERCE THE UNIT REPRESENTED BY SB TO THE MODE M ROWED ROWCOUNT TIMES.*) 63940 VAR ROWM, NEWM: MODE; 63950 WIDTYP: STATE; 63960 OPCOD : POP; 63970 I, PSPACE: INTEGER; 63980 BEGIN WITH SB^ DO 63990 BEGIN 64000 WHILE SBMODE<>M DO WITH SBMODE^ DO 64010 BEGIN 64020 IF MDV.MDID=MDIDREF THEN 64030 BEGIN 64040 IF SBTYP=SBTVAR THEN SBTYP := SBTID 64050 ELSE IF SBWEAKREF IN SBINF THEN SBINF := SBINF-[SBWEAKREF] 64060 ELSE 64070 BEGIN 64080 GETTOTAL(SB); OPCOD := PDEREF; 64090 GENOP(OPCOD,MDPRRMD,OLIST3,NIL); 64100 IF GENDPOCV=OCVNONE THEN 64110 EMITX2(OPCOD,OCVSB,ORD(SB),OCVRES,ORD(SB)) 64120 ELSE EMITX3(OPCOD,OCVSB,ORD(SB),GENDPOCV,GENDPVAL,OCVRES,ORD(SB)) 64130 END; 64140 SBMODE := MDPRRMD; 64150 END 64160 ELSE IF MDV.MDDEPROC THEN 64170 BEGIN 64180 GETTOTAL(SB); 64190 IF MDV.MDID=MDIDPROC THEN 64200 CGDEPROC(SB) 64210 ELSE (*MDV.MDID=MDIDPASC*) 64220 CGPASC(SB, SB); 64230 SBMODE := MDPRRMD; 64240 END 64250 ELSE BEGIN 64260 GETTOTAL(SB); 64270 IF MDV.MDID<=MDIDSTRNG THEN 64280 BEGIN CASE MDV.MDID OF 64290 MDIDINT : BEGIN WIDTYP := 0; NEWM := MDREAL END; 64300 (*+61() MDIDLINT : BEGIN WIDTYP := 1; NEWM := MDLREAL END; ()+61*) 64310 MDIDREAL : BEGIN WIDTYP := 2; NEWM := MDCOMPL END; 64320 (*+61() MDIDLREAL: BEGIN WIDTYP := 3; NEWM := MDLCOMPL END; ()+61*) 64330 MDIDCHAR : BEGIN WIDTYP := 4; NEWM := MDSTRNG END; 64340 MDIDBITS : BEGIN WIDTYP := 5; NEWM := ROWBOOL END; 64350 MDIDBYTES: BEGIN WIDTYP := 6; NEWM := ROWCHAR END; 64360 MDIDSTRNG: BEGIN WIDTYP := 7; NEWM := ROWCHAR END; 64370 END; 64380 EMITX2(PWIDEN+WIDTYP,OCVSB,ORD(SB),OCVRES,ORD(SB)); 64382 SBMODE := NEWM; 64390 IF (SBMODE^.MDV.MDID=MDIDROW) AND (SBMODE^.MDPRRMD=M) AND (ROWCOUNT>0) THEN 64400 BEGIN ROWCOUNT := ROWCOUNT-1; M := SBMODE END 64410 END 64420 ELSE IF MDV.MDID=MDIDPASC THEN 64430 BEGIN 64432 PSPACE := 0; 64434 FOR I := 0 TO MDV.MDCNT-1 DO WITH MDPRCPRMS[I]^ DO 64436 IF MDV.MDPILE THEN PSPACE := PSPACE+SZADDR ELSE PSPACE := PSPACE+MDV.MDLEN; 64440 EMITX3(PLOADRTP, OCVSB, ORD(SB), OCVIMMED, PSPACE, OCVRES,ORD(SB)); 64450 SBMODE := DEPASCAL(SBMODE) 64460 END 64470 ELSE BEGIN 64480 IF M<>MDERROR THEN MODERR(SBMODE, ESE+33); 64490 SBMODE := M; SBTYP := SBTVOID; 64500 END; 64510 END; 64520 END; 64530 IF ROWCOUNT>0 THEN 64540 BEGIN 64550 GETTOTAL(SB); 64560 IF SBMODE^.MDV.MDID=MDIDROW THEN 64570 BEGIN 64580 WITH SBMODE^ DO ROWM := FINDROW(MDPRRMD, MDV.MDCNT+ROWCOUNT); 64590 EMITX3(PROWMULT, OCVSB, ORD(SB), OCVIMMED, ROWM^.MDV.MDCNT, OCVRES, ORD(SB)) 64600 END 64610 ELSE 64620 BEGIN 64630 ROWM := FINDROW(SBMODE, ROWCOUNT); 64640 GENDP(ROWM); 64650 EMITX4(PROWNONMULT, OCVSB, ORD(SB), OCVIMMED, ROWM^.MDV.MDCNT, GENDPOCV, GENDPVAL, OCVRES, ORD(SB)) 64660 END; 64670 SBMODE := ROWM; 64680 END 64690 END 64700 END; 64710 (**) 64720 (**) 64730 FUNCTION COSOFT(M: MODE): MODE; 64740 (*FUNCTION: FINDS SOFTEST COERCION OF M*) 64750 BEGIN 64760 WHILE M^.MDV.MDDEPROC DO 64770 M := M^.MDPRRMD; 64780 COSOFT := M 64790 END; 64800 (**) 64810 (**) 64820 FUNCTION COMEEK(SRCM: MODE): MODE; 64830 (*FUNCTION: MEEKLY COERCES SRCM AS FAR AS POSSIBLE 64840 YIELDS THE MODE REACHED. 64850 *) 64860 LABEL 9; 64870 BEGIN 64880 LASTPREF := MDVOID; LASTPROC := NIL; COERCLEN := 0; 64890 WHILE SRCM<>NIL DO WITH SRCM^ DO 64900 IF MDV.MDDEPROC THEN 64910 BEGIN LASTPROC := SRCM; LASTPREF := SRCM; COERCLEN := COERCLEN+1; SRCM := MDPRRMD END 64920 ELSE IF MDV.MDID=MDIDREF THEN 64930 BEGIN LASTPREF := SRCM; COERCLEN := COERCLEN+1; SRCM := MDPRRMD END 64940 ELSE GOTO 9; 64950 9:COMEEK := SRCM 64960 END; 64970 (**) 64980 (**) 64990 FUNCTION COFIRM(SRCM, DSTM: MODE): MODE; 65000 (*FUNCTION: FIRMLY COERCES SRCM AS FAR AS POSSIBLE IN THE DIRECTION OF DSTM. 65010 YIELDS THE MODE (POSSIBLY DSTM) REACHED. 65020 *) 65030 LABEL 9; 65040 BEGIN 65050 LASTPREF := MDVOID; LASTPROC := NIL; COERCLEN := 0; 65060 WHILE SRCM<>DSTM DO WITH SRCM^ DO 65070 IF MDV.MDDEPROC THEN 65080 BEGIN LASTPROC := SRCM; LASTPREF := SRCM; COERCLEN := COERCLEN+1; SRCM := MDPRRMD END 65090 ELSE IF MDV.MDID=MDIDREF THEN 65100 BEGIN LASTPREF := SRCM; COERCLEN := COERCLEN+1; SRCM := MDPRRMD END 65110 ELSE IF MDV.MDID=MDIDPASC THEN 65120 SRCM := DEPASCAL(SRCM) 65130 ELSE GOTO 9; 65140 9:COFIRM := SRCM 65150 END; 65160 (**) 65170 (**) 65180 FUNCTION COWEAK(M: MODE): MODE; 65190 (*FUNCTION: FINDS WEAKEST COERCION OF M*) 65200 BEGIN 65210 M := COMEEK(M); 65220 IF LASTPREF^.MDV.MDID=MDIDREF THEN 65230 M := LASTPREF; 65240 COWEAK := M 65250 END; 65260 (**) 65270 (**) 65280 FUNCTION TSTRENGTH(SRCM, DSTM: MODE): STRTYP; 65290 (*FUNCTION: DETERMINES THE STRENGTH OF COERCION NECESSARY TO GET FROM SRCM TO DSTM*) 65300 BEGIN 65310 IF DSTM=SRCM THEN TSTRENGTH := STREMPTY 65320 ELSE IF COSOFT(DSTM)=COSOFT(SRCM) THEN TSTRENGTH := STRSOFT 65330 ELSE IF COWEAK(DSTM)=COWEAK(SRCM) THEN TSTRENGTH := STRWEAK 65340 ELSE IF COMEEK(DSTM)=COMEEK(SRCM) THEN TSTRENGTH := STRMEEK 65350 ELSE TSTRENGTH := STRFIRM 65360 END; 65370 (**) 65380 (**) 65390 FUNCTION BALMOIDS(M1, M2: MODE): MODE; 65400 (*FUNCTION: RETURNS THE PIVOTAL MODE OF THE BALANCE M1/M2. 65410 ON EXIT, M1COERC AND M2COERC CONTAIN THE NECESSARY STRENGTHS. 65420 *) 65430 VAR FIRMM1, FIRMM2: MODE; 65440 LEN1, LEN2, DIFF, I: INTEGER; 65450 BEGIN 65460 M1COERC := STREMPTY; M2COERC := STREMPTY; 65470 IF (M1^.MDV.MDID>=MDIDSKIP) AND (M1^.MDV.MDID<=MDIDNIL) THEN 65480 BEGIN M1COERC := STRSTRONG; BALMOIDS := M2 END; 65490 IF (M2^.MDV.MDID>=MDIDSKIP) AND (M2^.MDV.MDID<=MDIDNIL) THEN 65500 BEGIN M2COERC := STRSTRONG; BALMOIDS := M1 END; 65510 IF (M1COERC=STREMPTY) AND (M2COERC=STREMPTY) THEN 65520 IF M1=M2 THEN BALMOIDS := M1 65530 ELSE BEGIN 65540 FIRMM1 := COFIRM(M1, NIL); LEN1 := COERCLEN; 65550 FIRMM2 := COFIRM(M2, NIL); LEN2 := COERCLEN; 65560 IF FIRMM1=FIRMM2 THEN 65570 BEGIN 65580 DIFF := LEN2-LEN1; 65590 IF DIFF>=0 THEN 65600 BEGIN FIRMM1 := M1; FIRMM2 := M2 END 65610 ELSE 65620 BEGIN FIRMM1 := M2; FIRMM2 := M1; DIFF := -DIFF END; 65630 FOR I := DIFF-1 DOWNTO 0 DO 65640 FIRMM2 := FIRMM2^.MDPRRMD; 65650 WHILE FIRMM1<>FIRMM2 DO 65660 IF FIRMM1^.MDV.MDID=MDIDPASC THEN 65670 BEGIN 65680 FIRMM1 := DEPASCAL(FIRMM1); 65690 FIRMM2 := DEPASCAL(FIRMM2) 65700 END 65710 ELSE 65720 BEGIN 65730 FIRMM1 := FIRMM1^.MDPRRMD; 65740 FIRMM2 := FIRMM2^.MDPRRMD 65750 END; 65760 M1COERC := TSTRENGTH(M1, FIRMM1); 65770 M2COERC := TSTRENGTH(M2, FIRMM1); 65780 BALMOIDS := FIRMM1 65790 END 65800 ELSE BEGIN 65810 WITH FIRMM1^.MDV DO 65820 IF MDID=MDIDROW THEN LEN1 := 100+MDCNT ELSE LEN1 := MODEID[MDID]; 65830 WITH FIRMM2^.MDV DO 65840 IF MDID=MDIDROW THEN LEN2 := 100+MDCNT ELSE LEN2 := MODEID[MDID]; 65850 IF LEN1<LEN2 THEN (*STRONG COERCION, IF ANY, IS FROM M1 TO FIRMM2*) 65860 BEGIN 65870 M1COERC := STRSTRONG; M2COERC := TSTRENGTH(M2, FIRMM2); 65880 BALMOIDS := FIRMM2; 65890 END 65900 ELSE 65910 BEGIN 65920 M1COERC := TSTRENGTH(M1, FIRMM1); M2COERC := STRSTRONG; 65930 BALMOIDS := FIRMM1; 65940 END; 65950 END; 65960 END 65970 END; 65980 (**) 65990 (**) 66000 PROCEDURE CGCOERCE(SB: PSB (*CONTAINING SOURCE MODE*); M: MODE (*DESTINATION MODE*)); 66010 VAR FIRMM, MM: MODE; 66020 SB1, SB2: PSB; 66030 MODENO: -1..31; 66040 SPACE: 0..MAXSIZE; 66050 I:0..MAXINT; 66052 OPCOD: POP; 66060 BEGIN WITH SB^ DO 66070 IF SBMODE<>M THEN 66080 BEGIN 66090 FIRMM := COFIRM(SBMODE,M); 66100 IF M=MDVOID THEN (*VOIDING COERCION NEEDED*) 66110 BEGIN 66120 IF (SBMORF IN SBINF) AND (LASTPROC<>NIL) THEN 66130 CGCSUPP(SB, LASTPROC^.MDPRRMD, 0); 66140 IF SBTYP>SBTDEN THEN (*THE VALUE IS ALREADY STORED SOMEWHERE*) 66150 BEGIN 66160 IF SBNAKED IN SBINF THEN BEGIN EMITX1(PVOIDNAKED,OCVSB,ORD(SB)); STACKSB(SB) END 66180 ELSE IF SBMODE^.MDV.MDPILE THEN BEGIN EMITX1(PVOIDNORMAL,OCVSB,ORD(SB)); STACKSB(SB) END 66182 ELSE IF SBTYP IN [SBTSTK..SBTSTKN] THEN EMITX1(PASP, OCVIMMED, SBMODE^.MDV.MDLEN); 66190 END; 66200 IF (SBVOIDWARN IN SBINF) AND (SBMODE<>MDVOID) THEN 66210 OUTERR(ESE+10, WARNING, NIL); 66220 SBINF := SBINF-[SBNAKED]; FILL(SBTVOID,SB); 66230 END 66240 ELSE IF TUNITED(M) THEN (*TRANSPUT COERCION*) 66250 BEGIN 66260 FIRMM := COMEEK(SBMODE); 66270 IF (FIRMM<>PRCVF) AND (FIRMM<>PASCVF) AND 66280 ((M=MDIN) OR (M=MDINB) OR (M=ROWIN) OR (M=ROWINB) OR (M=MDROWS)) THEN 66290 MM := COWEAK(SBMODE) 66300 ELSE IF FIRMM=MDSKIP THEN 66310 BEGIN MM := MDCHAR; FIRMM := MM END (*TO FORCE A RUN-TIME ERROR*) 66320 ELSE MM := FIRMM; 66330 CGCOERCE(SB, MM); 66340 IF M<>MDROWS THEN 66350 BEGIN 66360 IF FIRMM^.MDV.MDID=MDIDROW THEN 66370 MODENO := TX(FIRMM^.MDPRRMD)+16 66380 ELSE MODENO := TX(FIRMM); 66390 SB1 := PUSHSB(MDINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := MODENO; TWIST; LOADSTK(SB1); 66400 (*-01() IF (M^.MDV.MDID=MDIDNUMBER) AND (MODENO=0(*INT*)) THEN 66410 BEGIN 66420 SB2 := PUSHSB(MDINT); SB2^.SBLEN := SZREAL-SZINT; SB2^.SBINF := SB2^.SBINF+[SBUNION]; SB2^.SBTYP := SBTLIT; SB1^.SBVALUE := 0; TWIST; LOADSTK(SB2); 66430 GETTOTAL(SB); LOADSTK(SB); 66440 COMBINE; SBTYP := SBTSTKN; 66450 END; 66460 ()-01*) 66470 GETTOTAL(SB); 66480 FOR I:= SBDELAYS-1 DOWNTO 0 DO CGRGXB(SB);(*DEAL WITH DELAYS*) 66490 SBDELAYS:=0;LOADSTK(SB); 66500 COMBINE; SBTYP := SBTSTKN; SBINF := SBINF+[SBUNION]; 66530 IF M^.MDV.MDID=MDIDROW THEN (*SINGLE UNIT TO BE ROWED TO A DATA LIST*) 66540 BEGIN 66550 (*+05() IF (RTSTKDEPTH MOD 4)<>0 THEN 66560 BEGIN SB1 := PUSHSB(MDINT); SB1^.SBTYP := SBTLIT; SB1^.SBVALUE := TX(MDVOID); 66570 LOADSTK(SB1); COMBINE; SB^.SBTYP := SBTSTKN END; 66580 ()+05*) 66590 SPACE := SBLEN; 66600 SB1 := PUSHSB(MDVOID); UNSTACKSB; SB1^.SBLEN := SPACE+SZDL; 66610 EMITX3(PDATALIST, OCVSB, ORD(SB), OCVIMMED, SPACE, OCVRES, ORD(SB1)); 66620 SBLEN := SB1^.SBLEN; SBINF := SBINF-[SBUNION]; SBTYP := SB1^.SBTYP; 66630 UNSTACKSB; DISPOSE(SRSTK[SRSEMP].SB); SRSEMP := SRSEMP-1; STACKSB(SB); 66640 END 66650 ELSE M := MM; (*SBMODE WILL BE MM, FOR BENEFIT OF STKMAP*) 66660 END 66670 ELSE GETTOTAL(SB) 66680 END 66690 ELSE WITH SBMODE^ DO 66700 IF (MDV.MDID<MDIDSKIP) OR (MDV.MDID>MDIDNIL) THEN (*NOT HIP*) 66710 WITH M^ DO 66720 IF MDV.MDID<>MDIDROW THEN 66730 CGCSUPP(SB, M, 0) 66740 ELSE IF COFIRM(SBMODE, MDPRRMD)=MDPRRMD THEN 66750 CGCSUPP(SB, MDPRRMD, MDV.MDCNT) 66760 ELSE IF FIRMM^.MDV.MDID=MDIDROW THEN 66770 CGCSUPP(SB, FIRMM, MDV.MDCNT-FIRMM^.MDV.MDCNT) 66780 ELSE 66790 CGCSUPP(SB, MDPRRMD, MDV.MDCNT) 66800 ELSE CASE MDV.MDID OF 66810 MDIDSKIP: 66820 BEGIN UNSTACKSB; 66830 IF M^.MDV.MDID=MDIDSTRUCT THEN 66840 BEGIN GENDP(M); EMITX2(PSKIPSTRUCT, GENDPOCV, GENDPVAL,OCVRES,ORD(SB)) END 66850 ELSE 66852 BEGIN 66854 IF M^.MDV.MDPILE THEN OPCOD := PSKIP+1 66856 ELSE IF M^.MDV.MDLEN>SZINT THEN OPCOD := PSKIP+2 66857 ELSE OPCOD := PSKIP; 66858 EMITX1(OPCOD, OCVRES, ORD(SB)); 66859 END; 66860 END; 66870 MDIDJUMP: (*NO ACTION*); 66880 MDIDNIL: BEGIN UNSTACKSB; EMITX1(PNIL, OCVRES, ORD(SB)) END 66890 END; 66900 SBMODE := M 66910 END 66920 END; 66930 (**) 66940 (**) 66950 PROCEDURE CGBALB(SB: PSB; M: MODE); 66960 (*EACH UNIT TO BE BALANCED*) 66970 VAR I: INTEGER; 66980 SB1: PSB; 66990 BEGIN WITH SB^ DO 67000 IF SBMODE<>MDJUMP THEN 67010 BEGIN 67012 (*+42() SETTEXTSTATE; ()+42*) 67020 FIXUPF(SBXPTR); (*SBXPTR WAS SET IN CGIBAL*) 67030 STACKSB(SB); 67040 CGCOERCE(SB, M); 67050 FOR I := SBDELAYS-1 DOWNTO 0 DO CGRGXB(SB); 67060 SBDELAYS := 0; 67070 LOADTOTAL(SB); 67080 IF SBUNION IN SBINF THEN 67090 WHILE SBLEN<BALANLEN+SZWORD DO (*TO MAKE STKMAP HAPPY*) 67100 BEGIN SB1 := PUSHSB(MDVOID); CGCOERCE(RTSTACK, M); COMBINE END; 67110 IF (SBTYP=SBTDL) AND (SBLEN<BALANLEN) THEN 67120 BEGIN 67130 EMITX1(PHOIST, OCVIMMED, BALANLEN-SBLEN); 67140 RTSTKDEPTH := RTSTKDEPTH+BALANLEN-SBLEN; 67150 SBLEN := BALANLEN; 67160 END; 67170 UNSTACKSB; 67180 IF SB<>SRSTK[SRSEMP].SB THEN 67190 GENFLAD 67200 END 67210 END; 67220 (**) 67230 (**) 67240 FUNCTION COERCE (*-01() (M: MODE): MODE ()-01*); 67250 (*FUNCTION: GENERATE CODE TO PERFORM THE APPROPRIATE COERCIONS FOR THE UNIT ON THE STACK. 67260 REDUCES THE STACK TO CONTAIN A SINGLE BLOCK REPRESENTING THE RESULTING UNIT. 67270 RETURNS M UNALTERED ??? 67280 *) 67290 VAR SEMP: -1..SRSTKSIZE; 67300 NOTJUMP: BOOLEAN; 67310 I: INTEGER; 67320 BEGIN 67330 IF BALFLAG THEN 67340 BEGIN 67350 STARTCHAIN; 67360 SEMP := SRSUBP+1; 67370 WHILE SEMP<=SRSEMP DO WITH SRSTK[SEMP] DO 67380 BEGIN 67390 THIPMD(SB^.SBMODE, M); 67400 CGBALB(SB, M); 67410 IF SEMP<>SRSEMP THEN DISPOSE(SB); 67420 SEMP := SEMP+1 67430 END; 67440 SUBREST; 67450 SRSEMP := SRSEMP+1; SRSTK[SRSEMP] := SRSTK[SEMP-1]; (*AS KEPT*) 67460 STACKSB(SRSTK[SRSEMP].SB); 67470 CGBALC; 67480 BALFLAG := FALSE; 67490 END 67500 ELSE WITH SRSTK[SRSEMP] DO WITH SB^ DO 67510 BEGIN 67520 THIPMD(SBMODE, M); 67530 NOTJUMP := SBMODE<>MDJUMP; 67540 CGCOERCE(SB, M); 67550 IF NOTJUMP THEN WITH SB^ DO 67560 FOR I := SBDELAYS-1 DOWNTO 0 DO CGRGXB(SB); 67570 SBDELAYS := 0 67580 END; 67590 WITH SRSTK[SRSEMP].SB^ DO SBINF := SBINF-[SBMORF]; 67600 COERCE := M 67610 END; 67620 (**) 67630 (**) 67640 FUNCTION BALANCE(STRENGTH: STRTYP): MODE; 67650 (*FUNCTION: DEDUCES THE MODE OF THE BALANCE ON THE SUBSTACK. 67660 COMPLAINS IF STRENGTH IS INSUFFICIENT. 67670 RETURNS THE MODE OF THE BALANCE. 67680 *) 67690 VAR COMM, M: MODE; 67700 SEMP: -1..SRSTKSIZE; 67710 BEGIN 67720 IF BALFLAG THEN SEMP := SRSUBP+1 ELSE SEMP := SRSEMP; 67730 COMM := SRSTK[SEMP].SB^.SBMODE; 67740 WITH COMM^.MDV DO 67750 IF (MDID<MDIDSKIP) OR (MDID>MDIDNIL) (*NOT HIPMODE*) THEN BALSTR := STREMPTY 67760 ELSE BALSTR := STRSTRONG; 67770 WHILE SEMP<SRSEMP DO 67780 BEGIN 67790 SEMP := SEMP+1; 67800 COMM := BALMOIDS(COMM, SRSTK[SEMP].SB^.SBMODE); 67810 IF BALSTR<M1COERC THEN BALSTR := M1COERC; 67820 IF BALSTR>M2COERC THEN BALSTR := M2COERC; 67830 END; 67840 IF BALSTR>STRENGTH THEN 67850 IF (STRENGTH=STRFIRM) AND (COMM^.MDV.MDID=MDIDROW) THEN 67860 COMM := MDROWS 67870 ELSE BEGIN 67880 CASE STRENGTH OF 67890 STRSOFT: SEMERR(ESE+26); 67900 STRWEAK: SEMERR(ESE+27); 67910 STRMEEK: SEMERR(ESE+28); 67920 STRFIRM: SEMERR(ESE+29); 67930 END; 67940 COMM := MDERROR; 67950 END; 67960 BALANCE := COMM 67970 END; 67980 (**) 67990 (**) 68000 FUNCTION SOFT: MODE; 68010 (*FUNCTION: PERFORMS SOFTEST COERCION ON UNIT OR BALANCE ON THE STACK*) 68020 BEGIN 68030 TCOLL; 68040 SOFT := COERCE(COSOFT(BALANCE(STRSOFT))) 68050 END; 68060 (**) 68070 (**) 68080 FUNCTION WEAK: MODE; 68090 (*FUNCTION: PERFORMS WEAKEST COERCION ON UNIT OR BALANCE ON THE STACK*) 68100 BEGIN 68110 TCOLL; 68120 WEAK := COERCE(COWEAK(BALANCE(STRWEAK))) 68130 END; 68140 (**) 68150 (**) 68160 FUNCTION FIRMBAL: MODE; 68170 (*FUNCTION: PERFORMS FIRM BALANCE (BUT DOES NOT COERCE)*) 68180 BEGIN 68190 TCOLL; 68200 FIRMBAL := COFIRM(BALANCE(STRFIRM), NIL); 68210 END; 68220 (**) 68230 (**) 68240 FUNCTION MEEK: MODE; 68250 (*FUNCTION: PERFORMS FIRMEST COERCION ON UNIT OR BALANCE ON THE STACK*) 68260 BEGIN 68270 TCOLL; 68280 MEEK := COERCE(COMEEK(BALANCE(STRMEEK))); 68290 END; 68300 (**) 68310 (**) 68320 FUNCTION UNITESTO(SRCM, DSTM: MODE): BOOLEAN; 68330 (*DSTM MUST BE ONE OF THE TRANSPUT MODES OUT, IN, OUT, INB OR NUMBER. 68340 FUNCTION: DETERMINES WHETHER SRCM CAN BE UNITED TO DSTM. 68350 *) 68360 LABEL 9; 68370 VAR WEAKM, MEEKM: MODE; 68380 BEGIN 68390 IF SRCM=MDERROR THEN 68400 BEGIN UNITESTO := TRUE; GOTO 9 END; 68410 IF DSTM^.MDV.MDID=MDIDROW THEN 68420 IF SRCM=DSTM THEN 68430 BEGIN UNITESTO := TRUE; GOTO 9 END 68440 ELSE DSTM := DSTM^.MDPRRMD; 68450 WEAKM := COWEAK(SRCM); MEEKM := COMEEK(WEAKM); 68460 UNITESTO := FALSE; 68470 WITH DSTM^.MDV DO 68480 IF (MDID>=MDIDOUT) AND (MDID<=MDIDNUMBER) (*A UNITED MODE*) THEN 68490 CASE MDID OF 68500 MDIDOUT: 68510 IF (MEEKM=PRCVF) OR (MEEKM=PASCVF) OR (MEEKM^.MDV.MDIO) THEN UNITESTO := TRUE; 68520 MDIDIN: 68530 IF (MEEKM=PRCVF) OR (MEEKM=PASCVF) THEN UNITESTO := TRUE 68540 ELSE IF WEAKM^.MDV.MDID=MDIDREF THEN 68550 UNITESTO := MEEKM^.MDV.MDIO; 68560 MDIDOUTB: 68570 UNITESTO := MEEKM^.MDV.MDIO; 68580 MDIDINB: 68590 IF WEAKM^.MDV.MDID=MDIDREF THEN 68600 UNITESTO := MEEKM^.MDV.MDIO; 68610 MDIDNUMBER: 68620 IF MEEKM^.MDV.MDID<=MDIDLREAL THEN UNITESTO := TRUE 68630 END; 68640 9: END; 68650 (**) 68660 (**) 68670 FUNCTION UNITEDBAL(M: MODE): BOOLEAN; 68680 (*FUNCTION: DETERMINES WHETHER THE UNIT OR BALANCE ON THE STACK CAN BE 68690 UNITED TO THE TRANSPUT MODE M. 68700 *) 68710 VAR SEMP: -1..SRSTKSIZE; 68720 BALCOUNT: INTEGER; 68730 BEGIN 68740 BALCOUNT := 0; 68750 BALANLEN := 0; 68760 IF BALFLAG THEN SEMP := SRSUBP+1 ELSE SEMP := SRSEMP; 68770 WHILE SEMP<=SRSEMP DO WITH SRSTK[SEMP] DO WITH SB^ DO 68780 BEGIN 68790 IF UNITESTO(SBMODE, M) THEN BALCOUNT := BALCOUNT+1 68800 ELSE IF (SBMODE^.MDV.MDID<MDIDSKIP) OR (SBMODE^.MDV.MDID>MDIDNIL) THEN BALCOUNT := -MAXINT; 68810 IF SBLEN>BALANLEN THEN BALANLEN := SBLEN; 68820 SEMP := SEMP+1 68830 END; 68840 UNITEDBAL := BALCOUNT>0 68850 END; 68860 (**) 68870 (**) 68880 PROCEDURE STRONG; 68890 (*FUNCTION: STRONGLY COERCES THE UNIT OR BALANCE ON THE STACK AS FAR AS THE 68900 MODE ON THE SC CHAIN. 68910 WHEN THE A POSTERIORI MODE IS VOID IT IS POSSIBLE TO GENERATE DIRECTLY THE COERCION CODE 68920 WITHOUT CALLING A BALANCING ROUTINE. THIS IS DUE TO THE FACT THAT ALL MODES CAN BE STRONGLY 68930 COERCED TO VOID. HOWEVER, COLLATERAL-CLAUSES MAY NOT APPEAR IN STRONG VOID CONTEXTS. 68940 *) 68950 VAR M, M1: MODE; 68960 BEGIN 68970 M := SCPOP; 68980 IF M=MDVOID THEN 68990 TCOLL 69000 ELSE WITH M^ DO 69010 BEGIN 69020 IF MDV.MDID=MDIDROW THEN M1 := MDPRRMD ELSE M1 := M; 69030 WITH M1^.MDV DO IF (MDID>=MDIDOUT) AND (MDID<=MDIDNUMBER) (*UNITEDMODE*) THEN 69040 IF NOT UNITEDBAL(M) THEN 69050 BEGIN 69060 SEMERR(ESE+31); 69070 M := MDERROR 69080 END 69090 END; 69100 M := COERCE(M) 69110 END; 69120 (**) 69130 (**) 69140 PROCEDURE SETBALFLAG; 69150 (*FUNCTION: SETS THE BALANCE FLAG (BALFLAG) FOR THE VALUE OF A RANGE. 69160 IF THE RANGE VALUE MAY BE ANY OF A NUMBER (>1) UNITS THEN THE FLAG IS SET AND THE STACK HOLDS 69170 A MARK PLUS THE BLOCKS FOR THE UNITS. F THE RANGE VALUE IS A SINGLE UNIT, 69180 THE FLAG IS CLEARED AND THE STACK HOLDS ONLY THE SINGLE BLOCK. 69190 *) 69200 VAR T: PSB; 69210 BEGIN 69220 IF SRSEMP<>SRSUBP+1 (*NOT ONE UNIT*) THEN 69230 BALFLAG := TRUE 69240 ELSE BEGIN 69250 T := SRSTK[SRSEMP].SB; SRSEMP := SRSEMP-1; 69260 SUBREST; 69270 SRSEMP := SRSEMP+1; SRSTK[SRSEMP].SB := T 69280 END 69290 END; 69300 (**) 69310 (**) 69320 PROCEDURE INNERBAL; 69330 (*FUNCTION: EXECUTED AFTER PROCESSING AN "INNER UNIT" OF A BALANCE. 69340 EVERY BALANCE CONSISTS OF ONE OR MORE UNITS WHICH ARE EVENTUALLY BALANCED. 69350 EACH UNIT EXCEPT THE LAST IS CALLED AN INNER UNIT. NOTE THAT EACH UNIT IN A BALANCE MAY IN FACT 69360 BE A SINGLE BASIC (NON-BALANCE) UNIT OR A SEQUENCE OF BASIC UNITS WHICH RESULTED FROM SOME BALANCE. 69370 *) 69380 VAR I: INTEGER; T: -1..SRSTKSIZE; 69390 BEGIN 69400 IF NOT BALFLAG THEN CGIBAL 69410 ELSE BEGIN 69420 BALFLAG := FALSE; 69430 T := SRSTK[SRSUBP].SUBP; 69440 FOR I := SRSUBP TO SRSEMP-1 DO 69450 SRSTK[I] := SRSTK[I+1]; 69460 SRSEMP := SRSEMP-1; 69470 SRSUBP := T 69480 END 69490 END; 69500 (**) 69510 (**) 69520 PROCEDURE LASTIBAL; 69530 (*FUNCTION: CALLS INNERBAL IF NECESSARY*) 69540 BEGIN 69550 IF (BALFLAG) OR (SRSEMP<>SRSUBP+1) THEN INNERBAL 69560 END; 69570 (**) 69580 (**) 69590 PROCEDURE MEEKLOAD(M: MODE; ERR: INTEGER); 69600 (*EXPECTS THE MAXIMUM COERCION OF THE STACKED UNIT OR BALANCE TO BE M*) 69610 VAR M1: MODE; 69620 BEGIN 69630 M1 := MEEK; 69640 IF M1<>M THEN MODERR(M1, ERR); 69650 CGFIRM 69660 END; 69670 (**) 69680 (**) 69690 PROCEDURE GETOPDM(PROCM: MODE); 69700 (*FUNCTION: PROCM IS THE MODE OF SOME OPERATOR. 69710 SETS LHMODE AND RHMODE.*) 69720 BEGIN WITH PROCM^ DO 69730 IF MDV.MDCNT=1 THEN 69740 BEGIN LHMODE := MDABSENT; RHMODE := MDPRCPRMS[0] END 69750 ELSE 69760 BEGIN LHMODE := MDPRCPRMS[0]; RHMODE := MDPRCPRMS[1] END 69770 END; 69780 (**) 69790 ()+84*)