*DECK     PASCLIB 
(*$A+,U+,L'PASCAL-6000 LIBRARY ROUTINES'*)
  
  
  
  
PROGRAM PASCLIB;
  
  
  
  
(*--- DEFAULT OPTIONS FOR THE LIBRARY ---*) 
(*$E+ MEANINGFUL ENTRYPOINT NAMES        *) 
(*$P0 NO POST-MORTEM DUMP INFORMATION    *) 
(*$T- NO RUN TIME TESTS                  *) 
(*$X4 PASS 4 PARAMETERS IN X-REGS        *) 
  
  
  
  
CONST                        (* ANCHOR LINE FOR NEW CONSTANTS *)
      T29 =  4000000000B;  (* 2**29 *)
      T30 = 10000000000B;  (* 2**30 *)
  
  
  
  
*CALL     COMSPAS 
  
  
  
  
TYPE                         (* ANCHOR LINE FOR NEW TYPES *)
  
  
   POSINT     = 0..323;   (* POSITIVE EXPONENT RANGE *) 
   EXPINT     = -293..323;(* EXPONENT RANGE *)
   DOUBLE     = RECORD UPPER: REAL; LOWER: REAL END;
  
  
   (* THE FOLLOWING TYPES BELONG TO PMD *)
  
   OPCODE = 0..77B; 
   REGISTER = 0..7B;
   BYTEFIELD = 0..7777B;
   PARCELFIELD = 0..77777B; 
   ADDRESSFIELD = 0..777777B; 
  
   PWORD = ^WORD; 
   WORDFORMAT = 1..14;
   WORD = RECORD CASE WORDFORMAT OF 
     1 : (I : INTEGER); 
     2 : (R : REAL);
     3 : (A : ALFA);
     4 : (B : BOOLEAN); 
     5 : (C : CHAR);
     6 : (P : PWORD); 
     7 : (BIT : PACKED ARRAY[-59..0] OF BOOLEAN); 
     8 : (BYTE : PACKED ARRAY[0..4] OF BYTEFIELD);
     9 : (PARCEL : PACKED ARRAY[0..3] OF PARCELFIELD);
    10 : (ADDRESS : PACKED RECORD 
           PAD    : 0..77B; 
           UPPER  : ADDRESSFIELD; 
           MIDDLE : ADDRESSFIELD; 
           LOWER  : ADDRESSFIELD
           END);
    11 : (HALF : PACKED RECORD
           OP   : OPCODE; 
           I    : REGISTER; 
           J    : REGISTER; 
           K    : ADDRESSFIELD
           END);
    12 : (QUARTER : PACKED RECORD 
           OP   : OPCODE; 
           I    : REGISTER; 
           J    : REGISTER; 
           K    : REGISTER
           END);
    13 : (DESCRIPTOR : PACKED RECORD
           P      : BOOLEAN;
           S      : BOOLEAN;
           F      : BOOLEAN;
           PAD    : 0..77B; 
           COUNT  : 0..77B; 
           ENTRY  : PARCELFIELD;
           CONSTS : PARCELFIELD;
           PMDINF : PARCELFIELD 
           END);
    14 : (INFO : PACKED RECORD
           PAD   : 0..7777777777B;
           VTYPE : BYTEFIELD; 
           VADDR : ADDRESSFIELD 
           END) 
    END;
  
   MEMORYARRAY = ARRAY[ADDRESSFIELD] OF WORD; 
   MESS = ARRAY[1..9] OF WORD;
  
  
  
  
  
  
  
(* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *) 
  
  
  
  
(* --- UTILITY ROUTINES FOR PASCLIB --- *)
  
  
  
(*        BPV - CHECK FOR BAD POINTER VALUE.
 *
 *        PARAM  P - POINTER TO CHECK.
 *) 
  
 FUNCTION (*$E'P.BPV'*) BPV(P : PWORD) : BOOLEAN; EXTERN; 
  
  
  
  
(*        DOUBLE PRECISION ROUTINES.
 *
 *        DADD - DOUBLE PRECISION ADD.
 *        DMUL - DOUBLE PRECISION MULTIPLY. 
 *        DDIV - DOUBLE PRECISION DIVIDE. 
 *
 *        PARAM  R - RESULT.
 *               A - LEFT OPERAND.
 *               B - RIGHT OPERAND. 
 *) 
  
 PROCEDURE (*$E'P.DADD'*) DADD(VAR R:DOUBLE; A,B:DOUBLE); EXTERN; 
 PROCEDURE (*$E'P.DMUL'*) DMUL(VAR R:DOUBLE; A,B:DOUBLE); EXTERN; 
 PROCEDURE (*$E'P.DDIV'*) DDIV(VAR R:DOUBLE; A,B:DOUBLE); EXTERN; 
  
  
  
  
