557 lines
21 KiB
OpenEdge ABL
557 lines
21 KiB
OpenEdge ABL
|
08000 #include "rundecs.h"
|
||
|
|
08010 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
|
||
|
|
08020 (**)
|
||
|
|
08030 (*+01() (*$X6*) ()+01*)
|
||
|
|
08040 PROCEDURE STANDINC(PCOV: OBJECTP; LFN: LFNTYPE); EXTERN;
|
||
|
|
08050 PROCEDURE STANDOUT(PCOV: OBJECTP; LFN: LFNTYPE); EXTERN;
|
||
|
|
08060 PROCEDURE STANDBAC(PCOV: OBJECTP; LFN: LFNTYPE); EXTERN;
|
||
|
|
08070 (*+01() (*$X4*) ()+01*)
|
||
|
|
08080 PROCEDURE CL68(PB: ASNAKED; RF: OBJECTP); EXTERN;
|
||
|
|
08090 PROCEDURE ERRORR(N: INTEGER); EXTERN;
|
||
|
|
08100 (*+05() FUNCTION TIME: REAL; EXTERN; ()+05*)
|
||
|
|
08110 PROCEDURE CALLPASC ; EXTERN;
|
||
|
|
08120 PROCEDURE ABORT; EXTERN;
|
||
|
|
08130 (*+02()
|
||
|
|
08140 PROCEDURE ACLS(FIL: FETROOMP); EXTERN;
|
||
|
|
08150 PROCEDURE STOPEN (VAR PF: FYL; VAR RF: OBJECTP; LFN: LFNTYPE; PROCEDURE CH(COV:OBJECTP;L:LFNTYPE) ); EXTERN;
|
||
|
|
08160 ()+02*)
|
||
|
|
08170 (*+01() (*$X6*) ()+01*)
|
||
|
|
08180 FUNCTION PROC(PROCEDURE P):ASPROC;EXTERN;
|
||
|
|
08190 (*-01()
|
||
|
|
08200 FUNCTION PROCH( PROCEDURE P( COV: OBJECTP ; L: LFNTYPE ) ): ASPROC ; EXTERN ;
|
||
|
|
08210 ()-01*)
|
||
|
|
08220 (*+01() (*$X4*) ()+01*)
|
||
|
|
08230 (**)
|
||
|
|
08240 (*+24()
|
||
|
|
08250 PROCEDURE FINDSORT(POINT: OBJECTP; VAR GETSORT: ALFA);
|
||
|
|
08260 BEGIN
|
||
|
|
08270 (*+01() (*$T-*) ()+01*)
|
||
|
|
08280 CASE POINT^.SORT OF
|
||
|
|
08290 STRUCT: GETSORT:='STRUCT ';
|
||
|
|
08300 MULT: GETSORT:='MULT ';
|
||
|
|
08310 IELS: GETSORT:='IELS ';
|
||
|
|
08320 ROUTINE:GETSORT:='ROUTINE ';
|
||
|
|
08330 REF1: GETSORT:='REF1 ';
|
||
|
|
08340 REF2: GETSORT:='REF2 ';
|
||
|
|
08350 REFN: GETSORT:='REFN ';
|
||
|
|
08360 CREF: GETSORT:='CREF ';
|
||
|
|
08370 REFR: GETSORT:='REFR ';
|
||
|
|
08380 REFSL1: GETSORT:='REFSL1 ';
|
||
|
|
08390 REFSLN: GETSORT:='REFSLN ';
|
||
|
|
08400 RECR: GETSORT:='RECR ';
|
||
|
|
08410 RECN: GETSORT:='RECN ';
|
||
|
|
08420 UNDEF: GETSORT:='UNDEF ';
|
||
|
|
08430 NILL: GETSORT:='NILL ';
|
||
|
|
08440 STRING: GETSORT:='STRING ';
|
||
|
|
08450 END
|
||
|
|
08460 END;
|
||
|
|
08470 (**)
|
||
|
|
08480 (**)
|
||
|
|
08490 PROCEDURE PRINTSORT(POINT: OBJECTP);
|
||
|
|
08500 BEGIN
|
||
|
|
08510 CASE POINT^.SORT OF
|
||
|
|
08520 STRUCT: WRITE('STRUCT');
|
||
|
|
08530 MULT: WRITE('MULT');
|
||
|
|
08540 IELS: WRITE('IELS');
|
||
|
|
08550 ROUTINE:WRITE('ROUTINE');
|
||
|
|
08560 REF1: WRITE('REF1');
|
||
|
|
08570 REF2: WRITE('REF2');
|
||
|
|
08580 REFN: WRITE('REFN');
|
||
|
|
08590 CREF: WRITE('CREF');
|
||
|
|
08600 REFR: WRITE('REFR');
|
||
|
|
08610 REFSL1: WRITE('REFSL1');
|
||
|
|
08620 REFSLN: WRITE('REFSLN');
|
||
|
|
08630 RECR: WRITE('RECR');
|
||
|
|
08640 RECN: WRITE('RECN');
|
||
|
|
08650 UNDEF: WRITE('UNDEF');
|
||
|
|
08660 NILL: WRITE('NILL');
|
||
|
|
08670 END;
|
||
|
|
08680 WRITELN(' SORT');
|
||
|
|
08690 (* ( $T+ ) *)
|
||
|
|
08700 END;
|
||
|
|
08710 (**)
|
||
|
|
08720 (**)
|
||
|
|
08730 PROCEDURE PRINTDESC(ADESC: OBJECTP);
|
||
|
|
08740 VAR I:INTEGER;
|
||
|
|
08750 BEGIN
|
||
|
|
08760 WITH ADESC^ DO
|
||
|
|
08770 BEGIN
|
||
|
|
08780 WRITE('SIZ',SIZE:2,' D0',D0:2,' LBJ',LBADJ:2);
|
||
|
|
08790 WRITE(' LIUIDI');
|
||
|
|
08800 FOR I := 0 TO ROWS DO WITH DESCVEC[I] DO
|
||
|
|
08810 WRITE(LI:2, UI:2, DI:2);
|
||
|
|
08820 WRITELN
|
||
|
|
08830 END;
|
||
|
|
08840 END;
|
||
|
|
08850 ()+24*)
|
||
|
|
08860 (**)
|
||
|
|
08870 (**)
|
||
|
|
08880 FUNCTION CRSTRING(LENGTH: OFFSETRANGE): OBJECTP;
|
||
|
|
08890 VAR POINT :OBJECTP;
|
||
|
|
08900 PTR: UNDRESSP;
|
||
|
|
08910 BEGIN
|
||
|
|
08920 IF LENGTH<0 THEN LENGTH := 0;
|
||
|
|
08930 ENEW(POINT, STRINGCONST+((LENGTH + CHARPERWORD - 1) DIV CHARPERWORD)*SZWORD);
|
||
|
|
08940 (*-02() POINT^.FIRSTWORD := SORTSHIFT * ORD(STRING); ()-02*)
|
||
|
|
08950 (*+02() POINT^.PCOUNT:=0; POINT^.SORT:=STRING; ()+02*)
|
||
|
|
08960 POINT^.STRLENGTH := LENGTH;
|
||
|
|
08970 PTR := INCPTR(POINT, STRINGCONST+((LENGTH-1) DIV CHARPERWORD)*SZWORD);
|
||
|
|
08980 IF LENGTH<>0 THEN PTR^.FIRSTWORD := 0;
|
||
|
|
08990 CRSTRING := POINT
|
||
|
|
09000 END;
|
||
|
|
09010 (**)
|
||
|
|
09020 (**)
|
||
|
|
09030 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP;
|
||
|
|
09040 VAR NEWSTRUCT: OBJECTP;
|
||
|
|
09050 TEMPOS, STRUCTPOS, STRUCTSIZE, COUNT: INTEGER;
|
||
|
|
09060 PTR, PTR1: UNDRESSP;
|
||
|
|
09070 BEGIN
|
||
|
|
09080 STRUCTSIZE:= TEMPLATE^[0];
|
||
|
|
09090 ENEW(NEWSTRUCT, STRUCTSIZE+STRUCTCONST);
|
||
|
|
09100 WITH NEWSTRUCT^ DO
|
||
|
|
09110 BEGIN
|
||
|
|
09120 (*-02() FIRSTWORD := SORTSHIFT * ORD(STRUCT); ()-02*)
|
||
|
|
09130 (*+02() PCOUNT:=0; SORT:=STRUCT; ()+02*)
|
||
|
|
09140 (*+01() SECONDWORD := 0; ()+01*)
|
||
|
|
09150 OSCOPE := 0 ;
|
||
|
|
09160 LENGTH := STRUCTSIZE+STRUCTCONST;
|
||
|
|
09170 DBLOCK:= TEMPLATE;
|
||
|
|
09180 PTR := INCPTR(NEWSTRUCT, STRUCTCONST);
|
||
|
|
09190 PTR^.FIRSTWORD := INTUNDEF;
|
||
|
|
09200 PTR1 := INCPTR(PTR, SZWORD);
|
||
|
|
09210 MOVELEFT(PTR, PTR1, STRUCTSIZE-SZWORD);
|
||
|
|
09220 TEMPOS:= 1;
|
||
|
|
09230 STRUCTPOS := TEMPLATE^[1];
|
||
|
|
09240 WHILE STRUCTPOS >= 0
|
||
|
|
09250 DO BEGIN
|
||
|
|
09260 PTR := INCPTR(NEWSTRUCT, STRUCTCONST+STRUCTPOS);
|
||
|
|
09270 PTR^.FIRSTPTR := UNDEFIN;
|
||
|
|
09280 TEMPOS:= TEMPOS+1;
|
||
|
|
09290 STRUCTPOS := TEMPLATE^[TEMPOS];
|
||
|
|
09300 END;
|
||
|
|
09310 END;
|
||
|
|
09320 CRSTRUCT := NEWSTRUCT
|
||
|
|
09330 END;
|
||
|
|
09340 (**)
|
||
|
|
09350 (**)
|
||
|
|
09360 PROCEDURE GARBAGE(ANOBJECT:OBJECTP); FORWARD;
|
||
|
|
09370 (**)
|
||
|
|
09380 (**)
|
||
|
|
09390 (*+02()
|
||
|
|
09400 PROCEDURE ACLOSE(EFET: FETROOMP);
|
||
|
|
09410 VAR NAME:OBJECTP;
|
||
|
|
09420 BEGIN
|
||
|
|
09430 WITH EFET^ DO
|
||
|
|
09440 IF UFD>2 THEN (*USER'S FILE*)
|
||
|
|
09450 BEGIN NAME := INCPTR(FNAME, -STRINGCONST);
|
||
|
|
09460 FPDEC(NAME^); IF FPTST(NAME^) THEN GARBAGE(NAME);
|
||
|
|
09470 END;
|
||
|
|
09480 ACLS(EFET);
|
||
|
|
09490 END;
|
||
|
|
09500 ()+02*)
|
||
|
|
09510 PROCEDURE GARBAGE(* (ANOBJECT: OBJECTP) *) ;
|
||
|
|
09520 LABEL 1;
|
||
|
|
09530 VAR ASINT: INTEGER;
|
||
|
|
09540 BACK, HEAD: OBJECTP; TEMPLATE: DPOINT;
|
||
|
|
09550 TEMP: OBJECTP;
|
||
|
|
09560 PTR: UNDRESSP;
|
||
|
|
09570 ELSIZE, SIZEACC, COUNT, STRUCTPOS, TEMPOS: INTEGER;
|
||
|
|
09580 ISHEAD: BOOLEAN;
|
||
|
|
09590 GETSORT: ALFA;
|
||
|
|
09600 PFET: FETROOMP;
|
||
|
|
09610 BEGIN
|
||
|
|
09620 (*+24()(*BUGFILE
|
||
|
|
09630 FINDSORT(ANOBJECT, GETSORT);
|
||
|
|
09640 WRITELN(BUGFILE, 'GARBGE', GETSORT, 'AT', ORD(ANOBJECT):(*-01()1()-01*)(*+01()6 OCT()+01*) ,
|
||
|
|
09650 'C=', ANOBJECT^.PCOUNT:4);
|
||
|
|
09660 BUGFILE*)()+24*)
|
||
|
|
09670 1: WITH ANOBJECT^ DO
|
||
|
|
09680 BEGIN
|
||
|
|
09690 (*+01() IF ORD(ANOBJECT)=0 THEN HALT; (*FOR CATCHING BUGS - SHOULDN'T HAPPEN*) ()+01*)
|
||
|
|
09700 CASE SORT OF
|
||
|
|
09710 STRUCT:
|
||
|
|
09720 BEGIN
|
||
|
|
09730 TEMPLATE:= DBLOCK;
|
||
|
|
09740 TEMPOS:= 1;
|
||
|
|
09750 STRUCTPOS:= TEMPLATE^[1];
|
||
|
|
09760 WHILE STRUCTPOS>=0 DO
|
||
|
|
09770 BEGIN
|
||
|
|
09780 PTR := INCPTR(ANOBJECT, STRUCTCONST+STRUCTPOS);
|
||
|
|
09790 WITH PTR^.FIRSTPTR^ DO
|
||
|
|
09800 BEGIN FDEC; IF FTST THEN GARBAGE(PTR^.FIRSTPTR) END;
|
||
|
|
09810 TEMPOS:= TEMPOS+1;
|
||
|
|
09820 STRUCTPOS:= TEMPLATE^[TEMPOS]
|
||
|
|
09830 END;
|
||
|
|
09840 EDISPOSE(ANOBJECT, LENGTH)
|
||
|
|
09850 END;
|
||
|
|
09860 IELS:
|
||
|
|
09870 BEGIN
|
||
|
|
09880 TEMPLATE := DBLOCK;
|
||
|
|
09890 IF ORD(TEMPLATE)<=MAXSIZE (*NOT STRUCT*) THEN
|
||
|
|
09900 BEGIN
|
||
|
|
09910 IF ORD(TEMPLATE)=0 (*DRESSED*) THEN
|
||
|
|
09920 BEGIN
|
||
|
|
09930 PTR := INCPTR(ANOBJECT, ELSCONST);
|
||
|
|
09940 WHILE ORD(PTR)<ORD(ANOBJECT)+ELSCONST+D0 DO
|
||
|
|
09950 BEGIN
|
||
|
|
09960 WITH PTR^.FIRSTPTR^ DO
|
||
|
|
09970 BEGIN
|
||
|
|
09980 FDEC;
|
||
|
|
09990 IF FTST THEN GARBAGE(PTR^.FIRSTPTR)
|
||
|
|
10000 END;
|
||
|
|
10010 PTR := INCPTR(PTR, SZADDR)
|
||
|
|
10020 END
|
||
|
|
10030 END
|
||
|
|
10040 END
|
||
|
|
10050 ELSE BEGIN (*UNDRESSED STRUCTURES*)
|
||
|
|
10060 ELSIZE:= TEMPLATE^[0];
|
||
|
|
10070 IF TEMPLATE^[1] >= 0 THEN
|
||
|
|
10080 BEGIN
|
||
|
|
10090 COUNT:= D0;
|
||
|
|
10100 ASINT:= ELSCONST;
|
||
|
|
10110 WHILE COUNT>0 DO
|
||
|
|
10120 BEGIN
|
||
|
|
10130 TEMPOS := 1;
|
||
|
|
10140 STRUCTPOS := TEMPLATE^[1];
|
||
|
|
10150 WHILE STRUCTPOS>=0 DO
|
||
|
|
10160 BEGIN
|
||
|
|
10170 PTR := INCPTR(ANOBJECT, ASINT+STRUCTPOS);
|
||
|
|
10180 WITH PTR^.FIRSTPTR^ DO
|
||
|
|
10190 BEGIN FDEC;
|
||
|
|
10200 IF FTST THEN GARBAGE(PTR^.FIRSTPTR)
|
||
|
|
10210 END;
|
||
|
|
10220 TEMPOS := TEMPOS+1;
|
||
|
|
10230 STRUCTPOS := TEMPLATE^[TEMPOS]
|
||
|
|
10240 END;
|
||
|
|
10250 ASINT:= ASINT+ELSIZE;
|
||
|
|
10260 COUNT:= COUNT-ELSIZE
|
||
|
|
10270 END
|
||
|
|
10280 END
|
||
|
|
10290 END;
|
||
|
|
10300 EDISPOSE(ANOBJECT, ELSCONST+D0)
|
||
|
|
10310 END;
|
||
|
|
10320 MULT:
|
||
|
|
10330 (*ASSERT: THIS MULTIPLE IS NOT SLICED*)
|
||
|
|
10340 IF PVALUE=NIL (* A BOUNDS BLOCK *) THEN
|
||
|
|
10350 EDISPOSE(ANOBJECT, MULTCONST+(ROWS+1)*SZPDS)
|
||
|
|
10360 ELSE
|
||
|
|
10370 BEGIN
|
||
|
|
10380 BACK := BPTR;
|
||
|
|
10390 IF BACK<>NIL THEN
|
||
|
|
10400 BEGIN (*NOT SLICED BUT A SLICE*)
|
||
|
|
10410 HEAD:= FPTR;
|
||
|
|
10420 IF ANOBJECT<>BACK^.IHEAD THEN
|
||
|
|
10430 BEGIN (*NOT FIRST SLICE*)
|
||
|
|
10440 BACK^.FPTR:= HEAD;
|
||
|
|
10450 IF HEAD<>NIL THEN
|
||
|
|
10460 HEAD^.BPTR:= BACK
|
||
|
|
10470 END
|
||
|
|
10480 ELSE
|
||
|
|
10490 IF HEAD<>NIL (* THE FIRST SLICE AND NOT THE LAST SLICE *) THEN
|
||
|
|
10500 BEGIN
|
||
|
|
10510 BACK^.IHEAD:= HEAD;
|
||
|
|
10520 HEAD^.BPTR := BACK
|
||
|
|
10530 END
|
||
|
|
10540 ELSE
|
||
|
|
10550 BEGIN (*THE ONLY SLICE*)
|
||
|
|
10560 BACK^.IHEAD := NIL;
|
||
|
|
10570 FPDEC(BACK^);
|
||
|
|
10580 IF FPTST(BACK^) THEN GARBAGE(BACK)
|
||
|
|
10590 END
|
||
|
|
10600 END;
|
||
|
|
10610 FPDEC(PVALUE^); TEMP := PVALUE;
|
||
|
|
10620 EDISPOSE(ANOBJECT, MULTCONST+(ROWS+1)*SZPDS);
|
||
|
|
10630 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
10640 END;
|
||
|
|
10650 REFN:
|
||
|
|
10660 BEGIN
|
||
|
|
10670 FPDEC(PVALUE^); TEMP := PVALUE;
|
||
|
|
10680 EDISPOSE(ANOBJECT, REFNSIZE);
|
||
|
|
10690 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
10700 END;
|
||
|
|
10710 REFSLN:
|
||
|
|
10720 BEGIN
|
||
|
|
10730 FPDEC(ANCESTOR^);
|
||
|
|
10740 TEMP := ANCESTOR;
|
||
|
|
10750 EDISPOSE(ANOBJECT, REFSLNCONST+(ROWS+1)*SZPDS);
|
||
|
|
10760 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
10770 END;
|
||
|
|
10780 REFSL1:
|
||
|
|
10790 BEGIN
|
||
|
|
10800 FPDEC(ANCESTOR^);
|
||
|
|
10810 TEMP := ANCESTOR;
|
||
|
|
10820 EDISPOSE(ANOBJECT, REFSL1SIZE);
|
||
|
|
10830 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
10840 END;
|
||
|
|
10850 REFR:
|
||
|
|
10860 BEGIN
|
||
|
|
10870 FPDEC(PVALUE^); TEMP := PVALUE;
|
||
|
|
10880 EDISPOSE(ANOBJECT, REFRCONST+(ROWS+1)*SZPDS);
|
||
|
|
10890 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
10900 END;
|
||
|
|
10910 RECR:
|
||
|
|
10920 BEGIN
|
||
|
|
10930 BACK:= PREV;
|
||
|
|
10940 HEAD:= NEXT;
|
||
|
|
10950 BACK^.NEXT:= HEAD;
|
||
|
|
10960 IF HEAD <> NIL THEN
|
||
|
|
10970 HEAD^.PREV:= BACK;
|
||
|
|
10980 FPDEC(PVALUE^); TEMP := PVALUE;
|
||
|
|
10990 EDISPOSE(ANOBJECT, RECRCONST+(ROWS+1)*SZPDS);
|
||
|
|
11000 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
11010 END;
|
||
|
|
11020 RECN:
|
||
|
|
11030 BEGIN
|
||
|
|
11040 BACK := PREV;
|
||
|
|
11050 HEAD := NEXT;
|
||
|
|
11060 BACK^.NEXT := HEAD;
|
||
|
|
11070 IF HEAD<>NIL THEN
|
||
|
|
11080 HEAD^.PREV:= BACK;
|
||
|
|
11090 FPDEC(PVALUE^); TEMP := PVALUE;
|
||
|
|
11100 EDISPOSE(ANOBJECT, RECNSIZE);
|
||
|
|
11110 IF FPTST(TEMP^) THEN BEGIN ANOBJECT := TEMP; GOTO 1 END
|
||
|
|
11120 END;
|
||
|
|
11130 CREF:
|
||
|
|
11140 EDISPOSE(ANOBJECT, CREFSIZE);
|
||
|
|
11150 REF1:
|
||
|
|
11160 EDISPOSE(ANOBJECT, REF1SIZE);
|
||
|
|
11170 (*-01() REF2:
|
||
|
|
11180 EDISPOSE(ANOBJECT, REF2SIZE); ()-01*)
|
||
|
|
11190 ROUTINE:
|
||
|
|
11200 EDISPOSE(ANOBJECT, ROUTINESIZE);
|
||
|
|
11210 PASCROUT:
|
||
|
|
11220 EDISPOSE(ANOBJECT, PROUTINESIZE);
|
||
|
|
11230 STRING:
|
||
|
|
11240 EDISPOSE(ANOBJECT, STRINGCONST+((STRLENGTH+CHARPERWORD-1) DIV CHARPERWORD)*SZWORD);
|
||
|
|
11250 UNDEF, NILL:
|
||
|
|
11260 PCOUNT := 255; (*MUSTN'T BE COLLECTED, OF COURSE*)
|
||
|
|
11270 COVER:
|
||
|
|
11280 BEGIN
|
||
|
|
11290 IF ASSOC THEN
|
||
|
|
11300 BEGIN FPDEC(ASSREF^); IF FPTST(ASSREF^) THEN GARBAGE(ASSREF) END
|
||
|
|
11310 ELSE BEGIN
|
||
|
|
11320 IF OPENED IN STATUS THEN ACLOSE(BOOK);
|
||
|
|
11330 PFET := BOOK;
|
||
|
|
11340 IF NOT(STARTUP IN STATUS) THEN DISPOSE(PFET)
|
||
|
|
11350 END;
|
||
|
|
11360 EDISPOSE(ANOBJECT, COVERSIZE)
|
||
|
|
11370 END
|
||
|
|
11380 END (*ESAC*)
|
||
|
|
11390 END (*OF WITH*)
|
||
|
|
11400 END; (*OF GARBAGE*)
|
||
|
|
11410 (**)
|
||
|
|
11420 (**)
|
||
|
|
11430 FUNCTION COPYDESC(ORIGINAL: OBJECTP; NEWSORT: STRUCTYPE): OBJECTP;
|
||
|
|
11440 (*PRODUCES EITHER A MULT,RECR,REFR OR A REFSLN FROM A MULT OR A REFSLN
|
||
|
|
11450 N.B. NO PCOUNTS ARE UPDATED*)
|
||
|
|
11460 VAR NEWDESC: OBJECTP;
|
||
|
|
11470 COUNT: INTEGER;
|
||
|
|
11480 BEGIN
|
||
|
|
11490 COUNT := MULTCONST (*REFSLNCONST*) + (ORIGINAL^.ROWS + 1)*SZPDS;
|
||
|
|
11500 ENEW(NEWDESC, COUNT);
|
||
|
|
11510 WITH NEWDESC^ DO
|
||
|
|
11520 BEGIN
|
||
|
|
11530 MOVELEFT(ORIGINAL, NEWDESC, COUNT);
|
||
|
|
11540 SORT := NEWSORT;
|
||
|
|
11550 PCOUNT := 0;
|
||
|
|
11560 END;
|
||
|
|
11570 COPYDESC := NEWDESC
|
||
|
|
11580 END;
|
||
|
|
11590 (**)
|
||
|
|
11600 (**)
|
||
|
|
11610 (*+01() (*$X6*) ()+01*)
|
||
|
|
11620 PROCEDURE OPENCOVER(
|
||
|
|
11630 PFET: FETROOMP; VAR PCOV: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() ( COV: OBJECTP; L: LFNTYPE) ()-01*)
|
||
|
|
11640 );
|
||
|
|
11650 BEGIN
|
||
|
|
11660 ENEW(PCOV, COVERSIZE);
|
||
|
|
11670 WITH PCOV^ DO
|
||
|
|
11680 BEGIN
|
||
|
|
11690 (*-02() FIRSTWORD := SORTSHIFT * ORD(COVER) + INCRF; ()-02*)
|
||
|
|
11700 (*+02() PCOUNT:=1; SORT:=COVER; ()+02*)
|
||
|
|
11710 BOOK := PFET;
|
||
|
|
11720 ASSOC := FALSE;
|
||
|
|
11730 OSCOPE := 1;
|
||
|
|
11740 CHANNEL := PROC(*-01()H()-01*)(CH);
|
||
|
|
11750 COFCPOS := 1; LOFCPOS := 1; POFCPOS := 1;
|
||
|
|
11760 CH(PCOV, LFN);
|
||
|
|
11770 END
|
||
|
|
11780 END;
|
||
|
|
11790 (**)
|
||
|
|
11800 (**)
|
||
|
|
11810 PROCEDURE START68;
|
||
|
|
11820 (*INITIALIZATION OF RUN68*)
|
||
|
|
11830 VAR PINT: INTPOINT;
|
||
|
|
11840 CURR: IPOINT;
|
||
|
|
11850 TEMP: PACKED RECORD CASE SEVERAL OF
|
||
|
|
11860 1: (INT: INTEGER);
|
||
|
|
11870 2: (ALF: LFNTYPE);
|
||
|
|
11880 3: (LFN: PACKED ARRAY [1..7] OF CHAR;
|
||
|
|
11890 (*+01() EFET1: 0..777777B ()+01*) );
|
||
|
|
11900 0 , 4 , 5 , 6 , 7 , 8 , 9 , 10 : () ;
|
||
|
|
11910 END;
|
||
|
|
11920 (*+01() AW66: ^W66 ; ()+01*)
|
||
|
|
11930 TEMP1: REALTEGER;
|
||
|
|
11940 I: INTEGER;
|
||
|
|
11950 EFET: INTEGER;
|
||
|
|
11960 (*+01() PROCEDURE ESTART(CURR: IPOINT); EXTERN; ()+01*)
|
||
|
|
11970 (*+02() PROCEDURE ESTART_(VAR INF,OUTF : TEXT); EXTERN;
|
||
|
|
11980 FUNCTION MAXR REAL; EXTERN; ()+02*)
|
||
|
|
11990 (*-02() PROCEDURE STOPEN(
|
||
|
|
12000 VAR PF: FYL; VAR RF: OBJECTP; LFN: LFNTYPE; PROCEDURE CH (*-01() ( COV: OBJECTP ; L: LFNTYPE ) ()-01*)
|
||
|
|
12010 ); EXTERN; ()-02*)
|
||
|
|
12020 BEGIN
|
||
|
|
12030 (*+01() CPUCLOCK := -CLOCK; ()+01*)
|
||
|
|
12040 (*-02() CURR := STATIC(ME)+FIRSTIBOFFSET;
|
||
|
|
12050 SETMYSTATIC(CURR); ()-02*)
|
||
|
|
12060 (*+01() ESTART(CURR); (*TO DO ALL THE MACHINE-DEPENDENT INITIALIZATIONS*) ()+01*)
|
||
|
|
12070 (*+02() ESTART_(INPUT,OUTPUT); (*THIS ALSO SETS UP THE FILES*)
|
||
|
|
12080 CURR := STATIC(ME);(*ESTART SET UP START68'S STATIC LINK*) ()+02*)
|
||
|
|
12090 SCOPE := 1;
|
||
|
|
12100 BITPATTERN.MASK := 0; BITPATTERN.COUNT := 0;
|
||
|
|
12110 TRACE := NIL;
|
||
|
|
12120 LEVEL := 0; PROCBL := NIL;
|
||
|
|
12130 LINENO := 0;
|
||
|
|
12140 (*+02()INTUNDEF := -32000 -768; ()+02*)
|
||
|
|
12150 WITH FIRSTRG DO WITH FIRSTW DO
|
||
|
|
12160 BEGIN
|
||
|
|
12170 LOOPCOUNT := 0; RGIDBLK := NIL; RECGEN := NIL;
|
||
|
|
12180 RGSCOPE := 1;
|
||
|
|
12190 (*-41()
|
||
|
|
12200 RIBOFFSET := INCPTR( ASPTR( CURR ) , IBCONST ) ;
|
||
|
|
12210 RGNEXTFREE := INCPTR(RIBOFFSET, RGCONST+SZINT+3*SZADDR (*+02()+3*SZREAL()+02*)) ;
|
||
|
|
12220 ()-41*)
|
||
|
|
12230 (*+41()
|
||
|
|
12240 RIBOFFSET := INCPTR( ASPTR( CURR ) , IBCONST + RGCONST ) ;
|
||
|
|
12250 RGLASTUSED := INCPTR(RIBOFFSET, -SZINT-3*SZADDR (*+02()-3*SZREAL()+02*)) ;
|
||
|
|
12260 ()+41*)
|
||
|
|
12270 END;
|
||
|
|
12280 ENEW(UNDEFIN, MULTCONST+8*SZPDS);
|
||
|
|
12290 (*SHOULD BE, INTER ALIA, THE EMPTY STRING AND THE FLATTEST MULT AND AN UNOPENED COVER*)
|
||
|
|
12300 WITH UNDEFIN^ DO
|
||
|
|
12310 BEGIN
|
||
|
|
12320 (*-02() FIRSTWORD := SORTSHIFT * ORD(UNDEF); ()-02*)
|
||
|
|
12330 (*+02() PCOUNT:=0; SORT:=UNDEF; ()+02*)
|
||
|
|
12340 (*+01() SECONDWORD := 0; ()+01*)
|
||
|
|
12350 PCOUNT := 255;
|
||
|
|
12360 ANCESTOR := UNDEFIN;
|
||
|
|
12370 OSCOPE := 1;
|
||
|
|
12380 ENEW(HIGHPCOUNT,MULTCONST+8*SZPDS);
|
||
|
|
12390 PVALUE := HIGHPCOUNT;
|
||
|
|
12400 WITH PVALUE^ DO
|
||
|
|
12410 BEGIN
|
||
|
|
12420 (*-02() FIRSTWORD := SORTSHIFT * ORD(UNDEF); ()-02*)
|
||
|
|
12430 (*+02() PCOUNT:=0; SORT:=UNDEF; ()+02*)
|
||
|
|
12440 (*+01() SECONDWORD := 0; ()+01*)
|
||
|
|
12450 ANCESTOR := UNDEFIN;
|
||
|
|
12460 PCOUNT := 255;
|
||
|
|
12470 PVALUE := UNDEFIN^.PVALUE;
|
||
|
|
12480 OSCOPE := 1;
|
||
|
|
12490 OFFSET := HIOFFSET;
|
||
|
|
12500 ROWS := 7;
|
||
|
|
12510 STRLENGTH := 0;
|
||
|
|
12520 STATUS := [];
|
||
|
|
12530 WITH DESCVEC[0] DO BEGIN LI := MAXBOUND; UI := MINBOUND END;
|
||
|
|
12540 FOR I := 1 TO 7 DO DESCVEC[I] := DESCVEC[1]
|
||
|
|
12550 END;
|
||
|
|
12560 OFFSET := HIOFFSET;
|
||
|
|
12570 ROWS := 7;
|
||
|
|
12580 STRLENGTH := 0;
|
||
|
|
12590 STATUS := [];
|
||
|
|
12600 WITH DESCVEC[0] DO BEGIN LI := MAXBOUND; UI := MINBOUND END;
|
||
|
|
12610 FOR I := 1 TO 7 DO DESCVEC[I] := DESCVEC[1]
|
||
|
|
12620 END;
|
||
|
|
12630 NILPTR := COPYDESC(UNDEFIN, NILL);
|
||
|
|
12640 NILPTR^.PCOUNT := 255;
|
||
|
|
12650 PUTSTRING := CRSTRING(2*REALWIDTH+2*EXPWIDTH+9);
|
||
|
|
12660 PUTSTRING^.PCOUNT := 255;
|
||
|
|
12670 ALLCHAR := []; FOR I := 0 TO (*+01()58()+01*) (*-01()MAXABSCHAR()-01*) DO ALLCHAR := ALLCHAR+[CHR(I)];
|
||
|
|
12680 (*+01() ALLCHAR1 := []; FOR I := 59 TO 63 DO ALLCHAR1 := ALLCHAR1+[CHR(I-59)]; ()+01*)
|
||
|
|
12690 ENEW(COMPLEX, 2*SZWORD);
|
||
|
|
12700 COMPLEX^[0] := 2*SZREAL; COMPLEX^[1] := -1; (*DBLOCK FOR .COMPL*)
|
||
|
|
12710 ENEW(FILEBLOCK, 12*SZWORD+SZTERMSET); (*DBLOCK FOR FILE*)
|
||
|
|
12720 FILEBLOCK^[0] := 5*SZADDR+SZTERMSET; FILEBLOCK^[1] := 0; FILEBLOCK^[2] := SZADDR; FILEBLOCK^[3] := 2*SZADDR;
|
||
|
|
12730 FILEBLOCK^[4] := 3*SZADDR; FILEBLOCK^[5] := 4*SZADDR; FILEBLOCK^[6] := -1;
|
||
|
|
12740 FILEBLOCK^[7] := 12; FILEBLOCK^[8] := 12; FILEBLOCK^[9] := 12; FILEBLOCK^[10] := 12;
|
||
|
|
12750 FILEBLOCK^[11] := 0; FOR I := 1 TO SZTERMSET DIV SZWORD DO FILEBLOCK^[11+I] := 1;
|
||
|
|
12760 NEW(PASCADDR); TEMP1.PROCC := PROC(CALLPASC); PASCADDR^.XBASE := TEMP1.PROCVAL.PROCADD;
|
||
|
|
12770 (*+54()
|
||
|
|
12780 ENEW(EXCEPTDB, 4*SZWORD);
|
||
|
|
12790 EXCEPTDB^[0] := 2*SZINT; EXCEPTDB^[1] := -1;
|
||
|
|
12800 EXCEPTDB^[2] := 1; EXCEPTDB^[3] := 0;
|
||
|
|
12810 ()+54*)
|
||
|
|
12820 (*-44()
|
||
|
|
12830 LASTRANDOM := ROUND(MAXINT/2);
|
||
|
|
12840 (*-01() (*-05() HALFPI.ACTUALPI := 2*ARCTAN(1.0); ()-05*) ()-01*)
|
||
|
|
12850 (*+01() HALFPI.FAKEPI := FAKEPI; ()+01*)
|
||
|
|
12860 (*+02() PI := 2.0*HALFPI.ACTUALPI;
|
||
|
|
12870 SMALLREAL := 1.0;
|
||
|
|
12880 WHILE (1.0+SMALLREAL*2.0>1.0) AND (1.0-SMALLREAL*2.0<1.0) DO SMALLREAL := SMALLREAL/2.0;
|
||
|
|
12890 MAXREAL := MAXR;
|
||
|
|
12900 ()+02*)
|
||
|
|
12910 (*+05() HALFPI.FAKEPI := FAKEPI ; HALFPI.FAKEPI1 := FAKEPI1 ; ()+05*)
|
||
|
|
12920 ()-44*)
|
||
|
|
12930 UNINT := INTUNDEF;
|
||
|
|
12940 (*+02() UNINTCOPY := UNINT; UNDEFINCOPY := UNDEFIN; ()+02*)
|
||
|
|
12950 (*+01()
|
||
|
|
12960 WITH TEMP DO
|
||
|
|
12970 BEGIN
|
||
|
|
12980 PINT := ASPTR(2); (*1ST PROGRAM PARAMETER*)
|
||
|
|
12990 INT := PINT^;
|
||
|
|
13000 IF INT = 0 THEN LFN := 'INPUT::' ;
|
||
|
|
13010 STOPEN(INPUT, STIN, ALF , STANDINC);
|
||
|
|
13020 EFET := CURR-FIRSTIBOFFSET+INPUTEFET;
|
||
|
|
13030 LFN := 'INPUT::'; EFET1 := EFET+1;
|
||
|
|
13040 PINT^ := INT;
|
||
|
|
13050 PINT := ASPTR(3); (*2ND PROGRAM PARAMETER*)
|
||
|
|
13060 INT := PINT^;
|
||
|
|
13070 IF INT = 0 THEN LFN := 'OUTPUT:' ;
|
||
|
|
13080 STOPEN(OUTPUT, STOUT, ALF , STANDOUT);
|
||
|
|
13090 EFET := CURR-FIRSTIBOFFSET+OUTPUTEFET;
|
||
|
|
13100 AW66 := ASPTR(66B);
|
||
|
|
13110 IF (AW66^.JOPR=3) AND (LFN='OUTPUT:') THEN WRITELN(OUTPUT, 'STARTING ...');
|
||
|
|
13120 LFN := 'OUTPUT:'; EFET1 := EFET+1;
|
||
|
|
13130 PINT^ := INT;
|
||
|
|
13140 PINT := ASPTR(4);
|
||
|
|
13150 PINT^ := INT; (*IN CASE USER OPENS ANOTHER FILE ON OUTPUT*)
|
||
|
|
13160 STBACK := UNDEFIN;
|
||
|
|
13170 END;
|
||
|
|
13180 ()+01*)
|
||
|
|
13190 (*+02()
|
||
|
|
13200 STOPEN(INPUT, STIN, NIL, STANDINC);
|
||
|
|
13210 STOPEN(OUTPUT, STOUT, NIL, STANDOUT);
|
||
|
|
13220 WRITELN(OUTPUT, 'STARTING ...');
|
||
|
|
13230 ()+02*)
|
||
|
|
13240 (*+05()
|
||
|
|
13250 STOPEN(INPUT, STIN, NIL , STANDINC);
|
||
|
|
13260 STOPEN(OUTPUT, STOUT, NIL , STANDOUT);
|
||
|
|
13270 WRITELN(ERROR, 'STARTING ...');
|
||
|
|
13280 ()+05*)
|
||
|
|
13290 END;
|
||
|
|
13300 (*+01() (*$X4*) ()+01*)
|
||
|
|
13310 (**)
|
||
|
|
13320 (**)
|
||
|
|
13330 (**)
|
||
|
|
13340 (**)
|
||
|
|
13350 PROCEDURE STOP68;
|
||
|
|
13360 (*+01() PROCEDURE PEND(EFET: INTEGER); EXTERN; ()+01*)
|
||
|
|
13370 (*+02() PROCEDURE ESTOP_; EXTERN; ()+02*)
|
||
|
|
13380 BEGIN
|
||
|
|
13390 (*+05() FLSBUF(STOUT^.PVALUE^.PCOVER^.BOOK^.XFILE, CHR(10)); ()+05*)
|
||
|
|
13400 WRITELN((*-05()OUTPUT()-05*)(*+05()ERROR()+05*));
|
||
|
|
13410 WRITELN((*-05()OUTPUT()-05*)(*+05()ERROR()+05*), ' ... AND YET ANOTHER ALGOL68 PROGRAM RUNS TO COMPLETION');
|
||
|
|
13420 (*+01() WRITELN(OUTPUT, ' CPU ', (CPUCLOCK+CLOCK)/1000:6:3); ()+01*)
|
||
|
|
13430 (*+05() WRITELN(ERROR, ' CPU ', TIME :5:2); ()+05*)
|
||
|
|
13440 (*+01() PEND(STATIC(ME)-FIRSTIBOFFSET+OUTPUTEFET) ()+01*)
|
||
|
|
13450 (*+02() ESTOP_; ()+02*)
|
||
|
|
13460 END;
|
||
|
|
13470 (**)
|
||
|
|
13480 (**)
|
||
|
|
13490 (**)
|
||
|
|
13500 (**)
|
||
|
|
13510 (*-02() BEGIN END ; ()-02*)
|
||
|
|
13520 (*+01()
|
||
|
|
13530 BEGIN (*OF MAIN PROGRAM*)
|
||
|
|
13540 END (*OF EVERYTHING*).
|
||
|
|
13550 ()+01*)
|