!**FILE LAST CHANGED ON 05/12/77 AT 16.49.27
!**DELSTART
%SYSTEMINTEGERMAPSPEC COMREG(%INTEGER I)
%EXTRINSICINTEGER SSDEBUG
%SYSTEMROUTINESPEC CONSOLE(%INTEGER EP,R1,R2,%INTEGERNAME R3)
%EXTERNALROUTINESPEC PROMPT(%STRING(15)S)
%SYSTEMROUTINESPEC MDIAG(%INTEGER PCOUNT,FAULT,INF)
%SYSTEMROUTINESPEC CONNECT(%STRING (15) S,  %C
   %INTEGER ACCESS, MAXBYTES, PROTECTION, %RECORDNAME R,  %C
   %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC PSYSMES(%INTEGER ROOT, FLAG)
%SYSTEMROUTINESPEC SET OUTPUT(%STRING (15) FILE,  %C
   %INTEGERNAME ADDR, FLAG)
%SYSTEMROUTINESPEC FINDFD(%STRING (8) DD, %INTEGERNAME I)
%SYSTEMROUTINESPEC DIRCALL(%INTEGER EP, %STRING (17) S,  %C
   %INTEGER P1, P2, %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC SETLIB(%INTEGER EP, %STRING (15) S,  %C
   %INTEGER AD, %INTEGERNAME FLAG)
%SYSTEMINTEGERFNSPEC SPAR(%INTEGER N, %STRINGNAME S)
%SYSTEMROUTINESPEC SETPAR(%STRING (63) S)
%SYSTEMROUTINESPEC SVC(%RECORDNAME P)
%SYSTEMROUTINESPEC IOCP(%INTEGER I, J)
   %SYSTEMROUTINESPEC SYSFIL(%STRING (15) K, FILE,  %C
         %INTEGERNAME FLAG)
%SYSTEMROUTINESPEC SIGNAL(%INTEGER EP, PARM, EXTRA, %INTEGERNAME FLAG)
%RECORDFORMAT PF(%SHORTINTEGER DSNO,DACT,SSNO,SACT,%C
%INTEGER X,A,B,C,D,E)
%RECORDFORMAT RF(%INTEGER CONAD, SIZE,  %C
   %BYTEINTEGER RUP, EEP, MODE, CONS, ARCH,  %C
   %STRING (6) TRAN, %SHORTINTEGER FILETYPE, NUMIPERMS,  %C
   %INTEGER DATASTART, DATAEND, PLISTPTR)
%RECORDFORMAT PUBF(%INTEGER DIRDA,  %C
   %SHORTINTEGER CTCHDEV, SP2, %INTEGER SLOMBUF,  %C
   %SHORTINTEGER SP3, %STRING (8) TIME, DATE,  %C
   %INTEGER SINCEIPL, SP4, SP5, SP6, SP7,  %C
   %SHORTINTEGER SYSCHDEV, SP8, %INTEGER NUSERS, SLOMWORD,  %C
   %STRING (5) VERSION, %INTEGER PMIN, SP9, SPA, SPB, SPC, SPD)
%RECORDFORMAT FD(%INTEGER ADESC, %BYTEINTEGER DISP, FTYPE,  %C
   %STRING (8) SUBFILE, %STRING (15) S,  %C
%STRING (8) DD, %BYTEINTEGER NUM, SEQ, DEV, RECFM, DISP2, FL, LM,  %C
   RM, %SHORTINTEGER LRECL, BLKSIZE,  %C
   %INTEGER CRECNUM, ASVAR, A, AREC, REMOTE, MAX, MAXHOLE,  %C
   %INTEGER AFILE,CURSIZE,CUROUTP,CURINP)
!*
%ROUTINESPEC RECODE(%INTEGER START, FINISH, CA)
!**DELEND
%REALSLONG;       !NEEDED FOR RTOH AND HTOR
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
'0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F'

%SYSTEMROUTINE PHEX(%INTEGER I)
%SHORTROUTINE
%INTEGER J
%CYCLE J=ADDR(I),1,ADDR(I)+3
PRINTSYMBOL(HEX(BYTEINTEGER(J)>>4))
PRINTSYMBOL(HEX(BYTEINTEGER(J)&15))
%REPEAT
%END;                                   !OF PHEX

%SYSTEMROUTINE DUMP(%INTEGER START, FINISH)
%SHORTROUTINE

%INTEGER I, J, CNT, OUTTYPE,ABOVE
   OUTTYPE = COMREG(45)
   %RETURN %IF COMREG(28)&16 = 0 %AND OUTTYPE = 0
   NEWLINE
   %IF OUTTYPE = 0 %THEN CNT = 16 %ELSE %START
      CNT = 32
      %CYCLE I = 0,1,131
         PRINT SYMBOL('*')
      %REPEAT
   %FINISH
   START = START&X'00FFFFFC'
   FINISH = ((FINISH+4)&X'00FFFFFC')-1
   %RETURN %IF FINISH < START
ABOVE=0
->PRINTLINE;       !MUST PRINT FIRST LINE IN FULL
NEXTLINE:
->PRINTLINE %IF FINISH-START<CNT;     !MUST PRINT LAST LINE
%CYCLE I=START,4,START+CNT-4
->PRINTLINE %IF INTEGER(I)#INTEGER(I-CNT);!LINE DIFFERS -  SO MUST PRINT
%REPEAT
        !GOT HERE SO MUST BE ALL ZERO
%IF ABOVE=0 %START;       !FIRST LINE AS ABOVE IN THIS GROUP
ABOVE=1
SPACES(18+CNT)
PRINTSTRING('LINE(S) AS ABOVE')
NEWLINE
%FINISH
START=START+CNT
->NEXTLINE
PRINTLINE:
ABOVE=0
   PRINT SYMBOL('*')
   %CYCLE I = START,1,START+CNT-1
      J = BYTEINTEGER(I)
      %UNLESS 32 <= J <= 127 %THEN J = '_'
      PRINTSYMBOL(J)
   %REPEAT
   PRINTSTRING('*   (')
PHEX(START)
   PRINTSTRING(')   ')
   %CYCLE I = START,4,START+CNT-4
PHEX(INTEGER(I))
      SPACES(2)
   %REPEAT
   START = START+CNT
NEWLINE
   -> NEXTLINE %UNLESS START > FINISH
%END;                                   ! DUMP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%ROUTINE OUTPUTSTREAM(%STRING (63) S)
%SHORTROUTINE
%INTEGER I, J
   %IF S # '' %THEN %START
      SETOUTPUT(S,I,J)
      %IF J = 0 %THEN SELECTOUTPUT(82)
   %FINISH
%END;                                   !OF OUTPUTSTREAM
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%ROUTINE GET STRING(%STRINGNAME S)
%SHORTROUTINE
                                        !S CONSTRUCTED FROM NON-SPACE CHARS UP TO(BUT EXCLUDING)NEXT NL
%CONSTSTRING (1) NEWLINE = '
'
   S = '';                              !NULL STRING
%CONSTSTRING (1) SP = ' '
%STRING (1) T
2: READ ITEM(T)
   -> 1 %IF T = NEWLINE;  -> 2 %IF T = SP
   S = S.T
   -> 2
1: -> 2 %IF S = ''
%END;                                   ! GET STRING
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%ROUTINE GET NUM(%INTEGERNAME I)
%SHORTROUTINE
%INTEGER J, K, L, M, SIGN
%STRING (80) S
   SIGN = 1;                            !DEFAULT POSITIVE
   -> 3 %IF SPAR(0,S) = 0
1: GET STRING(S)
3:
   L = LENGTH(S)
   I = 0
   J = CHARNO(S,1)
   -> HEX %IF J = 'X'
   %CYCLE K = 1,1,L
      J = CHARNO(S,K)
      %IF J = '-' %AND K = 1 %THEN SIGN = -1 %AND -> REP
      -> 1 %UNLESS '0' <= J <= '9'
      I = 10*I+J&15
REP:
   %REPEAT
   I = SIGN*I
   -> END
HEX:

   %CYCLE K = 2,1,L
      J = CHARNO(S,K)
      %CYCLE M = 0,1,15
         -> 2 %IF HEX(M) = J
      %REPEAT
      -> 1
2:    I = (I<<4)!M
   %REPEAT
END:

   PROMPT(':')
%END;                                   ! GET NUM

%ROUTINE GET REAL(%LONGREALNAME R)
%SHORTROUTINE
%INTEGER SIGN, P, LEN
%STRING (80) S
%REAL FRAC
   R = 0
   SIGN = 1;                            !DEFAULT POSITIVE
   PROMPT('R=')
   %IF SPAR(0,S) # 0 %THEN GETSTRING(S);!NO PARAMETER SO READ
   LEN = LENGTH(S)
   P = 1
   %IF CHARNO(S,1) = '-' %THEN SIGN = -1 %AND P = 2
   %WHILE '9' >= CHARNO(S,P) >= '0' %CYCLE
      R = R*10+CHARNO(S,P)-'0'
      P = P+1
      %IF P > LEN %THEN -> EXIT
   %REPEAT
   %IF CHARNO(S,P) # '.' %THEN -> EXIT
   FRAC = 0.1
   P = P+1;                             !TO SKIP DECIMAL POINT
   %IF P > LEN %THEN -> EXIT
   %WHILE '9' >= CHARNO(S,P) >= '0' %CYCLE
      R = R+FRAC*(CHARNO(S,P)-'0')
      P = P+1
      %IF P > LEN %THEN -> EXIT
      FRAC = FRAC/10
   %REPEAT
EXIT:

   R = R*SIGN
%END;                                   !OF GET REAL
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%ROUTINE GET INT(%INTEGERNAME I)
%SHORTROUTINE
   PROMPT('N=')
   GET NUM(I)
%END;                                   !OF GET INT
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%ROUTINE GET HEX(%INTEGERNAME I)
%SHORTROUTINE
   PROMPT('X=')
   GET NUM(I)
%END;                                   !OF GET HEX
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

%ROUTINE CONDUMP(%INTEGER START, N)
%SHORTROUTINE
%INTEGER I
%CYCLE
 NEWLINE
   PRINT SYMBOL('(')
   PHEX(START)
   PRINTSTRING(')   ')
   %CYCLE I = 1,1,4
      PHEX(INTEGER(START))
      SPACE
      START = START+4;  N = N-1
      -> 2 %IF N = 0
   %REPEAT
   NEWLINE
%REPEAT
2: NEWLINE
%END;                                   !OF CONDUMP
%ROUTINE CHDUMP(%INTEGER START,N)
%SHORTROUTINE
%INTEGER I
%CYCLE I=START,1,START+(N*4)-1
%IF (START-I)&X'1F'=0 %START
NEWLINE
PRINTSYMBOL('(')
PHEX(I)
PRINTSTRING(')   ')
%FINISH
%IF 32<=BYTEINTEGER(I)<=127 %THEN PRINTSYMBOL(BYTEINTEGER(I))%ELSE SPACE
%REPEAT
NEWLINE
%END;       !OF CHDUMP

%EXTERNALROUTINE TTWIDTH(%STRING (63) S)
%SHORTROUTINE
%INTEGER I, J, K
%RECORD P(PF)
   SETPAR(S)
1: GETINT(I)
   -> 1 %UNLESS 0 < I < 161
   FINDFD('STREAM90',J)
   %IF J > 0 %THEN %START
      BYTEINTEGER(J+47) = I
      %IF COMREG(22) = 90 %THEN IOCP(12,X'10000'!I)
   %FINISH
%IF I>132 %THEN I=132;        !MAX MARGINS FOR OUTPUT
   FINDFD('STREAM91',J)
   %IF J > 0 %THEN %START
      BYTEINTEGER(J+47) = I
      %IF COMREG(23) = 91 %THEN IOCP(13,X'10000'!I)
   %FINISH
%END;                                   ! TTWIDTH
%ROUTINESPEC DIAGDUMP(%STRING (63) S)

%SYSTEMROUTINE HASHCOMMAND(%STRING (63) S, T)
%INTEGER I, J, AD
%CONSTINTEGER NUMHASH = 27
%RECORD R(RF)
%CONSTSTRING (8) %ARRAY C(0 : 27) =     %C
'DIAGDUMP',
'SNAP',
'HEX',
'DEC',
'PCOM',
'SCOM',
'SNAPCODE',
'SBYTE',
'SWORD',
'SSTRING',
'FDLIST',
'FD',
'BASE',
'CONNECT',
'SETSYS',
'LDATA',
   'PVM',
   'LISTSFI',
   '',
   '',
   'SNAPCH',
   'ALLTT',
   'CLEANTT',
   'NEWBASE',
   'SETBASE',
'RTOH',
'HTOR',
'PTF'

%SWITCH CSW(0 : 27)
   -> CHECK
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE OUTHEX(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I
      SETPAR(S)
      GET INT(I)
      PRINTSTRING('X=')
      PHEX(I);  NEWLINE
   %END;                                !OF OUTHEX
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE DEC(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I
      SETPAR(S)
      GET HEX(I)
      PRINTSTRING('N=')
      WRITE(I,1);  NEWLINE
   %END;                                !OF DEC
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE RTOH(%STRING (63) S)
   %SHORTROUTINE
   %LONGREAL R
      SETPAR(S)
      GET REAL(R)
      PRINTSTRING('X=')
      PHEX(INTEGER(ADDR(R)))
      PHEX(INTEGER(ADDR(R)+4))
NEWLINE
   %END;                                !OF RTOH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE HTOR(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I,J,CHAR,LEN
%LONGREAL R
%INTEGERNAME R1,R2;        !POINT TO TWO HALVES OF R
SETPAR(S)
R1==INTEGER(ADDR(R))
R2==INTEGER(ADDR(R)+4)
PROMPT('X=')
AGAIN:GETSTRING(S)%UNLESS SPAR(0,S)=0
LEN=LENGTH(S)
->AGAIN %UNLESS (LEN=9 %OR LEN=17)%AND CHARNO(S,1)='X'
%CYCLE I=2,1,9
CHAR=CHARNO(S,I)
%CYCLE J=0,1,15
%IF HEX(J)=CHAR%THEN ->FOUND1
%REPEAT
->AGAIN;       !NOT A HEX CHARACTER
FOUND1:R1=(R1<<4)!J
%REPEAT
%IF LEN=17 %START;       !DOUBLE LENGTH
%CYCLE I=10,1,17
CHAR=CHARNO(S,I)
%CYCLE J=0,1,15
%IF HEX(J)=CHAR %THEN ->FOUND2
%REPEAT
->AGAIN;      !NOT HEX CHARACTER
FOUND2:   R2=(R2<<4)!J
%REPEAT
%FINISHELSE R2=0
PRINTFL(R,LEN-2);   !EITHER 7 OR 15 PLACES
      NEWLINE
   %END;                                !OF HTOR
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE PCOM(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I
      SETPAR(S)
      GET INT(I)
      PRINTSTRING('COMREG(')
      WRITE(I,1);  PRINTSTRING(')=')
      I = COMREG(I);  PHEX(I);  NEWLINE
   %END;                                !OF PCOM
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE SCOM(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I, J
      SETPAR(S)
      GET INT(I)
      GET HEX(J)
      COMREG(I) = J
   %END;                                !   SCOM
%ROUTINE PTESTFLAG(%STRING(63)S)
%SHORTROUTINE
%INTEGER I
SETPAR(S)
GETINT(I)
PHEX(INTEGER(X'1780'+(I-1)*4))
NEWLINE
%END;            !OF PTESTFLAG
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE SNAP(%STRING (63) S,%INTEGER MODE)
   %SHORTROUTINE
!MODE=1 FOR SNAP MODE=2 FOR SNAPCH
   %INTEGER START, N, I
      SETPAR(S)
      GET HEX(START);  GET INT(N)
      START = START&X'00FFFFFC'
      I = SPAR(0,S)
      OUTPUTSTREAM(S)
%IF MODE=1 %THEN CONDUMP(START,N) %ELSE CHDUMP(START,N)
   %END;                                !OF SNAP

   %ROUTINE SNAPCODE(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER START, FINISH, N
      SETPAR(S)
      GETHEX(START)
      GETINT(N)
      START = START&X'00FFFFFC'
      FINISH = START+N<<2
      N = SPAR(0,S)
      OUTPUTSTREAM(S)
      RECODE(START,FINISH,START)
      NEWLINE
   %END;                                ! SNAPCODE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE SBYTE(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I, J
      SETPAR(S)
      GETHEX(I);  GET INT(J)
      BYTEINTEGER(I) = J
   %END;                                !  SBYTE

   %ROUTINE SWORD(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I, J
      SETPAR(S)
      GETHEX(I);  GETINT(J)
      %IF I&3 # 0 %THEN %START
         PRINTSTRING('
WORD ALLIGN IT!
')
         %RETURN
      %FINISH
      INTEGER(I) = J
   %END;                                ! SWORD

   %ROUTINE SSTRING(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I, J
      GETHEX(I)
      J = SPAR(0,S)
      STRING(I) = S
   %END;                                !  SSTRING
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE FDMAP(%INTEGER AFD)
   %SHORTROUTINE

      %ROUTINE B(%INTEGER I)
      %SHORTROUTINE
         WRITE(BYTEINTEGER(AFD+I+4),4);  NEWLINE
      %END;                             !OF B

      %ROUTINE ST(%INTEGER I)
      %SHORTROUTINE
         PRINTSTRING('  '.STRING(AFD+I+4).'
')
      %END;                             !OF  ST

      %ROUTINE P(%INTEGER I, J)
      %SHORTROUTINE
      %INTEGER K
         %CYCLE K = 1,1,J
            SPACES(2);  PHEX(INTEGER(AFD+I+4))
            I = I+4
         %REPEAT
         NEWLINE
      %END;                             !OF P
      PRINTSTRING('   LINK ');  P(-4,1)
      PRINTSTRING(' 0 ADESC');  P(0,1)
      PRINTSTRING(' 4 DISP ');  B(4)
      PRINTSTRING(' 5 FTYPE');  B(5)
      PRINTSTRING(' 6 VOL  ');  ST(6)
      PRINTSTRING('15 S    ');  ST(15)
      PRINTSTRING('31 DD   ');  ST(31)
      PRINTSTRING('40 NUM  ');  P(40,4)
      PRINTSTRING('56 ASVAR');  P(56,4)
      PRINTSTRING('72 MAX  ');  P(72,2)
      PRINTSTRING('80 AFILE');  P(80,4)
   %END;                                !  FDMAP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE FD(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER AFD
      SETPAR(S)
      GETHEX(AFD)
      FDMAP(AFD)
   %END;                                ! FD
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE FDLIST(%STRING (63) S)
   %SHORTROUTINE
   %INTEGER I
      FINDFD(S,I)
      %IF I <= 0 %THEN %START
         PRINTSTRING(S.' NOT DEFINED
')
         %RETURN
      %FINISH
      FDMAP(I-4)
   %END;                                ! FDLIST
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

   %ROUTINE CON(%STRING (63) S)
   %SHORTROUTINE
   %RECORD R(RF)
   %INTEGER I, J
      I = 0
      SETPAR(S)
2:    %RETURN %IF SPAR(0,S) # 0
      CONNECT(S,3,0,0,R,J)
      %IF J = 0 %THEN -> 1
      CONNECT(S,0,0,0,R,J)
      %IF J # 0 %THEN %START
         PRINTSTRING('CON FAILS')
         WRITE(J,2);  NEWLINE
      %FINISH %ELSE %START
1:       I = R_CONAD
         PRINTSTRING(S.' CONNECTED AT ')
         PHEX(I);  NEWLINE
      %FINISH
      -> 2
   %END;                                !  CON

   %ROUTINE SETSYS(%STRING (63) S)
   %SHORTROUTINE
   %STRING (15) T, U
   %INTEGER I, J
      %UNLESS S->T.(',').U %THEN T=S %AND U=''
      %IF T='' %THEN PRINTSTRING('PARAMS?
') %AND %RETURN
      SYSFIL(T,U,I)
      %IF I # 0 %THEN PRINTSTRING('INVALID KEY
')
   %END;                                !OF SETSYS
!*

   %ROUTINE STRSORT(%STRINGARRAYNAME X, %INTEGER A, B)
   %SHORTROUTINE
!   DERIVED FROM IMP MANUAL P 62.
   %INTEGER L, U, M
   %STRING (255) D
      %RETURN %IF A >= B
      L = A;  U = B
      D = X(U)
      -> FIND
UP:   L = L+1
      -> FOUND %IF L = U
FIND: -> UP %UNLESS X(L) >= D
      X(U) = X(L)
DOWN: U = U-1
      -> FOUND %IF L = U
      -> DOWN %UNLESS X(U) < D
      X(L) = X(U)
      -> UP
FOUND:X(U) = D
      STRSORT(X,A,L-1)
      STRSORT(X,U+1,B)
   %END;                                !OF STRSORT

   %ROUTINE PRINT SORTED LIST(%STRINGARRAYNAME A, %INTEGER K)
   %SHORTROUTINE
   %ROUTINESPEC CHECK LAST
   %STRING (8) LAST
   %INTEGER I, J, LASTCNT
      %RETURN %UNLESS K > 0
      STRSORT(A,1,K)
      LAST = ''
      LASTCNT = 1
      I = 0
      %CYCLE J = 1,1,K
         %IF A(J) = LAST %THEN %START
            LASTCNT = LASTCNT+1
         %FINISH %ELSE %START
            CHECKLAST
            LAST = A(J)
            PRINTSTRING(A(J))
            I = I+1
            %IF I = 8 %THEN %START
               NEWLINE
               I = 0
            %FINISH %ELSE SPACES(9-LENGTH(A(J)))
         %FINISH
      %REPEAT
      CHECK LAST
      NEWLINE
      %RETURN

      %ROUTINE CHECK LAST
      %SHORTROUTINE
         %UNLESS LASTCNT = 1 %THEN %START
            WRITE(LASTCNT,3)
            SPACES(5)
            I = I+1
            %IF I = 8 %THEN %START
               NEWLINE
               I = 0
            %FINISH
            LASTCNT = 1
         %FINISH
      %END;                             ! CHECK LAST
   %END;                                ! PRINT SORTED LIST

   %ROUTINE LDATA(%STRING (63) S)
   %SHORTROUTINE
   %ROUTINESPEC PCAP(%INTEGER N)
   %INTEGERARRAYFORMAT HEADF(0 : 11)
   %INTEGERARRAYNAME HEAD
   %STRING (8) %ARRAY T(1 : 1000)
   %INTEGER GBASE, LBASE
   %INTEGER I, J, K, L, M
   %STRING (63) TT
   %CONSTSTRING (15) %ARRAY CAP(1 : 5) =  'ENTRIES:',
         'XREFS:','DYNAMIC XREFS:','DATA ENTRIES:','DATA REFS:'
      SETPAR(S)
      %RETURN %IF SPAR(0,S) # 0;        ! NO PARAMS
      CONNECT(S,0,0,0,R,J)
      %IF J # 0 %THEN %START
         PRINTSTRING(S.' FAILS TO CONNECT
')
         %RETURN
      %FINISH
      I = R_CONAD
      %UNLESS INTEGER(I+12) > 16 %THEN %START
         PRINTSTRING(S.' NOT AN OBJECT FILE
')
         %RETURN
      %FINISH
      J = SPAR(0,TT)
      OUTPUTSTREAM(TT)
      PRINTSTRING('
FILE: '.S.'
')
      GBASE = I+INTEGER(I+8)
      LBASE = I+INTEGER(I+12)
      HEAD == ARRAY(LBASE,HEADF)
      M = 0
      J = HEAD(1)
      %WHILE J # 0 %CYCLE
         K = LBASE+J
         M = M+1
         T(M) = STRING(K+20)
         J = INTEGER(K)
      %REPEAT
      PCAP(1)
      M = 0
      %CYCLE L = 0,1,1
         J = HEAD(2+L)
         %WHILE J # 0 %CYCLE
            K = GBASE+J
            M = M+1
            T(M) = STRING(K+20)
            J = INTEGER(K)
         %REPEAT
         %IF HEAD(0) > 7 %THEN %START
            J = HEAD(7+L)
            %WHILE J # 0 %CYCLE
               K = LBASE+J
               M = M+1
               T(M) = STRING(K+12)
               J = INTEGER(K)
            %REPEAT
         %FINISH
         PCAP(2+L)
         M = 0
      %REPEAT
      I = LBASE
      %CYCLE L = 0,1,1
         J = HEAD(4+L)
         %WHILE J # 0 %CYCLE
            K = I+J
            M = M+1
            T(M) = STRING(K+20)
            J = INTEGER(K)
         %REPEAT
         %IF L = 0 %THEN %START
            PCAP(4)
            M = 0
         %FINISH
         I = GBASE
      %REPEAT
      %IF HEAD(0) > 7 %THEN %START
         J = HEAD(9)
         %WHILE J # 0 %CYCLE
            K = LBASE+J
            M = M+1
            T(M) = STRING(K+12)
            J = INTEGER(K)
         %REPEAT
      %FINISH
      PCAP(5)
      NEWLINE
      %RETURN

      %ROUTINE PCAP(%INTEGER N)
      %SHORTROUTINE
         %IF M = 0 %THEN %RETURN
         PRINTSTRING(CAP(N).'
')
         PRINT SORTED LIST(T,M)
      %END;                             ! PCAP
   %END;                                ! LDATA
!*
!*

   %ROUTINE LISTSFI
   %SHORTROUTINE
   %RECORD P(PF)
   %CONSTSTRING (15) %ARRAY STR(0 : 7) =  'USER NAME',%C
'BASE FILE','BASE GLA ','MODLIB   ','LOADLIB  ',
'BASELIB  ','SFI 6', 'SFI 7'
   %STRING (15) S
   %INTEGER I, FLAG
      %CYCLE I = 0,1,7
         P_DSNO = 160;  P_A = I;  SVC(P)
         FLAG = P_A
         %MONITORSTOP %IF FLAG # 0
         S = STRING(ADDR(P_B))
         %IF I = 7 %START
            PRINTSTRING(STR(I).': ')
            PHEX(INTEGER(ADDR(S)))
            PHEX(INTEGER(ADDR(S)+4))
            NEWLINE
            %EXIT
         %FINISH
         %IF I < 5 %OR LENGTH(S) # 0 %THEN %START
            PRINTSTRING(STR(I))
            PRINTSTRING(': ')
            PRINTSTRING(S)
            NEWLINE
         %FINISH
      %REPEAT
   %END;                                !OF LISTSFI
!*

   %ROUTINE PVM
   %SHORTROUTINE
   %INTEGER I, J, K, M
   %BYTEINTEGERARRAY RS(0 : 4480)
      %CYCLE I = 0,20,4480
         RS(I) = 0
      %REPEAT
      DIRCALL(174,'',ADDR(RS(0)),0,I)
%IF I#0 %THENRETURN
      I = 0
%WHILE  I<4460  %CYCLE
%IF RS(I)#0 %START
         J = I//20+32
         K = J&15
         J = J>>4
         %IF 0 <= J <= 9 %THEN PRINT SYMBOL(J+'0') %C
            %ELSE PRINT SYMBOL(J+'A'-10)
         %IF 0 <= K <= 9 %THEN PRINT SYMBOL(K+'0') %C
            %ELSE PRINT SYMBOL(K+'A'-10)
         M = 1
%WHILE STRING(ADDR(RS(I+20))) = STRING(ADDR(RS(I))) %CYCLE
            M = M+1
            I = I+20
%REPEAT
         WRITE(M,2)
         PRINT STRING('  '.STRING(ADDR(RS(I))).'
')
      %FINISH
      I = I+20
%REPEAT
   %END;                                ! PVM
!*
!++++++++++++++++++++++++++++++++++++++++++++++++++++
CHECK:

   LENGTH(S) = 8 %IF LENGTH(S) > 8
   %CYCLE I = 0,1,NUMHASH
      -> CSW(I) %IF C(I) = S
   %REPEAT
   PRINTSTRING('#'.S.' INVALID
')
1: %RETURN
CSW(0):

   DIAGDUMP(T);  -> 1
CSW(1):

   SNAP(T,1);  -> 1
CSW(2):

   OUTHEX(T);  -> 1
CSW(3):

   DEC(T);  -> 1
CSW(4):

   PCOM(T);  -> 1
CSW(5):

   SCOM(T);  -> 1
CSW(6):

   SNAPCODE(T);  -> 1
CSW(7):

   SBYTE(T);  -> 1
CSW(8):

   SWORD(T);  -> 1
CSW(9):

   SSTRING(T);  -> 1
CSW(10):

   FDLIST(T);  -> 1
CSW(11):

   FD(T);  -> 1
CSW(12):

   DIRCALL(161,'MANAGR.BASEFILE',1,0,I)
   PRINTSTRING('BASE FILE RESET TO MANAGR.BASEFILE
')
   SETLIB(0,'SS#LIB',0,I);              ! LOADLIB
   SETLIB(1,'SS#LIB',0,I)
   DIRCALL(161,'MANAGR.BASELIB',5,0,I); ! BASELIB
   -> 1
CSW(13):

   CON(T);  -> 1
CSW(14):

   SETSYS(T);  -> 1
CSW(15):

   LDATA(T);  -> 1
CSW(16):

   PVM;  -> 1
CSW(17):

   LISTSFI;  -> 1
CSW(18):

CSW(19):

   -> 1
CSW(20):SNAP(T,2);               !SNAPCH
   -> 1
CSW(21):

->1
CSW(22):

->1
CSW(23):

   DIRCALL(161,'MANAGR.NEWBASE',1,0,I)
   PRINTSTRING('BASEFILE SET TO MANAGR.NEWBASE
')
   DIRCALL(161,'MANAGR.NEWLIB',5,0,I)
   -> 1
CSW(24):                                ! SETBASE(FILENAME)
   %IF LENGTH(T) > 15 %THEN -> ERR
   CONNECT(T,0,0,0,R,J)
! CONNECT READ MODE
   %IF J # 0 %THEN %START
      PSYSMES(8,J);                     ! CONNECT FAILS
      %RETURN
   %FINISH
   %UNLESS R_FILETYPE = 1 %THEN %START
      PRINTSTRING(T.' IS NOT AN OBJECT FILE
')
      %RETURN
   %FINISH
   DIRCALL(161,T,1,0,I);                ! CHANGE BASEFILE IDENT
   %IF I = 0 %THEN PRINTSTRING('BASEFILE SET TO '.T.'
')
   %RETURN
ERR:

   PRINTSTRING('INVALID PARAM
')
   -> 1
CSW(25):

   RTOH(T);  -> 1
CSW(26):

   HTOR(T);  -> 1
CSW(27):                 !PRINT TEST FLAG
PTESTFLAG(T);        ->1
%END;                                   !  HASH COMMAND
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!MUST BE COMPILED WITH PARM(NOCHECK)

%ROUTINE DIAGDUMP(%STRING (63) FILE)
%SHORTROUTINE
%INTEGER LAST, POINT, HOLD
%INTEGER I, ADUMP, WT, PC, FLAG, AD
%STRING (15) STR
%INTEGERARRAY VMAP(0 : 1125)
%INTEGER VBASE
%INTEGERARRAY R(4 : 15)
%INTEGERARRAY REG(-2 : 15)
   FILE = '.LP' %IF FILE = ''
   AD = 0
   SETOUTPUT(FILE,AD,FLAG)
   %RETURN %IF FLAG # 0
   SELECT OUTPUT(82)
   I = ADDR(R(4))
   *L_1,I
   *STM_4,14,0(1)
   *LA_2,<ERROR>
   *ST_2,44(1)
   *MVI_44(1),8
   SIGNAL(0,I,0,FLAG);                  !STORE RECOVERY INFO
   %MONITORSTOP %IF FLAG # 0
   SIGNAL(4,0,0,FLAG);                  !REPEAT LAST SIGNAL
   %MONITORSTOP
ERROR:

   *ST_1,ADUMP
   *ST_2,WT
   PRINTSTRING('SIGNAL WEIGHT ');  WRITE(WT,1);  NEWLINES(2)
   %CYCLE I = -1,1,15
      REG(I) = INTEGER(ADUMP+8+4*I)
   %REPEAT
   PC = REG(-1)
   REG(-2) = PC-4096
   PRINTSTRING('PROGRAM COUNTER :')
   PHEX(PC)
   NEWLINES(2)
   PRINTSTRING('REGISTERS
')
   %CYCLE I = 0,1,15
      WRITE(I,2);  SPACES(2)
      PHEX(REG(I))
      NEWLINE
   %REPEAT
   %CYCLE I = -2,1,15
      REG(I) = REG(I)&X'FFFFE0'
   %REPEAT
   %CYCLE I = 0,1,1125;                 !CLEAR SPACE FOR PVM
      VMAP(I) = 0
   %REPEAT
   VBASE = ADDR(VMAP(0))
   DIRCALL(174,'',VBASE,0,FLAG);        !GET FILE NAMES
   %MONITORSTOP %IF FLAG # 0
   VBASE = VBASE-20*32
   STRING(VBASE+20*256) = ''
   NEWLINES(2)
   PRINTSTRING('VIRTUAL MEMORY MAP')
   NEWLINES(2)
   %CYCLE I = 32,1,255
      STR = STRING(VBASE+20*I)
      %IF STR # '' %THEN %START
         SPACE
         PRINTSYMBOL(HEX(I>>4))
         PRINTSYMBOL(HEX(I&15))
         SPACES(2)
         PHEX(INTEGER(VBASE+20*I+16))
         SPACES(2);  PRINTSTRING(STR);  NEWLINE
      %FINISH
   %REPEAT
   NEWLINES(2)
   PRINTSTRING('COMREG')
NEWLINES(2)
%CYCLE I=0,1,59
WRITE(I,5)
SPACES(2)
PHEX(COMREG(I))
%IF I&7=7 %THEN NEWLINE
%REPEAT
NEWLINES(2)
%CYCLE I=-2,1,15
HOLD = REG(I)&X'FFF000';                !PAGE START
%IF X'200000' <= HOLD %AND STRING(VBASE+20*(HOLD>>16)) # '' %C
   %THEN REG(I) = HOLD %ELSE REG(I) = 0
!IN SUBSYSTEM AREA - SEGMENT IN USE
%REPEAT
LAST = X'1FF000';                       !PAGE BEFORE SS BASE
%CYCLE
POINT = X'FF0000';                   !HIGHEST POSSIBLE PAGE
   %CYCLE I = -2,1,15
      %IF LAST < REG(I) < POINT %THEN POINT = REG(I)
                                        !SET POINT TO NEXT LOWEST PAGE
   %REPEAT
   %EXIT %IF POINT = X'FF0000';         !GOT TO TOP
   DUMP(POINT,POINT+4095)
   LAST = POINT;      !MOVE TO NEXT PAGE REQUIRED
%REPEAT
NEWLINES(2)
PRINTSTRING('END OF DIAGNOSTIC DUMP')
NEWLINE
%END;                                   !OF DIAGDUMP

%SYSTEMROUTINE RECODE(%INTEGER START, FINISH, CA)
%SWITCH SW(0 : 3)
%BYTEINTEGER B0, B1
%INTEGER D1, D2, D3, D4, H1, H2, H3, LENGTH, K, M, X, Y, Z, PTR
%INTEGER OPC
%OWNINTEGER BLANKS = M'    '
%OWNINTEGER MASK1 = X'0F0F0F0F'
%OWNINTEGER MASK2 = X'0F0F0F0F'
%OWNINTEGER P1;  %OWNINTEGER P2;  %OWNINTEGER P3;  %OWNINTEGER P4
%CONSTINTEGERARRAY C(0 : 127) =   %C
M'    ',M'    ',M'    ',M'    ',M'SPM ',
 M'BALR',M'BCTR',M'BCR ',M'SSK ',M'ISK ',M'SVC ',M'    ',M'    ',
 M'    ',M'    ',M'    ',M'LPR ',M'LNR ',M'LTR ',M'LCR ',
 M'NR  ',M'CLR ',M'OR  ',M'XR  ',M'LR  ',M'CR  ',M'AR  ',M'SR  ',
 M'MR  ',
 M'DR  ',M'ALR ',M'SLR ',M'LPDR',M'LNDR',M'LTDR',M'LCDR',M'HDR ',
 M'    ',M'    ',M'    ',M'LDR ',M'CDR ',M'ADR ',M'SDR ',M'MDR ',
 M'DDR ',M'AWR ',M'SWR ',M'LPER',M'LNER',M'LTER',
 M'LCER',M'HER ',M'    ',M'    ',M'    ',M'LER ',M'CER ',M'AER ',
 M'SER ',M'MER ',M'DER ',M'AUR ',M'SUR ',
 M'STH ',M'LA  ',M'STC ',M'IC  ',M'EX  ',M'BAL ',M'BCT ',M'B   ',
 M'LH  ',M'CH  ',M'AH  ',M'SH  ',M'MH  ',M'    ',M'CVD ',M'CVB ',
 M'ST  ',M'    ',M'    ',M'    ',M'N   ',M'CL  ',M'O   ',M'X   ',
 M'L   ',M'C   ',M'A   ',M'S   ',M'M   ',M'D   ',M'AL  ',M'SL  ',
 M'STD ',M'    ',M'    ',M'    ',M'    ',M'    ',M'    ',M'    ',
 M'LD  ',M'CD  ',M'AD  ',M'SD  ',M'MD  ',M'DD  ',M'AW  ',
 M'SW  ',M'STE ',M'    ',M'    ',M'    ',M'    ',
 M'    ',M'    ',M'    ',M'LE  ',M'CE  ',M'AE  ',M'SE  ',M'ME  ',
 M'DE  ',M'AU  ',M'SU  '
%CONSTINTEGERARRAY D(128 : 159) =   %C
M'IDL ',M'    ',M'PC  ',M'DIG ',M'    ',
 M'RDD ',M'BXH ',M'BXLE',M'SRL ',M'SLL ',
 M'SRA ',M'SLA ',M'SRDL',M'SLDL',M'SRDA',M'SLDA',M'STM ',M'TM  ',
 M'MVI ',M'    ',M'NI  ',M'CLI ',M'OI  ',M'XI  ',M'LM  ',
 M'    ',M'    ',M'    ',M'SDV ',M'TDV ',M'HDV ',M'CKC' 
%CONSTINTEGERARRAY E(208 : 255) =   %C
M'SSP ',M'MVN',M'MVC ',M'MVZ ',M'NC  ',
 M'CLC ',M'OC  ',M'XC  ',M'LSP ',M'    ',M'    ',M'    ',M'TR  ',
 M'TRT ',M'ED  ',M'EDMK',
 M'    ',M'    ',M'    ',M'    ',M'    ',M'    ',
 M'    ',M'    ',M'    ',M'    ',M'    ',M'    ',
 M'    ',M'    ',M'    ',M'    ',M'    ',M'MVO ',M'PACK',M'UNPK',
 M'    ',M'    ',M'    ',M'    ',M'ZAP ',M'CP  ',M'AP  ',M'SP  ',
 M'MP  ',M'DP  ',M'    ',M'    '
!--------------------------------------UNPK-----------------------------

   %ROUTINE UNPK(%INTEGER Z)
   %SHORTROUTINE
      -> 1 %IF Z = BLANKS
      *UNPK_P2(5),Z+2(3)
      *NC_P2(4),MASK1
      *L_1,HEX
      *TR_P2(4),0(1)
      *MVI_P1+3,4
      *LA_1,P1+3;  *->P5
      -> 99
1:    SPACES(4)
99: %END;                               !OF UNPK
!--------------------------------------FETCH HALF-----------------------

   %ROUTINE FETCH HALF
   %SHORTROUTINE
      *MVC_K(2),P1
      *L_1,X;  *LA_2,2(1);  *ST_2,X
      *A_1,START
      *MVC_K+2(2),0(1)
      *MVC_B0(2),K+2
   %END;                                !OF FETCH HALF
!-----------------------------------------PS----------------------------

   %ROUTINE PS(%INTEGER N)
   %SHORTROUTINE
      P2 = N;  *MVI_P1+3,4
      *LA_1,P1+3;  *->P5
   %END;                                !OF PS
!--------------------------------------PRINTCODE------------------------

   %ROUTINE PRINTCODE
   %SHORTROUTINE
      NEWLINE
      UNPK(PTR+CA)
      WRITE(PTR+CA,5)
      SPACES(5);  UNPK(H1)
      UNPK(H2);  UNPK(H3)
      SPACES(4)
   %END;                                !OF PRINTCODE

   %ROUTINE DB(%INTEGER D, B)
   %SHORTROUTINE
      WRITE(D,4);  PRINTSTRING('(')
      WRITE(B,2);  PRINTSTRING(')')
   %END;                                !OF DB
!----------------------------------RECODE-------------------------------

   START = START&(-4);  X = 0;  Y = FINISH-START;  -> 100
1: %IF X >= Y %THEN %RETURN
100:

   H2 = BLANKS;  H3 = BLANKS;  FETCH HALF
   H1 = K;  M = B0>>6
   -> SW(M) %UNLESS 160 <= B0 %AND B0 <= 207
20:PTR = X-2;  PRINTCODE;  -> 1
SW(0):

   OPC = C(B0)
   -> 20 %IF OPC = BLANKS
   PTR = X-2;  PRINTCODE
   PS(OPC);  WRITE(B1>>4,4)
   -> 1 %IF B0 = 4
   PRINTSTRING(',');  WRITE(B1&15,4);  -> 1
SW(1):

   OPC = C(B0);  -> 20 %IF OPC = BLANKS
   D1 = B1>>4;  D3 = B1&15
   FETCH HALF;  H2 = K
   PTR = X-4;  PRINT CODE;  PS(OPC)
   WRITE(D1,4);  PRINTSTRING(',')
   WRITE(K&4095,4);  PRINTSTRING('(')
   WRITE(D3,2);  PRINTSTRING(',')
   WRITE(K>>12,2);  PRINTSTRING(')');  -> 1
SW(2):

   OPC = D(B0);  -> 20 %IF OPC = BLANKS
   Z = B0
   D3 = B1;  FETCH HALF;  H2 = K
   PTR = X-4;  PRINT CODE;  PS(OPC)
   D2 = K>>12;  D4 = K&4095
   -> 200 %IF 134 <= Z <= 144 %OR Z = 152
   DB(D4,D2);  PRINTSTRING(',')
   WRITE(D3,3);  -> 1
200:

   WRITE(D3>>4,4);  PRINTSTRING(',')
   -> 201 %IF 136 <= Z <= 143;          ! SHIFTS
   WRITE(D3&15,4);  PRINTSTRING(',')
201:

   DB(D4,D2);  -> 1
SW(3):

   OPC = E(B0);  -> 20 %IF OPC = BLANKS
   LENGTH = B1;  FETCH HALF;  H2 = K
   D1 = K&4095;  D2 = K>>12;  FETCH HALF;  H3 = K
   PTR = X-6;  PRINT CODE;  PS(OPC)
   WRITE(LENGTH+1,4);  PRINTSTRING(',')
   DB(D1,D2);  PRINTSTRING(',')
   DB(H3&4095,H3>>12);  -> 1
%END;                                   !OF RECODE
%SYSTEMROUTINE IMPMON
!THIS ROUTINE IS CALLED BEFORE EVERY LINE OF AN
!IMP OBJECT FILE COMPILED WITH DEBUG PARM.
!ON ENTRY R8 POINTS TO REGISTER SET FOR CALLING ROUTINE
!DEBUG=0 - NEW START, DEBUG=-1 IGNORE, DEBUG=1 BP SET
%STRING (160) COM;                      !MUST BE LONG ENOUGH FOR INPUT BUFFER
%INTEGER I, GLA, LINE, BLOCK, P, ENDCOM, FLAG, J, ADATA, TYPE,  %C
      OLDREG
%INTEGER SIGN, HOLD
%LONGREAL RHOLD
%STRING (255) SHOLD
%CONSTSTRING (15) %ARRAY FINDERR(-2 : 2) =    %C
'INVALID ADDRESS','NOT FOUND','','UNASSIGNED','NOT USED'
%CONSTBYTEINTEGERARRAY VALIDCOM(1 : 5) =      %C
'I', 'C', 'S' ,'M','A'
%SWITCH COMSW(1 : 5), TSW, SSW(0 : 7)
%STRING (8) NAME
%STRING (15) HOLDPROMPT
%OWNINTEGER BPLINE, BPBLOCK
%INTEGER CUROUTSTREAM

   %ROUTINE OUTLINE(%STRING (255) S)
      PRINTSTRING(S)
      NEWLINE
   %END

   %ROUTINE READLINE(%STRINGNAME S, %INTEGER MODE)
      !MODE=0 SKIP INITIAL NEWLINES
                                        !MODE=1 ALLOW INITIAL NEWLINES
AGAIN:CONSOLE(0,ADDR(S)+1,1,ENDCOM)
      %IF MODE = 0 %AND ENDCOM = 1 %THEN -> AGAIN;!SKIP NEWLINES
      ENDCOM = ENDCOM-1;                !REMOVE NEWLINE CHAR
      LENGTH(S) = ENDCOM
      S = S.TOSTRING(255);              !TO TERMINATE GET INT ETC
   %END

   %ROUTINE GETINT(%INTEGERNAME VALUE, FLAG)
!ON ENTRY P POINTS TO FIRST CHARACTER OF
!INTEGER IN STRING COM. PUT VALUE IN VALUE
!FLAG=0 OK. P LEFT POINTING TO NEXT CHAR
      !SIGN MUST BE GLOBAL AS IT IS USED
      !BY GET REAL
      SIGN = 1;                         !DEFAULT
      FLAG = 0
      VALUE = 0
      %IF CHARNO(COM,P) = '+' %THEN P = P+1 %ELSE %START
         %IF CHARNO(COM,P) = '-' %THEN SIGN = -1 %AND P = P+1
      %FINISH
      %UNLESS '9' >= CHARNO(COM,P) >= '0' %C
         %THEN FLAG = 1 %AND %RETURN
      %WHILE '9' >= CHARNO(COM,P) >= '0' %CYCLE
         VALUE = VALUE*10+CHARNO(COM,P)-'0'
         P = P+1
      %REPEAT
      VALUE = VALUE*SIGN
!P NOW POINTS TO FIRST NON-NUMERIC CHAR.
   %END

   %ROUTINE GETREAL(%LONGREALNAME RES, %INTEGERNAME FLAG)
   %INTEGER I
   %LONGREAL MULT
      GETINT(I,FLAG)
      %IF FLAG # 0 %THEN %RETURN
      RES = I
      %IF CHARNO(COM,P) = '.' %START
         P = P+1
         %UNLESS '9' >= CHARNO(COM,P) >= '0' %C
            %THEN FLAG = 1 %AND %RETURN
         MULT = 0.1*SIGN;               !THIS WAS SET BY GETINT
         %WHILE '9' >= CHARNO(COM,P) >= '0' %CYCLE
            RES = RES+(CHARNO(COM,P)-'0')*MULT
            MULT = MULT/10
            P = P+1
         %REPEAT
      %FINISH
   %END

   %ROUTINE GETSTRING(%STRINGNAME S, %INTEGERNAME FLAG)
!DOES NOT DEAL WITH NEWLINES OR EMBEDDED QUOTES
      FLAG = 0
      %IF CHARNO(COM,P) # '''' %THEN FLAG = 1 %AND %RETURN
      P = P+1
      S = ''
      %WHILE CHARNO(COM,P) # '''' %CYCLE
         S = S.TOSTRING(CHARNO(COM,P))
         %IF LENGTH(S) = 255 %THEN FLAG = 1 %AND %RETURN
         P = P+1
         %IF CHARNO(COM,P) = 255 %START
            PROMPT(''':')
            %UNTIL ENDCOM # 0 %CYCLE
               READLINE(COM,1)
               P = 1
               S = S.TOSTRING(NL)
               %IF LENGTH(S) = 255 %THEN FLAG = 1 %AND %RETURN
            %REPEAT
            PROMPT('DEBUG:')
         %FINISH
      %REPEAT
      P = P+1
   %END

   %ROUTINE GETNAME(%STRINGNAME NAME, %INTEGERNAME FLAG)
!GETS NAME FROM CURRENT POSITION OF POINTER. SKIPS CHAS AFTER 8
!LEAVES POINTER AFTER NAME
      FLAG = 0
      NAME = ''
      %UNLESS 'A' <= CHARNO(COM,P) <= 'Z' %C
         %THEN FLAG = 1 %AND %RETURN
      !MUST START WITH ALPHA
      %WHILE 'A' <= CHARNO(COM,P) <= 'Z' %C
         %OR '0' <= CHARNO(COM,P) <= '9' %CYCLE
         NAME = NAME.TOSTRING(CHARNO(COM,P)) %C
            %UNLESS LENGTH(NAME) = 8
         P = P+1
         %EXIT %IF P > 71
      %REPEAT
   %END

   %ROUTINE FINDNAME(%STRING (8) NAME,  %C
      %INTEGERNAME ADATA, TYPE, FLAG)
!SEARCHES LOCAL BLOCK DIAGS FOR NAME AND RETURNS ADDR OF VARIABLE
!IN ADATA. TYPE AS BELOW,FLAG =0 O.K.,=1 UNASSIGNED, =2 NOT USED
!=-1 NOT FOUND, =-2 INVALID ADDRESS
   %CONSTINTEGER BMARK = X'C2C2C2C2', SMARK = X'E2E2E2E2', BTRTAB =  %C
         X'03000107', UNASSI = X'80808080'
   %INTEGER P, T, DISP, VBREG, K, PREC, NAM, BYTES, BLOCKNO
   %SWITCH S(0 : 11)
      BLOCKNO = BLOCK;                  !FIRST TIME ROUND
AGAIN:                                  !COME HERE FOR OUTER BLOCKS
      P = INTEGER(GLA+28)+INTEGER(GLA+12)
      %UNTIL INTEGER(P) = SMARK %CYCLE
         %IF INTEGER(P) = BMARK %START
            -> RIGHT BLOCK %IF SHORTINTEGER(P+4) = BLOCKNO
         %FINISH
         P = P+4
      %REPEAT
      FLAG = -1;                        !NO DIAGS FOR THIS BLOCK
      %RETURN
RIGHTBLOCK:

      K = BYTEINTEGER(P+7)
      %IF K = 0 %THEN ADATA = P+12 %C
         %ELSE ADATA = (P+K+11)&X'FFFFFC'
      !ADATA NOW POINTS TO FIRST NAME IN DIAGS
      %CYCLE
         %IF INTEGER(ADATA) < 0 %START; !TRY NEXT OUTER BLOCK
            %IF INTEGER(ADATA) = -2 %THEN ADATA = ADATA+4 %C
               %ELSE %START
               BLOCKNO = INTEGER(ADATA+4)
               %IF BLOCKNO = 0 %OR BLOCKNO = BMARK %C
                  %THEN FLAG = -1 %AND %RETURN
               !NO OUTER BLOCK
               -> AGAIN
            %FINISH
         %FINISH
         %IF STRING(ADATA+3) = NAME %THEN %EXIT
         ADATA = (ADATA+7+BYTEINTEGER(ADATA+3))&X'FFFFFC'
      %REPEAT
                                        !ADATA NOW POINTS TO REQUIRED NAME
      I = INTEGER(ADATA)
      DISP = I>>8&4095
      VBREG = I>>20&15
      K = I>>24
      T = K&7
      PREC = K>>3&3
      NAM = K>>6&1
      BYTES = PREC
      *TR_BYTES+3(1),BTRTAB
      ADATA = INTEGER(OLDREG+4*VBREG)+DISP
      %IF NAM = 1 %START;               !NAME TYPE VARIABLE
         %UNLESS ADATA&3 = 0 %THEN FLAG = -2 %AND %RETURN
                                        !MUST BE WORD ALIGNED
         ADATA = INTEGER(ADATA)
         %IF ADATA = UNASSI %THEN FLAG = 2 %AND %RETURN
      %FINISH
!DEAL WITH STRINGS
      %IF T = 5 %START
         TYPE = (NAM<<4)!5
         %IF BYTEINTEGER(ADATA) = 128 = BYTEINTEGER(ADATA+1) %C
            %THEN FLAG = 1
         %RETURN
      %FINISH
      %UNLESS ADATA&BYTES = 0 %AND T # 0 %C
         %THEN FLAG = -2 %AND %RETURN
      TYPE = (PREC+4*(T&3-1))!NAM<<4
      -> S(TYPE&15)
S(0):

S(4):                                   !INTEGER AND REAL
      FLAG = 1 %IF INTEGER(ADATA) = UNASSI
S(1):                                   !BYTEINTEGER
      %RETURN
S(2): FLAG = 1 %IF SHORTINTEGER(ADATA) = X'FFFF8080'
      %RETURN
S(7): %IF INTEGER(ADATA) = UNASSI = INTEGER(ADATA+4) %C
         %THEN FLAG = 1
      %RETURN
S(3):

S(5):

S(6):

S(8):

S(9):

S(10):

S(11):
      FLAG = -2
   %END
   *ST_8,OLDREG;                        !BASE OF CALLING REGS
   %RETURN %IF SSDEBUG = -1
   GLA = INTEGER(OLDREG+52);            !R13 OF OLD SET
   %UNLESS 0 < GLA < X'FFFFFF' %AND GLA&7 = 0 %C
      %THEN OUTLINE('INVALID GLA ADDRESS') %AND %RETURN
   !ON VALID WORD BOUNDARY
   LINE = SHORTINTEGER(GLA+22);         !START OF LINE
   BLOCK = SHORTINTEGER(GLA+20);        !START OF BLOCK
   %RETURN %IF SSDEBUG = 1 %AND (LINE # BPLINE %C
      %OR BLOCK # BPBLOCK # -1)
   CUROUTSTREAM = -1
   %IF COMREG(23) # 91 %START;          !OUTPUT STREAM
      CUROUTSTREAM = COMREG(23)
      SELECTOUTPUT(0)
   %FINISH
   HOLDPROMPT = STRING(COMREG(50))
   PROMPT('DEBUG:')
   %IF SSDEBUG = 0 %START;              !FIRST ENTRY SINCE COMMAND:
      BPLINE = -1;                      !INITIAL VALUE
      BPBLOCK = -1;                     !INITIAL VALUE - IGNORE
      SSDEBUG = -1;                     !IGNORE FUTURE CALLS UNLESS BP SET
      NEWLINE
      OUTLINE('**PROGRAM RUNNING IN DEBUG MODE')
   %FINISH %ELSE %START;                !LOOKING FOR BREAK POINT
      NEWLINE
      PRINTSTRING('**AT LINE')
      WRITE(LINE,1)
      %IF BPBLOCK # -1 %START
         PRINTSTRING(' OF BLOCK')
         WRITE(BLOCK,1)
      %FINISH
      NEWLINE
   %FINISH
NEXT:

   READLINE(COM,0)
   %IF CHARNO(COM,1) = '.' %START
      J = CHARNO(COM,2)
      %CYCLE I = 1,1,5
         %IF J = VALIDCOM(I) %THEN -> COMSW(I)
      %REPEAT
      OUTLINE('?')
      -> NEXT
COMSW(1):                               !.I - IGNORE
      SSDEBUG = -1;                     !TO IGNORE ALL FUTURE CALLS
      -> EXIT
COMSW(2):                               !.C - CONTINUE
      -> EXIT
COMSW(3):                               !.S - SET
      P = 3
      GETINT(BPLINE,FLAG)
      %IF FLAG # 0 %START
         OUTLINE('.S LINE NO [,BLOCK START]')
         -> NEXT
      %FINISH
      SSDEBUG = 1;                      !TO CAUSE FUTURE STOPS
      -> NEXT %IF P > ENDCOM
      %IF CHARNO(COM,P) = ',' %START
         P = P+1;                       !FIRST CHARACTER OF BLOCK NO
         GETINT(BPBLOCK,FLAG)
         -> NEXT %IF FLAG = 0
      %FINISH
      OUTLINE('.S LINE NO,BLOCKSTART')
      -> NEXT
COMSW(4):                               !.M %MONITOR
      MDIAG(OLDREG-4,0,0);              !CALL DIAGS WITH OLD REGISTER SET
      -> NEXT
COMSW(5):                               ! .A - ABORT TO COMMAND:
      I = COMREG(36);                   !REG SAVE AREA ON ENTRY TO PROG
      *L_1,I
      *LM_4,15,16(1);                   !LOAD UP REGS AND
      *BCR_15,15;                       !RETURN
   %FINISH;                             !END OF DOT COMMANDS
   P = 1
   GETNAME(NAME,FLAG)
   %IF FLAG # 0 %THEN OUTLINE('?') %AND -> NEXT
   %IF P > ENDCOM %START;               !PRINT VALUE
      FINDNAME(NAME,ADATA,TYPE,FLAG)
      %IF FLAG # 0 %THEN OUTLINE(FINDERR(FLAG)) %AND -> NEXT
      -> TSW(TYPE&7)
TSW(0):

      WRITE(INTEGER(ADATA),1);          !INTEGER
      -> TSWEND
TSW(1):

      WRITE(BYTEINTEGER(ADATA),1);      !BYTE
      -> TSWEND
TSW(2):

      WRITE(SHORTINTEGER(ADATA),1);     !SHORT
      -> TSWEND
TSW(4):

      PRINTFL(REAL(ADATA),7);           !REAL
      -> TSWEND
TSW(5):

      PRINTSYMBOL('''');                !STRING
      PRINTSTRING(STRING(ADATA))
      PRINTSYMBOL('''')
      -> TSWEND
TSW(7):

      PRINTFL(LONGREAL(ADATA),14);      !LONGREAL
      -> TSWEND
TSWEND:

      NEWLINE
      -> NEXT
   %FINISH
   %IF CHARNO(COM,P) # '=' %THEN OUTLINE('?') %AND -> NEXT
   P = P+1
   FINDNAME(NAME,ADATA,TYPE,FLAG)
   %UNLESS 1 >= FLAG >= 0 %C
      %THEN OUTLINE(FINDERR(FLAG)) %AND -> NEXT
   -> SSW(TYPE&7)
SSW(0):

   GETINT(HOLD,FLAG)
   %IF FLAG = 0 %THEN INTEGER(ADATA) = HOLD %C
      %ELSE OUTLINE(NAME.' IS AN INTEGER')
   -> NEXT
SSW(1):

   GETINT(HOLD,FLAG)
   %IF FLAG = 0 %AND 255 >= HOLD >= 0 %C
      %THEN BYTEINTEGER(ADATA) = HOLD %C
      %ELSE OUTLINE(NAME.' IS A BYTE')
   -> NEXT
SSW(2):

   GETINT(HOLD,FLAG)
%IF FLAG=0%AND -32768<=HOLD<=32767 %THEN SHORTINTEGER(ADATA)=HOLD %C
%ELSE OUTLINE(NAME.' IS A SHORTINTEGER')
   -> NEXT
SSW(4):

   GETREAL(RHOLD,FLAG)
   %IF FLAG = 0 %THEN REAL(ADATA) = RHOLD %C
      %ELSE OUTLINE(NAME.' IS A REAL')
   -> NEXT
SSW(5):

   GETSTRING(SHOLD,FLAG)
   %IF FLAG = 0 %THEN STRING(ADATA) = SHOLD %C
      %ELSE OUTLINE(NAME.' IS A STRING')
   -> NEXT
SSW(7):

   GETREAL(RHOLD,FLAG)
   %IF FLAG = 0 %THEN LONGREAL(ADATA) = RHOLD %C
      %ELSE OUTLINE(NAME.' IS A LONGREAL')
   -> NEXT
EXIT:

   PROMPT(HOLDPROMPT)
   %IF CUROUTSTREAM # -1 %THEN SELECTOUTPUT(CUROUTSTREAM)
%END
%ENDOFFILE