! DATED 19 SEP 79
!
CONSTINTEGER INVI=X'80308030'
DYNAMICSTRINGFNSPEC HTOS(INTEGER I,PL)
DYNAMICROUTINESPEC RSTRG(STRINGNAME S)
DYNAMICINTEGERFNSPEC RDFILEAD(STRING (63) S)
DYNAMICROUTINESPEC RDINT(INTEGERNAME I)
DYNAMICROUTINESPEC CONNFLAG(STRING (63) S,INTEGER FLAG)
DYNAMICINTEGERFNSPEC BIN(STRING (255) S)
DYNAMICSTRINGFNSPEC FROMSTR(STRING (255) S,INTEGER I,J)
DYNAMICINTEGERFNSPEC NWFILEAD(STRING (15) S,INTEGER PGS)
DYNAMICINTEGERFNSPEC WRFILEAD(STRING (31) S)
DYNAMICROUTINESPEC COMPARE(STRING (255) S)
DYNAMICROUTINESPEC CHERISH(STRING (255) S)
EXTERNALROUTINESPEC HAZARD(STRING (255) S)
DYNAMICROUTINESPEC NEWGEN(STRING (255) S)
SYSTEMROUTINESPEC PHEX(INTEGER I)
SYSTEMROUTINESPEC MOVE(INTEGER LEN,FROM,TO)
SYSTEMROUTINESPEC FINFO(STRING (31) S,INTEGER MODE, C
RECORDNAME R, INTEGERNAME FLAG)
DYNAMICROUTINESPEC COPY(STRING (63) S)
DYNAMICINTEGERFNSPEC EXIST(STRING (63) FILE)
SYSTEMROUTINESPEC NCODE(INTEGER S,F,FF)
DYNAMICROUTINESPEC SEND(STRING (63) S)
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
SYSTEMROUTINESPEC DESTROY(STRING (31) S,INTEGERNAME FLAG)
SYSTEMROUTINESPEC DISCONNECT(STRING (31) S,INTEGERNAME F)
DYNAMICROUTINESPEC DELIVER(STRING (19) S)
DYNAMICROUTINESPEC PARM(STRING (63) S)
DYNAMICROUTINESPEC IMP(STRING (63) S)
DYNAMICROUTINESPEC LIST(STRING (63) S)
DYNAMICROUTINESPEC PROMPT(STRING (15) S)
DYNAMICROUTINESPEC CLEAR(STRING (63) S)
DYNAMICROUTINESPEC DEFINE(STRING (63) S)
DYNAMICROUTINESPEC OBEY(STRING (63) S)
DYNAMICROUTINESPEC DETACH(STRING (255) S)
SYSTEMROUTINESPEC CONNECT(STRING (31) S, INTEGER ACC,MAXB,PROT, C
RECORDNAME R, INTEGERNAME FLAG)
!
SYSTEMROUTINESPEC CHANGEFILESIZE(STRING (31) S, C
INTEGER NEWSIZE,INTEGERNAME FLAG)
!
CONSTSTRINGNAME DATE=X'80C0003F', TIME=X'80C0004B'
!
RECORDFORMAT OBJF(INTEGER NEXTFREEBYTE,CODERELST,GLARELST,TYPE1,C
CHKSM,DT,W6,W7)
RECORDFORMAT SRCF(INTEGER NEXTFREEBYTE,TXTRELST,MAXLEN,ZERO)
!
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)
!
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
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
!
DYNAMICSTRINGFNSPEC SEPARATE(STRINGNAME S)
!
OWNINTEGER NEXT=-1
!
ROUTINE SANAL(STRINGNAME S,STRING (1) OBJCHAR, C
ROUTINE COMPILER,INTEGER CPLR ID)
SPEC COMPILER(STRING (255) S)
ROUTINESPEC BADPAR
SWITCH CR(0:12)
CONSTINTEGER TOPSAN=25
SWITCH SP(1:TOPSAN)
CONSTSTRING (9)ARRAY PARS(1:TOPSAN)= C
"NULL", "NULLY", "NOLIST", "OPT", "PX",
"NOCHECK", "NOTRACE", "NOARRAY", "NODIAG",
"MAP", "STACK", ".LP", ".N", ".NY",
"PARMX", "PY", "DEBUG", "MAXDICT", ".LPD",
"B", "NEWGEN", "X", "CHECK", ".OUT", "PARMY"
RECORDNAME H(OBJF)
INTEGER TOLP,NEWG,SAVPARM
INTEGER PARAM,AS,P,BADP,CHECK,JJ
STRING (127) REST,PARMFLD,CSTRING,WORK
STRING (31) SOU
STRING (11) OBJ,LI,TTE,RHGEN
AS=ADDR(S)
BADP=0
NEWG=0
CHECK=0
TOLP=0
PARAM=0
PARMFLD=""
TTE=",.OUT"
NEXT=-1
S=SEPARATE(S)
SOU<-S
P=1
UNLESS LONGCFN(S)=0 THEN BADPAR
! TURN S INTO THE ROOT FOR OBJ AND LIST FILENAMES
IF S->REST.(".").S START ;FINISH
IF S->REST.("_").S START ;FINISH
IF BYTEINTEGER(AS+LENGTH(S))#'S' START
IF LENGTH(S)=11 THEN BADPAR
FINISH ELSE START
LENGTH(S)=LENGTH(S)-1
FINISH
RETURN IF BADP#0
OBJ=S.OBJCHAR
LI=S."L"
!
! REMAINING PARAMETERS AFTER FIRST
WHILE SEPARATE(REST)#"" CYCLE
P=P+1
CYCLE PARAM=1,1,TOPSAN
IF REST=PARS(PARAM) THEN -> SP(PARAM)
REPEAT
BADPAR
-> REPT
SP(1): ! NULL
SP(13): ! .N
LI=".NULL"
REST="NOLIST"
-> TACK ON
SP(2): ! NULLY
SP(14): ! .NY
OBJ=".NULL"
-> REPT
SP(6): ! NOCHECK - IGNORE IF "CHECK" GIVEN BEFORE
-> REPT IF CHECK#0
-> TACK ON
SP(4): ! OPT
CHECK=1
SP(18): ! MAXDICT
SP(3):SP(17):
SP(7):SP(8):
SP(9):SP(10):SP(11):
TACK ON:
IF PARMFLD#"" THEN PARMFLD=PARMFLD.","
PARMFLD=PARMFLD.REST
-> REPT
SP(19): ! .LPD, IE. LIST TO .LP AND DESTROY LISTING
IF TOLP#0 THEN BADPAR
TOLP=2
-> REPT
SP(12): ! .LP
IF TOLP#0 THEN BADPAR
TOLP=1
-> REPT
SP(5): ! PX (=PARMX)
SP(15): ! PARMX
REST="PARMX"
-> TACK ON
SP(16): ! PY (=PARMY)
SP(25): ! PARMY
REST="PARMY"
-> TACK ON
SP(24): ! .OUT
! TTE=",.OUT" (IGNORE)
-> REPT
SP(20): ! "B" COMPILER, IE. COMPER
IF CPLR ID<10 THEN CPLR ID=CPLR ID + 10
-> REPT
SP(21): ! NEWGEN
NEWG=1
SP(22): ! "X" OBJ, BUT NOT NEWGEN
RHGEN=OBJ
BYTEINTEGER(ADDR(OBJ)+LENGTH(OBJ))='X'
-> REPT
SP(23): ! CHECK - GIVEN ONLY TO SUPPRESS "NOCHECK" !
CHECK=1
REPT:
REPEAT
RETURN IF BADP#0
! Remove NOCHECK if CHECK included.
IF CHECK=1 START
IF PARMFLD->WORK.("NOCHECK").REST START
PARMFLD=WORK.REST
IF PARMFLD->WORK.(",,").REST THEN PARMFLD=WORK.",".REST
FINISH
FINISH
SAVPARM=COMREG(27)
PARM(PARMFLD)
! TOLP HAS BEEN SET 1 FOR .LP
! 2 FOR .LPD
IF TOLP=2 OR (TOLP#0 AND CPLR ID>=10) START
DESTROY(LI,JJ)
LI=".LP"
FINISH
CSTRING=SOU.",".OBJ.",".LI.TTE
-> CR(CPLR ID) UNLESS CPLR ID<0
COMPILER(CSTRING); ! NONSTANDARD COMPILER
-> LO OUT
CR(0): IMP(CSTRING); -> LO OUT
CR(1): IMP(CSTRING); -> LO OUT
CR(2): IMP(CSTRING); -> LO OUT
CR(10): IMP(CSTRING); -> HI OUT
CR(11): IMP(CSTRING); -> HI OUT
CR(12): IMP(CSTRING); -> HI OUT
LO OUT:
IF TOLP=1 THEN LIST(LI.",.LP")
IF NEWG=0 THEN -> HI OUT
P=RDFILEAD(OBJ)
IF P=0 THEN -> HI OUT
H==RECORD(P)
IF H_NEXTFREEBYTE<=H_CODERELST THEN -> HI OUT
NEWGEN(OBJ.",".RHGEN)
HI OUT:
COMREG(27)=SAVPARM
RETURN
ROUTINE BADPAR
PRINTSTRING("BAD PARAM")
WRITE(P,1)
NEWLINE
BADP=1
END ; ! BADPAR
END ; ! SANAL
!--------------------------------------------------------------------------------
EXTERNALROUTINE PIM(STRING (63) S)
SANAL(S,"Y",IMP,0)
END ; ! PIM
!--------------------------------------------------------------------------------
EXTERNALROUTINE NIM(STRING (63) S)
S=S.",STACK,NOCHECK"
SANAL(S,"Y",IMP,2)
END ; ! NIM
!
!--------------------------------------------------------------------------------
EXTERNALROUTINE COMPLR(ROUTINE COMPILER,STRING (1) OBJSYM, C
STRING (63) S)
SPEC COMPILER
! THIS ROUTINE TO PASS ANY COMPILER IN TO HAVE THE STRING ANALYSIS DONE
! AS USUAL ..
SANAL(S,OBJSYM,COMPILER,-1)
END ; ! COMPLR
EXTERNALINTEGERFN VAL(INTEGER ADR,LEN,RW,PSR)
! RESULT = 1 AREA OK (ACCESSIBLE)
! 0 AREA NOT OK (INACCESSIBLE)
!
! RW SHOULD BE SET 0 (READ ACCESS)
! OR 1 (WRITE ACCESS)
!
! PARAM PSR IS USED IN THE VALIDATE, BUT IF ZERO, THE
! PSR HERE (OR OF CALLING ROUTINE IS USED
INTEGER INSEG0,BEYOND SEG0,SEG0,SEG0 AD
INTEGER DR0
CONSTINTEGER WRITE=1
SEG0=ADR>>18
RESULT =0 IF LEN<=0
IF PSR=0 START ; *LSS_(LNB +1); *ST_PSR; FINISH
IF SEG0 # (ADR+LEN-1)>>18 START
SEG0 AD=SEG0<<18
INSEG0=X'40000' - (ADR-SEG0 AD)
BEYOND SEG0=LEN - INSEG0
RESULT =VAL(ADR,INSEG0,RW,PSR) & C
VAL(ADR+INSEG0,BEYOND SEG0,RW,PSR)
FINISH
! WE SHOULD ALSO CHECK THAT THE AREA LIES WITHIN USER SEGMENTS, AND
! NOT IN ANY HIGHER ACR SEGMENTS AS WELL.
DR0=X'18000000' ! LEN
*LDTB_DR0
*LDA_ADR
*VAL_PSR
*JCC_8,<CCZER>
*JCC_4,<CCONE>
*JCC_2,<CCTWO>
! THEN CC=3, INVALID
RESULT =0
CCZER: ! READ AND WRITE PERMITTED
RESULT =1; ! OK
CCONE: ! READ, BUT NOT WRITE, PERMITTED
IF RW=WRITE THEN RESULT =0; ! BAD
RESULT =1; ! OK
CCTWO: ! WRITE, BUT NOT READ, PERMITTED
RESULT =0; ! BAD
END ; ! VAL
!--------------------------------------------------------------------------------
EXTERNALROUTINE SBYTE(STRING (255) S)
INTEGER START,J,VALUE
PROMPT("ADDR OR SEGNO: ")
RDINT(START)
IF 0< START < 1<<18 START
PROMPT("OFFSET: ")
RDINT(J)
START=START<<18 + J
FINISH
IF VAL(START,1,1,0)=0 THEN -> INVAL
PROMPT("VALUE: ")
RDINT(VALUE) UNTIL 0<=VALUE<=255
PRINTSTRING("BYTE AT ADDRESS ")
PHEX(START)
NEWLINE
PRINTSTRING(" WAS ")
PHEX(BYTEINTEGER(START))
BYTEINTEGER(START)=VALUE
NEWLINE
PRINTSTRING(" BECOMES ")
PHEX(VALUE)
NEWLINE
RETURN
INVAL:
PRINTSTRING("INVALID ADDRES ")
PHEX(START); NEWLINE
END ; ! SBYTE
!--------------------------------------------------------------------------------
EXTERNALROUTINE SWORD(STRING (255) S)
INTEGER START,J,VALUE
PROMPT("ADDR OR SEGNO: ")
RDINT(START)
IF 0< START < 1<<18 START
PROMPT("OFFSET: ")
RDINT(J)
START=START<<18 + J
FINISH
UNLESS START&3=0 THEN -> INVAL
IF VAL(START,4,1,0)=0 THEN -> INVAL
PROMPT("VALUE: ")
RDINT(VALUE)
PRINTSTRING("WORD AT ADDRESS ")
PHEX(START)
NEWLINE
PRINTSTRING(" WAS ")
PHEX(INTEGER(START))
INTEGER(START)=VALUE
NEWLINE
PRINTSTRING(" BECOMES ")
PHEX(VALUE)
NEWLINE
RETURN
INVAL:
PRINTSTRING("INVALID ADDRES ")
PHEX(START); NEWLINE
END ; ! SBYTE
INTEGERFN MEMTYPE(STRING (15) MASTER,STRING (8) MEMBER)
INTEGER FLAG
STRING (31) FILE
RECORD R(CONRECF)
FILE=MASTER."_".MEMBER
CONNECT(FILE,0,X'40000',0,R,FLAG)
CONNFLAG(FILE,FLAG)
RESULT =-1 IF FLAG#0
RESULT =R_FILETYPE
END ; ! MEMTYPE
!
RECORDFORMAT PDSHF(INTEGER NEXTFREEBYTE,DATAST,MAXBYTES,TYPE6, C
DATE,TIME,DIRRELST,FILECOUNT)
!
RECORDFORMAT PDSDIRF(INTEGER FILERELST,STRING (11) NAME, C
INTEGER P4,P5,P6,P7)
!
ROUTINE SORT FILES(RECORDARRAYNAME P,INTEGERARRAYNAME X,INTEGER NUM)
! DECLARE INTEGER ARRAY X, BOUNDS 1:NUM, IN CALLING ROUTINE
RECORDSPEC P(PDSDIRF)
INTEGER I, J, HIT, N
CYCLE I=1, 1, NUM
X(I)=I
REPEAT
CYCLE I=NUM-1, -1, 1
HIT=0
CYCLE N=1, 1, I
IF P(X(N))_NAME>P(X(N+1))_NAME START
J=X(N)
X(N)=X(N+1)
X(N+1)=J
HIT=1
FINISH
REPEAT
IF HIT=0 THENEXIT
REPEAT
END ; ! SORT FILES
!
EXTERNALINTEGERFN FILETYPE(STRING (63) FILE)
RECORD R(CONRECF)
STRING (63) MAS,MEM,FI,OWN
INTEGER FLAG
! CONNECT IN A SUITABLE MODE
FLAG=1
IF 0<LENGTH(FILE)<=31 THEN CONNECT(FILE,0,X'40000',0,R,FLAG)
CONNFLAG(FILE,FLAG)
RESULT =-1 IF FLAG#0
RESULT =R_FILETYPE
END ; ! FILETYPE
!--------------------------------------------------------------------------------
EXTERNALROUTINE PD INSERT(STRING (63) S)
STRING (31) MAS,MEM,OWNER
INTEGER NUM
NUM=0
WHILE SEPARATE(S)#"" CYCLE
NUM=NUM+1
UNLESS S->MAS.("_").MEM THEN -> BP
! Allow also the form PDINSERT(pdfile_owner.member) meaning
! COPY(owner.member,pdfile_member).
IF MEM->OWNER.(".").MEM THEN C
S=MAS."_".MEM AND MEM=OWNER.".".MEM
IF EXIST(S)#0 START
PRINTSTRING(S.": MEMBER ALREADY EXISTS
")
-> E1
FINISH
COPY(MEM.",".S)
CHERISH(MAS)
REPEAT
RETURN
BP:
PRINTSTRING("BAD PARAM"); WRITE(NUM,1); NEWLINE
E1:
WHILE SEPARATE(S)#"" CYCLE ;REPEAT
END ; ! PD INSERT
!--------------------------------------------------------------------------------
EXTERNALROUTINE REPLACE(STRING (63) S)
STRING (31) MAS,MEM
INTEGER NUM
NUM=0
NEXT=-1
WHILE SEPARATE(S)#"" CYCLE
NUM=NUM+1
UNLESS S->MAS.("_").MEM THEN -> BP
IF EXIST(S)=0 START
PRINTSTRING(S.": MEMBER DOES NOT EXIST
")
-> E1
FINISH
IF FILETYPE(MEM)=FILETYPE(S) THEN C
COPY(MEM.",".S) ELSE C
PRINTSTRING(S.": FILE-TYPE MIS-MATCH
")
CHERISH(MAS)
REPEAT
RETURN
BP:
PRINTSTRING("BAD PARAM"); WRITE(NUM,1); NEWLINE
E1:
WHILE SEPARATE(S)#"" CYCLE ; REPEAT
END ; ! REPLACE
!--------------------------------------------------------------------------------
EXTERNALROUTINE EXTRACT(STRING (63) S)
STRING (31) MAS,MEM
INTEGER NUM
NUM=0
NEXT=-1
WHILE SEPARATE(S)#"" CYCLE
NUM=NUM+1
UNLESS S->MAS.("_").MEM THEN -> BP
IF EXIST(S)=0 START
PRINTSTRING(S.": MEMBER DOES NOT EXIST
")
-> E1
FINISH
IF EXIST(MEM)#0 START
PRINTSTRING("FILE ALREADY EXISTS
")
RETURN
FINISH
COPY(S.",".MEM)
REPEAT
RETURN
BP:
PRINTSTRING("BAD PARAM"); WRITE(NUM,1); NEWLINE
E1:
WHILE SEPARATE(S)#"" CYCLE ; REPEAT
END ; ! EXTRACT
!--------------------------------------------------------------------------------
EXTERNALROUTINE BEL(STRING (255) T)
INTEGER J
CYCLE J=1,1,8
PRINTCH(7); SPACES(7)
REPEAT
NEWLINE
END ; ! BEL
OWNINTEGER FIRSTB=0; ! SHOULD BE SET TO ADDR OF FIRST TEXT BYTE OF FILE
OWNINTEGER LASTB=0; ! SHOULD BE SET TO ADDR OF BYTE
! FOLLOWING LAST BYTE OF FILE
OWNINTEGER CURP=0; ! SHOULD BE SET TO SEARCH START ADDRESS
! LOCATE - RESULT = -1 NOT FOUND IN ¬4K BYTES
! 0 NOT FOUND IN FILE
! 1 FOUND, CURP POINTS TO TEXT
INTEGERFN LOCATE(STRING (71) S)
!
! THIS FUNCTION USES GLOBALS CURP (SEARCH START ADDRESS, UPDATED)
! LASTB (ADDRESS OF BYTE FOLLOWING LAST
! BYTE OF FILE)
!
! RETURNS RESULT 1 STRING S FOUND, CURP POINTS TO IT
! 0 STRING S NOT FOUND AT ALL IN FILE, CURP=LASTB
! -1 STRING S NOT FOUND IN ABOUT 1 PAGE FROM STARTING
! CURP. CURP POINTS TO WHERE SEARCH CAN RESUME.
!
!*THE FUNCTION USES THE MACHINE CODE INSTRUCTIONS SWNE AND CPS. *
!*SWNE IS USED TO FIND THE FIRST CHARACTER OF THE REQUESTED TEXT. *
! THEN CPS IS USED TO TEST FOR THE REST OF THE TEXT.
INTEGER LENB,TLEN,CH1,LIM,AS1,B
INTEGER DR0, DR1, ACC0, ACC1; !DR0-DR1 AND ACC0-ACC1 MUST STAY AS PAIRS
LIM=CURP+4096
LIM=LASTB IF LIM>LASTB
AS1=ADDR(S)+1
TLEN =LENGTH(S); !NO OF CHAS TO BE TESTED
CH1 = BYTEINTEGER(AS1); !CH1 CHAR TO BE FOUND
AGAIN:LENB =LIM-CURP+1; !NUMBER LEFT IN CURRENT RECORD
!LOOK FOR CH1 CHARACTER
!SWNE INS REQUIRES B REGISTER TO CONTAIN MASK IN BITS 16-23
!AND REF BYTE IN BITS 24-31. DR MUST CONTAIN A DESCRIPTOR
!TO THE STRING TO BE SEARCHED
B = CH1; !MASK(0)<<8 ! TEST CHAR
DR0 = X'58000000'!LENB; !STRING DESCRIPTOR
DR1 = CURP; !ADDRESS OF STRING
*LB_B; !LOAD B REGISTER
*LD_DR0; !LOAD DESCRIPTOR REGISTER
*PUT_X'A300'; !*SWNE_X'100' SCAN WHILE NOT EQUAL
!CONDITION CODE NOW SET AS FOLLOWS
!0 REF BYTE NOT FOUND
!1 REF BYTE FOUND - ADDRESS IN BOTTOM OF DR
*JCC_8,<FIRSTNOTFOUND>; !JUMP IF NOT FOUND
*STD_DR0; !STORE DESCRIPTOR REGISTER
CURP = DR1; !POSSIBLE FIRST BYTE
!NOW DEAL WITH SINGLE CHARACTER SEARCH
IF TLEN = 1 THEN -> FOUND; !FIRST AND ONLY CHARACTER MATCHED OK
!NOW NEED TO COMPARE REST OF TEXT
!IF ENOUGH TEXT IN BEFORE EOF USE CPS INSTRUCTION ELSE NOT FOUND AT ALL
IF LASTB-CURP+1< TLEN THEN CURP=LASTB AND RESULT =0; ! NOT FOUND AT ALL
!CPS(COMPARE STRINGS) INSTRUCTION REQUIRES DESCRIPTORS TO TWO
!STRINGS IN DR AND ACC
DR0 = X'58000000'!(TLEN-1); !NO NEED TO TEST FIRST CHAR AGAIN
DR1 = AS1+1; !START OF STRING TO BE TESTED
ACC0 = DR0
ACC1 = CURP+1; !POSSIBLE SECOND CHARACTER
*LD_DR0; !LOAD DESCRIPTOR REGISTER
*LSD_ACC0; !SET ACS TO 64 AND LOAD
*PUT_X'A500'; !*CPS_X'100' COMPARE STRINGS
!CONDITION CODE NOW 0 IF STRINGS EQUAL
*JCC_8,<FOUND>; !JUMP IF EQUAL
!INCREMENT CURP AND TRY ALL OVER AGAIN
CURP = CURP+1; !CANNOT HIT END OF SEGMENT BECAUSE STRING CONTAINS AT LEAST 2 CHAS
-> AGAIN; !TRY AGAIN
FOUND: !THIS IS EXIT FOR SIMPLE CASE WHERE ALL TEXT IN ONE SEGMENT
RESULT =1; ! FOUND
FIRSTNOTFOUND:
CURP=LIM
IF CURP=LASTB THEN RESULT =0; ! NOT FOUND AT ALL
RESULT =-1; ! NOT FOUND IN ABOUT 4K
END ; ! LOCATE
ROUTINE ENDLINE
! MOVES CURP TO NEXT NL (IF NOT ALREADY POINTING TO A NL)
WHILE BYTEINTEGER(CURP)#NL THEN CURP=CURP+1
END ; ! ENDLINE
ROUTINE STARTLINE
! MAKES SURE BYTE BEFORE CURP IS NL, OR STEPS BACK TILL IT IS
IF CURP>FIRSTB AND BYTEINTEGER(CURP-1)#NL START
UNTIL BYTEINTEGER(CURP-1)=NL OR CURP<=FIRSTB C
THEN CURP=CURP-1
FINISH
END ; ! STARTLINE
ROUTINE PREVLINE
! MOVES CURP BACK TO START OF PREVIOUS LINE (IF ANY)
STARTLINE
CURP=CURP-1 IF CURP>FIRSTB
STARTLINE
END ; ! PREVLINE
ROUTINE NEXTLINE
! MOVES CURP TO 1ST BYTE OF NEXT LINE (OR PREV NL IF LINE NULL)
ENDLINE
CURP=CURP+1
END ; ! NEXTLINE
ROUTINE PRINTLINE
INTEGER J
STARTLINE; ! TO 1ST BYTE OF LINE (OR PREV NL IF NULL)
J=CURP
UNTIL BYTEINTEGER(J-1)=NL CYCLE
PRINTSYMBOL(BYTEINTEGER(J)) UNLESS BYTEINTEGER(J-1)=' ' C
AND BYTEINTEGER(J)=' '
J=J+1
REPEAT
END ; ! PRINTLINE
ROUTINE DOUBLE U OUT(STRINGNAME S)
STRING (255) W
INTEGER AS
INTEGER I,CH1,CH2
RETURN IF S=""
AS=ADDR(S)
I=1
W=""
UNTIL I>LENGTH(S) CYCLE
CH1=BYTEINTEGER(AS+I)
CH2=BYTEINTEGER(AS+I+1)
IF I>LENGTH(S) THEN CH2=0
IF CH1='_'=CH2 THEN I=I+1 AND CH1=' '
W=W.TOSTRING(CH1)
I=I+1
REPEAT
S=W
END ; ! DOUBLE U OUT
INTEGERFN LINEAD(INTEGER FAD,LINE1)
! RETURNS ADDRESS OF CODE FOR LINE1 IN FILE AT ADDRESS FILE, OR ZERO IF NOT FOUND
RECORDNAME H(OBJF)
INTEGER TIMES,MAX LNB VALUE
INTEGER IT0,IT1,RELST,ERR,J
INTEGERFNSPEC ST INSTR(INTEGER PLUS)
H==RECORD(FAD)
RELST=FAD+H_CODERELST
CURP=RELST
LASTB=FAD+H_NEXTFREEBYTE
! MAKE SUITABLE STRINGS FOR THE SEARCHES, IN IT0,IT1 AND ST0,ST1
IT0=4
IT1=X'63800000' ! LINE1
IF LINE1<=63 START
IT0=2
IT1=X'62000000' ! (LINE1<<16)
FINISH
!
! HAVE TWO SHOTS AT EACH LINE WITH INCREASED MAX LNB VALUE FOR THE
! SECOND TRY
!
ERR=1
MAX LNB VALUE=12
CYCLE TIMES=0,1,1
CURP=RELST
CYCLE
CURP=CURP+1
J=LOCATE(STRING(ADDR(IT0)+3))
IF J=0 START
IF TIMES=0 THEN EXIT ELSE RESULT =0
FINISH
IF J=1 AND ST INSTR(IT0)#0 THEN RESULT =CURP; ! FOUND
REPEAT
MAX LNB VALUE=127
REPEAT
PRINTSTRING("SHOULD NOT GET HERE
")
RESULT =0
INTEGERFN ST INSTR(INTEGER PLUS)
! RESULT = 1 IF NEXT HALFWORD IS A SUITABLE "STORE" INSTRUCTION
! 0 OTHERWISE
INTEGER NEXTHALFWORD,PT
PT=CURP + PLUS
RESULT =0 IF PT>=LASTB
IF PT&1#0 THEN RESULT =0
IF PT&3=0 THEN NEXTHALFWORD=INTEGER(PT)>>16 C
ELSE NEXTHALFWORD=INTEGER(PT-2)&X'FFFF'
UNLESS X'4885'<=NEXTHALFWORD C
<=X'4880'!MAX LNB VALUE THEN RESULT =0
RESULT =1
END ; ! ST INSTR
END ; ! LINEAD
EXTERNALROUTINE RECODE LINES(STRING (255) S)
CONSTINTEGER MAXOFF=7
INTEGER SIGN,OFFX
RECORDNAME H(OBJF)
STRING (31) FILE,SL1,SL2,DEVS
INTEGER LINE1,LINE2,FAD,RELST,AD1,AD2,ERR,J,REQL1,REQL2
FILE=S; SL1=""; SL2=""; DEVS=""
IF S->FILE.(",").SL1 START ; FINISH
IF SL1->SL1.(",").SL2 START ;FINISH
IF SL2->SL2.(",").DEVS START ;FINISH
IF SL1#""#SL2 AND DEVS="" THEN DEVS=".OUT"
PROMPT("FILE: ")
WHILE LONG CFN(FILE)#0 THEN RSTRG(FILE)
FAD=RDFILEAD(FILE)
RETURN IF FAD=0
H==RECORD(FAD)
RELST=FAD+H_CODERELST
CURP=RELST
LASTB=FAD+H_NEXTFREEBYTE
PROMPT("START LINE NO: ")
LINE1=BIN(SL1)
IF LINE1=X'80308030' THEN RDINT(LINE1)
LINE2=BIN(SL2)
PROMPT("END LINE NO: ")
IF LINE2=X'80308030' THEN RDINT(LINE2)
PROMPT("TO FILE/DEV: ")
WHILE ".OUT"#DEVS AND FROMSTR(DEVS,1,3)#".LP" AND C
CFN(DEVS)#0 THEN RSTRG(DEVS)
REQL1=LINE1
REQL2=LINE2
!---------------------------------------------------------------
OFFX=0
SIGN=1
UNTIL AD1>0 OR OFFX>MAXOFF CYCLE
LINE1=LINE1+SIGN*OFFX
AD1=LINEAD(FAD,LINE1)
SIGN=-SIGN
OFFX=OFFX+1
REPEAT
IF AD1=0 THEN LINE1=REQL1; ! set back to requested value
PRINTSTRING("Line")
WRITE(LINE1,1)
SPACES(2)
PRINTSTRING(HTOS(LINE1,5))
IF AD1=0 THEN PRINTSTRING(" not")
PRINTSTRING(" found")
NEWLINE
!-------------------------------------------------------------------------
OFFX=0
SIGN=1
UNTIL AD1>0 OR OFFX>MAXOFF CYCLE
LINE2=LINE2+SIGN*OFFX
AD2=LINEAD(FAD,LINE2)
SIGN=-SIGN
OFFX=OFFX+1
REPEAT
IF AD2=0 THEN LINE2=REQL2; ! set back to requested value
PRINTSTRING("Line")
WRITE(LINE2,1)
SPACES(2)
PRINTSTRING(HTOS(LINE2,5))
IF AD2=0 THEN PRINTSTRING(" not")
PRINTSTRING(" found")
NEWLINES(3)
IF AD1=0=AD2 THEN RETURN ELSE START
IF AD1=0 THEN AD1=AD2-64
IF AD2=0 THEN AD2=AD1+64
FINISH
!-----------------------------------------------------------------------
DEFINE("65,".DEVS)
SELECT OUTPUT(65)
IF DEVS#".OUT" START
PRINTSTRING("DUMPED FROM FILE: ")
PRINTSTRING(FILE)
SPACES(5)
PRINTSTRING(DATE." ".TIME)
NEWLINES(2)
FINISH
NCODE(AD1,AD2,AD1)
SELECT OUTPUT(0)
CLOSE STREAM(65)
CLEAR("65")
RETURN
!
NOTF:
S="START"
J=LINE1
IF ERR=2 THEN S="END" AND J=LINE2
PRINTSTRING(S)
PRINTSTRING(" LINE NO")
WRITE(J,1)
PRINTSTRING(" NOT FOUND
")
RETURN
END ; ! RECODE LINES
EXTERNALROUTINE EXFILE(STRING (135) S)
RECORDNAME H1(SRCF)
RECORDNAME H2(SRCF)
INTEGER FLAG,COPY FROM,COPY TO,IN,OUT,J
STRING (63) FILE,OUTFN,OUTDEV
SWITCH LOC1(-1:1)
SWITCH LOC2(-1:1)
STRING (127) TEXT1,TEXT2,HEADER
INTEGER LEN,OUTFPGS,PAR
!
PAR=1
OUTFN=".LP"
OUTDEV=".LP"
IF S="" THEN -> GETIPS
IF S->FILE.(",").TEXT1 START
UNLESS CFN(FILE)=0 THEN -> BP
PAR=2
IF TEXT1->TEXT1.(",").TEXT2 START
PAR=3
! NOW SEE IF THERE IS AN OUTPUT FILE SPECIFIED
IF TEXT2->TEXT2.(",").OUTFN START
PAR=4
UNLESS FROMSTR(OUTFN,1,3)=".LP" OR CFN(OUTFN)=0 C
THEN -> BP
FINISH
DOUBLE U OUT(TEXT1)
DOUBLE U OUT(TEXT2)
-> READY
FINISH
FINISH
BP:
PRINTSTRING("BAD/MISSING PARAM")
WRITE(PAR,1); NEWLINE
RETURN
GETIPS:
PROMPT("FILE: ")
RSTRG(FILE) UNTIL RDFILEAD(FILE)>0
PROMPT("TEXT1:")
INSTRG(TEXT1)
! GET TEXT2
PROMPT("TEXT2:")
INSTRG(TEXT2)
! GET OUT FILE NAME
PROMPT("OUTFILE: ")
INSTRG(OUTFN) UNTIL OUTFN="" OR FROMSTR(OUTFN,1,3)=".LP" C
OR CFN(OUTFN)=0
!
READY:
IF FROMSTR(OUTFN,1,3)=".LP" THEN OUTDEV=OUTFN C
AND OUTFN="SS#KLP"
IN=RDFILEAD(FILE)
RETURN IF IN<=0
H1==RECORD(IN)
OUTFPGS=(H1_NEXTFREEBYTE+4095)>>12
OUT=NWFILEAD(OUTFN,OUTFPGS)
RETURN IF OUT<=0
H2==RECORD(OUT)
!
!
!----------------------------- PHASE ONE -----------------------------
CURP=IN + H1_TXTRELST
LASTB=IN + H1_NEXTFREEBYTE
IF TEXT1="" THEN COPY FROM=CURP AND -> FIND END
LOC1(-1): ! TEXT1 NOT FOUND WITHIN ABOUT 1 PAGE. CONTINUE.
-> LOC1(LOCATE(TEXT1))
!
LOC1(1): ! CURP POINTS TO TEXT1. FIND PRECEDING NEWLINE
J=CURP
IF BYTEINTEGER(J-1)#NL START
UNTIL BYTEINTEGER(J-1)=NL OR J<=IN+H1_TXTRELST THEN J=J-1
FINISH
COPY FROM=J
! SET POINTER ONE BYTE PAST THIS TEXT SO THAT IF TEXT2 IS IDENTICAL
! WITH TEXT1 WE FIND THE NEXT (RATHER THAN THE SAME) OCCURRENCE OF IT IN
! PHASE TWO
CURP=CURP+1
!
!
!------------------------------- PHASE TWO ---------------------------
FIND END:
! COPY FROM IS SET UP. FIND TEXT2, IE. END OF AMOUNT TO COPY
!
! PUT FILENAME D+T HERE
HEADER="
EXTRACT FROM FILE: ".FILE." ".DATE." ".TIME."
"
COPY TO=OUT + 16
STRING(COPY TO - 1)=HEADER
BYTEINTEGER(COPY TO - 1)=0
COPY TO=COPY TO + LENGTH(HEADER)
!
IF TEXT2="" START
LEN=LASTB - COPY FROM
-> TIDYUP
FINISH
!
LOCATE TEXT2:
-> LOC2(LOCATE(TEXT2))
!
LOC2(1): ! TEXT2 FOUND. CURP POINTS TO IT.
! FIND END OF LINE CONTAINGING TEXT2
J=CURP
UNTIL BYTEINTEGER(J)=NL THEN J=J+1
LEN=J+1-COPYFROM
-> TIDYUP
!
LOC2(-1): ! TEXT2 NOT FOUND WITHIM ABOUT 1 PAGE. COPY AND CONTINUE
LEN=CURP - COPY FROM
MOVE(LEN,COPY FROM,COPY TO)
COPY FROM=CURP
COPY TO=COPY TO + LEN
-> LOCATE TEXT2
!
TIDYUP:
MOVE(LEN,COPY FROM,COPY TO)
COPY TO=COPY TO + LEN
H2_NEXTFREEBYTE=COPY TO - OUT
H2_TXTRELST=16
H2_MAXLEN=(H2_NEXTFREEBYTE + X'FFF') & X'FFFFF000'
H2_ZERO=0
! REDUCE FILE SIZE (PHYSICAL) TO MINIMUM
CHANGEFILESIZE(OUTFN,H2_MAXLEN,FLAG)
IF FLAG#0 START
PRINTSTRING("CHANGEFILESIZE FLAG =")
WRITE(FLAG,1); NEWLINE
FINISH
! PRINTSTRING("H2_NEXTFREEBYTE=")
! PHEX(H2_NEXTFREEBYTE)
! PRINTSTRING(" FILE PHYSICAL SIZE=")
! PHEX(J)
! NEWLINE
IF OUTFN="SS#KLP" THEN SEND(OUTFN.",".OUTDEV)
RETURN
!
LOC1(0): ! TEXT1 NOT FOUND IN FILE
PRINTSTRING("TEXT1 """.TEXT1.""" NOT FOUND")
NEWLINE
RETURN
!
LOC2(0): ! TEXT2 NOT FOUND IN FILE
PRINTSTRING("TEXT2 """.TEXT2.""" NOT FOUND")
NEWLINE
RETURN
END ; ! EXFILE
!--------------------------------------------------------------------------------
INTEGERFN FTEXTF(INTEGER FAD,INTEGERNAME GOON, C
STRING (255) TEXT)
INTEGER J
INTEGER CT
RECORDNAME HS(SRCF)
SWITCH STAT(-1:1)
CT=3
HS==RECORD(FAD)
IF HS_ZERO#0 THEN -> OBJ
FIRSTB=FAD+HS_TXTRELST
LASTB=FAD+HS_NEXTFREEBYTE
IF FIRSTB=LASTB START
PRINTSTRING("FILE EMPTY
")
RESULT =0; ! BAD
FINISH
CURP=FAD+HS_TXTRELST
CURP=GOON IF GOON>0
!
STAT(-1):
-> STAT(LOCATE(TEXT))
STAT(1):
NEWLINE
PREVLINE
CYCLE J=1,1,CT
PRINTLINE
NEXTLINE
REPEAT
NEWLINE
GOON=CURP
RESULT =1; ! OK
STAT(0):
RESULT =0; ! BAD
OBJ:
PRINTSTRING("NOT CHAR FILE
")
RESULT =0; ! BAD
END ; ! FTEXTF
!--------------------------------------------------------------------------------
EXTERNALROUTINE DELI(STRING (255) T)
INTEGER N,SPS
STRING (63) S
PROMPT("DELIVER: ")
RSTRG(S)
SPS=(19 - LENGTH(S))>>1
N=0
WHILE N<SPS CYCLE
S=" ".S." "
N=N+1
REPEAT
DELIVER(S)
END ; ! DELI
!--------------------------------------------------------------------------------
EXTERNALROUTINE LI(STRING (63) S)
NEXT=-1
LIST(S.",.LP") WHILE SEPARATE(S)#""
END ; ! LI
ROUTINE ADDNP(STRING (63) FILE)
INTEGER FAD
RECORDNAME H(SRCF)
FAD=WRFILEAD(FILE)
RETURN IF FAD=0
H==RECORD(FAD)
IF H_ZERO#0 START
PRINTSTRING("NOT A CHAR FILE
")
RETURN
FINISH
BYTEINTEGER(FAD+H_NEXTFREEBYTE)=12; ! NEWPAGE
H_NEXTFREEBYTE=H_NEXTFREEBYTE+1
END ; ! ADDNP
EXTERNALINTEGERFN CONCF(STRING (255) S)
! INTENDED TO BE ASUBSTITUTE FOR "CONCAT", ALLOWING THE PARAMS
! "FILE1,FILE2, /OUTFILE"
!
! RESULT = 0 SUCCESSFUL
! 1 SOME ERROR (MESSAGE ALREADY PRINTED)
RECORD R1(FINFRECF)
STRING (1) SEPR
STRING (255) SAV
STRING (31) OUT,OUT1
INTEGER BYTES,AD1,AD2,FLAG,LEN,PGS,NP
RECORDNAME H1(SRCF)
RECORDNAME H2(SRCF)
UNLESS S->S.("/").OUT START
S=""; SEPR=","
PROMPT("CONC: ")
CYCLE
RSTRG(SAV)
IF SAV=".E" OR SAV=".END" START
SEPR="/"
PROMPT("TO FILE: ")
RSTRG(SAV)
FINISH
IF RDFILEAD(SAV)=0 THEN -> CONTINUE
S=S.SEPR IF LENGTH(S)>0
S=S.SAV
EXIT IF SEPR="/"
CONTINUE:
REPEAT
FINISH
OUT1=""; ! SET TO OUT FILE WHEN OUT=ONE OF THE IN FILES
NP=0
IF OUT-> OUT.(",NP") OR OUT->OUT.(",.NP") THEN NP=1
SAV=S
BYTES=0
NEXT=-1
WHILE SEPARATE(S)#"" CYCLE
IF S=OUT START
OUT1=OUT
OUT="SS#CON"
FINISH
FINFO(S,1,R1,FLAG)
IF FLAG#0 START
PRINTSTRING(S." FINFO FLAG =")
WRITE(FLAG,1); NEWLINE; RESULT =1
FINISH
BYTES=BYTES+R1_SIZE
REPEAT
PGS=(BYTES+X'FFF')>>12
AD2=NWFILEAD(OUT,PGS)
RESULT =1 IF AD2=0
H2==RECORD(AD2)
H2_NEXTFREEBYTE=32
H2_TXTRELST=32
H2_MAXLEN=PGS<<12
H2_ZERO=0
S=SAV
WHILE SEPARATE(S)#"" CYCLE
AD1=RDFILEAD(S)
RESULT =1 IF AD1<=0
H1==RECORD(AD1)
LEN=H1_NEXTFREEBYTE - H1_TXTRELST
MOVE(LEN,AD1+H1_TXTRELST,AD2+H2_NEXTFREEBYTE)
H2_NEXTFREEBYTE=H2_NEXTFREEBYTE + LEN
IF NP#0 START
BYTEINTEGER(AD2+H2_NEXTFREEBYTE)=12
H2_NEXTFREEBYTE=H2_NEXTFREEBYTE+1
FINISH
REPEAT
IF OUT1#"" THEN NEWGEN("SS#CON,".OUT1)
RESULT =0
BP:
PRINTSTRING("PARAMS ?
")
RESULT =1
END ; ! CONCF
!--------------------------------------------------------------------------------
EXTERNALROUTINE CONC(STRING (79) S)
INTEGER J
J=CONCF(S)
END ; ! CONC
! THESE FUNCTIONS ALL USE A PACKED FORMAT OF DATE AND TIME OF THE
! FOLLOWING FORM. BITS ARE NUMBERED FROM 31 (MOST SIGNIFICANT) TO
! 0 (LEAST SIGNIFICANT)
! BITS USE
! 31-26 YEAR-70 (VALID FOR 1970-2033)
! 25-22 MONTH
! 21-17 DAY
! 16-12 HOUR
! 11- 6 MINUTE
! 5- 0 SECOND
!
STRINGFN S2(INTEGER N)
!THIS FUNCTION RETURNS A TWO DIGIT DECIMAL VALUE FOR N
INTEGER TENS, UNITS
TENS = N//10
UNITS = N-10*TENS
RESULT = TOSTRING(TENS+'0').TOSTRING(UNITS+'0')
END ; !OF S2
STRINGFN UNPACKDATE(INTEGER P)
RESULT = S2(P>>17&X'1F')."/".S2(P>>22&X'F')."/".S2((P>>26& C
X'3F')+70)
END ; !OF UNPACKDATE
STRINGFN UNPACKTIME(INTEGER P)
RESULT = S2(P>>12&X'1F').".".S2(P>>6&X'3F').".".S2(P&X'3F')
END ; !OF UNPACKTIME
STRINGFN CDATE(INTEGER FAD)
RECORDNAME HO(OBJF)
HO==RECORD(FAD)
! 1ST CONDITION BELOW IS TO EXCLUDE THE FUNNY FILES PRODUCED BY
! SUPFIX ETC. (FOR THE 2970).
UNLESS HO_TYPE1=1 START
RESULT ="NOT OBJ FILE
"
FINISH
RESULT =UNPACKDATE(HO_DT)." ".UNPACKTIME(HO_DT)." "
END ; ! CDATE
INTEGERFN DIFFERENT(INTEGER LEN,A,B)
INTEGER DR0,DR1,AC0,AC1
DR0=X'58000000' ! LEN
DR1=A
AC0=DR0
AC1=B
*LD_DR0
*LSD_AC0
*PUT_X'A500'; ! CPS
*JCC_8,<EQUAL>
RESULT =1; ! DIFFERENT
EQUAL:
RESULT =0; ! SAME
END ; ! DIFFERENT
INTEGERFN LEXIST(STRING (8) MEM,INTEGER DIRAD,CT)
! RESULT IS 1 IF A LISTING FILE EXISTS FOR THIS SRC FILENAME
! ELSE RESULT 0.
BYTEINTEGERNAME CH
INTEGER J
RECORDARRAYFORMAT DIRARRF(1:255)(PDSDIRF)
RECORDARRAYNAME D(PDSDIRF)
D==ARRAY(DIRAD,DIRARRF)
CH==BYTEINTEGER(ADDR(MEM)+LENGTH(MEM))
IF CH='S' THEN CH='L' ELSE START
RESULT =0 IF LENGTH(MEM)=8
MEM=MEM."L"
FINISH
CYCLE J=1,1,CT
IF D(J)_NAME=MEM THEN RESULT =1
REPEAT
RESULT =0
END ; ! LEXIST
INTEGERFN SEARCHF(INTEGER ALL,STRING (79) TEXT,MASTER)
! SEARCHES FOR "TEXT" IN PDFILE "MASTER" (WHICH MAY BE A SEQUENCE OF
! PDFILENAMES SEPARATED BY COMMAS.
! FOR ALL = 0
! RESULT = 1 FOUND
! 0 NOT FOUND
! FOR ALL = 1, CONTINUE TO FIND ALL OCCURRENCES
INTEGER TYPE,J
SWITCH MP(0:6)
CONSTBYTEINTEGER NONSTD=0
CONSTINTEGER OBJ=1
CONSTINTEGER LIB=2
CONSTINTEGER CHAR=3
CONSTINTEGER DAT=4
CONSTINTEGER MAP=5
CONSTINTEGER PART=6
STRING (63) MEMBER
STRING (31) FULLMEM NAME
RECORDNAME H1(OBJF)
RECORDNAME H(PDSHF)
RECORDARRAYFORMAT DIRARRF(1:255)(PDSDIRF)
RECORDARRAYNAME D(PDSDIRF)
!
! FOR THE ALPHA SORT
INTEGERARRAY X(1:255)
!
INTEGER PAD,FC,MTYPE,F1,FOUND,GOON
NEXT=-1
WHILE SEPARATE(MASTER)#"" CYCLE
! NEWLINES(3)
NEWLINES(2)
PAD=RDFILEAD(MASTER)
IF PAD=0 THEN -> NEXT MASTER
TYPE=FILETYPE(MASTER)
PRINTSTRING(MASTER); NEWLINE
IF TYPE=CHAR START
GOON=0
J=FTEXTF(PAD,GOON,TEXT)
IF J#0 START
PRINTSTRING("FOUND
")
RESULT =0
FINISH
PRINTSTRING("NOT FOUND
")
-> NEXTMASTER
FINISH
H==RECORD(PAD)
UNLESS H_TYPE6=6 START
! TYPE IS 13 FOR PDFILE, ALTHOUGH TYPE RETURNED BY RT
! CONMEMBER IS 6.
PRINTSTRING(MASTER." IS NOT PARTIONED OR CHAR
")
-> NEXTMASTER
FINISH
IF H_FILECOUNT>255 START
PRINTSTRING("TOO MANY FILES FOR TSEARCH
")
-> NEXTMASTER
FINISH
D==ARRAY(PAD + H_DIRRELST,DIRARRF)
SORT FILES(D,X,H_FILECOUNT)
FC=0
WHILE FC<H_FILECOUNT CYCLE ; ! MEMBERS
! 32-BYTE ENTRIES
FC=FC+1
MEMBER=D(X(FC))_NAME
FULLMEM NAME=MASTER."_".MEMBER
MTYPE=MEMTYPE(MASTER,MEMBER)
UNLESS 0<=MTYPE<=6 THEN MTYPE=0
F1=RDFILEAD(FULLMEM NAME)
-> MCONT IF F1=0
H1==RECORD(F1)
-> MP(MTYPE)
MP(3): ! CHARACTER
SPACES(3)
PRINTSTRING(MEMBER)
! SKIP SRC MEM IF A LISTING MEM EXISTS..
IF LEXIST(MEMBER,PAD+H_DIRRELST,H_FILECOUNT)#0 THEN -> MCONT
SPACES(3)
FOUND=0
GOON=0
UNTIL FOUND=0 CYCLE
FOUND=FTEXTF(F1,GOON,TEXT)
IF FOUND=0 THEN PRINTSTRING("NOT FOUND
")
IF ALL=0 AND FOUND#0 THEN PRINTSTRING("FOUND
") AND RESULT =1
REPEAT
-> MCONT
MP(1): ! OBJECT
MP(2): MP(4): MP(5): MP(6):
MCONT:
MP(0): ! NON-STANDARD
NEWLINE
REPEAT ; ! MEMEBSER
NEXTMASTER:
REPEAT
!------------------------------------------------------------------
IF ALL=0 THEN PRINTSTRING("""".TEXT.""" NOT FOUND
")
RESULT =0
END ; ! SEARCHF
!--------------------------------------------------------------------------------
EXTERNALROUTINE TSEARCH(STRING (79) S)
STRING (79) TEXT,FILE
INTEGER J
IF S="" START
PROMPT("TEXT:")
RSTRG(TEXT)
PROMPT("FILE/.END: ")
UNTIL FILE=".END" OR SEARCHF(0,TEXT,FILE)#0 THEN RSTRG(FILE)
RETURN
FINISH
UNLESS S->TEXT.(",").FILE START
PRINTSTRING("PARAMS ?
")
RETURN
FINISH
DOUBLE U OUT(TEXT)
J=SEARCHF(0,TEXT,FILE)
END ; ! TSEARCH
!--------------------------------------------------------------------------------
EXTERNALROUTINE TSEARCHALL(STRING (79) S)
STRING (79) TEXT,FILE
INTEGER J
IF S="" START
PROMPT("TEXT:")
RSTRG(TEXT)
PROMPT("FILE/.END: ")
UNTIL FILE=".END" OR SEARCHF(1,TEXT,FILE)=-1 THEN RSTRG(FILE)
! (IT NEVER IS -1)
RETURN
FINISH
UNLESS S->TEXT.(",").FILE START
PRINTSTRING("PARAMS ?
")
RETURN
FINISH
DOUBLE U OUT(TEXT)
J=SEARCHF(1,TEXT,FILE)
END ; ! TSEARCHALL
!--------------------------------------------------------------------------------
EXTERNALROUTINE PDCHECK(STRING (79) MASTER)
SYSTEMROUTINESPEC DISCONNECT(STRING (15) S,INTEGERNAME FLAG)
STRING (31)ARRAY DESS(0:39)
STRING (31)ARRAY REPS(0:39)
STRING (31)ARRAY FOR DISCONN(0:25)
INTEGER DPT,RPT,NF,RUBBISH,CURROUTSTREAM
SWITCH MP(0:6)
ROUTINESPEC MAKE FILE
ROUTINESPEC ENTER(INTEGER TYPE,STRING (17) S)
ROUTINESPEC PRINTNOT
ROUTINESPEC MULSYM(INTEGER SYM,MUL)
ROUTINESPEC HEAD(STRING (71) S)
CONSTINTEGER DESTR=53, REPLA=54
CONSTBYTEINTEGER NONSTD=0
CONSTINTEGER OBJ=1
CONSTINTEGER LIB=2
CONSTINTEGER CHAR=3
CONSTINTEGER DAT=4
CONSTINTEGER MAP=5
CONSTINTEGER PART=6
CONSTSTRING (11)ARRAY MTYPES(0:6)= C
"NONSTANDARD","OBJECT ","LIBRARY ","CHARACTER ","DATA ",
"STOREMAP ","PARTITIONED"
STRING (63) MEMBER,MEMFILE OWNER
STRING (31) FULLMEM NAME
STRING (31) S1,S2,OUTPUT
RECORDNAME H1,H2(OBJF)
RECORDNAME H(PDSHF)
RECORDARRAYFORMAT DIRARRF(1:255)(PDSDIRF)
RECORDARRAYNAME D(PDSDIRF)
!
! FOR THE ALPHA SORT
INTEGERARRAY X(1:255)
!
INTEGER PAD,FC,MTYPE,F1,F2,DIFF
CURROUTSTREAM=COMREG(23)
OUTPUT=""
IF MASTER->MASTER.("/").OUTPUT START
DEFINE("ST54,".OUTPUT)
SELECT OUTPUT(54)
FINISH
DEFINE("ST52,SS#DESRP")
DPT=0; RPT=0; NF=0
NEXT=-1
WHILE SEPARATE(MASTER)#"" CYCLE
NEWLINES(3)
HEAD("ANALYSIS OF PDFILE: ".MASTER)
NEWLINES(2)
MEMFILE OWNER=""
IF MASTER->MASTER.("(").MEMFILE OWNER START
UNLESS LENGTH(MEMFILE OWNER)=7 AND C
BYTEINTEGER(ADDR(MEMFILE OWNER)+7)=')' START
PRINTSTRING("INVALID MEMBER-FILE OWNER
")
-> NEXT MASTER
FINISH
LENGTH(MEMFILE OWNER)=LENGTH(MEMFILE OWNER)-1
FINISH
PAD=RDFILEAD(MASTER)
IF PAD=0 THEN -> NEXTMASTER
H==RECORD(PAD)
UNLESS H_TYPE6=6 START
PRINTSTRING(MASTER." IS NOT A PARTIONED FILE
")
-> NEXTMASTER
FINISH
PRINTSTRING( C
" (OBJECT)")
PRINTSTRING( C
" (OBJECT)
MEMBER TYPE FILE OF SAME NAME MEMBER COMPILED")
PRINTSTRING( C
" FILE COMPILED
")
IF H_FILECOUNT>255 START
PRINTSTRING("TOO MANY FILES FOR MASTERCHECK
")
-> NEXTMASTER
FINISH
D==ARRAY(PAD + H_DIRRELST,DIRARRF)
SORT FILES(D,X,H_FILECOUNT)
FC=0
WHILE FC<H_FILECOUNT CYCLE
! 32-BYTE ENTRIES
FC=FC+1
MEMBER=D(X(FC))_NAME
FULLMEM NAME=MASTER."_".MEMBER
PRINTSTRING(MEMBER)
SPACES(10-LENGTH(MEMBER))
MTYPE=MEMTYPE(MASTER,MEMBER)
UNLESS 0<=MTYPE<=6 THEN MTYPE=0
PRINTSTRING(MTYPES(MTYPE)." ")
F1=RDFILEAD(FULLMEM NAME)
-> MCONT IF F1=0
H1==RECORD(F1)
F2=0
IF MEMFILE OWNER#"" THEN MEMBER=MEMFILE OWNER.".".MEMBER
IF EXIST(MEMBER)=0 THEN PRINTNOT ELSE F2=RDFILEAD(MEMBER)
H2==RECORD(F2)
DIFF=1
-> MP(MTYPE)
MP(3): ! CHARACTER
-> MCONT IF F2=0; ! NOT EXIST
IF H1_NEXTFREEBYTE=H2_NEXTFREEBYTE THEN C
DIFF=DIFFERENT(H1_NEXTFREEBYTE,F1,F2)
IF DIFF#0 THEN COMPARE(MASTER."_".MEMBER.",".MEMBER.",.F") C
ELSE PRINTSTRING("COMPARISON COMPLETE") AND HAZARD(MEMBER)
-> MCONT
MP(1): ! OBJECT
SPACES(19) IF F2#0
S1<-CDATE(F1)
PRINTSTRING(S1)
-> MCONT IF F2=0
S2<-CDATE(F2)
IF S1#S2 START
SPACES(2)
PRINTSTRING(S2)
-> MCONT
FINISH
IF H1_NEXTFREEBYTE=H2_NEXTFREEBYTE THEN C
DIFF=DIFFERENT(H1_NEXTFREEBYTE,F1,F2)
IF DIFF=0 THEN PRINTSTRING("COMPARISON COMPLETE") C
ELSE PRINTSTRING("DIFFERENT")
-> MCONT
MP(2): MP(4): MP(5): MP(6):
-> MCONT IF F2=0
DIFF=DIFFERENT(H1_NEXTFREEBYTE,F1,F2)
IF DIFF=0 THEN PRINTSTRING("COMPARISON COMPLETE") C
ELSE PRINTSTRING("DIFFERENT")
-> MCONT
MCONT:
IF F2#0 START ; ! IE. FILE OF SAME NAME EXISTS
! ? REPLACE IF DIFFERENT ? DESTROY IF NOT DIFFERENT
IF DIFF=0 THEN ENTER(DESTR,MEMBER) ELSE C
ENTER(REPLA,FULLMEMNAME)
! COUNT FILES WHICH EXIST, DISCONNECT IF "TOO MANY"
FOR DISCONN(NF)=MEMBER
NF=NF + 1
IF NF>25 START
WHILE NF>0 CYCLE
NF=NF-1
DISCONNECT(FOR DISCONN(NF),RUBBISH)
REPEAT
FINISH
FINISH
MP(0): ! NON-STANDARD
NEWLINE
REPEAT
NEXTMASTER:
! CLEARVM
REPEAT
!------------------------------------------------------------------
IF OUTPUT#"" START
SELECT OUTPUT(CURROUTSTREAM); CLOSE STREAM(54)
CLEAR("54")
FINISH
MAKE FILE
NEWLINES(4)
PRINTSTRING("ANALYSIS COMPLETE
")
RETURN
ROUTINE MAKE FILE
INTEGER J,PERL
SELECT OUTPUT(52)
J=0; PERL=0
WHILE J<DPT CYCLE
PRINTSTRING(DESS(J))
IF PERL>=4 START
PERL=0
NEWLINE
FINISH ELSE START
PERL=PERL+1
PRINTSYMBOL(',')
FINISH
J=J+1
REPEAT
PRINTSTRING("
.END
")
J=0; PERL=0
WHILE J<RPT CYCLE
PRINTSTRING(REPS(J))
IF PERL>=2 START
PERL=0
NEWLINE
FINISH ELSE START
PERL=PERL+1
PRINTSYMBOL(',')
FINISH
J=J+1
REPEAT
PRINTSTRING("
.END
")
SELECT OUTPUT(CURROUTSTREAM)
CLOSE STREAM(52)
CLEAR("52")
END ; ! MAKE FILE
ROUTINE ENTER(INTEGER TYPE,STRING (17) FILE)
IF TYPE=DESTR START
RETURN IF DPT>39
DESS(DPT)=FILE
DPT=DPT+1
FINISH ELSE START
RETURN IF RPT>39
REPS(RPT)=FILE
RPT=RPT+1
FINISH
END ; ! ENTER
ROUTINE HEAD(STRING (71) S)
INTEGER J
S=" ".S." "
J=(80-LENGTH(S))>>1
MULSYM('-',J)
PRINTSTRING(S)
MULSYM('-',J)
NEWLINE
END ; ! HEAD
ROUTINE PRINTNOT
PRINTSTRING("DOES NOT EXIST ")
END ; ! PRINTNOT
ROUTINE MULSYM(INTEGER SYM,MUL)
INTEGER J
RETURN IF MUL<=0
CYCLE J=1,1,MUL; PRINT SYMBOL(SYM); REPEAT
END ; ! MULSYM
END ; ! PDCHECK
!--------------------------------------------------------------------------------
EXTERNALROUTINE UPDATE(STRING (255) T)
ROUTINESPEC DO IP(INTEGER STRM)
CONSTINTEGER DESTR=51, REPLA=52
INTEGER J
STRING (31) S
NEXT=-1
DEFINE("ST51,SS#DESRP")
DEFINE("ST53,SS#DETAC")
PROMPT("YN: ")
PRINTSTRING("
:::DESTROY:::
")
DO IP(51)
PRINTSTRING("
:::REPLACE:::
")
DO IP(51)
CLOSE STREAM(51)
CLOSE STREAM(53)
CLEAR("51,53")
PRINTSTRING("
:::DETACH FILE:::
")
LIST("SS#DETAC")
NEWLINES(2)
PROMPT("DETACH/OBEY: ")
UNTIL S="Q" OR 0<J<=40 OR S="OBEY" CYCLE
RSTRG(S)
J=BIN(S)
REPEAT
IF S="Q" THEN RETURN
IF S="OBEY" START
PROMPT(".LP/.OUT: ")
RSTRG(S) UNTIL S=".OUT" OR FROMSTR(S,1,3)=".LP"
S=",".S
S="" IF S=",.OUT"
OBEY("SS#DETAC".S)
RETURN
FINISH
DETACH("SS#DETAC,".S)
RETURN
ROUTINE DO IP(INTEGER STRM)
OWNINTEGER ONE=1
STRING (17)ARRAY FILES(0:7)
INTEGERARRAY YNS(0:7)
STRING (63) S,CUR
STRING (19) PRIST,MAS
INTEGER OK,PT,J,CH,PERLINE
IF ONE=1 THEN PRIST="DESTROY " ELSE PRIST="REPLACE "
ONE=ONE+1
SELECT INPUT(STRM); RSTRG(S); SELECT INPUT(0)
WHILE S#".END" CYCLE ; ! LINES OF FILES
REDO:
CUR=S; PERLINE=0; PRINTSTRING(CUR."
")
WHILE SEPARATE(CUR)#"" CYCLE
! FULL NAME FOR REPLACE ELSE MEM NAME
IF STRM=REPLA THEN CUR->MAS.("_").CUR
FILES(PERLINE)=CUR
PERLINE=PERLINE+1
REPEAT
OK=1; PT=0
UNTIL CH=NL CYCLE ; ! TT INPUT
READSYMBOL(CH)
UNLESS CH='Y' OR CH='N' OR CH=' ' OR CH=NL THEN OK=0
IF CH='Y' THEN YNS(PT)=1 AND PT=PT+1
IF CH='N' THEN YNS(PT)=0 AND PT=PT+1
REPEAT ; ! TT INPUT
IF OK=0 OR PT#PERLINE THEN -> REDO
SELECT OUTPUT(53); J=0
WHILE J<PT CYCLE ; ! FILE OUTPUT
IF YNS(J)#0 THEN PRINTSTRING(PRIST.FILES(J)."
")
J=J+1
REPEAT
SELECT OUTPUT(0)
SELECT INPUT(STRM); RSTRG(S); SELECT INPUT(0)
REPEAT ; ! LINES OF FILES
END ; ! DO IP
CLOSE STREAM(51)
CLOSE STREAM(53)
CLEAR("51,53")
PRINTSTRING("
:::DETACH FILE:::
")
LIST("SS#DETAC")
PROMPT("DETACH: ")
UNTIL S="NOW" OR S="Q" OR 0<J<=40 CYCLE
RSTRG(S)
J=BIN(S)
REPEAT
IF S="Q" THEN RETURN
DETACH("SS#DETAC,".S)
END ; ! UPDATE
ENDOFFILE