(*        IOE - ISSUE AN INPUT/OUTPUT ERROR.
 *
 *        PARAM  F - FILE WITH THE ERROR. 
 *               N - ERROR NUMBER (SEE COMSPAS).
 *) 
  
 PROCEDURE (*$E'P.IOE'*) IOE( VAR F : TEXT; N : INTEGER ); EXTERN;
  
  
  
  
(*        WRITEOCT - WRITE INTEGER IN OCTAL.
 *
 *        PARAM  F - TEXTFILE RECEIVING OUTPUT. 
 *               I - THE INTEGER. 
 *               W - THE FIELDWIDTH FOR THE INTEGER.
 *) 
  
(*$X0 PASS NO PARAMETERS IN X-REGS. *)
 PROCEDURE (*$E'P.WRO'*) WRITEOCT(VAR F: TEXT; I,W: INTEGER); EXTERN; 
(*$X= RESUME OLD X-OPTION. *) 
  
  
  
  
(*        TEN - RETURN POWER OF TEN.
 *
 *        RETURN AN INTEGER POWER OF TEN, IN THE RANGE 1..321.
 *
 *        PARAM  R - RESULT.
 *               X - POWER OF TEN.
 *) 
  
PROCEDURE (*$E'P.TEN'*) TEN(VAR R: DOUBLE; X: POSINT);
VAR T1,T2: DOUBLE;
BEGIN (* TEN *) 
 T1.UPPER := 1; T1.LOWER := 0.0;
 T2.UPPER := 10; T2.LOWER := 0.0; 
 REPEAT 
  IF ODD(X) THEN DMUL(T1,T1,T2);
  X := X DIV 2; 
  IF X <> 0 THEN DMUL(T2,T2,T2) 
 UNTIL X = 0; 
 R := T1
END (* TEN *);
  
  
  
  
(*        RND - ROUND NUMBER AFTER SCALING. 
 *
 *        PARAM  X - NUMBER TO ROUND. 
 *               DIGIT - DIGIT POSITION TO ROUND. 
 *               EXP - EXPONENT (SCALE FACTOR) IF RESCALING REQUIRED. 
 *) 
  
PROCEDURE (*$E'P.RND'*) RND(VAR X: DOUBLE; DIGIT: INTEGER;
                            VAR EXP: EXPINT); 
VAR T,S: DOUBLE;
BEGIN (* RND *) 
 IF DIGIT IN [0..28] THEN 
  BEGIN T.UPPER := 5; T.LOWER := 0.0; 
   TEN(S,DIGIT);
   DDIV(T,T,S); 
   DADD(X,X,T)
  END;
 IF X.UPPER >= 10.0 THEN
  BEGIN T.UPPER := 10; T.LOWER := 0.0;
   DDIV(X,X,T); 
   EXP := EXP + 1 
  END 
END (* RND *);
  
  
  
  
(*        SCL - SCALE NUMBER AND DETERMINE SIGN.
 *
 *        DETERMINE THE SIGN OF X, AND SCALE IT INTO THE RANGE
 *             1.0 <= X < 10.0. 
 *
 *        PARAM  X - NUMBER TO BE SCALED. 
 *               SIGN - SIGN (' ' OR '-') OF X. 
 *               EXP - EXPONENT (SCALE FACTOR) OF X.
 *) 
  
PROCEDURE (*$E'P.SCL'*) SCL(VAR X: DOUBLE; VAR SIGN: CHAR;
                            VAR EXP: EXPINT); 
VAR T,S: DOUBLE;
    EXP2: INTEGER;
BEGIN (* SCL *) 
 IF X.UPPER < 0 THEN
  BEGIN SIGN := '-'; X.UPPER := -X.UPPER; X.LOWER := -X.LOWER END 
 ELSE SIGN := ' ';
 EXP2 := EXPO(X.UPPER); 
 IF EXP2 >= 0 THEN
  BEGIN EXP := EXP2 * 77 DIV 256; 
   TEN(T,EXP);
   DDIV(S,X,T); 
   IF S.UPPER >= 10.0 THEN
    BEGIN EXP := EXP + 1; 
     TEN(T,EXP);
     DDIV(S,X,T)
    END 
  END 
 ELSE 
  BEGIN EXP := (EXP2 + 1) * 77 DIV 256 - 1; 
   TEN(T,-EXP); 
   DMUL(S,T,X); 
   IF S.UPPER < 1.0 THEN
    BEGIN EXP := EXP - 1; 
     TEN(T,-EXP); 
     DMUL(S,T,X)
    END 
  END;
 X := S 
