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

43 lines
1.3 KiB
OpenEdge ABL

34600 #include "rundecs.h"
34610 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
34620 (**)
34630 (**)
34640 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
34650 PROCEDURE ERRORR(N :INTEGER); EXTERN ;
34660 (**)
34670 (**)
34680 FUNCTION GTOTREF (NAK: NAKED; TEMPLATE: DPOINT): OBJECTP;
34690 (*PGETTOTAL+4*)
34700 VAR OFFSPRING: OBJECTP;
34710 BEGIN
34720 WITH NAK, STOWEDVAL^ DO
34730 BEGIN
34740 CASE SORT OF
34750 UNDEF:ERRORR(RSEL);
34760 NILL:ERRORR(RSELNIL);
34770 REFSL1, REFSLN, REFR, RECR, RECN, REFN:
34780 END;
34790 ENEW(OFFSPRING, REFSL1SIZE);
34800 WITH ANCESTOR^ DO FINC;
34810 WITH OFFSPRING^ DO
34820 BEGIN
34830 (*-02() FIRSTWORD := SORTSHIFT*ORD(REFSL1); ()-02*)
34840 (*+02() PCOUNT:=0; SORT:=REFSL1; ()+02*)
34850 (*+01() SECONDWORD := 0; ()+01*)
34860 ANCESTOR := STOWEDVAL^.ANCESTOR;
34870 OFFSET := POSITION;
34880 DBLOCK := TEMPLATE;
34890 OSCOPE := STOWEDVAL^.OSCOPE
34900 END;
34910 IF FTST THEN GARBAGE(STOWEDVAL)
34920 END; (*WITH*)
34930 GTOTREF := OFFSPRING
34940 END;
34950 (**)
34960 (**)
34970 (*-02() BEGIN END ; ()-02*)
34980 (*+01()
34990 BEGIN (*OF MAIN PROGRAM*)
35000 END (*OF EVERYTHING*).
35010 ()+01*)