SYSTEMROUTINESPEC CONNECT(STRING (31) S, C
INTEGER A, M, P, RECORDNAME R, INTEGERNAME FLAG)
SYSTEMROUTINESPEC MOVE(INTEGER LENGTH, F, T)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
EXTERNALSTRINGFNSPEC UINFS(INTEGER ENTRY)
EXTERNALINTEGERFNSPEC INSTREAM
EXTERNALINTEGERFNSPEC OUTSTREAM
SYSTEMROUTINESPEC PHEX(INTEGER N)
SYSTEMSTRINGFNSPEC ITOS(INTEGER I)
EXTERNALROUTINESPEC PROMPT(STRING (255) S)
SYSTEMROUTINESPEC PSYSMES(INTEGER ROOT, FLAG)
SYSTEMROUTINESPEC OUTFILE(STRING (31) S, C
INTEGER L, A, C, INTEGERNAME C, F)
OWNSTRING (31) LISTING FILE
SYSTEMROUTINE IMPMON(INTEGER LINENO)
INTEGER SAVEOUTPUT, NEWTOP, BREAK, DOFOLLOWING, FLAG
INTEGER FORMAT, NEXT, ADATA, I, J, SAVEINPUT, K
INTEGER LNB, GLAAD, VADDR, TYPE, PREC, NAM
INTEGER CONVERTAD, DTOPHALF, SST, SSTART, SSEND, CODE
INTEGER WORD0, WORD3, TSTART, RTNO, RTSTATUS, COUNT, LINE
SWITCH OP('A' : 'Z')
INTEGERNAME TOP, PARTOP, NOCOM, TOTCOM
OWNINTEGER SSDEBUG, CONAD, RACE TO LINE
RECORDFORMAT F(INTEGER VAL, STRING (11) VNAME)
RECORDNAME VAR(F)
BYTEINTEGERARRAYNAME TRTAB
BYTEINTEGERARRAYFORMAT TRTF(0:255)
LONGLONGREAL HOLD CONVERTED VALUE
CONSTINTEGER UNASSI = X'81818181'
STRING (11) RTNAME
STRING (63) SUBSCR, KLINES, KL1, KL2
STRING (6) LST, MST
STRING (31) CURRENT LINE
CONSTINTEGER FORM = 0; !PRINT CONTROL
CONSTINTEGER LANG = 3; !IMP
CONSTSTRING (1) NLS = "
"
STRING (255) C, SAVEPROMPT
RECORDFORMAT COMF(INTEGER STARTLINE, ENDLINE, RT, PT, BYTE C
INTEGER CODE, COMNO)
RECORDARRAYFORMAT COMMF(1 : 256)(COMF)
RECORDARRAYNAME COM(COMF)
RECORDNAME CURR, NRECORD(COMF)
RECORDFORMAT FINF(INTEGER CONAD, TYPE, DSTART, DEND)
RECORD R(FINF)
CONSTBYTEINTEGERARRAY HEX(0 : 15) = C
'0','1','2','3','4','5','6','7',
'8','9','A','B','C','D','E','F'
!*
!*
STRINGFN READLINE
STRING (255) S
INTEGER QUOT, SYM
WHILE NEXTSYMBOL = ' ' OR NEXTSYMBOL = NL C
THEN SKIPSYMBOL
S = ""
QUOT = 0
WHILE NEXTSYMBOL # NL OR QUOT = 1 CYCLE
READSYMBOL(SYM); !THROW AWAY UNQUOTED SPACES
UNLESS SYM = ' ' AND QUOT = 0 THEN START
IF SYM = '"' THEN QUOT = 1-QUOT; !INVERT
IF QUOT=0 AND 'a'<=SYM<='z' THEN SYM=SYM-'a'+'A'
S = S.TOSTRING(SYM)
FINISH
REPEAT
SKIPSYMBOL
RESULT = S
END ; !OF READLINE
!*
!*
INTEGERFN CHKNAME(STRINGNAME S)
STRING (63) SS
INTEGER I
UNLESS 'A' <= CHARNO(S,1) <= 'Z' THEN RESULT = 1
IF S -> SS.("(").SUBSCR.(")") THEN S = SS C
ELSE SUBSCR = ""
IF LENGTH(S) > 11 THEN LENGTH(S) = 11
CYCLE I = 1,1,LENGTH(S)
UNLESS 'A' <= CHARNO(S,I) <= 'Z' C
OR '0' <= CHARNO(S,I) <= '9' THEN RESULT = 1
REPEAT
IF SUBSCR = "" THEN RESULT = 0
CYCLE I = 1,1,LENGTH(SUBSCR)
UNLESS '0' <= CHARNO(SUBSCR,1) <= '9' C
OR CHARNO(SUBSCR,1) = '-' THEN START
IF CHARNO(SUBSCR,1) # ',' C
OR (1 # I # LENGTH(SUBSCR)) THEN RESULT = 1
FINISH
REPEAT
S = S."(".SUBSCR.")"
RESULT = 0
END ; !OF CHKNAME
!*
!*
ROUTINE CONDUMP(INTEGER START, N)
INTEGER I
CYCLE
NEWLINE
PRINT SYMBOL('(')
PHEX(START)
PRINTSTRING(') ')
CYCLE I = 1,1,4
PHEX(INTEGER(START))
SPACE
START = START+4; N = N-1
IF N = 0 THEN -> OUT
REPEAT
NEWLINE
REPEAT
OUT:
NEWLINE
END ; !OF CONDUMP
!*
!*
ROUTINE CHDUMP(INTEGER START, N, MODE)
! MODE = 1 FOR ISO, 2 FOR EBCDIC
INTEGER I, C
IF MODE = 2 THEN TRTAB == ARRAY(COMREG(11),TRTF)
CYCLE I = START,1,START+(N*4)-1
IF (START-I)&X'1F' = 0 START
NEWLINE
PRINTSYMBOL('(')
PHEX(I)
PRINTSTRING(') ')
FINISH
C = BYTEINTEGER(I)
IF MODE = 2 THEN C = TRTAB(C)
IF 32 <= C < 127 THEN PRINTSYMBOL(C) ELSE SPACE
REPEAT
NEWLINE
END ; !OF CHDUMP
!*
!*
ROUTINE FAIL(INTEGER MESS)
CONSTSTRING (20) ARRAY M(1 : 9) = C
"Command missing","Unknown command","No parameter allowed",
"Parameter missing","No condition allowed","Condition missing",
"Invalid condition","Invalid line range","Invalid parameters"
PRINTSTRING(M(MESS)); NEWLINE
FLAG = 1
END ; !OF FAIL
!*
!*
INTEGERFN STOI(STRING (255) S, INTEGER PREC)
SWITCH P(3 : 6)
INTEGER L, I, ST, SIGN
LONGINTEGER LI
LI = 0
L = LENGTH(S)
IF L <= 0 THEN RESULT = -1
IF CHARNO(S,1) = 'X' THEN START ; !HEX VALUE
CYCLE I = ADDR(S)+2,1,ADDR(S)+L
LI = LI<<4
IF '0' <= BYTEINTEGER(I) <= '9' C
THEN LI = LI!(BYTEINTEGER(I)-'0') ELSE START
IF 'A' <= BYTEINTEGER(I) <= 'F' C
THEN LI = LI!(BYTEINTEGER(I)-'A'+10) C
ELSE RESULT = -1
FINISH
REPEAT
FINISH ELSE START
SIGN = 1
ST = 1
IF CHARNO(S,1) = '+' THEN ST = 2 ELSE START
IF CHARNO(S,1) = '-' THEN ST = 2 AND SIGN = -1
FINISH
CYCLE I = ADDR(S)+ST,1,ADDR(S)+L
UNLESS '0' <= BYTEINTEGER(I) <= '9' C
THEN RESULT = -1
LI = 10*LI+BYTEINTEGER(I)-'0'
REPEAT
LI = LI*SIGN
FINISH
-> P(PREC)
P(3): !BYTEINTEGER
BYTEINTEGER(CONVERTAD) <- LI
IF BYTEINTEGER(CONVERTAD) = LI THEN RESULT = 0 C
ELSE RESULT = -1
P(4): !HALFINTEGER
HALFINTEGER(CONVERTAD) <- LI
IF HALFINTEGER(CONVERTAD) = LI THEN RESULT = 0 C
ELSE RESULT = -1
P(5): !INTEGER
INTEGER(CONVERTAD) <- LI
IF INTEGER(CONVERTAD) = LI THEN RESULT = 0 C
ELSE RESULT = -1
P(6): !LONGINTEGER
LONGINTEGER(CONVERTAD) = LI
RESULT = 0
END ; !OF STOI
!*
!*
INTEGERFN STOR(STRING (255) S, INTEGER PREC)
SWITCH P(5 : 7)
STRING (63) INTEG, FRAC
LONGLONGREAL LONGR,FRACR
UNLESS S -> INTEG.(".").FRAC C
THEN INTEG = S AND FRAC = ""
IF INTEG = "" THEN LONGR = 0.0 ELSE START
FLAG = STOI(INTEG,5)
IF FLAG < 0 THEN RESULT = -1
LONGR = INTEGER(CONVERTAD)
FINISH
WHILE LENGTH(FRAC) > 0 AND CHARNO(FRAC,LENGTH(FRAC)) = C
'0' THEN LENGTH(FRAC) = LENGTH(FRAC)-1
IF FRAC = "" THEN FRACR = 0.0 ELSE START
FLAG = STOI(FRAC,5)
IF FLAG < 0 THEN RESULT = -1
FRACR = INTEGER(CONVERTAD)
FRACR = FRACR/(10**LENGTH(FRAC))
FINISH
IF LONGR < 0.0 THEN LONGR = LONGR-FRACR C
ELSE LONGR = LONGR+FRACR
-> P(PREC)
P(5): !REAL
REAL(CONVERTAD) = LONGR; RESULT = 0
P(6): !LONGREAL
LONGREAL(CONVERTAD) = LONGR; RESULT = 0
P(7): !LONGLONGREAL
LONGLONGREAL(CONVERTAD) = LONGR; RESULT = 0
END ; !OF STOR
!*
!*
INTEGERFN PSTOI(STRING (255) S)
INTEGER I
I = STOI(S,5); !READ INTEGER
IF I < 0 OR INTEGER(CONVERTAD) < 0 THEN RESULT = -1
RESULT = INTEGER(CONVERTAD)
END ; !OF PSTOI
!*
!*
STRINGFN LINE ONCE
STRING (31) S
S = CURRENT LINE
CURRENT LINE = " "; !MAX SPACES
LENGTH(CURRENTLINE) = LENGTH(S)&X'1F'
RESULT = S
END ; !OF LINEONCE
!*
!*
ROUTINE FMESS(INTEGER FLAG)
CONSTSTRING (22) ARRAY MESS(2 : 16) = C
"Not found","Subscripted scalar","Invalid address",
"Name type variable","Constant wrong type","Constant wrong length",
"Unknown type","Scope violation","End of file reached",
"Not a character file","Wrong no of subscripts","Invalid array header",
"Bound pairs invalid","Subscript out of range","Invalid command nos"
PRINTSTRING(LINEONCE.TOSTRING(COM(NEXT)_CODE)." ".STRING( C
COM(NEXT)_PT)." fails - ".MESS(FLAG))
NEWLINE
END ; !OF FMESS
!*
!*
ROUTINE REASSIGN(STRING (255) STR)
IF TYPE = 1 THEN FLAG = STOI(STR,PREC) AND -> TEST
IF TYPE = 2 THEN FLAG = STOR(STR,PREC) AND -> TEST
IF TYPE = 5 THEN START
UNLESS STR -> ("""").STR.("""") C
THEN FLAG = 6 AND -> FAIL
IF LENGTH(STR) > DTOPHALF&X'1FF' C
THEN FLAG = 7 AND -> FAIL
STRING(VADDR) = STR
RETURN
FINISH
FLAG = 8; !UNKNOWN TYPE
-> FAIL
TEST:
IF FLAG = 0 THEN START
MOVE(1<<(PREC-3),CONVERTAD,VADDR)
RETURN
FINISH
FLAG = 6; !WRONG TYPE
FAIL:
FMESS(FLAG); !PRINT MESSAGE
END ; !OF REASSIGN
!*
!*
INTEGERFN TRANSLATE LINE NOS(STRING (255) C, C
INTEGERNAME N1, N2)
STRING (31) CC
INTEGER CODE
IF '0' <= CHARNO(C,1) <= '9' C
THEN CC <- C AND CODE = 0 C
ELSE CODE = CHARNO(C,1) C
AND CC < -FROMSTRING(C,2,LENGTH(C))
N1 = STOI(CC,5); !GET INTEGER
IF N1 # 0 THEN RESULT = -1
N1 = INTEGER(CONVERTAD)
IF 0 # CODE # '+' AND '-' # CODE # '#' C
AND '*' # CODE THEN RESULT = -1
IF CODE = '-' OR CODE = '*' THEN N1 = -N1
IF CODE = '+' OR CODE = '-' THEN N1 = N1+LINE NO
N2 = N1
IF CODE = '#' OR CODE = '*' THEN N1 = -LINE NO
RESULT = 0
END ; !OF TRANSLATE LINE NOS
!*
!*
ROUTINE RESOLVE(STRING (255) C)
STRING (255) COMMAND, CONDITION, C1, C2, PARAM
STRING (63) HOLD, HOLDC, HOLDR, HOLDL
SWITCH AN('A' : 'V')
INTEGER I, N1, N2, J
!*A B C D E F G H I J K L M
!*N O P Q R S T U V W X Y Z
CONSTBYTEINTEGERARRAY ACTION('A' : 'Z') = C
7, 13, 0, 7, 0, 1, 0, 5, 5, 0, 3, 0, 5,
0, 0, 7, 0, 5, 7, 0, 0, 0, 0, 0, 0, 0
!* BITS ARE AS FOLLOWS:
!* 2**0 = 1 VALID COMMAND
!* 2**1 = 1 PARAMETER REQUIRED
!* 2**2 = 1 CONDITION ALLOWED
!* 2**3 = 1 CONDITION MANDATORY
FLAG = 0
NEWTOP = TOP; !SAVE OLD TOP
UNLESS C -> COMMAND.(".IF").CONDITION THEN START
UNLESS C -> COMMAND.("@").CONDITION C
THEN COMMAND = C AND CONDITION = ""
FINISH
IF LENGTH(COMMAND) < 1 THEN FAIL(1) AND RETURN
I = CHARNO(COMMAND,1)
UNLESS 'A' <= I <= 'Z' AND ACTION(I) > 0 C
THEN FAIL(2) AND RETURN
COM(TOP)_CODE = I
COM(TOP)_STARTLINE = 1; !DUMMY LINE RANGE
COM(TOP)_ENDLINE = 99999
COM(TOP)_RT = 1; !DEFAULT=ANY ROUTINE
COM(TOP)_COMNO = NOCOM; !NOTE STORED COMMAND NO
IF LENGTH(COMMAND) > 1 THEN PARAM = FROMSTRING(COMMAND, C
2,LENGTH(COMMAND)) ELSE PARAM = ""
IF ACTION(I)&2 = 0 THEN START ; !NO PARAMETER
IF PARAM # "" THEN FAIL(3) AND RETURN
FINISH ELSE START ; !REQUIRES A PARAMETER
IF LENGTH(PARAM) = 0 THEN FAIL(4) AND RETURN
PARTOP = (PARTOP+3)//4*4
COM(TOP)_PT = PARTOP
-> AN(I); !ANALYSE COMMAND PARAMETERS
AN('A'): !ASSIGN: VARIABLE=VALUE
UNLESS PARAM -> C1.("=").C2 THEN -> ERR
FLAG = CHKNAME(C1)
IF FLAG # 0 OR C2 = "" THEN -> ERR
STRING(PARTOP) = C1
PARTOP = PARTOP+LENGTH(C1)+1
STRING(PARTOP) = C2
PARTOP = PARTOP+LENGTH(C2)+1
-> OUT
AN('D'): !DUMP: ADDR,LENGTH,FORMAT
UNLESS PARAM -> C1.(",").C2 C
AND C2 -> C2.(",").PARAM THEN -> ERR
INTEGER(PARTOP) = PSTOI(C1)
IF INTEGER(PARTOP) <= 0 THEN -> ERR
INTEGER(PARTOP+4) = PSTOI(C2)
IF INTEGER(PARTOP+4) <= 0 THEN -> ERR
-> ERR IF "C" # PARAM # "H" AND PARAM # "E"
IF PARAM = "C" THEN J = 1 ELSE START
IF PARAM = "E" THEN J = 2 ELSE J = 0
FINISH
INTEGER(PARTOP+8) = J
PARTOP = PARTOP+12
-> OUT
AN('K'): !KILL: NO OF COMMANDS
STRING(PARTOP) = PARAM
PARTOP = PARTOP+LENGTH(PARAM)+1
-> OUT
AN('P'): !PRINT: VARIABLE
FLAG = CHKNAME(PARAM)
IF FLAG # 0 THEN -> ERR
STRING(PARTOP) = PARAM
PARTOP = PARTOP+LENGTH(PARAM)+1
-> OUT
AN('S'): !PRINT SOURCE: LINE NO,COUNT
UNLESS PARAM -> C1.(",").C2 THEN -> ERR
J = PSTOI(C1)
IF J <= 0 THEN -> ERR
INTEGER(PARTOP) = J
J = PSTOI(C2)
IF J <= 0 THEN -> ERR
INTEGER(PARTOP+4) = J
PARTOP = PARTOP+8
-> OUT
ERR:
FAIL(9); !BAD PARAMETERS
RETURN
OUT:
FINISH
IF ACTION(I)&4 = 0 THEN START ; !NO CONDITION ALLOWED
IF CONDITION # "" THEN FAIL(5)
TOP = TOP+1
RETURN
FINISH
IF CONDITION = "" THEN START
IF ACTION(I)&8 > 0 THEN FAIL(6); !CONDITION MANDATORY
TOP = TOP+1
RETURN
FINISH
HOLDC = ""; HOLDL = ""; HOLDR = ""
UNTIL CONDITION = "" CYCLE
UNLESS CONDITION -> HOLD.("&").CONDITION C
THEN HOLD = CONDITION AND CONDITION = ""
UNLESS (HOLDL = "" AND HOLD -> ("L=").HOLDL) C
OR (HOLDR = "" AND HOLD -> ("R=").HOLDR) C
OR (HOLDC = "" AND HOLD -> ("C=").HOLDC) C
THEN FAIL(7) AND RETURN
REPEAT
IF HOLDR # "" THEN START ; !R=ROUTINE SPECIFIED
FLAG = CHKNAME(HOLDR); !CHECK ROUTINE NAME
IF FLAG = 0 AND SUBSCR = "" THEN START
STRING(PARTOP) = HOLDR
COM(TOP)_RT = PARTOP
PARTOP = PARTOP+LENGTH(HOLDR)+1
FINISH ELSE START ; !CHECK FOR BLOCK LINE NO
FLAG = PSTOI(HOLDR)
IF FLAG < 0 THEN FAIL(7) AND RETURN
COM(TOP)_RT = -FLAG; !STORE NEGATIVE
FINISH
FINISH
IF HOLDC # "" THEN START ; !C=VARIABLE SPECIFIED
FLAG = CHKNAME(HOLDC)
IF FLAG # 0 THEN FAIL(7) AND RETURN
NRECORD == COM(TOP+1); !NOTE RECORD GOVERNED BY "N"
NRECORD = COM(TOP); !COPY TO NEXT SLOT
NRECORD_STARTLINE = 0; !TO ENSURE THIS IS IGNORED
NRECORD_ENDLINE = 0
COM(TOP)_CODE = 'C'
IF TOP > 1 THEN START ; !SEE IF THIS VARIABLE ALREADY HAS A 'C' ENTRY
CYCLE I = 1,1,TOP-1
CURR == COM(I); !LOOK FOR C COMMAND
IF CURR_CODE = 'C' AND STRING(CURR_PT) = C
HOLDC AND (CURR_STARTLINE # 0 C
OR CURR_ENDLINE # 0) THEN START
IF COM(TOP)_RT = CURR_RT C
OR (COM(TOP)_RT > 0 AND CURR_RT > 0 C
AND STRING(COM(TOP)_RT) = STRING(CURR_RT)) C
THEN START
COM(TOP)_PT = CURR_PT; !FOUND, USE SAME PARAMS
-> DONE
FINISH
FINISH
REPEAT
FINISH
PARTOP = (PARTOP+LENGTH(HOLDC)+4)//4*4-LENGTH(HOLDC)-1
!TO ALIGN
STRING(PARTOP) = HOLDC; !NOTE VARIABLE NAME
COM(TOP)_PT = PARTOP; !POINTER TO PARAM AREA: VARIABLE,@DIAGS,@VALUE
PARTOP = PARTOP+LENGTH(HOLDC)+1
INTEGER(PARTOP) = 0; !ADDR OF DIAG TABLE ENTRY
INTEGER(PARTOP+4) = 0; !ADDR OF VALUE(WHEN FOUND)
PARTOP = PARTOP+8
DONE:
TOP = TOP+1
FINISH
IF HOLDL # "" THEN START ; !L=LINE(S) SPECIFIED
IF HOLDC # "" THEN TOP = TOP-1; !BACK TO FIRST OF PAIR FOR N
CYCLE
UNLESS HOLDL -> C1.(",").HOLDL C
THEN C1 = HOLDL AND HOLDL = ""
IF C1 -> C1.("-").C2 THEN START ; !RANGE SPECIFIED
N1 = PSTOI(C1); N2 = PSTOI(C2)
UNLESS 0 <= N1 <= N2 AND N2 <= 99999 C
THEN FAIL(8) AND RETURN
FINISH ELSE START
FLAG = TRANSLATE LINE NOS(C1,N1,N2)
IF FLAG # 0 THEN FAIL(8) AND RETURN
FINISH
COM(TOP) = COM(NEWTOP); !COPY COMMAND
COM(TOP)_STARTLINE = N1
COM(TOP)_ENDLINE = N2
IF HOLDC # "" THEN START ;!C REQUIRES A DOUBLE RECORD
TOP = TOP+1
COM(TOP) = NRECORD
FINISH
IF HOLDL = "" THEN EXIT
TOP = TOP+1
REPEAT
FINISH
TOTCOM = TOTCOM + TOP - NEWTOP + 1
NEWTOP = TOP+1
TOP = TOP+1
NOCOM = NOCOM+1; !INCREMENT STORED COMMAND INDEX
IF TOTCOM = 1 AND COM(TOP-1)_CODE = 'B' AND C
COM(TOP-1)_STARTLINE = COM(TOP-1)_ENDLINE C
THEN RACE TO LINE = COM(TOP-1)_STARTLINE C
ELSE RACE TO LINE = 0
END ; !OF RESOLVE
!*
!*
ROUTINE FINDNAME(STRING (63) VNAME)
INTEGER TSTART, WORD1, WORD3, CURLNB
INTEGER SAVESSTBASE, SAVETL, GLOBADR
UNLESS VNAME -> VNAME.("(").SUBSCR.(")") THEN SUBSCR = ""
FLAG = 2; !NOT FOUND
*STLN_CURLNB; !LNB FOR THIS ROUTINE
LNB = INTEGER(CURLNB); !LNB FOR IMPMON
SAVESSTBASE = 0
SAVETL = 0
GLOBADR = 0
UNTIL SAVETL = 1 CYCLE ; !BOTTOM OF THE STACK
LNB = INTEGER(LNB); !LNB FOR CALLING ROUTINE
LNB = LNB&X'FFFFFFFC'; !WORD ALIGN
GLAAD = INTEGER(LNB+16); !ADDR OF GLA
TSTART = INTEGER(LNB+12)&X'FFFFFF'; !OFFSET OF DIAGS FROM SST
IF TSTART = 0 THEN FLAG = 1 AND RETURN
!NO DIAGNOSTICS
UNTIL TSTART = 0 CYCLE
TSTART = TSTART+INTEGER(GLAAD+12); !ADD SST BASE FOR THIS BLOCK
WORD1 = INTEGER(TSTART+4)
WORD3 = INTEGER(TSTART+12)
IF SAVETL = 0 THEN START ;!FIRST TIME THROUGH
SAVETL = (WORD1>>18)&255;!NOTE TEXTUAL LEVEL
SAVESSTBASE = INTEGER(GLAAD+12); !TO ENSURE SAME OBJECT FILE
FINISH ELSE START
IF SAVETL # (WORD1>>18)&255 THEN EXIT ; !WRONG TEXTUAL LEVEL
IF SAVESSTBASE # INTEGER(GLAAD+12) THEN EXIT ; !DIFFERENT OBJECT FILE
FINISH
IF GLOBADR = 0 AND WORD1&X'C0000000' # 0 C
THEN GLOBADR = WORD1&X'3FFFF'
ADATA = TSTART+20+(WORD3>>26)<<2;!START OF TABLE
WHILE INTEGER(ADATA) > 0 CYCLE ;!SEARCH LOCAL VARIABLES
IF STRING(ADATA+4) = VNAME THEN -> FOUND
ADATA = ADATA+8+BYTEINTEGER(ADATA+4)&(-4)
REPEAT
SAVETL = SAVETL-1; !NOT HERE, TRY NEXT LEVEL DOWN
IF WORD3 # 0 THEN EXIT ; !DO AGAIN IF THIS IS A BLOCK(SAME LNB)
TSTART = WORD1&X'3FFFF'; !NEXT ENVIRONMENT
REPEAT ; !UNTIL NO MORE ENCLOSING BLOCKS
REPEAT
IF GLOBADR > 0 THEN START ; !ANY GLOBALS?
ADATA = GLOBADR+SAVESSTBASE+20
WHILE INTEGER(ADATA) > 0 CYCLE ; !SEARCH GLOBAL VARIABLES
IF STRING(ADATA+4) = VNAME THEN -> FOUND
ADATA = ADATA+8+BYTEINTEGER(ADATA+4)&(-4)
REPEAT
FINISH ; !NAME NOT FOUND
RETURN
FOUND:
FLAG = 0
VAR == RECORD(ADATA)
IF VAR_VAL>>28&3 # 0 THEN START
IF SUBSCR = "" THEN FLAG = 12; !MISSING SUBSCRIPT
FINISH ELSE START
IF SUBSCR # 0 THEN FLAG = 3; !SUBSCRIPTED SCALAR
FINISH
END ; !OF FINDNAME
!*
!*
ROUTINE DCODEDV(LONGINTEGER DV,INTEGERARRAYNAME LB,UB)
!***********************************************************************
!* WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND *
!* RETURN SIZE,DIMENIONALITY AND SUBSCRIPT RANGES IN DATA *
!***********************************************************************
INTEGER I, ND, AD, U
ND = (DV>>32)&255; ND = ND//3
LB(0) = ND; UB(0) = ND
AD = INTEGER(ADDR(DV)+4)+12*(ND-1)
CYCLE I = 1,1,ND
U = INTEGER(AD+8)//INTEGER(AD+4)-1
LB(I) = INTEGER(AD)
UB(I) = LB(I)+U
AD = AD-12
REPEAT
UB(ND+1) = 0
LB(ND+1) = 0
END ; !OF DCODEDV
!*
!*
ROUTINE GET ARRAY ELEMENT(INTEGER HDADDR)
LONGINTEGER ARRD,DOPED
INTEGERARRAY LBS, UBS(0 : 13)
INTEGER BASEADDR, ND, ELSIZE, I, POS, OFFSET, VALUE
STRING (63) SUB, RESTSUB
ARRD = LONG INTEGER(HDADDR); !VALIDATE TWO DESCRIPTORS
DOPED = LONG INTEGER(HDADDR+8)
*LD_ARRD
*VAL_(LNB +1)
*JCC_3,<HINV>
*LD_DOPED
*VAL_(LNB +1)
*JCC_3,<HINV>
BASEADDR = INTEGER(ADDR(ARRD)+4)
DCODEDV(DOPED,LBS,UBS)
ND = LBS(0)
IF TYPE # 5 THEN ELSIZE = 1<<(PREC-3) ELSE START
I = INTEGER(ADDR(DOPED)+4)
ELSIZE = INTEGER(I+12*(ND-1)+4)
FINISH
OFFSET = 1
POS = 0
RESTSUB = SUBSCR
CYCLE I = 1,1,ND
UNLESS RESTSUB -> SUB.(",").RESTSUB C
THEN SUB = RESTSUB AND RESTSUB = ""
IF SUB = "" THEN FLAG = 12 AND RETURN ; !MISSING SUBSCRIPTS
FLAG = STOI(SUB,5); !GET INTEGER
IF FLAG # 0 THEN RETURN ; !INVALID INTEGER
VALUE = INTEGER(CONVERTAD)
UNLESS LBS(I) <= UBS(I) THEN FLAG = 14 AND RETURN ; !BOUND PAIR INVALID
UNLESS LBS(I) <= VALUE <= UBS(I) C
THEN FLAG = 15 AND RETURN ; !SUBSCRIPT OUT OF RANGE
POS = POS+(VALUE-LBS(I))*OFFSET
OFFSET = OFFSET*(UBS(I)-LBS(I)+1)
REPEAT
IF RESTSUB # "" THEN FLAG = 12 AND RETURN ; !TOO MANY SUBSCRIPTS
VADDR = BASEADDR+POS*ELSIZE
RETURN
HINV: !INVALID HEADER
FLAG = 13
END ; !OF ARRAY ELEMENT
!*
!*
ROUTINE DECODE AND VALIDATE(RECORDNAME VAR)
!***********************************************************************
!* A VARIABLE ENTRY IN THE TABLES IS:- *
!* FLAG<<20!VBREG<<18!DISP *
!* WHERE:- *
!* VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET *
!* AND FLAGS=NAM<<6!PREC<<3!TYPE *
!***********************************************************************
RECORDSPEC VAR(F)
INTEGER I, K, LOCALVAD
DTOPHALF = 255
I = VAR_VAL
K = I>>20
TYPE = K&7
PREC = K>>4&7
NAM = K>>10&1
IF I&X'40000' = 0 THEN VADDR = LNB ELSE VADDR = GLAAD
VADDR = VADDR+I&X'3FFFF'
! USE VALIDATE ADDRESS HERE TO CHECK ACR LEVELS ETC
LOCALVAD = VADDR; !REQUIRED TO USE A LOCAL VARIABLE
*LDTB_X'18000010'
*LDA_LOCALVAD
*VAL_(LNB +1)
*JCC_3,<INVALID>
IF SUBSCR # "" THEN START
GET ARRAY ELEMENT(LOCALVAD)
IF FLAG # 0 THEN RETURN
LOCALVAD = VADDR
*LDTB_X'18000010'
*LDA_LOCALVAD
*VAL_(LNB +1)
*JCC_3,<INVALID>
RETURN
FINISH
IF NAM # 0 OR (TYPE = 5 AND FORM = 0) THEN START
IF INTEGER(VADDR)>>24 = X'E5' THEN -> INVALID
!ESCAPE ROUTINE
DTOPHALF = INTEGER(VADDR)
VADDR = INTEGER(VADDR+4)
-> NOT ASS IF VADDR = UNASSI
LOCALVAD = VADDR
*LDTB_X'18000010'
*LDA_LOCALVAD
*VAL_(LNB +1)
*JCC_3,<INVALID>
FINISH
RETURN
INVALID: !INVALID ADDRESS
FLAG = 4; FMESS(4)
RETURN
NOT ASS:
FLAG = 5
END ; !OF DECODE AND VALIDATE
!*
!*
ROUTINE PRINT VAR(INTEGER TYPE, PREC, NAM, LANG, FORM, VADDR)
!***********************************************************************
!* OUTPUT A VARIABLE. FIXED FORMAT(FORM#0) TAKE 14 PLACES FOR *
!* VARIABLES UP TO 32 BITS AND 21 PLACES THEREAFTER *
!***********************************************************************
INTEGER K, I, J
SWITCH INTV, REALV(3 : 7)
IF SUBSCR # "" THEN SUBSCR = "(".SUBSCR.")"; !ADD BRACKETS
PRINTSTRING(LINEONCE.VAR_VNAME.SUBSCR." = ")
IF FLAG = 5 THEN -> NOT ASS
-> ILL ENT IF PREC < 3; ! BITS NOT IMPLEMENTED
IF TYPE = 1 THEN -> INTV(PREC)
IF TYPE = 2 THEN -> REALV(PREC)
IF TYPE = 3 AND PREC = 5 THEN -> BOOL
IF TYPE = 5 THEN -> STR
INTV(4): ! 16 BIT INTEGER
K = BYTEINTEGER(VADDR)<<8!BYTEINTEGER(VADDR+1)
-> NOT ASS IF K = UNASSI>>16
WRITE(K,12*FORM+1)
RETURN
INTV(7): ! 128 BIT INTEGER
REALV(3): ! 8 BIT REAL
REALV(4): ! 16 BIT REAL
ILL ENT: ! SHOULD NOT OCCUR
PRINTSTRING("Unknown type of variable")
RETURN
INTV(5): ! 32 BIT INTEGER
-> NOT ASS IF INTEGER(VADDR) = UN ASSI
WRITE(INTEGER(VADDR),1+12*FORM)
UNLESS FORM=1 OR -255<=INTEGER(VADDR)<=255 START
PRINTSTRING(" (X'")
PHEX(INTEGER(VADDR)); PRINTSTRING("')")
FINISH
RETURN
INTV(3): ! 8 BIT INTEGER
WRITE(BYTEINTEGER(VADDR),1+12*FORM); RETURN
REALV(5): ! 32 BIT REAL
-> NOT ASS IF INTEGER(VADDR) = UN ASSI
PRINT FL(REAL(VADDR),7)
RETURN
INTV(6): ! 64 BIT INTEGER
-> NOT ASS IF UN ASSI = INTEGER(VADDR) = INTEGER(VADDR+4)
PRINTSTRING("X'")
PHEX(INTEGER(VADDR)); SPACES(2)
PHEX(INTEGER(VADDR+4))
PRINTSYMBOL('''')
RETURN
REALV(6): ! 64 BIT REAL
-> NOT ASS IF UNASSI = INTEGER(VADDR) = INTEGER(VADDR+4)
PRINT FL(LONG REAL(VADDR),14)
RETURN
REALV(7): ! 128 BIT REAL
-> NOT ASS IF UNASSI = INTEGER(VADDR) = INTEGER(VADDR+4)
PRINT FL(LONGREAL(VADDR),14)
IF FORM = 0 THEN START
PRINTSTRING(" (R'"); PHEX(INTEGER(VADDR))
PHEX(INTEGER(VADDR+4))
SPACE; PHEX(INTEGER(VADDR+8))
PHEX(INTEGER(VADDR+12))
PRINTSTRING("')")
FINISH
RETURN
BOOL: ! BOOLEAN
-> NOT ASS IF INTEGER(VADDR) = UNASSI
IF INTEGER(VADDR) = 0 THEN PRINTSTRING(" 'FALSE' ") C
ELSE PRINTSTRING(" 'TRUE' ")
RETURN
STR:
I = BYTEINTEGER(VADDR)
-> NOT ASS IF BYTE INTEGER(VADDR+1) = UNASSI&255 = I
-> WRONGL IF I > DTOPHALF&X'1FF'; !CUR LENGTH>MAX LENGTH
K = 1
WHILE K <= I CYCLE
J = BYTE INTEGER(VADDR+K)
-> NPRINT UNLESS 32 <= J <= 126 OR J = 10
K = K+1
REPEAT
PRINTSTRING("""")
PRINTSTRING(STRING(VADDR)); PRINTSTRING("""")
RETURN
NPRINT:
PRINT STRING(" Contains unprintable chars")
RETURN
WRONGL:
PRINTSTRING("Wrong length ")
RETURN
NOT ASS:
PRINTSTRING(" Not assigned")
END ; ! PRINT VAR
!*
!*
IF SSDEBUG = -1 THEN RETURN
IF RACE TO LINE > 0 THEN START ; !RACE IN FORCE?
IF RACE TO LINE # LINE NO THEN RETURN ; !NOT THERE YET
RACE TO LINE = 0; !HAVE ARRIVED
FINISH
!* INITIALISE
SAVEOUTPUT = -1
SAVEINPUT = -1
IF INSTREAM # 0 THEN START
SAVEINPUT = INSTREAM
SELECT INPUT(0)
FINISH
IF OUTSTREAM # 0 THEN START
SAVEOUTPUT = OUTSTREAM
SELECTOUTPUT(0)
FINISH
CONVERTAD = ADDR(HOLD CONVERTED VALUE)
CURRENTLINE = "Line=".ITOS(LINE NO)." "
IF SSDEBUG = 0 THEN START ; !INITIALISE
OUTFILE("T#DBUG",12288,12288,0,CONAD,FLAG)
IF FLAG # 0 THEN START
PSYSMES(10,FLAG)
SSDEBUG = -1; !CANT CONTINUE
-> ERR
FINISH
FINISH
TOP == INTEGER(CONAD+32); !TOP OF COMMAND ARRAY
PARTOP == INTEGER(CONAD+36); !FOR STORING PARAMETERS
COM == ARRAY(CONAD+64,COMMF); !COMMAND ARRAY
NOCOM == INTEGER(CONAD+40); !INDEX OF NEXT STORED COMMAND
TOTCOM == INTEGER(CONAD+44); !NO OF STORED COMMANDS
RTSTATUS = 0; !CURRENT ROUTINE NOT YET KNOWN
IF SSDEBUG = 0 THEN START ; !FIRST TIME IN
TOP = 1
PARTOP = CONAD+4164
SSDEBUG = 1
NOCOM = 1
TOTCOM = 0
LISTING FILE = ""
FINISH
NEWTOP = TOP
IF TOP = 1 THEN BREAK = 1 ELSE BREAK = 0; !BREAK IF NO STORED COMMANDS
DOFOLLOWING = 0; !SET IF "C=" CONDITION SUCCEEDS
NEXT = 0
SAVEPROMPT = UINFS(4)
AGAIN:
NEXT = NEXT+1
IF NEXT < TOP THEN -> OBEY; ! STORED COMMAND?
TOP = NEWTOP
NEXT = TOP
IF BREAK = 0 THEN -> ERR
GETCOMMAND:
IF TOP > 200 OR PARTOP > CONAD+12000 THEN START
PRINTSTRING("Workspace nearly full"); NEWLINE
FINISH
IF CHARNO(CURRENT LINE,1) # ' ' C
THEN PRINTSTRING(LINEONCE.NLS)
SUBSCR = ITOS(NOCOM)
LENGTH(CURRENT LINE) = 7+LENGTH(SUBSCR)
PROMPT("Debug ".ITOS(NOCOM).":")
C = READLINE
RESOLVE(C); !ANALYSE LINE
IF FLAG # 0 THEN TOP = NEWTOP AND -> GETCOMMAND
OBEY: !CHECK STORED COMMAND
CODE = COM(NEXT)_CODE
IF DOFOLLOWING = 1 THEN DOFOLLOWING = 0 AND -> OP(CODE)
IF COM(NEXT)_STARTLINE >= 0 THEN START
UNLESS COM(NEXT)_STARTLINE <= LINE NO <= COM(NEXT)_ENDLINE C
THEN -> AGAIN
FINISH ELSE START
IF COM(NEXT)_ENDLINE < 0 THEN START ; !L=*N
IF LINE NO+COM(NEXT)_STARTLINE # 0 THEN -> AGAIN
!NOT THIS LINE
COM(NEXT)_ENDLINE = COM(NEXT)_ENDLINE+1; !BUMP COUNT
FINISH ELSE START ; !L=#N
COM(NEXT)_ENDLINE = COM(NEXT)_ENDLINE-1; !BUMP COUNT
FINISH
IF COM(NEXT)_ENDLINE # 0 THEN -> AGAIN; !NOT YET
COM(NEXT)_STARTLINE = 0; !NOW COMPLETED
FINISH
IF COM(NEXT)_RT # 1 AND RTSTATUS = 0 THEN START
!IDENTIFY CURRENT ROUTINE
*STLN_LNB; !LNB FOR IMPMON
LNB = INTEGER(LNB); !LNB FOR CALLING ROUTINE
LNB = LNB&X'FFFFFFFC'; !WORD ALIGN
TSTART = INTEGER(LNB+12)&X'FFFFFF'
IF TSTART = 0 THEN -> ERR; !NO DIAGNOSTICS
GLAAD = INTEGER(LNB+16); !ADDR OF GLA/PLT
TSTART = TSTART+INTEGER(GLAAD+12); !ADD STT BASE
WORD0 = INTEGER(TSTART)
WORD3 = INTEGER(TSTART+12)
IF WORD0>>16 = 0 THEN RTNO = 0 AND RTSTATUS = 2 ELSE START
IF WORD3 = 0 THEN RTNO = WORD0>>16 C
AND RTSTATUS = 2 ELSE RTNAME = STRING(TSTART+12) C
AND RTSTATUS = 1
FINISH
FINISH
IF COM(NEXT)_RT # 1 THEN START ; !1=DONT CARE
IF COM(NEXT)_RT <= 0 THEN START ; !-BLOCK START OR 0=MAIN
UNLESS RTSTATUS = 2 AND COM(NEXT)_RT+RTNO = 0 C
THEN -> AGAIN
FINISH ELSE START
UNLESS RTSTATUS = 1 AND RTNAME = STRING(COM(NEXT)_RT) C
THEN -> AGAIN
FINISH
FINISH
!*
!*
-> OP(CODE); !EXECUTE COMMAND
!*
!*
OP('A'): !ASSIGN VALUE TO VARIABLE
FINDNAME(STRING(COM(NEXT)_PT)); !FIRST FIND IT
IF FLAG > 0 THEN START
IF FLAG = 1 THEN -> ERR; !NO DIAGNOSTICS
FMESS(FLAG); !OTHER FAULT
-> AGAIN
FINISH
DECODE AND VALIDATE(VAR)
IF FLAG = 5 THEN FMESS(5)
IF FLAG # 0 THEN -> AGAIN; !OTHER MESSAGES ALREADY PRINTED
REASSIGN(STRING(COM(NEXT)_PT+BYTEINTEGER(COM(NEXT)_PT)+1))
-> AGAIN
OP('B'): !BREAK POINT
BREAK = 1
-> AGAIN
OP('C'): !EXECUTE NEXT COM IF VALUE CHANGED
FINDNAME(STRING(COM(NEXT)_PT))
IF FLAG > 0 THEN START
IF FLAG = 1 THEN -> ERR
FMESS(FLAG)
-> AGAIN
FINISH
DECODE AND VALIDATE(VAR)
IF FLAG > 0 THEN -> AGAIN
I = COM(NEXT)_PT+BYTEINTEGER(COM(NEXT)_PT)+1
IF INTEGER(I) = 0 THEN START ; !FIRST TIME FOUND
INTEGER(I) = ADATA; !NOTE DIAG TABLE ENTRY ADDR
INTEGER(I+4) = PARTOP; !WHERE VALUE IS TO BE STORED
IF TYPE = 5 THEN START ; !STRING
MOVE(BYTEINTEGER(VADDR),VADDR,PARTOP)
PARTOP = PARTOP+DTOPHALF&X'1FF'
FINISH ELSE START ; !OTHER VARIABLES
MOVE(1<<(PREC-3),VADDR,PARTOP)
PARTOP = PARTOP+1<<(PREC-3)
-> AGAIN
FINISH
FINISH
IF INTEGER(I) # ADATA THEN FMESS(9) AND -> AGAIN
!SAME VARIABLE?
J = INTEGER(I+4); !ADDR OF STORED VARIABLE
IF TYPE = 5 THEN COUNT = BYTEINTEGER(VADDR)+1 C
ELSE COUNT = 1<<(PREC-3)
CYCLE K = VADDR,1,VADDR+COUNT-1
IF BYTEINTEGER(K) # BYTEINTEGER(J) THEN START
!VALUE HAS CHANGED
MOVE(COUNT,VADDR,INTEGER(I+4)); !NOTE NEW VALUE
DOFOLLOWING = 1; !CONDITION SATISFIED, EXECUTE NEXT COMMAND
-> AGAIN
FINISH
J = J+1
REPEAT
-> AGAIN
OP('D'): !DUMP VM AREA
!CAN CHECK FOR READ PERM?
FORMAT = INTEGER(COM(NEXT)_PT+8)
I = INTEGER(COM(NEXT)_PT)
J = INTEGER(COM(NEXT)_PT+4) + 3 // 4
IF FORMAT = 0 THEN CONDUMP(I,J) ELSE CHDUMP(I,J,FORMAT)
-> AGAIN
OP('F'): !FILE MAP
*STLN_LNB; !LNB FOR THIS ROUTINE
LNB = INTEGER(LNB); !LNB FOR CALLING ROUTINE
LNB = LNB&X'FFFFFFFC'; !WORD ALIGN
GLAAD = INTEGER(LNB+16); !ADDR OF GLA
SST = INTEGER(GLAAD+12)+4; !BASE OF SST
BEGIN
RECORDFORMAT MPF(STRING (11) NAME, INTEGER LINE, TL)
RECORDARRAY MP(1 : 256)(MPF)
INTEGERARRAY OPEN(1 : 256)
INTEGER LO, HI, PT, MAX, LAST TL
INTEGERFN CHECKNAME(INTEGER I)
INTEGER J
UNLESS 1 <= BYTEINTEGER(I) <= 31 THEN RESULT = 1
CYCLE J = I+1,1,I+BYTEINTEGER(I)
UNLESS 'A' <= BYTEINTEGER(J) <= 'Z' C
OR ('0' <= BYTEINTEGER(J) <= '9' C
AND J > I+1) THEN RESULT = 1
REPEAT
RESULT = 0
END ; !OF CHECKNAME
CYCLE MAX = 1,1,256
OPEN(MAX) = 0; !INITIALISE
REPEAT
MAX = 0
WHILE MAX < 256 CYCLE ; !GET RT NAMES
PT = SST
WHILE INTEGER(SST) # X'FFFFFFFF' THEN SST = SST+4
WHILE PT < SST-12 CYCLE
FLAG = CHECKNAME(PT+12); !NAME OK?
IF FLAG = 0 THEN START
IF 1 <= (INTEGER(PT+4)>>18)&255 <= 7 THEN START
IF (INTEGER(PT+8)>>8)&X'FF' = X'10' THEN EXIT
FINISH
FINISH
PT = PT+4
REPEAT
IF PT >= (SST-12) THEN -> NEXTSST
MAX = MAX+1
MP(MAX)_LINE = INTEGER(PT)>>16; !GET LINE NO
MP(MAX)_TL = (INTEGER(PT+4)>>18)&255; !TEXTUAL LEVEL
MP(MAX)_NAME <- STRING(PT+12)
NEXTSST:
SST = SST+4
IF INTEGER(SST) = X'E2E2E2E2' THEN EXIT ; !END MARK
REPEAT
PRINTSTRING("File map".NLS.NLS."Line no Name".NLS.NLS)
LO = -1; LASTTL = 1
CYCLE I = 1,1,MAX
HI = 99999
CYCLE J = 1,1,MAX; !FIND NEXT
IF LO < MP(J)_LINE < HI C
THEN PT = J AND HI = MP(J)_LINE
REPEAT
IF MP(PT)_TL < 2 THEN -> SKIP
WHILE LAST TL >= MP(PT)_TL CYCLE ; !PRINT 'END'S
WHILE OPEN(LAST TL) > 0 CYCLE
SPACES(7+LAST TL*2)
PRINTSTRING("END".NLS)
OPEN(LAST TL) = OPEN(LAST TL)-1
REPEAT
LAST TL = LAST TL-1
REPEAT
OPEN(MP(PT)_TL) = OPEN(MP(PT)_TL)+1; !BUMP COUNT
WRITE(MP(PT)_LINE,6)
SPACES(MP(PT)_TL*2)
PRINTSTRING(MP(PT)_NAME)
NEWLINE
LAST TL = MP(PT)_TL
SKIP:
LO = HI
REPEAT
WHILE LAST TL >1 CYCLE ; !PRINT 'END'S
WHILE OPEN(LAST TL) > 0 CYCLE
SPACES(7+LAST TL*2)
PRINTSTRING("END".NLS)
OPEN(LAST TL) = OPEN(LAST TL)-1
REPEAT
LAST TL = LAST TL-1
REPEAT
NEWLINES(2)
END
-> AGAIN
OP('H'): !HALT EXECUTION AND RETURN TO COMMAND LEVEL
STOP
OP('I'): !IGNORE ALL FUTURE BREAKPOINTS
SSDEBUG = -1
-> ERR
OP('K'): !KILL STORED COMMAND
KLINES = STRING(COM(NEXT)_PT)
IF NEWTOP < 2 THEN -> AGAIN; !NOTHING TO DO
WHILE KLINES # "" CYCLE
UNLESS KLINES -> KL1.(",").KLINES C
THEN KL1 = KLINES AND KLINES = ""
IF KL1 -> KL1.("-").KL2 THEN START ; !RANGE SPECIFIED
I = PSTOI(KL1); J = PSTOI(KL2)
FINISH ELSE START
I = PSTOI(KL1); J = I
FINISH
UNLESS 0 < I <= J AND J <= NOCOM C
THEN FMESS(16) AND -> AGAIN
CYCLE K = 1,1,NEWTOP-1
IF I <= COM(K)_COMNO <= J THEN COM(K) = 0
REPEAT
REPEAT
CYCLE K = NEWTOP-1,-1,1; !FIND LAST STORED COMMAND
IF COM(K)_COMNO = 0 THEN NEWTOP = NEWTOP-1 ELSE EXIT
REPEAT
RACE TO LINE = 0; TOTCOM = 0
IF NEWTOP = 1 THEN PARTOP = CONAD+4164 AND NOCOM = 1 ELSE START
I = 0; J = 0
CYCLE K=1,1,NEWTOP-1
UNLESS COM(K)_STARTLINE = 0 = COM(K)_ENDLINE THEN START
J = K; !NOTE COMMAND
TOTCOM = TOTCOM + 1; !COUNT DISTINCT COMMANDS
FINISH
REPEAT
IF TOTCOM = 1 AND COM(J)_CODE = 'B' AND C
COM(J)_STARTLINE = COM(J)_ENDLINE THEN C
RACE TO LINE = COM(J)_STARTLINE
FINISH
BREAK = 1
-> AGAIN
OP('M'): !MONITOR
HOLDCONVERTEDVALUE = 0.0; !TEMP
MONITOR
-> AGAIN
OP('P'): !PRINT VALUE
FINDNAME(STRING(COM(NEXT)_PT))
IF FLAG > 0 THEN START
IF FLAG = 1 THEN -> ERR; !NO DIAGNOSTICS
FMESS(FLAG); !OTHER FAULT
-> AGAIN
FINISH
DECODE AND VALIDATE(VAR)
IF 0 # FLAG # 5 THEN START ; !5=UNASSIGNED NOT A FAULT HERE
IF FLAG # 4 THEN FMESS(FLAG)
-> AGAIN
FINISH
PRINT VAR(TYPE,PREC,NAM,LANG,0,VADDR)
NEWLINE
-> AGAIN
OP('R'): !RESUME EXECUTION
BREAK = 0
-> AGAIN
OP('S'): !PRINT SOURCE
LINE = INTEGER(COM(NEXT)_PT)
COUNT = INTEGER(COM(NEXT)_PT+4)
IF LISTING FILE = "" THEN START
PROMPT("List file?: ")
C = READLINE
LISTING FILE = C
FINISH ELSE C = LISTING FILE
CONNECT(C,0,0,0,R,FLAG)
IF FLAG # 0 THEN START
PSYSMES(8,FLAG)
LISTING FILE = ""
-> AGAIN
FINISH
IF R_TYPE # 3 THEN FMESS(11) AND -> AGAIN
SSTART = R_CONAD+R_DSTART
SSEND = R_CONAD+R_DEND
LST = ITOS(LINE)
I = LINE
CYCLE
CYCLE J = 1,1,I
IF SSTART >= SSEND THEN FMESS(10) AND -> AGAIN
WHILE BYTEINTEGER(SSTART) # NL THEN SSTART = SSTART+1
SSTART = SSTART+1
REPEAT
MOVE(6,SSTART,ADDR(MST)+1)
LENGTH(MST) = 6
WHILE MST -> (" ").MST CYCLE
REPEAT
IF LST = MST THEN START ; !FOUND
WHILE COUNT > 0 CYCLE
IF SSTART >= SSEND THEN FMESS(10) AND -> AGAIN
WHILE BYTEINTEGER(SSTART) # NL C
THEN PRINTSYMBOL(BYTEINTEGER(SSTART)) C
AND SSTART = SSTART+1
NEWLINE
SSTART = SSTART+1
COUNT = COUNT-1
REPEAT
-> AGAIN
FINISH
I = 0
IF LENGTH(MST) > 0 AND '0' <= CHARNO(MST,1) <= '9' C
THEN I = LINE-PSTOI(MST)
IF I <= 0 THEN I = 1
REPEAT
-> AGAIN
ERR:
TOP = NEWTOP; !IN CASE LEFT SET AT TEMP COMMAND
IF SAVEOUTPUT > 0 THEN SELECTOUTPUT(SAVEOUTPUT)
IF SAVEINPUT > 0 THEN SELECTINPUT(SAVEINPUT)
PROMPT(SAVEPROMPT); !RESTORE PROMPT
END
ENDOFFILE