END (* SCL *);
  
  
  
  
(* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *) 
  
  
  
  
(* --- INPUT/OUTPUT ROUTINES --- *) 
  
  
  
  
(*$X0 NO PARAMETERS PASSED IN X-REGS *) 
  
  
  
  
(* --- RDI - READ INTEGERS IN FREE FORMAT. --- *) 
(*     J. STRAIT.  78/10/17.                   *) 
  
FUNCTION (*$E'P.RDI'*) RDI(VAR F: TEXT): INTEGER; 
(* READ INTEGER NUMBER IN FREE FORMAT *)
VAR S: BOOLEAN; 
    T,UPPER,LOWER: INTEGER; 
    CH: CHAR; 
BEGIN (* RDI *) 
 WHILE (F^ = ' ') AND NOT EOF(F) DO GET(F); 
 IF NOT EOF(F) THEN 
  BEGIN CH := F^; 
   IF CH IN ['-','+'] THEN
    BEGIN S := CH = '-'; GET(F); CH := F^ END 
   ELSE S := FALSE; 
   UPPER := 0; LOWER := 0;
   IF NOT (CH IN ['0'..'9']) THEN IOE(F,IOEE);
   REPEAT LOWER := LOWER * 10 + ORD(CH) - ORD('0'); 
    T := LOWER DIV T30; 
    LOWER := LOWER - T * T30; 
    IF UPPER < T30 THEN UPPER := UPPER * 10 + T;
    GET(F); CH := F^
   UNTIL NOT (CH IN ['0'..'9']);
   IF UPPER >= T29 THEN IOE(F,IOEF);
   T := UPPER * T30 + LOWER;
   IF S THEN RDI := -T ELSE RDI := T
  END 
 ELSE IOE(F,IOEB) 
END (* RDI *);
  
  
  
  
(* --- RDR - READ REAL NUMBERS IN FREE FORMAT. --- *) 
(*     N. WIRTH / K. JENSEN / J. P. STRAIT.        *) 
  
FUNCTION (*$E'P.RDR'*) RDR(VAR F: TEXT): REAL;
(* READ REAL NUMBERS IN FREE FORMAT *)
CONST LIM1 = 322;     (* MAXIMUM EXPONENT *)
      LIM2 = -292;    (* MINIMUM EXPONENT *)
VAR CH: CHAR; 
    C,E,I,DCOUNT,ECOUNT,UPPER,LOWER: INTEGER; 
    T1,T2,T3: DOUBLE; 
    S,SS: BOOLEAN;   (* SIGNS *)
