Trailing-Edge
-
PDP-10 Archives
-
decuslib10-06
-
43,50417/libpas.pas
There are no other files named libpas.pas in the archive.
00100 (*$E+,T-,S1200
00200
00300 PASCAL RUNTIME PROGRAM LIBRARY (24-AUG-76,KISICKI)
00400
00500 DICTIONARY:
00600
00700 PAGE1 : DICTIONARY
00800 PAGE2 : CCL
00900 PAGE3 : DDT
01000 PAGE4 : STATUS
01100 PAGE5 : READ
01200 PAGE6 : WRITE
01300 PAGE7 : UNDEFINED
01400
01500 *)
00100 PROGRAM CCL, OPTION, GETOPTION, GETFILENAME, GETPARAMETER;
00200
00300 (******************************************************************************************
00400 *
00500 * (C) COPYRIGHT H.-H. NAGEL
00600 * INSTITUT FUER INFORMATIK
00700 * DER UNIVERSITAET HAMBURG
00800 * SCHLUETERSTRASSE 70
00900 * 2000 HAMBURG 13
01000 * GERMANY
01050 * 1976
01100 *
01200 *
01300 * PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
01400 *
01500 * DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
01600 *
01700 * PASCAL RUNTIME-SUPPORTS: GETPARAMETER
01800 *
01900 * PRE-DECLARED FUNCTIONS: OPTION
02000 *
02100 * PRE-DECLARED PROCEDURES: GETOPTION,
02200 * GETFILENAME
02300 *
02400 * DEFINITIONS:
02500 *
02600 * <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
02700 * <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
02800 * (<SWITCH>/.../<SWITCH>)
02900 * /<SWITCH>.../<SWITCH>
03000 *
03100 * <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
03200 * <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
03300 * <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
03400 * <VALUE> ::= <UNSIGNED DECIMAL NUMBER>
03500 *
03600 ****************************************************************************************)
03700
03800 TYPE
03900 ANYFILE = FILE OF INTEGER;
04000 PACK9 = PACKED ARRAY[1..9] OF CHAR;
04100 PACK6 = PACKED ARRAY[1..6] OF CHAR;
04200 PACK5 = PACKED ARRAY[1..5] OF CHAR;
04300 SOURCE_FORM = (TEMPFILE,COMMANDFILE,TELETYPEOUTPUT,TELETYPEINPUT,TELETYPE);
04400 DELIMITER = (BLANK,LPARENT,RPARENT,COMMA,POINT,SLASH,LESS,EQUAL,GREATER,RBRACK,LBRACK,COLON,EXCLAMATION,UNKNOWN);
04500 SWP = ^SWITCH_DESCRIPTOR;
04600 SWITCH_DESCRIPTOR = PACKED RECORD
04700 NAME: ALFA;
04800 LEFT, RIGHT: SWP;
04900 VALUE: INTEGER
05000 END;
05100
05200 VAR
05300 CALLCNT, PROT_OLD, UFD_OLD: INTEGER;
05400 TMP_FILENAME, COM_FILENAME, FILE_OLD: PACK9;
05500 SOURCE: SOURCE_FORM;
05700 END_OF_FILENAME, DEFAULTED, ERROR, USERCALL: BOOLEAN;
05800 LASTCH: CHAR;
05900 DEVICE_OLD: PACK6;
06000 CURRENT_SWITCH, NEW_SWITCH, SWITCH_TREE: SWP;
06100 DELIMITER1: ARRAY[' '..'/'] OF DELIMITER;
06200 DELIMITER2: ARRAY[':'..'>'] OF DELIMITER;
06300 DELIMITER3: ARRAY['['..']'] OF DELIMITER;
06400
06500 INITPROCEDURE;
06600 BEGIN
06700 SOURCE := TEMPFILE; CALLCNT := 0; USERCALL := TRUE; ERROR := FALSE;
06800 DEFAULTED := TRUE; LASTCH := ' ';
06900 COM_FILENAME := ' CMD';
07000 TMP_FILENAME := ' TMP';
07200 SWITCH_TREE := NIL; CURRENT_SWITCH := NIL;
07300 DELIMITER1[' '] := BLANK; DELIMITER1['!'] := EXCLAMATION;
07400 DELIMITER1['('] := LPARENT; DELIMITER1[')'] := RPARENT;
07500 DELIMITER1[','] := COMMA; DELIMITER1['.'] := POINT;
07600 DELIMITER1['/'] := SLASH;
07700 DELIMITER2[':'] := COLON; DELIMITER2['<'] := LESS;
07800 DELIMITER2['='] := EQUAL; DELIMITER2['>'] := GREATER;
07900 DELIMITER3['['] := LBRACK; DELIMITER3[']'] := RBRACK;
08000 END;
08100
08200 PROCEDURE ENTER(FNAME: ALFA; FVALUE: INTEGER);
08300
08400 PROCEDURE ENTER_SWITCH(FTREE: SWP);
08500 BEGIN
08600 WITH FTREE^ DO
08700 IF NEW_SWITCH^.NAME <> NAME
08800 THEN
08900 IF NEW_SWITCH^.NAME < NAME
09000 THEN
09100 IF LEFT = NIL
09200 THEN LEFT := NEW_SWITCH
09300 ELSE ENTER_SWITCH(LEFT)
09400 ELSE
09500 IF RIGHT = NIL
09600 THEN RIGHT := NEW_SWITCH
09700 ELSE ENTER_SWITCH(RIGHT)
09800 END (* ENTER_SWITCH *);
09900
10000 BEGIN (* ENTER *)
10100 NEW(NEW_SWITCH);
10200 WITH NEW_SWITCH^ DO
10300 BEGIN
10400 NAME := FNAME; VALUE := FVALUE;
10500 LEFT := NIL ; RIGHT := NIL
10600 END;
10700 IF SWITCH_TREE = NIL
10800 THEN SWITCH_TREE := NEW_SWITCH
10900 ELSE ENTER_SWITCH(SWITCH_TREE)
11000 END (* ENTER *);
11100
11200 (**********************************************************************
11300 *
11400 * FUNCTION OPTION
11500 *
11600 * - TEST IF <SWITCH> "SWITCHNAME" HAS BEEN
11700 * SPECIFIED IN THE DECSYSTEM-10 COMMAND-STRING
11800 * INTERPRETED BY PREVIOUS GETPARAMETER-/GETFILENAME-CALLS.
11900 *
12000 * OPTION IS A PRE-DECLARED FUNCTION AND AVAILABLE TO EVERY
12100 * PASCAL USER.
12200 *
12300 **********************************************************************)
12400
12500 FUNCTION OPTION(SWITCHNAME: ALFA): BOOLEAN;
12600
12700 FUNCTION FIND_SWITCH( FTREE: SWP): BOOLEAN;
12800 BEGIN
12900 IF FTREE <> NIL
13000 THEN
13100 WITH FTREE^ DO
13200 IF SWITCHNAME = NAME
13300 THEN
13400 BEGIN
13500 FIND_SWITCH := TRUE; CURRENT_SWITCH := FTREE
13600 END
13700 ELSE
13800 IF SWITCHNAME < NAME
13900 THEN
14000 FIND_SWITCH := FIND_SWITCH(LEFT)
14100 ELSE
14200 FIND_SWITCH := FIND_SWITCH(RIGHT)
14300 ELSE FIND_SWITCH := FALSE
14400 END (* FIND_SWITCH *);
14500
14600 BEGIN (*OPTION*)
14700 IF SWITCH_TREE = NIL
14800 THEN
14900 OPTION := FALSE
15000 ELSE
15100 OPTION := FIND_SWITCH(SWITCH_TREE)
15200 END (*OPTION*);
15300
15400 (**********************************************************************
15500 *
15600 * PROCEDURE GETOPTION
15700 *
15800 * - ASSIGN <VALUE> OF "SWITCHNAME" TO "SWITCHVALUE".
15900 *
16000 * GETOPTION IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO EVERY
16100 * PASCAL USER.
16200 *
16300 **********************************************************************)
16400
16500 PROCEDURE GETOPTION(SWITCHNAME: ALFA; VAR SWITCHVALUE: INTEGER);
16600 BEGIN
16700 IF OPTION(SWITCHNAME)
16800 THEN
16900 WITH CURRENT_SWITCH^ DO
17000 SWITCHVALUE := VALUE
17100 ELSE
17200 SWITCHVALUE := 0
17300 END (* GETOPTION *);
17400
17500 FUNCTION PICTURE(FCH: CHAR): DELIMITER;
17600 BEGIN
17700 IF FCH IN [' ','!','(',')',',','.','/',':','<','=','>','[',']']
17800 THEN
17900 IF FCH <= '/'
18000 THEN PICTURE := DELIMITER1[FCH]
18100 ELSE
18200 IF FCH <= '>'
18300 THEN PICTURE := DELIMITER2[FCH]
18400 ELSE PICTURE := DELIMITER3[FCH]
18500 ELSE PICTURE := UNKNOWN;
18600 END (* PICTURE *);
18700
18800 (**********************************************************************
18900 *
19000 * PROCEDURE GETFILENAME
19100 *
19200 * - READ DECSYSTEM-10 <FILE SPECIFICATION> FROM
19300 * "SOURCEFILE".
19400 *
19500 * GETFILENAME IS A PRE-DECLARED PROCEDURE
19600 * AND AVAILABLE TO EVERY PASCAL USER.
19700 *
19800 **********************************************************************)
19900
20000 PROCEDURE GETFILENAME(VAR SOURCEFILE: TEXT;
20100 VAR FILENAME: PACK9;
20200 VAR PROTECTION,UFD: INTEGER;
20300 VAR DEVICE: PACK6;
20400 FILEVARIABLE: ALFA);
20500 VAR
20600 BUFFER: ALFA;
20700 I, J, K, IMAX, OCVAL, SOURCE_PROT, SOURCE_PPN: INTEGER;
20800 SOURCE_FIL: PACKED ARRAY[1..9] OF CHAR;
20900 SOURCE_DEV: PACKED ARRAY[1..6] OF CHAR;
21000 CH,STATUS: CHAR;
21100 NEW_STATUS: BOOLEAN;
21200
21300 PROCEDURE RE_INITIALIZE;
21400 BEGIN
21500 I := 0; BUFFER := ' '; OCVAL := 0;
21600 NEW_STATUS := FALSE;
21700 END (* RE_INITIALIZE *);
21800
21900 PROCEDURE INITIALIZE;
22000 BEGIN
22100 FILENAME := ' '; DEVICE := 'DSK '; STATUS := ' '; IMAX := 6;
22200 CH := ' '; UFD := 0; PROTECTION := 0; ERROR := FALSE; END_OF_FILENAME := FALSE;
22300 RE_INITIALIZE; DEFAULTED := TRUE
22400 END (* INITIALIZE *);
22500
22600 PROCEDURE READCHAR;
22700 BEGIN
22800 I := I + 1;
22900 IF I > IMAX
23000 THEN ERROR := TRUE
23100 ELSE BUFFER[I] := CH
23200 END (*READCHAR*) ;
23300
23400 PROCEDURE READOCTAL;
23500 BEGIN
23600 IF CH IN ['0'..'7']
23700 THEN
23800 BEGIN
23900 OCVAL := OCVAL * 10B + ORD(CH) - ORD('0')
24000 END
24100 ELSE ERROR := TRUE
24200 END (*READOCTAL*) ;
24300
24400 PROCEDURE READDECIMAL;
24500 BEGIN
24600 IF CH IN ['0'..'9']
24700 THEN
24800 BEGIN
24900 OCVAL := OCVAL * 10 + ORD(CH) - ORD('0')
25000 END
25100 ELSE ERROR := TRUE
25200 END (*READDECIMAL*) ;
25300
25400 PROCEDURE SETSTATUS;
25500 BEGIN
25600 IF CH <> ' '
25700 THEN
25800 BEGIN
25900 CASE PICTURE(CH) OF
26000 COLON :
26100 ERROR := STATUS <> ' ';
26200 POINT :
26300 ERROR := NOT (STATUS IN [' ',':']);
26400 LBRACK :
26500 ERROR := NOT (STATUS IN [' ',':','.']);
26600 LESS :
26700 ERROR := NOT (STATUS IN [' ',':','.',']']);
26800 COMMA :
26900 ERROR := STATUS <> '[';
27000 RBRACK :
27100 ERROR := STATUS <> ',';
27200 GREATER :
27300 ERROR := STATUS <> '<';
27400 SLASH :
27500 ERROR := NOT (STATUS IN [' ',':','.',']','>',')']);
27600 LPARENT :
27700 ERROR := NOT (STATUS IN [' ',':','.',']','>']);
27800 RPARENT :
27900 ERROR := STATUS <> '(';
28000 OTHERS :
28100 ERROR := TRUE
28200 END;
28300 IF NOT ERROR
28400 THEN
28500 BEGIN
28600 NEW_STATUS := TRUE; STATUS := CH
28700 END
28800 END
28900 END (*SETSTATUS*) ;
29000
29100 PROCEDURE READSWITCH;
29200 VAR
29300 READ_VALUE, END_OF_SWITCH: BOOLEAN;
29400 BEGIN
29500 IF NOT EOLN(SOURCEFILE)
29600 THEN
29700 BEGIN
29800 REPEAT
29900 IMAX := ALFALENGTH;
30000 RE_INITIALIZE;
30100 READ_VALUE := FALSE;
30200 END_OF_SWITCH := FALSE;
30300 LOOP
30400 IF EOLN(SOURCEFILE)
30500 THEN
30600 BEGIN
30700 END_OF_SWITCH := TRUE; CH := ' '
30800 END
30900 ELSE READ(SOURCEFILE,CH);
31000 LASTCH := CH
31100 EXIT IF NOT (CH IN ['0'..'9',':','A'..'Z',' ']) OR END_OF_SWITCH;
31200 IF CH <> ' '
31300 THEN
31400 IF READ_VALUE
31500 THEN READDECIMAL
31600 ELSE
31700 IF CH = ':'
31800 THEN READ_VALUE := TRUE
31900 ELSE READCHAR
32000 END;
32100 IF I > 0
32200 THEN ENTER(BUFFER,OCVAL)
32300 UNTIL NOT (CH IN ['/','!',',']) OR ((CH = ',') AND (STATUS <> '(')) OR END_OF_SWITCH;
32400 IF CH IN [',','=']
32500 THEN
32600 BEGIN
32700 END_OF_FILENAME := TRUE; CH := ' '
32800 END;
32900 SETSTATUS
33000 END
33100 END (* READSWITCH *);
33200
33300
33400 PROCEDURE OPERAND;
33500
33600 PROCEDURE NEXTCH;
33700 BEGIN
33800 IF EOLN(SOURCEFILE)
33900 THEN
34000 BEGIN
34100 END_OF_FILENAME := TRUE; CH := ' '
34200 END
34300 ELSE READ(SOURCEFILE,CH);
34400 LASTCH := CH;
34500 IF END_OF_FILENAME OR ((CH=',') AND (STATUS<>'[')) OR (CH='=')
34600 THEN
34700 BEGIN
34800 END_OF_FILENAME := TRUE;
34900 CASE PICTURE(STATUS) OF
35000 BLANK:
35100 CH := '.';
35200 COLON:
35300 CH := '.';
35400 POINT:
35500 CH := '[';
35600 RPARENT,
35700 SLASH,
35800 GREATER,
35900 RBRACK:
36000 BEGIN
36100 CH := ' '; STATUS := ' '
36200 END;
36300 OTHERS:
36400 BEGIN
36500 ERROR := TRUE; CH := ' '
36600 END
36700 END
36800 END
36900 END (*NEXTCH*) ;
37000
37100 BEGIN
37200 (*OPERAND*)
37300 REPEAT
37400 NEXTCH;
37500 IF CH IN ['A'..'Z','0'..'9']
37600 THEN
37700 IF STATUS IN ['[',',','<']
37800 THEN READOCTAL
37900 ELSE READCHAR
38000 ELSE SETSTATUS
38100 UNTIL NEW_STATUS OR ERROR OR END_OF_FILENAME
38200 END (*OPERAND*) ;
38300
38400 PROCEDURE ASSIGNFILENAMEOREXTENSION;
38500 BEGIN
38600 IF I > 0
38700 THEN
38800 IF (FILENAME[1] = ' ') OR ((FILENAME[7] = ' ') AND (IMAX = 3))
38900 THEN
39000 BEGIN
39100 IF IMAX = 3
39200 THEN K := 6
39300 ELSE K := 0;
39400 FOR J := 1 TO IMAX DO FILENAME[K+J] := BUFFER[J];
39500 END
39600 END;
39700
39800 BEGIN
39900 (*GETFILENAME*)
40000 IF USERCALL
40100 THEN
40200 BEGIN
40300 GETSTATUS(SOURCEFILE, SOURCE_FIL, SOURCE_PROT, SOURCE_PPN, SOURCE_DEV);
40400 IF SOURCE_DEV = 'TTY '
40500 THEN
40600 BEGIN
40700 WRITE(TTY,CR,LF,FILEVARIABLE,'= ');
40800 BREAK(TTY);
40900 READLN(SOURCEFILE)
41000 END
41100 END;
41200 INITIALIZE;
41300 IF NOT EOF(SOURCEFILE)
41400 THEN
41500 IF NOT EOLN(SOURCEFILE)
41600 THEN
41700 REPEAT
41800 OPERAND;
41900 IF NOT ERROR
42000 THEN
42100 BEGIN
42200 CASE PICTURE(STATUS) OF
42300 COLON:
42400 IF I > 0
42500 THEN BEGIN
42550 DEVICE := ' ' ;
42575 FOR J := 1 TO I DO DEVICE[J] := BUFFER[J];
42587 END ;
42600 POINT:
42700 BEGIN
42800 ASSIGNFILENAMEOREXTENSION; IMAX := 3
42900 END;
43000 LESS,
43100 LBRACK:
43200 ASSIGNFILENAMEOREXTENSION;
43300 LPARENT,
43400 SLASH:
43500 BEGIN
43600 ASSIGNFILENAMEOREXTENSION; READSWITCH
43700 END;
43800 COMMA :
43900 UFD := OCVAL * 1000000B;
44000 RBRACK :
44100 UFD := UFD + OCVAL;
44200 GREATER :
44300 PROTECTION := OCVAL
44400 END;
44500 RE_INITIALIZE; DEFAULTED := FALSE
44600 END
44700 UNTIL ERROR OR END_OF_FILENAME;
44800 DEFAULTED := FILENAME[1] = ' ';
44900 IF NOT (USERCALL OR DEFAULTED)
45000 THEN
45100 IF NOT ERROR AND EOLN(SOURCEFILE) AND (PRED(SOURCE) <= COMMANDFILE) AND NOT EOF(SOURCEFILE)
45200 THEN
45300 BEGIN
45400 READLN(SOURCEFILE); STATUS := ' '; CH := ' '; READSWITCH
45500 END;
45600 IF ERROR AND USERCALL
45700 THEN
45800 BEGIN
45900 WRITELN(TTY,'%? SYNTAX ERROR: REENTER'); BREAK(TTY);
46000 GETFILENAME(SOURCEFILE,FILENAME,PROTECTION,UFD,DEVICE,FILEVARIABLE)
46100 END
46200 ELSE USERCALL := TRUE
46300 END (*GETFILENAME*);
46400
46500 (**********************************************************************
46600 *
46700 * PROCEDURE GETPARAMETER
46800 *
46900 * - READ A DECSYSTEM-10 <FILE SPECIFICATION> FROM EITHER
47000 *
47100 * * A TEMPCORE-FILE NAMED <1ST 3 CHARS. OF PROGRAMNAME>.TMP,
47200 * CREATED BY DECSYSTEM-10 COMPIL-CLASS COMMANDS OR USER, OR
47300 *
47400 * * A COMMAND-FILE NAMED <1ST 6 CHARS. OF PROGRAMNAME>.CMD,
47500 * CREATED BY USER, OR
47600 *
47700 * * TTY
47800 *
47900 * ALL FILES HAVE TO BE "TEXT"-FILES.
48000 *
48100 * TEMPCORE-FILES CAN BE ACCESSED AND CREATED AUTOMATICALLY
48200 * BY PASCAL PROGRAMS IF THE FILENAME IS SPECIFIED AS
48300 * 'XXX TMP' AND DEVICE IS 'DSK ', WHERE XXX ARE
48400 * THE 1ST 3 CHARACTERS OF THE <PROGRAMNAME>. IF THE TEMPCORE-FILE
48500 * CANNOT BE FOUND/CREATED THE DISK-FILE 'NNNXXXTMP' IS
48600 * SEARCHED/CREATED, WHERE NNN IS THE JOB-NUMBER.
48700 *
48800 * - GETPARAMETER IS PART OF THE PASREL RUNTIME-SUPPORT.
48900 * A CALL OF GETPARAMETER IS GENERATED BY THE PASREL COMPILER
49000 * FOR EACH PARAMETER SPECIFIED IN THE <PROGRAM HEADING>.
49100 *
49200 * THE INPUT FORMAT IS FOR
49300 *
49400 * * TEMPCORE- AND COMMAND-FILES:
49500 *
49600 * <FILE SPECIFICATION>,...,<FILE SPECIFICATION><CR><LF>
49700 * <SWITCH>!...<SWITCH>!<CR><LF>
49800 *
49900 * THE SECOND LINE (USED BY COMPIL-CLASS COMMANDS) IS OPTIONAL
50000 *
50100 * * TTY:
50200 *
50300 * <FILE SPECIFICATION><CR><LF>
50400 *
50500 ***********************************************************************)
50600
50700 PROCEDURE GETPARAMETER(VAR CURRENTFILE: ANYFILE;
50800 VAR FILEIDENT,PROGRAMNAME:ALFA;
50900 INPUTFILE:BOOLEAN);
51000 VAR
51100 PROTECTION, UFD, I: INTEGER;
51200 FILENAME: PACK9;
51300 DEVICE: PACK6;
51400
51500 PROCEDURE INITIALIZE;
51600 BEGIN
51700 IF SOURCE <> TELETYPE
51800 THEN
51900 BEGIN
52000 CASE SOURCE OF
52100 TEMPFILE:
52200 BEGIN
52300 FOR I := 1 TO 6 DO COM_FILENAME[I] := PROGRAMNAME[I];
52400 FOR I := 1 TO 3 DO TMP_FILENAME[I] := PROGRAMNAME[I];
52500 RESET(TTY,TMP_FILENAME,0,0,'DSK ')
52600 END;
52700 COMMANDFILE:
52800 RESET(TTY,COM_FILENAME);
52900 TELETYPEOUTPUT:
53000 REWRITE(TTY,'TTYOUTPUT');
53100 TELETYPEINPUT:
53200 RESET(TTY,'TTY ',0,0,'TTY ')
53300 END;
53400 SOURCE := SUCC(SOURCE);
53500 IF EOF(TTY) AND NOT (SOURCE IN [TELETYPEINPUT,TELETYPE])
53600 THEN INITIALIZE;
53700 END
53800 END (* INITIALIZE *);
53900
54000 BEGIN (*GETPARAMETER*)
54100 IF CALLCNT = 0
54200 THEN
54300 INITIALIZE;
54400 CALLCNT := CALLCNT + 1;
54500 GETSTATUS(CURRENTFILE,FILE_OLD,PROT_OLD,UFD_OLD,DEVICE_OLD);
54600
54700 LOOP
54800
54900 IF SOURCE IN [TELETYPE,TELETYPEINPUT]
55000 THEN
55100 BEGIN
55200 WRITE(TTY,FILEIDENT,'= ');BREAK(TTY);
55300 IF SOURCE = TELETYPEINPUT
55400 THEN INITIALIZE
55500 ELSE READLN(TTY)
55600 END;
55700
56100 USERCALL := FALSE;
56200 GETFILENAME(TTY,FILENAME,PROTECTION,UFD,DEVICE,' ');
56400 IF DEVICE = 'LPT '
56500 THEN ENTER('LPT ',0) ;
58000
58100 ERROR := (INPUTFILE AND NOT DEFAULTED AND (DEVICE = 'LPT ')) OR ERROR;
58200
58300 IF NOT ERROR
58400 THEN
58500 IF DEFAULTED
58600 THEN
58700 IF INPUTFILE
58800 THEN
58900 RESET(CURRENTFILE,FILE_OLD,PROT_OLD,UFD_OLD,DEVICE_OLD)
59000 ELSE
59100 REWRITE(CURRENTFILE,FILE_OLD,PROT_OLD,UFD_OLD,DEVICE_OLD)
59200 ELSE
59300 IF INPUTFILE
59400 THEN
59500 RESET(CURRENTFILE,FILENAME,PROTECTION,UFD,DEVICE)
59600 ELSE
59700 REWRITE(CURRENTFILE,FILENAME,PROTECTION,UFD,DEVICE)
59800 EXIT IF ( (NOT EOF(CURRENTFILE) AND INPUTFILE) OR (EOF(CURRENTFILE) AND NOT INPUTFILE) ) AND NOT ERROR;
59900 IF SOURCE <> TELETYPE
60000 THEN
60100 BEGIN
60200 SOURCE := TELETYPEOUTPUT; INITIALIZE
60300 END;
60400 IF ERROR
60500 THEN WRITELN(TTY,'%? SYNTAX ERROR: REENTER')
60600 ELSE
60700 BEGIN
60800 WRITE(TTY,'%? NO ACCESS TO ');
60900 IF FILENAME = ' '
61000 THEN WRITE(TTY,FILEIDENT:6,'.',FILEIDENT[7],FILEIDENT[8],FILEIDENT[9])
61100 ELSE WRITE(TTY,FILENAME:6,'.',FILENAME[7],FILENAME[8],FILENAME[9]);
61200 WRITELN(TTY,' OR NOT FOUND: REENTER')
61300 END;
61400 BREAK(TTY)
61500 END
61600 END (*GETPARAMETER*) ;
61700
61800 BEGIN
61900 END.
00100 PROGRAM DDT, DEBUG;
00200
00300 (************************************************************
00400 * *
00500 * *
00600 * PASCAL-DDT PROGRAM *
00700 * ****************** *
00800 * *
00900 * *
01000 * AUTHOR: PETER PUTFARKEN *
01100 * *
01200 * POST - MORTEM - DUMP BY *
01300 * B. NEBEL AND B. PRETSCHNER (APR 76) *
01400 * *
01500 * INSTITUT FUER INFORMATIK *
01600 * SCHLUETERSTRASSE 70 *
01700 * D-2000 HAMBURG 13 *
01800 * GERMANY *
01900 * *
02000 * *
02100 ***********************************************************)
02200
02300 CONST
02400 VERSION = 'DEBUG(VERSION FROM 25-AUG-76)';
02500 STOPMAX = 20;
02600 BUFFMAX = 120;
02700 BITMAX = 36;
02800 BASEMAX = 71;
02900 STRGLGTH = 120;
03000 OFFSET = 40B;
03100 MAXTABS = 4;
03200 TYPE
03300 ACRANGE = 0..15; BIT = 0..1;
03400 BITRANGE = 0..BITMAX;
03500 ADDRRANGE = 0..777777B;
03600 LINEELEM = PACKED RECORD
03700 CASE INTEGER OF
03800 1: (CODE:0..677B; AC:ACRANGE; IB:BIT; INXR:ACRANGE; ADP:^LINEELEM);
03900 2: (CONSTANT1: INTEGER;
04000 DB2: ADDRRANGE; ABSLINE: ADDRRANGE)
04100 END;
04200 PAGEELEM = PACKED RECORD
04300 INSTR: 0..677B; AC: ACRANGE; DUMMYBIT: BIT; INXREG: ACRANGE; PAGPTR: ^PAGEELEM;
04400 LASTLINE: ADDRRANGE; LASTSTOP: ^LINEELEM
04500 END;
04600 STRINGTYP = PACKED ARRAY [1:STRGLGTH] OF CHAR;
04700 CSTCLASS = (INT,REEL,PSET,STRD,STRG);
04800 SIXBIT=PACKED ARRAY[1..6] OF 0..77B;
04900 CSP = ^CONSTNT;
05000 CONSTNT = RECORD
05100 SELFCSP: CSP; NOCODE: BOOLEAN;
05200 CASE CCLASS: CSTCLASS OF
05300 INT : (INTVAL: INTEGER; INTVAL1: INTEGER)
05400 END;
05500 VALU = RECORD
05600 CASE INTEGER OF
05700 1: (IVAL: INTEGER);
05800 2: (RVAL: REAL);
05900 3: (BVAL: BOOLEAN);
06000 4: (VALP: CSP)
06100 END;
06200 BITS5 = 0..37B; BITS6 = 0..77B; BITS7 = 0..177B;
06300 BITS17 = 0..377777B; BITS18 = 0..777777B;
06400 STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
06500 FORMSET=SET OF STRUCTFORM;
06600 DECLKIND = (STANDARD,DECLARED);
06700 STP = ^STRUCTURE; CTP = ^IDENTIFIER;
06800 STRUCTURE = PACKED RECORD
06900 SELFSTP: STP; SIZE: ADDRRANGE;
07000 NOCODE: BOOLEAN;
07100 BITSIZE: BITRANGE;
07200 CASE FORM: STRUCTFORM OF
07300 SCALAR: (CASE SCALKIND: DECLKIND OF
07400 DECLARED: (DB0:BITS6; FCONST: CTP));
07500 SUBRANGE: (DB1:BITS7; RANGETYPE: STP; MINV,MAXV: VALU);
07600 POINTER: (DB2:BITS7; ELTYPE: STP);
07700 POWER: (DB3:BITS7; ELSET: STP);
07800 ARRAYS: (ARRAYPF: BOOLEAN; DB4:BITS6; ARRAYBPADDR: ADDRRANGE;
07900 AELTYPE,INXTYPE: STP);
08000 RECORDS: (RECORDPF:BOOLEAN; DB5:BITS6;
08100 FSTFLD: CTP; RECVAR: STP);
08200 FILES: (DB6: BITS6; FILEPF: BOOLEAN; FILTYPE: STP);
08300 TAGFWITHID,
08400 TAGFWITHOUTID: (DB7:BITS7; FSTVAR: STP;
08500 CASE BOOLEAN OF
08600 TRUE : (TAGFIELDP: CTP);
08700 FALSE: (TAGFIELDTYPE: STP));
08800 VARIANT: (DB9: BITS7; NXTVAR,SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU)
08900 END;
09000 (* ALFA = PACKED ARRAY[1..ALFALENG] OF CHAR; *)
09100 LEVRANGE = 0..10;
09200 IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELS);
09300 IDKIND = (ACTUAL,FORMAL);
09400 PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
09500 BPOINTER = PACKED RECORD
09600 SBITS,PBITS: BITRANGE;
09700 IBIT,DUMMYBIT: BIT;
09800 IREG: ACRANGE;
09900 RELADDR: ADDRRANGE
10000 END;
10100 IDENTIFIER = PACKED RECORD
10200 NAME: ALFA; LLINK, RLINK: CTP;
10300 IDTYPE: STP; NEXT: CTP;
10400 SELFCTP: CTP; NOCODE: BOOLEAN;
10500 CASE KLASS: IDCLASS OF
10600 KONST: (VALUES: VALU);
10700 VARS: (VKIND: IDKIND; VLEV: LEVRANGE;
10800 CHANNEL: ACRANGE; VDUMMY1: 0..37B; VDUMMY2:0..777777B; VADDR: ADDRRANGE);
10900 FIELD: (CASE PACKF: PACKKIND OF
11000 NOTPACK,
11100 HWORDL,
11200 HWORDR: (FDUMMY: 0..7777B; FLDADDR: ADDRRANGE);
11300 PACKK: (PDUMMY: 0..7777B; FLDBYTE: BPOINTER));
11400 PROC,
11500 FUNC: (CASE PFDECKIND: DECLKIND OF
11600 STANDARD: (KEY: 1..44);
11700 DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE))
11800 END;
11900 SYMBOL= (STOPSY, TRACESY, ENDSY, NOTSY, EOLSY, IDENT, INTCONST, STRINGCONST,
12000 CHARCONST, REALCONST, LBRACK, RBRACK, COMMA, PERIOD, ARROW, PLUS, MINUS, MUL,
12100 SLASHSY, BECOMES, EQSY, LPARENT, RPARENT, OTHERSY, STACKDUMPSY, HEAPDUMPSY);
12200 ASCII_MNEMONICS = (NUL,SOH,STX,ETX,EOT,ENQ,ACK,BEL,
12300 BS,HT,LF,VT,FF,CR,SO,SI,
12400 DLE,DC1,DC2,DC3,DC4,NAK,SYN,ETB,
12500 CAN,EM,SUB,ESC,FS,GS,RS,US,DEL);
12600
12700 ACR = ^ AKTIVIERUNGSRECORD;
12800 AKTIVIERUNGSRECORD = ARRAY [0..0] OF INTEGER;
12900 ATTRKIND = (CST,VARBL,EXPR);
13000 ATTR = RECORD
13100 TYPTR: STP;
13200 CASE KIND: ATTRKIND OF
13300 CST,
13400 EXPR: (CVAL: VALU);
13500 VARBL:(PACKFG: BOOLEAN;
13600 GADDR: ADDRRANGE;
13700 GBITCOUNT: BITRANGE;
13800 MAXADDR:ADDRRANGE)
13900 END;
14000 LEFTORRIGHT=(LEFT,RIGHT);
14100 DEBUGENTRY = RECORD
14200 LASTPAGEELEM: PAGEELEM;
14300 GLOBALIDTREE: CTP;
14400 STANDARDIDTREE: CTP;
14500 INTPTR: STP;
14600 REALPTR: STP;
14700 BOOLPTR: STP;
14800 CHARPTR: STP
14900 END;
15000 STATUSKIND = (INITK, STOPK, DDTK, RUNTMERRK, HALTK);
15100 DEBUGSTATUS = PACKED RECORD
15200 DD: 0:77777B;
15300 KIND: STATUSKIND;
15400 RETURNADDR: ADDRRANGE
15500 END;
15600 DYNENTRY = PACKED RECORD
15700 DUMM1: BITS18; (* LH 140B *)
15800 REGISTRS: ACR; (* RH 140B *)
15900 STOPPY: INTEGER; (* 141B *)
16000 DUMM2: BITS18; (* LH 142B *)
16100 ENTRYPTR: ^DEBUGENTRY; (* RH 142B *)
16200 DUMM3: BITS17;
16300 INTERACTIVE: BOOLEAN; (* LH 143B *)
16400 STACKBOTTOM: ACR; (* RH 143B *)
16500 STATUS: DEBUGSTATUS; (* 144B *)
16600 TIME_LIMIT: INTEGER; (* 145B USED ONLY BY BATCH JOBS *)
16700 PUSHJ_INDEB: INTEGER; (* 146B *)
16800 DUMMI146: ADDRRANGE; (* 147B LH *)
16900 NAME_PNT_PNT: ACR (* 147B RH POINTER OF POINTER OF PROGRAM-NAME *)
17000 END;
17100
17200 VAR
17300 DUMP, TABS: BOOLEAN;
17400 TABULATOR: ARRAY[BOOLEAN,1..MAXTABS] OF INTEGER;
17500 FILE_NAME: PACKED ARRAY[1..9] OF CHAR;
17600 ASCII_CHANGE: RECORD
17700 CASE INTEGER OF
17800 1: (IVAL: INTEGER);
17900 2: (MNEMO: ASCII_MNEMONICS)
18000 END;
18100 DAY, DAY_TIME: ALFA;
18200 DEVICE:PACKED ARRAY[1..6] OF CHAR;
18300 CH: CHAR;
18400 ID: ALFA;
18500 VAL: VALU;
18600 STRING: ^STRINGTYP;
18700 STRINGPTR, STRINGINDEX: STP;
18800 LGTH: INTEGER;
18900 CHCNT, LEFTSPACE: INTEGER;
19000 SY: SYMBOL;
19100 BUFFER: PACKED ARRAY[1:BUFFMAX] OF CHAR;
19200 BUFFLNG: 0:BUFFMAX;
19300 GPAGE: INTEGER; (*CURRENT PAGENUMBER*)
19400 STOPTABLE: ARRAY[1..STOPMAX] OF PACKED RECORD
19500 THISLINE: INTEGER;
19600 PAGE: ADDRRANGE;
19700 THISADDR: ^LINEELEM;
19800 ORIGINALCONT: INTEGER
19900 END;
20000 STOPNR: 0..STOPMAX;
20100 ENTRY1: DEBUGENTRY;
20200 ENTRY2: DYNENTRY;
20300 POINTERCV: PACKED RECORD
20400 CASE INTEGER OF
20500 0:(ADDR: ADDRRANGE);
20600 1:(ENTPTR2: ^DYNENTRY);
20700 2:(STRINGPTR: ^STRINGTYP);
20800 3:(CTPTR: CTP);
20900 4:(ALFAPNT:^ALFA)
21000 END;
21100 HEAPCV:PACKED RECORD
21200 CASE BOOLEAN OF
21300 TRUE: (CIVAL:INTEGER);
21400 FALSE: (CIDTYPE:STP;
21500 CACR:ACR)
21600 END;
21700 MERKBASIS,BASIS, ACCUS, NULLPTR: ACR;
21800 BYTECV: PACKED RECORD
21900 CASE BOOLEAN OF
22000 FALSE: (BITS: PACKED ARRAY[1..BITMAX] OF BIT );
22100 TRUE : (INTCONST: INTEGER)
22200 END;
22300 LADDR: ADDRRANGE;
22400 DIGITS, LETTERSDIGITSORLEFTARROW: SET OF CHAR;
22500 NL: BOOLEAN;
22600 GATTR: ATTR;
22700
22800 (******************************************************************************************************)
22900
23000 INITPROCEDURE;
23100 BEGIN
23200 DIGITS :=['0'..'9'];
23300 LETTERSDIGITSORLEFTARROW:=['A'..'Z','0'..'9', '_'];
23400 STRING := NIL;
23500 TABULATOR[TRUE,1]:=35;
23600 TABULATOR[TRUE,2]:=65;
23700 TABULATOR[TRUE,3]:=95;
23800 TABULATOR[TRUE,4]:=377777777777B;
23900 TABULATOR[FALSE,1]:=0;
24000 TABULATOR[FALSE,2]:=0;
24100 TABULATOR[FALSE,3]:=35;
24200 TABULATOR[FALSE,4]:=377777777777B;
24300 TABS:=FALSE;
24400 DUMP:=FALSE;
24500 END;
24600
24700
24800 PROCEDURE DEBUG;
24900
25000
25100 PROCEDURE SYSTEM_ERROR( KIND : INTEGER );
25200 BEGIN
25300 WRITELN(TTY);
25400 WRITELN(TTY,'%? DEBUG-SYSTEM ERROR: ',KIND:2);
25500 HALT; (* JUMP TO "HALT.".
25600 THERE WILL BE DECDECTED THAT
25700 DEBUG IS LOADED. THEREFORE, JUMP TO
25800 "ERRDB." AND EXIT *)
25900 END;
26000
26100
26200 PROCEDURE ERROR;
26300 BEGIN
26400 WRITE(TTY, '$', '^ ':CHCNT+1 );
26500 GATTR.TYPTR := NIL
26600 END (*ERROR*);
26700
26800
26900 PROCEDURE NEWLINE;
27000 VAR
27100 I:INTEGER;
27200 BEGIN
27300 I:=1;
27400 IF TABS
27500 THEN
27600 WHILE (TABULATOR[DUMP,I] <= CHCNT) DO
27700 I:=I+1;
27800 IF (I = MAXTABS) OR NOT TABS
27900 THEN
28000 BEGIN
28100 WRITELN(TTY);
28200 WRITE(TTY,'$ ',' ':LEFTSPACE);
28300 CHCNT:=LEFTSPACE;
28400 END
28500 ELSE
28600 BEGIN
28700 WRITE(TTY,' ':TABULATOR[DUMP,I]-CHCNT);
28800 CHCNT:=TABULATOR[DUMP,I];
28900 END (* ELSE *)
29000 END (* NEWLINE *);
29100
29200 FUNCTION LENGTH(FVAL: INTEGER): INTEGER;
29300 VAR
29400 E, H: INTEGER;
29500 BEGIN
29600 IF FVAL < 0
29700 THEN
29800 BEGIN
29900 E := 1; FVAL := -FVAL
30000 END
30100 ELSE E := 0;
30200 H := 1;
30300 IF FVAL >= 10000000000 (* 10**10 *)
30400 THEN E := E + 11
30500 ELSE
30600 REPEAT
30700 E := E + 1; H := H * 10
30800 UNTIL (FVAL < H) ;
30900 LENGTH := E
31000 END (*LENGTH*);
31100
31200 PROCEDURE INSYMBOL;
31300 CONST
31400 MAX10 = 3817748707;
31500 MAXEXP = 35;
31600 VAR
31700 IVAL,SCALE,EXP,I: INTEGER;
31800 RVAL,R,FAC: REAL;
31900 STRINGTOOLONG, SIGN: BOOLEAN;
32000
32100 PROCEDURE NEXTCH;
32200 BEGIN
32300 IF EOLN(TTY)
32400 THEN CH:=' '
32500 ELSE READ(TTY,CH);
32600 CHCNT := CHCNT + 1
32700 END (*NEXTCH*);
32800 BEGIN
32900 WHILE NOT EOLN(TTY) AND (CH=' ') DO NEXTCH;
33000 CASE CH OF
33100 ' ':
33200 SY := EOLSY;
33300 'A','B','C','D','E','F','G','H','I','J','K','L','M',
33400 'N','O','P','Q','R','S','T','U','V','W','X','Y',
33500 'Z':
33600 BEGIN
33700 ID := ' '; I := 0;
33800 REPEAT
33900 IF I < ALFALENGTH
34000 THEN
34100 BEGIN
34200 I := I + 1;
34300 ID[I] := CH
34400 END;
34500 NEXTCH
34600 UNTIL NOT ( CH IN LETTERSDIGITSORLEFTARROW );
34700 SY := IDENT;
34800 IF ID='NOT '
34900 THEN SY:=NOTSY;
35000 IF ID='STOP '
35100 THEN SY:=STOPSY;
35200 IF ID='TRACE '
35300 THEN SY:=TRACESY;
35400 IF ID='END '
35500 THEN SY:=ENDSY;
35600 IF ID='STACKDUMP '
35700 THEN SY:=STACKDUMPSY;
35800 IF ID='HEAPDUMP '
35900 THEN SY:=HEAPDUMPSY;
36000 IF SY IN [STOPSY,TRACESY,STACKDUMPSY,HEAPDUMPSY]
36100 THEN
36200 (* LOOK AHEAD, WHETHER ARGUMENT OR EOL FOLLOWS *)
36300 BEGIN
36400 WHILE NOT EOLN(TTY) AND (CH=' ') DO NEXTCH;
36500 IF NOT (CH IN ['0'..'9','A'..'Z',' '] )
36600 THEN SY:= IDENT
36700 END
36800 END;
36900 '0','1','2','3','4','5','6','7','8',
37000 '9':
37100 BEGIN
37200 IVAL := 0; SY := INTCONST;
37300 REPEAT
37400 IF IVAL <= MAX10
37500 THEN IVAL := 10*IVAL + ORD(CH)-ORD('0')
37600 ELSE
37700 BEGIN
37800 ERROR; WRITELN(TTY,'NUMBER TOO LARGE');
37900 IVAL := 0
38000 END;
38100 NEXTCH
38200 UNTIL NOT (CH IN DIGITS);
38300 SCALE := 0;
38400 IF CH = '.'
38500 THEN
38600 BEGIN
38700 NEXTCH;
38800 IF CH = '.'
38900 THEN CH := ':'
39000 ELSE
39100 BEGIN
39200 RVAL := IVAL; SY := REALCONST;
39300 IF NOT (CH IN DIGITS)
39400 THEN
39500 BEGIN
39600 ERROR; WRITELN(TTY,'DIGIT MUST FOLLOW')
39700 END
39800 ELSE
39900 REPEAT
40000 RVAL := 10.0*RVAL + (ORD(CH) - ORD('0'));
40100 SCALE := SCALE - 1; NEXTCH
40200 UNTIL NOT (CH IN DIGITS)
40300 END
40400 END;
40500 IF CH = 'E'
40600 THEN
40700 BEGIN
40800 IF SCALE = 0
40900 THEN
41000 BEGIN
41100 RVAL := IVAL; SY := REALCONST
41200 END;
41300 NEXTCH;
41400 SIGN := CH = '-' ;
41500 IF (CH = '+') OR SIGN
41600 THEN NEXTCH;
41700 EXP := 0;
41800 IF NOT (CH IN DIGITS)
41900 THEN
42000 BEGIN
42100 ERROR; WRITELN(TTY,'DIGIT MUST FOLLOW')
42200 END
42300 ELSE
42400 REPEAT
42500 EXP := 10*EXP + ORD(CH) - ORD('0');
42600 NEXTCH
42700 UNTIL NOT (CH IN DIGITS);
42800 IF SIGN
42900 THEN SCALE := SCALE - EXP
43000 ELSE SCALE := SCALE + EXP;
43100 IF ABS(SCALE + LENGTH(IVAL) - 1) > MAXEXP
43200 THEN
43300 BEGIN
43400 ERROR; WRITELN(TTY,'EXPONENT TOO LARGE');
43500 SCALE := 0
43600 END
43700 END;
43800 IF SCALE <> 0
43900 THEN
44000 BEGIN
44100 R := 1.0; (*NOTE POSSIBLE OVERFLOW OR UNDERFLOW*)
44200 IF SCALE < 0
44300 THEN
44400 BEGIN
44500 FAC := 0.1; SCALE := -SCALE
44600 END
44700 ELSE FAC := 10.0;
44800 REPEAT
44900 IF ODD(SCALE)
45000 THEN R := R*FAC;
45100 FAC := SQR(FAC); SCALE := SCALE DIV 2
45200 UNTIL SCALE = 0; (*NOW R = 10^SCALE*)
45300 RVAL := RVAL*R
45400 END;
45500 IF SY = INTCONST
45600 THEN VAL.IVAL := IVAL
45700 ELSE VAL.RVAL := RVAL
45800 END;
45900 ':':
46000 BEGIN
46100 NEXTCH;
46200 IF CH = '='
46300 THEN
46400 BEGIN
46500 SY := BECOMES; NEXTCH
46600 END
46700 ELSE SY := OTHERSY
46800 END;
46900 '''':
47000 BEGIN
47100 LGTH := 0; STRINGTOOLONG := FALSE;
47200 IF STRING = NIL
47300 THEN
47400 BEGIN
47500 NEW(STRING); NEW(STRINGPTR,ARRAYS); NEW(STRINGINDEX,SUBRANGE);
47600 WITH STRINGINDEX^ DO
47700 BEGIN
47800 SIZE := 1; BITSIZE := 7;
47900 RANGETYPE := ENTRY1.INTPTR; MINV.IVAL := 1
48000 END;
48100 WITH STRINGPTR^ DO
48200 BEGIN
48300 BITSIZE := BITMAX; AELTYPE := ENTRY1.CHARPTR;
48400 INXTYPE := STRINGINDEX; ARRAYPF := TRUE
48500 END
48600 END;
48700 REPEAT
48800 REPEAT
48900 NEXTCH;
49000 IF LGTH < STRGLGTH
49100 THEN
49200 BEGIN
49300 LGTH := LGTH + 1; STRING^[LGTH] := CH
49400 END
49500 ELSE STRINGTOOLONG := TRUE
49600 UNTIL EOLN(TTY) OR (CH = '''');
49700 IF STRINGTOOLONG
49800 THEN
49900 BEGIN
50000 ERROR; WRITELN(TTY,'STRING CONSTANT IS TOO LONG')
50100 END;
50200 IF CH <> ''''
50300 THEN
50400 BEGIN
50500 ERROR; WRITELN(TTY,'STRING CONSTANT CONTAINS "<CR><LF>"')
50600 END
50700 ELSE NEXTCH
50800 UNTIL CH <> '''';
50900 LGTH := LGTH - 1; (*NOW LGTH = NR OF CHARS IN STRING*)
51000 IF LGTH = 1
51100 THEN
51200 BEGIN
51300 SY := CHARCONST; VAL.IVAL := ORD(STRING^[1])
51400 END
51500 ELSE
51600 BEGIN
51700 SY := STRINGCONST;
51800 STRINGINDEX^.MAXV.IVAL := LGTH;
51900 STRINGPTR^.SIZE := (LGTH + 4) DIV 5
52000 END
52100 END;
52200 '=':
52300 BEGIN
52400 SY := EQSY; NEXTCH
52500 END;
52600 '/':
52700 BEGIN
52800 SY := SLASHSY; NEXTCH
52900 END;
53000 '[':
53100 BEGIN
53200 SY := LBRACK; NEXTCH
53300 END;
53400 ']':
53500 BEGIN
53600 SY := RBRACK; NEXTCH
53700 END;
53800 '.':
53900 BEGIN
54000 SY := PERIOD; NEXTCH
54100 END;
54200 '^':
54300 BEGIN
54400 SY := ARROW; NEXTCH
54500 END;
54600 ',':
54700 BEGIN
54800 SY := COMMA; NEXTCH
54900 END;
55000 '+':
55100 BEGIN
55200 SY := PLUS; NEXTCH
55300 END;
55400 '*':
55500 BEGIN
55600 SY := MUL; NEXTCH
55700 END;
55800 '-':
55900 BEGIN
56000 SY := MINUS; NEXTCH
56100 END;
56200 '(':
56300 BEGIN
56400 SY := LPARENT; NEXTCH
56500 END;
56600 ')':
56700 BEGIN
56800 SY := RPARENT; NEXTCH
56900 END;
57000 OTHERS:
57100 SY := OTHERSY
57200 END;
57300 END (*INSYMBOL*);
57400
57500 FUNCTION ACRPOINT(FINT:INTEGER;LLEFT:LEFTORRIGHT): ACR;
57600 (*CONVERTS INTEGER TO ACR-POINTER*)
57700 VAR
57800 ACR_INT: PACKED RECORD
57900 CASE BOOLEAN OF
58000 FALSE:(LINT: INTEGER);
58100 TRUE: (LACR,LACL: ACR)
58200 END;
58300 BEGIN
58400 WITH ACR_INT DO
58500 BEGIN
58600 LINT := FINT;
58700 IF LLEFT=LEFT
58800 THEN ACRPOINT := LACL
58900 ELSE ACRPOINT := LACR
59000 END
59100 END (*ACRPOINT*);
59200
59300 PROCEDURE TESTGLOBALBASIS;
59400 BEGIN
59500 IF BASIS = ENTRY2.STACKBOTTOM
59600 THEN BASIS := NULLPTR
59700 END (*TESTGLOBALBASIS*);
59800
59900 FUNCTION IDTREE: CTP;
60000 (*POINTS TO THE IDTREE OF THE PROCEDURE, TO WHICH BASIS POINTS*)
60100 VAR
60200 I: INTEGER;
60300 LACR: ACR;
60400 BEGIN
60500 IF BASIS = NULLPTR
60600 THEN IDTREE := ENTRY1.GLOBALIDTREE
60700 ELSE
60800 BEGIN
60900 LACR := ACRPOINT ( BASIS^[0] - 1, RIGHT );
61000 I := LACR^[0];
61100 REPEAT
61200 I := I - 1;
61300 LACR := ACRPOINT ( I, RIGHT)
61400 UNTIL ORD(ACRPOINT(LACR^[0],RIGHT)) <> 777777B (*HRR BASIS,-1(BASIS)*);
61500 WITH POINTERCV DO
61600 BEGIN
61700 ADDR := LACR^[0];
61800 IDTREE := CTPTR
61900 END
62000 END
62100 END (*IDTREE*);
62200
62300 PROCEDURE FIRSTBASIS;
62400 (*GENERATES BASISPOINTER TO 'AKTIVIERUNGSRECORD' OF UNDERBREAKED PROCEDURE*)
62500 BEGIN
62600 BASIS := ACRPOINT ( ACCUS^[0 +16B], RIGHT );
62700 TESTGLOBALBASIS
62800 END (*FIRSTBASIS*);
62900
63000 PROCEDURE SUCCBASIS(SIDE: LEFTORRIGHT);
63100 (*GENERATES BASISPOINTER TO 'AKTIVIERUNGSR.'
63200 OF STATIC/DYNAMIC HIGHER PROCEDURE)*)
63300 (*SIDE: RIGHT FOR STATIC LINK
63400 LEFT FOR DYNAMIC LINK*)
63500
63600 VAR
63700 OLDBASIS:ACR;
63800 BEGIN
63900 OLDBASIS:=BASIS;
64000 BASIS := ACRPOINT( BASIS^[0-1], SIDE );
64100 TESTGLOBALBASIS;
64200 IF ORD(OLDBASIS) <= ORD(BASIS)
64300 THEN
64400 BEGIN
64500 BASIS:=NULLPTR;
64600 TABS:=FALSE; NEWLINE;
64700 WRITE(TTY,'ERROR IN PROCEDURE-BACKTRACING'); NEWLINE;
64800 END;
64900 END (*SUCCBASIS*);
65000
65100 PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
65200 LABEL
65300 1;
65400 BEGIN
65500 WHILE FCP <> NIL DO WITH FCP^ DO
65600 BEGIN
65700 IF NAME = ID
65800 THEN GOTO 1;
65900 IF NAME < ID
66000 THEN FCP := RLINK
66100 ELSE FCP := LLINK
66200 END;
66300 1:
66400 FCP1 := FCP
66500 END (*SEARCHSECTION*);
66600
66700 PROCEDURE SEARCHID(VAR FCP: CTP);
66800 LABEL
66900 1;
67000 VAR
67100 LCP: CTP;
67200 BEGIN
67300 FIRSTBASIS;
67400 LOOP
67500 SEARCHSECTION( IDTREE, LCP );
67600 IF LCP <> NIL
67700 THEN GOTO 1
67800 EXIT IF BASIS = NULLPTR;
67900 SUCCBASIS ( RIGHT(*=STATIC*) )
68000 END;
68100 SEARCHSECTION( ENTRY1.STANDARDIDTREE, LCP );
68200 1:
68300 FCP := LCP
68400 END (*SEARCHID*);
68500
68600 PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
68700 (*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
68800 (*ASSUME (FSP <> NIL) AND (FSP^.FORM <= SUBRANGE) AND (FSP <> INTPTR)
68900 AND NOT COMPTYPES(REALPTR,FSP)*)
69000 BEGIN
69100 WITH FSP^ DO
69200 IF FORM = SUBRANGE
69300 THEN
69400 BEGIN
69500 FMIN := MINV.IVAL; FMAX := MAXV.IVAL
69600 END
69700 ELSE
69800 BEGIN
69900 FMIN := 0;
70000 IF FSP = ENTRY1.CHARPTR
70100 THEN FMAX := 177B
70200 ELSE
70300 IF FCONST <> NIL
70400 THEN FMAX := FCONST^.VALUES.IVAL
70500 ELSE FMAX := 0
70600 END
70700 END (*GETBOUNDS*) ;
70800
70900 FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
71000 (*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
71100 VAR
71200 NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
71300 BEGIN
71400 IF FSP1 = FSP2
71500 THEN COMPTYPES := TRUE
71600 ELSE
71700 IF (FSP1 <> NIL) AND (FSP2 <> NIL)
71800 THEN
71900 IF FSP1^.FORM = FSP2^.FORM
72000 THEN
72100 CASE FSP1^.FORM OF
72200 SCALAR:
72300 COMPTYPES := FALSE;
72400 (* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
72500 NOT RECOGNIZED TO BE COMPATIBLE*)
72600 SUBRANGE:
72700 COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2^.RANGETYPE);
72800 POINTER:
72900 COMPTYPES := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE);
73000 POWER:
73100 COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET);
73200 ARRAYS:
73300 BEGIN
73400 GETBOUNDS (FSP1^.INXTYPE,LMIN,LMAX);
73500 I := LMAX-LMIN;
73600 GETBOUNDS (FSP2^.INXTYPE,LMIN,LMAX);
73700 COMPTYPES := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE)
73800 AND (FSP1^.ARRAYPF = FSP2^.ARRAYPF) AND ( I = LMAX - LMIN )
73900 END;
74000 (*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
74100 BE COMPATIBLE. MAY GIVE TROUBLE FOR ENT OF STRINGCONSTANTS
74200 -- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
74300 BE THE SAME*)
74400 RECORDS:
74500 BEGIN
74600 NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE;
74700 WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
74800 BEGIN
74900 COMP := COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE) AND COMP;
75000 NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT
75100 END;
75200 COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
75300 AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL)
75400 END;
75500 (*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
75600 IF NO VARIANTS OCCUR*)
75700 FILES:
75800 COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE)
75900 END (*CASE*)
76000 ELSE (*FSP1^.FORM <> FSP2^.FORM*)
76100 IF FSP1^.FORM = SUBRANGE
76200 THEN COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2)
76300 ELSE
76400 IF FSP2^.FORM = SUBRANGE
76500 THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE)
76600 ELSE COMPTYPES := FALSE
76700 ELSE COMPTYPES := TRUE
76800 END (*COMPTYPES*) ;
76900
77000 FUNCTION NEXTBYTE(FBITSIZE: INTEGER ): INTEGER;
77100 VAR
77200 LVAL,J: INTEGER;
77300 BEGIN
77400 WITH GATTR DO
77500 IF PACKFG
77600 THEN
77700 BEGIN
77800 LVAL := 0;
77900 IF FBITSIZE + GBITCOUNT > BITMAX
78000 THEN
78100 BEGIN
78200 GADDR := GADDR + 1;
78300 GBITCOUNT := 0
78400 END;
78500 IF FBITSIZE = BITMAX
78600 THEN LVAL := BASIS^[GADDR]
78700 ELSE
78800 WITH BYTECV DO
78900 BEGIN
79000 INTCONST := BASIS^[GADDR];
79100 FOR J := GBITCOUNT + 1 TO GBITCOUNT + FBITSIZE DO
79200 LVAL := LVAL*2 + BITS[J]
79300 END;
79400 GBITCOUNT := GBITCOUNT + FBITSIZE;
79500 NEXTBYTE := LVAL
79600 END (*IF PACKFG*)
79700 ELSE
79800 BEGIN
79900 IF GBITCOUNT > 0
80000 THEN SYSTEM_ERROR(1);
80100 NEXTBYTE := BASIS^[GADDR];
80200 GADDR := GADDR + 1; GBITCOUNT := 0
80300 END
80400 END (*NEXTBYTE*);
80500
80600 PROCEDURE PUTNEXTBYTE( FBITSIZE, FVAL: INTEGER );
80700 VAR
80800 J: INTEGER;
80900 BEGIN
81000 WITH GATTR, BYTECV DO
81100 BEGIN
81200 IF FBITSIZE + GBITCOUNT > BITMAX
81300 THEN
81400 BEGIN
81500 GADDR := GADDR + 1; GBITCOUNT := 0
81600 END;
81700 INTCONST := BASIS^[GADDR];
81800 FOR J := GBITCOUNT + FBITSIZE DOWNTO GBITCOUNT+ 1 DO
81900 BEGIN
82000 BITS[J] := ORD(ODD(FVAL));
82100 FVAL := FVAL DIV 2
82200 END;
82300 GBITCOUNT := GBITCOUNT + FBITSIZE;
82400 BASIS^[GADDR] := INTCONST
82500 END
82600 END (*PUTNEXTBYTE*);
82700
82800 PROCEDURE LOAD;
82900 (* LOAD VALUE, DESCRIBED BY GATTR, INTO GATTR.CVAL*)
83000 BEGIN
83100 WITH GATTR DO
83200 IF KIND = VARBL
83300 THEN
83400 IF TYPTR <> NIL
83500 THEN
83600 IF TYPTR^.FORM <= POINTER
83700 THEN
83800 BEGIN
83900 KIND := EXPR; CVAL.IVAL := NEXTBYTE(GBITCOUNT)
84000 END;
84100 END (*LOAD*);
84200
84300 PROCEDURE GETFIELD( FCP:CTP );
84400 BEGIN
84500 WITH FCP^, GATTR DO
84600 BEGIN
84700 IF KLASS <> FIELD
84800 THEN SYSTEM_ERROR(3);
84900 CASE PACKF OF
85000 NOTPACK,
85100 HWORDL:
85200 BEGIN
85300 GADDR := GADDR + FLDADDR; GBITCOUNT := 0
85400 END;
85500 HWORDR:
85600 BEGIN
85700 GADDR := GADDR + FLDADDR;
85800 GBITCOUNT := 18
85900 END;
86000 PACKK:
86100 WITH FLDBYTE DO
86200 BEGIN
86300 GADDR := GADDR + RELADDR;
86400 GBITCOUNT := BITMAX - SBITS -PBITS
86500 END
86600 END (*CASE*);
86700 PACKFG := PACKF <> NOTPACK;
86800 TYPTR := IDTYPE
86900 END (*WITH*)
87000 END (*GETFIELD*);
87100
87200 PROCEDURE EXPRESSION; FORWARD;
87300
87400 PROCEDURE SELECTOR;
87500 LABEL
87600 1;
87700 VAR
87800 LCP: CTP;
87900 LMIN, LMAX: INTEGER;
88000 LATTR: ATTR;
88100 INDEX, I, INDEXOFFSET, BYTESINWORD: INTEGER;
88200 BEGIN
88300 WHILE SY IN [LBRACK,ARROW,PERIOD] DO WITH GATTR DO
88400 CASE SY OF
88500 LBRACK:
88600 BEGIN
88700 REPEAT
88800 IF TYPTR <> NIL
88900 THEN
89000 IF TYPTR^.FORM <> ARRAYS
89100 THEN
89200 BEGIN
89300 ERROR; WRITELN(TTY,'TYPE OF VARIABLE IS NOT ARRAY')
89400 END;
89500 INSYMBOL;
89600 LATTR := GATTR;
89700 EXPRESSION;
89800 IF (TYPTR <> NIL) AND (LATTR.TYPTR<>NIL)
89900 THEN
90000 BEGIN
90100 IF COMPTYPES( GATTR.TYPTR, LATTR.TYPTR^.INXTYPE )
90200 THEN WITH GATTR DO
90300 BEGIN
90400 LOAD;
90500 INDEX := CVAL.IVAL;
90600 GATTR := LATTR;
90700 WITH TYPTR^ DO
90800 BEGIN
90900 GETBOUNDS(INXTYPE, LMIN, LMAX );
91000 INDEXOFFSET := INDEX - LMIN;
91100 IF INDEXOFFSET < 0
91200 THEN I := - INDEXOFFSET
91300 ELSE
91400 IF INDEX > LMAX
91500 THEN
91600 I:= INDEX - LMAX
91700 ELSE
91800 GOTO 1;
91900 ERROR; WRITE(TTY,'ARRAY-INDEX BY ', I:LENGTH(I));
92000 IF INDEXOFFSET < 0
92100 THEN WRITELN(TTY, ' LESS THAN LOW BOUND')
92200 ELSE WRITELN(TTY, ' GREATER THAN HIGH BOUND');
92300 1:
92400 IF ARRAYPF
92500 THEN
92600 BEGIN
92700 PACKFG := TRUE;
92800 BYTESINWORD := BITMAX DIV AELTYPE^.BITSIZE; I := INDEXOFFSET MOD BYTESINWORD;
92900 GADDR := GADDR + (INDEXOFFSET DIV BYTESINWORD);
93000 IF INDEXOFFSET < 0
93100 THEN
93200 BEGIN
93300 GADDR := GADDR-1;
93400 I := I + BYTESINWORD
93500 END;
93600 GBITCOUNT := I * AELTYPE^.BITSIZE
93700 END
93800 ELSE GADDR := GADDR + (AELTYPE^.SIZE * INDEXOFFSET);
93900 IF TYPTR <> NIL
94000 THEN TYPTR := AELTYPE
94100 END (*WITH TYPTR^*)
94200 END (*IF COMPTYPES*)
94300 ELSE
94400 BEGIN
94500 ERROR; WRITELN(TTY,'INDEX-TYPE IS NOT COMPATIBLE WITH DECLARATION')
94600 END
94700 END (*IF TYPTR<>NIL*)
94800 UNTIL SY <> COMMA;
94900 IF SY = RBRACK
95000 THEN INSYMBOL
95100 ELSE
95200 BEGIN
95300 ERROR; WRITELN(TTY,'"]" EXPECTED')
95400 END;
95500 END;
95600 PERIOD:
95700 BEGIN
95800 IF TYPTR <> NIL
95900 THEN
96000 IF TYPTR^.FORM <> RECORDS
96100 THEN
96200 BEGIN
96300 ERROR; WRITELN(TTY,'TYPE OF VARIABLE IS NOT RECORD')
96400 END;
96500 INSYMBOL;
96600 IF SY = IDENT
96700 THEN
96800 BEGIN
96900 IF TYPTR <> NIL
97000 THEN
97100 BEGIN
97200 SEARCHSECTION(TYPTR^.FSTFLD, LCP);
97300 IF LCP = NIL
97400 THEN
97500 BEGIN
97600 ERROR; WRITELN(TTY,'NO SUCH FIELD IN THIS RECORD')
97700 END
97800 ELSE GETFIELD(LCP)
97900 END (*TYPTR <> NIL*);
98000 INSYMBOL
98100 END
98200 ELSE
98300 BEGIN
98400 ERROR; WRITELN(TTY,'IDENTIFIER EXPECTED')
98500 END
98600 END (*PERIOD*);
98700 ARROW:
98800 BEGIN
98900 INSYMBOL;
99000 IF TYPTR <> NIL
99100 THEN
99200 CASE TYPTR^.FORM OF
99300 POINTER:
99400 BEGIN
99500 GADDR := NEXTBYTE(18);
99600 IF GADDR = ORD(NIL)
99700 THEN
99800 BEGIN
99900 ERROR; WRITELN(TTY,'POINTER IS NIL')
00100 END
00200 ELSE
00300 IF (GADDR >= ORD(ACCUS)) OR
00400 (GADDR <= ORD(ACRPOINT(ACCUS^[0+15B],RIGHT)))
00500 THEN
00600 BEGIN
00700 ERROR; WRITELN(TTY,'POINTER IS OUT OF HEAP')
00800 END
00900 ELSE
01000 WITH HEAPCV DO
01100 BEGIN
01200 TYPTR := TYPTR^.ELTYPE;
01300 MERKBASIS:=ACRPOINT(GADDR-1,RIGHT);
01400 CIVAL:=MERKBASIS^[0];
01500 IF (GADDR < ORD(CACR) )
01600 AND (ORD(CIDTYPE) >= ORD(NIL) )
01700 THEN
01800 MAXADDR:=ORD(CACR)-1
01900 ELSE MAXADDR:=ORD(NIL);
02000 END (* WITH HEAPCV *);
02100 END;
02200 FILES:
02300 BEGIN
02400 GADDR := BASIS^[GADDR];
02500 TYPTR := TYPTR^.FILTYPE
02600 END;
02700 OTHERS:
02800 BEGIN
02900 ERROR;
03000 WRITELN(TTY,'TYPE OF VARIABLE MUST BE FILE OR POINTER')
03100 END
03200 END (*CASE FORM*);
03300 PACKFG := FALSE; GBITCOUNT := 0
03400 END (*ARROW*)
03500 END (*CASE*)
03600 END (*SELECTOR*);
03700
03800 PROCEDURE VARIABLE;
03900 VAR
04000 LCP: CTP;
04100
04200 BEGIN
04300 (*VARIABLE*)
04400 SEARCHID(LCP);
04500 INSYMBOL;
04600 IF LCP = NIL
04700 THEN
04800 BEGIN
04900 ERROR; WRITELN(TTY,'NOT FOUND')
05000 END
05100 ELSE
05200 BEGIN
05300 WITH LCP^, GATTR DO
05400 CASE KLASS OF
05500 TYPES:
05600 BEGIN
05700 ERROR; WRITELN(TTY,'!TYPE')
05800 END;
05900 KONST:
06000 BEGIN
06100 KIND := CST; CVAL := VALUES;
06200 TYPTR := IDTYPE
06300 END;
06400 VARS:
06500 BEGIN
06600 KIND := VARBL;
06700 GADDR := VADDR + ORD(BASIS); BASIS := NULLPTR;
06800 GBITCOUNT := 0;
06900 IF VKIND = FORMAL
07000 THEN GADDR := BASIS^[GADDR];
07100 TYPTR := IDTYPE; PACKFG := FALSE;
07200 SELECTOR
07300 END;
07400 (*FIELD: WRITE(TTY,'NOT IMPL.; TYPE <RECORD>.<FIELD> ...');*)
07500 PROC:
07600 BEGIN
07700 ERROR; WRITELN(TTY,'!PROCEDURE')
07800 END;
07900 FUNC:
08000 BEGIN
08100 ERROR; WRITELN(TTY,'!FUNCTION')
08200 END
08300 END (*CASE CLASS*)
08400 END
08500 END (*VARIABLE*);
08600
08700 PROCEDURE EXPRESSION;
08800
08900 PROCEDURE SIMPLEEXPRESSION;
09000 VAR
09100 SIGNED: BOOLEAN;
09200 LATTR: ATTR;
09300 LOP: SYMBOL;
09400
09500 PROCEDURE TERM;
09600 VAR
09700 LATTR: ATTR;
09800
09900 PROCEDURE FACTOR;
10000 BEGIN
10100 CASE SY OF
10200 IDENT:
10300 VARIABLE;
10400 INTCONST,
10500 REALCONST,
10600 CHARCONST:
10700 WITH GATTR DO
10800 BEGIN
10900 KIND := CST; CVAL := VAL;
11000 IF SY = INTCONST
11100 THEN TYPTR := ENTRY1.INTPTR
11200 ELSE
11300 IF SY = REALCONST
11400 THEN TYPTR := ENTRY1.REALPTR
11500 ELSE TYPTR := ENTRY1.CHARPTR;
11600 INSYMBOL
11700 END;
11800 STRINGCONST:
11900 WITH GATTR DO
12000 BEGIN
12100 TYPTR := STRINGPTR;
12200 KIND := VARBL; PACKFG := FALSE;
12300 GADDR := ORD(STRING); GBITCOUNT := 0;
12400 INSYMBOL
12500 END;
12600 NOTSY:
12700 BEGIN
12800 INSYMBOL; FACTOR;
12900 WITH GATTR DO
13000 IF TYPTR = ENTRY1.BOOLPTR
13100 THEN
13200 BEGIN
13300 LOAD; CVAL.BVAL := NOT CVAL.BVAL
13400 END
13500 ELSE
13600 BEGIN
13700 ERROR; WRITELN(TTY,'TYPE IS NOT BOOLEAN')
13800 END
13900 END (* NOT *);
14000 LPARENT:
14100 BEGIN
14200 INSYMBOL; EXPRESSION;
14300 IF SY = RPARENT
14400 THEN INSYMBOL
14500 ELSE
14600 BEGIN
14700 ERROR;
14800 WRITELN(TTY,'")" EXPECTED')
14900 END
15000 END (* ( *) ;
15100 OTHERS:
15200 BEGIN
15300 ERROR; WRITELN(TTY,'FACTOR EXPECTED')
15400 END
15500 END (* CASE *)
15600 END (*FACTOR*);
15700
15800 BEGIN (*TERM*)
15900 FACTOR;
16000 WHILE SY = MUL DO
16100 BEGIN
16200 INSYMBOL;
16300 LOAD; LATTR := GATTR;
16400 FACTOR; LOAD;
16500 IF COMPTYPES(LATTR.TYPTR,ENTRY1.INTPTR) AND
16600 COMPTYPES(GATTR.TYPTR,ENTRY1.INTPTR)
16700 THEN GATTR.CVAL.IVAL := GATTR.CVAL.IVAL * LATTR.CVAL.IVAL
16800 ELSE
16900 BEGIN
17000 ERROR; WRITELN(TTY,'OPERANDS MUST BE OF TYPE INTEGER')
17100 END
17200 END
17300 END (*TERM*);
17400
17500 BEGIN (*SIMPLEEXPRESSION*)
17600 IF SY IN [PLUS,MINUS]
17700 THEN WITH GATTR DO
17800 BEGIN
17900 SIGNED := SY=MINUS ;
18000 INSYMBOL; TERM;
18100 IF COMPTYPES(TYPTR,ENTRY1.INTPTR) OR COMPTYPES(TYPTR,ENTRY1.REALPTR)
18200 THEN
18300 BEGIN
18400 IF SIGNED
18500 THEN
18600 BEGIN
18700 LOAD; CVAL.IVAL := - CVAL.IVAL
18800 END
18900 END
19000 ELSE
19100 BEGIN
19200 ERROR; WRITELN(TTY,'NO SIGN ALLOWED HERE')
19300 END
19400 END (*MINUS*)
19500 ELSE TERM;
19600 WHILE SY IN [PLUS,MINUS] DO
19700 BEGIN
19800 LOP := SY; INSYMBOL;
19900 LOAD; LATTR := GATTR;
20000 TERM; LOAD;
20100 IF COMPTYPES(LATTR.TYPTR,ENTRY1.INTPTR) AND
20200 COMPTYPES(GATTR.TYPTR,ENTRY1.INTPTR)
20300 THEN
20400 IF LOP = PLUS
20500 THEN GATTR.CVAL.IVAL := LATTR.CVAL.IVAL + GATTR.CVAL.IVAL
20600 ELSE GATTR.CVAL.IVAL := LATTR.CVAL.IVAL - GATTR.CVAL.IVAL
20700 ELSE
20800 BEGIN
20900 ERROR; WRITELN(TTY,'OPERANDS MUST BE OF TYPE INTEGER')
21000 END
21100 END
21200 END (*SIMPLEEXPRESSION*);
21300
21400 BEGIN
21500 SIMPLEEXPRESSION
21600 END (*EXPRESSION*);
21700
21800 PROCEDURE SHIFTED_OUT(NAME:ALFA);
21900 LABEL
22000 1;
22100 VAR
22200 RUN:INTEGER;
22300 BEGIN
22400 FOR RUN := 1 TO 10 DO
22500 IF NAME[RUN]=' '
22600 THEN GOTO 1
22700 ELSE WRITE(TTY,NAME[RUN]);
22800 1:
22900 CHCNT:=CHCNT+RUN-1;
23000 END (*SHIFTED_OUT*);
23100
23200 PROCEDURE WRITESCALAR(FVAL:INTEGER; FSP: STP);
23300 VAR
23400 LCP: CTP; LENG,MAXVAL,MINVAL: INTEGER;
23500 LVALU: VALU;
23600 BEGIN
23700 LENG:=0;
23800 IF FSP <> NIL
23900 THEN WITH FSP^ DO
24000 CASE FORM OF
24100 SCALAR:
24200 IF SCALKIND=STANDARD
24300 THEN
24400 IF FSP=ENTRY1.INTPTR
24500 THEN
24600 BEGIN
24700 LENG := LENGTH(FVAL); WRITE(TTY, FVAL:LENG)
24800 END
24900 ELSE
25000 IF FSP=ENTRY1.REALPTR
25100 THEN WITH LVALU DO
25200 BEGIN
25300 IVAL := FVAL;
25400 WRITE(TTY, RVAL); LENG := 17
25500 END
25600 ELSE (*==>CHARPTR*)
25700 BEGIN
25800 IF FSP <> ENTRY1.CHARPTR
25900 THEN SYSTEM_ERROR(4)
26000 ELSE
26100 IF (FVAL<0) OR (FVAL>177B)
26200 THEN
26300 BEGIN
26400 WRITE(TTY,FVAL:LENGTH(FVAL),' (ILL. CHAR.)');LENG:=13+LENGTH(FVAL);
26500 END
26600 ELSE
26700 BEGIN
26800 IF (FVAL<40B) OR (FVAL=177B)
26900 THEN
27000 BEGIN
27100 ASCII_CHANGE.IVAL := FVAL;
27200 IF FVAL = 177B
27300 THEN ASCII_CHANGE.IVAL := 40B;
27400 WRITE(TTY,ASCII_CHANGE.MNEMO:3); LENG := 3
27500 END
27600 ELSE
27700 BEGIN
27800 WRITE(TTY,'''',CHR(FVAL),''''); LENG := 3
27900 END
28000 END;
28100 END
28200 ELSE (*SCALKIND==>DECLARED*)
28300 BEGIN
28400 LCP := FCONST;
28500 IF FVAL >= 0
28600 THEN WHILE LCP^.VALUES.IVAL > FVAL DO LCP := LCP^.NEXT;
28700 WITH LCP^ DO
28800 IF VALUES.IVAL <> FVAL
28900 THEN
29000 BEGIN
29100 WRITESCALAR(FVAL,ENTRY1.INTPTR); WRITE(TTY,'(OUT OF RANGE)'); LENG := 14
29200 END
29300 ELSE
29400 SHIFTED_OUT(NAME);
29500 END;
29600 SUBRANGE:
29700 BEGIN
29800 WRITESCALAR(FVAL,RANGETYPE); LENG := 0;
29900 IF NOT COMPTYPES(ENTRY1.REALPTR,RANGETYPE)
30000 THEN
30100 BEGIN
30200 IF RANGETYPE<>ENTRY1.INTPTR
30300 THEN
30400 GETBOUNDS(RANGETYPE,MINVAL,MAXVAL);
30500 IF (FVAL <= MAXVAL) AND (FVAL >= MINVAL) OR (ENTRY1.INTPTR=RANGETYPE)
30600 THEN
30700 BEGIN
30800 GETBOUNDS(FSP,MINVAL,MAXVAL);
30900 IF (FVAL > MAXVAL) OR (FVAL < MINVAL)
31000 THEN
31100 BEGIN
31200 WRITE(TTY,'(OUT OF SUBRANGE)');
31300 LENG:=17;
31400 END (* IF ..>...<.. *);
31500 END (* IF ..=<..=>..=.. *);
31600 END (* IF COMPTYPES *);
31700 END;
31800 POINTER:
31900 IF FVAL = ORD(NIL)
32000 THEN
32100 BEGIN
32200 WRITE(TTY,'NIL'); LENG := 3
32300 END
32400 ELSE
32500 BEGIN
32600 WRITE(TTY,FVAL:6:O,'B');
32700 IF (FVAL < ACCUS^[0+15B]) OR (FVAL > ORD(ACCUS))
32800 THEN
32900 BEGIN
33000 WRITE(TTY,'(OUT OF HEAP)');
33100 LENG:=20;
33200 END
33300 ELSE
33400 LENG:=7;
33500 END;
33600 OTHERS:
33700 SYSTEM_ERROR(5)
33800 END (*CASE*);
33900 CHCNT := CHCNT + LENG;
34000 TABS:=TRUE;
34100 END (*WRITESCALAR*);
34200
34300 PROCEDURE PUTSIXBIT(FSIXBIT:SIXBIT;FIX:INTEGER);
34400 VAR
34500 I:INTEGER;
34600 BEGIN
34700 FOR I:=1 TO FIX DO
34800 WRITE(TTY,CHR(FSIXBIT[I]+40B));
34900 CHCNT:=CHCNT+FIX;
35000 END;
35100
35200 PROCEDURE WRITESTRUCTURE( FSP: STP );
35300 TYPE
35400 ASCII=PACKED ARRAY[1..5] OF CHAR;
35500 THREEBIT=PACKED ARRAY[1..12] OF 0..7;
35600 HALFWORD=PACKED ARRAY[LEFTORRIGHT] OF BITS18;
35700
35800 FILBLKTYP=RECORD
35900 FILEOF,FILPTR:INTEGER;
36000 FILEOL:BOOLEAN;
36100 FILSTA,FILCLS,FILOUT,FILIN,FILENT,
36200 FILLKP,FILOPN:INTEGER;
36300 FILDEV:SIXBIT;
36400 FILPBH:HALFWORD;
36500 FILEXT,FILNAM:SIXBIT;
36600 FILPPN,FILPROT:THREEBIT;
36700 FILBTC,FILBTP,FILBFH:INTEGER;
36800 FILLNR:ASCII;
36900 FILCMP,FILCNT:INTEGER
37000 END;
37100 VAR
37200 STINX, INX, I : INTEGER;
37300 LLMAX, CURRCOMPO, LMIN, LMAX, LENG, LSPACE: INTEGER;
37400 OATTR, LATTR: ATTR;
37500 ILLSTRING,NEXTEQ, LASTEQ, ZERO, NOCOMMA: BOOLEAN;
37600 SETWANDEL: RECORD
37700 CASE BOOLEAN OF
37800 FALSE: (CONST1: INTEGER; CONST2: INTEGER);
37900 TRUE: (MASK: SET OF 0..BASEMAX)
38000 END;
38100 FILBLKWANDEL:RECORD
38200 CASE BOOLEAN OF
38300 TRUE:(INT:INTEGER);
38400 FALSE:(PTR:^FILBLKTYP)
38500 END;
38600
38700
38800 PROCEDURE WRITEFIELDLIST(FNEXTFLD: CTP; FRECVAR: STP);
38900 LABEL
39000 1;
39100 VAR
39200 LSP: STP;
39300 J,LMIN,LMAX : INTEGER;
39400 LATTR : ATTR;
39500 TAGF : CTP;
39600 BEGIN
39700 LATTR := GATTR; TAGF := NIL;
39800 IF FRECVAR <> NIL
39900 THEN
40000 IF FRECVAR^.FORM = TAGFWITHID
40100 THEN TAGF := FRECVAR^.TAGFIELDP;
40200 WHILE (FNEXTFLD <> NIL) AND (FNEXTFLD <> TAGF) DO
40300 BEGIN
40400 NEWLINE;
40500 GETFIELD(FNEXTFLD);
40600 WITH FNEXTFLD^ DO
40700 BEGIN
40800 SHIFTED_OUT(NAME);WRITE(TTY,'=');
40900 CHCNT:=CHCNT+1;
41000 NL := TRUE;
41100 LEFTSPACE:=LEFTSPACE+2;
41200 WRITESTRUCTURE(IDTYPE);
41300 LEFTSPACE:=LEFTSPACE-2;
41400 FNEXTFLD := NEXT
41500 END;
41600 IF FNEXTFLD<>NIL
41700 THEN
41800 WITH FNEXTFLD^.IDTYPE^ DO
41900 IF FORM=ARRAYS
42000 THEN
42100 BEGIN
42200 GETBOUNDS(INXTYPE,LMIN,LMAX);
42300 TABS:=ARRAYPF AND TABS AND
42400 COMPTYPES(AELTYPE , ENTRY1.CHARPTR) AND
42500 (LMAX-LMIN <= 20 )
42600 END
42700 ELSE
42800 TABS:=TABS AND (FORM<=POINTER)
42900 ELSE
43000 TABS:=FALSE;
43100 GATTR := LATTR
43200 END (*WHILE*);
43300 IF TAGF <> NIL
43400 THEN
43500 BEGIN
43600 WITH TAGF^ DO
43700 BEGIN
43800 NEWLINE;
43900 SHIFTED_OUT(NAME);
44000 WRITE(TTY,'=');
44100 CHCNT:=CHCNT+1;
44200 GETFIELD( TAGF );
44300 J := NEXTBYTE(IDTYPE^.BITSIZE);
44400 WRITESCALAR(J, IDTYPE);
44500 WRITE(TTY,' (TAGFIELD)');
44600 CHCNT:=CHCNT+11;
44700 END;
44800 LSP := FRECVAR^.FSTVAR;
44900 TABS:=FALSE;
45000 LOOP
45100 IF LSP = NIL
45200 THEN
45300 BEGIN
45400 WRITE(TTY,'(NO CORRESP.VARIANT)'); GOTO 1
45500 END
45600 EXIT IF LSP^.VARVAL.IVAL = J;
45700 LSP := LSP^.NXTVAR
45800 END (*LOOP*);
45900 WITH LSP^ DO
46000 BEGIN
46100 IF FORM <> VARIANT
46200 THEN
46300 SYSTEM_ERROR(6);
46400 GATTR := LATTR;
46500 WRITEFIELDLIST( FIRSTFIELD, SUBVAR );
46600 TABS:=FALSE;
46700 END;
46800 1:
46900 END
47000 END (*WRITEFIELDLIST*);
47100
47200 BEGIN
47300 (*WRITESTRUCTURE*)
47400 IF FSP <> NIL
47500 THEN WITH FSP^ DO
47600 IF FORM <= POINTER
47700 THEN WRITESCALAR ( NEXTBYTE(BITSIZE), FSP )
47800 ELSE
47900 BEGIN
48000 LATTR := GATTR;
48100 WITH GATTR DO
48200 BEGIN
48300 IF GBITCOUNT > 0
48400 THEN
48500 BEGIN
48600 GADDR := GADDR + 1; GBITCOUNT := 0
48700 END;
48800 CASE FORM OF
48900 POWER:
49000 BEGIN
49100 NOCOMMA := TRUE; WRITE(TTY, '['); LENG := 1;
49200 WITH SETWANDEL DO
49300 BEGIN
49400 CONST1 := BASIS^[GADDR]; CONST2 := BASIS^[GADDR+1];
49500 FOR INX := 0 TO BASEMAX DO
49600 IF INX IN MASK
49700 THEN
49800 BEGIN
49900 IF NOCOMMA
50000 THEN NOCOMMA := FALSE
50100 ELSE WRITE(TTY,',');
50200 LENG := LENG + 1;
50300 IF COMPTYPES(ELSET,ENTRY1.CHARPTR)
50400 THEN I := INX + OFFSET
50500 ELSE I := INX;
50600 WRITESCALAR(I,ELSET)
50700 END
50800 END (*WITH SETWANDEL*);
50900 WRITE(TTY,']' ); CHCNT := CHCNT + LENG;
51000 TABS:=FALSE;
51100 END (*POWER*);
51200 ARRAYS:
51300 BEGIN
51400 ILLSTRING:=FALSE;
51500 GETBOUNDS(INXTYPE, LMIN, LMAX );
51600 IF ( GADDR > ORD(ACRPOINT(ACCUS^[0+15B],RIGHT))) (* DYNAMIC ALLOCATED *)
51700 AND ( GADDR <= ORD(NIL) ) (* NOT A CONSTANT *)
51800 THEN
51900 BEGIN
52000 IF MAXADDR > ORD(ACCUS)
52100 THEN MAXADDR := ORD(ACCUS);
52200 IF ARRAYPF
52300 THEN
52400 LLMAX := (MAXADDR-GADDR+1) * (36 DIV AELTYPE^.BITSIZE) + LMIN - 1
52500 ELSE
52600 LLMAX := (MAXADDR-GADDR+1) DIV AELTYPE^.SIZE + LMIN - 1;
52700 IF LLMAX < LMAX
52800 THEN LMAX := LLMAX;
52900 END;
53000 LENG := LMAX - LMIN + 1 ;
53100 IF COMPTYPES(AELTYPE , ENTRY1.CHARPTR) AND ARRAYPF AND (LENG<121)
53200 THEN
53300 BEGIN
53400 POINTERCV.ADDR := GADDR;
53500 INX:=1;
53600 WITH POINTERCV DO
53700 WHILE (INX<=LENG) DO
53800 IF (STRINGPTR^[INX] < CHR(40B (*' '*))) OR (STRINGPTR^[INX] > CHR(172B (* LOWER-Z *)))
53900 THEN
54000 INX:=122
54100 ELSE INX:=INX+1;
54200 IF INX = 122
54300 THEN
54400 BEGIN
54500 ILLSTRING:=TRUE;
54600 WRITE(TTY,'STRING CONT. ILL. CHAR');
54700 TABS:=FALSE;
54800 LEFTSPACE:=LEFTSPACE+2;
54900 NEWLINE;
55000 WRITE(TTY,'THE COMPONENTS ARE:');
55100 NL:=TRUE;
55200 END;
55300 END (* TEST ILLSTRING *);
55400 IF COMPTYPES(AELTYPE , ENTRY1.CHARPTR) AND ARRAYPF AND (LENG<121) AND NOT ILLSTRING
55500 THEN (*STRING*)
55600 BEGIN
55700 WRITE ( TTY, '''', POINTERCV.STRINGPTR^ : LENG, '''' ) ;
55800 CHCNT := CHCNT + LENG + 2;
55900 TABS:= (LENG <= 20);
56000 END (*STRING*)
56100 ELSE
56200 BEGIN
56300 TABS:=FALSE;
56400 PACKFG:=ARRAYPF;
56500 LASTEQ:=FALSE;
56600 FOR INX:= LMIN TO LMAX DO
56700 BEGIN
56800 IF INX=LMAX
56900 THEN NEXTEQ:=FALSE
57000 ELSE
57100 IF AELTYPE^.FORM <= POINTER
57200 THEN
57300 BEGIN
57400 OATTR:=GATTR;
57500 CURRCOMPO:=NEXTBYTE(AELTYPE^.BITSIZE);
57600 NEXTEQ:=CURRCOMPO = NEXTBYTE(AELTYPE^.BITSIZE);
57700 GATTR:=OATTR;
57800 END
57900 ELSE
58000 BEGIN
58100 NEXTEQ:=TRUE;I:=0;
58200 LOOP
58300 NEXTEQ:=(BASIS^[GADDR+I] = BASIS^[GADDR+AELTYPE^.SIZE+I]);
58400 EXIT IF NOT NEXTEQ OR (I = AELTYPE^.SIZE-1);
58500 I:=I+1;
58600 END;
58700 END (* FORM>POINTER *);
58800 IF NOT(LASTEQ AND NEXTEQ)
58900 THEN
59000 BEGIN
59100 IF NL
59200 THEN NEWLINE
59300 ELSE NL:=TRUE;
59400 WRITE(TTY,'['); WRITESCALAR(INX,INXTYPE);
59500 WRITE(TTY,']'); CHCNT:=CHCNT+2;
59600 END;
59700 IF NOT NEXTEQ
59800 THEN
59900 BEGIN
60000 WRITE(TTY,'=');CHCNT:=CHCNT+1;
60100 LEFTSPACE:=LEFTSPACE + 3;
60200 NL:=TRUE;
60300 WRITESTRUCTURE(AELTYPE);
60400 LEFTSPACE:=LEFTSPACE - 3;
60500 END
60600 ELSE
60700 BEGIN
60800 IF NOT LASTEQ
60900 THEN
61000 BEGIN
61100 WRITE(TTY,'..');
61200 CHCNT:=CHCNT+2;
61300 NL:=FALSE;
61400 END;
61500 IF AELTYPE^.FORM <= POINTER
61600 THEN CURRCOMPO:=NEXTBYTE(AELTYPE^.BITSIZE)
61700 ELSE GADDR:=GADDR+AELTYPE^.SIZE;
61800 END (* NEXTEQ *);
61900 LASTEQ:=NEXTEQ;
62000 END (* FOR *);
62100 TABS:=FALSE;
62200 IF ILLSTRING
62300 THEN LEFTSPACE := LEFTSPACE - 2;
62400 END (* NOT STRING *);
62500 END (*ARRAYS*);
62600 RECORDS:
62700 BEGIN
62800 WRITE(TTY,'RECORD');
62900 LSPACE := LEFTSPACE; LEFTSPACE := CHCNT + 1;
63000 TABS:=FALSE;
63100 WRITEFIELDLIST(FSTFLD,RECVAR);
63200 TABS:=FALSE;
63300 LEFTSPACE := LEFTSPACE - 1; NEWLINE;
63400 WRITE(TTY,'END');
63500 LEFTSPACE := LSPACE;
63600 END;
63700 FILES:
63800 WITH FILBLKWANDEL DO
63900 BEGIN
64000 IF NL
64100 THEN
64200 NEWLINE;
64300 TABS:=TRUE;
64400 INT:=GADDR;
64500 WITH PTR^, GATTR DO
64600 IF (FILPBH[LEFT]=0) AND (FILPBH[RIGHT]=0)
64700 THEN
64800 BEGIN
64900 WRITE(TTY,' FILE NOT OPENED');
65000 END
65100 ELSE
65200 BEGIN
65300 SHIFTED_OUT('DEVICE: ');
65400 PUTSIXBIT(FILDEV,6);
65500 NEWLINE;
65600 SHIFTED_OUT('NAME: ');
65700 PUTSIXBIT(FILNAM,6);
65800 SHIFTED_OUT('. ');
65900 PUTSIXBIT(FILEXT,3);
66000 NEWLINE;
66100 SHIFTED_OUT('PPN:[ ');
66200 STINX:=1;
66300 LOOP
66400 ZERO:=TRUE;
66500 FOR INX:=STINX TO STINX+5 DO
66600 IF NOT(ZERO AND (FILPPN[INX]=0)) OR (INX=STINX+5)
66700 THEN
66800 BEGIN
66900 ZERO:=FALSE;
67000 WRITE(TTY,CHR(FILPPN[INX]+ORD('0')));
67100 CHCNT:=CHCNT+1;
67200 END;
67300 EXIT IF STINX=7;
67400 STINX:=7;WRITE(TTY,',');
67500 END;
67600 WRITE(TTY,']');CHCNT:=CHCNT+2;
67700 NEWLINE;
67800 SHIFTED_OUT('PROT:< ');
67900 FOR INX:=1 TO 3 DO
68000 WRITE(TTY,CHR(FILPROT[INX]+60B));
68100 WRITE(TTY,'>');
68200 CHCNT:=CHCNT+4;
68300 NEWLINE;
68400 SHIFTED_OUT('STATUS: ');
68500 IF FILSTA=0
68600 THEN SHIFTED_OUT('ASCII ')
68700 ELSE SHIFTED_OUT('BINARY ');
68800 NEWLINE;
68900 SHIFTED_OUT('MODE(I/O):');
69000 IF FILPBH[LEFT]<>0
69100 THEN SHIFTED_OUT('OUTPUT ')
69200 ELSE SHIFTED_OUT('INPUT ');
69300 NEWLINE;
69400 IF FILPBH[LEFT]=0
69500 THEN
69600 BEGIN
69700 IF FILSTA=0
69800 THEN
69900 BEGIN
70000 IF FILLNR<>'-----'
70100 THEN
70200 BEGIN
70300 SHIFTED_OUT('LINENR.: ');
70400 WRITE(TTY,FILLNR);
70500 CHCNT:=CHCNT+5;
70600 NEWLINE;
70700 END;
70800 WRITE(TTY,'EOLN:',FILEOL:5);
70900 CHCNT:=CHCNT+10;
71000 NEWLINE;
71100 END (* FILSTA = 0 *);
71200 WRITE(TTY,'EOF:',(FILEOF<>0):5);
71300 CHCNT:=CHCNT+9;
71400 NEWLINE;
71500 END (* FILPBH[LEFT]=0 *);
71600 GADDR:=FILPTR;
71700 TYPTR := TYPTR^.FILTYPE;
71800 TABS:=FALSE;
71900 IF CHCNT<>LEFTSPACE
72000 THEN NEWLINE;
72100 SHIFTED_OUT('COMPONENT:');
72200 NL:=TRUE;
72300 WRITESTRUCTURE(TYPTR);
72400 END (* WITH PTR^ *);
72500 TABS:=FALSE;
72600 END (* FILBLKWANDEL *)
72700 END (*CASE FORM*)
72800 END (*WITH GATTR*);
72900 GATTR := LATTR;
73000 WITH GATTR DO
73100 BEGIN
73200 GADDR := GADDR + SIZE; GBITCOUNT := 0
73300 END
73400 END (*IF FORM > POINTER*)
73500 END (*WRITESTRUCTURE*);
73600
73700 PROCEDURE ASSIGNMENT;
73800 VAR
73900 LATTR: ATTR;
74000 LSP: STP;
74100 BYTE, I: INTEGER;
74200 BEGIN
74300 IF GATTR.KIND <> VARBL
74400 THEN
74500 BEGIN
74600 ERROR; WRITELN(TTY,'ASSIGNMENT ALLOWED TO VARIABLES ONLY')
74700 END
74800 ELSE
74900 BEGIN
75000 LATTR := GATTR;
75100 EXPRESSION;
75200 IF SY <> EOLSY
75300 THEN
75400 BEGIN
75500 ERROR; WRITELN(TTY,'<CR><LF> EXPECTED')
75600 END
75700 ELSE
75800 IF COMPTYPES( LATTR.TYPTR, GATTR.TYPTR )
75900 THEN
76000 BEGIN
76100 IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
76200 THEN
76300 IF LATTR.PACKFG
76400 THEN
76500 BEGIN
76600 LOAD; BYTE := GATTR.CVAL.IVAL;
76700 GATTR := LATTR;
76800 PUTNEXTBYTE( GATTR.TYPTR^.BITSIZE, BYTE )
76900 END (* IF PACKFG *)
77000 ELSE
77100 IF GATTR.KIND <> VARBL
77200 THEN BASIS^[LATTR.GADDR] := GATTR.CVAL.IVAL
77300 ELSE
77400 IF GATTR.PACKFG
77500 THEN BASIS^[LATTR.GADDR] := NEXTBYTE( GATTR.TYPTR^.BITSIZE )
77600 ELSE FOR I := 0 TO LATTR.TYPTR^.SIZE - 1 DO
77700 BASIS^[LATTR.GADDR + I ] := BASIS^[ GATTR.GADDR + I ]
77800 END (* IF COMPTYPES *)
77900 ELSE
78000 BEGIN
78100 ERROR; WRITELN(TTY, 'TYPE-CONFLICT IN ASSIGNMENT' )
78200 END
78300 END (* KIND=VARIABLE *)
78400 END (*ASSIGNMENT*);
78500
78600
78700 FUNCTION STOPSEARCH(FLINE:ADDRRANGE):INTEGER;
78800 LABEL
78900 1;
79000 VAR
79100 I: INTEGER;
79200 BEGIN
79300 FOR I := 1 TO STOPMAX DO WITH STOPTABLE[I] DO
79400 IF (PAGE=GPAGE) AND (THISLINE=FLINE)
79500 THEN
79600 BEGIN
79700 STOPSEARCH := I;
79800 GOTO 1(*EXIT*)
79900 END;
80000 STOPSEARCH := 0; (*NOT FOUND*)
80100 1:
80200 END (*STOPSEARCH*);
80300
80400 FUNCTION PAGEVALUE(FPAGER: PAGEELEM): INTEGER;
80500 BEGIN
80600 WITH FPAGER DO PAGEVALUE := AC*16 + INXREG
80700 END (*PAGEVALUE*);
80800
80900 FUNCTION LINEVALUE ( VAR FLINER: LINEELEM; FLINE: INTEGER) : INTEGER;
81000 LABEL
81100 1;
81200 VAR
81300 I: INTEGER;
81400 BEGIN
81500 WHILE FLINER.CODE = 260B(*PUSHJ*) DO
81600 BEGIN
81700 I := STOPSEARCH( FLINE );
81800 IF I = 0
81900 THEN
82000 BEGIN
82100 WRITELN(TTY,'$ STOPTABLE DESTROYED'); LINEVALUE := -1; GOTO 1
82200 END;
82300 FLINER.CONSTANT1 := STOPTABLE[I] . ORIGINALCONT
82400 END (*PUSHJ*);
82500 WITH FLINER DO
82600 IF CODE = 320B(*JUMP*)
82700 THEN LINEVALUE := FLINE - ( AC + 16*INXR )
82800 ELSE (*SKIPA*)
82900 BEGIN
83000 IF CODE <> 334B(*SKIPA*)
83100 THEN
83200 BEGIN
83300 SYSTEM_ERROR(7);
83400 LINEVALUE := -1; GOTO 1
83500 END;
83600 IF ABSLINE = 777777B
83700 THEN LINEVALUE := -1
83800 ELSE LINEVALUE := ABSLINE
83900 END;
84000 1:
84100 END (*LINEVALUE*) ;
84200
84300 PROCEDURE BREAKPOINT;
84400 LABEL
84500 1;
84600 VAR
84700 LINENR, I: INTEGER;
84800 PAGER: PAGEELEM; LLE: LINEELEM;
84900 LLINE,LPAGE: INTEGER;
85000 OLDLINE: INTEGER;
85100 OLDADDR: ^LINEELEM;
85200 CHANGEPTR: ^LINEELEM;
85300
85400 FUNCTION GETLINPAG: BOOLEAN; (*READS LINENUMBER AND PAGENUMBER*)
85500 BEGIN
85600 GETLINPAG := FALSE;
85700 IF SY <> INTCONST
85800 THEN WRITELN(TTY,'$ ILL. LINENR.')
85900 ELSE
86000 BEGIN
86100 LINENR := VAL.IVAL; GPAGE := 1(*DEFAULT*);
86200 INSYMBOL;
86300 IF SY = SLASHSY
86400 THEN
86500 BEGIN
86600 INSYMBOL;
86700 IF SY <> INTCONST
86800 THEN WRITELN(TTY,'$ ILL. PAGENR.')
86900 ELSE
87000 BEGIN
87100 GPAGE := VAL.IVAL; INSYMBOL
87200 END
87300 END;
87400 IF SY <> EOLSY
87500 THEN WRITELN(TTY,'$ COMMAND ERROR')
87600 ELSE GETLINPAG := TRUE
87700 END
87800 END (*GETLINPAG*);
87900
88000 BEGIN
88100 (*BREAKPOINT*)
88200 CASE SY OF
88300 IDENT:
88400 IF ID = 'LIST '
88500 THEN
88600 BEGIN
88700 INSYMBOL;
88800 IF SY <> EOLSY
88900 THEN WRITELN(TTY,'$ COMMAND ERROR')
89000 ELSE FOR I := 1 TO STOPMAX DO WITH STOPTABLE[I] DO
89100 IF PAGE > 0
89200 THEN WRITELN(TTY,'$ ', THISLINE:5, '/', PAGE:LENGTH(PAGE))
89300 END
89400 ELSE
89500 WRITELN(TTY,'$ COMMAND ERROR');
89600 NOTSY:
89700 BEGIN
89800 INSYMBOL;
89900 IF GETLINPAG
90000 THEN
90100 BEGIN
90200 I:=STOPSEARCH(LINENR);
90300 IF I = 0
90400 THEN WRITELN(TTY, '$ ?NO STOP')
90500 ELSE WITH STOPTABLE[I] DO
90600 BEGIN
90700 PAGE := 0;
90800 PROTECTION(FALSE);
90900 THISADDR^.CONSTANT1 := ORIGINALCONT;
91000 PROTECTION(TRUE);
91100 THISADDR := NIL
91200 END
91300 END
91400 END;
91500 INTCONST:
91600 IF GETLINPAG AND ( STOPSEARCH(LINENR) = 0 (*A NEW STOP*) )
91700 THEN
91800 BEGIN
91900 STOPNR := 1;
92000 WHILE STOPTABLE[STOPNR].PAGE <> 0 DO STOPNR := STOPNR + 1;
92100 IF STOPNR > STOPMAX
92200 THEN WRITELN(TTY,'$ TOO MUCH STOPS')
92300 ELSE
92400 BEGIN
92500 (*EXECUTE STOP*)
92600 (*1.STEP: SEARCH PAGE*)
92700 PAGER := ENTRY1.LASTPAGEELEM;
92800 LPAGE := PAGEVALUE(PAGER);
92900 IF LPAGE < GPAGE
93000 THEN WRITELN(TTY,'$ PAGENR. TOO LARGE')
93100 ELSE
93200 BEGIN
93300 WHILE LPAGE > GPAGE DO
93400 BEGIN
93500 PAGER := PAGER.PAGPTR^;
93600 LPAGE := PAGEVALUE(PAGER)
93700 END;
93800 IF LPAGE <> GPAGE
93900 THEN
94000 BEGIN
94100 WRITELN(TTY,'$ CAN''T STOP ON THIS PAGE'); GOTO 1
94200 END;
94300 WITH LLE, PAGER DO
94400 BEGIN
94500 LLINE := LASTLINE; ADP := LASTSTOP
94600 END;
94700 IF LLINE < LINENR
94800 THEN WRITELN(TTY,'$ LINENR. TOO LARGE')
94900 ELSE
95000 BEGIN
95100 WHILE LLINE > LINENR DO
95200 BEGIN
95300 OLDLINE := LLINE; OLDADDR := LLE.ADP;
95400 LLE := LLE.ADP^;
95500 LLINE := LINEVALUE ( LLE, LLINE )
95600 END;
95700 IF LLINE <> LINENR
95800 THEN
95900 BEGIN
96000 WRITE(TTY,'$ NEXT POSSIBLE: ',OLDLINE:LENGTH(OLDLINE),' (Y OR N)? ');
96100 BREAK; READLN(TTY);
96200 INSYMBOL;
96300 IF (SY <> IDENT) OR (ID[1] <> 'Y') OR (STOPSEARCH(OLDLINE) <> 0)
96400 THEN GOTO 1;
96500 LLE.ADP := OLDADDR; LLINE := OLDLINE
96600 END;
96700 CHANGEPTR := LLE.ADP;
96800 WITH STOPTABLE[STOPNR] DO
96900 BEGIN
97000 THISLINE := LLINE; PAGE := GPAGE;
97100 ORIGINALCONT := CHANGEPTR^.CONSTANT1;
97200 THISADDR := CHANGEPTR
97300 END;
97400 PROTECTION(FALSE);
97500 CHANGEPTR^.CONSTANT1 := ENTRY2.STOPPY;
97600 PROTECTION(TRUE)
97700 END
97800 END
97900 END;
98000 1:
98100 END (*INTCONST*);
98200 OTHERS:
98300 WRITELN(TTY,'$ COMMAND ERROR')
98400 END (*CASE*)
98500 END (*BREAKPOINT*);
98600
98700 PROCEDURE LINEINTERVAL(FADDR: ADDRRANGE; VAR LIN1,LIN2,PAG: INTEGER);
98800 VAR
98900 PAGER: PAGEELEM; LINER: LINEELEM;
99000 BEGIN
99100 PAGER := ENTRY1.LASTPAGEELEM;
99200 WHILE ORD(PAGER.PAGPTR) > FADDR DO
99300 PAGER := PAGER.PAGPTR^;
99400 LINER.ADP := PAGER.LASTSTOP;
99500 PAG := PAGEVALUE(PAGER); LIN2 := PAGER.LASTLINE;
99600 LIN1 := LIN2;
99700 WHILE ORD ( LINER.ADP ) > FADDR DO
99800 BEGIN
99900 LINER := LINER.ADP^;
00100 LIN2 := LIN1;
00200 LIN1 := LINEVALUE(LINER,LIN2)
00300 END;
00400 IF LIN1<0
00500 THEN LIN1 := 0
00600 END (*LINEINTERVAL*);
00700
00800 PROCEDURE STOPMESSAGE(FADDR: ADDRRANGE);
00900 VAR
01000 LIN1, LIN2, PAG: INTEGER;
01100 BEGIN
01200 LINEINTERVAL(FADDR,LIN1,LIN2,PAG);
01300 WRITELN(TTY, '$ STOP IN ', LIN1:LENGTH(LIN1), '/', PAG:LENGTH(PAG), ':',LIN2:LENGTH(LIN2) )
01400 END (*STOPMESSAGE*) ;
01500
01600 PROCEDURE TRACEOUT;
01700 VAR
01800 I: 0:5; LCP: CTP;
01900 LADDR: ADDRRANGE;
02000 LIN1, LIN2, PAG, MAXNAMES: INTEGER;
02100 BEGIN
02200 TABS:=FALSE;
02300 IF DUMP
02400 THEN
02500 BEGIN
02600 NEWLINE;
02700 WRITELN(TTY,' ':39,'PROCEDURE BACKTRACING');
02800 WRITE(TTY,'$',' ':40,'=====================');
02900 NEWLINE;
03000 WRITELN(TTY);MAXNAMES:=5;
03100 END
03200 ELSE
03300 MAXNAMES:=2;
03400 FIRSTBASIS; I := 0; LEFTSPACE := 0;
03500 LADDR := ENTRY2.STATUS.RETURNADDR;
03600 WRITE(TTY,'$ ');
03700 LOOP
03800 LINEINTERVAL ( LADDR, LIN1, LIN2, PAG ) ;
03900 WRITE(TTY,LIN1:5,'/',PAG:LENGTH(PAG),' ')
04000 EXIT IF BASIS = NULLPTR;
04100 LCP := IDTREE;
04200 IF LCP<>NIL
04300 THEN
04400 WRITE(TTY, LCP^.NEXT^.NAME )
04500 ELSE
04600 WRITE(TTY,'''NO NAME'' ');
04700 IF I = MAXNAMES
04800 THEN
04900 BEGIN
05000 NEWLINE; I := 0
05100 END
05200 ELSE
05300 BEGIN
05400 WRITE(TTY,' _ '); I := I + 1
05500 END;
05600 LADDR := ORD ( ACRPOINT(BASIS^[0]-1,RIGHT) );
05700 SUCCBASIS( LEFT(*=DYNAMIC*) )
05800 END;
05900 WRITELN(TTY, 'MAIN')
06000 END (*TRACEOUT*);
06100
06200
06300 PROCEDURE ONE_VAR_OUT(LCP:CTP);
06400 BEGIN
06500 WITH LCP^,GATTR DO
06600 BEGIN
06700 KIND:=VARBL;
06800 GADDR:=VADDR+ORD(MERKBASIS);
06900 GBITCOUNT:=0;
07000 IF VKIND=FORMAL
07100 THEN
07200 GADDR:=NULLPTR^[GADDR];
07300 TYPTR:=IDTYPE;
07400 PACKFG:=FALSE;
07500 SHIFTED_OUT(NAME);
07600 WRITE(TTY,'=');
07700 CHCNT:=CHCNT+1;
07800 IF IDTYPE^.FORM > POWER
07900 THEN
08000 BEGIN
08100 NL:=TRUE;
08200 LEFTSPACE:=2;
08300 END;
08400 WRITESTRUCTURE(IDTYPE);
08500 IF IDTYPE^.FORM >= POWER
08600 THEN
08700 BEGIN
08800 LEFTSPACE:=0;
08900 TABS:=FALSE;
09000 NEWLINE;
09100 END;
09200 NEWLINE;
09300 END (* WITH *);
09400 END (* ONE_VAR_OUT *);
09500
09600 PROCEDURE SECTION_OUT(LCP:CTP;FFORMSET:FORMSET);
09700 BEGIN
09800 WITH LCP^ DO
09900 BEGIN
10000 IF LLINK<>NIL
10100 THEN
10200 SECTION_OUT(LLINK,FFORMSET);
10300 IF (KLASS=VARS) AND (IDTYPE^.FORM IN FFORMSET)
10400 THEN
10500 ONE_VAR_OUT(LCP);
10600 IF RLINK<>NIL
10700 THEN
10800 SECTION_OUT(RLINK,FFORMSET);
10900 END (* WITH *);
11000 END (* SECTION_OUT *);
11100
11200 PROCEDURE OUT(SIDE:LEFTORRIGHT);
11300 VAR
11400 CALLCNT:INTEGER;
11500 TREEPNT:CTP;
11600 LOWESTDYNAMICBASIS,STATICBASIS:ACR;
11700 VARSOUT:BOOLEAN;
11800 BEGIN
11900 CALLCNT:=1;
12000 CHCNT:=0;
12100 TABS:=FALSE;
12200 LOWESTDYNAMICBASIS:=MERKBASIS;
12300 FIRSTBASIS;
12400 STATICBASIS:=BASIS;
12500 LOOP
12600 MERKBASIS:=BASIS;
12700 TREEPNT:=IDTREE;
12800 BASIS:=NULLPTR;
12900 VARSOUT:=TRUE;
13000 IF MERKBASIS=NULLPTR
13100 THEN
13200 WRITE(TTY,' * * * * * * * * MAIN')
13300 ELSE
13400 IF TREEPNT=NIL
13500 THEN
13600 WRITE(TTY,'P R O C E D U R E ''NO NAME'' ')
13700 ELSE
13800 IF TREEPNT^.NEXT <> NIL
13900 THEN
14000 IF TREEPNT^.NEXT^.KLASS = FUNC
14100 THEN WRITE(TTY,'F U N C T I O N ',TREEPNT^.NEXT^.NAME)
14200 ELSE WRITE(TTY,'P R O C E D U R E ',TREEPNT^.NEXT^.NAME);
14300 NEWLINE;
14400 WRITE(TTY,'- - - - - - - - - - - - - - - -');
14500 NEWLINE;
14600 IF (SIDE = LEFT) AND (STATICBASIS = MERKBASIS) AND (MERKBASIS <> NULLPTR)
14700 THEN
14800 BEGIN
14900 WRITE(TTY,'THE FOLLOWING VARIABLES ARE VALID');NEWLINE;
15000 WRITE(TTY,' IN THE INTERRUPTED PROCEDURE ');
15100 NEWLINE;NEWLINE;
15200 BASIS:=STATICBASIS;
15300 SUCCBASIS(RIGHT);
15400 STATICBASIS:=BASIS;
15500 BASIS:=NULLPTR;
15600 END
15700 ELSE
15800 IF (SIDE = RIGHT) AND (ORD(LOWESTDYNAMICBASIS) <= ORD(MERKBASIS))
15900 THEN
16000 BEGIN
16100 WRITE(TTY,'LOOK ABOVE ( VAR. OF CALLED PROC.) ');
16200 NEWLINE; VARSOUT:=FALSE;
16300 END;
16400 IF (TREEPNT = NIL) AND VARSOUT
16500 THEN
16600 BEGIN
16700 WRITE(TTY,' THERE IS NO INFORMATION ABOUT' );NEWLINE;
16800 WRITE(TTY,' THIS PART OF THE PROGRAMM ( LOCAL D- ??)');
16900 NEWLINE; VARSOUT:=FALSE;
17000 END (* TREEPTR=NIL ....*);
17100 IF VARSOUT AND (MERKBASIS<>NULLPTR)
17200 THEN TREEPNT:=TREEPNT^.LLINK;
17300 IF VARSOUT
17400 THEN
17500 IF TREEPNT<>NIL
17600 THEN
17700 BEGIN
17800 SECTION_OUT(TREEPNT,[SCALAR,SUBRANGE,POINTER]);
17900 TABS:=FALSE;
18000 IF CHCNT<>0
18100 THEN NEWLINE;
18200 NEWLINE;
18300 SECTION_OUT(TREEPNT,[POWER,ARRAYS,RECORDS,FILES]);
18400 TABS:=FALSE;
18500 END (* TREEPNT<>NIL *)
18600 ELSE
18700 BEGIN
18800 WRITE(TTY,'+++ NO VARIABLES +++');
18900 NEWLINE;NEWLINE;
19000 END;
19100 NEWLINE;NEWLINE;
19200 EXIT IF (MERKBASIS=NULLPTR) OR (CALLCNT=10);
19300 CALLCNT:=CALLCNT+1;
19400 BASIS:=MERKBASIS;
19500 SUCCBASIS(SIDE);
19600 END (* LOOP *);
19700 IF MERKBASIS=NULLPTR
19800 THEN
19900 SECTION_OUT(ENTRY1.STANDARDIDTREE,[FILES]);
20000 END (* OUT *);
20100
20200 PROCEDURE STACK_OUT;
20300 BEGIN
20400 NEWLINE;NEWLINE;
20500 WRITELN(TTY,' ':40,'VARIABLES OF THE CALLED PROCEDURE(S)');
20600 WRITE(TTY,'$',' ':41,'====================================');
20700 NEWLINE;NEWLINE;
20800 OUT(LEFT);
20900 IF MERKBASIS<>NULLPTR
21000 THEN
21100 BEGIN
21200 NEWLINE;NEWLINE;
21300 WRITE(TTY,' BECAUSE THERE ARE MORE THAN 10 DYNAMIC NESTED PROCEDURES AND/OR FUNCTIONS');
21400 NEWLINE;
21500 WRITE(TTY,' NOW ONLY THE VARIABLES OF THE STATIC NESTED PROCEDURES AND/OR FUNCTIONS ');
21600 NEWLINE;WRITE(TTY,' WILL BE PRINTED OUT');NEWLINE;
21700 NEWLINE;NEWLINE;NEWLINE;
21800 WRITELN(TTY,' ':40,'VARIABLES OF STATIC NESTED PROCEDURES');
21900 WRITE(TTY,'$',' ':41,'=====================================');
22000 NEWLINE;NEWLINE;NEWLINE;
22100 OUT(RIGHT);
22200 END (*BASIS<>.. *);
22300 END (* ALL_VAR_OUT *);
22400
22500 PROCEDURE HEAP_OUT;
22600 VAR
22700 REC:ACR;
22800
22900 BEGIN
23000 NEWLINE;
23100 WRITELN(TTY,' ':39,'THE CONTENTS OF THE HEAP');
23200 WRITE(TTY,'$ ',' ':39,'========================');
23300 NEWLINE;
23400 TABS:=FALSE;
23500 REC:=ACRPOINT(ACCUS^[0+15B],RIGHT);
23600 WITH HEAPCV DO
23700 BEGIN
23800 CIVAL:=REC^[0];
23900 IF (CIDTYPE=NIL) AND (CACR=NIL)
24000 THEN
24100 BEGIN
24200 NEWLINE;
24300 WRITE(TTY,' NO VARIABLES ALLOCATED');
24400 NEWLINE;
24500 END
24600 ELSE
24700 WHILE CACR<>NIL DO
24800 BEGIN
24900 IF (ORD(CACR) > ORD(ACCUS)) OR
25000 (ORD(CACR) <= ACCUS^[0+15B]) OR
25100 (ORD(CACR) <= ORD(REC)) OR
25200 (ORD(CIDTYPE) < ORD(NIL)) OR
25300 (ORD(CIDTYPE) > ORD(ENTRY2.ENTRYPTR))
25400 THEN
25500 BEGIN
25600 NEWLINE;
25700 WRITE(TTY,' CANT CONTINUE THE HEAP-DUMP');
25800 CACR:=NIL;
25900 NEWLINE;
26000 END
26100 ELSE
26200 BEGIN
26300 NEWLINE;
26400 WRITE(TTY,(ORD(REC)+1):6:O,'B^=');
26500 CHCNT:=CHCNT+9;
26600 IF CIDTYPE=NIL
26700 THEN
26800 BEGIN
26900 NEWLINE;
27000 WRITE(TTY,' TYPE OF REFERENCED VARIABLE NOT KNOWN');
27100 NEWLINE;
27200 END
27300 ELSE
27400 WITH GATTR DO
27500 BEGIN
27600
27700 NL:=TRUE;
27800 TYPTR:=CIDTYPE;
27900 KIND:=VARBL;
28000 PACKFG:=FALSE;
28100 GADDR:=ORD(REC)+1;
28200 MAXADDR:=ORD(CACR) - 1;
28300 GBITCOUNT:=0;
28400 WRITESTRUCTURE(CIDTYPE);
28500 END (* WITH GATTR *);
28600 TABS:=FALSE;
28700 REC:=CACR;
28800 CIVAL:=REC^[0];
28900 NEWLINE;
29000 END (* POINTER OK *);
29100 END (* WHILE *);
29200 END (* WITH HEAPCV *);
29300 NEWLINE;
29400 END (* HEAP_OUT *);
29500
29600 PROCEDURE WRITE_PROGRAM_NAME;
29700 BEGIN
29800 WITH POINTERCV DO
29900 BEGIN
30000 ADDR := ORD(ACRPOINT(ENTRY2.NAME_PNT_PNT^[0],RIGHT));
30100 SHIFTED_OUT(ALFAPNT^);
30200 END;
30300 WRITELN(TTY)
30400 END (* WRITE_PROGRAM_NAME *);
30500
30600 PROCEDURE HEADER;
30700 BEGIN
30800 LEFTSPACE:=0;
30900 DUMP:=TRUE;
31000 TIME(DAY_TIME);
31100 DATE(DAY);
31200 FILE_NAME:=' PMD';
31300 FILE_NAME[1]:=DAY_TIME[1];
31400 FILE_NAME[2]:=DAY_TIME[2];
31500 FILE_NAME[3]:=DAY_TIME[4];
31600 FILE_NAME[4]:=DAY_TIME[5];
31700 FILE_NAME[5]:=DAY_TIME[7];
31800 FILE_NAME[6]:=DAY_TIME[8];
31900 IF ENTRY2.INTERACTIVE
32000 THEN
32100 DEVICE:='DSK '
32200 ELSE DEVICE:='LPT ';
32300 REWRITE(TTYOUTPUT,FILE_NAME,0,0,DEVICE);
32400 NEWLINE;
32500 WRITE(TTY,DAY:20,DAY_TIME:20,'PROGRAM-NAME ':20);
32600 WRITE_PROGRAM_NAME;
32700 WRITE(TTY,'$ ');
32800 END (* HEADER *);
32900
33000 PROCEDURE BACK_TO_TTY;
33100 BEGIN
33200 TABS:=FALSE;
33300 DUMP := FALSE;
33400 REWRITE(TTYOUTPUT,'123456789',0,0,'TTY ');
33500 IF ENTRY2.INTERACTIVE
33600 THEN WRITE(TTY,'$');
33700 NEWLINE;
33800 NEWLINE;
33900 WRITELN(TTY,'LOOK FOR DUMP ON FILE ',FILE_NAME:6,
34000 '.',FILE_NAME[7],FILE_NAME[8],FILE_NAME[9]);
34100 END (* BACK_TO_TTY *);
34200
34300
34400 PROCEDURE CORRECT_ADDR;
34500 VAR
34600 PAGEPOINTER:^PAGEELEM;
34700
34800 FUNCTION RIGHT_ADDR:ADDRRANGE;
34900 VAR
35000 HELP:INTEGER;
35100 LACR:ACR;
35200 BEGIN
35300 FIRSTBASIS;
35400 IF BASIS=NULLPTR
35500 THEN RIGHT_ADDR:=ORD(ACRPOINT(ENTRY2.STACKBOTTOM^[0+2]-1,RIGHT))
35600 ELSE
35700 BEGIN
35800 LACR:=ACRPOINT(BASIS^[0]-1,RIGHT);
35900 HELP:=LACR^[0];
36000 REPEAT
36100 HELP:=HELP+1;
36200 LACR:=ACRPOINT(HELP,RIGHT);
36300 UNTIL ORD(ACRPOINT(LACR^[0],LEFT))=541757B (*HRRI 17,?(17)*);
36400 HELP:=ORD(ACRPOINT(LACR^[0],RIGHT));
36500 RIGHT_ADDR:=ORD(ACRPOINT(BASIS^[HELP+1]-1,RIGHT));
36600 END;
36700 END (* RIGHT_ADDR *);
36800
36900 BEGIN
37000 WITH ENTRY1,ENTRY2.STATUS DO
37100 BEGIN
37200 IF ORD(ENTRY2.ENTRYPTR) <= RETURNADDR
37300 THEN
37400 RETURNADDR:=RIGHT_ADDR
37500 ELSE
37600 BEGIN
37700 PAGEPOINTER:=LASTPAGEELEM.PAGPTR;
37800 IF ORD(PAGEPOINTER) <> 0
37900 THEN
38000 WHILE ORD(PAGEPOINTER^.PAGPTR) <> 0 DO
38100 PAGEPOINTER:=PAGEPOINTER^.PAGPTR;
38200 IF (ORD(PAGEPOINTER) > RETURNADDR) OR ( ORD(PAGEPOINTER) = 0 )
38300 THEN
38400 RETURNADDR:=RIGHT_ADDR;
38500 END (* ELSE *);
38600 END (* WITH *);
38700 END (* CORRECT_ADDR *);
38800
38900
39000 PROCEDURE INIT;
39100 BEGIN
39200 WITH POINTERCV DO
39300 BEGIN
39400 ADDR := 140B;
39500 ENTRY2 := ENTPTR2^
39600 END;
39700 ENTRY1 := ENTRY2.ENTRYPTR^;
39800 ACCUS := ENTRY2.REGISTRS;
39900 NULLPTR := ACRPOINT(0,RIGHT);
40000 IF ENTRY2.STATUS.KIND IN [DDTK,RUNTMERRK]
40100 THEN CORRECT_ADDR;
40200 LADDR := ENTRY2.STATUS.RETURNADDR;
40300 END (*INIT*);
40400
40500 PROCEDURE DEBUG_INTERACTIVE;
40600 LABEL
40700 1;
40800 VAR
40900 OPEN_TTY: BOOLEAN;
41000 BEGIN
41100 WRITELN(TTY);
41200 BREAK;
41300 OPEN_TTY := TRUE;
41400 CASE ENTRY2.STATUS.KIND OF
41500 INITK:
41600 BEGIN
41700 ID := 'TTY '; VARIABLE; (*FILEBLOCK(TTY)-->GATTR*)
41800 IF BASIS^[GATTR.GADDR+13B] = 0
41900 THEN
42000 OPEN_TTY := FALSE;
42100 (* TO BE SURE THAT THE TTY-INPUT FILE HAS BEEN OPENED *)
42200 WRITE(TTY, VERSION:5,': ');
42300 WRITE_PROGRAM_NAME;
42400 END;
42500 STOPK:
42600 BEGIN
42700 FOR STOPNR := 1 TO STOPMAX DO
42800 WITH STOPTABLE[STOPNR] DO
42900 IF ORD(THISADDR) = LADDR
43000 THEN
43100 BEGIN
43200 WRITE(TTY,'$ STOP AT ', THISLINE:LENGTH(THISLINE), '/', PAGE:LENGTH(PAGE),' IN ');
43300 WRITE_PROGRAM_NAME;
43400 GOTO 1
43500 END;
43600 STOPMESSAGE(LADDR); (*,IF NOT FOUND*)
43700 1:
43800 END;
43900 DDTK:
44000 BEGIN
44100 WRITE(TTY, '$ STOP BY DDT COMMAND IN ');
44200 WRITE_PROGRAM_NAME;
44300 STOPMESSAGE(LADDR)
44400 END;
44500 HALTK, RUNTMERRK:
44600 BEGIN
44700 IF ENTRY2.STATUS.KIND = RUNTMERRK
44800 THEN
44900 WRITE(TTY,'$ STOP BY RUNTIME ERROR IN ')
45000 ELSE
45100 WRITE(TTY,'$ STOP BY HALT IN ');
45200 WRITE_PROGRAM_NAME;
45300 STOPMESSAGE(LADDR)
45400 END
45500 END (*CASE*);
45600 BUFFLNG := 0;
45700 WHILE NOT EOLN(TTY) AND OPEN_TTY DO
45800 BEGIN
45900 BUFFLNG := BUFFLNG + 1;
46000 (*READ ( TTY, BUFFER[BUFFLNG] )*) BUFFER[BUFFLNG] := TTY^; GET(TTY)
46100 END;
46200 REPEAT
46300 REPEAT
46400 WRITE(TTY,'$'); BREAK;
46500 IF OPEN_TTY
46600 THEN READLN(TTY)
46700 ELSE
46800 BEGIN
46900 OPEN_TTY := TRUE;
47000 RESET(TTY,'TTY ',0,0,'TTY ');
47100 END;
47200 UNTIL NOT EOLN(TTY);
47300 READ(TTY,CH); CHCNT := 0;
47400 INSYMBOL;
47500 CASE SY OF
47600 STOPSY:
47700 BEGIN
47800 INSYMBOL;
47900 BREAKPOINT
48000 END;
48100 STACKDUMPSY,
48200 HEAPDUMPSY:
48300 BEGIN
48400 HEADER;
48500 WRITELN(TTY);
48600 STOPMESSAGE(LADDR);
48700 WRITE(TTY,'$');
48800 NEWLINE;
48900 TRACEOUT;
49000 WRITE(TTY,'$ ');
49100 IF SY=STACKDUMPSY
49200 THEN STACK_OUT
49300 ELSE HEAP_OUT;
49400 BACK_TO_TTY;
49500 END;
49600 TRACESY:
49700 TRACEOUT;
49800 IDENT, NOTSY, (*EXPRESSION-BEGIN-SYMBOLS*)
49900 INTCONST, REALCONST, CHARCONST, STRINGCONST, PLUS, MINUS,
50000 LPARENT:
50100 BEGIN
50200 EXPRESSION;
50300 CASE SY OF
50400 EQSY:
50500 WITH GATTR DO
50600 IF TYPTR <> NIL
50700 THEN
50800 BEGIN
50900 WRITE(TTY,'$ ');
51000 CHCNT := 0; LEFTSPACE := 0; NL := FALSE;
51100 IF KIND <> VARBL
51200 THEN
51300 IF TYPTR^.FORM = ARRAYS
51400 THEN
51500 BEGIN
51600 GADDR := CVAL.IVAL;
51700 BASIS := NULLPTR;
51800 WRITESTRUCTURE ( TYPTR )
51900 END
52000 ELSE WRITESCALAR(CVAL.IVAL,TYPTR)
52100 ELSE WRITESTRUCTURE( TYPTR );
52200 WRITELN(TTY)
52300 END;
52400 BECOMES:
52500 BEGIN
52600 INSYMBOL; ASSIGNMENT
52700 END;
52800 OTHERS:
52900 BEGIN
53000 ERROR; WRITELN(TTY, '"=" OR ":=" EXPECTED')
53100 END
53200 END (*CASE*)
53300 END;
53400 ENDSY, EOLSY: (*EMPTY*) ;
53500 OTHERS:
53600 WRITELN(TTY,'$ COMMAND ERROR')
53700 END (*CASE*)
53800 UNTIL SY=ENDSY;
53900 IF ENTRY2.STATUS.KIND IN [RUNTMERRK,HALTK]
54000 THEN WRITELN(TTY,'$ CANNOT CONTINUE')
54100 ELSE
54200 BEGIN
54300 WHILE SY <> EOLSY DO INSYMBOL;
54400 IF (BUFFLNG > 0) AND (ENTRY2.STATUS.KIND <> DDTK)
54500 THEN WITH GATTR DO
54600 BEGIN
54700 ID := 'TTY '; VARIABLE; (*FILEBLOCK(TTY)-->GATTR*)
54800 BASIS^[GADDR+25B(*FILCMP*)] := ORD(BUFFER[1]);
54900 BASIS^[GADDR+ 2B(*FILEOL*)] := ORD(FALSE);
55000 BASIS^[GADDR+22B(*FILBTC*)] := BUFFLNG + 2;
55100 LADDR := BASIS^[GADDR+20B(*FILBFH*)]+2; (*ADDR OF 1ST DATA*)
55200 BASIS^[GADDR+21B(*FILBTP*)] := 010700000000B + LADDR -1;
55300 GADDR := LADDR; PACKFG:= TRUE;
55400 FOR CHCNT := 2 TO BUFFLNG DO PUTNEXTBYTE(7,ORD(BUFFER[CHCNT]));
55500 PUTNEXTBYTE(7,015B); PUTNEXTBYTE(7,012B); (*<CR><LF>*)
55600 FOR CHCNT := 1 TO 4 DO PUTNEXTBYTE(7,0); (*CLEAR WITH NULL*)
55700 WRITELN(TTY,'$ INPUT RESCANNED(!) : ', BUFFER:BUFFLNG);
55800 BREAK
55900 END;
56000 WRITELN(TTY)
56100 END
56200 END (*DEBUG_INTERACTIVE*);
56300
56400
56500 PROCEDURE DEBUG_BATCH;
56600
56700 BEGIN
56800 CASE ENTRY2.STATUS.KIND OF
56900 INITK:
57000 WITH POINTERCV DO
57100 BEGIN
57200 WRITE(TTY,VERSION:5,': ');
57300 WRITE_PROGRAM_NAME;
57400 ADDR:=140B;
57500 ENTPTR2^.TIME_LIMIT:= 4 * ((ENTRY2.TIME_LIMIT + CLOCK) DIV 5);
57600 BREAK;
57700 END;
57800 HALTK, RUNTMERRK:
57900 BEGIN
58000 HEADER;
58100 NEWLINE;
58200 NEWLINE;
58300 WRITELN(TTY,'***************************************************':90);
58400 WRITELN(TTY,'$','*':41,'*':50);
58500 WRITELN(TTY,'$','*':41,'*':50);
58600 WRITELN(TTY,'$','*':41,' P O S T - M O R T E M - D U M P *':51);
58700 WRITELN(TTY,'$','*':41,VERSION:34,'*':16);
58800 WRITELN(TTY,'$','*':41,'*':50);
58900 WRITELN(TTY,'$','***************************************************':91);
59000 WRITE(TTY,'$');
59100 NEWLINE;
59200 WRITELN(TTY);
59300 STOPMESSAGE(LADDR);
59400 WRITE(TTY,'$ ');
59500 IF ENTRY2.STATUS.KIND = HALTK
59600 THEN WRITE(TTY,'STOP BY HALT')
59700 ELSE WRITE(TTY,'STOP BY RUNTIME ERROR');
59800 NEWLINE;
59900 NEWLINE;
60000 TRACEOUT;
60100 WRITE(TTY,'$');
60200 STACK_OUT;
60300 NEWLINE;
60400 HEAP_OUT;
60500 WRITE(TTY,' END OF POST - MORTEM - DUMP');
60600 BACK_TO_TTY;
60700 END;
60800 OTHERS:
60900 WRITELN(TTY,'$ POST-MORTEM-DUMP ERROR')
61000 END;
61100 END;
61200
61300 (*!!!!!!!!!!!!!!!!!!!!!! DEBUG !!!!!!!!!!!!!!!!!!!!!!!!*)
61400 BEGIN
61500 INIT;
61600 IF ENTRY2.INTERACTIVE
61700 THEN
61800 DEBUG_INTERACTIVE
61900 ELSE
62000 DEBUG_BATCH;
62100 END;
62200 BEGIN
62300 END.
00100 PROGRAM STATUS, GETSTATUS;
00200
00300 (*******************************************************************************
00400 *
00500 * PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
00600 *
00700 * PROCEDURE GETSTATUS
00800 *
00900 * - ASSIGN APPROPRIATE VALUES TO
01000 * "FILENAME", "PROTECTION", "UFD" AND "DEVICE"
01100 * AS FOUND IN "FILE_BLOCK".
01200 *
01300 * GETSTATUS IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO
01400 * EVERY PASCAL USER.
01500 *
01600 ******************************************************************************)
01700
01800 TYPE
01900 LEFTORRIGHT = (LEFT,RIGHT);
02000 ASCII = PACKED ARRAY[1..5] OF CHAR;
02100 PACK6 = PACKED ARRAY[1..6] OF CHAR;
02200 PACK9 = PACKED ARRAY[1..9] OF CHAR;
02300 THREEBIT = PACKED ARRAY[1..12] OF 0..7;
02400 HALFWORD = PACKED ARRAY[LEFTORRIGHT] OF 0..777777B;
02500 SIXBIT = PACKED ARRAY[1..6] OF 0..77B;
02600 FILEBLOCKPOINTER = ^FILEBLOCK;
02700 FILEBLOCK = RECORD
02800 FILEOF,FILPTR:INTEGER;
02900 FILEOL:BOOLEAN;
03000 FILSTA,FILCLS,FILOUT,FILIN,FILENT,
03100 FILLKP,FILOPN:INTEGER;
03200 FILDEV:SIXBIT;
03300 FILPBH:HALFWORD;
03400 FILEXT,FILNAM:SIXBIT;
03500 FILPROT:THREEBIT;
03600 FILPPN: INTEGER;
03700 FILBTC,FILBTP,FILBFH:INTEGER;
03800 FILLNR:ASCII;
03900 FILCMP,FILCNT:INTEGER
04000 END;
04100
04200 PROCEDURE GETSTATUS(FILE_BLOCK: FILEBLOCKPOINTER;
04300 VAR FILENAME: PACK9;
04400 VAR PROTECTION, UFD: INTEGER;
04500 VAR DEVICE: PACK6);
04600 VAR
04700 I: INTEGER;
04800
04900 BEGIN
05000 (*GETSTATUS*)
05100 WITH FILE_BLOCK^ DO
05200 BEGIN
05300 UFD := FILPPN;
05400 PROTECTION := 0;
05500 FOR I := 1 TO 3 DO PROTECTION := PROTECTION*10B + FILPROT[I];
05600 FOR I := 1 TO 6 DO FILENAME[I] := CHR(FILNAM[I] + 40B);
05700 FOR I := 1 TO 3 DO FILENAME[I+6] := CHR(FILEXT[I] + 40B);
05800 FOR I := 1 TO 6 DO DEVICE[I] := CHR(FILDEV[I] + 40B)
05900 END
06000 END (*GETSTATUS*);
06100
06200 BEGIN
06300 END.
00100 PROGRAM READ, READSCALAR, READIRANGE,
00200 READCRANGE, READRRANGE, READISET, READCSET, READDSET;
00300
00400 (************************************************************************************
00500 *
00600 * PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
00700 *
00800 * EXTENDED FORMATTED INPUT
00900 *
01000 * - READSCALAR : READ IDENTIFIERS OF DECLARED SCALARS
01100 *
01200 * - READIRANGE,
01300 * READCRANGE,
01400 * READRRANGE : READ SUBRANGE OF INTEGER, CHAR OR REAL
01500 * WITH BOUNDARY CHECKS
01600 *
01700 * - READISET,
01800 * READCSET,
01900 * READDSET : READ SETS OF INTEGER, CHAR OR DECLARED SCALARS
02000 * OR THEIR SUBRANGES WITH BOUNDARY CHECKS
02100 *
02200 ************************************************************************************)
02300
02400 CONST
02500 MAXSET = 71;
02600 OFFSET = 40B;
02700
02800 TYPE
02900 SETRANGE = 0..MAXSET;
03000 VECTOR = ^NAME_VECTOR;
03100 NAME_VECTOR = ARRAY[0..0] OF ALFA;
03200 STANDARD_SET = SET OF SETRANGE;
03300 SCALAR_FORM = (INTEGER_FORM,CHAR_FORM,REAL_FORM,BOOL_FORM,DECLARED_FORM);
03400
03500 VAR
03600 ERRORMESSAGE: PACKED ARRAY[1..4,1..45] OF CHAR;
03700 CH: CHAR; DIRECT_CALL, ERROR_EXIT: BOOLEAN;
03800 IDENTIFIER: ALFA;
03900
04000 INITPROCEDURE;
04100 BEGIN
04200 ERRORMESSAGE[1] := 'INPUT ERROR: INVALID SCALAR SPECIFICATION ';
04300 ERRORMESSAGE[2] := 'INPUT ERROR: SCALAR UNDEFINED OR OUT OF RANGE';
04400 ERRORMESSAGE[3] := 'INPUT ERROR; INVALID SET SPECIFICATION ';
04500 ERRORMESSAGE[4] := 'INPUT ERROR: SET ELEMENT SPECIFIED DOUBLE ';
04600 DIRECT_CALL := TRUE; ERROR_EXIT := FALSE;
04700 END;
04800
04900 PROCEDURE STOP; EXTERN;
05000
05100 PROCEDURE ERROR( ERRORNUMBER: INTEGER);
05200 BEGIN
05300 IF NOT ERROR_EXIT
05400 THEN
05500 BEGIN
05600 WRITELN(TTY);
05700 WRITE(TTY,'%? ',ERRORMESSAGE[ERRORNUMBER]);
05800 BREAK(TTY);
05900 ERROR_EXIT := TRUE
06000 END
06100 END;
06200
06300 PROCEDURE NEXTCH( VAR SOURCE_FILE: TEXT);
06400 BEGIN
06500 IF NOT EOLN(SOURCE_FILE)
06600 THEN READ(SOURCE_FILE,CH)
06700 ELSE CH := ' '
06800 END;
06900
07000 PROCEDURE SKIP( VAR SOURCE_FILE: TEXT);
07100 BEGIN
07200 IF EOLN(SOURCE_FILE)
07300 THEN READLN(SOURCE_FILE);
07400 NEXTCH(SOURCE_FILE);
07500 WHILE (CH = ' ') AND NOT (EOF(SOURCE_FILE) OR EOLN(SOURCE_FILE)) DO
07600 NEXTCH(SOURCE_FILE)
07700 END;
07800
07900 PROCEDURE READIRANGE( VAR SOURCE_FILE: TEXT;
08000 VAR SCALAR_VARIABLE: INTEGER;
08100 MIN_VALUE, MAX_VALUE: INTEGER);
08200 VAR
08300 NEGATIVE: BOOLEAN;
08400 BEGIN
08500
08600 IF DIRECT_CALL
08700 THEN SKIP(SOURCE_FILE);
08800
08900 NEGATIVE := FALSE; SCALAR_VARIABLE := 0;
09000 IF CH IN ['+','-']
09100 THEN
09200 BEGIN
09300 NEGATIVE := CH = '-';
09400 NEXTCH(SOURCE_FILE)
09500 END;
09600
09700 IF NOT (CH IN ['0'..'9'])
09800 THEN ERROR(1);
09900
10000 WHILE CH IN ['0'..'9'] DO
10100 BEGIN
10200 SCALAR_VARIABLE := SCALAR_VARIABLE * 10 + (ORD(CH) - ORD('0'));
10300 NEXTCH(SOURCE_FILE)
10400 END;
10500
10600 IF (SCALAR_VARIABLE < MIN_VALUE) OR (SCALAR_VARIABLE > MAX_VALUE)
10700 THEN
10800 BEGIN
10900 ERROR(2); WRITE(TTY,' ***',SCALAR_VARIABLE,'***')
11000 END;
11100 IF DIRECT_CALL AND ERROR_EXIT
11200 THEN
11300 BEGIN
11400 ERROR_EXIT := FALSE;
11500 BREAK(TTY);
11600 STOP
11700 END
11800 ELSE DIRECT_CALL := TRUE
11900 END;
12000
12100 PROCEDURE READCRANGE( VAR SOURCE_FILE: TEXT;
12200 VAR SCALAR_VARIABLE: CHAR;
12300 MIN_VALUE, MAX_VALUE: CHAR);
12400 BEGIN
12500 IF EOLN(SOURCE_FILE)
12600 THEN READLN(SOURCE_FILE);
12700 READ(SOURCE_FILE,CH);
12800 SCALAR_VARIABLE := CH;
12900 IF (SCALAR_VARIABLE < MIN_VALUE) OR (SCALAR_VARIABLE > MAX_VALUE)
13000 THEN
13100 BEGIN
13200 ERROR(2); WRITE(TTY,' ***''',SCALAR_VARIABLE,'''***')
13300 END;
13400 IF DIRECT_CALL AND ERROR_EXIT
13500 THEN
13600 BEGIN
13700 ERROR_EXIT := FALSE;
13800 BREAK(TTY);
13900 STOP
14000 END
14100 ELSE DIRECT_CALL := TRUE
14200 END;
14300
14400 PROCEDURE READRRANGE( VAR SOURCE_FILE: TEXT;
14500 VAR SCALAR_VARIABLE: REAL;
14600 MIN_VALUE, MAX_VALUE: REAL);
14700 BEGIN
14800 IF EOLN(SOURCE_FILE)
14900 THEN READLN(SOURCE_FILE);
15000 READ(SOURCE_FILE,SCALAR_VARIABLE);
15100 IF (SCALAR_VARIABLE < MIN_VALUE) OR (SCALAR_VARIABLE > MAX_VALUE)
15200 THEN
15300 BEGIN
15400 ERROR(2); WRITE(TTY,' ***',SCALAR_VARIABLE,'***')
15500 END;
15600 IF DIRECT_CALL AND ERROR_EXIT
15700 THEN
15800 BEGIN
15900 ERROR_EXIT := FALSE;
16000 BREAK(TTY);
16100 STOP
16200 END
16300 ELSE DIRECT_CALL := TRUE
16400 END;
16500
16600 PROCEDURE READSCALAR( VAR SOURCE_FILE: TEXT;
16700 VAR SCALAR_VARIABLE: INTEGER;
16800 MIN_VALUE, MAX_VALUE: INTEGER;
16900 SCALAR_NAME: VECTOR);
17000
17100 PROCEDURE READIDENTIFIER;
17200 VAR
17300 I: INTEGER;
17400
17500 BEGIN
17600 IDENTIFIER := ' '; I := 1;
17700 IF NOT (CH IN ['A'..'Z'])
17800 THEN ERROR(1)
17900 ELSE
18000 LOOP
18100 IDENTIFIER[I] := CH;
18200 NEXTCH(SOURCE_FILE)
18300 EXIT IF NOT (CH IN ['0'..'9','A'..'Z','_']);
18400 IF I < ALFALENGTH
18500 THEN I := I + 1
18600 END
18700 END;
18800
18900 BEGIN (*READSCALAR*)
19000 IF DIRECT_CALL
19100 THEN SKIP(SOURCE_FILE);
19200 READIDENTIFIER; SCALAR_VARIABLE := MIN_VALUE;
19300 WHILE (SCALAR_NAME^[-SCALAR_VARIABLE] <> IDENTIFIER) AND NOT ERROR_EXIT DO
19400 IF SCALAR_VARIABLE < MAX_VALUE
19500 THEN SCALAR_VARIABLE := SCALAR_VARIABLE+1
19600 ELSE
19700 BEGIN
19800 ERROR(2); WRITE(TTY,' ***',IDENTIFIER,'***')
19900 END;
20000 IF DIRECT_CALL AND ERROR_EXIT
20100 THEN
20200 BEGIN
20300 ERROR_EXIT := FALSE;
20400 BREAK(TTY);
20500 STOP
20600 END
20700 ELSE DIRECT_CALL := TRUE
20800 END;
20900
21000 PROCEDURE READSET( VAR SOURCE_FILE: TEXT;
21100 VAR SET_VARIABLE: STANDARD_SET;
21200 MIN_VALUE, MAX_VALUE: INTEGER;
21300 SCALAR_NAME: VECTOR;
21400 ELEMENT_FORM: SCALAR_FORM);
21500
21600 LABEL
21700 111;
21800
21900 VAR
22000 SCALAR_VALUE: RECORD
22100 CASE SCALAR_FORM OF
22200 INTEGER_FORM: (IVAL: INTEGER);
22300 CHAR_FORM : (CVAL: CHAR)
22400 END;
22500 I, FIRST_SCALAR: INTEGER;
22600 SUBRANGE: BOOLEAN;
22700
22800 BEGIN
22900 SUBRANGE := FALSE;
23000 FIRST_SCALAR := 0;
23100 SET_VARIABLE := [];
23200 SKIP(SOURCE_FILE);
23300 IF MAX_VALUE = 0
23400 THEN MAX_VALUE := MAXSET;
23500 IF NOT EOF(SOURCE_FILE)
23600 THEN
23700 BEGIN
23800 IF CH = '['
23900 THEN
24000 BEGIN
24100 SKIP(SOURCE_FILE);
24200 IF CH <> ']'
24300 THEN
24400 LOOP
24500 DIRECT_CALL := FALSE;
24600 CASE ELEMENT_FORM OF
24700 INTEGER_FORM:
24800 READIRANGE(SOURCE_FILE,SCALAR_VALUE.IVAL,MIN_VALUE,MAX_VALUE);
24900 CHAR_FORM:
25000 BEGIN
25100 IF CH <> ''''
25200 THEN ERROR(3)
25300 ELSE
25400 BEGIN
25500 READCRANGE(SOURCE_FILE,SCALAR_VALUE.CVAL,CHR(MIN_VALUE),CHR(MAX_VALUE));
25510 IF SCALAR_VALUE.IVAL = ORD('''')
25520 THEN
25530 BEGIN
25540 NEXTCH(SOURCE_FILE) ;
25550 IF CH <> '''' THEN ERROR(3) ;
25560 END ;
25600 SCALAR_VALUE.IVAL := SCALAR_VALUE.IVAL-OFFSET;
25700 NEXTCH(SOURCE_FILE);
25800 IF CH <> ''''
25900 THEN ERROR(3)
26000 ELSE NEXTCH(SOURCE_FILE)
26100 END
26200 END;
26300 DECLARED_FORM:
26400 READSCALAR(SOURCE_FILE,SCALAR_VALUE.IVAL,MIN_VALUE,MAX_VALUE,SCALAR_NAME)
26500 END;
26600 IF SCALAR_VALUE.IVAL IN SET_VARIABLE
26700 THEN
26800 BEGIN
26900 IF NOT ERROR_EXIT
27000 THEN
27100 BEGIN
27200 ERROR(4); WRITE(TTY,' ***');
27300 CASE ELEMENT_FORM OF
27400 INTEGER_FORM:
27500 WRITE(TTY,SCALAR_VALUE.IVAL);
27600 CHAR_FORM:
27605 BEGIN
27610 IF SCALAR_VALUE.IVAL + OFFSET = ORD('''')
27620 THEN WRITE(TTY,'''') ;
27700 WRITE(TTY,'''',CHR(SCALAR_VALUE.IVAL+OFFSET),'''');
27710 END ;
27800 DECLARED_FORM:
27900 WRITE(TTY,IDENTIFIER)
28000 END;
28100 WRITE(TTY,'***')
28200 END
28300 END
28400 ELSE
28500 IF SUBRANGE
28600 THEN
28700 FOR I := FIRST_SCALAR+1 TO SCALAR_VALUE.IVAL DO
28800 SET_VARIABLE := SET_VARIABLE + [ I ]
28900 ELSE
29000 SET_VARIABLE := SET_VARIABLE + [ SCALAR_VALUE.IVAL ];
29100 SUBRANGE := FALSE;
29200 IF (CH = ' ') AND NOT ERROR_EXIT
29300 THEN SKIP(SOURCE_FILE)
29400 EXIT IF NOT (CH IN [',','.',':']) OR ERROR_EXIT;
29500 IF CH IN ['.',':']
29600 THEN
29700 BEGIN
29800 SUBRANGE := TRUE;
29900 FIRST_SCALAR := SCALAR_VALUE.IVAL
30000 END;
30100 IF CH = '.'
30200 THEN
30300 BEGIN
30400 NEXTCH(SOURCE_FILE);
30500 IF CH <> '.'
30600 THEN
30700 BEGIN
30800 ERROR(3); GOTO 111
30900 END
31000 END;
31100 SKIP(SOURCE_FILE)
31200 END;
31300 111:
31400 DIRECT_CALL := TRUE;
31500 IF (CH <> ']')
31600 THEN ERROR(3)
31700 END
31800 ELSE ERROR(3)
31900 END
32000 ELSE ERROR(3)
32100 END;
32200
32300 PROCEDURE READISET( VAR SOURCE_FILE: TEXT;
32400 VAR SET_VARIABLE: STANDARD_SET;
32500 MIN_VALUE, MAX_VALUE: INTEGER);
32600 BEGIN
32700 READSET(SOURCE_FILE,SET_VARIABLE,MIN_VALUE,MAX_VALUE,NIL,INTEGER_FORM);
32800 IF ERROR_EXIT
32900 THEN
33000 BEGIN
33100 ERROR_EXIT := FALSE;
33200 BREAK(TTY);
33300 STOP
33400 END
33500 END;
33600
33700 PROCEDURE READCSET( VAR SOURCE_FILE: TEXT;
33800 VAR SET_VARIABLE: STANDARD_SET;
33900 MIN_VALUE, MAX_VALUE: INTEGER);
34000 BEGIN
34100 READSET(SOURCE_FILE,SET_VARIABLE,MIN_VALUE,MAX_VALUE,NIL,CHAR_FORM);
34200 IF ERROR_EXIT
34300 THEN
34400 BEGIN
34500 ERROR_EXIT := FALSE;
34600 BREAK(TTY);
34700 STOP
34800 END
34900 END;
35000
35100 PROCEDURE READDSET( VAR SOURCE_FILE: TEXT;
35200 VAR SET_VARIABLE: STANDARD_SET;
35300 MIN_VALUE, MAX_VALUE: INTEGER;
35400 SCALAR_NAME: VECTOR);
35500 BEGIN
35600 READSET(SOURCE_FILE,SET_VARIABLE,MIN_VALUE,MAX_VALUE,SCALAR_NAME,DECLARED_FORM);
35700 IF ERROR_EXIT
35800 THEN
35900 BEGIN
36000 ERROR_EXIT := FALSE;
36100 BREAK(TTY);
36200 STOP
36300 END
36400 END;
36500
36600 BEGIN
36700 END.
00100 PROGRAM WRITE, WRTSCALAR, WRTISET, WRTCSET, WRTDSET;
00200
00300 (************************************************************************************
00400 *
00500 * PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
00600 *
00700 * EXTENDED FORMATTED OUTPUT
00800 *
00900 * - WRTSCALAR : WRITE IDENTIFIERS OF DECLARED SCALARS
01000 *
01100 * - WRTISET,
01200 * WRTCSET,
01300 * WRTDSET : WRITE SETS OF INTEGER, CHAR OR DECLARED SCALARS
01400 * OR THEIR SUBRANGES
01500 *
01600 ************************************************************************************)
01700
01800 CONST
01900 MAXSET = 71;
02000 OFFSET = 40B;
02100 HALFWORD = 777777B;
02200 INTSTDLGTH = 12;
02300
02400 TYPE
02500 HALFRANGE = 0..HALFWORD;
02600 SETRANGE = 0..MAXSET;
02700 VECTOR = ^NAME_VECTOR;
02800 NAME_VECTOR = ARRAY[0..0] OF ALFA;
02900 STANDARD_SET = SET OF SETRANGE;
03000 SCALAR_FORM = (INTEGER_FORM,CHAR_FORM,REAL_FORM,BOOL_FORM,DECLARED_FORM);
03100 PAIR = PACKED RECORD
03200 VALUE: HALFRANGE;
03300 LENGTH: HALFRANGE
03400 END;
03500
03600 VAR
03700 DIRECT_CALL: BOOLEAN;
03800
03900 INITPROCEDURE;
04000 BEGIN
04100 DIRECT_CALL := TRUE
04200 END;
04300
04400 PROCEDURE WRTSCALAR( VAR TARGET_FILE: TEXT;
04500 SCALAR_VALUE: INTEGER;
04600 MAXIMUM: PAIR;
04700 SCALAR_NAME: VECTOR);
04800 VAR
04900 I: INTEGER;
05000
05100 BEGIN
05200 IF (SCALAR_VALUE >= 0) AND (SCALAR_VALUE <= MAXIMUM.VALUE)
05300 THEN
05400 WITH MAXIMUM DO
05500 BEGIN
05510 IF LENGTH=0 THEN LENGTH:=10 (*DEFAULT FORMAT*);
05600 I := 0;
05700 WHILE SCALAR_NAME^[-SCALAR_VALUE,I+1] <> ' ' DO I := I + 1;
05800 IF LENGTH < I THEN WRITE(TARGET_FILE,SCALAR_NAME^[-SCALAR_VALUE]:LENGTH) ELSE BEGIN
05900 WRITE(TARGET_FILE,' ':(LENGTH-I));
06000 WRITE(TARGET_FILE,SCALAR_NAME^[-SCALAR_VALUE]:I)
06010 END
06100 END
06200 ELSE
06400 WRITE(TARGET_FILE,'**********');
06800 DIRECT_CALL := TRUE
06900 END;
07000
07100 PROCEDURE WRTSET( VAR TARGET_FILE: TEXT;
07200 SET_VALUE: STANDARD_SET;
07300 MAXIMUM: PAIR;
07400 SCALAR_NAME: VECTOR;
07500 ELEMENT_FORM: SCALAR_FORM);
07600 VAR
07700 ELEMENT: SETRANGE;
07800 FIRST_ELEMENT, SUBRANGE: BOOLEAN;
07900
08000 BEGIN
08100 WRITE(TARGET_FILE,'[');
08200 FIRST_ELEMENT := TRUE;
08300 SUBRANGE := FALSE;
08400 ELEMENT := 0;
08500 WHILE ELEMENT <= MAXSET DO
08600 BEGIN
08700 IF ELEMENT IN SET_VALUE
08800 THEN
08900 BEGIN
09000 IF NOT (FIRST_ELEMENT OR SUBRANGE)
09100 THEN WRITE(TARGET_FILE,',');
09200 FIRST_ELEMENT := FALSE;
09300 SUBRANGE := FALSE;
09400 DIRECT_CALL := FALSE;
09500 WITH MAXIMUM DO
09600 CASE ELEMENT_FORM OF
09700 INTEGER_FORM:
09800 BEGIN
09900 IF LENGTH <= 0
10000 THEN LENGTH := INTSTDLGTH;
10100 WRITE(TARGET_FILE,ELEMENT:LENGTH)
10200 END;
10300 CHAR_FORM:
10400 BEGIN
10500 IF LENGTH > 3
10550 THEN
10575 IF (ELEMENT + OFFSET) = ORD('''')
10585 THEN WRITE(TARGET_FILE,' ':(LENGTH-4),'''')
10600 ELSE WRITE(TARGET_FILE,' ':(LENGTH-3));
10700 WRITE(TARGET_FILE,'''',CHR(ELEMENT+OFFSET),'''')
10800 END;
10900 DECLARED_FORM:
11000 WRTSCALAR(TARGET_FILE,ELEMENT,MAXIMUM,SCALAR_NAME)
11100 END;
11200 IF (ELEMENT+1 IN SET_VALUE) AND (ELEMENT+2 IN SET_VALUE)
11300 THEN
11400 BEGIN
11500 WHILE ELEMENT+2 IN SET_VALUE DO
11600 ELEMENT := ELEMENT + 1;
11700 SUBRANGE := TRUE;
11800 WRITE(TARGET_FILE,'..')
11900 END
12000 END;
12100 ELEMENT := ELEMENT + 1
12200 END;
12300 WRITE(TARGET_FILE,']');
12400 DIRECT_CALL := TRUE
12500 END;
12600
12700 PROCEDURE WRTISET( VAR TARGET_FILE: TEXT;
12800 SET_VALUE: STANDARD_SET;
12900 MAXIMUM: PAIR);
13000 BEGIN
13100 WRTSET(TARGET_FILE,SET_VALUE,MAXIMUM,NIL,INTEGER_FORM)
13200 END;
13300
13400 PROCEDURE WRTCSET( VAR TARGET_FILE: TEXT;
13500 SET_VALUE: STANDARD_SET;
13600 MAXIMUM: PAIR);
13700 BEGIN
13800 WRTSET(TARGET_FILE,SET_VALUE,MAXIMUM,NIL,CHAR_FORM)
13900 END;
14000
14100 PROCEDURE WRTDSET( VAR TARGET_FILE: TEXT;
14200 SET_VALUE: STANDARD_SET;
14300 MAXIMUM: PAIR;
14400 SCALAR_NAME: VECTOR);
14500 BEGIN
14600 WRTSET(TARGET_FILE,SET_VALUE,MAXIMUM,SCALAR_NAME,DECLARED_FORM)
14700 END;
14800
14900 BEGIN
15000 END.