691 lines
26 KiB
OpenEdge ABL
691 lines
26 KiB
OpenEdge ABL
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*)
|