40800 #include "rundecs.h"
40810     (*  COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER  *)
40820 (**)
40830 (**)
40840 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
40850 (**)
40860 (**)
40870 (*+01() (*$X3*) ()+01*)
40880 FUNCTION PCCMN(NEWMULT: OBJECTP; TEMPLATE: DPOINT; ELSIZE: INTEGER): ASNAKED;
40890   VAR TEMP: NAKEGER;
40900       DESCDEX: INTEGER;
40910       NEWELS: OBJECTP;
40920     BEGIN WITH NEWMULT^, TEMP DO WITH NAK DO
40930       BEGIN
40940       MDBLOCK := TEMPLATE;
40950       ENEW(NEWELS, ELSCONST+ELSIZE);
40960       PVALUE := NEWELS;
40970       WITH PVALUE^ DO
40980         BEGIN IHEAD := NIL ;
40990 (*-02() FIRSTWORD := SORTSHIFT * ORD(IELS); PCOUNT := 1; ()-02*)
41000 (*+02() PCOUNT:=1; SORT:=IELS; ()+02*)
41010               OSCOPE := 0; DBLOCK := TEMPLATE; D0 := ELSIZE; CCOUNT := 1 END;
41020       IHEAD := NIL; FPTR := NIL; BPTR := NIL;
41030 (*+11() ASNAK := 0; ()+11*)
41040       STOWEDVAL := NEWMULT; POINTER := INCPTR(PVALUE, ELSCONST);
41050       PCCMN := ASNAK;
41060       END
41070     END;
41080 (**)
41090 (**)
41100 FUNCTION PCOLLR(NOROWS: INTEGER; TEMPLATE: DPOINT): ASNAKED;
41110 (*PPREPROWDISP*)
41120   VAR NEWMULT: OBJECTP;
41130       DESCDEX: INTEGER; ELSIZE, SUM: BOUNDSRANGE;
41140     BEGIN
41150     IF ORD(TEMPLATE)=0 THEN ELSIZE := 1 (*DRESSED*)
41160     ELSE IF ORD(TEMPLATE)<=MAXSIZE THEN ELSIZE := ORD(TEMPLATE) (*UNDRESSED*)
41170     ELSE ELSIZE := TEMPLATE^[0];
41180     ENEW(NEWMULT, MULTCONST+NOROWS*SZPDS);
41190     SUM := -ELSCONST;
41200     WITH NEWMULT^ DO
41210       BEGIN
41220 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
41230 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*)
41240 (*+01() SECONDWORD := 0; ()+01*)
41250       SIZE := ELSIZE;
41260       FOR DESCDEX := 0 TO NOROWS-1 DO WITH DESCVEC[DESCDEX] DO
41270         BEGIN
41280         UI := GETSTKTOP(SZINT, DESCDEX*SZINT); LI := 1; DI := ELSIZE;
41290         SUM := SUM+ELSIZE; ELSIZE := UI*ELSIZE
41300         END;
41310       LBADJ := SUM;
41320       ROWS := NOROWS-1;
41330       END;
41340     PCOLLR := PCCMN(NEWMULT, TEMPLATE, ELSIZE);
41350       (*THIS WILL NOT WORK THUS ON 16-BITS*)
41360     END;
41370 (**)
41380 (**)
41390 FUNCTION PCOLLRM(NOROWS: INTEGER; TEMPLATE: DPOINT): ASNAKED;
41400 (*PPREPROWDISP+1*)
41410   VAR OLDMULT, NEWMULT: OBJECTP;
41420       DESCDEX, FIRSTROW: INTEGER; ELSIZE, SUM: BOUNDSRANGE;
41430     BEGIN
41440     OLDMULT := ASPTR(GETSTKTOP(SZADDR, NOROWS*SZINT));
41450     WITH OLDMULT^ DO
41460       BEGIN ELSIZE := SIZE;
41470       ENEW(NEWMULT, MULTCONST+(NOROWS+ROWS+1)*SZPDS);
41480       SUM := -ELSCONST;
41490 (*-02() NEWMULT^.FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
41500 (*+02() NEWMULT^.PCOUNT:=0; NEWMULT^.SORT:=MULT; ()+02*)
41510 (*+01() NEWMULT^.SECONDWORD := 0; ()+01*)
41520       NEWMULT^.SIZE := ELSIZE;
41530       FOR DESCDEX := 0 TO ROWS DO WITH DESCVEC[DESCDEX] DO
41540         BEGIN
41550         NEWMULT^.DESCVEC[DESCDEX] := DESCVEC[DESCDEX];
41560         NEWMULT^.DESCVEC[DESCDEX].DI := ELSIZE;
41570         SUM := SUM+LI*ELSIZE; ELSIZE := (UI-LI+1)*ELSIZE;
41580         IF ELSIZE<0 THEN ELSIZE := 0
41590         END
41600       END;
41610     FIRSTROW := OLDMULT^.ROWS+1;
41620     WITH NEWMULT^ DO
41630       BEGIN
41640       FOR DESCDEX := FIRSTROW TO FIRSTROW+NOROWS-1 DO WITH DESCVEC[DESCDEX] DO
41650         BEGIN
41660         UI := GETSTKTOP(SZINT, (DESCDEX-FIRSTROW)*SZINT); LI := 1; DI := ELSIZE;
41670         SUM := SUM+ELSIZE; ELSIZE := UI*ELSIZE
41680         END;
41690       LBADJ := SUM;
41700       ROWS := FIRSTROW+NOROWS-1;
41710       END;
41720     PCOLLRM := PCCMN(NEWMULT, TEMPLATE, ELSIZE);
41730     END;
41740 (*+01() (*$X4*) ()+01*)
41750 (**)
41760 (**)
41770 FUNCTION PCOLLCK(TEMP: NAKEGER; DEPTH, COUNT: INTEGER): ASNAKED;
41780 (*PCOLLCHECK*)
41790     BEGIN
41800     WITH TEMP.NAK.STOWEDVAL^ DO WITH DESCVEC[ROWS-DEPTH] DO
41810       IF (LI<>1) OR (UI<>COUNT) THEN ERRORR(RMULASS);
41820     PCOLLCK := TEMP.ASNAK;
41830     END;
41840 (**)
41850 (**)
41860 (*-02() BEGIN END ; ()-02*)
41870 (*+01()
41880 BEGIN (*OF MAIN PROGRAM*)
41890 END (*OF EVERYTHING*).
41900 ()+01*)