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

691 lines
26 KiB
OpenEdge ABL
Raw Normal View History

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