52000 #include "rundecs.h"
52010     (*  COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER  *)
52020 (**)
52030 (**)
52040 FUNCTION STRUCTSCOPE(STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT):DEPTHRANGE; EXTERN;
52050 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); EXTERN;
52060 FUNCTION NEXTEL(I: INTEGER; VAR PDESC1: PDESC): BOOLEAN; EXTERN;
52070 PROCEDURE PCINCR(STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER); EXTERN;
52080 PROCEDURE FORMPDESC(OLDESC: OBJECTP; VAR PDESC1: PDESC); EXTERN;
52090 PROCEDURE PCINCRMULT(ELSPTR: OBJECTP; INCREMENT: INTEGER); EXTERN;
52100 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN;
52110 PROCEDURE TESTCC (TARGET: OBJECTP); EXTERN;
52120 PROCEDURE ERRORR(N :INTEGER); EXTERN;
52130 FUNCTION CHKDESC(SOURCEMULT, CDESC: OBJECTP): OBJECTP; EXTERN;
52140 (**)
52150 (**)
52160 PROCEDURE PCINCRSLICE(MULT: OBJECTP; VAR APDESC: PDESC; INCREMENT: INTEGER);
52170   VAR I, ELSIZE: INTEGER;
52180       TEMPLATE: DPOINT;
52190       PTR: UNDRESSP;
52200     BEGIN WITH APDESC, MULT^ DO
52210       BEGIN
52220       TEMPLATE := MDBLOCK;
52230       IF ORD(TEMPLATE)<=MAXSIZE THEN (*NOT STRUCT*)
52240         IF ORD(TEMPLATE)=0 THEN (*DRESSED*)
52250           WHILE NEXTEL(0, APDESC) DO WITH PDESCVEC[0] DO
52260             BEGIN
52270             PTR := INCPTR(PVALUE, PP);
52280             WHILE ORD(PTR)<ORD(PVALUE)+PP+PSIZE DO WITH PTR^ DO
52290               BEGIN
52300               FINCD(FIRSTPTR^,INCREMENT);
52310               IF FPTST(FIRSTPTR^) THEN GARBAGE(FIRSTPTR);
52320               PTR := INCPTR(PTR, SZADDR);
52330               END
52340             END
52350         ELSE (*NO ACTION*)
52360       ELSE
52370         BEGIN
52380         ELSIZE := TEMPLATE^[0];
52390         IF TEMPLATE^[1]>0 THEN
52400           WHILE NEXTEL(0, APDESC) DO WITH PDESCVEC[0] DO
52410             BEGIN
52420             I := PP;
52430             WHILE I<PP+PSIZE DO
52440               BEGIN PCINCR(INCPTR(PVALUE, I), TEMPLATE, INCREMENT); I := I+ELSIZE END
52450             END
52460         END
52470       END
52480     END;
52490 (**)
52500 (**)
52510 FUNCTION MULTSCOPE(MULT: OBJECTP):DEPTHRANGE;
52520   VAR TEMPLATE: DPOINT;
52530       NEWEST, CURRENT: DEPTHRANGE;
52540       DRESSED: BOOLEAN;
52550       APDESC: PDESC;
52560       ELSIZE: INTEGER;
52570       PTR: UNDRESSP;
52580     BEGIN
52590     TEMPLATE := MULT^.MDBLOCK;
52600     DRESSED := ORD(TEMPLATE)=0;
52610     IF DRESSED THEN ELSIZE := 1 ELSE ELSIZE := TEMPLATE^[0];
52620     NEWEST := 0;
52630     WITH MULT^ DO
52640       IF BPTR=NIL THEN (*NOT A SLICE*)
52650         BEGIN
52660         PTR := INCPTR(PVALUE, ELSCONST);
52670         WHILE ORD(PTR)<ORD(PVALUE)+ELSCONST+PVALUE^.D0 DO
52680           BEGIN
52690           IF DRESSED THEN WITH PTR^.FIRSTPTR^ DO
52700             IF NEWEST<OSCOPE THEN NEWEST := OSCOPE
52710             ELSE (*NO ACTION*)
52720           ELSE BEGIN
52730             CURRENT := STRUCTSCOPE(PTR, TEMPLATE);
52740             IF NEWEST<CURRENT THEN NEWEST := CURRENT
52750             END;
52760           PTR := INCPTR(PTR, ELSIZE);
52770           END;
52780         PVALUE^.OSCOPE := NEWEST;
52790         END
52800       ELSE (*A SLICE*)
52810         BEGIN
52820         FORMPDESC(MULT, APDESC);
52830         WHILE NEXTEL(0, APDESC) DO WITH APDESC DO WITH PDESCVEC[0] DO
52840           BEGIN
52850           PTR := INCPTR(PVALUE, PP);
52860           WHILE ORD(PTR)<ORD(PVALUE)+PP+PSIZE DO
52870             BEGIN
52880             IF DRESSED THEN WITH PTR^.FIRSTPTR^ DO
52890               IF NEWEST<OSCOPE THEN NEWEST := OSCOPE
52900               ELSE (*NO ACTION*)
52910             ELSE BEGIN
52920               CURRENT := STRUCTSCOPE(PTR, TEMPLATE);
52930               IF NEWEST<CURRENT THEN NEWEST := CURRENT
52940               END;
52950             PTR := INCPTR(PTR, ELSIZE);
52960             END
52970           END
52980         END;
52990     MULT^.OSCOPE := NEWEST;
53000     MULTSCOPE := NEWEST
53010     END;
53020 (**)
53030 (**)
53040 FUNCTION TASSTM(DESTINATION, SOURCE: OBJECTP): OBJECTP;
53050 (*PASSIGNTT+4*)
53060   VAR DESTELS, SOURCELS, NEWSOURCE: OBJECTP;
53070       VECPOS, ELSIZE: INTEGER;
53080       PDESC1, PDESC2: PDESC;
53090       DUMMY: BOOLEAN;
53100     BEGIN
53110     SOURCE := CHKDESC(SOURCE, DESTINATION);
53120     SOURCELS := SOURCE^.PVALUE;
53130     WITH DESTINATION^ DO
53140       IF SORT = REFSLN THEN
53150         BEGIN
53160         IF FPTWO(ANCESTOR^.PVALUE^) THEN
53170           TESTCC(DESTINATION);
53180         DESTELS := ANCESTOR^.PVALUE;
53190         FORMPDESC(DESTINATION, PDESC2);
53200         PCINCRSLICE(ANCESTOR, PDESC2, -INCRF);
53210         IF SOURCE^.BPTR=NIL THEN
53220           WITH PDESC2 DO
53230             BEGIN (*SOURCE IS NOT A SLICE*)
53240             PCINCRMULT(SOURCELS, +INCRF);
53250             VECPOS := ELSCONST;
53260             WHILE NEXTEL(0, PDESC2) DO WITH PDESCVEC[0] DO
53270               BEGIN
53280               MOVELEFT(INCPTR(SOURCELS, VECPOS), INCPTR(DESTELS, PP), PSIZE);
53290               VECPOS:= VECPOS+PSIZE;
53300               END;
53310             END
53320         ELSE
53330           BEGIN (*SOURCE IS A SLICE*)
53340           FORMPDESC(SOURCE, PDESC1);
53350           PCINCRSLICE(SOURCE, PDESC1, +INCRF);
53360           IF PDESC1.PSIZE>PDESC2.PSIZE THEN
53370             WHILE NEXTEL(0, PDESC1) DO
53380               WITH PDESC1, PDESCVEC[0] DO
53390                 BEGIN
53400                 VECPOS := PP;
53410                 WHILE VECPOS<PP+PSIZE DO
53420                   BEGIN
53430                   DUMMY := NEXTEL(0, PDESC2);
53440                   WITH PDESC2 DO WITH PDESCVEC[0] DO
53450                     BEGIN
53460                     MOVELEFT(INCPTR(SOURCELS, VECPOS), INCPTR(DESTELS, PP), PSIZE);
53470                     VECPOS := VECPOS+PSIZE
53480                     END
53490                   END
53500                 END
53510           ELSE
53520             WHILE NEXTEL(0, PDESC2) DO WITH PDESC2, PDESCVEC[0] DO
53530               BEGIN
53540               VECPOS := PP;
53550               WHILE VECPOS<PP+PSIZE DO BEGIN
53560                 DUMMY := NEXTEL(0, PDESC1);
53570                 WITH PDESC1 DO WITH PDESCVEC[0] DO
53580                   BEGIN
53590                   MOVELEFT(INCPTR(SOURCELS, PP), INCPTR(DESTELS, VECPOS), PSIZE);
53600                   VECPOS := VECPOS+PSIZE
53610                   END
53620                 END
53630               END
53640           END
53650         END
53660       ELSE (* SORT IS REFR OR RECR *)
53670         IF SOURCE^.BPTR=NIL THEN (*SOURCE IS NOT A SLICE*)
53680           BEGIN
53690           DESTELS := PVALUE;
53700           WITH SOURCELS^ DO
53710             IF DESTELS^.CCOUNT>=CCOUNT THEN
53720               IF CCOUNT<>0 THEN CCOUNT := CCOUNT+1 ELSE (*NA*)
53730             ELSE IF DESTELS^.CCOUNT=0 THEN CCOUNT := 0;
53740                 (*CCOUNT=0 TREATED AS INFINITY*)
53750                   (*CCOUNT(SOURCELS) = MAX(CCOUNT(SOURCELS), CCOUNT(DESTELS)+1)*)
53760           NEWSOURCE:=COPYDESC(SOURCE,MULT);
53770           FPINC(SOURCELS^);
53780           FPINC(NEWSOURCE^);
53790           IF FPTST(PVALUE^) THEN GARBAGE(PVALUE);
53800           PVALUE:= SOURCELS
53810           END
53820         ELSE
53830           BEGIN
53840           IF FPTWO(PVALUE^) THEN 
53850             TESTCC(DESTINATION);
53860           DESTELS := PVALUE;
53870           FORMPDESC(SOURCE, PDESC1);
53880           PCINCRSLICE(SOURCE, PDESC1, +INCRF);
53890           PCINCRMULT(DESTELS, -INCRF);
53900           VECPOS := ELSCONST;
53910           WHILE NEXTEL(0, PDESC1) DO WITH PDESC1, PDESCVEC[0] DO
53920             BEGIN
53930             MOVELEFT(INCPTR(SOURCELS, PP), INCPTR(DESTELS, VECPOS), PSIZE);
53940             VECPOS:= VECPOS+PSIZE
53950             END
53960       END;
53970     IF FPTST(SOURCE^) THEN GARBAGE(SOURCE);
53980     TASSTM := DESTINATION;
53990     END;
54000 (**)
54010 (**)
54020 FUNCTION SCPTTM(DESTINATION, SOURCE: OBJECTP): OBJECTP;
54030 (*PSCOPETT+4*)
54040     BEGIN
54050     WITH SOURCE^ DO
54060       BEGIN
54070       IF OSCOPE=0 THEN OSCOPE := MULTSCOPE(SOURCE);
54080       IF DESTINATION^.OSCOPE<OSCOPE THEN ERRORR(RSCOPE);
54090       END;
54100     SCPTTM := TASSTM(DESTINATION, SOURCE);
54110     END;
54120 (**)
54130 (**)
54140 (*-02() BEGIN END ; ()-02*)
54150 (*+01()
54160 BEGIN (*OF MAIN PROGRAM*)
54170 END (*OF EVERYTHING*).
54180 ()+01*)