ack/lang/a68s/liba68s/rownm.p
1988-10-04 13:41:01 +00:00

58 lines
2 KiB
OpenEdge ABL

45400 #include "rundecs.h"
45410 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
45420 (**)
45430 (**)
45440 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
45450 PROCEDURE PCINCR (STRUCTPTR: UNDRESSP; TEMPLATE: DPOINT; INCREMENT: INTEGER); EXTERN ;
45460 FUNCTION CRMULT( NEWMULT: OBJECTP ; TEMPLATE: DPOINT ) : OBJECTP ; EXTERN ;
45470 (**)
45480 (**)
45490 FUNCTION ROWNM(PVAL: OBJECTP; ROWCOUNT: INTEGER; TEMPLATE: DPOINT): OBJECTP;
45500 (*PROWNONMULT*)
45510 (*WARNING: PVAL CAN ALSO BE AN A68INT; TROUBLE WILL ENSUE IF SZINT>SZADDR*)
45520 VAR NEWMULT: OBJECTP;
45530 DESCDEX: INTEGER;
45540 PTR: UNDRESSP;
45550 BEGIN
45560 ENEW(NEWMULT, MULTCONST+ROWCOUNT*SZPDS);
45570 WITH NEWMULT^ DO
45580 BEGIN
45590 (*-02() FIRSTWORD := SORTSHIFT * ORD(MULT); ()-02*)
45600 (*+02() PCOUNT:=0; SORT:=MULT; ()+02*)
45610 (*+01() SECONDWORD := 0; ()+01*)
45620 ROWS := ROWCOUNT-1;
45630 FOR DESCDEX := 0 TO ROWCOUNT-1 DO
45640 WITH DESCVEC[DESCDEX] DO
45650 BEGIN LI := 1; UI := 1 END;
45660 IHEAD := NIL; FPTR := NIL; BPTR := NIL
45670 END;
45680 NEWMULT := CRMULT(NEWMULT, TEMPLATE);
45690 PTR := INCPTR(NEWMULT^.PVALUE, ELSCONST);
45700 IF ORD(TEMPLATE)=0 THEN (*DRESSED*)
45710 BEGIN
45720 PTR^.FIRSTPTR := PVAL;
45730 WITH PVAL^ DO FINC
45740 END
45750 ELSE IF ORD(TEMPLATE)=1 THEN (*SIMPLE*)
45760 PTR^.FIRSTINT := ORD(PVAL)
45770 ELSE IF PVAL^.SORT<>UNDEF THEN
45780 BEGIN
45790 IF ORD(TEMPLATE)<=MAXSIZE THEN (*NOT STRUCT*)
45800 MOVELEFT(PVAL, PTR, ORD(TEMPLATE))
45810 ELSE (*STRUCT*)
45820 BEGIN
45830 MOVELEFT(INCPTR(PVAL, STRUCTCONST), PTR, TEMPLATE^[0]);
45840 PCINCR(INCPTR(PVAL, STRUCTCONST), TEMPLATE, +INCRF)
45850 END;
45860 IF FPTST(PVAL^) THEN GARBAGE(PVAL)
45870 END;
45880 ROWNM := NEWMULT;
45890 END;
45900 (**)
45910 (**)
45920 (*-02() BEGIN END ; ()-02*)
45930 (*+01()
45940 BEGIN (*OF MAIN PROGRAM*)
45950 END (*OF EVERYTHING*).
45960 ()+01*)