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-I0 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+LOCRGNIL 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*)