BEGIN (* RDR *) 
 (* SKIP LEADING BLANKS *)
 WHILE (F^ = ' ') AND NOT EOF(F) DO GET(F); 
 IF NOT EOF(F) THEN 
  BEGIN CH := F^; 
   IF CH IN ['+','-'] THEN
    BEGIN S := CH = '-'; GET(F); CH := F^ END 
   ELSE S := FALSE; 
   IF NOT (CH IN ['0'..'9']) THEN IOE(F,IOEE);
   E := 0;
   DCOUNT := 0; UPPER := 0; LOWER := 0; 
   REPEAT C := ORD(CH) - ORD('0');
    IF DCOUNT < 28 THEN 
     BEGIN
      IF DCOUNT < 14 THEN UPPER := UPPER * 10 + C 
      ELSE LOWER := LOWER * 10 + C; 
      IF (C <> 0) OR (DCOUNT <> 0) THEN DCOUNT := DCOUNT + 1
     END
    ELSE E := E + 1;
    GET(F); CH := F^
   UNTIL NOT (CH IN ['0'..'9']);
   IF CH = '.' THEN (* READ FRACTION *) 
    BEGIN GET(F); CH := F^; 
     WHILE CH IN ['0'..'9'] DO
      BEGIN C := ORD(CH) - ORD('0');
       IF DCOUNT < 28 THEN
        BEGIN E := E - 1; 
         IF DCOUNT < 14 THEN UPPER := UPPER * 10 + C
         ELSE LOWER := LOWER * 10 + C;
         IF (C <> 0) OR (DCOUNT <> 0) THEN DCOUNT := DCOUNT + 1 
        END;
       GET(F); CH := F^ 
      END 
    END;
   IF CH = 'E' THEN (* READ SCALE FACTOR *) 
    BEGIN GET(F); CH := F^; 
     IF CH IN ['+','-'] THEN
      BEGIN SS := CH = '-'; GET(F); CH := F^ END
     ELSE SS := FALSE;
     I := 0; ECOUNT := 0; 
     IF CH IN ['0'..'9'] THEN 
      REPEAT C := ORD(CH) - ORD('0'); 
       IF ECOUNT < 14 THEN
        BEGIN I := I * 10 + C;
         IF (C <> 0) OR (ECOUNT <> 0) THEN ECOUNT := ECOUNT + 1 
        END;
       GET(F); CH := F^ 
      UNTIL NOT (CH IN ['0'..'9'])
     ELSE IOE(F,IOEE);
     IF SS THEN E := E - I ELSE E := E + I
    END;
   T1.UPPER := UPPER; T1.LOWER := 0.0;
   IF DCOUNT > 14 THEN
    BEGIN T2.UPPER := LOWER; T2.LOWER := 0.0; 
     TEN(T3,DCOUNT - 14); 
     DMUL(T1,T3,T1);
     DADD(T1,T1,T2) 
    END;
   I := E + DCOUNT; 
   IF I < LIM2 THEN 
    BEGIN T1.UPPER := 0.0; T1.LOWER := 0.0; E := 0 END
   ELSE 
    IF I > LIM1 THEN IOE(F,IOEF); 
   IF S THEN BEGIN T1.UPPER := -T1.UPPER; T1.LOWER := -T1.LOWER END;
   TEN(T2,ABS(E));
   IF E < 0 THEN DDIV(T1,T1,T2) 
   ELSE 
    IF E <> 0 THEN DMUL(T1,T1,T2);
   RDR := T1.UPPER + T1.LOWER 
  END 
 ELSE IOE(F,IOEB) 
END (* RDR *);
  
  
  
  
(* --- WRB - WRITE BOOLEANS. --- *) 
(*     J. P. STRAIT.  78/10/17.  *) 
  
PROCEDURE (*$E'P.WRB'*) WRB(VAR F: TEXT; B,N: INTEGER); 
BEGIN (* WRB *) 
 IF B = 0 THEN WRITE(F, 'FALSE':N)
 ELSE 
  IF B = 1 THEN WRITE(F, 'TRUE':N)
  ELSE IOE(F,IOEH)
END (* WRB *);
  
  
  
  
(* --- WRC - WRITE CHARACTERS. --- *) 
(*     K. JENSEN.                  *) 
  
PROCEDURE (*$E'P.WRC'*) WRC(VAR F: TEXT; CH: CHAR; N: INTEGER); 
BEGIN (* WRC *) 
 WHILE N > 1 DO BEGIN N := N - 1; WRITE(F, ' ') END;
 WRITE(F, CH) 
END (* WRC *);
  
PROCEDURE (*$E'P.WRCD'*) WRCD(VAR F: TEXT; CH: CHAR; N: INTEGER); 
BEGIN 
 IF (ORD(CH) < 0) OR (ORD(CH) > 63) THEN IOE(F,IOEH)
 ELSE 
  BEGIN 
   WHILE N > 1 DO BEGIN N := N - 1; WRITE(F, ' ') END;
   WRITE(F, CH) 
  END 
END (* WRCD *); 
  
  
  
  
(* --- WRE - WRITE REAL NUMBER IN EXPONENTIAL FORM. --- *)
(*     N. WIRTH / K. JENSEN / J. P. STRAIT.             *)
  
PROCEDURE (*$E'P.WRE'*) WRE(VAR F:TEXT; X: REAL; N: INTEGER); 
(* WRITE REAL NUMBER X IN N CHARACTERS *) 
VAR E0,E1,E2,I: INTEGER;
    E: EXPINT;
    SIGN: CHAR; 
    DX: DOUBLE; 
    UPPER, LOWER: PACKED RECORD CASE BOOLEAN OF 
              FALSE: (I: INTEGER);
               TRUE: (D: 0..7777B;
                      F: 0..7777777777777777B)
                 END; 
