01000 #include "rundecs.h"
01010     (*  COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER  *)
01020 (**)
01030 PROCEDURE CL68(PB: ASNAKED; RF: OBJECTP); EXTERN;
01040 (*+05() FUNCTION TIME: REAL; EXTERN; ()+05*)
01050 PROCEDURE ABORT; EXTERN;
01060 PROCEDURE ACLOSE(EFET: FETROOMP); EXTERN;
01070 PROCEDURE GARBAGE (ANOBJECT: OBJECTP); EXTERN ;
01080 (**)
01090 (**)
01100 FUNCTION CRSTRUCT(TEMPLATE: DPOINT): OBJECTP; EXTERN;
01110 FUNCTION GETPROC(RN: OBJECTP): ASNAKED; EXTERN;
01120 (*+02() FUNCTION GETLINENO :INTEGER; EXTERN; ()+02*)
01130 (**)
01140 (**)
01150 PROCEDURE ERRORR(N :INTEGER); FORWARD;
01160 (**)
01170 (**)
01180 FUNCTION RELSUP(REF: OBJECTP): UNDRESSP;
01190 (*FINDS THE TRUE POINTER TO A REFERENCE VALUE*)
01200     BEGIN
01210     WITH REF^ DO
01220       CASE SORT OF
01230         REFSL1:
01240           RELSUP := INCPTR(ANCESTOR, OFFSET);
01250         REFSLN, UNDEF:
01260           ERRORR(IDREL);
01270         REF1, REF2, REFN, RECN, REFR, RECR, NILL:
01280           RELSUP := ASPTR(ORD(REF));
01290         CREF:
01300           RELSUP := IPTR;
01310         END;
01320     IF FPTST(REF^) THEN GARBAGE(REF)
01330     END;
01340 (**)
01350 (**)
01360 PROCEDURE ERRORR (*N: INTEGER*);
01370  TYPE BYTES = PACKED ARRAY [1..BYTESWIDTH] OF CHAR ;
01380   VAR RANGE: PRANGE;
01390       CURR: IPOINT;
01400       XCASE: 0..15;
01410       IDP: PIDBLK;
01420       RP,RQ : RECORD CASE SEVERAL OF
01430         1: ( PP : OBJECTPP ) ;
01440         2: ( PI : ^ INTEGER ) ;
01450         3: ( PR : ^ REAL ) ;
01460         4: ( PB : ^ BYTES ) ;
01470         5: ( PD : ^ INTEGER ) ;
01480         0 , 6 , 7 , 8 , 9 , 10 : () ;
01490         END ;
01500       INT: INTEGER ;
01510       POINT: OBJECTP ;
01520       PI1: ^INTEGER ;
01530       RANGECOUNT :INTEGER ; DECPOINT :OFFSETRANGE ; COUNT :INTEGER ;
01540       LOOPTYP : INTEGER ;
01550       THISWAS68: BOOLEAN ;
01560       PFET: FETROOMP;
01570 (*+02() LOCALRANGE :BOOLEAN ; ()+02*)
01580 (*+54() EXCEPT: UNDRESSP; IB: IPOINT; RG: PRANGE; ()+54*)
01590   PROCEDURE PRINTREAL(X: REAL);
01600     VAR RTG: REALTEGER;
01610       BEGIN WITH RTG DO
01620         BEGIN
01630         REA := X;
01640         IF (INT=INTUNDEF) (*+05()OR (INT2=INTUNDEF)()+05*) THEN WRITE(OUTPUT, ' UNDEFINED')
01650         ELSE WRITE(OUTPUT, X);
01660         END
01670       END;
01680   PROCEDURE PRINTSINGLE(II :INTEGER);
01690 (*+01()
01700     VAR RTG: PACKED RECORD CASE SEVERAL OF
01710           1: ( INT : INTEGER ) ;
01720           2: ( REA : REAL ) ;
01730           3: ( SIGN : BOOLEAN ; EXP : 0..3777B ; MANT : 0..7777777777777777B )
01740         END ;
01750       BEGIN WITH RTG DO
01760         BEGIN
01770         INT := II;
01780         IF II=INTUNDEF THEN WRITE('UNDEFINED')
01790         ELSE IF EXP=ORD(SIGN)*3777B THEN
01800           BEGIN WRITE(II:1);
01810           IF  (II<64) AND (II>=0)  THEN  WRITE(' (', CHR(II), ')');
01820           END
01830         ELSE WRITE(REA)
01840         END
01850       END;
01860 ()+01*)
01870 (*+02()
01880   BEGIN
01890     IF II = INTUNDEF THEN WRITE( OUTPUT , 'UNDEFINED' )
01900     ELSE
01910       BEGIN
01920         WRITE( OUTPUT , II : 1 ) ;
01930         IF ( II >= 32 ) AND ( II < 128 ) THEN WRITE( OUTPUT , ' (' , CHR( II ) , ')' )
01940       END
01950   END ;
01960 ()+02*)
01970 (*+05()
01980   BEGIN
01990     IF II = INTUNDEF THEN WRITE( OUTPUT , 'UNDEFINED' )
02000     ELSE
02010       BEGIN
02020         WRITE( OUTPUT , II : 1 ) ;
02030         IF ( II >= 32 ) AND ( II < 128 ) THEN WRITE( OUTPUT , ' (' , CHR( II ) , ')' )
02040       END
02050   END ;
02060 ()+05*)
02070   PROCEDURE PRINTDOUBLE( LV : A68LONG ) ;
02080 (*+01()
02090     BEGIN
02100     END ;
02110 ()+01*)
02120 (*+05()
02130     BEGIN
02140     PRINTREAL(LV);
02150     END ;
02160 ()+05*)
02170 (*+02()
02180 (*+12()
02190     BEGIN
02200     PRINTREAL(LV);
02210     END ;
02220 ()+12*)
02230 (*+13()
02240     BEGIN
02250     PRINTREAL(LV);
02260     END;
02270 ()+13*)
02280 ()+02*)
02290   PROCEDURE PRINTVAL(ANOBJECT :OBJECTP);FORWARD;
02300     PROCEDURE PRINTBIGD(ANOBJECT :OBJECTP; TEMPLATE :DPOINT; OFF :INTEGER);
02310       VAR I, J :INTEGER;
02320     PROCEDURE PRINTD(ANOBJECT :OBJECTP; TEMPLATE :DPOINT);
02330       LABEL 9;
02340       VAR TEMPOS, I :INTEGER;
02350         BEGIN
02360         RQ.PI := INCPTR(ANOBJECT, OFF) ;
02370         WITH RQ DO
02380         IF ORD(TEMPLATE)<=MAXSIZE THEN (*NOT STRUCT*)
02390           IF ORD(TEMPLATE)=0  THEN (*DRESSED*)
02400             IF PP ^ ^.SORT IN [REF1,REF2,CREF,REFSL1] THEN
02410               WRITE(OUTPUT , 'REF #', ORD( RELSUP(PP ^) ):(*-01()1()-01*)(*+01()6 OCT()+01*) )
02420             ELSE PRINTVAL(PP ^)
02430 (*-01()   ELSE IF ORD(TEMPLATE)>SZINT THEN PRINTDOUBLE(PR^) ()-01*)
02440           ELSE PRINTSINGLE( PI ^ )
02450         ELSE (*PART OF STRUCT*)
02460           BEGIN
02470           TEMPOS := 1;
02480           WHILE TEMPLATE^[TEMPOS]>=0 DO
02490             BEGIN
02500             IF TEMPLATE^[TEMPOS]=OFF THEN
02510               BEGIN
02520               IF PP ^ ^.SORT IN [REF1,CREF,REFSL1] THEN
02530                 WRITE(OUTPUT , 'REF #', ORD( RELSUP(PP ^) ):(*-01()1()-01*)(*+01()6 OCT()+01*) )
02540               ELSE PRINTVAL(PP ^);
02550               OFF := OFF+SZADDR;
02560               GOTO 9
02570               END;
02580             TEMPOS := TEMPOS+1
02590             END;
02600           INT := ORD( PI^ ) ;
02610           IF INT = INTUNDEF THEN
02620             BEGIN
02630               WRITE( OUTPUT , 'UNDEFINED' ) ;
02640               OFF := OFF + SZINT
02650             END
02660           ELSE CASE TEMPLATE^[TEMPOS+1+J] OF
02670             0: (*NO ACTION*);
02680             1: BEGIN WRITE( OUTPUT , PI ^ : 1 ); OFF := OFF+SZINT END;
02690             3: BEGIN WRITE( OUTPUT , PR ^ ); OFF := OFF+SZREAL END;
02700             5: BEGIN
02710                PRINTREAL(PR^); WRITE(OUTPUT, ' I'); OFF := OFF+SZREAL;
02720                PR := INCPTR(ANOBJECT, OFF);
02730                PRINTREAL(PR^);
02740                OFF := OFF+SZREAL;
02750                END;
02760             7: BEGIN WRITE(OUTPUT , '"', CHR( PI ^ ) , '"'); OFF := OFF+SZINT END;
02770             9: BEGIN
02780 (*+01()        IF PI^<0  THEN ()+01*)
02790 (*-01()        IF PI^<>0 THEN ()-01*)
02800                  WRITE(OUTPUT , '.TRUE') ELSE WRITE(OUTPUT , '.FALSE'); OFF := OFF+SZINT
02810                END;
02820             10: BEGIN WRITE( OUTPUT , PI ^ : (*-01()1()-01*)(*+01()20 OCT()+01*) ); OFF := OFF+SZINT END;
02830             11: BEGIN
02840                 (*+05() RQ.PI := ASPTR( ORD( PI ) * 2 ) ; ()+05*)
02850                 WRITE( OUTPUT , '"', (*+05()RQ.()+05*)PB ^ , '"') ;
02860                 OFF := OFF + SZINT
02870                 END ;
02880             12: BEGIN WRITE( OUTPUT , 'PROC'); OFF := OFF+1; OFF := OFF+SZADDR END;
02890             END;
02900       9: J := J+1;
02910           END
02920         END;
02930         BEGIN (* OF PRINTBIGD *)
02940         J := 0; I := OFF;
02950         IF ORD(TEMPLATE)>MAXSIZE THEN (*COMPLETE STRUCT*)
02960           BEGIN WRITE( OUTPUT , '(');
02970           WHILE OFF-I<TEMPLATE^[0] DO
02980             BEGIN IF J<>0 THEN WRITE( OUTPUT , ', '); PRINTD(ANOBJECT, TEMPLATE) END;
02990           WRITE( OUTPUT , ')')
03000           END
03010         ELSE PRINTD(ANOBJECT, TEMPLATE)
03020         END;
03030   PROCEDURE PRINTVAL;
03040     VAR I, K :INTEGER;
03050         ELEMENTS :OBJECTP;
03060       BEGIN (*OF PRINTVAL*)
03070       WITH ANOBJECT^ DO
03080         CASE SORT OF
03090           STRING:
03100             BEGIN
03110               WRITE( OUTPUT , ' STRING "');
03120               FOR I := 1 TO STRLENGTH DO WRITE( OUTPUT , CHARVEC[I]);
03130               WRITE( OUTPUT , '"')
03140             END;
03150           ROUTINE:
03160             BEGIN WRITE( OUTPUT , ' PROC   ');
03170                   WRITE( OUTPUT , PROCBL^.ROUTNAME.ALF, ' ', ENVCHAIN:(*-01()1()-01*)(*+01()6 OCT()+01*) ) END;
03180           STRUCT:
03190             BEGIN WRITE( OUTPUT , ' STRUCT');
03200             PRINTBIGD(INCPTR(ANOBJECT, STRUCTCONST), DBLOCK,  0)
03210             END;
03220           COVER:
03230             BEGIN
03240             IF (OPENED IN STATUS) AND NOT ASSOC THEN
03250               BEGIN
03260               ACLOSE(BOOK);
03270               IF NOT(STARTUP IN STATUS) THEN BEGIN PFET := BOOK;
03280                 DISPOSE(PFET) END;
03290               STATUS := STATUS-[OPENED];
03300               END;
03310             WRITE( OUTPUT , ' (', POFCPOS:1, ',', LOFCPOS:1, ',', COFCPOS:1, ')');
03320             END;
03330           REF1:
03340             PRINTSINGLE(VALUE);
03350 (*-01()   REF2:
03360             PRINTDOUBLE( LONGVALUE ) ; ()-01*)
03370           REFSL1:
03380             PRINTBIGD(ANCESTOR^.PVALUE, DBLOCK, OFFSET);
03390           CREF:
03400             PRINTSINGLE(IPTR^.FIRSTWORD);
03410           RECN, REFN:
03420             WRITE( OUTPUT , ' REF    #', ORD(ANOBJECT):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO STRUCT');
03430           REFR, RECR:
03440             WRITE( OUTPUT , ' REF    #', ORD(ANOBJECT):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ARRAY');
03450           REFSLN:
03460             WRITE( OUTPUT , ' REF         TO SLICE');
03470           NILL:
03480             WRITE( OUTPUT , ' NIL');
03490           UNDEF:
03500             WRITE( OUTPUT , ' UNDEFINED');
03510           END;
03520       END;  (* OF PRINTVAL *)
03530   PROCEDURE PRINTMULT(ANOBJECT:OBJECTP);
03540     VAR I, K :INTEGER;
03550         ELEMENTS:OBJECTP;
03560       BEGIN
03570       WITH ANOBJECT^ DO
03580         BEGIN
03590         IF SORT<>REFSLN THEN BEGIN WRITE( OUTPUT , ' ARRAY  '); ELEMENTS := PVALUE END
03600         ELSE BEGIN WRITE( OUTPUT , ' SLICE  '); ELEMENTS := ANCESTOR^.PVALUE END;
03610         WRITE( OUTPUT , '[');
03620         FOR I := ROWS DOWNTO 0 DO WITH DESCVEC[I] DO
03630           BEGIN WRITE( OUTPUT , LI:1, ':', UI:1); IF I>0 THEN WRITE( OUTPUT , ', ') END;
03640         WRITE( OUTPUT , ']');
03650         IF ROWS=0 THEN (*1 DIMENSION ONLY*) WITH DESCVEC[0] DO
03660           BEGIN
03670           FOR I := LI TO LI+2 DO IF I<=UI THEN
03680             BEGIN WRITELN( OUTPUT ) ; WRITE( OUTPUT , '            ');
03690             PRINTBIGD(INCPTR(ELEMENTS, DI*I-LBADJ), MDBLOCK, 0) END;
03700           IF UI-LI>5 THEN
03710             BEGIN WRITELN( OUTPUT ); WRITE( OUTPUT , '            ...'); K := UI-2 END
03720           ELSE K := LI + 3 ;
03730           FOR I := K TO UI DO
03740             BEGIN WRITELN( OUTPUT ); WRITE( OUTPUT , '            ');
03750             PRINTBIGD(INCPTR(ELEMENTS, DI*I-LBADJ), MDBLOCK, 0) END
03760           END
03770         END
03780       END;
03790     BEGIN (*OF ERROR*)
03800 (*+02()LOCALRANGE := TRUE;()+02*)
03810     CURR := DYNAMIC(ME);
03820 (*+54()
03830     IB := CURR;
03840     REPEAT
03850       SETMYSTATIC(IB);
03860       IF ISA68(IB) THEN
03870         BEGIN
03880         RG := FIRSTRG.RIBOFFSET;
03890         WHILE (RG^.FIRSTW.TRACESAVE=NIL) AND (RG^.RIBOFFSET<>FIRSTRG.RIBOFFSET) DO
03900           RG := RG^.RIBOFFSET;
03910         END;
03920       IB := DYNAMIC(IB);
03930     UNTIL (SCOPE=1) OR (RG^.FIRSTW.TRACESAVE<>NIL);
03940     WITH RG^ DO
03950       IF (FIRSTW.TRACESAVE<>NIL) AND (N<>0) THEN
03960         BEGIN
03970         SETMYSTATIC(CURR);
03980         EXCEPT := INCPTR(CRSTRUCT(EXCEPTDB), STRUCTCONST);
03990         EXCEPT^.FIRSTWORD := N;
04000         CL68(GETPROC(FIRSTW.TRACESAVE), INCPTR(EXCEPT, -STRUCTCONST));
04010         END;
04020 ()+54*)
04030     WRITELN( OUTPUT );
04040     WRITELN( OUTPUT , ' RUN-TIME ERROR');
04050     WRITE( OUTPUT , ' ');
04060     IF (N>56) OR (N<0) THEN WRITE( OUTPUT , (*+54()'USER DEFINED ',()+54*) 'ERROR NO. ', N:1)
04070     ELSE
04080     CASE N OF
04090 (*+05()
04100       -16,-15,-14,-13,-12,-11,-10,-9,-8,-7,-6,-5,-4,-3,-2,-1: (* SYSTEM INTERRUPTS *)
04110         WRITE( OUTPUT ,  'SIGNAL NUMBER ' , -N:1 ) ;
04120 ()+05*)
04130       0: (*NO FURTHER ACTION*);
04140       1: (*RASSIG*)
04150         WRITE( OUTPUT ,  'ASSIGNATION TO UNDEFINED NAME');
04160       2: (*RSEL*)
04170         WRITE( OUTPUT ,  'SELECTION FROM UNDEFINED STRUCTURE');
04180       3: (*RDEREF*)
04190         WRITE( OUTPUT ,  'DEREFERENCING UNDEFINED NAME');
04200       4: (*RASSIGNIL*)
04210         WRITE( OUTPUT ,  'ASSIGNATION TO .NIL');
04220       5: (*RSELNIL*)
04230         WRITE( OUTPUT ,  'SELECTION FROM .NIL');
04240       6: (*RDEREFNIL*)
04250         WRITE( OUTPUT ,  'DEREFERENCING .NIL');
04260       7: (*IDREL*)
04270         WRITE( OUTPUT ,  'IDENTITY-RELATION INVOLVING UNDEFINED NAME, OR NAME OF SLICE');
04280       8: (*RPOWNEG*)
04290         WRITE( OUTPUT ,  'RAISING AN .INT TO A -VE POWER');
04300       9: (*RBYTESPACK*)
04310         WRITE( OUTPUT ,  'BYTESPACK ON .STRING LONGER THAN BYTES WIDTH');
04320       13: (*RCLOWER*)
04330         WRITE( OUTPUT ,  'UNDEFINED LOWER-BOUND IN ACTUAL-DECLARER');
04340       14: (*RCUPPER*)
04350         WRITE( OUTPUT ,  'UNDEFINED UPPER-BOUND IN ACTUAL-DECLARER');
04360       15: (*RLWUPB*)
04370         WRITE( OUTPUT ,  'LEFT OPERAND OF .LWB OR .UPB OUT OF RANGE');
04380       16: (*RSL1ERROR*)
04390         WRITE( OUTPUT , 'SUBSCRIPT (OR LOWER-BOUND) TOO LOW');
04400       17: (*RSL2ERROR*)
04410         WRITE( OUTPUT , 'SUBSCRIPT (OR UPPER-BOUND) TOO HIGH');
04420       18: (*RSLICE*)
04430         WRITE( OUTPUT , 'SLICE FROM UNDEFINED ARRAY');
04440       19: (*RSLICENIL*)
04450         WRITE( OUTPUT , 'SLICE FROM .NIL');
04460       20: (*RMULASS*)
04470         WRITE( OUTPUT , 'BOUNDS MISMATCH IN ASSIGNATION OF ARRAY');
04480       21: (*RROUTN*)
04490         WRITE( OUTPUT , 'CALL OF UNDEFINED ROUTINE');
04500       22: (*RCHARERROR*)
04510         WRITE( OUTPUT , 'PRINTING NON-EXISTENT .CHAR');
04520       23: (*RSCOPE*)
04530         WRITE( OUTPUT , 'SCOPE VIOLATION');
04540       24: (*RARG*)
04550         WRITE( OUTPUT , 'ARGUMENT OF ZERO IS IMPOSSIBLE');
04560       RDUMMY:
04570         WRITE( OUTPUT , 'FEATURE NOT IMPLEMENTED YET');
04580       NOREAD,NOWRITE,NOBIN,NORESET,NOSET,NOESTAB:
04590         WRITE( OUTPUT , 'IMPOSSIBLE TRANSPUT OPERATION');
04600       NOTOPEN:
04610         WRITE( OUTPUT , 'FILE NOT OPEN');
04620       NOPHYSICAL:
04630         WRITE( OUTPUT , 'PHYSICAL END OF FILE REACHED');
04640       NOLOGICAL:
04650         WRITE( OUTPUT , 'LOGICAL END OF FILE REACHED');
04660       NOMOOD:
04670         WRITE( OUTPUT , 'NOT KNOWN WHETHER READING OR WRITING');
04680       POSMIN:
04690         WRITE( OUTPUT , '(P,L,C) < (1,1,1)');
04700       POSMAX:
04710         WRITE( OUTPUT , '(P,L,C) > PHYSICAL FILE SIZE');
04720       SMALLLINE:
04730         WRITE( OUTPUT , 'LINE TOO SHORT FOR VALUE');
04740       WRONGCHAR:
04750         WRITE( OUTPUT , 'UNACCEPTABLE CHARACTER READ');
04760       NODIGIT:
04770         WRITE( OUTPUT , 'DIGIT EXPECTED');
04780       WRONGVAL:
04790         WRITE( OUTPUT , 'VALUE OUT OF RANGE');
04800       WRONGMULT:
04810         WRITE( OUTPUT , 'LOWER BOUND OF ASSOCIATED ARRAY /= 1');
04820       NOALTER,NOSHIFT:
04830         WRITE( OUTPUT , 'ILLEGAL CHANGE TO/FROM BINARY TRANSPUT');
04840       END;
04850     WRITE( OUTPUT , ', DETECTED IN ');
04860     THISWAS68 := FALSE ;
04870     REPEAT
04880       SETMYSTATIC(CURR);
04890       IF ISA68(CURR) THEN
04900       BEGIN
04910       THISWAS68 := TRUE ;
04920 (*+02()IF LOCALRANGE THEN
04930           BEGIN
04940           WRITE(OUTPUT, 'LINE ', GETLINENO:1);
04950           LOCALRANGE := FALSE;
04960           END
04970        ELSE ()+02*)
04980             WRITE( OUTPUT , 'LINE ', LINENO:1);
04990       IF SCOPE<>1 THEN
05000         WRITELN( OUTPUT ,' OF PROCEDURE ', PROCBL^.ROUTNAME.ALF)
05010       ELSE WRITELN( OUTPUT , ' OF MAIN PROGRAM');
05020       RANGE := FIRSTRG.RIBOFFSET; RANGECOUNT := 0;
05030       REPEAT WITH RANGE^ DO
05040         WITH FIRSTW , RP  DO
05050         BEGIN
05060         WRITELN( OUTPUT );
05070         IF RIBOFFSET<>FIRSTRG.RIBOFFSET THEN
05080           BEGIN WRITE( OUTPUT , ' RANGE ', RANGECOUNT:2); IDP := RGIDBLK;
05090           (*-41() PP := INCPTR ( RANGE , RGCONST ) ; ()-41*)
05100           (*+41() PP := ASPTR ( ORD( RANGE ) ) ; ()+41*)
05110           END
05120         ELSE IF SCOPE<>1 THEN
05130           BEGIN WRITE( OUTPUT , ' PARAMETERS'); IDP := RGIDBLK;
05140           (*-41() PP :=ASPTR(CURR-PARAMOFFSET-PROCBL^.PARAMS) ()-41*)
05150           (*+41() PP :=ASPTR((*+02()ARGBASE()+02*)(CURR)-PARAMOFFSET+PROCBL^.PARAMS) ()+41*)
05160           END
05170         ELSE IDP := NIL;
05180         IF IDP<>NIL THEN
05190           BEGIN
05200           RANGECOUNT := RANGECOUNT-1;
05210           (*-41() WHILE ORD ( PP ) < ORD ( RGNEXTFREE ) DO ()-41*)
05220           (*+41() WHILE ORD ( PP ) > ORD ( RGLASTUSED ) DO ()+41*)
05230             BEGIN
05240               IDP := INCPTR(IDP, -SZIDBLOCK);
05250               WITH IDP ^ DO
05260                 BEGIN
05270                   (*+41()
05280                   IF IDSIZE <> 0 THEN
05290                     PP := INCPTR( PP , - IDSIZE )
05300                   ELSE
05310                     PP := INCPTR( PP , - SZADDR ) ;
05320                   ()+41*)
05330                 WRITELN( OUTPUT ); WRITE( OUTPUT , ' ', ALF);
05340                 IF XMODE>=16 THEN
05350                   BEGIN WRITE( OUTPUT , ' LOC'); XCASE := XMODE-16 END
05360                 ELSE BEGIN WRITE( OUTPUT , '    '); XCASE := XMODE END;
05370                 INT := ORD (PI^) ;
05380                 IF INT=INTUNDEF THEN WRITE( OUTPUT , '        UNDEFINED')
05390                 ELSE CASE XCASE OF
05400                   0: (*REF*)
05410                     WITH PP ^ ^ DO
05420                   CASE SORT OF
05430                     REF1, REF2, CREF, REFSL1:
05440                       BEGIN
05450                         WRITE( OUTPUT , ' REF    #', ORD(RELSUP(PP ^)):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ') ;
05460                         PRINTVAL(PP ^)
05470                       END;
05480                     RECN, REFN:
05490                       BEGIN
05500                         WRITE( OUTPUT , ' REF   #', ORD(PP ^):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ') ;
05510                         PRINTVAL(PVALUE)
05520                       END;
05530                     RECR, REFR:
05540                       BEGIN
05550                         WRITE( OUTPUT , ' REF   #', ORD(PP ^):(*-01()1()-01*)(*+01()6 OCT()+01*) , ' TO ') ;
05560                         PRINTMULT(PP ^)
05570                       END;
05580                     REFSLN:
05590                       BEGIN WRITE( OUTPUT , ' REF           TO '); PRINTMULT(PP ^) END;
05600                     NILL:
05610                       WRITE( OUTPUT , ' REF    NIL');
05620                     UNDEF:
05630                       WRITE( OUTPUT , ' REF    UNDEFINED');
05640                     END;
05650                   1: (*INT*)
05660                     WRITE( OUTPUT , ' INT    ', PI ^ :1);
05670                   3: (*REAL*)
05680                     WRITE( OUTPUT , ' REAL   ', PR ^ );
05690                   5: (*COMPL*)
05700                     BEGIN
05710                       IF XMODE>=16 THEN POINT := PP ^ ^.PVALUE ELSE POINT := PP ^ ;
05720                       WITH POINT ^ DO
05730                        BEGIN WRITE(OUTPUT, ' COMPL  '); PRINTREAL(RE); WRITE(OUTPUT, ' I'); PRINTREAL(IM); END
05740                     END;
05750                   7: (*CHAR*)
05760                     WRITE( OUTPUT , ' CHAR   "', CHR( PI ^ ) , '"');
05770                   8: (*STRING*)
05780                     IF PP^=UNDEFIN THEN WRITE( OUTPUT , ' STRING ""')
05790                     ELSE PRINTVAL(PP^);
05800                   9: (*BOOL*)
05810 (*+01()             IF PI^<0  THEN ()+01*)
05820 (*-01()             IF PI^<>0 THEN ()-01*)
05830                       WRITE( OUTPUT , ' BOOL   .TRUE') ELSE WRITE( OUTPUT , ' BOOL   .FALSE');
05840                   10: (*BITS*)
05850                     WRITE( OUTPUT , ' BITS   ', PI ^ : (*-01()1()-01*)(*+01()20 OCT()+01*) );
05860                   11: (*BYTES*)
05870                     BEGIN
05880                     (*+05() RQ.PI := ASPTR( ORD( PI ) * 2 ) ; ()+05*)
05890                     WRITE( OUTPUT , ' BYTES  "', (*+05()RQ.()+05*)PB ^ , '"' )
05900                     END ;
05910                   12: (*PROC*)
05920                     PRINTVAL(PP ^);
05930                   13: (*STRUCT*)
05940                     BEGIN IF XMODE>=16 THEN POINT := PP ^ ^.PVALUE ELSE POINT := PP ^ ;  PRINTVAL(POINT) END;
05950                   14: (*ROW*)
05960                     PRINTMULT(PP ^);
05970                   END ;
05980                   (*-41()
05990                   IF IDSIZE<>0 THEN
06000                     PP := INCPTR ( PP , IDSIZE )
06010                   ELSE
06020                     PP := INCPTR ( PP , SZADDR )
06030                   ()-41*)
06040                 END
06050               END;
06060             END;
06070             IF (RIBOFFSET=FIRSTRG.RIBOFFSET) AND (SCOPE <> 1) THEN (*PARAMS*)
06080               PP:=(*+41() ASPTR(ORD(RANGE))       ()+41*)
06090                   (*-41() INCPTR(RANGE,RGCONST)   ()-41*)
06100             ELSE
06110               PP := (*+41() INCPTR(RGLASTUSED, -SZINT ); ()+41*)
06120                     (*-41() ASPTR(ORD(RGNEXTFREE))     ; ()-41*)
06130             LOOPTYP := PD^ ;
06140             FOR COUNT := 1 TO LOOPCOUNT DO
06150               BEGIN
06160               WRITELN( OUTPUT ) ;
06170               CASE LOOPTYP OF
06180                1: BEGIN
06190                   PI1 := INCPTR( PI , 2 * STACKSZINT ) ;
06200                   WRITELN( OUTPUT , '.FOR ', PI1 ^ :1);
06210                   PI1 := INCPTR( PI , STACKSZINT ) ;
06220                   WRITELN( OUTPUT , '.BY  ', PI1 ^ :1);
06230                   PI1 := INCPTR( PI , 3 * STACKSZINT ) ;
06240                   WRITE  ( OUTPUT , '.TO  ', PI1 ^ :1);
06250                   PD := INCPTR( PD , 4 * STACKSZINT )
06260                   END;
06270                2: BEGIN
06280                   PI1 := INCPTR( PI , STACKSZINT ) ;
06290                   WRITELN( OUTPUT , '.FOR ', PI1 ^ :1);
06300                   PI1 := INCPTR( PI , 2 * STACKSZINT ) ;
06310                   WRITE  ( OUTPUT , '.TO  ', PI1 ^  :1);
06320                   PD := INCPTR( PD , 3 * STACKSZINT )
06330                   END;
06340                3: BEGIN
06350                   PI1 := INCPTR( PI , 2 * STACKSZINT ) ;
06360                   WRITELN( OUTPUT , '.FOR ', PI1 ^ :1);
06370                   PI1 := INCPTR( PI , STACKSZINT ) ;
06380                   WRITE  ( OUTPUT , '.BY  ', PI1 ^ :1);
06390                   PD := INCPTR( PD , 3 * STACKSZINT )
06400                   END;
06410                4: BEGIN
06420                   PI1 := INCPTR( PI , STACKSZINT ) ;
06430                   WRITE  ( OUTPUT , '.FOR ', PI1 ^ :1);
06440                   PD := INCPTR( PD , 2 * STACKSZINT )
06450                   END
06460               END;
06470               LOOPTYP := PD^
06480             END;
06490           RANGE := RIBOFFSET;
06500           WRITELN( OUTPUT )
06510         END
06520       UNTIL RANGE=FIRSTRG.RIBOFFSET;
06530       WRITELN( OUTPUT );
06540       WRITE( OUTPUT , ' WHICH WAS CALLED FROM ')
06550       END
06560      ELSE THISWAS68 := FALSE ;
06570       CURR := DYNAMIC(CURR);
06580     UNTIL (SCOPE=1) AND THISWAS68 ;
06590    WRITELN( OUTPUT , 'STANDARD-PRELUDE');
06600 (*+01()
06610     WRITELN(' CPU ', (CPUCLOCK+CLOCK)/1000:6:3);
06620     MESSAGE(' RUN ABORTED');
06630 ()+01*)
06640 (*+05()
06650     WRITELN(ERROR, ' RUN ABORTED');
06660     WRITELN(ERROR, ' CPU ', TIME :5:2);
06670 ()+05*)
06680     ABORT
06690     END;
06700 (**)
06710 (**)
06720 (*+01()
06730 PROCEDURE PDERR(VAR A: INTEGER; J,K,L,M: INTEGER; N: BOOLEAN;
06740                   VAR F: TEXT; VAR MSG: MESS);
06750 (*TO CATCH NOS- AND PASCAL-DETECTED ERRORS*)
06760   VAR I: INTEGER;
06770     BEGIN
06780     SETMYSTATIC(DYNAMIC(ME));
06790     WRITELN(F);
06800     I := 1;
06810     REPEAT
06820       WRITE(F, MSG[I]); I := I+1
06830     UNTIL ORD(MSG[I])=0;
06840     WRITELN(F);
06850     ERRORR(0);
06860     END;
06870 ()+01*)
06880 (**)
06890 (**)
06900 (*+54()
06910 PROCEDURE OFFERROR;
06920   VAR CURR, IB: IPOINT; RG: PRANGE;
06930     BEGIN
06940     CURR := STATIC(ME);
06950     IB := CURR;
06960     REPEAT
06970       SETMYSTATIC(IB);
06980       IF ISA68(IB) THEN
06990         BEGIN
07000         RG := FIRSTRG.RIBOFFSET;
07010         WHILE (RG^.FIRSTW.TRACESAVE=NIL) AND (RG^.RIBOFFSET<>FIRSTRG.RIBOFFSET) DO
07020           RG := RG^.RIBOFFSET;
07030         END;
07040       IB := DYNAMIC(IB);
07050     UNTIL (SCOPE=1) OR (RG^.FIRSTW.TRACESAVE<>NIL);
07060     WITH RG^.FIRSTW DO WITH TRACESAVE ^ DO
07070       IF TRACESAVE<>NIL THEN
07080       BEGIN
07090       FDEC; IF FTST THEN GARBAGE(TRACESAVE);
07100       TRACESAVE := NIL;
07110       END;
07120     SETMYSTATIC(CURR);
07130     END;
07140 (**)
07150 (**)
07160 PROCEDURE ONERROR(R: OBJECTP);
07170   VAR LOCRG: DEPTHRANGE;
07180       RG: PRANGE;
07190     BEGIN
07200     LOCRG := 0;
07210     RG := FIRSTRG.RIBOFFSET;
07220     WHILE RG^.RIBOFFSET<>FIRSTRG.RIBOFFSET DO
07230       BEGIN RG := RG^.RIBOFFSET; LOCRG := LOCRG+1 END;
07240     IF SCOPE+LOCRG<R^.OSCOPE THEN ERRORR(RSCOPE);
07250     WITH FIRSTRG.RIBOFFSET^ DO
07260       BEGIN
07270       IF FIRSTW.TRACESAVE<>NIL THEN WITH FIRSTW.TRACESAVE^ DO
07280         BEGIN FDEC; IF FTST THEN GARBAGE(FIRSTW.TRACESAVE) END;
07290       FIRSTW.TRACESAVE := R;
07300       FPINC(R^);
07310       END;
07320     END;
07330 (**)
07340 (**)
07350 FUNCTION MAKEXCE(N: INTEGER): OBJECTP;
07360   VAR NEWSTRUCT: UNDRESSP;
07370     BEGIN
07380     NEWSTRUCT := INCPTR(CRSTRUCT(EXCEPTDB), STRUCTCONST);
07390     NEWSTRUCT^.FIRSTWORD := N;
07400     MAKEXCE := INCPTR(NEWSTRUCT, -STRUCTCONST);
07410     END;
07420 (**)
07430 (**)
07440 ()+54*)
07450 (*-02() BEGIN END ; ()-02*)
07460 (*+01()
07470 BEGIN (*OF MAIN PROGRAM*)
07480 END (*OF EVERYTHING*).
07490 ()+01*)
