26000 #include "rundecs.h"
26010     (*  COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER  *)
26020 (**)
26030 (**)
26040 PROCEDURE COPYSLICE(ASLICE: OBJECTP); EXTERN;
26050 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP; EXTERN;
26060 PROCEDURE ERRORR(N :INTEGER); EXTERN;
26070 (**)
26080 (**)
26090 FUNCTION BOUND(ROWCOUNT: INTEGER): OBJECTP;
26100 (*PBOUNDS*)
26110   VAR NEWMULT: OBJECTP;
26120       DESCDEX: INTEGER; BND: BOUNDSRANGE;
26130     BEGIN
26140     ENEW(NEWMULT, MULTCONST+ROWCOUNT*SZPDS);
26150     WITH NEWMULT^ DO
26160       BEGIN
26170 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
26180 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*)
26190 (*+01() SECONDWORD := 0; ()+01*)
26200       OSCOPE := 0 ;
26210       FOR DESCDEX := 0 TO ROWCOUNT-1 DO
26220         WITH DESCVEC[DESCDEX] DO
26230           BEGIN
26240           BND := GETSTKTOP(SZINT, DESCDEX*2*SZINT);
26250           IF BND=INTUNDEF THEN ERRORR(RCUPPER); UI := BND;
26260           BND := GETSTKTOP(SZINT, DESCDEX*2*SZINT+SZINT);
26270           IF BND=INTUNDEF THEN ERRORR(RCLOWER); LI := BND;
26280           END;
26290       ROWS := ROWCOUNT-1;
26300       PVALUE := NIL;
26310       IHEAD := NIL; FPTR := NIL; BPTR := NIL
26320       END;
26330     BOUND := NEWMULT;
26340     END;
26350 (**)
26360 (**)
26370 FUNCTION CRMULT(NEWMULT: OBJECTP; TEMPLATE: DPOINT): OBJECTP;
26380 (*PACTDRMULT*)
26390   VAR NEWELS: OBJECTP;
26400       SUM, ELSIZE, INDEX, DESCDEX, TEMPOS, STRUCTPOS, INC: INTEGER;
26410       PTR, LIMIT: UNDRESSP;
26420     BEGIN
26430     WITH NEWMULT^ DO
26440       BEGIN
26450       IF ORD(TEMPLATE)=0 THEN ELSIZE := SZADDR  (*DRESSED*)
26460       ELSE IF ORD(TEMPLATE)<=MAXSIZE THEN ELSIZE := ORD(TEMPLATE)  (*UNDRESSED*)
26470         ELSE ELSIZE := TEMPLATE^[0];  (*STRUCT*)
26480       SIZE:= ELSIZE;
26490       SUM:= 0;
26500       FOR DESCDEX := 0 TO ROWS DO
26510         WITH DESCVEC[DESCDEX] DO
26520           BEGIN
26530           DI:= ELSIZE;
26540           SUM := SUM+LI*ELSIZE;
26550           ELSIZE:= (UI-LI+1)*ELSIZE;
26560           IF ELSIZE <= 0 THEN
26570             ELSIZE:= 0
26580           END;
26590       LBADJ := SUM-ELSCONST;
26600       MDBLOCK := TEMPLATE;
26610       ENEW(NEWELS, ELSCONST+ELSIZE);
26620       WITH NEWELS^ DO
26630         BEGIN
26640 (*-02() FIRSTWORD := SORTSHIFT*ORD(IELS)+INCRF; ()-02*)
26650 (*+02() PCOUNT:=1; SORT:=IELS; ()+02*)
26660         OSCOPE := 0;
26670         DBLOCK:= TEMPLATE;
26680         D0:= ELSIZE;
26690         CCOUNT:= 1;
26700         PTR := INCPTR(NEWELS, ELSCONST);
26710         IHEAD := NIL;
26720 (*-02()
26730         IF ORD(TEMPLATE)=0 THEN BEGIN PTR^.FIRSTPTR := UNDEFIN; INC := SZADDR END  (*DRESSED*)
26740         ELSE BEGIN PTR^.FIRSTWORD := INTUNDEF; INC := SZWORD END;  (*UNDRESSED*)
26750         MOVELEFT(PTR, INCPTR(PTR, INC), ELSIZE-INC);
26760 ()-02*)
26770 (*+02()
26780         LIMIT := INCPTR(PTR, ELSIZE);
26790         IF ORD(TEMPLATE)=0 THEN WHILE PTR<>LIMIT DO
26800           BEGIN PTR^.FIRSTPTR := UNDEFIN; PTR := INCPTR(PTR, SZADDR) END
26810         ELSE WHILE PTR<>LIMIT DO
26820           BEGIN PTR^.FIRSTWORD := INTUNDEF; PTR := INCPTR(PTR, SZWORD) END;
26830 ()+02*)
26840         IF ORD(TEMPLATE)>MAXSIZE  (*STRUCT*) THEN
26850           BEGIN
26860           ELSIZE:= TEMPLATE^[0];
26870           INDEX:= 0;
26880           WHILE INDEX < D0 DO
26890             BEGIN
26900             TEMPOS:= 1;
26910             STRUCTPOS:= TEMPLATE^[1];
26920             WHILE STRUCTPOS >= 0 DO
26930               BEGIN
26940               PTR := INCPTR(NEWELS, ELSCONST+INDEX+STRUCTPOS);
26950               PTR^.FIRSTPTR := UNDEFIN;
26960               TEMPOS:= TEMPOS+1;
26970               STRUCTPOS:= TEMPLATE^[TEMPOS]
26980               END;
26990             INDEX:= INDEX+ELSIZE
27000             END
27010           END
27020         END;
27030         PVALUE:= NEWELS
27040       END;
27050     CRMULT := NEWMULT
27060     END;
27070 (**)
27080 (**)
27090 FUNCTION CRREFR(ANOBJECT: OBJECTP): OBJECTP;
27100 (*PCREATEREF+2*)
27110   VAR  NEWREFR: OBJECTP;
27120     BEGIN
27130     WITH ANOBJECT^ DO
27140       BEGIN
27150       IF (BPTR<>NIL) AND (SORT=MULT)  THEN (*SOURCE IS A SLICE*)
27160         COPYSLICE(ANOBJECT);
27170       IF FTST THEN
27180         BEGIN NEWREFR := ANOBJECT; NEWREFR^.SORT := REFR END
27190       ELSE
27200         BEGIN
27210         NEWREFR := COPYDESC(ANOBJECT, REFR);
27220         WITH NEWREFR^.PVALUE^ DO FINC
27230         END
27240       END;
27250     WITH NEWREFR^ DO
27260       BEGIN
27270       OSCOPE := SCOPE+FIRSTRG.RIBOFFSET^.RGSCOPE;
27280       ANCESTOR:= NEWREFR;
27290       CCOUNT:= 1;
27300       END;
27310     CRREFR := NEWREFR;
27320     END;
27330 (**)
27340 (**)
27350 FUNCTION CHKDESC(SOURCEMULT, CDESC: OBJECTP): OBJECTP;
27360  (*PCHECKDESC*)
27370 VAR  COUNT: INTEGER;
27380 BEGIN
27390      IF SOURCEMULT^.SORT=UNDEF THEN ERRORR(RMULASS);
27400      FOR COUNT:= 0 TO CDESC^.ROWS
27410           DO   WITH CDESC^.DESCVEC[COUNT], SOURCEMULT^ DO
27420                     IF (LI <> DESCVEC[COUNT].LI)
27430                          OR (UI <>  DESCVEC[COUNT].UI)
27440                     THEN ERRORR(RMULASS);
27450     CHKDESC := SOURCEMULT;
27460 END;
27470 (**)
27480 (**)
27490 (*-02() BEGIN END ; ()-02*)
27500 (*+01()
27510 BEGIN (*OF MAIN PROGRAM*)
27520 END (*OF EVERYTHING*).
27530 ()+01*)