d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
ack/lang/a68s/liba68s/errorr.p

651 lines
26 KiB
OpenEdge ABL
Raw Permalink Normal View History

Initial revision
1988-10-04 13:41:01 +00:00
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*)
Reference in a new issue Copy permalink