BEGIN (* WRE *) 
 (* AT LEAST 10 CHARACTERS NEEDED: B+9.9E+999 *)
 IF N < 10 THEN N := 2 ELSE N := N - 8; (* TOTAL NUMBER OF DIGITS *)
 IF UNDEFINED(X) THEN IOE(F,IOEH) 
 ELSE 
  IF X = 0 THEN 
   BEGIN WRITE(F, '  0.');
    FOR I := 2 TO N DO WRITE(F, '0'); 
    WRITE(F, 'E+000') 
   END
  ELSE
   BEGIN
    DX.UPPER := X; DX.LOWER := 0.0; 
    SCL(DX,SIGN,E); 
    RND(DX,N,E);
    UPPER.I := TRUNC(DX.UPPER,48);
    LOWER.I := TRUNC(DX.LOWER,96);
    WRITE(F, ' ', SIGN);
    FOR I := 1 TO N DO
     BEGIN UPPER.I := UPPER.I + LOWER.D;
      WRITE(F, CHR(UPPER.D + ORD('0')));
      UPPER.I := UPPER.F * 10;
      LOWER.I := LOWER.F * 10;
      IF I = 1 THEN WRITE(F, '.') 
     END; 
    WRITE(F, 'E');
    IF E < 0 THEN 
     BEGIN WRITE(F, '-'); E := -E END 
    ELSE WRITE(F, '+'); 
    E1 := E * 205 DIV 2048; 
    E2 := E - 10 * E1;
    E0 := E1 * 205 DIV 2048;
    E1 := E1 - 10 * E0; 
    WRITE(F, CHR(E0 + ORD('0')),
             CHR(E1 + ORD('0')),
             CHR(E2 + ORD('0')))
   END
END (* WRE *);
  
  
  
  
(* --- WRF - WRITE REAL NUMBERS IN FIXED POINT FORMAT. --- *) 
(*     N. WIRTH / K. JENSEN / J. P. STRAIT.                *) 
  
PROCEDURE (*$E'P.WRF'*) WRF(VAR F: TEXT; X: REAL; M,N: INTEGER);
(* WRITE REAL NUMBER X IN M CHARACTERS, N AFTER THE DECIMAL POINT *)
VAR K2,K3,I: INTEGER; 
    E: EXPINT;
    SIGN: CHAR; 
    DX: DOUBLE; 
    UPPER, LOWER: PACKED RECORD CASE BOOLEAN OF 
              FALSE: (I: INTEGER);
               TRUE: (D: 0..7777B;
                      F: 0..7777777777777777B)
                 END; 
BEGIN (* WRF *) 
 IF UNDEFINED(X) THEN IOE(F,IOEH) 
 ELSE 
  BEGIN DX.UPPER := X; DX.LOWER := 0.0; 
   IF N < 1 THEN N := 1;
   SCL(DX,SIGN,E);
   E := E + 1;
   RND(DX,N + E,E); 
   IF N + E <= 0 THEN (* NUMBER WILL PRINT AS 0.0 *)
    BEGIN I := M - N; 
     IF I < 2 THEN I := 2;
     WRITE(F, '0.':I);
     REPEAT WRITE(F, '0'); N := N - 1 UNTIL N = 0 
    END 
   ELSE 
    BEGIN (* CALCULATE CHARACTER COUNTS: *) 
     IF E > 0 THEN
      BEGIN M := M - N - E - 1; K2 := E; K3 := 0 END
     ELSE 
      BEGIN M := M - N - 2; K2 := 0; K3 := -E; N := N - K3 END; 
     (* M-1 BLANKS, SIGN, K2 DIGITS, '.', K3 ZEROS, N DIGITS *) 
     WHILE M > 1 DO BEGIN M := M - 1; WRITE(F, ' ') END;
     IF (SIGN = '-') OR (M = 1) THEN WRITE(F, SIGN);
     UPPER.I := TRUNC(DX.UPPER,48); 
     LOWER.I := TRUNC(DX.LOWER,96); 
     IF K2 = 0 THEN WRITE(F, '0') 
     ELSE 
      REPEAT UPPER.I := UPPER.I + LOWER.D;
       WRITE(F, CHR(UPPER.D + ORD('0'))); 
       UPPER.I := UPPER.F * 10; 
       LOWER.I := LOWER.F * 10; 
       K2 := K2 - 1 
      UNTIL K2 = 0; 
     WRITE(F, '.'); 
     WHILE K3 <> 0 DO BEGIN K3 := K3 - 1; WRITE(F, '0') END;
     WHILE N <> 0 DO
      BEGIN N := N - 1; 
       UPPER.I := UPPER.I + LOWER.D;
       WRITE(F, CHR(UPPER.D + ORD('0'))); 
       UPPER.I := UPPER.F * 10; 
       LOWER.I := LOWER.F * 10
      END 
    END 
  END 
