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*)