181 lines
7.4 KiB
OpenEdge ABL
181 lines
7.4 KiB
OpenEdge ABL
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*)
|