END (* WRF *);
  
  
  
  
(* --- WRI - WRITE INTEGERS. --- *) 
(*     J. P. STRAIT.  78/10/17.  *) 
  
PROCEDURE (*$E'P.WRI'*) WRI(VAR F: TEXT; N,W: INTEGER); 
(* WRITE INTEGER NUMBER N IN W CHARACTERS *)
VAR UPPER,LOWER,I,T1,T2: INTEGER; 
    D: ARRAY[1..20] OF CHAR;
    S: BOOLEAN; 
BEGIN (* WRI *) 
 IF N >= 0 THEN S := FALSE
 ELSE BEGIN S := TRUE; N := -N END; 
 UPPER := N DIV T30; LOWER := N - UPPER * T30;
 I := 0;
 REPEAT I := I + 1; 
  T1 := UPPER DIV 10; 
  T2 := UPPER - T1 * 10;
  UPPER := T1;
  T1 := LOWER + T2 * T30; 
  T2 := T1 DIV 10;
  D[I] := CHR(T1 - T2 * 10 + ORD('0')); 
  LOWER := T2 
 UNTIL UPPER + LOWER = 0; 
 IF S THEN BEGIN I := I + 1; D[I] := '-' END; 
 WHILE W > I DO BEGIN W := W - 1; WRITE(F, ' ') END;
 REPEAT WRITE(F, D[I]); I := I - 1 UNTIL I <= 0 
END (* WRI *);
  
  
  
  
(*$X= RESUME OLD X-OPTION *)
(* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *) 
  
  
  
  
(*        PASCPMD - PASCAL POST-MORTEM DUMP.
 *        J. P. STRAIT       77/11/29.
 *        BASED ON THE ORIGINAL VERSION BY
 *        H.SANDMAYR        CIRCA JUNE 1974.
 *) 
  
(*$X0 NO PARAMETERS PASSED IN X-REGS *) 
  
PROCEDURE (*$E'P.PMD'*) PASCPMD(
 VAR MEMORY   : MEMORYARRAY; (* ARRAY BASED AT ADDRESS ZERO *)
     MAIN        : INTEGER;  (* MAIN PROGRAM ENTRY POINT ADDRESS *) 
     LINE        : INTEGER;  (* LINE NUMBER WHERE ERROR OCCURRED *) 
     MVAR        : INTEGER;  (* ADDRESS OF MAIN ACTIVATION RECORD *)
     STACKP      : INTEGER;  (* STACK POINTER OF CURRENT PROCEDURE *) 
 VAR F           : TEXT;     (* FILE TO RECEIVE THE POST-MORTEM DUMP *) 
 VAR MSG         : MESS;     (* ERROR MESSAGE WITH ZERO BYTE *) 
     ABORT       : BOOLEAN;  (* ABNORMAL TERMINATION FLAG *)
     NLEVELS     : INTEGER   (* NUMBER OF LEVELS TO DUMP *) 
                 ); 
  
CONST SABPKI     = 51B;      (* SAI BJ+K INSTRUCTION *) 
      PARCELSHIFT= 100000B;  (* ENOUGH TO SHIFT 15 BITS *)
      MAXCOUNT   = 3;        (* MAX NUMBER OF ACTIVATIONS TO LIST *)
      MAXCWORD   = 'THREE';  (* MAXCOUNT IN ENGLISH *)
  
VAR ENTRYP       : INTEGER;  (* CURRENT ENTRY POINT ADDRESS *)
    MODULE       : ALFA;     (* TYPE OF MODULE: PROC/FUNC/PROG *) 
    MLENGTH      : INTEGER;  (* LENGTH OF MODULE TYPE *)
    NAME         : ALFA;     (* NAME OF CURRENT PROCEDURE *)
    NLENGTH      : INTEGER;  (* LENGTH OF NAME *) 
    OLDNAME      : ALFA;     (* NAME OF PREVIOUS PROCEDURE *) 
    OLDNLENGTH   : INTEGER;  (* LENGTH OF OLDNAME *)
    VARNAME      : ALFA;     (* NAME OF CURRENT VARIABLE *) 
    VLENGTH      : INTEGER;  (* LENGTH OF VARNAME *)
    HALFWORDOPS  : SET OF 0..58;  (* OP CODES FOR HALF WORD INSTS. *) 
    OPCODE       : INTEGER;  (* OP CODE IN CALLWORD OR LINEWORD *)
    RETURN       : INTEGER;  (* RETURN ADDRESS *) 
    EXECADDR     : INTEGER;  (* FOR TRACING LINE NUMBERS *) 
    LINEWORD     : WORD;     (* WORD WITH SA0 B0+LINE *)
    INFOP        : INTEGER;  (* PMD INFO POINTER *) 
    VARTYPE      : INTEGER;  (* VARIABLE-S TYPE (IN PMD INFO) *)
    VARADDR      : INTEGER;  (* VARIABLE-S ADDRESS (IN PMD INFO) *) 
    PMDON        : BOOLEAN;  (* CURRENT -P- OPTION *) 
    RIGHT        : BOOLEAN;  (* LEFT/RIGHT COLUMN FLAG *) 
    LISTCOUNT    : INTEGER;  (* COUNT FROM DESCRIPTOR *)
    FIRSTPROC    : BOOLEAN;  (* FIRST PROCEDURE LISTED *) 
    I            : INTEGER;  (* LOOP INDEX *) 
    BLANKS       : INTEGER;  (* BLANK COUNTER *)
