! DATED 27 JUL 79
!
CONSTINTEGER INVI=X'80308030'
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
ROUTINESPEC RSTRG(STRINGNAME S)
DYNAMICSTRINGFNSPEC UINFS(INTEGER I)
DYNAMICROUTINESPEC DPOFF(RECORDNAME P)
DYNAMICINTEGERFNSPEC DPERMISSION(STRING (6) OWNER,USER, C
STRING (8) DATE,STRING (15) FILE, INTEGER FSYS,TYPE,ADRPRM)
DYNAMICINTEGERFNSPEC DSFI(STRING (6) USER, C
INTEGER FSYS,TYPE,SET,ADR)
!
DYNAMICSTRINGFNSPEC DERRS(INTEGER I)
DYNAMICINTEGERFNSPEC DFINFO(STRING (6) USER, STRING (15) FILE, C
INTEGER FSYS,ADR)
!
SYSTEMROUTINESPEC PHEX(INTEGER I)
SYSTEMROUTINESPEC MOVE(INTEGER LEN,FROM,TO)
SYSTEMROUTINESPEC ETOI(INTEGER AD,LEN)
SYSTEMROUTINESPEC FINFO(STRING (31) S,INTEGER MODE, C
RECORDNAME R, INTEGERNAME FLAG)
DYNAMICINTEGERFNSPEC EXIST(STRING (63) FILE)
SYSTEMROUTINESPEC NCODE(INTEGER S,F,FF)
SYSTEMROUTINESPEC DISCONNECT(STRING (31) S,INTEGERNAME F)
DYNAMICROUTINESPEC PROMPT(STRING (15) S)
DYNAMICROUTINESPEC CLEAR(STRING (63) S)
DYNAMICROUTINESPEC DEFINE(STRING (63) S)
DYNAMICROUTINESPEC DETACH(STRING (255) S)
SYSTEMROUTINESPEC OUTFILE(STRING (31) S, C
INTEGER LENGTH,MAXBYTES,PROT, INTEGERNAME CONAD,FLAG)
!
SYSTEMROUTINESPEC CONNECT(STRING (31) S, INTEGER ACC,MAXB,PROT, C
RECORDNAME R, INTEGERNAME FLAG)
!
RECORDFORMAT OBJF(INTEGER NEXTFREEBYTE,CODERELST,GLARELST,LDRELST,C
CHKSM,DT,W6,W7)
RECORDFORMAT SRCF(INTEGER NEXTFREEBYTE,TXTRELST,MAXLEN,ZERO)
CONSTSTRINGNAME DATE=X'80C0003F', TIME=X'80C0004B'
!
!
!
RECORDFORMAT CONRECF(INTEGER CONAD,FILETYPE,RELST,RELEND)
!
RECORDFORMAT FINFRECF(INTEGER CONAD,FILETYPE,RELST,RELEND, C
SIZE,RUP,EEP,MODE,USERS,ARCH, C
STRING (6) TRAN,STRING (8) DATE,TIME, C
INTEGER COUNT,SPARE1,SPARE2)
!
CONSTSTRING (15)ARRAY OUTFMSGS(1:19)= C
"INVALID NAME",
"INVALID OWNER",
"", "",
"NO FREE FDS",
"NO FREE CELLS",
"FSYS FULL", "CONFLICT USE", "ON OFFER",
"TWO GEN", "INVALID SIZE", "NO VM GAP", "",
"USER NOT OWNER", "BEING EXEC", "",
"FILE IN USE", "TOO MANY CONN", "USER NOT OWNER"
!
CONSTSTRING (23)ARRAY CONNMSGS(1:24)= C
"INVALID NAME",
"INVALID OWNER",
"NOT EXIST OR NO ACC",
"REQ ACC NOT GRANTED",
"", "", "",
"CONFLICTING USE",
"ON OFFER",
""(8),
"NO VM GAP",
""(3),
"BEING EXEC",
"CURRENTLY IN USE",
"TOO MANY FILES CONN"
!
EXTERNALSTRINGFN FROMSTR(STRING (255) S,INTEGER I,J)
UNLESS I<=J AND J<=LENGTH(S)>0 THEN RESULT =""
RESULT =FROMSTRING(S,I,J)
END ; ! FROMSTR
!--------------------------------------------------------------------------------
EXTERNALROUTINE UDERRS(INTEGER N)
PRINTSTRING("FLAG =")
PRINTSTRING(DERRS(N))
NEWLINE
END ; ! UDERRS
EXTERNALSTRINGFN HTOS(INTEGER I,PL)
! RESULT IS THE STRING OF HEX DIGITS REPRESENTING THE NUMBER I.
! THE SECOND PARAM, TO BE SET IN RANGE 1 TO 8, SPECIFIES LENGTH OF
! RESULT STRING, TRUNCATING ON THE LEFT (NO CHECKING OF THIS PARAM, OR
! OF WHAT DIGITS ARE BEING TRUNCATED)
INTEGER J,K,M
STRING (8) W
J=ADDR(W)
CYCLE M=8,-1,1
K=I&15 + '0'
IF K>57 THEN K=K+7
BYTEINTEGER(J+M)=K
I=I>>4
REPEAT
BYTEINTEGER(J)=8
J=ADDR(W) + 8 - PL
BYTEINTEGER(J)=PL
RESULT =STRING(J)
END ; ! HTOS
!--------------------------------------------------------------------------------
EXTERNALROUTINE CONNFLAG(STRING (63) S,INTEGER FLAG)
INTEGER CURRST
IF FLAG#0 START
CURRST=COMREG(23)
SELECT OUTPUT(0)
PRINTSTRING(S.": CONNECT FLAG =")
WRITE(FLAG,1)
PRINTSTRING(" ".CONNMSGS(FLAG)) IF 0<FLAG<=24
NEWLINE
SELECT OUTPUT(CURRST)
FINISH
END ; ! CONNFLAG
EXTERNALINTEGERFN NWFILEAD(STRING (15) S,INTEGER PGS)
INTEGER I,FLAG,CURR
FLAG=1
IF 0<LENGTH(S)<=15 THEN OUTFILE(S,PGS<<12,X'40000',0,I,FLAG)
IF FLAG#0 START
CURR=COMREG(23)
SELECT OUTPUT(0)
PRINTSTRING("OUTFILE FLAG =")
WRITE(FLAG,1)
IF FLAG>9 THEN FLAG=FLAG-6; ! 16-24 -> 10-18
IF FLAG+6=49 THEN FLAG=19
IF 0<FLAG<=19 THEN PRINTSTRING(" ".OUTFMSGS(FLAG)."
")
I=0
SELECT OUTPUT(CURR)
FINISH
RESULT =I
END ; ! NWFILEAD
EXTERNALINTEGERFN TPFILEAD(STRING (15) S,INTEGER PGS)
! SAME AS NWFILEAD, BUT SETS NEXT TO TOP BIT IN "PROTECT", THUS
! FORMING A FILE MARKED "TEMPFI"
INTEGER I,FLAG,CURR
FLAG=1
IF 0<LENGTH(S)<=15 THEN OUTFILE(S,PGS<<12,X'40000', C
X'40000000',I,FLAG)
IF FLAG#0 START
CURR=COMREG(23)
SELECT OUTPUT(0)
PRINTSTRING("OUTFILE FLAG =")
WRITE(FLAG,1)
IF FLAG>9 THEN FLAG=FLAG-6; ! 16-24 -> 10-18
IF FLAG+6=49 THEN FLAG=19
PRINTSTRING(" ".OUTFMSGS(FLAG)."
")
I=0
SELECT OUTPUT(CURR)
FINISH
RESULT =I
END ; ! TPFILEAD
INTEGERFN SHORTCFN(STRINGNAME S)
!
! CHECK FILE NAME - 1-8 CHARS, ALPHA,NUMBERS OR HASH
!
! RESULT = 0 GOOD 1 BAD
!
INTEGER CH,J,L
L=LENGTH(S)
RESULT =1 UNLESS 0<L<=11
CYCLE J=1,1,L
CH=BYTEINTEGER(ADDR(S)+J)
RESULT =1 UNLESS 'A'<=CH<='Z' OR '0'<=CH<='9' OR CH='#'
REPEAT
RESULT =0; ! FILENAME IS GOOD
END ; ! SHORTCFN
INTEGERFN CFN(STRINGNAME S)
STRING (31) MAS,MEM
IF S->MAS.("_").MEM THEN RESULT =SHORTCFN(MAS) ! C
SHORTCFN(MEM)
RESULT =SHORTCFN(S)
END ; ! CFN
INTEGERFN LONG CFN(STRINGNAME S)
! RESULT 0 GOOD 1 BAD
STRING (63) USER,FILE
IF S->USER.(".").FILE START
IF LENGTH(USER)#6 OR SHORTCFN(USER)#0 OR C
CFN(FILE)#0 THEN RESULT =1
RESULT =0; ! GOOD
FINISH
RESULT =CFN(S)
END ; ! LONG CFN
EXTERNALINTEGERFN RDFILEAD(STRING (63) S)
RECORD R(CONRECF)
INTEGER I,FLAG
! CONNECT IN A SUITABLE MODE
FLAG=1
R=0
IF 0<LENGTH(S)<=31 THEN CONNECT(S,0,X'40000',0,R,FLAG)
CONNFLAG(S,FLAG)
I=R_CONAD
I=0 IF FLAG#0
RESULT =I
END ; ! RDFILEAD
EXTERNALINTEGERFN WRFILEAD(STRING (31) S)
RECORD R(CONRECF)
INTEGER I,FLAG
! CONNECT IN WRITE MODE
FLAG=1
R=0
IF 0<LENGTH(S)<=31 THEN CONNECT(S,3,X'40000',0,R,FLAG)
CONNFLAG(S,FLAG)
I=R_CONAD
I=0 IF FLAG#0
RESULT =I
END ; ! WRFILEAD
EXTERNALSTRINGFN ITOS(INTEGER VALUE)
!**********************************************************************
! *
! TURNS AN INTEGER INTO A STRING *
! *
!**********************************************************************
STRING (11) S
STRING (1) SIGN
INTEGER J
SIGN = ""; S = ""
SIGN = "-" AND VALUE = -VALUE IF VALUE < 0
CYCLE
J = VALUE
VALUE = VALUE//10
J = J-VALUE*10+'0'
S = TO STRING(J).S
EXIT IF VALUE <= 0
REPEAT
RESULT = SIGN.S
END ; !OF STRINGFN I TO S
!--------------------------------------------------------------------------------
EXTERNALROUTINE AWAIT(STRING (255) S)
RECORDFORMAT PARMF(INTEGER DEST,SRCE,P1,P2,P3,P4,P5,P6)
RECORD P(PARMF)
PRINTSTRING("WAITING ..
")
DPOFF(P)
END ; ! AWAIT
!--------------------------------------------------------------------------------
EXTERNALROUTINE COPF(STRING (71) S)
INTEGER J,SIZEBYTES
RECORD R(FINFRECF)
STRING (63) FILE1,FILE2
INTEGER FROMAD,TOAD,FLAG
UNLESS LENGTH(S)>0 AND C
S->FILE1.(",").FILE2 AND C
0<LENGTH(FILE1)<=31 AND C
0<LENGTH(FILE2)<=31 THEN -> BAD
FROMAD=RDFILEAD(FILE1)
RETURN IF FROMAD<=0
FINFO(FILE1,0,R,FLAG)
MONITOR IF FLAG#0
SIZEBYTES=R_SIZE
TOAD=NWFILEAD(FILE2,(SIZEBYTES+X'FFF')>>12)
RETURN IF TOAD<=0
MOVE(SIZEBYTES,FROMAD,TOAD)
DISCONNECT(FILE2,J)
RETURN
BAD:
PRINTSTRING("PARAMS?
")
END ; ! COPF
INTEGERFNSPEC HXSTOBIN(STRING (29) S)
!
EXTERNALINTEGERFN BIN(STRING (255) S)
! RESULT IS VALUE REPRESENTED BY THE STRING PARAM
! ERROR RESULT IS X80308030 (BAD CHAR IN STRING OR BAD
! LENGTH)
INTEGER I,Q,L,AS,CH,SIGN
SIGN=1
WHILE S->(" ").S CYCLE ;REPEAT
IF S->("-").S THEN SIGN=-1
WHILE S->(" ").S CYCLE ; REPEAT
IF S->("X").S START
I=HXSTOBIN(S)
IF I#X'80308030' THEN I=I*SIGN
RESULT =I
FINISH
AS=ADDR(S)
L=LENGTH(S)
RESULT =X'80308030' IF L=0
I=0
CYCLE Q=1,1,L
CH=BYTEINTEGER(AS+Q)
RESULT =X'80308030' UNLESS '0'<=CH<='9'
I= 10*I + CH - 48
REPEAT
RESULT =I*SIGN
END ; ! BIN
ROUTINE INSTRG(STRINGNAME S)
! READS NEXT LINE FROM CURRENT INPUT STREAM, SETTING S TO BE CONTENTS
! OF THE LINE WITHOUT THE NEWLINE.
INTEGER I
S=""
UNTIL I=NL CYCLE
READSYMBOL(I)
S=S.TOSTRING(I)
REPEAT
LENGTH(S)=LENGTH(S) - 1
END ; ! INSTRG
!--------------------------------------------------------------------------------
EXTERNALROUTINE RSTRG(STRINGNAME S)
INSTRG(S) UNTIL S#""
END ; ! RSTRG
EXTERNALINTEGERFN HXSTOBIN(STRING (29) S)
! RESULT IS VALUE REPRESENTED BY UP TO 8 HEX DIGITS IN THE PARAM.
! ERROR RESULT IS X80308030
INTEGER I,Q,L,AS,CH
AS=ADDR(S)
L=LENGTH(S)
RESULT =X'80308030' IF L>8 OR L=0
I=0
CYCLE Q=1,1,L
CH=BYTEINTEGER(AS+Q)
RESULT =X'80308030' UNLESS '0'<=CH<='9' OR 'A'<=CH<='F'
IF CH>'9' THEN CH=CH-55 ELSE CH=CH-48
I=I<<4 ! CH
REPEAT
RESULT =I
END ; ! HXSTOBIN
EXTERNALINTEGERFN RDINTS(STRING (63) S)
! READS NEXT UNSIGNED DEC NO. OR HEX NO. (NOT X80308030).
OWNSTRING (15)ARRAY NS(1:10)=""(10)
STRING (1) T
STRING (63) REST
INTEGER I
OWNINTEGER NP=0,NL=0
IF S#"" THEN -> NONNULL START
IF NP>=NL THEN START
RESET:
RSTRG(S)
NONNULL START:
NP=0; NL=0
WHILE S->(" ").S CYCLE ;REPEAT
WHILE S->NS(NL+1).(" ").S CYCLE
WHILE S->(" ").S CYCLE ;REPEAT
IF NS(NL+1)="X" OR NS(NL+1)="-" START
T=NS(NL+1)
WHILE S->(" ").S CYCLE ;REPEAT
UNLESS S->REST.(" ").S THEN REST=S AND S=""
NS(NL+1)=T.REST
FINISH
NL=NL+1
REPEAT
IF S#"" START
NL=NL+1
NS(NL)=S
FINISH
FINISH
!----------------------------------------
!
!
NP=NP+1
S=NS(NP)
I=BIN(S)
IF I=X'80308030' THEN START
PRINTSTRING("INVALID HEX OR DEC NO.
")
IF NP>1 START
NP=NP-1
PRINTSTRING("LAST TAKEN WAS ")
PRINTSTRING(NS(NP))
NEWLINE
FINISH
-> RESET
FINISH
RESULT =I
END ; ! RDINTS
!--------------------------------------------------------------------------------
EXTERNALROUTINE RDINT(INTEGERNAME I)
I=RDINTS("")
END ; ! RDINT
OWNINTEGER NEXT=-1
EXTERNALSTRINGFN SEPARATE(STRINGNAME S)
! SEPARATES STRING S INTO SUB-STRINGS COMPRISING THINGS BETWEEN
! (ENDS OR) COMMAS IN S. AT SUCCESSIVE CALS OF THIS FN, S AND THE
! RESULT ARE SET TO THE "NEXT" SUB-STRING. RESULT IS "" WHEN THERE
! ARE NO SUB-STRINGS LEFT. A NULL SUB-STRING (IE. ",," IN THE
! ORIGINAL) ALSO TERMINATES THE SET OF SUB-STRINGS.
OWNSTRING (127)ARRAY FS(0:19)=""(20)
OWNINTEGER N=0
STRING (127) LH,RH
INTEGER J
!
!
IF NEXT<0 START
IF LENGTH(S)=0 THEN RESULT =""
NEXT=0
WHILE S->LH.(" ").RH THEN S=LH.RH
CYCLE J=0,1,19; FS(J)=""; REPEAT ; ! TO ALLOW SERIAL RE-USE
N=0
FS(0)=S
WHILE FS(N)->FS(N).(",").FS(N+1) THEN N=N+1
FINISH
IF FS(NEXT)="" THEN NEXT=-1 AND S="" AND RESULT =""
NEXT=NEXT+1
S=FS(NEXT-1)
RESULT =S
END ; ! SEPARATE
!
!
ROUTINE AINNER(STRING (255) S)
RECORDFORMAT INDIVF(STRING (6) USER,BYTEINTEGER UPRM)
RECORDFORMAT RETF(INTEGER BYTES,OWNP,EEP,SPARE, C
RECORDARRAY INDIV(0:15)(INDIVF))
RECORD P(RETF)
INTEGER I,J,TYPE
ROUTINESPEC OUT(INTEGER A)
IF S#"" START
J=DPERMISSION(UINFS(1),"","",S,-1,4,ADDR(P)); ! GIVE LIST FOR FILE
TYPE=4
IF J#0 THEN -> MONPRM
PRINTSTRING("OWNP: "); OUT(P_OWNP)
PRINTSTRING("; EEP: "); OUT(P_EEP); NEWLINE
I=0
J=16
WHILE J<P_BYTES CYCLE
SPACE; PRINTSTRING(P_INDIV(I)_USER)
OUT(P_INDIV(I)_UPRM); NEWLINE
J=J+8
I=I+1
REPEAT
FINISH ; ! S NOT ""
J=DPERMISSION(UINFS(1),"","",S,-1,8,ADDR(P)); ! GIVE LIST FOR INDEX
TYPE=8
IF J#0 THEN -> MONPRM
I=0
J=16
WHILE J<P_BYTES CYCLE
PRINTSTRING("+")
PRINTSTRING(P_INDIV(I)_USER)
OUT(P_INDIV(I)_UPRM); NEWLINE
J=J+8
I=I+1
REPEAT
RETURN
MONPRM:
PRINTSTRING("DPERM"); WRITE(TYPE,1)
PRINTSTRING(" FLAG ="); WRITE(J,1); NEWLINE
RETURN
ROUTINE OUT(INTEGER A)
SPACE
IF A&4#0 THEN PRINTSTRING("X")
IF A&2#0 THEN PRINTSTRING("W")
IF A&1#0 THEN PRINTSTRING("R")
END ; ! OUT
END ; ! AINNER
!
!
!--------------------------------------------------------------------------------
EXTERNALROUTINE QINFO(STRING (255) FILE)
RECORDFORMAT DFINFRECF(INTEGER NKB,RUP,EEP,APF,USE,ARCH,FSYS, C
CONSEG,CCT,CODES,CODES2,SSBYTE, STRING (6) OFFER)
RECORD X(DFINFRECF)
CONSTINTEGER UNAVA=1, WRCONN=1
CONSTINTEGER OFFER=2, NEWGE=2
CONSTINTEGER TEMPFI=4, OLDGE=4
CONSTINTEGER VTEMPF=8, WSALLOW=8
CONSTINTEGER TEMPFS=12
CONSTINTEGER CHERSH=16, COMMS=16
CONSTINTEGER PRIVAT=32, DISCFI=32
CONSTINTEGER VIOLAT=64
CONSTINTEGER NOARCH=128, DEAD=128
INTEGER J
STRING (31) USER
!
STRING (31) W1,W2
WHILE SEPARATE(FILE)#"" CYCLE
J=0
USER=""
IF FILE->USER.(".").FILE START
J=8 UNLESS (LENGTH(USER)=6 OR LENGTH(USER)=0) AND C
0<LENGTH(FILE)<=11
FINISH
USER=UINFS(1) IF USER=""
X=0
J=DFINFO(USER,FILE,-1,ADDR(X)) IF J=0
IF X_CODES&CHERSH#0 THEN PRINTSYMBOL('*') AND SPACE
PRINTSTRING(FILE.":")
IF J#0 START
UDERRS(J)
CONTINUE
FINISH
PRINTSTRING(" CONN ")
IF X_CONSEG>15 THEN PRINTSYMBOL('X')
PRINTSTRING(HTOS(X_CONSEG,2))
PRINTSTRING("; PGS ")
IF X_NKB>>2>15 THEN PRINTSYMBOL('X')
PRINTSTRING(HTOS(X_NKB>>2,3))
PRINTSTRING("; OWP"); WRITE(X_RUP,1)
PRINTSTRING("; EEP"); WRITE(X_EEP&15,1)
PRINTSTRING("; APF "); PRINTSTRING(HTOS(X_APF,3))
PRINTSTRING("; USERS"); WRITE(X_USE,1)
PRINTSTRING("; POOL"); WRITE(X_SSBYTE,1)
IF LENGTH(X_OFFER)=6 THEN PRINTSTRING("; OFF: ".X_OFFER)
IF X_CODES&VIOLAT#0 THEN PRINTSTRING("; VIOL")
IF X_CODES&TEMPFS#0 THEN PRINTSTRING("; ")
IF X_CODES&VTEMPF#0 THEN PRINTSTRING("V")
IF X_CODES&TEMPFS#0 THEN PRINTSTRING("TEMPFI")
IF X_CODES&NOARCH#0 THEN PRINTSTRING("; NOARCH")
IF X_CODES2&(NEWGE!OLDGE)#0 THEN PRINTSTRING("; GENRS")
NEWLINE
! %IF S->W1.(".").W2 %THEN %CONTINUE
! J=0
! %WHILE J<U_CT %CYCLE
! PRINTSTRING(U_PS(J)_USER )
! WRITE(U_PS(J)_PRM,1)
! NEWLINE
! J=J+1
! %REPEAT
REPEAT
NEWLINE
END ; ! QINFO
!--------------------------------------------------------------------------------
EXTERNALROUTINE AINFO(STRING (63) S)
IF S="" THEN AINNER("") AND RETURN
WHILE SEPARATE(S)#"" CYCLE
PRINTSTRING(S." ")
AINNER(S)
REPEAT
END ; ! AINFO
!--------------------------------------------------------------------------------
EXTERNALROUTINE DUMP(INTEGER START,FINISH,PRINTST,LIM)
!
! DUMP ROUTINE FOR .LP OR EQUIVALENT FILE
!
! LIM GIVE BYTES PER LINE REQUIRED
! BUT IN ADDITION, LIM=-1 WILL GIVE LIM=32, AND
! LIM=-16 WILL GIVE LIM=16 AND EBCDIC PRINT, AND
! LIM=-32 WILL GIVE LIM=32 AND EBCDIC PRINT
ROUTINESPEC EXLINES
INTEGER K,SAMEAS,MSGIND,ACURL
INTEGER ALIGN,MAINSTOP,LM1,ACL4
INTEGER ZER,EBCDIC
BYTEINTEGER CH2
EBCDIC=0
PRINTST=START IF PRINTST=-1
IF START&3#PRINTST&3 THEN PRINTSTRING("DUMP: WRONG PARAMS
")
START=START&(¬3)
FINISH=FINISH&(¬3)
PRINTST=PRINTST&(¬3)
MSGIND=0
IF LIM=-16 THEN EBCDIC=1 AND LIM=16
IF LIM=-32 THEN EBCDIC=1 AND LIM=32
LIM=32 UNLESS LIM=16; ! ONLY THESE TWO VALUES VALID
LM1=LIM-1
ALIGN=PRINTST&LM1
ACURL=START-ALIGN
PRINTST=PRINTST-ALIGN
MAINSTOP=FINISH&(¬LM1)
EXLINES
EXLINES
WHILE ACURL<MAINSTOP CYCLE
ACL4=ACURL+LIM-4
SAMEAS=1
CYCLE K=ACURL,4,ACL4
IF INTEGER(K-LIM)#INTEGER(K) THEN SAMEAS=0 AND EXIT
REPEAT
IF SAMEAS=0 THEN MSGIND=0 ELSE MSGIND=MSGIND+1
IF MSGIND=0 START ; ! NOT SAME, GO ON
! PRINT ADDRESS OF LINESTART
PRINTSYMBOL('(')
PHEX(PRINTST)
PRINTSTRING(") ")
! PRINT HEX PART
CYCLE K=ACURL,4,ACL4
PRINTSTRING(" ")
PHEX(INTEGER(K))
REPEAT
PRINTSTRING(" ")
! PRINT CHAR PART
CYCLE K=ACURL,1,ACURL+LM1
CH2=BYTEINTEGER(K)
IF EBCDIC#0 THEN ETOI(ADDR(CH2),1)
IF 32<=CH2<122 THEN PRINTSYMBOL(CH2) ELSE SPACE
REPEAT
NEWLINE
FINISH ELSE START ; ! NOT SAME, GO ON/ELSE START SAME
IF MSGIND=1 START
PRINTSYMBOL('(')
PHEX(PRINTST)
PRINTSTRING(") ")
ZER=1
CYCLE K=ACURL,4,ACL4
IF INTEGER(K)#0 THEN ZER=0 AND EXIT
REPEAT
IF ZER=0 THEN PRINTSTRING("SAME AS ABOVE") C
ELSE PRINTSTRING("ZEROES")
NEWLINE
FINISH
FINISH ; ! SAME
ACURL=ACURL+LIM
PRINTST=PRINTST+LIM
REPEAT
EXLINES
RETURN
!
ROUTINE EXLINES
!--- STARTING AND FINAL LINES ---
RETURN UNLESS ACURL+LIM>START AND ACURL<FINISH
! PRINT ADDRESS OF LINESTART
PRINTSYMBOL('(')
PHEX(PRINTST)
PRINTSTRING(") ")
! PRINT HEX PART
CYCLE K=ACURL,4,ACURL+LIM-4
PRINTSTRING(" ")
IF START<=K<FINISH THEN PHEX(INTEGER(K)) ELSE SPACES(8)
REPEAT
PRINTSTRING(" ")
! PRINT CHAR PART
CYCLE K=ACURL,1,ACURL+LIM-1
CH2=BYTEINTEGER(K)
IF EBCDIC#0 THEN ETOI(ADDR(CH2),1)
IF START<=K<=FINISH AND 32<=CH2<=122 THEN C
PRINTSYMBOL(CH2) ELSE SPACE
REPEAT
ACURL=ACURL+LIM
PRINTST=PRINTST+LIM
NEWLINE
END ; ! EXLINES
END ; ! DUMP
ROUTINE REDUCE PARAMS(INTEGER A,B,C,D)
NCODE(A,B,C)
D=0
END ; ! REDUCE PARAMS
ROUTINE OCDUMP(STRING (71) S,ROUTINE DUMPRT,INTEGER TYPE)
!
SPEC DUMPRT(INTEGER I,J,K,L)
INTEGER PAR,ST,FI,FILEAD
INTEGER MARG,PRINTST,LIM
STRING (71) FIS,STS,DEVS,FILE
RECORDNAME HDR(SRCF)
!
PAR=1
PROMPT("FILE: ")
NEXT=-1
FILE=SEPARATE(S)
WHILE LONG CFN(FILE)#0 THEN RSTRG(FILE)
FILEAD=RDFILEAD(FILE)
IF FILEAD=0 THEN RETURN
HDR==RECORD(FILEAD)
STS=SEPARATE(S)
PROMPT("RELSTART: ")
ST=RDINTS(STS)
PROMPT("RELFINISH: ")
FIS=SEPARATE(S)
FI=RDINTS(FIS)
IF TYPE=2 START ; ! DUMPCODE
UNLESS 0<=ST<FI AND FI<=HDR_MAXLEN THEN -> FAIL
FINISH
IF FI=0 THEN FI=HDR_NEXTFREEBYTE
DEVS=SEPARATE(S)
PROMPT("TO FILE/DEV: ")
WHILE ".OUT"#DEVS AND FROMSTR(DEVS,1,3)#".LP" AND C
CFN(DEVS)#0 THEN RSTRG(DEVS)
DEFINE("ST63,".DEVS)
SELECT OUTPUT(63)
IF DEVS#".OUT" START
MARG=132
PRINTSTRING("DUMPED FROM FILE: ".FILE)
SPACES(5)
PRINTSTRING(DATE." ".TIME)
NEWLINES(3)
FINISH ELSE MARG=72
PRINTST=FILEAD+ST
IF TYPE=2 THEN PRINTST=ST; ! "FIDDLE-FACTOR" FOR NCODE
LIM=16
IF MARG>72 THEN LIM=32
IF TYPE=3 THEN LIM=-LIM
DUMPRT(FILEAD+ST,FILEAD+FI,PRINTST,LIM)
NEWLINES(2)
SELECT OUTPUT(0)
CLOSE STREAM(63)
CLEAR("")
RETURN
FAIL:
PRINTSTRING("ADDRESSES MUST BE REL TO FILE START AND WITHIN
FILE LENGTH
")
END ; ! OCDUMP
!--------------------------------------------------------------------------------
EXTERNALROUTINE DUMPFILE(STRING (71) S)
OCDUMP(S,DUMP,1)
END ; ! DUMPFILE
!--------------------------------------------------------------------------------
EXTERNALROUTINE DUMPCODE(STRING (71) S)
OCDUMP(S,REDUCE PARAMS,2)
END ; ! DUMPCODE
!--------------------------------------------------------------------------------
EXTERNALROUTINE NRCODE(STRING (71) S)
OCDUMP(S,REDUCE PARAMS,2)
END ; ! NRCODE
!--------------------------------------------------------------------------------
EXTERNALROUTINE EBCDICDUMP(STRING (71) S)
OCDUMP(S,DUMP,3)
END ; ! EBCDICDUMP
!--------------------------------------------------------------------------------
EXTERNALROUTINE DUMPVM(STRING (255) S)
INTEGER LIM
INTEGER START,FINISH,AS AT,J,SEGAD
LIM=32
PROMPT("ADDR OR SEGNO: ")
RDINT(START)
IF 0< START < 1<<18 START
PROMPT("RELSTART: ")
RDINT(J)
START=START<<18 + J
FINISH
SEGAD=START&X'FFFC0000'
PROMPT("ADDR OR RELEND:")
RDINT(FINISH)
IF 0< FINISH < 2<<18 THEN FINISH=SEGAD + FINISH
AS AT=0
PROMPT("TO FILE/DEV: ")
RSTRG(S)
DEFINE("STREAM01,".S)
SELECT OUTPUT(1)
IF S=".OUT" THEN LIM=16 ELSE START
PROMPT("TITLE: ")
RSTRG(S)
PRINTSTRING(S)
NEWLINES(4)
FINISH
DUMP(START,FINISH,START,LIM)
NEWLINE
SELECT OUTPUT(99)
CLOSE STREAM(1)
CLEAR("")
END ; ! DUMPVM
ROUTINE ISEARCH(INTEGER FROM,TO,SEGAD)
STRING (63) TYPE,SEEK
STRING (63) FILE
INTEGER LSEEKM1,ASEEKPLUS1
INTEGER J,K,FIN
INTEGER SEEK1,SEEK2
J=FROM
FIN=TO
PROMPT("STR/SHORT/INT: ")
RSTRG(TYPE) UNTIL TYPE="STR" OR TYPE="SHORT" OR TYPE="INT"
IF TYPE="SHORT" THEN -> SHORT
IF TYPE="INT" THEN -> INT
! THEN STRING
PROMPT("STRING: ")
RSTRG(SEEK)
LSEEKM1=LENGTH(SEEK) - 1
ASEEKPLUS1=ADDR(SEEK) + 1
UNTIL J>FIN-LSEEKM1 CYCLE
CYCLE K=0,1,LSEEKM1
IF BYTEINTEGER(J+K)#BYTEINTEGER(ASEEKPLUS1+K) THEN EXIT
-> FOUND IF K=LSEEKM1; ! GOT THROUGH ALL BYTES WITHOUT DISAGREEMENT
REPEAT
J=J+1
REPEAT
-> NOT FOUND
!
SHORT:
PROMPT("SEARCH FOR: ")
RDINT(SEEK2) UNTIL SEEK2&X'FFFF0000'=0
UNTIL J>FIN-2 CYCLE
IF J&3=0 THEN K=INTEGER(J)>>16 ELSE K=INTEGER(J)&X'FFFF'
IF K=SEEK2 THEN -> FOUND
J=J+2
REPEAT
-> NOT FOUND
!
INT:
PROMPT("SEARCH FOR: ")
RDINT(K)
SEEK1=K>>16
SEEK2=K&X'FFFF'
UNTIL J>FIN-4 CYCLE
IF J&3=0 START
IF INTEGER(J)=K THEN -> FOUND
FINISH ELSE START
IF INTEGER(J-2)&X'FFFF'=SEEK1 AND C
INTEGER(J+2)>>16=SEEK2 THEN -> FOUND
FINISH
J=J+2
REPEAT
!
NOT FOUND:
PRINTSTRING("
NOT FOUND
")
RETURN
FOUND:
PRINTSTRING("
FOUND:
")
K=J+16
K=FIN IF K>FIN
J=J-16
J=SEGAD IF J<SEGAD
DUMP(J,K,J-SEGAD,16)
NEWLINE
END ; ! ISEARCH
!--------------------------------------------------------------------------------
EXTERNALROUTINE SEARCHVM(STRING (255) S)
INTEGER LIM
INTEGER START,FINISH,AS AT,J,SEGAD
LIM=32
PROMPT("ADDR OR SEGNO: ")
RDINT(START)
IF 0< START < 1<<18 START
PROMPT("RELSTART: ")
RDINT(J)
START=START<<18 + J
FINISH
SEGAD=START&X'FFFC0000'
PROMPT("ADDR OR RELEND:")
RDINT(FINISH)
IF 0< FINISH < 2<<18 THEN FINISH=SEGAD + FINISH
ISEARCH(START,FINISH,SEGAD)
END ; ! SEARCHVM
!--------------------------------------------------------------------------------
EXTERNALROUTINE YSEARCH(STRING (255) S)
STRING (63) FILE
INTEGER START,J,K,FIN
PROMPT("FILE: ")
RSTRG(FILE)
START=RDFILEAD(FILE)
RETURN IF START<=0
PROMPT("RELSTART: ")
RDINT(J)
PROMPT("RELFINISH: ")
RDINT(K) UNTIL K>J
FIN=START + K
ISEARCH(START+J,FIN,START)
END ; ! YSEARCH
!--------------------------------------------------------------------------------
EXTERNALROUTINE YCOMP(STRING (255) S)
RECORD FINF(FINFRECF)
INTEGER ORIGS1,FLAG
STRING (63) FILE1,FILE2
INTEGER U,V,S1,S2,SA,LIM
PROMPT("FILE1: ")
RSTRG(FILE1)
PROMPT("FILE2: ")
RSTRG(FILE2)
PROMPT("REL START: ")
RDINT(SA)
SA=SA & (¬B'11'); ! ALIGN TO WORD
S1=RDFILEAD(FILE1)
S2=RDFILEAD(FILE2)
RETURN IF S1<=0 OR S2<=0
ORIGS1=S1
FINFO(FILE1,0,FINF,FLAG)
IF FLAG#0 START
PRINTSTRING("ERROR"); WRITE(FLAG,1); NEWLINE; RETURN
FINISH
LIM=FINF_SIZE
FINFO(FILE2,0,FINF,FLAG)
IF FLAG#0 START
PRINTSTRING("ERROR"); WRITE(FLAG,1); NEWLINE; RETURN
FINISH
! SET LIM TO SHORTER OF THE TWO FILESIZES
IF LIM>FINF_SIZE THEN LIM=FINF_SIZE
S1=S1 + SA
S2=S2 + SA
LIM=ORIGS1 + LIM
CYCLE
U=INTEGER(S1)
V=INTEGER(S2)
IF U#V THEN -> DIFF
S1=S1+4
S2=S2+4
-> DONE IF S1>=LIM
REPEAT
DIFF:
PRINTSTRING("DIFF AT REL ADDRESS: ")
PHEX(S1 - ORIGS1)
SPACES(5)
PHEX(U); SPACES(2)
PHEX(V); NEWLINE
RETURN
DONE:
PRINTSTRING("FINISHED AT REL ADDRESS: ")
PHEX(S1-ORIGS1)
NEWLINE
END ; ! YCOMP
!--------------------------------------------------------------------------------
EXTERNALROUTINE COMPARE(STRING (255) S)
! IF NULL PARAMETER IS SUPPLIED, THE PROGRAM PROMPTS FOR INPUT FILES
! FOR COMPARISON. IT THEN PROMPTS : FOR THE "COMPARE"
! COMMANDS.
! IF PARAMETER COMPRISES TWO FILENAMES SEPARATED BY COMMA, THEN
! COMPARISON COMMENCES RIGHT AWAY.
! UNLESS A THIRD PARAMETER ,.F IS APPENDED, THE PROGRAM RETURNS
! AFTER A DIFFERENCE HAS BEEN FOUND. IT RETURNS ANYWAY IF THE FILES
! ARE FOUND IDENTICAL.
!
STRING (131)FNSPEC RSTRG
ROUTINESPEC LRSTRG(STRINGNAME S)
RECORDNAME H(SRCF)
INTEGER I,J,C,F,AS,L,AGOFLAG,FNCALL
INTEGER OUTSTRM,OUTFILE,CUR IN TO OUT
STRING (63) U,V,PD,MEM
STRING (255)ARRAY CUR(1:2)
INTEGER CURIP
INTEGERARRAY FP,FL(1:2)
SWITCH A('A':'Z')
FNCALL=0
OUTSTRM=0
CUR IN TO OUT=1
CURIP=1
AS=ADDR(S)
AGOFLAG=0
OUTFILE=0
U=""; V=""
IF LENGTH(S)>0 START
UNLESS S->U.(",").V START
IF S->PD.("_").MEM START
IF EXIST(MEM)#0 THEN U=PD."_".MEM AND V=MEM
FINISH
FINISH
AGOFLAG=1
OUTFILE=0
S=".N"
! IF PARAMETER ,.F APPENDED, WE SET "FNCALL" TO INDICATE RETURN
! REQUIRED AFTER DIFFERENCE FOUND, AS WELL AS WHEN IDENTITY FOUND.
IF V->V.(",.F") THEN FNCALL=1
FINISH
IF U="" START
PROMPT("FILE1:")
U=RSTRG
FINISH
I=RDFILEAD(U)
H==RECORD(I)
RETURN IF I<=0
FP(1)=I+H_TXTRELST; FL(1)=I+H_NEXTFREEBYTE
IF V="" START
PROMPT("FILE2:")
V=RSTRG
FINISH
J=RDFILEAD(V)
RETURN IF J<=0
H==RECORD(J)
FP(2)=J+H_TXTRELST; FL(2)=J+H_NEXTFREEBYTE
ADVANCE:
CURIP=1
LRSTRG(CUR(1))
CURIP=2
LRSTRG(CUR(2))
IF LENGTH(CUR(1))=255 START ;F=1;->EOF;FINISH
IF LENGTH(CUR(2))=255 START ;F=2; ->EOF; FINISH
IF AGOFLAG#0 START
AGOFLAG=0
S="GO"
-> L11
FINISH
NEXTCMD:
PROMPT(":")
S=RSTRG
L11:
L=LENGTH(S)
C=BYTEINTEGER(AS+1)
F=BYTEINTEGER(AS+2) - '0'
-> NO UNLESS C='M' OR C='P' OR C='G' OR C='F' OR C='Q' C
OR C='A' OR C='E'
-> A(C)
!
!
A('A'):
-> NO UNLESS L=1 OR S="AGO"
AGOFLAG=1
-> ADVANCE
!
!
A('M'):
-> NO UNLESS L>=3 AND 1<=F<=2
S=FROMSTRING(S,3,L)
I=BIN(S)
-> NO IF I<=0
CURIP=F
CYCLE J=1,1,I
LRSTRG(CUR(F))
IF LENGTH(CUR(F))=255 THEN -> EOF
REPEAT
-> PRINT BOTH
!
!
A('E'):
A('Q'):
-> NO UNLESS L=1
RETURN
!
!
A('P'):
-> NO UNLESS L=2 AND (1<=F<=2 OR F+'0'='B')
IF F+'0'='B' START
PRINT BOTH:
IF LENGTH(CUR(1))=255 THEN PRINTSTRING("**EOF1**
") ELSE PRINTSTRING(CUR(1) ."
")
IF LENGTH(CUR(2))=255 THEN PRINTSTRING("**EOF2**
") ELSE PRINTSTRING(CUR(2)."
")
-> NEXTCMD
FINISH
IF LENGTH(CUR(F))=255 THEN PRINTSTRING("**EOF**
") ELSE PRINTSTRING(CUR(F)."
")
-> NEXTCMD
!
!
A('G'):
L50:
-> NO UNLESS L=2 AND F+'0'='O'
IF CUR(1)#CUR(2) AND LENGTH(CUR(1))<255 C
AND LENGTH(CUR(2))<255 THEN -> DIFF
IF LENGTH(CUR(1))=255 THEN -> EOFS
CURIP=1
LRSTRG(CUR(1))
CURIP=2
LRSTRG(CUR(2))
-> L50
!
!
A('F'):
-> NO UNLESS L>2 AND (1<=F<=2 OR F+'0'='B')
S=FROMSTRING(S,3,L)
IF F+'0'='B' THEN J=0 ELSE J=1
! J=0 MEANS DO BOTH FILES, 1 MEANS DO JUST ONE.
IF J=0 THEN F=1
L22:
CURIP=F
L20:
IF LENGTH(CUR(F))=255 THEN -> EOF
IF CUR(F)->U.(S).V THEN -> L25
LRSTRG(CUR(F))
-> L20
L25:
-> PRINT BOTH IF J=1
! THEN BOTH FILES ARE BEING DONE. NO. 2 NEXT.
F=2
J=1; ! TO STOP IT AFTER THIS TIME.
-> L22
!
!
NO:
PRINTSTRING("NO
")
-> NEXTCMD
DIFF:
PRINTSTRING("DIFF
")
CYCLE J=1,1,2
SPACES(20) IF FNCALL#0
PRINTSTRING(CUR(J))
NEWLINE
REPEAT
IF FNCALL#0 THEN RETURN
-> NEXTCMD
EOF:
PRINTSTRING("EOF"); WRITE(F,1)
NEWLINE
RETURN
EOFS:
PRINTSTRING("COMPARISON COMPLETE
")
RETURN
!
!
STRING (255) FN RSTRG
STRING (131) S
INTEGER I,CT,AS
AS=ADDR(S)
NEW:
CT=0
L1:
READSYMBOL(I)
-> L9 IF I=10
CT=CT+1
BYTEINTEGER(AS+CT)=I
-> L1
L9:
BYTEINTEGER(AS)=CT
IF S="" THEN -> NEW
RESULT =S
END ; ! RSTRG
ROUTINE LRSTRG(STRINGNAME S)
! SETS S TO THE NEXT LINE (WITHOUT THE NL CHARACTER) FROM THE
! RELEVANT FILE AND SETS FP(CURIP) TO POINT TO THE CHARACTER
! AFTER THE NL.
INTEGER AS,CURP,I,L
AS=ADDR(S)
CURP=FP(CURIP)
I=FL(CURIP)
IF CURP>=I THEN -> LEOF
L=0
WHILE BYTEINTEGER(CURP)#10CYCLE
L=L+1
BYTEINTEGER(AS+L)=BYTEINTEGER(CURP)
CURP=CURP+1
REPEAT
BYTEINTEGER(AS)=L
-> OUT
LEOF:
BYTEINTEGER(AS)=255; ! EOF INDICATION
OUT:
FP(CURIP)=CURP+1; ! POINTS TO CHAR AFTER NEWLINE
RETURN
END ; ! LRSTRG
END ; ! COMPARE
!--------------------------------------------------------------------------------
EXTERNALROUTINE NOF(STRING (255) S)
INTEGER FILES,USEDFDS,FREEBYTES,ISIZE KB,NCELLS, C
FREECELLS,NCELLS1,FREECELLS1
! THE ORDER MUST REMAIN THE SAME FOR THE ABOVE !!
INTEGER J
FILES=0; USEDFDS=0; FREEBYTES=0; NCELLS=0; FREECELLS=0
NCELLS1=0; FREECELLS1=0
J=DSFI(UINFS(1),-1,4,0,ADDR(FILES))
IF J#0 START
UDERRS(J)
RETURN
FINISH
PRINTSTRING("FILES "); WRITE(FILES,1); NEWLINE
PRINTSTRING("USEDFDS "); WRITE(USEDFDS,1); NEWLINE
PRINTSTRING("FREEBYTES "); WRITE(FREEBYTES,1); NEWLINE
PRINTSTRING("ISIZE KB "); WRITE(ISIZE KB,1); NEWLINE
PRINTSTRING("CELLS/FREEC"); WRITE(NCELLS,1); PRINTSYMBOL('/')
WRITE(FREECELLS,1)
WRITE(NCELLS1,4); PRINTSYMBOL('/'); WRITE(FREECELLS1,1)
NEWLINE
END ; ! NOF
!--------------------------------------------------------------------------------
EXTERNALROUTINE NKB(STRING (255) S)
INTEGER J,FSYS
INTEGER MAXFILE,MAXKB
INTEGER NOF,TOTKB,NOCHER,CHERKB,NOTEMP,TEMPKB
STRING (31) USER
FSYS=-1
USER=UINFS(1)
MAXFILE=0; MAXKB=0
NOF=0; TOTKB=0; NOCHER=0; CHERKB=0; NOTEMP=0; TEMPKB=0
FSYS=-1
J=DSFI(USER,FSYS,11,0,ADDR(MAXKB))
UDERRS(J) IF J#0
J=DSFI(USER,FSYS,12,0,ADDR(MAXFILE))
UDERRS(J) IF J#0
J=DSFI(USER,FSYS,30,0,ADDR(NOF))
UDERRS(J) IF J#0
PRINTSTRING("Single file limit =")
WRITE(MAXFILE,1); PRINTSTRING(" Kbytes"); NEWLINE
PRINTSTRING("Total file limit =")
WRITE(MAXKB,1); PRINTSTRING(" Kbytes")
PRINTSTRING(" total Kbytes =")
WRITE(TOTKB,1); NEWLINE
PRINTSTRING("No of files ")
WRITE(NOF,1); NEWLINE
PRINTSTRING("No of temp files =")
WRITE(NOTEMP,1); NEWLINE
PRINTSTRING("Amount of temp file space =")
WRITE(TEMPKB,1)
NEWLINE
END ; ! NKB
!--------------------------------------------------------------------------------
EXTERNALROUTINE TIM(STRING (255) S)
PRINTSTRING(TIME)
NEWLINE
END ; ! TIM
!--------------------------------------------------------------------------------
EXTERNALROUTINE DETA(STRING (255) S)
ROUTINESPEC SET CPU FIELD
INTEGER K,AS,AT,FAD,LIMFIELD,DO DET
RECORDNAME H(SRCF)
STRING (63) TIM
FAD=NWFILEAD("SS#DET",1)
DEFINE("STREAM55,SS#DET")
SELECT OUTPUT(55)
PRINTSTRING("CPULIMIT(0000)
CPULIMIT 0000
")
AS=ADDR(S)
AT=ADDR(TIM)
DO DET=0
PROMPT(":")
MOREIP:
RSTRG(S)
IF S="Q" THEN DO DET=1 AND -> ENDIP
IF S="%C" THEN -> ENDIP
TIM="20"
K=BIN(S)
IF 0<K<=600 THEN TIM=S AND -> ENDIP
PRINTSTRING(S)
NEWLINE
-> MOREIP
ENDIP:
S="SS#DET"
IF TIM#"" THEN S=S.","
S=S.TIM
SELECT OUTPUT(99)
CLOSE STREAM(55)
CLEAR("")
RETURN IF DO DET#0
FAD=WRFILEAD("SS#DET")
RETURN IF FAD=0
H==RECORD(FAD)
! SET LIMFIELD TO POINT TO THI CPULIMIT NUMERIC FIELD
LIMFIELD=FAD + H_TXTRELST
SET CPU FIELD
LIMFIELD=LIMFIELD + 5
SET CPU FIELD
DETACH(S)
RETURN
ROUTINE SET CPU FIELD
INTEGER J
UNTIL BYTEINTEGER(LIMFIELD)='0' THEN LIMFIELD=LIMFIELD+1
IF 0<LENGTH(TIM)<=4 START
CYCLE J=LENGTH(TIM),-1,1
BYTEINTEGER(LIMFIELD+3-LENGTH(TIM)+J)=BYTEINTEGER(AT+J)
REPEAT
FINISH
END ; ! SET CPU FIELD
END ; ! DETA
ENDOFFILE