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*)