650 lines
26 KiB
OpenEdge ABL
650 lines
26 KiB
OpenEdge ABL
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*)
|