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*)