282 lines
10 KiB
OpenEdge ABL
282 lines
10 KiB
OpenEdge ABL
30000 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
|
|
30010 (**)
|
|
30020 (**)
|
|
30030 (*+04()
|
|
30040 MODULE A68SIN;
|
|
30050 PROCEDURE DUMP;
|
|
30060 PRIVATE
|
|
30070 IMPORTS A68COM FROM A68DEC;
|
|
30080 ()+04*)
|
|
30090 (*+83() PROCEDURE INITIALIZE; FORWARD; ()+83*)
|
|
30100 (*+85() PROCEDURE STANDARDPRELUDE; FORWARD; ()+85*)
|
|
30110 (*+82() PROCEDURE PARSEPARSER; FORWARD; ()+82*)
|
|
30120 (*+85() PROCEDURE INITSEMANTICS; FORWARD; ()+85*)
|
|
30130 (*+01() PROCEDURE INITBEGIN; FORWARD; ()+01*)
|
|
30140 (*+86() PROCEDURE INITCODES; FORWARD; ()+86*)
|
|
30150 PROCEDURE SIN;
|
|
30160 BEGIN
|
|
30170 (*+83() INITIALIZE; ()+83*)
|
|
30180 (*+82() PARSEPARSER; ()+82*)
|
|
30190 (*+85() STANDARDPRELUDE; ()+85*)
|
|
30200 (*+85() INITSEMANTICS; ()+85*)
|
|
30210 (*+01() INITBEGIN; ()+01*)
|
|
30220 (*+86() INITCODES; ()+86*)
|
|
30230 END;
|
|
30240 (**)
|
|
30250 (**)
|
|
30260 (**)
|
|
30270 (**)
|
|
30280 (*+01()
|
|
30290 FUNCTION PFL: INTEGER;
|
|
30300 (*OBTAIN FIELD LENGTH FROM GLOBAL P.FL*)
|
|
30310 EXTERN;
|
|
30320 (**)
|
|
30330 (**)
|
|
30340 FUNCTION PFREE: PINTEGER;
|
|
30350 (*OBTAIN ADDRESS OF GLOBAL P.FREE*)
|
|
30360 EXTERN;
|
|
30370 (**)
|
|
30380 (**)
|
|
30390 (*$T-+)
|
|
30400 PROCEDURE DUMP(VAR START: INTEGER);
|
|
30410 (*DUMPS STACK AND HEAP ONTO FILE DUMPF.
|
|
30420 START IS FIRST VARIABLE ON STACK TO BE DUMPED*)
|
|
30430 CONST TWO30=10000000000B;
|
|
30440 FREEINIT=40000000000000000000B; (*INITIAL VALUE OF P.FREE*)
|
|
30450 VAR F1: FILE OF INTEGER;
|
|
30460 STACKSTART, STACKLENGTH, HEAPSTART, HEAPLENGTH: INTEGER;
|
|
30470 FRIG: RECORD CASE INTEGER OF
|
|
30480 1:(INT: INTEGER); 2:(POINT: PINTEGER) END;
|
|
30490 D: DUMPOBJ;
|
|
30500 MASKM,MASKL: INTEGER;
|
|
30510 I: INTEGER;
|
|
30520 BEGIN
|
|
30530 FRIG.INT := GETB(5)+3; STACKSTART := FRIG.POINT^;
|
|
30540 STACKLENGTH := GETB(5)-STACKSTART;
|
|
30550 FOR I := STACKSTART TO STACKSTART+STACKLENGTH-1 DO
|
|
30560 BEGIN FRIG.INT := I; FRIG.POINT^ := 40000000000000000000B END; (*CLEAR STACK*)
|
|
30570 FOR I := GETB(6) TO PFL-1 DO
|
|
30580 BEGIN FRIG.INT := I; FRIG.POINT^ := 0 END; (*CLEAR SPACE BETWEEN STACK AND HEAPTOP*)
|
|
30590 SIN;
|
|
30600 HEAPSTART := GETB(4); HEAPLENGTH := PFL-HEAPSTART;
|
|
30610 FRIG.POINT := PFREE; START := FRIG.POINT^; (*STORE P.FREE ON STACK FOR DUMPING*)
|
|
30620 WRITELN(' STACK SIZE =', STACKLENGTH); WRITELN(' HEAP SIZE =', HEAPLENGTH);
|
|
30630 REWRITE(F1);
|
|
30640 FOR I := STACKSTART TO STACKSTART+STACKLENGTH-1 DO
|
|
30650 BEGIN FRIG.INT := I; WRITE(F1, FRIG.POINT^) END;
|
|
30660 FOR I := HEAPSTART TO HEAPSTART+HEAPLENGTH-1 DO
|
|
30670 BEGIN FRIG.INT := I; WRITE(F1, FRIG.POINT^) END;
|
|
30680 WRITELN(' F1 WRITTEN');
|
|
30690 (**)
|
|
30700 (*NOW CLEAR THE HEAP AND REINITIALIZE IT ONE WORD DOWN*)
|
|
30710 SETB(4, PFL-1); FRIG.POINT := PFREE; FRIG.POINT^ := FREEINIT;
|
|
30720 FOR I := STACKSTART TO STACKSTART+STACKLENGTH-1 DO
|
|
30730 BEGIN FRIG.INT := I; FRIG.POINT^ := 40000000000000000000B END;
|
|
30740 FOR I := GETB(6) TO PFL-1 DO
|
|
30750 BEGIN FRIG.INT := I; FRIG.POINT^ := 0 END;
|
|
30760 SIN;
|
|
30770 FRIG.POINT := PFREE; START := FRIG.POINT^;
|
|
30780 RESET(F1); REWRITE(A68INIT);
|
|
30790 D.INT := STACKLENGTH; D.MASK := HEAPLENGTH; WRITE(A68INIT, D.INT, D.MASK);
|
|
30800 FOR I := STACKSTART TO STACKSTART+STACKLENGTH-1 DO
|
|
30810 BEGIN
|
|
30820 READ(F1, D.INT);
|
|
30830 FRIG.INT := I; D.MASK := D.INT-FRIG.POINT^;
|
|
30840 (*D.MASK CONTAINS A 1 AT THE LS END OF EACH ^ FIELD OF D.INT*)
|
|
30850 (*NOW WE HAVE TO MULTIPLE D.MASK BY HEAPSTART*)
|
|
30860 MASKM := D.MASK DIV TWO30; MASKL := D.MASK-MASKM*TWO30;
|
|
30870 MASKM := MASKM*HEAPSTART; MASKL := MASKL*HEAPSTART;
|
|
30880 D.INT := D.INT-MASKM*TWO30-MASKL;
|
|
30890 WRITE(A68INIT, D.INT, D.MASK)
|
|
30900 END;
|
|
30910 FOR I := HEAPSTART TO HEAPSTART+HEAPLENGTH-1 DO
|
|
30920 BEGIN
|
|
30930 READ(F1, D.INT);
|
|
30940 FRIG.INT := I-1; D.MASK := D.INT-FRIG.POINT^;
|
|
30950 MASKM := D.MASK DIV TWO30; MASKL := D.MASK-MASKM*TWO30;
|
|
30960 MASKM := MASKM*HEAPSTART; MASKL := MASKL*HEAPSTART;
|
|
30970 D.INT := D.INT-MASKM*TWO30-MASKL;
|
|
30980 WRITE(A68INIT, D.INT, D.MASK)
|
|
30990 END;
|
|
31000 WRITELN(' A68INIT WRITTEN');
|
|
31010 (**)
|
|
31020 (*FINALLY, CLEAR THE HEAP AGAIN*)
|
|
31030 SETB(4, PFL); FRIG.POINT := PFREE; FRIG.POINT^ := FREEINIT
|
|
31040 END;
|
|
31050 ()+01*)
|
|
31060 (**)
|
|
31070 (**)
|
|
31080 (*-11()
|
|
31090 PROCEDURE STASHLEX(A1: ALFA);
|
|
31100 VAR I: INTEGER;
|
|
31110 BEGIN
|
|
31120 WITH CURRENTLEX DO
|
|
31130 BEGIN S10 := A1;
|
|
31140 I := 10; REPEAT I := I+1 ; STRNG[I] := ' ' UNTIL I MOD CHARPERWORD = 0;
|
|
31150 WHILE STRNG[I]=' ' DO I := I-1;
|
|
31160 LXCOUNT := (I+CHARPERWORD-1) DIV CHARPERWORD;
|
|
31170 END
|
|
31180 END;
|
|
31190 (**)
|
|
31200 (**)
|
|
31210 PROCEDURE STASHLLEX(A1, A2: ALFA);
|
|
31220 VAR I: INTEGER;
|
|
31230 BEGIN
|
|
31240 WITH CURRENTLEX DO
|
|
31250 BEGIN S10 := A1;
|
|
31251 FOR I := 11 TO 20 DO STRNG[I] := A2[I-10];
|
|
31260 I := 20; REPEAT I := I+1; STRNG[I] := ' ' UNTIL I MOD CHARPERWORD = 0;
|
|
31270 WHILE STRNG[I]=' ' DO I := I-1;
|
|
31280 LXCOUNT := (I+CHARPERWORD-1) DIV CHARPERWORD;
|
|
31290 END
|
|
31300 END;
|
|
31310 ()-11*)
|
|
31320 (**)
|
|
31330 (**)
|
|
31340 (*-01() (*-03() (*-04()
|
|
31350 FUNCTION GETADDRESS(VAR VARIABLE:INTEGER): ADDRINT; EXTERN;
|
|
31360 (**)
|
|
31370 PROCEDURE RESTORE(VAR START,FINISH: INTEGER);
|
|
31380 VAR STACKSTART,STACKEND,GLOBALLENGTH,HEAPLENGTH,
|
|
31390 HEAPSTART(*+19(),LENGTH,POINTER()+19*): ADDRINT;
|
|
31395 I:INTEGER;
|
|
31400 P: PINTEGER;
|
|
31410 FRIG: RECORD CASE SEVERAL OF
|
|
31420 1: (INT: ADDRINT);
|
|
31421 2: (POINT: PINTEGER);
|
|
31422 3: (PLEXP: PLEX);
|
|
31423 (*+19() 4: (APOINT: ^ADDRINT); ()+19*)
|
|
31424 (*-19()4,()-19*)5,6,7,8,9,10: ()
|
|
31430 END;
|
|
31440 D: RECORD INT,MASK: INTEGER END;
|
|
31450 BEGIN
|
|
31459 (*+05()
|
|
31460 OPENLOADFILE(A68INIT, 4, FALSE);
|
|
31461 ()+05*)
|
|
31470 STACKSTART := GETADDRESS(START);
|
|
31480 IF NOT EOF(A68INIT) THEN
|
|
31490 BEGIN
|
|
31500 READ(A68INIT,GLOBALLENGTH,HEAPLENGTH);
|
|
31510 ENEW(FRIG.PLEXP, HEAPLENGTH);
|
|
31520 HEAPSTART := FRIG.INT;
|
|
31530 FRIG.INT := STACKSTART;
|
|
31535 (*-19()
|
|
31540 FOR I := 1 TO GLOBALLENGTH DIV SZWORD DO
|
|
31550 BEGIN
|
|
31560 READ(A68INIT,D.INT,D.MASK);
|
|
31570 IF D.MASK=SZREAL THEN (*D.INT IS A POINTER OFFSET FROM HEAPSTART*)
|
|
31580 D.INT := D.INT+HEAPSTART;
|
|
31590 FRIG.POINT^ := D.INT;
|
|
31600 FRIG.INT := FRIG.INT+SZWORD;
|
|
31610 END;
|
|
31620 FRIG.INT := HEAPSTART;
|
|
31630 FOR I := 1 TO HEAPLENGTH DIV SZWORD DO
|
|
31640 BEGIN
|
|
31642 READ(A68INIT,D.INT,D.MASK);
|
|
31644 IF D.MASK=SZREAL THEN
|
|
31646 D.INT := D.INT+HEAPSTART;
|
|
31648 FRIG.POINT^ := D.INT;
|
|
31650 FRIG.INT := FRIG.INT+SZWORD
|
|
31652 END
|
|
31654 ()-19*)
|
|
31659 (*+19()
|
|
31660 LENGTH:=GLOBALLENGTH DIV SZWORD;
|
|
31662 I:=1;
|
|
31664 WHILE I<=LENGTH DO
|
|
31666 BEGIN
|
|
31668 READ(A68INIT,D.MASK);
|
|
31670 IF D.MASK=SZADDR+SZWORD THEN (*IT IS A POINTER*)
|
|
31672 BEGIN
|
|
31674 READ(A68INIT,POINTER);
|
|
31676 POINTER:=POINTER+HEAPSTART;
|
|
31678 FRIG.APOINT^:=POINTER;
|
|
31680 FRIG.INT:=FRIG.INT+SZWORD+SZWORD; (*POINTER IS 2 WORDS *)
|
|
31682 I:=I+2
|
|
31684 END
|
|
31686 ELSE
|
|
31688 BEGIN
|
|
31690 READ(A68INIT,D.INT);
|
|
31691 FRIG.POINT^:=D.INT;
|
|
31692 FRIG.INT:=FRIG.INT+SZWORD;
|
|
31693 I:=I+1
|
|
31694 END
|
|
31695 END;
|
|
31696 LENGTH:=HEAPLENGTH DIV SZWORD;
|
|
31697 FRIG.INT:=HEAPSTART;
|
|
31698 I:=1;
|
|
31699 WHILE I<=LENGTH DO
|
|
31700 BEGIN
|
|
31701 READ(A68INIT,D.MASK);
|
|
31702 IF D.MASK=SZADDR+SZWORD THEN (*IT IS A POINTER*)
|
|
31703 BEGIN
|
|
31704 READ(A68INIT,POINTER);
|
|
31705 POINTER:=POINTER+HEAPSTART;
|
|
31706 FRIG.APOINT^:=POINTER;
|
|
31707 FRIG.INT:=FRIG.INT+SZWORD+SZWORD; (*POINTER IS 2 WORDS *)
|
|
31708 I:=I+2
|
|
31709 END
|
|
31710 ELSE
|
|
31711 BEGIN
|
|
31712 READ(A68INIT,D.INT);
|
|
31713 FRIG.POINT^:=D.INT;
|
|
31714 FRIG.INT:=FRIG.INT+SZWORD;
|
|
31715 I:=I+1
|
|
31716 END
|
|
31717 END
|
|
31718 ()+19*)
|
|
31719 END
|
|
31720 END;
|
|
31730 PROCEDURE DUMP(VAR START,FINISH: INTEGER);
|
|
31740 VAR STACKSTART,STACKEND,GLOBALLENGTH,
|
|
31750 HEAPLENGTH,HEAPSTART: ADDRINT;
|
|
31755 I:INTEGER;
|
|
31760 P: PINTEGER;
|
|
31770 FRIG: RECORD CASE SEVERAL OF
|
|
31780 1: (INT:ADDRINT); 2: (POINT:PINTEGER);
|
|
31790 3: (PLEXP: PLEX); 4,5,6,7,8,9,10: ()
|
|
31800 END;
|
|
31810 D: RECORD INT,MASK: INTEGER END;
|
|
31830 (**)
|
|
31840 BEGIN (* DUMP *)
|
|
31850 REWRITE(LSTFILE);WRITELN(LSTFILE,' START DUMP');
|
|
31860 (*+05()
|
|
31870 OPENLOADFILE(DUMPF, 5, TRUE);
|
|
31871 ()+05*)
|
|
31880 IF EOF(LGO) THEN ENEW(FRIG.PLEXP,SZREAL)
|
|
31890 ELSE ENEW(FRIG.PLEXP,2*SZREAL);
|
|
31900 NEW(FRIG.POINT); (*-02() DISPOSE(FRIG.POINT); ()-02*)
|
|
31910 HEAPSTART := FRIG.INT;
|
|
31920 RESTORE(START,FINISH);
|
|
31930 SIN;
|
|
31935 (*-02()
|
|
31940 NEW(FRIG.POINT); DISPOSE(FRIG.POINT);
|
|
31941 ()-02*)
|
|
31943 (*+02()
|
|
31945 ENEW(FRIG.POINT,100); (* TO MAKE SURE IT GOES AT THE END *)
|
|
31947 ()+02*)
|
|
31950 HEAPLENGTH := FRIG.INT-HEAPSTART;
|
|
31960 STACKSTART := GETADDRESS(START);
|
|
31970 STACKEND := GETADDRESS(FINISH);
|
|
31980 GLOBALLENGTH := STACKEND-STACKSTART;
|
|
31990 WRITE(DUMPF,GLOBALLENGTH,HEAPLENGTH,HEAPSTART);
|
|
32000 FRIG.INT := STACKSTART;
|
|
32010 FOR I := 1 TO ABS(GLOBALLENGTH) DIV SZWORD DO
|
|
32020 BEGIN
|
|
32030 WRITE(DUMPF,FRIG.POINT^);
|
|
32040 FRIG.INT := FRIG.INT+SZWORD*(ORD(GLOBALLENGTH>0)*2-1);
|
|
32050 END;
|
|
32060 FRIG.INT := HEAPSTART;
|
|
32070 FOR I := 1 TO ABS(HEAPLENGTH) DIV SZWORD DO
|
|
32080 BEGIN
|
|
32090 WRITE(DUMPF,FRIG.POINT^);
|
|
32100 FRIG.INT := FRIG.INT+SZWORD*(ORD(HEAPLENGTH>0)*2-1);
|
|
32110 END;
|
|
32120 WRITELN(LSTFILE,' DUMPF WRITTEN');
|
|
32130 (**)
|
|
32140 WRITELN(LSTFILE,' GLOBAL LENGTH',GLOBALLENGTH,' HEAP LENGTH',HEAPLENGTH);
|
|
32150 END;
|
|
32160 ()-04*) ()-03*) ()-01*)
|
|
32170 (*-01() (*-02() (*-05()
|
|
32180 PROCEDURE DUMP(VAR START, FINISH: INTEGER);
|
|
32190 BEGIN SIN END;
|
|
32200 ()-05*) ()-02*) ()-01*)
|