31800 #include "rundecs.h"
31810     (*  COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER  *)
31820 (**)
31830 (**)
31840 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN;
31850 PROCEDURE RANGEXT; EXTERN;
31860 (**)
31870 (**)
31880 PROCEDURE DORECGEN;
31890   VAR RECGEN, RECPOINT: OBJECTP;
31900     BEGIN
31910     RECGEN := FIRSTRG.RIBOFFSET^.FIRSTW.RECGEN;
31920     WHILE RECGEN<>NIL DO WITH RECGEN^ DO
31930         BEGIN
31940         FINC;
31950         WITH PVALUE^ DO FDEC;
31960         IF FPTST(PVALUE^) THEN GARBAGE(PVALUE);
31970         PVALUE := UNDEFIN;
31980         RECPOINT := RECGEN; RECGEN := NEXT;
31990         WITH RECPOINT^ DO BEGIN FDEC; IF FTST THEN GARBAGE(RECPOINT) END
32000         END
32010     END;
32020 (**)
32030 (**)
32040 FUNCTION GETOUT(TARGETRN: DEPTHRANGE; TARGETLEB: OFFSETRANGE; MAP: BITMAP; LOOPS: INTEGER): ASNAKED;
32050 (*PGETOUT - EXIT FROM ROUTINES UNTIL TARGET IS REACHED.
32060   MAP IS THE STACK TO BE LEFT STANDING*)
32070   VAR CURR, NECLEV, IB: IPOINT;
32080       BITP: BITMAP;
32090       PTR: OBJECTPP;
32100       I: INTEGER;
32110       XMODE: INTEGER; IBTYPE: (A68, PUT, GET, OTHER);
32120       PVAL: OBJECTP;
32130       TEMPOINT: RECORD CASE SEVERAL OF
32140         0: (POINT: INTPOINT);
32150         1: (PPOINT: OBJECTPP);
32160         2,3,4,5,6,7,8,9,10: ();
32170         END;
32180       TEMP: NAKEGER;
32190     BEGIN
32200     CURR := STATIC(ME);
32210     REPEAT
32220       NECLEV := (*-05()STATIC( CURR )()-05*)(*+05()STATICP+192()+05*) ;
32230       WHILE (*-41()(NECLEV>CURR) AND (NECLEV<ME)()-41*)(*+41()(NECLEV<CURR) AND (NECLEV>ME)()+41*) DO
32240         (*BYPASS ANY STATIC LEVELS CREATED BY SETNSTATIC*)
32250         (*-05() NECLEV:=STATIC(NECLEV) ; ()-05*)
32260         (*+05() BEGIN SETMYSTATIC( NECLEV ) ; NECLEV := STATICP+192 END ; ()+05*)
32270       REPEAT
32280         REPEAT
32290           IF ISA68(CURR) THEN
32300             BEGIN
32310             IBTYPE := A68;
32320             BITP := BITPATTERN;
32330             END
32340           ELSE
32350             BEGIN BITP.COUNT := 0; BITP.MASK := 0;
32360             IF ISPUT(CURR) THEN IBTYPE := PUT
32370             ELSE IF ISGET(CURR) THEN IBTYPE := GET
32380             ELSE IBTYPE := OTHER;
32390             END;
32400 (*-02()   IB := CURR; ()-02*)
32410 (*+02()   IB := ARGBASE(CURR); ()+02*)
32420           PTR := ASPTR(IB);
32430           CURR := DYNAMIC(CURR);
32440           SETMYSTATIC(CURR);
32450           WITH BITP DO
32460             BEGIN
32470             IF (CURR=NECLEV) AND (LEVEL=TARGETRN) THEN (*THIS IS TARGET ROUTINE*)
32480               BEGIN
32490               COUNT := COUNT-MAP.COUNT;
32500               FOR I := 1 TO MAP.COUNT DIV SZWORD DO MASK := MASK*2
32510               END;
32520             IF MASK<>0 THEN
32530               BEGIN
32540               PTR := INCPTR( PTR, (*-41()- ()-41*)COUNT - PARAMOFFSET ) ;
32550               FOR I := 1 TO COUNT DIV SZWORD DO
32560                 BEGIN
32570 (*+41()         PTR := INCPTR(PTR, -SZWORD); ()+41*)
32580                 IF MASK<0 THEN IF FPTST(PTR^^) THEN GARBAGE(PTR^);
32590 (*-41()         PTR := INCPTR(PTR, SZWORD); ()-41*)
32600                 MASK := MASK*2
32610                 END
32620               END
32630             ELSE IF IBTYPE IN [PUT, GET] THEN WITH TEMPOINT DO (*DESTROY DATA LIST OF PUT OR GET*)
32640               BEGIN
32650               POINT := ASPTR(IB-DLOFFSET); BITP.COUNT := POINT^;
32660               POINT := INCPTR(POINT, (*-41()-()-41*) BITP.COUNT);
32670               WHILE ORD(POINT) (*-41()<()-41*)(*+41()>()+41*) IB-DLOFFSET DO
32680                 BEGIN
32690                 XMODE := POINT^;
32700 (*-41()         POINT := INCPTR(POINT, SZWORD); ()-41*)
32710                 IF IBTYPE=PUT THEN
32720                   BEGIN
32730                   CASE XMODE OF
32740                     4,7,11,12,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31:
32750                       BEGIN
32760 (*+41()               POINT := INCPTR(POINT, -SZADDR); ()+41*)
32770                       PVAL := PPOINT^;
32780 (*-41()               POINT := INCPTR(POINT, SZADDR); ()-41*)
32790                       WITH PVAL^ DO
32800                         BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
32810                       END;
32820 (*+61()             1,3,5: POINT := INCPTR(POINT, (*+41()-()+41*) SZLONG); ()+61*)
32830                     14: POINT := INCPTR(POINT, (*+41()-()+41*) SZPROC);
32840                     2: POINT := INCPTR(POINT, (*+41()-()+41*) SZREAL);
32850                     0,6,8,9,10: POINT := INCPTR(POINT, (*+41()-()+41*) SZINT);
32860                     -1: (*NO ACTION*);
32870                     END;
32880                   END
32890                 ELSE
32900                   IF XMODE IN [0..13,15..31] THEN
32910                     BEGIN
32920 (*+41()             POINT := INCPTR(POINT, -SZADDR); ()+41*)
32930                     PVAL := PPOINT^;
32940 (*-41()             POINT := INCPTR(POINT, SZADDR); ()-41*)
32950                     WITH PVAL^ DO
32960                       BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
32970                     END
32980                   ELSE IF XMODE=14 THEN POINT := INCPTR(POINT, (*+41()-()+41*) SZPROC);
32990 (*+41()         POINT := INCPTR(POINT, -SZWORD); ()+41*)
33000                 END;
33010 (*-01()
33020               POINT := INCPTR(POINT, (*-41()+SZWORD()-41*)(*+41()-SZADDR()+41*));
33030               PVAL := PPOINT^; (*PVAL = THE .REF.FILE PARAMETER OF PUT/GET*)
33040               WITH PVAL^ DO
33050                 BEGIN FDEC; IF FTST THEN GARBAGE(PVAL) END;
33060 ()-01*)
33070               END
33080             END
33090           UNTIL ISA68(CURR);
33100           IF (CURR=NECLEV) AND (LEVEL=TARGETRN) THEN (*THIS IS TARGET ROUTINE*)
33110             WHILE ORD(FIRSTRG.RIBOFFSET)-CURR (*-41()>()-41*)(*+41()< -()+41*) TARGETLEB DO
33120               BEGIN RANGEXT; IF FIRSTRG.RIBOFFSET^.FIRSTW.RECGEN<>NIL THEN DORECGEN END
33130           ELSE BEGIN
33140             WHILE FIRSTRG.RIBOFFSET^.RIBOFFSET<>FIRSTRG.RIBOFFSET DO
33150               BEGIN RANGEXT; IF FIRSTRG.RIBOFFSET^.FIRSTW.RECGEN<>NIL THEN DORECGEN END;
33160             RANGEXT; (*FOR PARAMETERS RANGE*)
33170             END;
33180       UNTIL CURR=NECLEV
33190     UNTIL LEVEL=TARGETRN;
33200     FIRSTRG.RIBOFFSET^.FIRSTW.LOOPCOUNT := LOOPS;
33210 (*+01() TEMP.ASNAK := 0; ()+01*)
33220     IF IBTYPE IN [PUT, GET] THEN
33230       TEMP.NAK.STOWEDVAL :=
33240         ASPTR(IB (*-41()(*-01()-SZADDR()-01*)-()-41*)(*+41()+SZWORD+SZADDR+()+41*) BITP.COUNT-DLOFFSET)
33250     ELSE
33260       TEMP.NAK.STOWEDVAL := ASPTR(IB (*-41()-()-41*)(*+41()+()+41*) BITP.COUNT-PARAMOFFSET);
33270     TEMP.NAK.POINTER := ASPTR(CURR);
33280     GETOUT := TEMP.ASNAK;
33290     END;
33300 (**)
33310 (**)
33320 PROCEDURE GBSTK(BITP: BITMAP);
33330 (*PGBSTK*)
33340   VAR PTR: OBJECTP;
33350       I: INTEGER;
33360     BEGIN WITH BITP DO
33370       BEGIN
33380       IF MASK<>0 THEN
33390         BEGIN
33400         I := COUNT;
33410         WHILE I>0 DO
33420           BEGIN
33430           I := I-SZWORD;
33440           IF MASK<0 THEN 
33450             BEGIN PTR := ASPTR(GETSTKTOP(SZADDR, I)); IF FPTST(PTR^) THEN GARBAGE(PTR) END;
33460           MASK := MASK*2
33470           END
33480         END;
33490       END
33500     END;
33510 (**)
33520 (**)
33530 (*-02()
33540   BEGIN
33550   END ;
33560 ()-02*)
33570 (*+01()
33580 BEGIN (*OF MAIN PROGRAM*)
33590 END (*OF EVERYTHING*).
33600 ()+01*)
