601 lines
22 KiB
OpenEdge ABL
601 lines
22 KiB
OpenEdge ABL
93000 (* COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER *)
|
|
93010 (*+82()
|
|
93020 (**)
|
|
93030 (*PARSING*)
|
|
93040 (***********)
|
|
93050 (**)
|
|
93060 FUNCTION ACTIONROUTINE(ARTN: RTNTYPE): BOOLEAN;
|
|
93070 LABEL 9;
|
|
93080 VAR STB: PSTB;
|
|
93090 M: MODE;
|
|
93100 OPL, OPR: PSTB;
|
|
93110 PREVLX: LXIOTYPE; INPT: PLEX;
|
|
93120 HEAD, PTR, PTR1: PLEXQ;
|
|
93130 LEV: INTEGER;
|
|
93140 PL, PR, I: INTEGER;
|
|
93150 PROCEDURE FORCEMATCH(LEX: PLEX);
|
|
93160 (*FORCES SRPLSTK[PLSTKP]=LEX*)
|
|
93170 LABEL 100;
|
|
93180 VAR TSTKP: 0..SRPLSTKSIZE;
|
|
93190 SLEX: PLEX;
|
|
93200 BEGIN TSTKP := PLSTKP;
|
|
93210 100: SLEX := SRPLSTK[TSTKP];
|
|
93220 IF SLEX^.LXV.LXCLASS2=1 THEN (*.FOR, ..., .WHILE*) SLEX := LEXWHILE;
|
|
93230 WITH SLEX^.LXV DO
|
|
93240 IF (LXCLASS2<>1) AND (LXCLASS2<>2) AND (LXIO<>LXIOSTART) OR (SLEX<>LEX) AND (TSTKP=PLSTKP) THEN
|
|
93250 BEGIN TSTKP := TSTKP+1; GOTO 100 END;
|
|
93260 IF SLEX=LEX THEN (*LEAVE ALONE OR POP*) PLSTKP := TSTKP
|
|
93270 ELSE (*PUSH*) BEGIN PLSTKP := PLSTKP-1; SRPLSTK[PLSTKP] := LEX END
|
|
93280 END; (*OF FORCEMATCH*)
|
|
93290 BEGIN
|
|
93300 (*+21()
|
|
93310 MONITORSEMANTIC(ARTN);
|
|
93320 ()+21*)
|
|
93330 CASE ARTN OF
|
|
93340 (**)
|
|
93350 1: (*AR1*)
|
|
93360 (*FUNCTION: INVOKED AFTER OPERAND SURROUNDED BY DYADIC-OPERATORS.
|
|
93370 DECIDES WHICH OPERATORS TAKE PRECEDENCE.
|
|
93380 TRUE IFF OPERATOR TO LEFT OF OPERAND TAKES PRECEDENCE;
|
|
93390 I.E. LEFT PRIORITY IS GREATER THAN OR EQUAL TO RIGHT PRIORITY.
|
|
93400 *)
|
|
93410 BEGIN
|
|
93420 OPL := SRPLSTK[PLSTKP+1]^.LXV.LXPSTB; OPR := INP^.LXV.LXPSTB;
|
|
93430 IF OPL<>NIL THEN PL := OPL^.STDYPRIO ELSE PL := 10;
|
|
93440 IF OPR<>NIL THEN PR := OPR^.STDYPRIO ELSE PR := 10;
|
|
93450 IF PL>=PR THEN
|
|
93460 BEGIN
|
|
93470 IF (ERRS-SEMERRS)=0 THEN SEMANTICROUTINE(79) (*SR45*);
|
|
93480 ACTIONROUTINE := TRUE
|
|
93490 END
|
|
93500 ELSE ACTIONROUTINE := FALSE
|
|
93510 END;
|
|
93520 (**)
|
|
93530 2: (*AR2*)
|
|
93540 (*INVOKED: AFTER OPEN FOLLOWED BY HEAD SYMBOL OF A DECLARER.
|
|
93550 FUNCTION: DECIDE WHETHER THIS IS START OF FORMAL-DECLARATIVE OF A
|
|
93560 ROUTINE-TEXT OR START OF A CLOSED-CLAUSE
|
|
93562 VALUE: TRUE IFF ROUTINE-TEXT*)
|
|
93570 BEGIN
|
|
93580 LEV := 0; PREVLX := LXIOERROR; NEW(HEAD); PTR := HEAD;
|
|
93590 WHILE TRUE DO
|
|
93600 BEGIN
|
|
93610 INPT := PARSIN; PTR^.DATA1 := INPT;
|
|
93620 WITH INPT^.LXV DO
|
|
93630 IF LXIO<LXIOBUS THEN (*NOT TAG OR PART OF A FORMAL-DECLARER*)
|
|
93640 BEGIN ACTIONROUTINE := FALSE; GOTO 9 END
|
|
93650 ELSE IF LXIO=LXIOOPEN THEN
|
|
93670 LEV := LEV+1
|
|
93700 ELSE IF LXIO=LXIOCLOSE THEN
|
|
93710 IF LEV<>0 THEN LEV := LEV-1
|
|
93720 ELSE
|
|
93730 BEGIN ACTIONROUTINE := TRUE; GOTO 9 END;
|
|
93740 PREVLX := INPT^.LXV.LXIO;
|
|
93750 NEW(PTR1); PTR^.LINK := PTR1; PTR := PTR1;
|
|
93760 END;
|
|
93770 9: PTR^.LINK := PLINPQ;
|
|
93780 PLINPQ := HEAD
|
|
93790 END;
|
|
93800 (**)
|
|
93810 (**)
|
|
93820 (**)
|
|
93830 3: (*AR3A*)
|
|
93840 (*FUNCTION: INVOKED AFTER APPLIED-MODE-INDICATION.
|
|
93850 DETERMINES IF ASCRIBED MODE IS NON-ROWED NON-VOID MODE.
|
|
93860 TRUE IFF MODE IS NON-ROWED NON-VOID.
|
|
93870 *)
|
|
93880 BEGIN
|
|
93890 STB := APPMI(SRPLSTK[PLSTKP]);
|
|
93900 WITH STB^ DO IF STBLKTYP>STBDEFOP THEN STB := STDEFPTR;
|
|
93910 SRSEMP := SRSEMP+1; SRSTK[SRSEMP].MD := STB^.STMODE;
|
|
93920 IF STB^.STMODE=MDVOID THEN ACTIONROUTINE := FALSE
|
|
93930 ELSE IF STB^.STOFFSET=0 THEN ACTIONROUTINE := TRUE
|
|
93940 ELSE ACTIONROUTINE := FALSE
|
|
93950 END;
|
|
93960 (**)
|
|
93970 4: (*AR3B*)
|
|
93980 (*FUNCTION: INVOKED AFTER ROWED OR VOID APPLIED-MODE-INDICATION.
|
|
93990 DETERMINES IF ASCRIBED MODE IS VOID.
|
|
94000 TRUE IFF MODE IS VOID.
|
|
94010 *)
|
|
94020 IF SRSTK[SRSEMP].MD=MDVOID THEN ACTIONROUTINE := TRUE
|
|
94030 ELSE ACTIONROUTINE := FALSE;
|
|
94040 (**)
|
|
94050 5: (*AR5*)
|
|
94060 (*INVOKED: AFTER ENQUIRY-CLAUSE OF BRIEF-CHOICE-CLAUSE.
|
|
94070 FUNCTION: DECIDE MORE SPECIFICALLY WHAT KIND OF CLAUSE THE BRIEF CLAUSE REPRESENTS.
|
|
94080 THE LEGAL POSSIBILITIES ARE CONDITIONAL-CLAUSE AND CASE-CLAUSE.
|
|
94090 A THIRD POSSIBILITY IS THAT THE SERIAL-CLAUSE PRESUMED TO BE AN ENQUIRY-CLAUSE
|
|
94100 IN FACT DOES NOT YIELD THE REQUIRED MODE AND HENCE IS IN ERROR.
|
|
94110 VALUE: TRUE IFF CONDITIONAL-CLAUSE OR ERROR.
|
|
94120 *)
|
|
94130 BEGIN
|
|
94140 IF (ERRS-SEMERRS)=0 THEN M := MEEK ELSE M := MDERROR;
|
|
94150 IF M=MDINT THEN ACTIONROUTINE := FALSE
|
|
94160 ELSE IF M=MDBOOL THEN ACTIONROUTINE := TRUE
|
|
94170 ELSE BEGIN MODERR(M, ESE+37); ACTIONROUTINE := TRUE END
|
|
94180 END;
|
|
94190 (**)
|
|
94200 6: (*AR6*)
|
|
94210 (*INVOKED: AFTER MODE-DEFINITION AND COMMA FOLLOWED BY MODE-INDICATION.
|
|
94220 FUNCTION: DETERMINE IF TAB IS START OF ANOTHER MODE-DEFINITION OR START OF
|
|
94230 VARIABLE- OR IDENTITY-DEFINITION-LIST.
|
|
94240 VALUE: TRUE IFF TAB IS START OF MODE-DEFINITION.
|
|
94250 *)
|
|
94260 BEGIN
|
|
94270 INPT := PARSIN;
|
|
94280 PTR := PLINPQ; NEW(PLINPQ);
|
|
94290 WITH PLINPQ^ DO
|
|
94300 BEGIN LINK := PTR; DATA1 := INPT END;
|
|
94310 ACTIONROUTINE := INPT^.LXV.LXIO = LXIOEQUAL
|
|
94320 END;
|
|
94330 (**)
|
|
94340 7: (*AR7*)
|
|
94350 (*TRUE IFF SEMANTIC CHECKING IS OFF*)
|
|
94360 ACTIONROUTINE := ERRS>SEMERRS;
|
|
94370 (**)
|
|
94380 8: (*ERRX*)
|
|
94390 (*INVOKED AFTER ERROR CORRECTING PRODUCTIONS HAVE FLUSHED THE SYNTAX STACK AND
|
|
94400 INPUT STREAM TO A POINT WHERE IT IS DEEMED POSSIBLE TO CONTINUE NORMAL PARSING.
|
|
94410 *)
|
|
94420 BEGIN
|
|
94430 FOR I := ERRPTR+1 TO ERRLXPTR DO ERRBUF[I] := ERRCHAR;
|
|
94440 ERRPTR := ERRLXPTR;
|
|
94450 ERRCHAR := ' ';
|
|
94460 (*FIXUP BRACKET MISMATCHES*)
|
|
94470 WITH INP^.LXV DO
|
|
94480 IF (LXIO=LXIOOUSE) OR (LXIO=LXIOOUT) OR (LXIO=LXIOESAC) THEN FORCEMATCH(LEXCASE)
|
|
94490 ELSE IF LXIO IN [LXIOELIF,LXIOELSE,LXIOFI] THEN FORCEMATCH(LEXIF)
|
|
94500 ELSE IF (LXIO IN [LXIOCSTICK,LXIOAGAIN]) OR (LXIO=LXIOCSTICK) THEN
|
|
94510 (*LXIONIL AND ABOVE ARE NOT ACCEPTABLE SET ELEMENTS IN CDC PASCAL*)
|
|
94520 IF SRPLSTK[PLSTKP]^.LXV.LXIO<>LXIOBRINPT THEN FORCEMATCH(LEXBRTHPT)
|
|
94530 ELSE (*NO ACTION*)
|
|
94540 ELSE IF LXIO=LXIOCLOSE THEN FORCEMATCH(LEXOPEN)
|
|
94550 ELSE IF LXIO=LXIOEND THEN FORCEMATCH(LEXBEGIN)
|
|
94560 ELSE IF LXIO=LXIOOD THEN FORCEMATCH(LEXWHILE);
|
|
94570 ACTIONROUTINE := TRUE
|
|
94580 END;
|
|
94590 (**)
|
|
94622 9: (*INVOKED: AFTER A PRIMARY FOLLOWED BY OPEN.
|
|
94624 FUNCTION: DETERMINES WHETHER IT IS START OF CALL OR SLICE.
|
|
94626 VALUE: TRUE IFF CALL*)
|
|
94628 IF (ERRS-SEMERRS)=0 THEN
|
|
94630 BEGIN
|
|
94632 M := COMEEK(BALANCE(STRMEEK));
|
|
94634 IF M^.MDV.MDID IN [MDIDPASC,MDIDPROC] THEN
|
|
94635 BEGIN SEMANTICROUTINE(76); ACTIONROUTINE := TRUE END
|
|
94636 ELSE ACTIONROUTINE := FALSE;
|
|
94637 END
|
|
94638 ELSE ACTIONROUTINE := FALSE;
|
|
94640 END;
|
|
94642 END;
|
|
94650 (**)
|
|
94660 (**)
|
|
94670 PROCEDURE INITPR;
|
|
94680 (*FUNCTION: PERFORMS PER-COMPILATION INITIALIZATION REQUIRED BY
|
|
94690 THE PARSING ROUTINES.
|
|
94700 *)
|
|
94710 BEGIN
|
|
94720 PLINPQ := NIL;
|
|
94730 PLPTR := 1;
|
|
94740 SRPLSTK[SRPLSTKSIZE] := LEXSTOP;
|
|
94750 SRPLSTK[SRPLSTKSIZE-1] := LEXSTOP;
|
|
94760 PLSTKP := SRPLSTKSIZE-1;
|
|
94770 ENDOFPROG := FALSE;
|
|
94780 INP := LEXSTART
|
|
94790 END;
|
|
94800 (**)
|
|
94810 (**)
|
|
94820 PROCEDURE PARSER;
|
|
94830 (*FUNCTION: THIS IS THE PRODUCTION LANGUAGE PARSER. IT PERFORMS THE
|
|
94840 SYNTAX ANALYSIS BY INTERPRETING PRODUCTION RULES FOR THE ALGOL 68 SUBLANGUAGE.
|
|
94850 *)
|
|
94860 VAR MATCH: BOOLEAN;
|
|
94870 STK: PLEX;
|
|
94880 I: INTEGER;
|
|
94890 MATCHES, UNMATCHES: INTEGER;
|
|
94900 (*HISTO: ARRAY [1..PRODLEN] OF INTEGER;*)
|
|
94910 BEGIN
|
|
94920 (*+22() PARSCLK := PARSCLK-CLOCK; ()+22*)
|
|
94930 MATCHES := 0; UNMATCHES := 0;
|
|
94940 WHILE NOT ENDOFPROG DO
|
|
94950 BEGIN
|
|
94960 WITH PRODTBL[PLPTR] DO
|
|
94970 BEGIN
|
|
94980 (*HISTO[PLPTR] := HISTO[PLPTR]+1;*)
|
|
94990 MATCH := TRUE;
|
|
95000 IF PRSTKA<3 THEN (*I.E. NOT ANY*)
|
|
95010 BEGIN
|
|
95020 STK := SRPLSTK[PLSTKP+PRSTKA];
|
|
95030 CASE PRSTKC OF
|
|
95040 S: MATCH := SYLXV.LX1IO = STK^.LXV.LXIO;
|
|
95050 C0: MATCH := SYLXV.LX1CL0 = STK^.LXV.LXCLASS0;
|
|
95060 C1: MATCH := SYLXV.LX1CL1 = STK^.LXV.LXCLASS1;
|
|
95070 C2: MATCH := SYLXV.LX1CL2 = STK^.LXV.LXCLASS2
|
|
95080 END
|
|
95090 END;
|
|
95100 IF MATCH THEN
|
|
95110 CASE PRINPC OF
|
|
95120 A: (*NO ACTION*);
|
|
95130 S: MATCH := SYLXV.LX2IO = INP^.LXV.LXIO;
|
|
95140 C0: MATCH := SYLXV.LX2CL0 = INP^.LXV.LXCLASS0;
|
|
95150 C1: MATCH := SYLXV.LX2CL1 = INP^.LXV.LXCLASS1;
|
|
95160 C2: MATCH := SYLXV.LX2CL2 = INP^.LXV.LXCLASS2;
|
|
95170 SSA: MATCH := SYLXV.LX2IO = SRPLSTK[PLSTKP+1]^.LXV.LXIO
|
|
95180 END;
|
|
95190 IF MATCH THEN
|
|
95200 IF RTN>FINISH THEN
|
|
95210 IF ((ERRS-SEMERRS)=0) OR (RTN>=119 (*SR81*) ) THEN
|
|
95220 BEGIN
|
|
95230 (*PARSCLKS := PARSCLKS+1; SEMCLK := SEMCLK-CLOCK;*)
|
|
95240 SEMANTICROUTINE(RTN);
|
|
95250 (*SEMCLK := SEMCLK+CLOCK; SEMCLKS := SEMCLKS+1*)
|
|
95260 END
|
|
95270 ELSE (*NOTHING*)
|
|
95280 ELSE IF RTN<>DUMMY THEN
|
|
95290 MATCH := ACTIONROUTINE(RTN);
|
|
95300 IF MATCH THEN
|
|
95310 BEGIN
|
|
95320 MATCHES := MATCHES+1;
|
|
95330 (*
|
|
95340 WRITELN(PLPTR:3, PLSTKP:3, ERRLXPTR:3);
|
|
95350 *)
|
|
95360 PLSTKP := PLSTKP+PRPOP;
|
|
95370 IF PRPUSH<>LXIODUMMY THEN
|
|
95380 BEGIN PLSTKP := PLSTKP-1; SRPLSTK[PLSTKP] := PUSHTBL[PRPUSH] END;
|
|
95390 IF PRSKIP THEN
|
|
95400 BEGIN IF LEXLINE <> PREVLINE THEN CGFLINE;
|
|
95410 INP := PARSIN END;
|
|
95420 FOR I := 1 TO PRSCAN DO
|
|
95430 BEGIN PLSTKP := PLSTKP-1; SRPLSTK[PLSTKP] := INP;
|
|
95440 IF LEXLINE <> PREVLINE THEN CGFLINE;
|
|
95450 INP := PARSIN END;
|
|
95460 PLPTR := SEXIT
|
|
95470 END
|
|
95480 ELSE
|
|
95490 BEGIN PLPTR := FEXIT; UNMATCHES := UNMATCHES+1 END
|
|
95500 END
|
|
95510 END
|
|
95520 (*+22() ; PARSCLK := PARSCLK+CLOCK; PARSCLKS := PARSCLKS+1; ()+22*)
|
|
95530 (*WRITELN('MATCHES', MATCHES, ' UNMATCHES', UNMATCHES);*)
|
|
95540 (*FOR I := 1 TO PRODLEN DO WRITELN(REMARKS, I, HISTO[I]);*)
|
|
95550 END;
|
|
95560 (**)
|
|
95570 ()+82*)
|
|
95580 (**)
|
|
95590 (**)
|
|
95592 PROCEDURE ABORT; EXTERN;
|
|
95600 (**)
|
|
95610 (*+80()
|
|
95620 (**)
|
|
95630 (*+01()
|
|
95640 FUNCTION PFL: INTEGER;
|
|
95650 (*OBTAIN FIELD LENGTH FROM GLOBAL P.FL*)
|
|
95660 EXTERN;
|
|
95670 (**)
|
|
95680 (**)
|
|
95690 FUNCTION PFREE: PINTEGER;
|
|
95700 (*OBTAIN ADDRESS OF GLOBAL P.FREE*)
|
|
95710 EXTERN;
|
|
95720 (**)
|
|
95730 (**)
|
|
95740 (*$T-+)
|
|
95750 (*+25() (*$T-+) ()+25*)
|
|
95760 FUNCTION RESTORE(VAR START: INTEGER): INTEGER;
|
|
95770 (*RESTORES STACK AND HEAP FROM FILE A68INIT.
|
|
95780 START IS FIRST VARIABLE ON STACK TO BE RESTORED*)
|
|
95790 CONST TWO30=10000000000B;
|
|
95800 VAR STACKSTART, STACKLENGTH, HEAPLENGTH: INTEGER;
|
|
95810 FRIG: RECORD CASE INTEGER OF
|
|
95820 1:(INT: INTEGER); 2:(POINT: PINTEGER) END;
|
|
95830 D: DUMPOBJ;
|
|
95840 MASKM,MASKL: INTEGER;
|
|
95850 I: INTEGER;
|
|
95860 BEGIN
|
|
95870 STACKSTART := GETX(0);
|
|
95880 RESET(A68INIT);
|
|
95890 IF EOF(A68INIT) THEN BEGIN WRITELN(' A68INIT NOT AVAILABLE, OR WRONG RFL'); RESTORE := 1 END
|
|
95900 ELSE
|
|
95910 BEGIN
|
|
95920 READ(A68INIT, D.INT, D.MASK); STACKLENGTH := D.INT; HEAPLENGTH := D.MASK;
|
|
95930 FIELDLENGTH := PFL-LOADMARGIN; (*BECAUSE THE LOADER CANNOT LOAD RIGHT UP TO THE FIELDLENGTH*)
|
|
95940 HEAPSTART := FIELDLENGTH-HEAPLENGTH;
|
|
95950 FOR I := STACKSTART TO STACKSTART+STACKLENGTH-1 DO
|
|
95960 BEGIN
|
|
95970 READ(A68INIT, D.INT, D.MASK);
|
|
95980 (*NOW WE HAVE TO MULTIPLY D.MASK BY HEAPSTART*)
|
|
95990 MASKM := D.MASK DIV TWO30; MASKL := D.MASK-MASKM*TWO30;
|
|
96000 MASKM := MASKM*HEAPSTART; MASKL := MASKL*HEAPSTART;
|
|
96010 D.INT := D.INT+MASKM*TWO30+MASKL;
|
|
96020 FRIG.INT := I; FRIG.POINT^ := D.INT
|
|
96030 END;
|
|
96040 FOR I := HEAPSTART TO HEAPSTART+HEAPLENGTH-1 DO
|
|
96050 BEGIN
|
|
96060 READ(A68INIT, D.INT, D.MASK);
|
|
96070 MASKM := D.MASK DIV TWO30; MASKL := D.MASK-MASKM*TWO30;
|
|
96080 MASKM := MASKM*HEAPSTART; MASKL := MASKL*HEAPSTART;
|
|
96090 D.INT := D.INT+MASKM*TWO30+MASKL;
|
|
96100 FRIG.INT := I; FRIG.POINT^ := D.INT
|
|
96110 END;
|
|
96120 FRIG.POINT := PFREE; FRIG.POINT^ := START;
|
|
96130 RESTORE := 0
|
|
96140 END
|
|
96150 END;
|
|
96160 (**)
|
|
96170 (**)
|
|
96190 PROCEDURE ACLOSE(VAR F: FYL); EXTERN;
|
|
96200 (**)
|
|
96210 (**)
|
|
96220 FUNCTION INITINIT: INTEGER;
|
|
96230 VAR WORD101: RECORD CASE INTEGER OF
|
|
96240 1: (INT: INTEGER);
|
|
96250 2: (REC: PACKED RECORD
|
|
96260 WCS: 0..777777B;
|
|
96270 FILLER: 0..77777777777777B
|
|
96280 END)
|
|
96290 END;
|
|
96300 HWORD: RECORD CASE INTEGER OF
|
|
96310 1: (INT: INTEGER);
|
|
96320 2: (REC: PACKED RECORD
|
|
96330 TABLE: 0..7777B; WC: 0..7777B;
|
|
96340 FILLER: 0..777777777777B
|
|
96350 END)
|
|
96360 END;
|
|
96370 I, J: INTEGER;
|
|
96380 P: PINTEGER;
|
|
96390 BEGIN
|
|
96400 IF DUMPED=43 THEN (*WE ARE OBEYING THE DUMPED VERSION OF THE COMPILER*)
|
|
96410 BEGIN
|
|
96420 IF PFL-LOADMARGIN-ABSMARGIN>FIELDLENGTH THEN (*FIELDLENGTH HAS CHANGED SINCE DUMP*)
|
|
96430 INITINIT := RESTORE(FIRSTSTACK)
|
|
96440 ELSE INITINIT := 0;
|
|
96450 SETB(4, HEAPSTART)
|
|
96460 END
|
|
96470 ELSE
|
|
96480 BEGIN (*A DUMP MUST BE MADE*)
|
|
96490 DUMPED := 43;
|
|
96500 INITINIT := RESTORE(FIRSTSTACK);
|
|
96510 REWRITE(LGO);
|
|
96520 GETSEG(A68INIT); (*START OF A68SB*)
|
|
96530 HWORD.INT := A68INIT^;
|
|
96540 WHILE HWORD.REC.TABLE<>5400B DO
|
|
96550 BEGIN GET(A68INIT);
|
|
96560 WRITE(LGO, HWORD.INT);
|
|
96570 FOR I := 1 TO HWORD.REC.WC DO (*COPY PRFX/LDSET TABLE*)
|
|
96580 BEGIN READ(A68INIT, J); WRITE(LGO, J) END;
|
|
96590 HWORD.INT := A68INIT^;
|
|
96600 END;
|
|
96610 WITH WORD101 DO (*MODIFY WORD 1 OF EACPM TABLE*)
|
|
96620 BEGIN
|
|
96630 P := ASPTR(101B);
|
|
96640 INT := FIELDLENGTH;
|
|
96650 REC.WCS := FIELDLENGTH-101B-LOADMARGIN;
|
|
96660 P^ := INT;
|
|
96670 P := ASPTR(104B);
|
|
96680 P^ := FIELDLENGTH
|
|
96690 END;
|
|
96700 P := ASPTR(100B);
|
|
96710 FOR I := 0 TO 8 DO (*WRITE EACPM TABLE FROM CORE*)
|
|
96720 BEGIN
|
|
96730 WRITE(LGO, P^);
|
|
96740 P := ASPTR(ORD(P)+1);
|
|
96750 GET(A68INIT)
|
|
96760 END;
|
|
96770 WHILE NOT EOS(A68INIT) DO (*COPY PROGRAM*)
|
|
96780 BEGIN
|
|
96790 READ(A68INIT, J); WRITE(LGO, J);
|
|
96800 P := ASPTR(ORD(P)+1)
|
|
96810 END;
|
|
96820 WHILE ORD(P)<FIELDLENGTH DO (*WRITE STACK-HEAP*)
|
|
96830 BEGIN
|
|
96840 WRITE(LGO, P^);
|
|
96850 P := ASPTR(ORD(P)+1)
|
|
96860 END;
|
|
96870 ABORT
|
|
96880 END
|
|
96890 END;
|
|
96900 (**)
|
|
96910 (**)
|
|
96920 PROCEDURE LOADGO(VAR LGO: LOADFILE); EXTERN;
|
|
96930 (**)
|
|
96940 (**)
|
|
96950 (*$E++)
|
|
96960 PROCEDURE PASCPMD(VAR A: INTEGER; J,K,L,M: INTEGER; N: BOOLEAN;
|
|
96970 VAR F: TEXT; VAR MSG: MESS);
|
|
96980 (*TO CATCH NOS- AND PASCAL-DETECTED ERRORS*)
|
|
96990 VAR I: INTEGER;
|
|
97000 BEGIN
|
|
97010 WRITELN(F);
|
|
97020 I := 1;
|
|
97030 REPEAT
|
|
97040 WRITE(F, MSG[I]); I := I+1
|
|
97050 UNTIL ORD(MSG[I])=0;
|
|
97060 WRITELN(F);
|
|
97070 ABORT
|
|
97080 END;
|
|
97090 ()+01*)
|
|
97100 (**)
|
|
97110 (**)
|
|
97120 (**)
|
|
97130 ()+80*)
|
|
97140 (**)
|
|
97150 (*-01() (*-03() (*-04()
|
|
97160 FUNCTION GETADDRESS(VAR VARIABLE:INTEGER): ADDRINT; EXTERN;
|
|
97170 (**)
|
|
97180 PROCEDURE RESTORE(VAR START,FINISH: INTEGER);
|
|
97190 VAR STACKSTART,STACKEND,GLOBALLENGTH,HEAPLENGTH,
|
|
97191 HEAPSTART(*+19(),LENGTH,POINTER()+19*): ADDRINT;
|
|
97195 I:INTEGER;
|
|
97200 P: PINTEGER;
|
|
97210 FRIG: RECORD CASE SEVERAL OF
|
|
97220 1: (INT: ADDRINT);
|
|
97221 2: (POINT: PINTEGER);
|
|
97222 3: (PLEXP: PLEX);
|
|
97223 (*+19() 4: (APOINT: ^ADDRINT); ()+19*)
|
|
97230 (*-19()4,()-19*)5,6,7,8,9,10: ()
|
|
97240 END;
|
|
97250 D: RECORD INT,MASK: INTEGER END;
|
|
97270 BEGIN
|
|
97280 (*+05() OPENLOADFILE(A68INIT, 4, FALSE); ()+05*)
|
|
97285 (*+02() RESET(A68INIT); ()+02*)
|
|
97290 STACKSTART := GETADDRESS(START);
|
|
97300 IF NOT EOF(A68INIT) THEN
|
|
97310 BEGIN
|
|
97320 READ(A68INIT,GLOBALLENGTH,HEAPLENGTH);
|
|
97330 ENEW(FRIG.PLEXP, HEAPLENGTH);
|
|
97340 HEAPSTART := FRIG.INT;
|
|
97350 FRIG.INT := STACKSTART;
|
|
97355 (*-19()
|
|
97360 FOR I := 1 TO GLOBALLENGTH DIV SZWORD DO
|
|
97370 BEGIN
|
|
97380 READ(A68INIT,D.INT,D.MASK);
|
|
97390 IF D.MASK=SZREAL THEN (*D.INT IS A POINTER OFFSET FROM HEAPSTART*)
|
|
97400 D.INT := D.INT+HEAPSTART;
|
|
97410 FRIG.POINT^ := D.INT;
|
|
97420 FRIG.INT := FRIG.INT+SZWORD;
|
|
97430 END;
|
|
97440 FRIG.INT := HEAPSTART;
|
|
97450 FOR I := 1 TO HEAPLENGTH DIV SZWORD DO
|
|
97460 BEGIN
|
|
97462 READ(A68INIT,D.INT,D.MASK);
|
|
97464 IF D.MASK=SZREAL THEN
|
|
97466 D.INT := D.INT+HEAPSTART;
|
|
97468 FRIG.POINT^ := D.INT;
|
|
97470 FRIG.INT := FRIG.INT+SZWORD
|
|
97472 END
|
|
97474 ()-19*)
|
|
97479 (*+19()
|
|
97480 LENGTH:=GLOBALLENGTH DIV SZWORD;
|
|
97482 I:=1;
|
|
97484 WHILE I<=LENGTH DO
|
|
97486 BEGIN
|
|
97488 READ(A68INIT,D.MASK);
|
|
97490 IF D.MASK=SZADDR+SZWORD THEN (*IT IS A POINTER*)
|
|
97492 BEGIN
|
|
97494 READ(A68INIT,POINTER);
|
|
97496 POINTER:=POINTER+HEAPSTART;
|
|
97498 FRIG.APOINT^:=POINTER;
|
|
97500 FRIG.INT:=FRIG.INT+SZWORD+SZWORD; (*POINTER IS 2 WORDS *)
|
|
97502 I:=I+2
|
|
97504 END
|
|
97506 ELSE
|
|
97508 BEGIN
|
|
97510 READ(A68INIT,D.INT);
|
|
97511 FRIG.POINT^:=D.INT;
|
|
97512 FRIG.INT:=FRIG.INT+SZWORD;
|
|
97513 I:=I+1
|
|
97514 END
|
|
97515 END;
|
|
97516 LENGTH:=HEAPLENGTH DIV SZWORD;
|
|
97517 FRIG.INT:=HEAPSTART;
|
|
97518 I:=1;
|
|
97519 WHILE I<=LENGTH DO
|
|
97520 BEGIN
|
|
97521 READ(A68INIT,D.MASK);
|
|
97522 IF D.MASK=SZADDR+SZWORD THEN (*IT IS A POINTER*)
|
|
97523 BEGIN
|
|
97524 READ(A68INIT,POINTER);
|
|
97525 POINTER:=POINTER+HEAPSTART;
|
|
97526 FRIG.APOINT^:=POINTER;
|
|
97527 FRIG.INT:=FRIG.INT+SZWORD+SZWORD; (*POINTER IS 2 WORDS *)
|
|
97528 I:=I+2
|
|
97529 END
|
|
97530 ELSE
|
|
97531 BEGIN
|
|
97532 READ(A68INIT,D.INT);
|
|
97533 FRIG.POINT^:=D.INT;
|
|
97534 FRIG.INT:=FRIG.INT+SZWORD;
|
|
97535 I:=I+1
|
|
97536 END
|
|
97537 END
|
|
97538 ()+19*)
|
|
97539 END
|
|
97540 END;
|
|
97550 ()-04*) ()-03*) ()-01*)
|
|
97560 (**)
|
|
97570 (*+82()
|
|
97580 (**)
|
|
97590 (*THE COMPILER*)
|
|
97600 (**************)
|
|
97610 (**)
|
|
97630 PROCEDURE ALGOL68;
|
|
97640 BEGIN
|
|
97650 (*+01()
|
|
97660 CPUCLK := -CLOCK;
|
|
97670 (*+22() CPUCLK := -CLOCK; PARSCLK := 0; LXCLOCK := 0; SEMCLK := 0; EMITCLK := 0;
|
|
97680 CPUCLKS := 0; PARSCLKS := 0; LXCLOCKS := 0; SEMCLKS := 0; EMITCLKS := 0; ()+22*)
|
|
97690 WARNS := INITINIT;
|
|
97700 ()+01*)
|
|
97710 (*+25() WARNS := INITINIT; ()+25*)
|
|
97720 ERRS := 0; SEMERRS := 0;
|
|
97730 (*+03()
|
|
97740 CLOSE(SOURCDECS);
|
|
97750 CLOSE(LSTFILE);
|
|
97760 CLOSE(OUTPUT);
|
|
97770 RESTARTHERE;
|
|
97780 CPUTIME(CPUCLK);
|
|
97790 ()+03*)
|
|
97800 (*-01() (*-03() (*-04() (*-25() RESTORE(FIRSTSTACK,LASTSTACK); ()-25*) ()-04*) ()-03*) ()-01*)
|
|
97810 INITIO;
|
|
97820 INITLX;
|
|
97830 INITPR;
|
|
97840 INITSR;
|
|
97850 (*+01()
|
|
97860 SETPARAM(' ', 0); (*FOR DEFAULT GO*)
|
|
97870 ()+01*)
|
|
97880 PARSER;
|
|
97890 (*+01() (*+22() EMITCLK := EMITCLK-EMITCLKS DIV 6;
|
|
97900 SEMCLK := SEMCLK-(SEMCLKS+EMITCLKS) DIV 6;
|
|
97910 LXCLOCK := LXCLOCK-LXCLOCKS DIV 6;
|
|
97920 PARSCLK := PARSCLK-(PARSCLKS+LXCLOCKS+SEMCLKS+EMITCLKS) DIV 6;
|
|
97930 CPUCLK := CPUCLK-(PARSCLKS+LXCLOCKS+SEMCLKS+EMITCLKS) DIV 6;
|
|
97940 WRITELN(' CPU', (CPUCLK+CLOCK)/1000:6:3,
|
|
97950 ' PAR', (PARSCLK-LXCLOCK-SEMCLK)/1000:6:3,
|
|
97960 ' LEX', LXCLOCK/1000:6:3,
|
|
97970 ' SEM', (SEMCLK-EMITCLK)/1000:6:3,
|
|
97980 ' EMIT', EMITCLK/1000:6:3); ()+22*) ()+01*)
|
|
97990 (*+01()
|
|
98000 IF LSTPAGE<>0 THEN
|
|
98010 IF ONLINE THEN WRITELN(LSTFILE, ' ', 'CPU', (CPUCLK+CLOCK)/1000:6:3)
|
|
98020 ELSE WRITELN(' ', 'CPU', (CPUCLK+CLOCK)/1000:6:3);
|
|
98030 IF ERRS<>0 THEN BEGIN MESSAGE('BAD PROGRAM - ABORTED'); ACLOSE(OUTPUT); ABORT END
|
|
98040 ELSE IF PRGGO IN PRAGFLGS THEN
|
|
98050 BEGIN
|
|
98060 PUTSEG(LGO);
|
|
98070 IF ONLINE AND (LSTPAGE<>0) THEN ACLOSE(LSTFILE);
|
|
98080 IF (WARNS<>0) OR NOT ONLINE AND (LSTPAGE<>0) THEN ACLOSE(OUTPUT);
|
|
98090 LOADGO(LGO)
|
|
98100 END
|
|
98110 ELSE MESSAGE('NO ERRORS');
|
|
98120 ()+01*)
|
|
98130 (*+03()
|
|
98140 CPUTIME(CPUCLK);
|
|
98150 IF LSTPAGE<>0 THEN
|
|
98160 IF ONLINE THEN WRITELN(LSTFILE, ' ', 'CPU', CPUCLK:4, 'SECS')
|
|
98170 ELSE WRITELN(' ', 'CPU', CPUCLK:4, ' SECS');
|
|
98180 IF ERRS<>0 THEN WRITELN(' ', 'ERRORS DETECTED')
|
|
98190 ELSE WRITELN(' ', 'NO ERRORS');
|
|
98200 CLOSE(SOURCDECS);
|
|
98210 CLOSE(LSTFILE);
|
|
98220 CLOSE(OUTPUT);
|
|
98230 ()+03*)
|
|
98232 (*+05()
|
|
98234 IF ERRS<>0 THEN BEGIN WRITELN(ERROR); WRITELN(ERROR, 'BAD PROGRAM - ABORTED'); ABORT END;
|
|
98236 ()+05*)
|
|
98237 (*+02()
|
|
98238 IF ERRS<>0 THEN BEGIN WRITELN; WRITELN('BAD PROGRAM - ABORTED'); ABORT END;
|
|
98239 ()+02*)
|
|
98240 END;
|
|
98260 (**)
|
|
98270 (**)
|
|
98280 (*+01() (*$P++) (*SO THAT IT KNOWS ABOUT PASCPMD*) ()+01*)
|
|
98290 (*+04() PROCEDURE S1; ()+04*)
|
|
98300 (*+25() (*$P++) ()+25*)
|
|
98310 (*-03()(*+71()
|
|
98320 BEGIN
|
|
98330 ALGOL68
|
|
98340 (*+01() (*-31() (*$P-+) ()-31*) ()+01*)
|
|
98350 (*+25() (*-31() (*$P-+) ()-31*) ()+25*)
|
|
98360 END (*+01() (*$G-+) ()+01*)(*+25() (*$G-+) ()+25*).
|
|
98370 ()+71*)()-03*)
|
|
98380 ()+82*)
|