BEGIN (* PASCPMD *) 
HALFWORDOPS := [0..7,50B,51B,52B,60B,61B,62B,70B,71B,72B];
FIRSTPROC := TRUE;
OLDNLENGTH := 7;
REPEAT IF NOT FIRSTPROC 
  THEN BEGIN STACKP := MEMORY[STACKP+1].HALF.K; 
   EXECADDR := RETURN;
   OLDNAME := NAME; 
   OLDNLENGTH := NLENGTH
   END; 
 IF STACKP <> MVAR
  THEN BEGIN RETURN := MEMORY[STACKP+1].ADDRESS.LOWER;
   ENTRYP := MEMORY[STACKP].HALF.K - 2; 
   IF MEMORY[ENTRYP-1].DESCRIPTOR.F 
    THEN BEGIN MODULE := 'FUNCTION  '; MLENGTH := 8 END 
    ELSE BEGIN MODULE := 'PROCEDURE '; MLENGTH := 9 END 
   END
  ELSE BEGIN ENTRYP := MAIN;
   MODULE := 'PROGRAM   '; MLENGTH := 7 
   END; 
 PMDON := MEMORY[ENTRYP-1].DESCRIPTOR.P;
 NAME := MEMORY[ENTRYP-2].A;
 NLENGTH := 11; 
 REPEAT NLENGTH := NLENGTH - 1 UNTIL NAME[NLENGTH] <> ' ';
 IF FIRSTPROC 
  THEN BEGIN FIRSTPROC := FALSE;
   WRITELN(F); WRITELN(F);
   IF ABORT 
    THEN WRITE(F, ' PROGRAM TERMINATED')
    ELSE WRITE(F, ' SNAPSHOT DUMP');
   IF PMDON THEN WRITE(F, ' AT LINE ', LINE:1); 
   WRITELN(F, ' IN ', MODULE:MLENGTH, ' ', NAME:NLENGTH, '.');
   I := 0;
   REPEAT I := I + 1; 
    WRITE(F, MSG[I].A)
   UNTIL MSG[I].BYTE[4] = 0 
   END
  ELSE IF (MEMORY[ENTRYP-1].DESCRIPTOR.COUNT < MAXCOUNT) OR 
          (LISTCOUNT < MAXCOUNT)
    THEN BEGIN WRITE(F, ' ', OLDNAME:OLDNLENGTH, ' WAS CALLED');
     IF PMDON (* FIND LINE NUMBER OF CALL *)
      THEN BEGIN
       REPEAT EXECADDR := EXECADDR - 1; 
        LINEWORD := MEMORY[EXECADDR]; 
        OPCODE := LINEWORD.HALF.OP; 
        WHILE NOT (OPCODE IN [0,SABPKI]) OR (LINEWORD.HALF.I <> 0) DO 
         BEGIN LINEWORD.HALF.OP := 0; 
         LINEWORD.HALF.I := 0;
         LINEWORD.I := LINEWORD.I * PARCELSHIFT;
         IF OPCODE IN HALFWORDOPS 
          THEN LINEWORD.I := LINEWORD.I * PARCELSHIFT;
         OPCODE := LINEWORD.HALF.OP 
         END
       UNTIL OPCODE <> 0; 
       WRITE(F, ' FROM LINE ', LINEWORD.HALF.K:1) 
       END; 
     WRITELN(F, ' IN ', MODULE:MLENGTH, ' ', NAME:NLENGTH, '.') 
     END; 
 WITH MEMORY[ENTRYP-1].DESCRIPTOR DO
  BEGIN IF ABORT
   THEN BEGIN LISTCOUNT := COUNT; 
    IF LISTCOUNT <= MAXCOUNT THEN COUNT := LISTCOUNT + 1
    END 
   ELSE LISTCOUNT := 0; 
  INFOP := ENTRYP + (PMDINF - ENTRY)
  END;
 IF (LISTCOUNT < MAXCOUNT) AND (NLEVELS <> 0) 
  THEN BEGIN NLEVELS := NLEVELS - 1;
    IF PMDON AND (MEMORY[INFOP].I <> 0) 
    THEN BEGIN WRITELN(F);
     WRITELN(F, '  ':30-NLENGTH DIV 2, '---  ', NAME:NLENGTH, '  ---'); 
     RIGHT := FALSE;
     REPEAT VARNAME := MEMORY[INFOP].A; 
      VLENGTH := 11;
      REPEAT VLENGTH := VLENGTH - 1 UNTIL VARNAME[VLENGTH] <> ' ';
      WRITE(F, '  ':11 - VLENGTH, VARNAME:VLENGTH,' =');
      WITH MEMORY[INFOP+1].INFO DO
       BEGIN VARTYPE := VTYPE;
       VARADDR := STACKP + VADDR
       END; 
      IF ODD(VARTYPE) THEN VARADDR := MEMORY[VARADDR].I;
      VARTYPE := VARTYPE DIV 2; 
      BLANKS := 0;
      WITH MEMORY[VARADDR] DO 
       CASE VARTYPE OF
        PMDREAL : IF UNDEFINED(R) 
                   THEN BEGIN WRITE(F, 'UNDEF':11); 
                    BLANKS :=  11 
                    END 
                   ELSE WRITE(F, R:22); 
        PMDINT, 
        PMDSCAL : IF ABS(I) > MAXINT
                   THEN BEGIN WRITE(F, 'UNDEF':11); 
                    BLANKS := 11
                    END 
                   ELSE IF ABS(I) < 1000000000
                    THEN BEGIN WRITE(F, I:11);
                     BLANKS := 11 
                     END
                    ELSE WRITE(F, I:22);
        PMDCHAR : IF ((ORD(C) > 00B) AND (ORD(C) <= 77B)) OR
                     (ORD(C) = ORD(':'))
                   THEN WRITE(F, '  ':10, C)
                   ELSE WRITE(F, 'UNDEF':11); 
        PMDBOOL : IF ORD(B) IN [0,1] THEN WRITE(F, B:11)
                  ELSE WRITE(F, 'UNDEF':11);
        PMDALFA : WRITE(F, A:11); 
        PMDUPTR : IF P = NIL
                   THEN WRITE(F, 'NIL':11)
                   ELSE 
                    BEGIN WRITE(F,'  ':5);
                     WRITEOCT(F,ORD(P),6) 
                    END;
        PMDCPTR : IF P = NIL
                   THEN WRITE(F, 'NIL':11)
                   ELSE IF BPV(P) 
                    THEN WRITE(F, 'UNDEF':11) 
                   ELSE 
                    BEGIN WRITE(F,'  ':5);
                     WRITEOCT(F,ORD(P),6) 
                    END 
        END;
      IF RIGHT
       THEN WRITELN(F)
       ELSE BEGIN IF VARTYPE IN [PMDREAL,PMDINT,PMDSCAL]
         THEN BLANKS := BLANKS + 7
         ELSE BLANKS := BLANKS + 18;
        WRITE(F, '  ':BLANKS) 
        END;
      RIGHT := NOT RIGHT; 
      INFOP := INFOP + 2
     UNTIL MEMORY[INFOP].I = 0; 
     IF RIGHT THEN WRITELN(F);
     WRITELN(F) 
     END
   END
  ELSE IF LISTCOUNT = MAXCOUNT
   THEN BEGIN 
    WRITELN(F, '    BECAUSE OF RECURSION, MORE THAN ', MAXCWORD,
               ' COPIES OF ', NAME:NLENGTH);
    WRITELN(F, '    WERE ACTIVE, BUT ONLY ', MAXCWORD,
               ' HAVE BEEN LISTED.')
    END 
UNTIL (STACKP = MVAR) OR (NLEVELS = 0)
END (* PASCPMD *);
  
(*$X= RESUME OLD X-OPTION *)
  
  
  
  
(* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *) 
  
  
  
  
BEGIN (* PASCLIB *) END.
