ack/lang/a68s/liba68s/routn.p

41 lines
1.1 KiB
OpenEdge ABL
Raw Permalink Normal View History

1988-10-04 13:41:01 +00:00
44100 #include "rundecs.h"
44110 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
44120 (**)
44130 (**)
44140 FUNCTION ROUTNA (PROC:PROCPOINT;ENV:IPOINT):OBJECTP;
44150 VAR NEWRT:OBJECTP;
44160 BEGIN
44170 ENEW(NEWRT, ROUTINESIZE);
44180 WITH NEWRT^ DO
44190 BEGIN
44200 (*-02() FIRSTWORD := SORTSHIFT * ORD(ROUTINE); ()-02*)
44210 (*+02() PCOUNT:=0; SORT:=ROUTINE; ()+02*)
44220 PROCBL:=PROC;
44230 ENVCHAIN:=ENV;
44240 SETMYSTATIC(ENV);
44250 OSCOPE:=SCOPE+PROC^.SCOFFSET;
44260 END;
44270 ROUTNA:= NEWRT
44280 END;
44290 (**)
44300 (**)
44310 FUNCTION ROUTN (PROC: PROCPOINT): OBJECTP;
44320 (* PLOADRT: CONSTRUCTS ROUTINE VALUE FOR GIVEN PROCBL;
44330 RETURNS POINTER TO NEW ROUTINEBLOCK; KK 13.5.1977 *)
44340 VAR I: INTEGER;
44350 BEGIN
44360 FOR I := LEVEL-1 DOWNTO PROC^.SCOPELEVEL DO
44370 SETMYSTATIC( (*-05()STATIC()-05*)(*+05()A68STATIC()+05*) ( STATIC( ME ) ) );
44380 ROUTN := ROUTNA(PROC,STATIC(ME));
44390 END;
44400 (**)
44410 (**)
44420 (*-02()
44430 BEGIN
44440 END ;
44450 ()-02*)
44460 (*+01()
44470 BEGIN (*OF MAIN PROGRAM*)
44480 END (*OF EVERYTHING*).
44490 ()+01*)