ack/lang/a68s/liba68s/slice12.p

68 lines
2 KiB
OpenEdge ABL
Raw Permalink Normal View History

1988-10-04 13:41:01 +00:00
48300 #include "rundecs.h"
48310 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
48320 (**)
48330 (**)
48340 PROCEDURE ERRORR(N :INTEGER); EXTERN;
48350 (**)
48360 (**)
48370 PROCEDURE SLCMN(STOWEDVAL: OBJECTP; INDEX, SLICDEX: INTEGER);
48380 BEGIN
48390 WITH STOWEDVAL^ DO CASE SORT OF
48400 MULT, REFSLN, REFR, RECR:
48410 WITH DESCVEC[SLICDEX] DO
48420 BEGIN
48430 IF INDEX<LI THEN ERRORR(RSL1ERROR);
48440 IF INDEX>UI THEN ERRORR(RSL2ERROR);
48450 END;
48460 UNDEF: ERRORR(RSLICE);
48470 NILL: ERRORR(RSLICENIL);
48480 END
48490 END;
48500 (**)
48510 (**)
48520 (*-01() (*-05()
48530 FUNCTION SLICE1(PRIMARY: OBJECTP; INDEX: BOUNDSRANGE): ASNAKED;
48540 (*PSLICE1*)
48550 VAR TEMP: NAKEGER;
48560 BEGIN
48570 WITH TEMP DO WITH NAK DO
48580 BEGIN
48590 STOWEDVAL := PRIMARY;
48600 WITH PRIMARY^ DO WITH DESCVEC[0] DO
48610 IF (INDEX<LI) OR (INDEX>UI) THEN SLCMN(STOWEDVAL, INDEX, 0)
48620 ELSE POSITION := DI*INDEX-LBADJ;
48630 SLICE1 := ASNAK;
48640 END;
48650 END;
48660 (**)
48670 (**)
48680 FUNCTION SLICE2(INDEX1, INDEX2: BOUNDSRANGE): ASNAKED;
48690 (*PSLICE2*)
48700 VAR TEMP: NAKEGER;
48710 OFFS: INTEGER;
48720 BEGIN
48730 WITH TEMP DO WITH NAK DO
48740 BEGIN
48750 (*+11() ASNAK := 0; ()+11*)
48760 STOWEDVAL := ASPTR(GETSTKTOP(SZADDR, 0));
48770 WITH STOWEDVAL^ DO
48780 BEGIN
48790 WITH DESCVEC[0] DO
48800 IF (INDEX2<LI) OR (INDEX2>UI) THEN SLCMN(STOWEDVAL, INDEX2, 0)
48810 ELSE OFFS := -LBADJ+DI*INDEX2;
48820 WITH DESCVEC[1] DO
48830 IF (INDEX1<LI) OR (INDEX1>UI) THEN SLCMN(STOWEDVAL, INDEX1, 1)
48840 ELSE POSITION := OFFS+DI*INDEX1
48850 END;
48860 SLICE2 := ASNAK;
48870 END;
48880 END;
48890 ()-05*) ()-01*)
48900 (**)
48910 (**)
48920 (*-02() BEGIN END ; ()-02*)
48930 (*+01()
48940 BEGIN (*OF MAIN PROGRAM*)
48950 END (*OF EVERYTHING*).
48960 ()+01*)