CONSTSTRING (63) SEPVSN=" ** SEPRTN14 21/05/85 **
"
!
!***********************************************************************
!* *
!* Conditional compilation constants *
!* *
!***********************************************************************
!
CONSTINTEGER FUNDS ON=0; ! Zero to suppress generation of FUNDS code
CONSTINTEGER NEWCONNECT = 0; ! Zero for "old CONNECT mechanism".
CONSTINTEGER NEWLOADER=1; ! 0 for old, 1 for new loader
CONSTINTEGER NOTES ON=0; ! Zero to suppress generation of NOTES code
CONSTINTEGER SYSPROCS=5; !NO F SYSTEM PROCESSES ALWAYS RUNNING
CONSTINTEGERNAME USERNO=X'80C0005B'; !NO OF ACTIVE PROCESSES
!
INCLUDE "SS0302S_SSOWNF"
!
!***********************************************************************
!* *
!* Record formats *
!* *
!***********************************************************************
!
! This format out of alphabetic sequence since DPERMF requires it
RECORDFORMAT PRMSF(STRING (6) USER, BYTEINTEGER UPRM)
!
RECORDFORMAT AFRECF(STRING (11) NAME, INTEGER KBYTES, STRING (8) DATE,
STRING (6) TAPE, INTEGER CHAPTER,FLAGS)
RECORDFORMAT ARF(STRING (31) NAME, INTEGER TYPE)
RECORDFORMAT COMF(INTEGER OCPTYPE,IPLDEV,SBLKS,SEPGS,NDISCS, C
DLVNADDR,GPCTABSIZE,GPCA,SFCTABSIZE,SFCA,SFCK,DIRSITE, C
DCODEDA,SUPLVN,WASKLOKCORRECT,DATE0,DATE1,DATE2, C
TIME0,TIME1,TIME2,EPAGESIZE,USERS,CATTAD,DQADDR, C
BYTEINTEGER NSACS,RESV1,SACPORT1,SACPORT0, C
NOCPS,RESV2,OCPPORT1,OCPPORT0, C
INTEGER ITINT,CONTYPEA,GPCCONFA,FPCCONFA,SFCCONFA, C
BLKADDR,RATION,SMACS,TRANS,LONGINTEGER KMON, C
INTEGER DITADDR,SMACPOS,SUPVSN,PSTVA,SECSFRMN,SECSTOCD, C
SYNC1DEST,SYNC2DEST,ASYNCDEST,MAXPROCS,INSPERSEC,ELAPHEAD, C
COMMSRECA,STOREAAD,PROCAAD,SFCCTAD,DRUMTAD,TSLICE,FEPS,SP1, C
SP2,SP3,SP4,SP5,SP6,SP7,SP8, C
LSTL,LSTB,PSTL,PSTB,HKEYS,HOOT,SIM,CLKX,CLKY,CLKZ, C
HBIT,SLAVEOFF,INHSSR,SDR1,SDR2,SDR3, C
SDR4,SESR,HOFFBIT,S2,S3,S4,END)
RECORDFORMAT DAHF(INTEGER DATAEND,DATASTART,SIZE,FILETYPE,DATE,TIME,FORMAT,
RECORDS)
RECORDFORMAT DHF(INTEGER DATAEND,DATASTART,SIZE,FILETYPE,SUM,DATETIME,
PSTART,SPARE)
RECORDFORMAT DPERMF(INTEGER BYTESRETURNED,OWNP,EEP,SPARE,
RECORD (PRMSF) ARRAY PRMS(0:15))
RECORDFORMAT E31F(INTEGER FILES,TOTSIZE,CHFILES,CHSIZE,TFILES,TSIZE)
RECORDFORMAT E4F(INTEGER FILES,USEDESC,FREEDESC,INDEX,MAXSECDESC,
FREESECDESC,MAXPERMDESC,FREEPERMDESC,MAXC3,FREEC3,MAXC4,FREEC4)
! %RECORDFORMAT FDF(%INTEGER LINK,DSNUM, %BYTEINTEGER STATUS,ACCESSROUTE,
! VALID ACTION,CUR STATE, %BYTEINTEGER MODE OF USE,MODE,FILE ORG,DEV CODE,
! %BYTEINTEGER REC TYPE,FLAGS,LM,RM, %INTEGER ASVAR,AREC,RECSIZE,MINREC,
! MAXREC,MAXSIZE,LASTREC,CONAD,CURREC,CUR,END,TRANSFERS,DARECNUM,CURSIZE,
! DATASTART, %STRING(31) IDEN, %INTEGER KEYDESC0,KEYDESC1,RECSIZEDESC0,
! RECSIZEDESC1, %BYTEINTEGER F77FLAG,F77FORM,F77ACCESS,F77STATUS,
! %INTEGER F77RECL,F77NREC,IDADDR, %BYTEINTEGER F77BLANK,F77UFD,SPARE1,
! SPARE2)
RECORDFORMAT FHF(INTEGER END,START,SIZE,TYPE,SPARE0,DATETIME,SPARE1,SPARE2)
RECORDFORMAT E9F(INTEGER ARFILES,ARKBYTES,BUFILES,BUKBYTES,IXSIZE, C
FILEDES,FREEFDES,PERMDES,FREEPDES)
RECORDFORMAT FRECF(STRING (11) NAME, INTEGER SP12,KBYTES,
BYTEINTEGER ARCH,CODES,CCT,OWNP,EEP,USE,CODES2,SSBYTE,FLAGS,SP29,SP30,
SP31)
RECORDFORMAT FRF(INTEGER CONAD,FILETYPE,DATASTART,DATEND,SIZE,RUP,EEP,MODE,
USERS,ARCH, STRING (6) TRAN, STRING (8) DATE,TIME, INTEGER COUNT,SPARE1,
SPARE2)
RECORDFORMAT HF(INTEGER DATAEND,DATASTART,FILESIZE,FILETYPE,SUM,DATETIME,
FORMAT,RECORDS)
RECORDFORMAT INFOF(INTEGER VSN,STATE, STRING (7) IDENT,USER,
STRING (15) DEST,SRCE,OUTPUT, STRING (31) NAME,DELIVERY,
STRING (7) ARRAY VOL LABEL(1:8), INTEGER DT RECEIVED,DT STARTED,
DT OUTPUT STARTED,DT DELETED,DATASTART,DATALENGTH,TIME,OUTPUT LIMIT,
PHYSICAL SIZE,PRIORITY,START AFTER DT,AHEAD, BYTEINTEGER FORMS,MODE,
COPIES,ORDER,RERUN,TAPES,DISCS,FAILS)
RECORDFORMAT JTABF(INTEGER START,LENGTH,TYPE)
RECORDFORMAT LNF(BYTEINTEGER TYPE, STRING (6) NAME, INTEGER REST,POINT,DR1)
RECORDFORMAT PDHF(INTEGER DATAEND,DATASTART,SIZE,FILETYPE,SUM,DATETIME,
ADIR,COUNT)
RECORDFORMAT PF(INTEGER DEST,SRCE,(INTEGER P1,P2,P3,P4,P5,P6 OR C
STRING (23) S))
RECORDFORMAT PRINTF(STRING (42) FNAME, BYTEINTEGER TYPE, STRING (8) DATE,
INTEGER SIZE,ERRMESS)
! N.B. PRMSF declared above.
RECORDFORMAT RF(INTEGER CONAD,FILETYPE,DATASTART,DATAEND)
!
!***********************************************************************
!* *
!* Constants *
!* *
!***********************************************************************
!
CONSTBYTEINTEGERARRAY FSYM(1:5)= '1','+','-','0',' '
CONSTBYTEINTEGERARRAY REPT(1:5)= 1,1,3,2,1
!
CONSTINTEGER ABASEFILE=x'00800000'; !start address of basefile
CONSTINTEGER CLISTSIZE=x'300000'; !MAX SIZE OF COMPILATION LISTING FILE
CONSTINTEGER CODE=2
CONSTINTEGER DEFJCPL=120; !DEFAULT JOB CPULIMIT - SECONDS
CONSTINTEGER EBCDICBIT=x'20'
CONSTINTEGER MACHINE=2960; ! Used by CHARGE routine to choose
! charging formula. Machine may be
! equal to 2980 or 2972 or other
! values - see the text of CHARGE in BCOM.
! If MACHINE=0 then the formula will be
! selected at run time according to the
! processor type determined by grope.
! MACHINE=2960 also causes slight
! variations in METER and DETACHOBEY.
CONSTINTEGER MAXJCPL=7200; !MAX CPULIMIT FOR DETACHED JOBS - SECONDS
CONSTINTEGER SSCHARFILETYPE=3
CONSTINTEGER SSCORRUPTOBJFILETYPE=5
CONSTINTEGER SSDATAFILETYPE=4
CONSTINTEGER SSDIRFILETYPE=2
CONSTINTEGER SSFFORMAT=1
CONSTINTEGER SSMAXWORKSIZE=x'200000'; !Max size for compiler workfile.
CONSTINTEGER SSOBJFILETYPE=1
CONSTINTEGER SSOPTFILETYPE=9
CONSTINTEGER SSPDFILETYPE=6
CONSTINTEGER SSUFORMAT=3
CONSTINTEGER SSVFORMAT=2
!
IF FUNDS ON#0 THENSTART
CONSTINTEGERNAME SCARCEWORD=x'80C00084'
FINISH
!
CONSTSTRING (4) LASTFN = "}{|~"; ! This can be used instead of a file name
! as a parameter to CONNECT, etc., to mean "the last file I nominated".
!
CONSTSTRING (4) ARRAY PPER(0:15)= "None","R ","W ","WR ","E ","RE ",
"WE ","All ",
"P ","RP ","WP ","WRP ","EP ","REP ","WEP ","WREP"
!
!***********************************************************************
!* *
!* %SYSTEM Routine/fn/map spec *
!* *
!***********************************************************************
!
SYSTEMINTEGERFNSPEC CHECKFILENAME(STRING (31) FILE, INTEGER TYPE)
IF NEWLOADER#0 THEN START
SYSTEMINTEGERFNSPEC CURRENTLL
FINISH
SYSTEMINTEGERFNSPEC DIRTOSS(INTEGER FLAG)
SYSTEMINTEGERFNSPEC IOCP(INTEGER EP,PARM)
SYSTEMINTEGERFNSPEC PARMAP
SYSTEMINTEGERFNSPEC PSTOI(STRING (63) S)
SYSTEMINTEGERFNSPEC STARTSWITH(STRINGNAME A, STRING (255) B, INTEGER CHOP)
SYSTEMINTEGERFNSPEC STOREMATCH(INTEGER L,A1,A2)
SYSTEMINTEGERFNSPEC TRAIL SPACES(INTEGER LINE END,LINE START,TRANS)
!
SYSTEMINTEGERMAPSPEC COMREG(INTEGER I)
!
IF NEWLOADER#0 THEN START
SYSTEMLONGINTEGERFNSPEC LOADEP(STRING (31) NAME, INTEGERNAME TYPE,FLAG,
INTEGER LOADLEVEL)
FINISH
!
SYSTEMROUTINESPEC CASTOUT(STRINGNAME S)
SYSTEMROUTINESPEC CHANGEFILESIZE(STRING (31) FILE, INTEGER NEWSIZE,
INTEGERNAME FLAG)
SYSTEMROUTINESPEC CHOPLDR(STRINGNAME A, INTEGER I)
SYSTEMROUTINESPEC CONNECT(STRING (31) FILE, INTEGER MODE,HOLE,PROT,
RECORD (RF) NAME R, INTEGERNAME FLAG)
SYSTEMROUTINESPEC DEFINE(INTEGER CHAN, STRING (31) IDEN, INTEGERNAME AFD,
FLAG)
SYSTEMROUTINESPEC DESTROY(STRING (31) FILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC DFDFOUT(STRING (31) OUT, INTEGER CHAN, INTEGERNAME FLAG)
SYSTEMROUTINESPEC DISCONNECT(STRING (31) FILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC ENTER(INTEGER MODE,DR0,DR1, STRING (255) PARAM)
SYSTEMROUTINESPEC ETOI(INTEGER AD,L)
SYSTEMROUTINESPEC EXAMINEMACRO(STRINGNAME M,C, INTEGER B,A,S,
INTEGERNAME FLAG)
SYSTEMROUTINESPEC FILL(INTEGER LENGTH,FROM,FILLER)
SYSTEMROUTINESPEC FILPS(STRINGNAME DPF,S)
IF NEWLOADER=0 THEN START
SYSTEMROUTINESPEC FINDENTRY(STRING (31) ENTRY, INTEGER TYPE,DAD,
STRINGNAME FILE, INTEGERNAME DR0,DR1,FLAG)
FINISH
SYSTEMROUTINESPEC FINFO(STRING (31) FILE, INTEGER MODE,
RECORD (FRF) NAME FR, INTEGERNAME FLAG)
SYSTEMROUTINESPEC FSTATUS(STRING (31) FILE, INTEGER ACT,VALUE,
INTEGERNAME FLAG)
SYSTEMROUTINESPEC INITCLIVARS
SYSTEMROUTINESPEC JOURNALOFF
IF NEWLOADER=0 THEN START
SYSTEMROUTINESPEC LOAD(STRING (31) NAME, INTEGER TYPE, INTEGERNAME FLAG)
FINISH
SYSTEMROUTINESPEC MACOPEN
SYSTEMROUTINESPEC MODDIRFILE(INTEGER EP, STRING (31) DIRFILE,
STRING (32) ENTRY,FILENAME, INTEGER TYPE,DR0,DR1, INTEGERNAME FLAG)
SYSTEMROUTINESPEC MODPDFILE(INTEGER EP, STRING (31) PDFILE,
STRING (11) MEMBER, STRING (31) INFILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC MOVE(INTEGER LENGTH,FROM,TO)
SYSTEMROUTINESPEC NEWGEN(STRING (31) S,T, INTEGERNAME FLAG)
SYSTEMROUTINESPEC OUTFILE(STRING (31) FILE, INTEGER FILESIZE,HOLE,PROT,
INTEGERNAME CONAD,FLAG)
SYSTEMROUTINESPEC PHEX(INTEGER I)
SYSTEMROUTINESPEC PRINTMESS(INTEGER N)
SYSTEMROUTINESPEC PSYSMES(INTEGER ROOT,FLAG)
SYSTEMROUTINESPEC SENDFILE(STRING (31) FILE, STRING (16) DEVICE,
STRING (24) NAME, INTEGER COPIES,FORMS, INTEGERNAME FLAG)
SYSTEMROUTINESPEC SETFNAME(STRING (40) NAME)
SYSTEMROUTINESPEC SETPAR(STRING (255) S)
SYSTEMROUTINESPEC SETUSE(STRING (31) FILE, INTEGER MODE,VALUE)
SYSTEMROUTINESPEC SETWORK(INTEGERNAME AD,FLAG)
SYSTEMROUTINESPEC UCTRANSLATE(INTEGER ADDRESS,LENGTH)
IF NEWLOADER#0 THEN START
SYSTEMROUTINESPEC UNLOAD2(INTEGER LOCLL,FAIL)
FINISH
!
SYSTEMSTRINGFNSPEC ITOS(INTEGER N)
SYSTEMSTRINGFNSPEC NEXTTEMP
SYSTEMSTRING (255) FNSPEC PRINTPARMS(LONGINTEGER P)
SYSTEMSTRINGFNSPEC SPAR(INTEGER N)
SYSTEMSTRINGFNSPEC SUBSTRING(STRINGNAME S, INTEGER I,J)
SYSTEMSTRING (8) FNSPEC UNPACK DATE(INTEGER P)
SYSTEMSTRING (8) FNSPEC UNPACK TIME(INTEGER P)
!
SYSTEMSTRING (255) MAPSPEC CONTROL LINE(INTEGERNAME FLAG)
!
!***********************************************************************
!* *
!* External/internal routine/fn/map specs *
!* *
!***********************************************************************
!
EXTERNALINTEGERFNSPEC DDESTROY(STRING (6) USER, STRING (11) FILE,
STRING (6) DATE, INTEGER FSYS,TYPE)
IF FUNDSON#0 THENSTART
EXTERNALINTEGERFNSPEC DDONATE(STRING (6) USER, INTEGER FSYS,UNITS)
FINISH
EXTERNALINTEGERFNSPEC DEXECMESS(STRING (6) USER, C
INTEGER SACT,LEN,ADDR)
EXTERNALINTEGERFNSPEC DFILENAMES(STRING (6) USER,
RECORD (AFRECF) ARRAYNAME INF, INTEGERNAME FILENUM,MAXREC,NFILES,
INTEGER FSYS,TYPE)
EXTERNALINTEGERFNSPEC DFSTATUS(STRING (6) USER, STRING (11) FILE,
INTEGER FSYS,ACT,VALUE)
EXTERNALINTEGERFNSPEC DFSYS(STRING (6) USER, INTEGERNAME FSYS)
EXTERNALINTEGERFNSPEC DMESSAGE2(STRING (6) USER, INTEGERNAME LEN,
INTEGER ACT,INVOC,FSYS,ADR)
EXTERNALINTEGERFNSPEC DPERMISSION(STRING (6) OWNER,USER, STRING (8) DATE,
STRING (11) FILE, INTEGER FSYS,TYPE,AD)
EXTERNALINTEGERFNSPEC DRESTORE(STRING (6) USER, STRING (11) FILE,
STRING (8) DATE, INTEGER FSYS,TYPE)
EXTERNALINTEGERFNSPEC DSFI(STRING (6) USER, INTEGER FSYS,TYPE,SET,ADR)
EXTERNALINTEGERFNSPEC DSPOOL(RECORD (PF) NAME P, INTEGER LEN,ADR)
EXTERNALINTEGERFNSPEC INSTREAM
EXTERNALINTEGERFNSPEC OUTPOS
EXTERNALINTEGERFNSPEC OUTSTREAM
EXTERNALINTEGERFNSPEC UINFI(INTEGER I)
!
EXTERNALROUTINESPEC DEFINFO(INTEGER CHAN, STRINGNAME FILENAME,
INTEGERNAME STATUS)
EXTERNALROUTINESPEC PROMPT(STRING (255) S)
EXTERNALROUTINESPEC SETMODE(STRING (255) S)
EXTERNALROUTINESPEC TRANSFERS(STRING (255) S)
!
EXTERNALSTRINGFNSPEC DATE
EXTERNALSTRINGFNSPEC TIME
EXTERNALSTRINGFNSPEC UCSTRING(STRING (255) S)
EXTERNALSTRINGFNSPEC UINFS(INTEGER N)
!
!***********************************************************************
!* *
!* Own variables *
!* *
!***********************************************************************
!
!
!***********************************************************************
!* *
!* Extrinsic variables *
!* *
!***********************************************************************
!
! %EXTRINSICINTEGER DIRDISCON; !SET TO 1 WHEN DIRECTORY DISCONNECTED
IF FUNDS ON#0 THENSTART
! %EXTRINSICINTEGER SCARCITYFOUND
FINISH
!
! %EXTRINSICSTRING(11) AVD; ! Active directory.
! %EXTRINSICSTRING(40) SSFNAME
!
!***********************************************************************
!* *
!* External variables *
!* *
!***********************************************************************
!
!
!***********************************************************************
!* *
!* End of declarations *
!* *
!***********************************************************************
!
!
!
ROUTINE CLOSEST(INTEGER CHAN)
!SAME AS CLOSESTREAM BUT DOES NOT CHECK FOR VALIDITY OF CHAN
INTEGER FLAG
FLAG=IOCP(16,CHAN); !CLOSESTREAM CALL ON IOCP
END ; !OF CLOSEST
!
!
INTEGERFN LENASA(INTEGER FF,TRANS)
!*RETURNS THE NUMBER OF BYTES REQUIRED TO PRINT A FORMAT EFFECTOR
INTEGER I
INTEGER SYM
SYM=BYTEINTEGER(FF); !AVOID WRITING TO FF
IF TRANS#0 THEN ETOI(ADDR(SYM)+3,1)
! %FOR I=1,1,5 %CYCLE
! %IF SYM = FSYM(I) %THEN %EXIT
! %REPEAT
I=ADDR(FSYM(1))
*ldtb_x'18000005'
*lda_I; ! Byte vector descriptor to FSYM(1:5).
*lb_SYM
*swne_ L = DR
*jcc_8,<NOTINC>
*inca_1
NOTINC:
*cyd_0
*stuh_ B
*isb_I
*st_I
RESULT =REPT(I)
END ; ! OF LENASA
!
!
ROUTINE INTASA(INTEGER FF,TRANS, INTEGERNAME OUTP)
!*
!* MAPS FORMAT EFFECTORS AS FOLLOWS:
!* 1 = 12 (NEWPAGE)
!* + = 13 (CR)
!* - = 10,10,10 (3 NEWLINES)
!* 0 = 10,10 (2 NEWLINES)
!* = 10 (NEWLINE)
!*
CONSTBYTEINTEGERARRAY VALS(1:5)= C
12,13,10,10,10
INTEGER I
INTEGER SYM
SYM=BYTEINTEGER(FF); !AVOID WRITING TO FF
IF TRANS#0 THEN ETOI(ADDR(SYM)+3,1)
! %FOR I=1,1,5 %CYCLE
! %IF SYM = FSYM(I) %THEN %EXIT
! %REPEAT
I=ADDR(FSYM(1))
*ldtb_x'18000005'
*lda_I; ! Byte vector descriptor to FSYM(1:5).
*lb_SYM
*swne_ L = DR
*jcc_8,<NOTINC>
*inca_1
NOTINC:
*cyd_0
*stuh_ B
*isb_I
*st_I
MOVE(REPT(I),ADDR(VALS(I)),OUTP)
OUTP=OUTP+REPT(I)
END ; ! OF INTASA
!
!
INTEGERFN {file length} FLC(INTEGER MODE,INCONAD,OUTFORM, INTEGERNAME FLAG)
INTEGER INP,INTOP,OUTLEN,RECORDS,FORMAT,INLEN,RLEN
INTEGER FE,LEN,I,LRECL,TRANS
RECORD (DAHF) NAME INH
FLAG=0
FE=(MODE&2)>>1; !=1 IF FIRST CHAR IS FORMAT EFFECTOR
INH==RECORD(INCONAD)
INP=INCONAD+INH_DATASTART
INTOP=INCONAD+INH_DATAEND
INLEN=INH_DATAEND-INH_DATASTART
TRANS=INH_FORMAT&EBCDICBIT; !EBCDIC FILE IF SET
IF MODE&1#0 START ; !DATA TO CHARACTER
FORMAT=INH_FORMAT&x'F'
IF FORMAT=SSVFORMAT START ; !VARIABLE LENGTH RECORD
OUTLEN=0
WHILE INP<INTOP CYCLE
RLEN=(BYTEINTEGER(INP)<<8)!BYTEINTEGER(INP+1)
IF RLEN<2 THENSTART
FLAG=311; !CORRUPT FILE
RESULT =0
FINISH
IF FE#0 AND RLEN>2 THEN LEN=LENASA(INP+2,TRANS) ELSE LEN=1
OUTLEN=OUTLEN+RLEN-2+LEN-FE-TRAIL SPACES(INP+RLEN-1,INP+2+FE,TRANS)
INP=INP+RLEN
REPEAT
RESULT =OUTLEN+FE; !FE FOR EXTRA NL AT END OF FILE
FINISHELSEIF FORMAT=SSFFORMAT START ; !FIXED LENGTH RECORDS
LRECL=INH_FORMAT>>16; !RECORD LENGTH
RECORDS=INLEN//LRECL; !NUMBER OF RECORDS
IF FE=0 THENSTART
OUTLEN=INLEN+RECORDS; !ALLOW ONE NL PER RECORD
FINISHELSESTART
OUTLEN=INLEN-RECORDS+1; ! - FE CHARS + LAST NL
FINISH
I=INP
WHILE I<INTOP CYCLE
OUTLEN=OUTLEN-TRAIL SPACES(I+LRECL-1,I+FE,TRANS)
IF FE#0 THEN OUTLEN=OUTLEN+LENASA(I,TRANS)
I=I+LRECL
REPEAT
RESULT =OUTLEN
FINISHELSEIF FORMAT=SSUFORMAT THENRESULT =INLEN
FLAG=267; !INVALID FILETYPE
SETFNAME("")
RESULT =0
FINISHELSESTART ; !CHARACTER TO CHARACTER
OUTLEN=1; !FOR EXTRA NL AT END
WHILE INP<INTOP CYCLE
OUTLEN=OUTLEN+LENASA(INP,TRANS)
FOR I=INP,1,INTOP-1 CYCLE
IF BYTEINTEGER(I)=NL THENEXIT
REPEAT
IF I#INP THEN OUTLEN=OUTLEN+I-INP-1
INP=I+1
REPEAT
RESULT =OUTLEN
FINISH
END ; !OF FLC
!
!
ROUTINE SORTNAMES(RECORD (ARF) ARRAYNAME R, INTEGER M,N)
INTEGER I,J,K,L,N1
RECORD (ARF) X
! There are N - M + 1 elements to be sorted.
L=M-1; ! L is never changed in this routine. Nor are M and N.
! N1 = 1
! %WHILE N1<N-L %CYCLE
! N1 = 2 * N1
! %REPEAT
! N1 is now the smallest (+ve integral) power of 2 which
! is not less than N-M+1. There is probably a faster way
! to find this, but I can't be bothered with it just now.
! Here it is - using the bit twiddling expression
! 1 << ((32 - SHZ(N-L-1)) & 31)
*lss_N; *isb_L; *isb_1; *shz_ TOS ; *lb_32; *sbb_ TOS
*lss_1; *rot_ B ; *st_N1
!
!
CYCLE
N1=N1//2
! N1 is now zero, or else a power of 2 less than N-M+1.
RETURNIF N1=0
! N1 is now a power of 2 less than N-M+1.
I=L; ! = M - 1.
CYCLE
I=I+1
J=I+N1
EXITIF J>N
K=I
WHILE R(J)_NAME<R(K)_NAME CYCLE
! J = K + N1, K>=M, J<=N.
X=R(J)
R(J)=R(K)
R(K)=X
J=K
K=K-N1
EXITIF K<M
REPEAT
! K<M or R(J)_NAME>=R(K)_NAME.
! Every N1th. element from the Kth. to the (I+N1)th. is
! in ascending order.
REPEAT
REPEAT
END ; !OF SORTNAMES
!
!
INTEGERFN {PRINT INDEX PERMS} PXP(STRING (255) BEFORE,AFTER)
! PRINT .ALL PERMISSIONS, IF ANY.
RECORD (DPERMF) DPERM
INTEGER N,I,FLAG
FLAG=DPERMISSION(UINFS(1),UINFS(1),"","",UINFI(1),8,ADDR(DPERM))
N=(DPERM_BYTESRETURNED-16)//8; !NO. OF INDIV PERMS
IF N>0 START
PRINTSTRING(BEFORE)
I=0
WHILE I<N CYCLE
PRINTSTRING(DPERM_PRMS(I)_USER." ".PPER(DPERM_PRMS(I)_UPRM))
IF OUTPOS+15>UINFI(15) THEN NEWLINE ELSE SPACES(3)
I=I+1
REPEAT
PRINTSTRING(AFTER)
FINISH
RESULT =FLAG
END ; ! of PRINT INDEX PERMS.
!
!
ROUTINE OUTOUT(INTEGER START,LEN)
INTEGER DR0,DR1,FLAG; !MUST STAY TOGETHER
DR0=LEN
DR1=START
FLAG=IOCP(19,ADDR(DR0))
END ; !OF OUTOUT
!
!
!< SINGLE SPACES
INTEGERFN SINGLE SPACES(INTEGER LENGTH,FROM,TO)
! Discards multiple spaces from LENGTH bytes at FROM, closing
! the text up so that only single spaces remain, and planting the
! compacted text at TO. It is permissible to give TO=FROM to
! achieve 'compaction in place'. It is not permissible (but
! there is no check to prevent it) to give FROM<TO<FROM+LENGTH.
! The %RESULT of the %FN gives the length of the compacted text.
!>
LONGINTEGER FROMDESCR,BLOCKLIM,NEWFROM
INTEGER TOBASE
! TOBASE will be a copy of the original value of TO. TO is
! updated as the routine works through the text, and has the
! destination address for the next block of text to be moved
! into the compacted string. On exit, TO - TOBASE is used
! to calculate the total length of the compacted text.
!
! FROMDESCR is a descriptor to the text remaining unprocessed
! in the uncompacted string. Except possibly at the start of the
! routine, the first byte in the text specified by FROMDESCR will
! not be a space. It will in fact be the first byte after a sequence
! of more than one space.
!
! BLOCKLIM is a descriptor specifying the residue of the area
! indicated by FROMDESCR after the first space in that area. Thus
! the text between FROMDESCR and BLOCKLIM is terminated by exactly one
! space. The routine will move this
! block of text to TO (and update TO), and thus it will build up
! a compacted text containing no multiple spaces.
!
! NEWFROM is a descriptor for the residue of the srea indicated by
! BLOCKLIM, starting at the first non-space. After a block of text
! has been moved into the compacted text, FROMDESCR can be replaced
! by NEWFROM and the next block of text can be located.
!
! The routine moves text from the original text into the compacted
! text in blocks each of which is terminated by exactly one space (i.e.,
! the penultimate character is not a space). These blocks are planted
! one after another in the compacted text, which consequently ends up
! containing no multiple spaces.
!
! The routine performs the compaction in the minimum possible number
! of moves. It only moves a block of text whose terminating space is
! followed (in the original text) by at least one more space. If it
! finds a space which is not followed by another in the original text,
! it does not treat that space as terminating a block to be moved.
! Instead, it goes on looking for multiple spaces. Single spaces are
! distinguished from multiple spaces by comparing BLOCKLIM with
! NEWFROM.
!
! The routine also avoids doing a move if the destination and source
! addresses are the same. This arises with the first move of a
! 'compaction in place'.
!
RESULT =0 IF LENGTH<=0
TOBASE=TO
*ldtb_x'58000000'; *ldb_LENGTH; *lda_FROM
! DR has a string descriptor to the area of store.
*std_FROMDESCR
! %CYCLE
! %CYCLE
L1:*swne_ L = DR ,0,32; ! %MASK=0,%REF=SP.
*jcc_8,<NOMORE>
! %IF another space has been found %THEN %START
*modd_1
! %FINISH
NOMORE:
*std_BLOCKLIM
!
! DR points just after the next unprocessed space in the row
! (or just after the end of the original text, if the FROMDESCR
! area contains no spaces).
*sweq_ L = DR ,0,32; ! DR points to the first non-space.
! %EXIT %IF the BLOCKLIM area is all spaces, or if there
! were no spaces at all in the FROMDESCR area.
*jcc_8,<DONE>
*cyd_0
*ucp_BLOCKLIM
*jcc_8,<L1>
! %REPEAT %UNTIL we find a multiple space.
DONE:
*std_NEWFROM
*lss_FROMDESCR+4
*ucp_TO; ! Check whether source address=destination address.
*irsb_BLOCKLIM+4; ! Gives length of text to move. Doesn't change CC.
*jcc_8,<NOMOVE>
! %IF the text needs moving %THEN %START
*slsd_FROMDESCR
*lda_TO
*ldb_ TOS
*mv_ L = DR ; ! Close up the string, leaving only one space.
*cyd_0
*stuh_ B ; ! Leaves updated TO address in Acc.
*ld_NEWFROM
*j_<MOVED>
! %FINISH %ELSE %START
NOMOVE:
*uad_TO; ! Simply update TO.
! %FINISH
MOVED:
*st_TO
*std_FROMDESCR
*jaf_11,<L1>; ! Go back to scan for next space.
! %REPEAT %UNTIL there's no text left.
!
RESULT =TO-TOBASE
!
END ; !OF TOBASE
!
!
ROUTINESPEC JOIN(RECORD (JTABF) ARRAYNAME TAB, INTEGER FIRSTCELL,LASTCELL,
STRING (31) OUT, INTEGER FE, INTEGERNAME FLAG)
ROUTINESPEC JOIN2(RECORD (JTABF) ARRAYNAME TAB, INTEGER FIRSTCELL,
LASTCELL, STRING (31) OUT, INTEGER FE,GAP, INTEGERNAME FLAG)
ROUTINESPEC JOINFILES(STRING (255) FILENAMES, RECORD (JTABF) ARRAYNAME TAB,
INTEGER MODE,FIRSTCELL, INTEGERNAME LASTCELL,FLAG)
ROUTINE SETINPUT(STRING (31) IN, INTEGERNAME FLAG)
!CHECKS THAT IN EXISTS AND IS ".IN" OR A CHARACTER FILE
!CALLS DEFINE(81,IN....) AND SELECTINPUT(81)
INTEGER AFD, TF
RECORD (RF) RR
IF NEWCONNECT=0 THEN TF = 0
IF "*"#IN#".IN" START ; !INPUT FROM A FILE
CONNECT(IN,0,0,0,RR,FLAG); ! {SEQ}
RETURN IF FLAG#0
IF NEWCONNECT=0 THEN TF = -1
IF RR_FILETYPE#SSCHARFILETYPE THENSTART
FLAG=267
->ERR
FINISH
!INVALID FILETYPE
COMREG(46)=RR_CONAD; !FOR COMPILER SOURCE MAPPING
FINISHELSE COMREG(46)=0; !CANNOT MAP
DEFINE(81,IN,AFD,FLAG)
->ERR IF FLAG#0
SELECTINPUT(81)
ERR:
IF NEWCONNECT#0 AND TF#0 THEN SETUSE (IN, -1, 0)
END ; !OF SETINPUT
!
!
ROUTINE FCONV(INTEGER MODE,INCONAD,OUT,RECFM, INTEGERNAME FLAG)
!INITIAL VERSION ONLY CONVERTS DATA FILES TO CHARACTER
! **** **** Ought to check file types and stop in good order **** ****
! **** **** if asked to convert unacceptable types. **** ****
INTEGER INP,OUTP,RLEN,INTOP,FORMAT,TRANS,FE,RECLEN,I
RECORD (DAHF) NAME INH
!
!{SEQ} - Files for conversion should be sequential-connected.
!
FLAG=0; !DEFAULT O.K.
FE=(MODE&2)>>1; !FOR FORMAT EFFECTORS
INH==RECORD(INCONAD)
INP=INCONAD+INH_DATASTART; !START OF DATA
INTOP=INCONAD+INH_DATAEND; !END OF DATA +1
FORMAT=INH_FORMAT&x'F'
TRANS=INH_FORMAT&EBCDICBIT; !EBCDIC FILE IF SET
OUTP=OUT
IF MODE&1#0 THENSTART ; !DATA TO CHARACTER
IF FORMAT=SSVFORMAT START ; !VARIABLE LENGTH RECORDS
WHILE INP<INTOP CYCLE
RECLEN=(BYTEINTEGER(INP)<<8)!BYTEINTEGER(INP+1)
!LENGTH INCLUDES LENGTH BYTES
RLEN=RECLEN-TRAIL SPACES(INP+RECLEN-1,INP+2+FE,TRANS)
IF FE#0 AND RLEN>2 THENSTART
INTASA(INP+2,TRANS,OUTP); !OUTPUT FORMAT EFFECTOR
MOVE(RLEN-3,INP+3,OUTP); !OUTPUT REST OF RECORD
IF TRANS#0 THEN ETOI(OUTP,RLEN-3)
OUTP=OUTP+RLEN-3
FINISHELSESTART
MOVE(RLEN-2,INP+2,OUTP)
IF TRANS#0 THEN ETOI(OUTP,RLEN-2)
!TRANSLATE IF NEC
OUTP=OUTP+RLEN-1
BYTEINTEGER(OUTP-1)=NL
FINISH
INP=INP+RECLEN
REPEAT
FINISHELSEIF FORMAT=SSFFORMAT START
RECLEN=INH_FORMAT>>16; !FIXED RECORD LENGTH
WHILE INP<INTOP CYCLE
RLEN=RECLEN-TRAIL SPACES(INP+RECLEN-1,INP+FE,TRANS)
IF FE#0 THENSTART
INTASA(INP,TRANS,OUTP)
MOVE(RLEN-1,INP+1,OUTP)
IF TRANS#0 THEN ETOI(OUTP,RLEN-1)
OUTP=OUTP+RLEN-1
FINISHELSESTART
MOVE(RLEN,INP,OUTP)
IF TRANS#0 THEN ETOI(OUTP,RLEN)
OUTP=OUTP+RLEN+1
BYTEINTEGER(OUTP-1)=NL
FINISH
INP=INP+RECLEN
REPEAT
FINISHELSEIF FORMAT=SSUFORMAT START
!UN-STRUCTURED - PRESUMABLY CONTAINS OWN NEWLINES
MOVE(INTOP-INP,INP,OUTP)
FINISHELSESTART
FLAG=267
SETFNAME("")
FINISH
FINISHELSESTART ; !CHARACTER TO CHARACTER
WHILE INP<INTOP CYCLE
INTASA(INP,TRANS,OUTP); !FIRST CHAR IS FE
FOR I=INP,1,INTOP-1 CYCLE
IF BYTEINTEGER(I)=NL THENEXIT
REPEAT
IF I#INP THENSTART
MOVE(I-INP-1,INP+1,OUTP)
OUTP=OUTP+I-INP-1
FINISH
INP=I+1
REPEAT
FINISH
IF FE#0 THEN BYTEINTEGER(OUTP)=NL; !ADD NL TO LAST LINE
END ; !OF FCONV
!
!
ROUTINE SETOUTPUT(STRING (31) OUT, INTEGERNAME FLAG)
!CALLS DEFINE(82,OUT) AND SELECTOUTPUT(82)
INTEGER AFD
DEFINE(82,OUT,AFD,FLAG)
IF FLAG=0 THEN SELECTOUTPUT(82)
END ; !OF SETOUTPUT
!
!
!*
!*
IF FUNDS ON#0 THENSTART
ROUTINESPEC FUNDS(STRING (255) S)
FINISH
IF NOTES ON#0 THENSTART
FINISH
ROUTINESPEC LIST(STRING (255) S)
!*
!*
SYSTEMROUTINE FILEANAL(STRING (31) FILE, RECORD (ARF) ARRAYNAME R,
INTEGERNAME COUNT,FLAG)
INTEGER PSTART,HASHCONST,I,CONAD,POINT,MAX,LDA,LIST
INTEGER LINK,MARK,SHAD
CONSTBYTEINTEGERARRAY HEADOFFSET(16:20)= C
4,16,28,32,36
CONSTBYTEINTEGERARRAY IDENOFFSET(16:20)= C
8,16,8,8,12
STRING (255) S
RECORD (PDHF) NAME PDH
RECORD (DHF) NAME DH
RECORD (RF) RR
RECORD (LNF) ARRAYFORMAT HAF(0:10000)
RECORD (LNF) ARRAYNAME H
MAX=COUNT; !MAX NO OF ELEMENTS IN ARRAY R
COUNT=0; !NUMBER FILLED BY ANALYSE
CONNECT(FILE,0,0,0,RR,FLAG)
RETURN IF FLAG#0
CONAD=RR_CONAD
IF RR_FILETYPE=SSOBJFILETYPE START ; !OBJECT FILE
LDA=CONAD+INTEGER(CONAD+24); !ABS ADDR LDATA
FOR LIST=16,1,20 CYCLE
LINK=INTEGER(LDA+HEADOFFSET(LIST)); !HEAD OF RIGHT LIST
WHILE LINK#0 CYCLE
COUNT=COUNT+1
->FULL IF COUNT>MAX
SHAD = CONAD + LINK + IDENOFFSET(LIST)
UNLESS LIST # 16 OR 0 < BYTEINTEGER(SHAD) < 32 THEN C
SHAD = CONAD + LINK + 20
!iput code entry type
UNLESS 0 < BYTEINTEGER(SHAD) < 32 THEN START
PRINTSTRING("bad ep..list=")
WRITE(LIST,1)
NEWLINE
FINISH
R(COUNT)_NAME = STRING(SHAD)
R(COUNT)_TYPE=LIST
LINK=INTEGER(CONAD+LINK)
REPEAT
REPEAT
->ERR
FINISH
IF RR_FILETYPE=SSDIRFILETYPE START ; !DIRECTORY FILE
DH==RECORD(CONAD); !DIRECTORY HEADER
HASHCONST=INTEGER(CONAD+DH_DATASTART); !NO OF ITEMS IN HASH TABLE
H==ARRAY(CONAD+DH_DATASTART+4,HAF); !MAP ONTO HASH ARRRAY
PSTART=CONAD+DH_PSTART
POINT=4; !FIRST STRING
! %CYCLE THROUGH PLIST
WHILE BYTEINTEGER(POINT+PSTART)#0 CYCLE
S=STRING(POINT+PSTART)
IF '='#CHARNO(S,1)#255 AND LENGTH(S)>7 AND CHARNO(S,7)='.' THENSTART
! NOT AN ALIAS OR EMPTY STRING
COUNT=COUNT+1
->FULL IF COUNT>MAX; !ARRAY R IS FULL
R(COUNT)_NAME=S
R(COUNT)_TYPE=SSOBJFILETYPE
!NOW LOOK FOR ENTRY NAMES THAT POINT TO THIS NAME
FOR MARK=0,1,1 CYCLE ; ! 0 for procedure entries,
! 1 for data entries.
FOR I=0,1,HASHCONST-1 CYCLE
IF H(I)_POINT=POINT AND H(I)_NAME#".EMPTY" AND C
H(I)_NAME#"" AND H(I)_TYPE&1=MARK THENSTART
COUNT=COUNT+1
->FULL IF COUNT>MAX
IF H(I)_TYPE&x'80'#0 THEN C
R(COUNT)_NAME=H(I)_NAME.STRING(CONAD+DH_PSTART+H(I) C
_REST) ELSE R(COUNT)_NAME=H(I)_NAME
R(COUNT)_TYPE=MARK+16; ! 16 for procedure, 17 for data.
FINISH
REPEAT
REPEAT
FINISH
POINT=POINT+LENGTH(S)+1; !MOVE ON TO NEXT STRING IN PLIST
REPEAT
!NOW LOOK FOR ALIASES
POINT=4; !FIRST STRING IN POINTER LIST
WHILE BYTEINTEGER(POINT+PSTART)#0 CYCLE
S=STRING(POINT+PSTART)
IF CHARNO(S,1)='=' START
COUNT=COUNT+1
->FULL IF COUNT>MAX
R(COUNT)_NAME=SUBSTRING(S,2,LENGTH(S))
!REMOVE '='
R(COUNT)_TYPE=21; !ALIASED NAME
!NOW LOOK FOR ALIASES THAT POINT HERE.
FOR I=0,1,HASHCONST-1 CYCLE
IF H(I)_POINT=POINT AND H(I)_NAME#".EMPTY" AND C
H(I)_NAME#"" THENSTART
COUNT=COUNT+1
->FULL IF COUNT>MAX
IF H(I)_TYPE&x'80'#0 THEN C
R(COUNT)_NAME=H(I)_NAME.STRING(CONAD+DH_PSTART+H(I)_REST) C
ELSE R(COUNT)_NAME=H(I)_NAME
R(COUNT)_TYPE=16
FINISH
REPEAT
FINISH
POINT=POINT+LENGTH(S)+1; !MOVE ON TO NEXT STRING IN PLIST
REPEAT
->ERR
FINISH ; !END OF DIRECTORY FILE
IF RR_FILETYPE=SSPDFILETYPE START ; !PARTITIONED FILE
PDH==RECORD(CONAD)
IF PDH_COUNT<=MAX THEN COUNT=PDH_COUNT ELSESTART
FLAG=300
COUNT=MAX
FINISH
!CHECK IF ENOUGH ROOM IN ARRAY R
->ERR IF COUNT=0; !NO MEMBERS
POINT=CONAD+PDH_ADIR+4
FOR I=COUNT,-1,1 CYCLE
R(I)_NAME=STRING(POINT+(I-1)*32)
R(I)_TYPE=19; !MEMBER OF A PDFILE
REPEAT
->ERR
FINISH
FULL:
FLAG=300; !USER DID NOT PROVIDE ENOUGH ROOM IN R
COUNT=COUNT-1; !RESET COUNT
ERR:
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
END ; !OF FILEANAL
!
!
EXTERNALROUTINE CONCAT(STRING (255) S)
!THIS VERSION ONLY READS FROM .IN AND ONLY ACCEPTS CHARACTER FILES
CONSTINTEGER MAX=64; !MAX NO. OF INPUT FILES
RECORD (RF) RR
RECORD (HF) NAME H
INTEGERARRAY FSTART,FLEN(1:64)
STRING (18) ARRAY FILE(1:64)
INTEGER OUTCONAD,OUTLENGTH,OUTP,I,J,FLAG,CHR,K
STRING (31) NAME,MEMBER
STRING (255) NAME LINE
STRING (7) OWNNAMEDOT
OUTLENGTH=32; !LENGTH OF HEADER
I=0
OWNNAMEDOT=UINFS(1)."."; !FOR REMOVAL OF OWN NAME FROM FILENAMES
PROMPT("Conc:")
CYCLE
LINE==CONTROL LINE(FLAG)
FLAG = 25 AND -> ERR IF FLAG#0; !end of file detected
UCTRANSLATE(ADDR(LINE)+1,LENGTH(LINE))
CHR=STARTSWITH(LINE,OWNNAMEDOT,-1); ! REMOVE OWN NAME
EXITIF LINE=".END"
IF I=MAX THENSTART ; !TOO MANY INPUT FILES
FLAG=277
-> ERR
FINISH
CONNECT(LINE,0,0,0,RR,FLAG); !{SEQ}
IF FLAG#0 THEN PSYSMES(8,FLAG) {CONNECT FAILS} ELSEIF C
RR_FILETYPE#SSCHARFILETYPE THENSTART
! INVALID FILETYPE
SETFNAME(LINE)
PSYSMES(8,267)
FINISHELSESTART
UNLESS LINE->NAME.("_").MEMBER THEN NAME=LINE
!REMOVE MEMBER
I=I+1
FILE(I)=NAME
FSTART(I)=RR_CONAD+RR_DATASTART
FLEN(I)=RR_DATAEND-RR_DATASTART
OUTLENGTH=OUTLENGTH+FLEN(I)
FINISH
REPEAT
!NOW GENERATE OUTPUT FILE
IF I=0 THENSTART ; !NO FILES
FLAG=305
->ERR
FINISH
PROMPT("File:")
LINE==CONTROL LINE(FLAG)
FLAG = 25 AND -> ERRD IF FLAG#0; !end of file detected
UCTRANSLATE(ADDR(LINE)+1,LENGTH(LINE))
CHR=STARTSWITH(LINE,OWNNAMEDOT,-1); ! REMOVE OWN NAME
FOR J=I,-1,1 CYCLE ; !CHECK FOR OUTPUT = INPUT
IF LINE=FILE(J) THENSTART
FLAG=266
-> ERRD
FINISH
REPEAT
OUTFILE(LINE,OUTLENGTH,0,0,OUTCONAD,FLAG); !{SEQ}
-> ERRD IF FLAG#0
H==RECORD(OUTCONAD)
H_DATASTART=32
H_DATAEND=OUTLENGTH
H_FILETYPE=SSCHARFILETYPE
OUTP=OUTCONAD+32
FOR J=1,1,I CYCLE
MOVE(FLEN(J),FSTART(J),OUTP)
OUTP=OUTP+FLEN(J)
IF NEWCONNECT#0 THEN DISCONNECT (FILE(I),K); ! Ignore flag.
REPEAT
IF NEWCONNECT#0 THEN DISCONNECT (LINE,K); ! Ignore flag.
WRITE(I,1)
PRINTSTRING(" Files concatenated into file: ".LINE)
NEWLINE
IF NEWCONNECT#0 THEN -> ERR
ERRD:
IF NEWCONNECT#0 THEN START
FOR J=1,1,I CYCLE
DISCONNECT (FILE(I),K); ! Ignore flag.
REPEAT
FINISH
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(7,FLAG)
END ; !OF CONCAT
!
!
!
EXTERNALROUTINE ANALYSE(STRING (255) S)
LONGINTEGER LONGTYPE
INTEGER I,P,RECFM,TYPE,FLAG,OFM,LDA,J,MAX,FILETYPE
INTEGER COST,ALIASHEAD,OPTI,CHAR,NS,CPF
SWITCH HIST(1:9)
STRING (31) FNAME,REST,TEMPLATE
STRING (19) HSTR
STRING (8) OPTIONS
RECORD (FRF) FR
RECORD (DAHF) NAME DAH
INTEGER FILES,ENTRIES,DATAENTRIES,ALIASEDNAMES,ALIASES
INTEGER HASHCONST,PLENGTH,PSTART,PUSED
RECORD (DHF) NAME DH
CONSTINTEGER PSET=1; !PERMISSIONS
CONSTINTEGER ESET=2; !ENTRIES
CONSTINTEGER ASET=4; !ALIASES
CONSTINTEGER RSET=8; !REFS
CONSTINTEGER FSET=16; !FILES
CONSTINTEGER MSET=32; !MEMBERS
CONSTINTEGER SSET=64; !STRUCTURE
CONSTINTEGER HSET=128; !HISTORY
CONSTBYTEINTEGERARRAY OPTL(1:8)= C
'P','E','A','R','F','M','S','H'
CONSTINTEGER MAXOPTL=8
CONSTSTRING (9) ARRAY ONAME(1:7)= C
"CODE","GLA","PLT","SST","UST","INITCMN","INITSTACK"
RECORD (ARF) ARRAY INITIALR(1:100); !MAY NEED TO CHANGE THIS
CONSTINTEGER MAXINITIALR=100
CONSTINTEGER MAXR=6553; !MAXIMUM VALUE OF R
RECORD (ARF) ARRAYFORMAT RAF(1:MAXR)
RECORD (ARF) ARRAYNAME R
STRING (2) CHARCH
STRING (32) CURALIASED,OUT,FILE
RECORD (RF) RR
RECORD (HF) NAME H
CONSTSTRING (22) ARRAY LISTNAME(16:20)= C
"Procedure entries","Data entries","Procedure refs",
"Dynamic procedure refs","Data refs"
CONSTINTEGER MAXTYPENAME=9
CONSTSTRING (14) ARRAY TYPENAME(0:MAXTYPENAME)= C
"NON-STANDARD", "OBJECT",
"DIRECTORY", "CHARACTER", "DATA",
"CORRUPT OBJECT", "PARTITIONED","NON-STANDARD","NON-STANDARD","OPTION FILE"
ROUTINE PRINTSORTEDLIST(INTEGER START,FINISH)
!PRINTS THE NAMES IN RECORDARRAY R FROM START TO FINISH IN ALPHA ORDER
!LENGTH OF EACH NAME ASSUMED <=11 BUT IF GREATER THEN MORE THAN ONE COLUMN
!ALLOWED FOR PRINTING
INTEGER I
RETURNIF FINISH<START
SORTNAMES(R,START,FINISH)
FOR I=START,1,FINISH CYCLE
IF OUTPOS+LENGTH(R(I)_NAME)>UINFI(15) THEN NEWLINE
PRINTSTRING(R(I)_NAME)
SPACE UNTIL (OUTPOS//12)*12=OUTPOS
REPEAT
NEWLINE
END ; !OF PRINTSORTEDLIST
!
!
ROUTINE PPMS; ! PRINTPERMISSIONS
RECORD (DPERMF) DPERM
INTEGER I,N
STRING (31) NAME
STRING (6) OWNER
! **** **** READ THIS **** ****
! The 8-bit in OWNP means that the file may not be destroyed.
! The 8-bit in EEP means "all permissions if any", but it is ignored
! in Director 13 and later. Consequently the masks in the code below
! should be 15 (instead of 7) for OWNP, but 7 for EEP. But this
! presupposes a corresponding change in ZPERMIT (namely a "3"
! instead of a "2" in a couple of places), and that depends on
! a decision about a satisfactory user interface in PERMIT.
! Also the strings in PPER may need to be changed: "P" for
! "Protect" is not self-explanatory, especially since all the
! other letters indicate what you can do to a file, not what
! you can't do.
PRINTSTRING("Access Permissions:")
IF FNAME->OWNER.(".").NAME START
IF OWNER#UINFS(1) THENSTART ; ! NOT MY FILE SO LIMITED INFO AVAILABLE
FLAG=DPERMISSION(OWNER,UINFS(1),"",NAME,-1,10,ADDR(I))
PRINTSTRING(" Self:".PPER(I&7)); NEWLINE
->NUSERS
FINISH
FINISHELSE NAME=FNAME
! Append process invocation number to temporary file names:
IF LENGTH(NAME)>1 AND CHARNO(NAME,1)='T' AND CHARNO(NAME,2)='#' THEN C
NAME=NAME.ITOS(UINFI(13))
FLAG=DPERMISSION(UINFS(1),UINFS(1),"",NAME,UINFI(1),4,ADDR(DPERM))
PRINTSTRING(" Self:".PPER(DPERM_OWNP&15)." Others:".PPER(DPERM_EEP&7))
N=(DPERM_BYTESRETURNED-16)//8; !NO. OF INDIVIDUAL PERMISSIONS
NEWLINE UNLESS N=0
I=0
WHILE I<N CYCLE
PRINTSTRING(DPERM_PRMS(I)_USER." ".PPER(DPERM_PRMS(I)_UPRM))
IF OUTPOS+15>UINFI(15) THEN NEWLINE ELSE SPACES(3)
I=I+1
REPEAT
FLAG{PRINT INDEX PERMS}=PXP("
Permissions for all files:
","")
NEWLINE
NUSERS:
I=FR_USERS
PRINTSTRING("Current users:")
WRITE(I,1)
NEWLINE
END ; !OF PRINTPERMISSIONS
!
!
TEMPLATE="FILE,OPTIONS=,OUT="
COST=OUTSTREAM
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP&1=0 OR PARMAP>7 THENSTART
FLAG=263
->ERR
FINISH
FILE=SPAR(1)
OPTIONS=SPAR(2)
OPTI=0
R==ARRAY(ADDR(INITIALR(1)),RAF); !MAP R ONTO INITIALR TO START WITH
IF OPTIONS#"" START
FOR I=LENGTH(OPTIONS),-1,1 CYCLE
CHAR=CHARNO(OPTIONS,I)
IF CHAR='*' THENSTART ; ! ALL OPTIONS
OPTI=-1
EXIT
FINISH
FOR J=MAXOPTL,-1,1 CYCLE
IF CHAR=OPTL(J) THENSTART
OPTI=OPTI!(1<<(J-1))
EXIT
FINISH
REPEAT
REPEAT
FINISH
OUT=SPAR(3)
IF OUT#"" START ; !OUTPUT DEV OR FILE SPECIFIED
SETOUTPUT(OUT,FLAG)
->ERR IF FLAG#0
FINISH
UNLESS FILE->FNAME.("_") THEN FNAME=FILE
!REMOVE MEMBER FOR FINFO CALL
FINFO(FNAME,0,FR,FLAG)
->ERR IF 273#FLAG#0; !UNLESS ON OFFER OR OK
IF LENGTH(FR_TRAN)=6 START ; !FILE IS ON OFFER
PRINTSTRING("File ".FILE." is on OFFER to ".FR_TRAN)
NEWLINE
->ERR
FINISH
! If the file wasn't connected in this process at the time we called
! FINFO, then we are about to increase the user count when we call
! CONNECT, so to keep our records straight we will increment the count
! in FR.
IF FR_CONAD=0 THEN FR_USERS=FR_USERS+1
CONNECT(FILE,0,0,0,RR,FLAG); !CONNECT IN READ MODE
IF FLAG#0 THEN -> ERRX
H==RECORD(RR_CONAD)
FILETYPE=RR_FILETYPE
UNLESS 0<=INTEGER(RR_CONAD+12)<=MAXTYPENAME THEN FILETYPE=0
!OLD OBJECT FILE
CHARCH=""
IF FR_ARCH&x'01'#0 THEN CHARCH="*"; !CHERISHED
IF FR_ARCH&x'80'#0 THEN CHARCH="**"; !ARCHIVE REQUEST OUTSTANDING
PRINTSTRING("File: ".CHARCH.FILE)
PRINTSTRING(" Type: ".TYPENAME(FILETYPE)." Length:")
WRITE(RR_DATAEND-RR_DATASTART,1)
PRINTSTRING(" Bytes")
NEWLINE
PRINTSTRING("Last altered: ".UNPACKDATE(H_DATETIME)." at ".UNPACKTIME C
(H_DATETIME))
NEWLINE
IF OPTI&PSET#0 THEN PPMS; ! PRINTPERMISSIONS
!******************************** OBJECT *************************
IF FILETYPE=SSOBJFILETYPE START ; !OBJECT
LDA=RR_CONAD+INTEGER(RR_CONAD+24)
OFM=RR_CONAD+INTEGER(RR_CONAD+28); !START OF OBJECT FILE MAP
P=RR_CONAD+INTEGER(LDA+48); !P POINTS TO START OF OBJDATA
IF OPTI&HSET#0 THENSTART ; !PRINT HISTORY
NS=0
WHILE BYTEINTEGER(P)#0 CYCLE
TYPE=BYTEINTEGER(P)
UNLESS 1<=TYPE<=9 THENEXIT
SPACES(NS) UNLESS TYPE=7
->HIST(BYTEINTEGER(P))
HIST(1):!SOURCE FILE NAME
PRINTSTRING("Source : ".STRING(P+1))
->NEXT
HIST(2):!PARMS
LONGTYPE=0; !OLD OBJECT FILES ONLY HAVE 4 BYTES OF PARM INFO
MOVE(BYTEINTEGER(P+1),P+2,ADDR(LONGTYPE))
!NEED TO MOVE TO ALIGN ON INTEGER BOUNDARY
PRINTSTRING("Parms set : ")
PRINTSTRING(PRINTPARMS(LONGTYPE))
->NEXT
HIST(3):!START OF LINKED OBJECT
PRINTSTRING("Components : ")
NS=NS+3; !FOR INDENTATION
->NEXT
HIST(4):!OBJECT FILE NAME
NEWLINE
SPACES(NS)
PRINTSTRING("Object : ".STRING(P+1))
->NEXT
HIST(5):!DATE LINKED
MOVE(4,P+2,ADDR(I)); !PUT IN WORD
PRINTSTRING("Linked : ".UNPACKDATE(I)." at ".UNPACKTIME(I))
->NEXT
HIST(6):!DATE COMPILED
MOVE(4,P+2,ADDR(I)); !PUT IN WORD
PRINTSTRING("Last altered: ".UNPACKDATE(I)." at ".UNPACKTIME(I))
->NEXT
HIST(7):!END OF LINKED OBJECT
NS=NS-3
SPACES(NS)
PRINTSTRING("END")
->NEXT
HIST(8):!ANY TEXT
I=P+2; !START OF TEXT
J=P+1+BYTEINTEGER(P+1); !END OF TEXT
WHILE I<=J CYCLE
PRINTSYMBOL(BYTEINTEGER(I))
IF BYTEINTEGER(I)=NL THEN SPACES(NS)
I=I+1
REPEAT
->NEXT
HIST(9):!THE COMPILER
PRINTSTRING("Compiler : ")
PRINTSTRING(STRING(P+1))
->NEXT
NEXT:
NEWLINE
P=P+2+BYTEINTEGER(P+1); !MOVE P TO POINT TO NEXT ITEM
REPEAT
FINISH
IF OPTI&ESET#0 OR OPTI&RSET#0 START ; !ENTRIES AND OR REFS SET
MAX=MAXINITIALR
FILEANAL(FILE,R,MAX,FLAG)
IF FLAG=300 START ; !NOT ENOUGH ROOM
I=x'40000'
SETWORK(I,FLAG)
IF FLAG#0 THEN ->ERR
R==ARRAY(I,RAF)
MAX=MAXR
FILEANAL(FILE,R,MAX,FLAG)
FINISH
->ERR IF FLAG#0
I=1
WHILE I<=MAX CYCLE
TYPE=R(I)_TYPE
IF (16<=TYPE<=17 AND OPTI&ESET#0) OR (18<=TYPE<=20 AND C
OPTI&RSET#0) THENSTART
PRINTSTRING(LISTNAME(TYPE))
PRINTSTRING(":
")
FOR J=I,1,MAX+1 CYCLE
IF J=MAX+1 OR R(J)_TYPE#TYPE START
PRINTSORTEDLIST(I,J-1)
I=J
EXIT
FINISH
REPEAT
FINISHELSE I=I+1
REPEAT
NEWLINE
FINISH
IF OPTI&SSET#0 START
PRINTSTRING("Area Offset Length")
NEWLINE
FOR P=1,1,7 CYCLE
I=OFM+4+12*(P-1)
IF INTEGER(I+4)>0 START
REST=ONAME(P)
PRINTSTRING(REST)
SPACES(12-LENGTH(REST))
PHEX(INTEGER(I))
SPACES(8)
PHEX(INTEGER(I+4))
NEWLINE
FINISH
REPEAT
FINISH
FINISH
!******************************** DATA *************************
IF FILETYPE=SSDATAFILETYPE START
!DATAFILE
DAH==RECORD(RR_CONAD)
RECFM=DAH_FORMAT&x'03'; !FORMAT
PRINTSTRING("Format: ")
IF DAH_FORMAT&EBCDICBIT#0 THEN PRINTSYMBOL('E'); !EBCDIC FILE
IF RECFM=3 THEN PRINTSTRING("Un-structured") ELSESTART
!FIXED OR VARIABLE
IF RECFM=1 THEN PRINTSTRING("F") ELSE PRINTSTRING("V")
WRITE(DAH_FORMAT>>16,1); !RECORD SIZE
PRINTSTRING(" Records:")
WRITE(DAH_RECORDS,1)
FINISH
FINISH
!******************************** DIRECTORY *************************
IF FILETYPE=SSDIRFILETYPE AND OPTI&x'56'#0 THENSTART
!DIRECTORY FILE - FILES, ENTRIES,
!STRUCTURE OR ALIASES SET
ALIASHEAD=0
MAX=MAXINITIALR
FILEANAL(FILE,R,MAX,FLAG); !GET MORE INFORMATION
IF FLAG=300 START ; !NOT ENOUGH ROOM
I=x'40000'
SETWORK(I,FLAG)
IF FLAG#0 THEN ->ERR
R==ARRAY(I,RAF)
MAX=MAXR
FILEANAL(FILE,R,MAX,FLAG)
FINISH
->ERR IF FLAG#0
IF OPTI&ESET#0 START ; !LIST ENTRIES
I=1
WHILE I<=MAX CYCLE
IF R(I)_TYPE=SSOBJFILETYPE START
!FILENAME
PRINTSTRING("
File: ".R(I)_NAME)
NEWLINE
I=I+1
CPF=16; ! 16 for procedures and 17 for data.
HSTR="Procedure entries:
"
CYCLE
IF I<=MAX START
FOR J=I,1,MAX+1 CYCLE
IF J=MAX+1 OR R(J)_TYPE#CPF START
!PRINT ENTRY NAMES
IF J>I START
PRINT STRING(HSTR)
PRINTSORTEDLIST(I,J-1)
I=J
FINISH
EXIT
FINISH
REPEAT
FINISH
CPF=CPF+1
HSTR="Data entries:
"
REPEATUNTIL CPF>17
FINISHELSE I=I+1
REPEAT
FINISHELSESTART ; !DEFAULT ONLY LIST FILENAMES
IF FSET&OPTI#0 START ; !FILENAMES ONLY
IF MAX>0 START
PRINTSTRING("Files:
")
FOR I=1,1,MAX CYCLE
IF R(I)_TYPE=SSOBJFILETYPE START
PRINTSTRING(R(I)_NAME)
NEWLINE
FINISH
REPEAT
FINISH
FINISH
FINISH
IF OPTI&ASET#0 START ; !PRINT ALIASES
PRINTSTRING("
Name Alias
")
I=1
WHILE I<=MAX CYCLE
IF R(I)_TYPE=21 START ; !ALIASED NAME
CURALIASED=R(I)_NAME
I=I+1
EXITIF I>MAX
FOR J=I,1,MAX CYCLE
IF R(J)_TYPE#16 THENEXIT
PRINTSTRING(CURALIASED)
SPACE UNTIL OUTPOS>=25
PRINTSTRING(R(J)_NAME)
NEWLINE
REPEAT
I=J
FINISHELSE I=I+1
REPEAT
FINISH
IF OPTI&SSET#0 THENSTART
I=1; FILES=0; ENTRIES=0
DATAENTRIES=0; ALIASEDNAMES=0; ALIASES=0
WHILE I<=MAX CYCLE
IF R(I)_TYPE=SSOBJFILETYPE THENSTART
I=I+1
FILES=FILES+1
J=I
WHILE J<=MAX AND R(J)_TYPE=16 CYCLE
J=J+1
REPEAT
ENTRIES=ENTRIES+J-I; !PROCEDURE ENTRIES
I=J
WHILE J<=MAX AND R(J)_TYPE=17 CYCLE
J=J+1
REPEAT
DATAENTRIES=DATAENTRIES+J-I; !DATA ENTRIES
I=J
FINISHELSESTART
IF R(I)_TYPE=21 THENSTART ; !ALIASED NAME
ALIASEDNAMES=ALIASEDNAMES+1
I=I+1
J=I
WHILE J<=MAX AND R(J)_TYPE=16 CYCLE
J=J+1
REPEAT
ALIASES=ALIASES+J-I; !ADD ALIASES
I=J
FINISH
FINISH
REPEAT
DH==RECORD(RR_CONAD); !MAP DIR HEADER
HASHCONST=INTEGER(RR_CONAD+DH_DATASTART); !LENGTH OF HASH TABLE
PSTART=RR_CONAD+DH_PSTART
PLENGTH=INTEGER(PSTART)
PUSED=4; !NOW FIND END OF PLIST
WHILE BYTEINTEGER(PSTART+PUSED)#0 CYCLE
PUSED=PUSED+BYTEINTEGER(PSTART+PUSED)+1
REPEAT
I=ENTRIES+DATAENTRIES+ALIASES; !TOTAL ENTRIES
NEWLINE
PRINTSTRING("Files : "); WRITE(FILES,1); NEWLINE
PRINTSTRING("Aliased names : "); WRITE(ALIASEDNAMES,1)
NEWLINES(2)
PRINTSTRING(" Entries Hash list Plist")
NEWLINE
PRINTSTRING("Procedure :"); WRITE(ENTRIES,3)
PRINTSTRING(" Used :"); WRITE(I,3)
PRINTSTRING(" Used :"); WRITE(PUSED,4)
PRINTSTRING(" bytes"); NEWLINE
PRINTSTRING("Data :"); WRITE(DATAENTRIES,3)
PRINTSTRING(" Free :"); WRITE(HASHCONST-I,3)
PRINTSTRING(" Free :"); WRITE(PLENGTH-PUSED,4)
PRINTSTRING(" bytes"); NEWLINE
PRINTSTRING("Alias :"); WRITE(ALIASES,3)
PRINTSTRING(" %Full :"); WRITE(I*100//HASHCONST,3)
PRINTSTRING(" %Full :"); WRITE(PUSED*100//PLENGTH,4)
NEWLINE
FINISH
FINISH
!******************************** PARTITIONED *************************
!***********************************************************************
!* *
!* Routine for sorting the records of an array *
!* *
!***********************************************************************
ROUTINE NSORT(RECORD (PRINTF) ARRAYNAME P, INTEGERARRAYNAME X, INTEGER N)
! DECLARE INTEGER ARRAY X, BOUNDS 1:NUM, IN CALLING ROUTINE
INTEGER I,J,K,M,W
RETURNUNLESS N>0
!
FOR I=1,1,N CYCLE
X(I)=I
REPEAT
!
M=1
M=M<<1 WHILE M<=N
M=M-1
!
CYCLE
M=M>>1
EXITIF M=0
FOR I=1,1,N-M CYCLE
K=I
WHILE K>0 CYCLE
J=K+M
!
EXITIF P(X(K))_FNAME<=P(X(J))_FNAME
W=X(J)
X(J)=X(K)
X(K)=W
!
K=K-M
REPEAT
REPEAT
REPEAT
END ; ! OF NSORT
!
!
!***********************************************************************
!* *
!* Routine for cycling round a specified pd file, picking up the *
!* names of all its members, together with their type, date last *
!* altered and size, and moving this data into an array, which *
!* will be sorted at a later stage *
!* *
!***********************************************************************
ROUTINE PDFILE(STRING (42) S, INTEGER PDFILESTART,FMEMS,
RECORD (PRINTF) ARRAYNAME RESULT, INTEGERNAME NEXTFREE)
STRING (255) JUNK
STRING (35) NAME
STRING (8) MDATE
INTEGER OFFSET,I,J,MOFF,TYPE,MEMSIZE,PDMEMS,AOFM,CODESIZE,CODEOFFSET
OFFSET=INTEGER(PDFILESTART+24)
!
FOR I=1,1,FMEMS CYCLE
J=I-1
MOFF=INTEGER(PDFILESTART+OFFSET+J<<5)
NAME=STRING(PDFILESTART+OFFSET+4+J<<5)
TYPE=INTEGER(PDFILESTART+MOFF+12)
IF TYPE = 0 THEN TYPE = 3; ! treat as standard character file
UNLESS 1<=TYPE<=6 THEN TYPE=0
IF TYPE=0 THEN MEMSIZE=0 AND MDATE="**/**/**" ELSE C
MDATE=UNPACKDATE(INTEGER(PDFILESTART+MOFF+20)) AND C
MEMSIZE=INTEGER(PDFILESTART+MOFF)-INTEGER(PDFILESTART+MOFF+4)
JUNK=S.",".NAME
IF LENGTH(JUNK)>41 THEN LENGTH(JUNK)=41 AND JUNK=JUNK."*"
RESULT(NEXTFREE)_FNAME=JUNK
RESULT(NEXTFREE)_TYPE=TYPE
RESULT(NEXTFREE)_DATE=MDATE
RESULT(NEXTFREE)_SIZE=MEMSIZE
RESULT(NEXTFREE)_ERRMESS=0
IF TYPE=1 START
AOFM=PDFILESTART+MOFF+INTEGER(PDFILESTART+MOFF+28)
!address of object file map
CODESIZE=INTEGER(AOFM+8); !size and offset of code from object file map
CODEOFFSET=INTEGER(AOFM+4)
IF ((PDFILESTART+MOFF+CODEOFFSET)!! C
(PDFILESTART+MOFF+CODEOFFSET+CODESIZE))&x'FFFC0000'#0 THEN C
RESULT(NEXTFREE)_ERRMESS=1
FINISH
NEXTFREE=NEXTFREE+1
!
IF TYPE=6 START
PDMEMS=INTEGER(PDFILESTART+MOFF+28)
PDFILE(JUNK,PDFILESTART+MOFF,PDMEMS,RESULT,NEXTFREE) UNLESS PDMEMS<=0
FINISH
!
REPEAT
!
END ; !OF PDFILE
!
!
!***********************************************************************
!* *
!* Main routine starts here *
!* *
!***********************************************************************
ROUTINE PDANAL(STRING (31) FILE, INTEGER CONAD, INTEGERNAME FLAG)
CONSTINTEGER MAXX=512
CONSTSTRING (44) OBJECT=" is object code and crosses segment boundary"
CONSTSTRING (1) NL="
"
RECORD (PRINTF) ARRAYFORMAT PRINTFAF(1:4300)
RECORD (PRINTF) ARRAYNAME RESULT
INTEGERARRAY X(1:MAXX)
CONSTSTRING (5) ARRAY TYPEF(1:7)="N-st","Obj","Dir",
"Char","Data","C-Ob","Pd"
STRING (35) P1,P2
CONSTSTRING (4) UL="===="
INTEGER FMEMS,NEXTFREE,I,J,K
STRING (31) SP
K=x'20000'
SETWORK(K,FLAG)
PSYSMES(8,FLAG) ANDRETURNIF FLAG#0
RESULT==ARRAY(K,PRINTFAF)
FMEMS=INTEGER(RR_CONAD+28)
IF FMEMS=0 THEN PRINTSTRING(FILE." does not have any members") ANDRETURN
PRINTSTRING("Number of members in file ".FILE." = ")
WRITE(FMEMS,4)
NEWLINES(2)
PRINTSTRING("NAME"); SPACES(25); PRINTSTRING("TYPE")
SPACES(8); PRINTSTRING("DATE"); SPACES(9); PRINTSTRING("SIZE")
NEWLINE
PRINTSTRING(UL); SPACES(25); PRINTSTRING(UL); SPACES(8)
PRINTSTRING(UL); SPACES(9); PRINTSTRING(UL); NEWLINE
NEXTFREE=1
PDFILE(FILE,RR_CONAD,FMEMS,RESULT,NEXTFREE)
NEXTFREE=NEXTFREE-1
IF NEXTFREE>MAXX START
PRINTSTRING(" PDANAL fails: > 512 members") ANDRETURN
FINISH
X(I)=I FOR I=1,1,NEXTFREE
NSORT(RESULT,X,NEXTFREE)
FOR I=1,1,NEXTFREE CYCLE
J=X(I)
RESULT(J)_FNAME->P1.(",").P2
SP=""
WHILE P2->P1.(",").P2 CYCLE
SP=SP." "
P2=SP."_".P2
REPEAT
PRINTSTRING(P2)
SPACES(29-LENGTH(P2))
PRINTSTRING(TYPEF(RESULT(J)_TYPE+1))
SPACES(10-LENGTH(TYPEF(RESULT(J)_TYPE+1)))
PRINTSTRING(RESULT(J)_DATE)
SPACES(4)
WRITE(RESULT(J)_SIZE,6)
IF RESULT(J)_ERRMESS#0 START
PRINTSTRING(NL."** Member ".P2.OBJECT.NL)
FINISHELSE NEWLINE
REPEAT
END ; !OF PDANAL
!
!
IF FILETYPE=SSPDFILETYPE START
!PD FILE
IF OPTI&MSET#0 START
PDANAL(FILE,RR_CONAD,FLAG)
IF FLAG#0 THEN PRINTSTRING("PDANAL has failed")
FINISHELSESTART
MAX=MAXINITIALR; !NO OF ELEMENTS IN ARRAY R
FILEANAL(FILE,R,MAX,FLAG)
IF FLAG=300 START ; !NOT ENOUGH ROOM
I=x'40000'
SETWORK(I,FLAG)
IF FLAG#0 THEN ->ERR
R==ARRAY(I,RAF)
MAX=MAXR
FILEANAL(FILE,R,MAX,FLAG)
FINISH
->ERR IF FLAG#0
IF MAX>0 START ; !MUST BE SOME MEMBERS
PRINTSTRING("Members:")
NEWLINE
PRINTSORTED LIST(1,MAX)
FINISH
NEWLINE
FINISH
FINISH
ERR:
IF NEWCONNECT#0 THEN SETUSE (FILE, -1, 0)
ERRX:
NEWLINE
IF COST#OUTSTREAM THENSTART
SELECTOUTPUT(COST)
CLOSEST(82)
FINISH
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(16,FLAG)
END ; !OF ANALYSE
!
!
EXTERNALROUTINE TIDYDIR(STRING (255) S)
CONSTINTEGER MAXR=1500
RECORD (ARF) ARRAY R(1:MAXR)
RECORD (RF) RR
INTEGER MACNPTR,MACNH,TFNPTR,TFNH
RECORD (RF) MACRR
STRING (31) MACRONAME,DUMMYS
CONSTSTRING (9) TEMPDIR="T#TIDYDIR"
STRING (31) DIR
INTEGER HASHUSED,PLISTUSED,NEWHASH,NEWPLIST,POINT,MAX
INTEGER I,J,FLAG,PERCENT
REAL FACTOR
STRING (36) TEMPLATE
TEMPLATE="DIRECTORY=".SSOWN_AVD.",FULLPERCENT=70"
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP>3 THENSTART ; ! TOO MANY PARAMS
FLAG=263
->ERR
FINISH
IF PARMAP&1#0 THEN DIR=SPAR(1) ELSE DIR=SSOWN_AVD
IF PARMAP&2#0 THENSTART
PERCENT=PSTOI(SPAR(2))
UNLESS 10<=PERCENT<=100 THENSTART
FLAG=202; !INVALID PARAMETER
SETFNAME(SPAR(2))
->ERR
FINISH
FINISHELSE PERCENT=70; !DEFAULT
CONNECT(DIR,3,0,0,RR,FLAG); !CHECK WRITE ACCESS FOR LATER
IF FLAG#0 THEN -> ERRX
IF RR_FILETYPE#SSDIRFILETYPE THENSTART
SETFNAME(DIR)
FLAG=267; !INVALID FILETYPE
->ERR
FINISH
MAX=MAXR
FILEANAL(DIR,R,MAX,FLAG); !GET INFO
IF FLAG#0 THEN ->ERR
IF MAX#0 THENSTART
I=INTEGER(RR_CONAD+RR_DATASTART); !LENGTH OF HASH TABLE
J=INTEGER(RR_CONAD+INTEGER(RR_CONAD+24)); !LENGTH OF PLIST
DESTROY(TEMPDIR,FLAG); !IGNORE FLAG
MODDIRFILE(10,TEMPDIR,"","",0,I,J+1023,FLAG)
IF FLAG#0 THEN ->ERR; !CREATING NEW DIR
MACNH=MAX
MACNPTR=MAXR
FOR I=1,1,MAX CYCLE
IF R(I)_TYPE=SSOBJFILETYPE START
MODDIRFILE(3,TEMPDIR,"",R(I)_NAME,0,0,0,FLAG)
!INSERT
! <<<< <<<< <<<< <<<< <<<<
IF FLAG#0 THENSTART
MODDIRFILE(2,TEMPDIR,"",R(I)_NAME,0,0,0,J)
IF FLAG=267 THENSTART ; ! It might have been a macro.
CONNECT(R(I)_NAME,0,0,0,MACRR,FLAG)
IF FLAG=0 THENSTART
IF MACRR_FILETYPE#SSCHARFILETYPE THEN FLAG=267 ELSESTART
INITCLIVARS
MACOPEN
EXAMINEMACRO(MACRONAME,DUMMYS,
MACRR_DATAEND-MACRR_DATASTART,
MACRR_CONAD+MACRR_DATASTART,0,FLAG)
IF FLAG#0 THENSTART
IF FLAG=x'80000800' THEN FLAG=336 ELSEIF C
FLAG=x'80001000' THEN FLAG=337
FINISHELSESTART
MODDIRFILE(9,TEMPDIR,MACRONAME,R(I)_NAME,0,0,0,FLAG)
IF FLAG#0 THEN C
MODDIRFILE(2,TEMPDIR,"",R(I)_NAME,0,0,0,J) ELSE C
START
R(I)_TYPE=SSCHARFILETYPE
IF MACNPTR>MACNH THENSTART
R(MACNPTR)_NAME=MACRONAME
MACNPTR=MACNPTR-1
FINISH
FINISH
FINISH
FINISH
IF NEWCONNECT#0 THEN SETUSE (R(I)_NAME, -1, 0)
FINISH
FINISH
IF FLAG#0 THENSTART
PRINT STRING("File ".R(I)_NAME." removed: ")
PRINTMESS(FLAG)
R(I)_TYPE=0
FINISH
FINISH
! >>>> >>>> >>>> >>>> >>>>
FINISH
IF R(I)_TYPE=21 START ; !ALIAS
FOR J=I+1,1,MAX CYCLE
IF R(J)_TYPE#16 THENEXIT ; !LAST REACHED
MODDIRFILE(9,TEMPDIR,R(J)_NAME,"=".R(I)_NAME,0,0,0,FLAG)
REPEAT
FINISH
REPEAT
CONNECT(TEMPDIR,0,0,0,RR,FLAG); !NOW REPACKED
IF FLAG#0 THEN ->ERR
POINT=RR_CONAD+INTEGER(RR_CONAD+24)+4; !START OF PLIST
PLISTUSED=POINT; !FOR SUMMING SIZE OF PLIST
WHILE BYTEINTEGER(POINT)#0 CYCLE
POINT=POINT+BYTEINTEGER(POINT)+1
REPEAT
PLISTUSED=POINT-PLISTUSED+4
MACNH=MACNPTR
TFNPTR=MACNH
FOR I=MAX,-1,1 CYCLE
IF R(I)_TYPE=SSCHARFILETYPE THENSTART
R(TFNPTR)=R(I)
TFNPTR=TFNPTR-1
FINISH
REPEAT
TFNH=TFNPTR
MAX=TFNH
FILEANAL(TEMPDIR,R,MAX,FLAG); !GET INFO IN ARRAY
IF FLAG#0 THEN -> ERRY
FINISH
IF MAX=0 THENSTART
NEWHASH=160; ! Same as DEFAULT HASHCONST in NEWDIRECTORY.
NEWPLIST=856; ! Same as DEFAULT PLENGTH in NEWDIRECTORY.
FINISHELSESTART
IF TFNH<MACNH THENSTART
FOR I=1,1,MAX CYCLE
IF R(I)_TYPE=SSOBJFILETYPE THENSTART
FOR TFNPTR=TFNH+1,1,MACNH CYCLE
IF R(I)_NAME=R(TFNPTR)_NAME THEN R(I)=R(TFNPTR)
REPEAT
FINISH
REPEAT
FINISH
HASHUSED=0
FOR I=1,1,MAX CYCLE ; !COUNT HASH LIST ENTRIES
IF 16<=R(I)_TYPE<=17 THEN HASHUSED=HASHUSED+1
REPEAT
FACTOR=PLISTUSED/HASHUSED; !FOR CALCULATING NEW PLIST
IF FACTOR<2 THEN FACTOR=2; !MINIMUM
IF FACTOR>20 THEN FACTOR=20; !MAXIMUM
NEWHASH=HASHUSED*100//PERCENT; !MAKE IT PERCENT FULL
NEWPLIST=INT(NEWHASH*FACTOR); !IN SAME PROPORTION AS OLD DIR
IF NEWHASH<100 OR (NEWHASH<160 AND NEWPLIST<856) THENSTART
! USE DEFAULTS FOR SMALL DIRS
NEWHASH=160
NEWPLIST=856
FINISH
FINISH
IF NEWCONNECT#0 THEN SETUSE (TEMPDIR, -1, 0)
DESTROY(TEMPDIR,FLAG); !IGNORE FLAG
MODDIRFILE(10,TEMPDIR,"","",0,NEWHASH,NEWPLIST,FLAG)
IF FLAG#0 THEN ->ERR; !REMAKE DIR WITH NEW SIZES
IF MAX#0 THENSTART
MACNPTR=MAXR
FOR I=1,1,MAX CYCLE
IF R(I)_TYPE=SSOBJFILETYPE START
MODDIRFILE(3,TEMPDIR,"",R(I)_NAME,0,0,0,FLAG)
!INSERT
IF FLAG#0 THEN MODDIRFILE(2,TEMPDIR,"",R(I)_NAME,0,0,0,J)
!REMOVE
FINISH
! <<<< <<<< <<<<
IF R(I)_TYPE=SSCHARFILETYPE THENSTART
FLAG=0
IF MACNPTR>MACNH THENSTART
MACRONAME=R(MACNPTR)_NAME
MACNPTR=MACNPTR-1
FINISHELSESTART
CONNECT(R(I)_NAME,0,0,0,MACRR,FLAG)
IF FLAG=0 THENSTART
EXAMINEMACRO(MACRONAME,DUMMYS,MACRR_DATAEND-MACRR_DATASTART,
MACRR_CONAD+MACRR_DATASTART,0,FLAG)
IF FLAG=x'80000800' THEN FLAG=336 ELSEIF C
FLAG=x'80001000' THEN FLAG=337
IF NEWCONNECT#0 THEN SETUSE (R(I)_NAME, -1, 0)
FINISH
FINISH
IF FLAG=0 THENSTART
MODDIRFILE(9,TEMPDIR,MACRONAME,R(I)_NAME,0,0,0,FLAG)
IF FLAG#0 THEN MODDIRFILE(2,TEMPDIR,"",R(I)_NAME,0,0,0,J)
FINISH
FINISH
! >>>> >>>> >>>>
IF R(I)_TYPE=21 START ; !ALIAS
FOR J=I+1,1,MAX CYCLE
IF R(J)_TYPE#16 THENEXIT ; !LAST REACHED
MODDIRFILE(9,TEMPDIR,R(J)_NAME,"=".R(I)_NAME,0,0,0,FLAG)
REPEAT
FINISH
REPEAT
FINISH
IF NEWLOADER#0 AND NEWCONNECT=0 THEN SETUSE(DIR,-1,0); ! Reduce use count
NEWGEN(TEMPDIR,DIR,FLAG)
SSOWN_DIRDISCON=1; !TELL LOADER TO REBUILD SEARCH LIST
IF NEWCONNECT#0 THEN -> ERR
ERRY:
IF NEWCONNECT#0 THEN SETUSE (TEMPDIR, -1, 0)
ERRX:
IF NEWCONNECT#0 THEN DISCONNECT (DIR, I); ! Ignore flag.
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(94,FLAG)
END ; !OF TIDYDIR
!
!
EXTERNALROUTINE FILES(STRING (255) S)
STRING (31) OUT,USER,TEMPLATE
STRING (31) PATTERN,PATS,PATT,PATU,NAME,OPTIONS
INTEGER PATTYPE,ARCHSET,CHERSET,CHERISH,HAZARD,PERLINE,EXTRA,CHAR
INTEGER AFILE,FSYS
CONSTINTEGER MAXPA=201
INTEGER FILENUM,NFILES,MAXREC,COUNT,FLAG,FLAG4,I,POS,COST,PROC,FINISHED
!FLAG4 is for a specific call on DSFI 4
INTEGER NPERM,NTEMP,PERMK,TEMPK
RECORD (E31F) E31
RECORD (E4F) E4
RECORD (E9F) E9
INTEGER TLIMIT,MAXFSIZE
!
!
INTEGERFN MATCH(STRING (31) NAME,PATTERN)
! RETURNS A BOOLEAN RESULT ON
! MATCHING A NAME WITH A PATTERN
! WHICH CONTAINS "*" SYMBOLS
! TO REPRESENT AN ARBITRARY
! NO OF CHARACTERS
CONSTINTEGER TRUE=1,FALSE=0
SWITCH TYP(1:4)
NAME=UCSTRING(NAME)
IF PATTYPE=0 START ; !FIRST TIME - ANALYSE PATTERN
IF PATTERN->PATS.("*").PATT THENSTART
IF PATS#"" THEN PATTYPE=3 ELSESTART
IF PATT->PATS.("*") THEN PATTYPE=1 ELSE PATTYPE=2
FINISH
FINISHELSE PATTYPE=4
FINISH ; ! FINISHED ANALYSING
!
! 1: *PATS*
! 2: *PATT
! 3: PATS*PATT
! 4: NAME
!
->TYP(PATTYPE); ! BRANCH ON TYPE
TYP(4):
IF PATTERN=NAME THENRESULT =TRUE ELSERESULT =FALSE
TYP(1):
TYP(3):
UNLESS NAME->PATU.(PATS).NAME THENRESULT =FALSE
IF PATTYPE=1 THENRESULT =TRUE
IF PATU#"" THENRESULT =FALSE
TYP(2):
IF LENGTH(NAME)>=LENGTH(PATT) AND C
STOREMATCH(LENGTH(PATT),ADDR(PATT)+1,
ADDR(NAME)+LENGTH(NAME)-LENGTH(PATT)+1)#0 THENRESULT =TRUE ELSE C
RESULT =FALSE
END ; ! OF MATCH
!
!
ROUTINE FILESA
!THIS HAS TO BE IN A SEPARATE ROUTINE TO AVOID USING TOO MUCH STACK
!STACK IS NOT UN-DECLARED AT THE END OF A BEGIN-END BLOCK
CONSTINTEGER ARCHFLSIZE=500; ! Do 500 at a time.
RECORD (AFRECF) ARRAY APA(0:ARCHFLSIZE-1)
NEWLINE
FILENUM=0; !FIRST FILE TO BE PROVIDED - MOST RECENT
CYCLE
MAXREC=ARCHFLSIZE; !MAX NO OF FILES ACCEPTABLE
FLAG=DIRTOSS(DFILENAMES(USER,APA,FILENUM,MAXREC,NFILES,FSYS,1))
IF FLAG#0 THEN MAXREC=0
IF FILENUM=0 THENSTART
PRINTSTRING("Archived files : "); WRITE(NFILES,1)
NEWLINES(2)
IF FLAG#0 THENRETURN
FINISH
E31=0
! FLAG=DSFI(USER,FSYS,31,0,ADDR(E31)); !DSFI ENTRY 31
! %IF E31_TOTSIZE > 0 %THEN %START
! PRINTSTRING(" Total size : ")
! WRITE(E31_TOTSIZE,1)
! PRINTSYMBOL('K')
! %FINISH
I=0
WHILE I<MAXREC CYCLE
NAME=APA(I)_NAME
IF PATTERN="" OR MATCH(NAME,PATTERN)=1 START
PRINTSTRING(NAME)
SPACES(13-LENGTH(NAME))
PRINTSTRING(APA(I)_DATE)
WRITE(APA(I)_KBYTES,5)
NEWLINE
FINISH
I=I+1
REPEAT
FILENUM=FILENUM+MAXREC
REPEATUNTIL FILENUM>=NFILES
END ; !OF FILESA
!
!
TEMPLATE="NAMES=*,OPTIONS=I,OUT="
FLAG=0
PERLINE=UINFI(15)//14; !NO OF FILENAMES PER LINE
COST=OUTSTREAM
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP>7 THENSTART
FLAG=263
->ERR
FINISH
PATTERN=SPAR(1); !MASK FOR FILENAMES
IF PATTERN->USER.(".").PATTERN THENSTART
FSYS=-1
FLAG=DFSYS(USER,FSYS)
FINISHELSESTART
USER=UINFS(1)
FSYS=UINFI(1)
FINISH
IF FLAG#0 THEN START
PRINTSTRING("No information available about user ".USER)
NEWLINE
RETURN
FINISH
PATTYPE=0; !INITIALISE
CHERISH=0
HAZARD=0
EXTRA=0
AFILE=0
PROC=0
COUNT=0
FINISHED=0
OPTIONS=SPAR(2)
IF OPTIONS="" THEN OPTIONS="I"
IF OPTIONS="*" THEN OPTIONS="ESAP"; !ALL POSSIBLE INFO
FOR I=LENGTH(OPTIONS),-1,1 CYCLE
CHAR=CHARNO(OPTIONS,I)
IF CHAR='C' THEN CHERISH=1 ELSEIF CHAR='H' THEN HAZARD=1 ELSEIF C
CHAR='S' THEN PERLINE=1 ELSEIF CHAR='A' THEN AFILE=1 ELSEIF C
CHAR='P' THEN PROC=1 ELSEIF CHAR='E' THENSTART
! PRINT EXTRA INFO
EXTRA=1
PERLINE=1
FINISHELSEIF CHAR='I' THENSTART
CHERISH=1
HAZARD=1
FINISH
REPEAT
IF PERLINE=1 AND CHERISH=0=HAZARD THENSTART ; ! DEAL WITH S ON ITS OWN
CHERISH=1
HAZARD=1
FINISH
OUT=SPAR(3)
IF OUT#"" START
SETOUTPUT(OUT,FLAG)
->ERR IF FLAG#0
FINISH
IF PATTERN="*" THEN PATTERN=""
E4=0
FLAG4=DSFI(USER,FSYS,4,0,ADDR(E4))
IF FLAG4=0 THEN NFILES=E4_FILES ELSE NFILES=MAXPA
BEGIN
RECORD (FRECF)ARRAY PA(0:NFILES-1)
RECORD (FRECF)NAME P
ROUTINE FLSORT(INTEGER M,N)
! This routine sorts the records for FLIST held in %RECORD (FRECF)%ARRAY PA.
INTEGER I,J,K,L,N1
RECORD (FRECF) X
! There are N - M + 1 elements to be sorted.
L=M-1; ! L is never changed in this routine. Nor are M and N.
! N1 = 1
! %WHILE N1<N-L %CYCLE
! N1 = 2 * N1
! %REPEAT
! N1 is now the smallest (+ve integral) power of 2 which
! is not less than N-M+1. There is probably a faster way
! to find this, but I can't be bothered with it just now.
! Here it is - using the bit twiddling expression
! 1 << ((32 - SHZ(N-L-1)) & 31)
*lss_N; *isb_L; *isb_1; *shz_ TOS ; *lb_32; *sbb_ TOS
*lss_1; *rot_ B ; *st_N1
!
!
CYCLE
N1=N1//2
! N1 is now zero, or else a power of 2 less than N-M+1.
RETURNIF N1=0
! N1 is now a power of 2 less than N-M+1.
I=L; ! = M - 1.
CYCLE
I=I+1
J=I+N1
EXITIF J>N
K=I
WHILE UCSTRING(PA(J)_NAME)<UCSTRING(PA(K)_NAME) CYCLE
! J = K + N1, K>=M, J<=N.
X=PA(J)
PA(J)=PA(K)
PA(K)=X
J=K
K=K-N1
EXITIF K<M
REPEAT
! K<M or PA(J)_NAME>=PA(K)_NAME.
! Every N1th. element from the Kth. to the (I+N1)th. is
! in ascending order.
REPEAT
REPEAT
END ; ! of FLSORT.
!LIST ALL FILENAMES
IF PROC=1 THENSTART
FILENUM=0
FLAG=DFILENAMES(USER,PA,FILENUM,NFILES,COUNT,FSYS,0)
! **** FLAG needs translating via DIRTOSS ****
! **** to give Subsystem error number ****
IF FLAG#0 THENSTART
FINISHED=-1
-> STOP
FINISH
NPERM=0; NTEMP=0
PERMK=0; TEMPK=0
FOR I=0,1,NFILES-1 CYCLE
P==PA(I)
IF CHARNO(P_NAME,1)#'#' THENSTART
IF P_CODES&x'0C'=0 THENSTART ; ! PERMANENT
NPERM=NPERM+1
PERMK=PERMK+P_KBYTES
FINISHELSESTART ; !TEMPORARY
NTEMP=NTEMP+1
TEMPK=TEMPK+P_KBYTES
FINISH
FINISH
REPEAT
E9=0
FLAG=FLAG4!DSFI(USER,FSYS,9,0,ADDR(E9))!DSFI(USER,FSYS,11,0,ADDR(TLIMIT))!DSFI(USER,FSYS,12,0,ADDR(MAXFSIZE))
!Unless all calls on DSFI are successful, then fail
IF FLAG#0 THEN START
PRINTSTRING("No information available about user ".USER)
NEWLINE
FINISHED=-1
-> STOP
FINISH
NEWLINE
PRINTSTRING("Disc files :"); WRITE(NPERM,5)
PRINTSTRING(" Temp files :"); WRITE(NTEMP,5)
PRINTSTRING(" Archived files :");WRITE(E9_ARFILES,5);NEWLINE
PRINTSTRING("Total size :"); WRITE(PERMK,5)
PRINTSTRING("K Temp total :"); WRITE(TEMPK,5)
PRINTSYMBOL('K'); NEWLINE
PRINTSTRING("Total limit :"); WRITE(TLIMIT,5)
PRINTSTRING("K Maxfilesize :"); WRITE(MAXFSIZE,5)
PRINTSYMBOL('K'); NEWLINE
PRINTSTRING("Index size :"); WRITE(E4_INDEX+1,5); !allow 1 extra Kbyte for fixed area
PRINTSYMBOL('K')
NEWLINES(2)
PRINTSTRING("Index space unused:")
NEWLINE
PRINTSTRING("File Descs :"); WRITE(E4_FREEDESC,5)
PRINTSTRING(" Sect Descs :"); WRITE(E4_FREESECDESC,5)
PRINTSTRING(" Perm Descs :"); WRITE(E4_FREEPERMDESC,5)
NEWLINE
PRINTSTRING("Archived File Descs :");WRITE(E9_FREEFDES,5)
PRINTSTRING(" Archived Perm Descs :");WRITE(E9_FREEPDES,5)
NEWLINES(2)
! NOW PRINT .ALL PERMISSIONS, IF ANY - BUT ONLY IF USER IS YOURSELF
IF USER=UINFS(1) START
FLAG{PRINT INDEX PERMS}=PXP(".ALL Access Permissions
","
")
FINISH
FINISH
UNLESS CHERISH=HAZARD=0 START
IF COUNT=0 THENSTART
FILENUM=0
FLAG=DFILENAMES(USER,PA,FILENUM,NFILES,COUNT,FSYS,0)
! **** FLAG needs translating via DIRTOSS ****
! **** to give subsystem error flag ****
IF FLAG#0 THENSTART
FINISHED=-1
-> STOP
FINISH
FINISH
COUNT=NFILES
FLSORT(0,COUNT-1)
POS=0
IF EXTRA=1 THEN PRINTSTRING(" Name Kbytes OWNP EEP")
NEWLINES(2)
FOR I=0,1,COUNT-1 CYCLE
P==PA(I)
NAME=P_NAME
CHERSET=P_CODES&x'10'; !CHERISH STATUS SET
ARCHSET=(P_ARCH>>7)&(P_CODES>>4); !ARCHIVE REQUEST SET
IF LENGTH(NAME)<2 OR SUBSTRING(NAME,1,2)#"T#" OR EXTRA=1 THENSTART
!OMIT T# FILES
IF CHARNO(NAME,1)#'#' AND (PATTERN="" OR C
MATCH(NAME,PATTERN)=1) THENSTART
IF (CHERISH=1 AND CHERSET#0) OR (HAZARD=1 AND CHERSET=0) THEN C
START
IF ARCHSET#0 THEN PRINTSTRING("**") ELSEIF CHERSET#0 THEN C
PRINTSTRING("* ") ELSE PRINTSTRING(" ")
PRINTSTRING(NAME)
SPACES(LENGTH(NAME)-12)
IF EXTRA=1 START ; !PRINT SIZE,OWNP,EEP,CON
SPACES(14-LENGTH(NAME))
WRITE(P_KBYTES,5)
SPACES(3)
PRINTSTRING(PPER(P_OWNP&15))
SPACES(3)
PRINTSTRING(PPER(P_EEP&7))
FINISH
POS=POS+1
IF (POS//PERLINE)*PERLINE#POS THEN C
SPACES(12-LENGTH(NAME)) ELSE NEWLINE
FINISH
FINISH
FINISH
REPEAT
FINISH
STOP:
END
IF FINISHED#0 THEN RETURN
IF AFILE#0 THEN FILESA; !LIST FILES ON ARCHIVE
ERR:
NEWLINE
IF COST#OUTSTREAM THENSTART
SELECTOUTPUT(COST)
CLOSEST(82)
FINISH
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(20,FLAG)
END ; !OF FILES
!
!
EXTERNALROUTINE COPY(STRING (255) S)
INTEGER OLDCONAD,NEWCONAD,OLDLEN,DUMMY,FLAG
RECORD (RF) RR,RN
STRING (31) OLD,NEW,NEWFILE,NEWMEMBER
STRING (7) TEMPLATE
TEMPLATE="FROM,TO"
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP#3 THENSTART ; ! WRONG NO OF PARAMS
FLAG=263
-> ERRX
FINISH
OLD=SPAR(1)
NEW=SPAR(2)
CONNECT(OLD,0,0,0,RR,FLAG); !{SEQ}
IF FLAG#0 THEN -> ERRX
IF NEWCONNECT=0 THEN SETUSE(OLD,1,0); !SET USE TO AVOID COPY(A,A) ETC
OLDCONAD=RR_CONAD
OLDLEN=INTEGER(RR_CONAD)
IF NEW->NEWFILE.("_").NEWMEMBER START
!COPY INTO PD FILE
MODPDFILE(2,NEWFILE,NEWMEMBER,"",FLAG)
!DESTROY MEMBER IF NECC
MODPDFILE(1,NEWFILE,NEWMEMBER,OLD,FLAG); !ADD NEW MEMBER
->ERR
FINISH
CONNECT(NEW,0,OLDLEN,0,RN,FLAG); !CHECK FOR COPY INTO PDFILE
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
IF FLAG=0 AND RN_FILETYPE=SSPDFILETYPE THENSTART
FLAG=310
->ERR
FINISH
OUTFILE(NEW,OLDLEN,OLDLEN,0,NEWCONAD,FLAG); !{SEQ}
->ERR IF FLAG#0
MOVE(OLDLEN,OLDCONAD,NEWCONAD)
DISCONNECT(NEW,DUMMY); !IGNORE FAILURE
ERR:
SETUSE(OLD,-1,0); !REMOVE USE
ERRX:
COMREG(24)=FLAG
IF FLAG=0 THEN PRINTSTRING(NEW." is a copy of ".OLD."
") ELSE PSYSMES(9,FLAG)
END ; !OF COPY
!
!
EXTERNALROUTINE NEWPDFILE(STRING (255) FILE)
INTEGER FLAG
RECORD (FRF) FR
UCTRANSLATE(ADDR(FILE)+1,LENGTH(FILE))
FINFO(FILE,0,FR,FLAG)
IF FLAG=0 THENSTART ; ! FILE ALREADY EXISTS
FLAG=219
->ERR
FINISH
MODPDFILE(4,FILE,"","",FLAG)
IF FLAG#0 THEN ->ERR
!**VERY TEMP*** WHEN DIRECTOR CORRECTED REMOVE COMMENT FROM NEXT LINE
!PERMIT(FILE,UINFS(1),15,FLAG); !PERMIT READ,WRITE EXECUTE AND PROTECT
ERR:
COMREG(24)=FLAG
IF FLAG=0 THEN PRINTSTRING("New partitioned file '".FILE."' created
") ELSE PSYSMES(51,FLAG)
END ; !OF NEWPDFILE
!
!
EXTERNALROUTINE CONVERT(STRING (255) S)
!INITIAL VERSION JUST CONVERTS DATA FILE TO CHAR FILE
STRING (31) IN,OUT
INTEGER OUTLENGTH,OUTCONAD,FLAG,DUMMY
RECORD (RF) RR
RECORD (HF) NAME H
STRING (7) TEMPLATE
TEMPLATE="IN,OUT"
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP#3 THENSTART ; ! WRONG NO OF PARAMS
FLAG=263
-> ERRX
FINISH
IN=SPAR(1)
OUT=SPAR(2)
CONNECT(IN,0,0,0,RR,FLAG); !{SEQ}
-> ERRX IF FLAG#0
IF NEWCONNECT=0 THEN SETUSE(IN,1,0); !SET USE TO AVOID CONVERT(A,A)
IF RR_FILETYPE#SSDATAFILETYPE THENSTART ; ! INVALID FILETYPE
FLAG=267
->ERR
FINISH
OUTLENGTH=FLC(1,RR_CONAD,0,FLAG) {file length}
->ERR IF FLAG#0
OUTFILE(OUT,OUTLENGTH+32,0,0,OUTCONAD,FLAG); !{SEQ}
->ERR IF FLAG#0
H==RECORD(OUTCONAD)
H_DATAEND=OUTLENGTH+32
H_DATASTART=32
H_FILETYPE=SSCHARFILETYPE
FCONV(1,RR_CONAD,OUTCONAD+32,0,FLAG)
DISCONNECT(OUT,DUMMY)
->ERR IF FLAG#0
PRINTSTRING("Data file ".IN." converted to character file ".OUT)
NEWLINE
ERR:
SETUSE(IN,-1,0); !REMOVE USE
ERRX:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(54,FLAG)
END ; !OF CONVERT
!
!
EXTERNALROUTINE DELETEDOC(STRING (255) S)
STRING (255) PARM
STRING (63) MESSAGE
RECORD (PF) P
STRING (11) IDENT
INTEGER I,J,FLAG,TRANS
COMREG(24)=0
SETPAR(S)
CYCLE
PARM=SPAR(0)
RETURN IF PARM=""
TRANS=STARTSWITH(PARM,"T",-1)
I=PSTOI(PARM); !CHECK NUMERIC
UNLESS 1<=I<=999999 THENSTART
FLAG=202; !INVALID PARAMETER
SETFNAME(PARM)
->ERR
FINISH
IDENT=PARM
WHILE LENGTH(IDENT)<4 OR LENGTH(IDENT)=5 CYCLE
IDENT="0".IDENT
REPEAT ; !FOUR CHARS LONG
IF LENGTH(IDENT)=4 THEN IDENT=ITOS(UINFI(1)).IDENT; !TO MAKE SPOOLR IDENT
WHILE LENGTH(IDENT)<6 CYCLE
IDENT="0".IDENT
REPEAT
MESSAGE="COMMAND DELETE ".IDENT
J=LENGTH(MESSAGE)
P=0
IF TRANS=0 THEN FLAG=DSPOOL(P,J,ADDR(MESSAGE)+1) ELSE C
FLAG=DEXECMESS("FTRANS",0,J,ADDR(MESSAGE)+1)
IF FLAG#0 THENSTART
IF FLAG=205 THEN FLAG=318 {DOC NOT QUEUED} ELSEIF FLAG=213 THEN C
FLAG=317 {OTHER USERS DOC} ELSEIF FLAG=236 THEN C
FLAG=284 {SPOOLR FAILS} ELSEIF FLAG<200 THEN FLAG=DIRTOSS(FLAG)
SETFNAME(PARM)
FINISH
ERR:
COMREG(24)=FLAG IF FLAG#0
IF FLAG#0 THEN PSYSMES(97,FLAG)
REPEAT
END ; !OF DELETEDOC
!
!
EXTERNALROUTINE DOCUMENTS(STRING (255) S)
CONSTSTRING (9) DOCINFO="T#DOCINFO"
RECORD (RF) R
RECORD (FHF) NAME FH
RECORD (INFOF) NAME INFO
STRING (64) MESSAGE
STRING (63) PARAM1
STRING (31) OUT
STRING (15) QUEUE,LAST QUEUE,TEMPLATE
STRING (11) IDENT
INTEGER LM,LI,I,J,ENTRIES,FLAG,ST,COST
!
! **** ****
CONSTINTEGER OFFSET=7; ! If FSYS numbers can get larger than 99,
! then this should be declared as
! %INTEGER OFFSET: see below.
! **** ****
!
CONSTSTRING (15) ARRAY STATES(-1:7)= C
"Completed","Deleted","Queued","Sending","Running",
"Receiving","Processing","Transferring","Held"
CONSTSTRING (5) ARRAY PR(0:5)= C
"OLD","Vlow","Low","Std","High","Vhigh"
CONSTSTRING (6) ARRAY MOD(0:2)= C
"ISO","EBCDIC","Binary"
CONSTSTRING (3) ARRAY RERUN(0:1)= C
"No","Yes"
ROUTINE GET SPOOLR INFO
RECORD (PF) P
FLAG=DSPOOL(P,LENGTH(MESSAGE),ADDR(MESSAGE)+1)
IF FLAG#0 THENSTART
IF FLAG>200 THEN FLAG=284 ELSE FLAG=DIRTOSS(FLAG)
RETURN
FINISH
I=DFSTATUS(UINFS(1),DOCINFO.ITOS(UINFI(13)),UINFI(1),5,0)
!MAKE TEMP
CONNECT(DOCINFO,3,0,0,R,FLAG)
IF FLAG#0 THENRETURN
FH==RECORD(R_CONAD)
ENTRIES=(FH_END-FH_START)//256
IF ENTRIES>0 AND INTEGER(R_CONAD+32)#1 THENSTART
! WRONG VSN
FLAG=284
RETURN
FINISH
END ; !OF GET SPOOLR FILE
!
!
ROUTINE PS(STRING (63) TYPE,VALUE)
RETURNIF VALUE=""
IF OUTPOS#0 THENSTART
PRINTSTRING(", ")
IF OUTPOS+LENGTH(TYPE)+LENGTH(VALUE)+2>72 THEN NEWLINE
FINISH
PRINTSTRING(TYPE."=".VALUE)
END ; !OF PS
!
!
STRINGFN DT(INTEGER PACKED)
RESULT =UNPACKDATE(PACKED)." ".UNPACKTIME(PACKED)
END ; !OF DT
!
!
!*
!*
FLAG = 0
TEMPLATE="NUMBER=,OUT="
IF NEWCONNECT#0 THEN R = 0
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
COST=OUTSTREAM
UNLESS 0<=PARMAP<=3 THENSTART ; ! WRONG NO OF PARAMS
FLAG=263
->ERR
FINISH
PARAM1=SPAR(1)
OUT=SPAR(2)
IF OUT#"" THENSTART
SETOUTPUT(OUT,FLAG)
IF FLAG#0 THEN ->ERR
FINISH
IF STARTSWITH(PARAM1,"T",-1)#0 THEN START
TRANSFERS(PARAM1)
->ERR
FINISH
DESTROY(DOCINFO,I); !IGNORE FLAG
IF PARAM1#"" AND '0'<=CHARNO(PARAM1,1)<='9' THENSTART
!IDENT GIVEN
IDENT<-PARAM1
I=PSTOI(IDENT); !CHECK NUMERIC
UNLESS 1<=I<=999999 THENSTART
FLAG=202; !INVALID PARAMETER
SETFNAME(IDENT)
->ERR
FINISH
LI=LENGTH(IDENT)
IF LI<6 THENSTART
!
! **** ****
! OFFSET = 7 would be necessary if we had to cope with UINFI(1)>99.
! **** ****
!
IF LI<=4 THENSTART
MESSAGE=ITOS(UINFI(1))
LM=LENGTH(MESSAGE); ! I'll assume that MESSAGE is non-null,
! i.e., that LM>0 ,
! and also that LM<=2,
! i.e., that UINFI(1)<100.
!
! **** ****
! If UINFI(1) can be > 99, we will need to do:
! %IF LM>2 %THEN OFFSET = LM + 5
! **** ****
!
FINISHELSE LM=0
MOVE(LI,ADDR(IDENT)+1,ADDR(IDENT)+OFFSET-LI)
FILL(6-LI,ADDR(IDENT)+1,'0')
MOVE(LM,ADDR(MESSAGE)+1,ADDR(IDENT)+OFFSET-4-LM)
LENGTH(IDENT)=OFFSET-1
FINISH
MESSAGE="COMMAND FIND ".IDENT.",".DOCINFO.ITOS(UINFI(13))
GET SPOOLR INFO
IF FLAG#0 THEN ->ERR
IF ENTRIES#1 THENSTART ; !OTHER USERS DOC
FLAG=317
SETFNAME(PARAM1)
->ERR
FINISH
INFO==RECORD(R_CONAD+32)
IF INFO_PRIORITY<0 THENSTART
IF INFO_STATE=1 THEN INFO_STATE=7; !HELD, NOT QUEUED
INFO_PRIORITY=-INFO_PRIORITY
FINISH
ST=INFO_STATE
IF ST=0 AND INFO_DT STARTED#0 THEN ST=-1
!COMPLETED
PS("Name",INFO_NAME)
MESSAGE=STATES(ST)
IF INFO_DT DELETED#0 THEN MESSAGE=MESSAGE." at ".DT(INFO_DT DELETED)
PS("State",MESSAGE)
PS("Queue",".".INFO_DEST)
PS("Source",INFO_SRCE)
PS("Out",INFO_OUTPUT)
PS("Received",DT(INFO_DT RECEIVED))
IF INFO_DT STARTED#0 THEN PS("Started",DT(INFO_DT STARTED))
IF INFO_TIME>0 THEN PS("Time",ITOS(INFO_TIME)."s") ELSESTART
I=(INFO_DATALENGTH+1023)>>10
PS("Size",ITOS(I)."K")
FINISH
PS("Priority",PR(INFO_PRIORITY))
IF INFO_START AFTER DT#0 THEN PS("Start after",DT(INFO_START AFTER DT))
IF INFO_FORMS#0 THEN PS("Forms",ITOS(INFO_FORMS))
PS("Mode",MOD(INFO_MODE))
IF INFO_COPIES>1 THEN PS("Copies",ITOS(INFO_COPIES))
IF INFO_ORDER>1 THEN PS("Order",ITOS(INFO_ORDER))
IF INFO_TIME>0 THEN PS("Rerun",RERUN(INFO_RERUN))
IF INFO_TAPES>0 THEN PS("Tape decks",ITOS(INFO_TAPES))
IF INFO_DISCS>0 THEN PS("Disc drives",ITOS(INFO_DISCS))
MESSAGE=""
FOR I=8,-1,1 CYCLE
MESSAGE=MESSAGE.INFO_VOL LABEL(I)
IF MESSAGE#"" AND CHARNO(MESSAGE,LENGTH(MESSAGE))#',' THEN C
MESSAGE=MESSAGE.","
REPEAT
IF MESSAGE#"" THENSTART
LENGTH(MESSAGE)=LENGTH(MESSAGE)-1; ! Discard final comma.
PS("Volumes",MESSAGE)
FINISH
IF INFO_FAILS>0 THEN PS("Fails",ITOS(INFO_FAILS))
NEWLINE
!*
FINISHELSESTART ; !QUEUE INFO WANTED
!*
QUEUE<-PARAM1
IF QUEUE#"" THENSTART
IF CHARNO(QUEUE,1)='.' THEN CHOPLDR(QUEUE,1) ELSESTART
FLAG=202; !INVALID PARAMETER
SETFNAME(QUEUE)
->ERR
FINISH
FINISH
MESSAGE="COMMAND QUEUE ".QUEUE.",".DOCINFO.ITOS(UINFI(13))
GET SPOOLR INFO
IF FLAG#0 THEN ->TER
IF ENTRIES<1 THENSTART
PRINTSTRING("No documents found")
IF QUEUE#"" THEN PRINTSTRING(" for .".QUEUE)
NEWLINE
->TER
FINISH
LAST QUEUE=""
NEWLINE; SPACES(24)
PRINTSTRING("Ident Date Time Priority Size Ahead")
FOR I=1,1,ENTRIES CYCLE
INFO==RECORD(R_CONAD+I*256-224)
IF INFO_DEST#LAST QUEUE THENSTART ; !ADD SUBHEADING FOR Q
NEWLINE
PRINTSTRING("Queue .".INFO_DEST)
NEWLINES(2)
LAST QUEUE=INFO_DEST
FINISH
IF INFO_PRIORITY<0 THENSTART
PRINT SYMBOL('*')
INFO_PRIORITY=-INFO_PRIORITY
FINISH
PRINTSTRING(INFO_NAME)
! If the FSYS in IDENT is the same as the user's FSYS,
! then strip it off:
IF PSTOI(SUBSTRING(INFO_IDENT,1,2))=UINFI(1) THENSTART
J=3
WHILE CHARNO(INFO_IDENT,J)='0' AND J<6 CYCLE
J=J+1
REPEAT
INFO_IDENT=SUBSTRING(INFO_IDENT,J,6)
FINISH
IF OUTPOS>23 OR OUTPOS+LENGTH(INFO_IDENT)>27 THEN NEWLINE
SPACES(28-OUTPOS-LENGTH(INFO_IDENT))
PRINTSTRING(INFO_IDENT)
SPACES(30-OUTPOS)
PRINTSTRING(DT(INFO_DT RECEIVED))
PRINTSTRING(" ".PR(INFO_PRIORITY))
SPACES(56-OUTPOS)
IF INFO_TIME>0 THENSTART
WRITE(INFO_TIME,5)
PRINTSTRING("s")
IF INFO_AHEAD=0 AND 1<INFO_STATE<6 THENSTART
SPACES(6)
PRINT STRING(STATES(INFO_STATE))
FINISHELSESTART
WRITE(INFO_AHEAD,6)
PRINTSTRING("s")
FINISH
FINISHELSESTART
WRITE((INFO_DATALENGTH+1023)>>10,5)
PRINTSTRING("K")
IF INFO_AHEAD=0 AND 1<INFO_STATE<6 THENSTART
SPACES(6)
PRINT STRING(STATES(INFO_STATE))
FINISHELSESTART
WRITE((INFO_AHEAD+1023)>>10,6)
PRINTSTRING("K")
FINISH
FINISH
NEWLINE
REPEAT
NEWLINE
TER:
IF QUEUE="" OR QUEUE="FTP" THEN TRANSFERS("")
FINISH
ERR:
IF NEWCONNECT#0 AND R_CONAD#0 THEN DISCONNECT (DOCINFO,I)
IF COST#OUTSTREAM THENSTART
SELECTOUTPUT(COST)
CLOSEST(82)
FINISH
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(96,FLAG)
END ; !OF DOCUMENTS
!
!
ROUTINE DETACHOBEY(INTEGER MODE, STRING (255) S)
!MODE=0 NORMAL DETACH MODE
!MODE=1 DETACHJOB MODE - CALLS OBEYJOB TO EXECUTE
RECORD (PF) P
RECORD (JTABF) ARRAY TAB(1:16)
CONSTSTRING (5) DETFILE="T#DET"
STRING (15) IDENT
STRING (255) INPUT,MESSAGE,WORK,DSTR,PRIORITY
STRING (255) NAME LINE
STRING (31) CONTROL
RECORD (RF) RR
INTEGER SECS,FLAG,TOP,I,CIST,CALLERSMODE
STRING (8) SSECS
STRING (27) TEMPLATE
BYTEINTEGER CHAR
TEMPLATE="FILE,SECONDS=".ITOS(DEFJCPL).",CONTROL="
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IDENT=""
MESSAGE=""
CIST=-1; !TO SHOW NO SELECT DONE
IF PARMAP&3#3 OR PARMAP>7 THENSTART ; ! WRONG NO OF PARAMS
FLAG=263
->ERR
FINISH
INPUT=SPAR(1)
SSECS=SPAR(2)
SECS=PSTOI(SSECS)
UNLESS 0<SECS<=MAXJCPL THENSTART ; !LIMIT HELD AS SECS
FLAG=202
SETFNAME(SSECS)
->ERR
FINISH
CONTROL=SPAR(3)
IF CONTROL#"" THENSTART ; !READ FURTHER PARAMS FROM CONTROL
! See if input is coming from someone typing at a console.
IF CONTROL=".IN" AND UINFI(2)=1 THEN CALLERSMODE=1 ELSE CALLERSMODE=0
CIST=INSTREAM
SETINPUT(CONTROL,FLAG)
IF FLAG#0 THEN ->ERR
PROMPT("DOC param:")
CYCLE
IF FLAG=0 THEN LINE==CONTROL LINE(FLAG) ELSE FLAG=-1
EXITIF FLAG<0
CASTOUT(LINE)
EXITIF LINE=".END"
IF LINE->DSTR.(",").WORK THEN START
! More than one param provided.
! If running in foreground with input from the console then
! warn and offer another chance else fatal error.
PRINTSTRING( "**Syntax error - Only one param per line")
IF CALLERSMODE#0 THEN PRINTSTRING("...Try again
") AND CONTINUE ELSE START
FLAG=320; !Illegal parameter format
NEWLINE
->ERR
FINISH
FINISH
IF MACHINE=2960 THENSTART
IF STARTSWITH(LINE,"PRTY=",0)#0 AND UINFI(4)>9 THEN LINE="PRTY=STD"
FINISH
IF LINE->DSTR.("NAME=").WORK AND DSTR="" THEN IDENT=WORK ELSEIF C
LINE->DSTR.("OUT=.").WORK AND DSTR="" THEN LINE="OUT=".WORK ELSE C
IF LINE->DSTR.("OUTNAME=").WORK AND DSTR="" THEN START
FLAG=CHECKFILENAME(WORK,5); ! Check for valid own filename
! However this is not enough since CHECKFILENAME is quite happy
! with an all numeric filename so .......
IF LENGTH(WORK)>7 AND CHARNO(WORK,7)='.' THEN CHAR=CHARNO(WORK,8) C
ELSE CHAR=CHARNO(WORK,1)
UNLESS 'A'<=CHAR<='Z' THEN SSOWN_SSFNAME=WORK AND FLAG=220
IF FLAG#0 THEN START
IF CALLERSMODE#0 THEN START
PRINTSTRING("**Syntax error - Invalid filename ".WORK."...Try again
")
FLAG=0
CONTINUE
FINISH ELSE ->ERR
FINISH
FINISH ELSE IF STARTSWITH(LINE,"PRTY=",0)#0 THEN PRIORITY=LINE
MESSAGE=MESSAGE.",".LINE
REPEAT
FINISH
TOP=16
JOINFILES(INPUT,TAB,0,1,TOP,FLAG)
->ERR IF FLAG#0
JOIN(TAB,1,TOP,DETFILE,0,FLAG)
->ERR IF FLAG#0
CONNECT(DETFILE,3,0,0,RR,FLAG)
->ERR IF FLAG#0
INTEGER(RR_CONAD+24)=MODE; !TO INDICATE TYPE OF PROCESSING
DISCONNECT(DETFILE,FLAG)
IF IDENT="" THENSTART
IDENT<-INPUT; !FIRST 15 CHAS OF INPUT FILENAMES
MESSAGE=MESSAGE.",NAME=".IDENT
FINISH
MESSAGE="DOCUMENT SRCE=".DETFILE.ITOS(UINFI(13)).",DEST=BATCH,TIME=".ITOS C
(SECS).",START=".ITOS(RR_DATASTART).",LENGTH=".ITOS C
(RR_DATAEND-RR_DATASTART).MESSAGE
P=0; ! CLEAR OUT RECORD
FLAG=DSPOOL(P,LENGTH(MESSAGE),ADDR(MESSAGE)+1)
IF 203<=FLAG<=204 THENSTART ; ! QUEUE FULL:
FLAG=331
->ERR
FINISH
IF FLAG=237 THENSTART ; ! Invalid OUT=
FLAG=339
->ERR
FINISH
IF FLAG=225 THENSTART
SETFNAME(PRIORITY)
FLAG=202
->ERR
FINISH
! We could also check for 238 (invalid OUTLIM=) and 239 (invalid OUTNAME=),
! but both of those are adequately handled by the following code:
! ** This is not true for 239 at any rate, SPOOLR doesn't check.
! ** Invalid OUTNAME is intercepted above.
IF P_P3#0#P_P1 START
P_P3=P_P3+9; !ALLOW FOR "DOCUMENT "
PRINTSTRING("
Incorrect parameter - ")
FOR I=P_P3-1,-1,1 CYCLE ; !P3 POINTS TO COMMA AT END OF INVALID PARAM
IF CHARNO(MESSAGE,I)=',' THENSTART ; !PREVIOUS COMMA
WHILE I<P_P3 CYCLE
I=I+1
PRINTSYMBOL(CHARNO(MESSAGE,I))
REPEAT
EXIT
FINISH
REPEAT
FLAG=0
->ERR
FINISH
->ERR IF FLAG#0
PRINTSTRING(INPUT." is Batch queue entry")
WRITE(P_P2&x'FFFFFF',1); !SPOOLER IDENT LESS FSYS
PRINT STRING(". Time limit ".ITOS(SECS)." secs.
")
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(13,FLAG)
IF CIST>=0 THENSTART
SELECTINPUT(CIST)
CLOSEST(81)
FINISH
END ; !OF DETACHOBEY
!
!
EXTERNALROUTINE DETACH(STRING (255) S)
DETACHOBEY(1,S)
END ; !OF DETACH
!
!
EXTERNALROUTINE DETACHJOB(STRING (255) S)
DETACHOBEY(0,S)
END ; !OF DETACHJOB
!
!
EXTERNALROUTINE DISCARD(STRING (255) CFILE)
STRING (80) FILE,DATE
INTEGER FLAG,COUNT,CIST,INFILE
ROUTINE GETFILEANDDATE
STRING (255) NAME LINE
STRING (255) LINE1
INTEGER FLAG
PROMPT("File Date:")
LINE==CONTROL LINE(FLAG)
IF FLAG#0 THENSTART ; !SIGNAL END OF LIST
FILE=".END"
RETURN
FINISH
! Remove multiple spaces:
LENGTH(LINE)=SINGLE SPACES(LENGTH(LINE),ADDR(LINE)+1,ADDR(LINE)+1)
! Remove leading space (there can be at most one, after SINGLE SPACES):
IF CHARNO(LINE,1)=' ' THENSTART
CHARNO(LINE,1)=LENGTH(LINE)-1
LINE==STRING(ADDR(LINE)+1)
FINISH
UNLESS LINE->FILE.(" ").DATE THENSTART
FILE=LINE
DATE=""
FINISH
UCTRANSLATE(ADDR(FILE)+1,LENGTH(FILE))
IF DATE->DATE.(" ").LINE1 THENSTART
FINISH ; !REMOVE REST OF LINE
END ; !OF GETFILEANDDATE
!
!
COUNT=0
CIST=-1
IF CFILE#"" START ; !READ NAMES FROM CFILE
UCTRANSLATE(ADDR(CFILE)+1,LENGTH(CFILE))
SETINPUT(CFILE,FLAG)
->ERR IF FLAG#0
CIST=INSTREAM
INFILE=1
FINISHELSE INFILE=0; !INPUT FROM .IN
CYCLE
GETFILEANDDATE
->SUMMARY IF FILE=".END"; !TERMINATOR
UNLESS 1<=LENGTH(FILE)<=11 AND LENGTH(DATE)=8 START
IF INFILE=0 THEN PRINTSTRING("Wrong format - should be:
<filename> <date>
e.g.
DESFILE 23/11/78
")
FINISHELSESTART
FLAG=DDESTROY(UINFS(1),FILE,DATE,UINFI(1),1)
!DESTROY ARCHIVED FILE
IF FLAG#0 START
IF INFILE=0 THEN PRINTSTRING("Not found
")
FINISHELSE COUNT=COUNT+1
FINISH
REPEAT
SUMMARY:
NEWLINES(2)
PRINTSTRING("Number of files discarded:")
WRITE(COUNT,1)
NEWLINES(2)
FLAG=0
ERR:
IF CIST>=0 THENSTART
SELECTINPUT(CIST)
CLOSEST(81)
FINISH
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(27,FLAG)
END ; !OF DISCARD
!
!
EXTERNALROUTINE CHERISH(STRING (255) S)
STRING (31) FILE
INTEGER FLAG
SETPAR(S)
FLAG=0
CYCLE
FILE=SPAR(0)
->ERR IF FILE=""; !END OF LIST
FSTATUS(FILE,1,0,FLAG); !SET CHERISH BIT
IF FLAG#0 THEN PSYSMES(5,FLAG)
!IGNORE FAILURE IN DISCONNECT
REPEAT
ERR:
COMREG(24)=FLAG
END ; !OF CHERISH
!
!
EXTERNALROUTINE HAZARD(STRING (255) S)
STRING (31) FILE
INTEGER FLAG
SETPAR(S)
FLAG=0
CYCLE
FILE=SPAR(0)
IF FILE="" THEN ->ERR
FSTATUS(FILE,0,0,FLAG); !REMOVE CHERISH STATUS
IF FLAG#0 THEN PSYSMES(22,FLAG)
FSTATUS(FILE,2,0,FLAG); !REMOVE 'ARCHIVE REQUESTED'
REPEAT
ERR:
COMREG(24)=FLAG
END ; !OF HAZARD
!
!
EXTERNALROUTINE ARCHIVE(STRING (255) S)
STRING (31) FILE
INTEGER DUMMY,FLAG
SETPAR(S)
FLAG=0
CYCLE
FILE=SPAR(0)
IF FILE="" THEN ->ERR
FSTATUS(FILE,3,0,FLAG)
IF FLAG#0 THEN PSYSMES(3,FLAG) ELSESTART
FSTATUS(FILE,1,0,DUMMY)
!CHERISH IT AS WELL
FINISH
REPEAT
ERR:
COMREG(24)=FLAG
END ; !OF ARCHIVE
!
!
EXTERNALROUTINE AWAITRESTORES(STRING (255) S)
INTEGER FLAG
IF UINFI(2)#2 THENRETURN ; !not a batch job- ignore call
FLAG=DRESTORE(UINFS(1),"","",UINFI(1),0); !volume will send a reply when all restores for this user completed
END ; !of awaitrestores
!
!
IF FUNDSON#0 THEN START
EXTERNALROUTINE DONATEFUNDS(STRING (255) S)
INTEGER FLAG,PENCE,POUNDS
STRING (31) MONEY,TOUSER,SPOUNDS,SPENCE
STRING (11) TEMPLATE
TEMPLATE="POUNDS,TO"
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP#3 THENSTART ; ! WRONG NUMBER OF PARAMS
FLAG=263
->ERR
FINISH
MONEY=SPAR(1)
UNLESS MONEY->SPOUNDS.(".").SPENCE THENSTART ; ! NO PENCE SPECIFIED
SPENCE="0"
SPOUNDS=MONEY
FINISH
IF SPOUNDS="" THEN SPOUNDS="0"
POUNDS=PSTOI(SPOUNDS)
IF SPENCE="" THEN SPENCE="0"
PENCE=PSTOI(SPENCE)
IF POUNDS<0 OR PENCE<0 THENSTART ; ! INVALID PARAMETER
SETFNAME(MONEY)
FLAG=202
->ERR
FINISH
TOUSER=SPAR(2)
IF LENGTH(TOUSER)#6 THENSTART ; ! INVALID PARAMETER
SETFNAME(TOUSER)
FLAG=202
->ERR
FINISH
PENCE=100*POUNDS+PENCE
IF UINFS(9)#"" THENSTART ; ! GROUP MEMBERS CANNOT DONATE
FLAG=333
->ERR
FINISH
IF PENCE>UINFI(20) THENSTART ; ! INSUFFICIENT FUNDS
FLAG=334
->ERR
FINISH
FLAG=DDONATE(TOUSER,-1,PENCE*100)
FLAG=DIRTOSS(FLAG)
IF FLAG#0 THEN SETFNAME(TOUSER)
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(101,FLAG)
END ; !OF DONATEFUNDS
!
!
EXTERNALROUTINE FUNDS(STRING (255) S)
CONSTRECORD (COMF)NAME COM = X'80C00000'
INTEGER PENCE, NPENCE, SESSION
STRING (6) HOLDER
HOLDER=UINFS(9)
PENCE=UINFI(20)
PRINTSTRING("Funds=")
PRINTSTRING(ITOS(PENCE//100).".")
NPENCE=PENCE-100*(PENCE//100)
IF NPENCE<10 THEN PRINTSTRING("0")
PRINTSTRING(ITOS(NPENCE))
IF HOLDER#"" THEN PRINTSTRING(" held by ".HOLDER)
PRINTSTRING(", users=")
PRINTSTRING(ITOS(USERNO-SYSPROCS))
SESSION=UINFI(2)
IF SESSION=1 THEN START
PRINT STRING (", scarcity/pre-emption at ")
PRINTSTRING(ITOS(COM_RATION>>24))
PRINTSTRING("/")
PRINTSTRING(ITOS((COM_RATION>>16)&X'000000FF'))
PRINTSTRING(".")
NEWLINE
FINISH
IF SCARCEWORD&x'FF'>=SCARCEWORD>>24 THENSTART
! INTERACTIVE USERS > SCARCITY LIMIT
SSOWN_SCARCITYFOUND=1
PRINTSTRING("**Resources are Scarce.")
IF UINFI(20)=0 THEN PRINTSTRING(" You are liable to pre-emption.")
NEWLINE
FINISH
END ; !OF FUNDS
FINISH
!
!
EXTERNALROUTINE LIST(STRING (255) S)
!***********************************************************************
!* *
!* LIST accepts concatenated filenames of type CHARACTER or DATA. It *
!* is necessary to call JOINFILes and JOIN if the output is directed *
!* to other than .OUT or if the file is a DATA file. *
!* *
!***********************************************************************
CONSTINTEGER BANNERLENGTH=2048; !room for banner
CONSTINTEGER MFNL=11; ! Max. length of name acceptable to SPOOLER.
! (**** should it be 31? ****)
INTEGER FLAG,FIRST,LAST,NJ,JMODE,COPIES,FORMS,PRINTER,GAP
STRING (11) OUTPUT
RECORD (RF) RR
STRING (255) FILENAMES,HEADER
STRING (39) TEMPLATE
STRING (11) NAME; ! Should be (MFNL).
STRING (8) SCOPIES,SFORMS,FE
STRING (15) DEVICE,REST
RECORD (JTABF) ARRAY TAB(0:18); !allow room for extra space for banners
TEMPLATE="FILES,DEVICE=.OUT,COPIES=,SPFORMS=,FE="
NJ=0; ! JOIN not needed.
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF PARMAP&1=0 OR PARMAP>31 THENSTART
FLAG=263
->ERR
FINISH
FILENAMES=SPAR(1)
FLAG=LENGTH(FILENAMES)
IF FLAG<=MFNL THEN NAME<-FILENAMES ELSESTART
NAME<-SUBSTRING(FILENAMES,FLAG-MFNL+1,FLAG)
FIRST=1
LAST=CHARNO(NAME,1)
WHILE FIRST<=MFNL AND LAST#'+' AND LAST#'.' AND LAST#'_' CYCLE
FIRST=FIRST+1
LAST=CHARNO(NAME,FIRST)
REPEAT
IF 1<FIRST<=MFNL THENSTART
IF FIRST>2 THEN NAME<-SUBSTRING(NAME,FIRST-1,MFNL)
CHARNO(NAME,1)='#'
FINISH
FINISH
IF FILENAMES->HEADER.("+").HEADER THEN NJ=1; ! Needs JOIN.
DEVICE=SPAR(2)
IF DEVICE="" THEN DEVICE=".OUT"
SCOPIES=SPAR(3); !NO OF COPIES
IF SCOPIES#"" THENSTART
COPIES=PSTOI(SCOPIES)
! COPIES MUST BE AN INTEGER IN RANGE 1-15
UNLESS 1<=COPIES<=15 THENSTART
SETFNAME(SCOPIES)
FLAG=202
->ERR
FINISH
FINISHELSE COPIES=0; !DEFAULT - MEANS 1 COPY OF COURSE!
SFORMS=SPAR(4); !FORMS IN RANGE 0-255
IF SFORMS#"" START
FORMS=PSTOI(SFORMS)
! FORMS MUST BE INTEGER IN RANGE 0 - 255
UNLESS 0<=FORMS<=255 THENSTART
SETFNAME(SFORMS)
FLAG=202
->ERR
FINISH
FINISHELSE FORMS=0; !DEFAULT
FE=SPAR(5); !FORMAT EFFECTORS IN FILE
IF FE="FE" THEN JMODE=2 ELSE JMODE=0; !SET BIT IN MODE
IF (DEVICE->REST.(".GP") OR DEVICE->REST.(".SGP") OR C
DEVICE->REST.(".B")) AND REST="" THENSTART
NJ=1; ! Needs JOIN.
JMODE=JMODE!1
FINISH
IF DEVICE=".OUT" AND NJ=0 THENSTART
CONNECT(FILENAMES,0,0,0,RR,FLAG); !{SEQ}
->ERR IF FLAG#0
IF RR_FILETYPE#SSCHARFILETYPE OR FE="FE" THEN ->JOINUP
OUTOUT(RR_CONAD+RR_DATASTART,RR_DATAEND-RR_DATASTART)
IF NEWCONNECT#0 THEN SETUSE (FILENAMES, -1, 0)
->ERR
FINISH
IF CHARNO(DEVICE,1)#'.' THENSTART ; ! SIMPLE CHECK ON DEVICE CODE
FLAG=264
SETFNAME(DEVICE)
->ERR
FINISH
JOINUP:
IF LENGTH(DEVICE)>=3 AND SUBSTRING(DEVICE,2,3)="LP" THEN PRINTER=1 ELSE C
PRINTER=0
OUTPUT="T#LIST".NEXTTEMP
FIRST=1;
LAST=17; !MAXIMUM OF 16 FILES
JOINFILES(FILENAMES,TAB,JMODE,FIRST,LAST,FLAG)
->ERR IF FLAG#0
IF PRINTER=0 THEN GAP=0 ELSE GAP=BANNERLENGTH
JOIN2(TAB,FIRST,LAST,OUTPUT,JMODE&2,GAP,FLAG)
->ERR IF FLAG#0
IF DEVICE=".OUT" THENSTART
CONNECT(OUTPUT,0,0,0,RR,FLAG); !{SEQ}
->ERR IF FLAG#0
OUTOUT(RR_CONAD+RR_DATASTART,RR_DATAEND-RR_DATASTART)
IF NEWCONNECT#0 THEN SETUSE (OUTPUT, -1, 0)
DESTROY(OUTPUT,FLAG)
->ERR
FINISH
SENDFILE(OUTPUT,DEVICE,NAME,COPIES,FORMS,FLAG)
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(29,FLAG)
END ; !OF LIST
!
!
!
!
EXTERNALROUTINE RESTORE(STRING (255) S)
RECORD (FRF) FR
INTEGER FLAG,FSYS
STRING (31) FILE,DATE,OWNER
STRING (11) TEMPLATE
TEMPLATE="FILE,DATE="
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
! FIRST PARAMETER IS OBLIGATORY, SECOND OPTIONAL
IF 1#PARMAP#3 THENSTART
FLAG=263
->ERR
FINISH
FILE=SPAR(1)
UNLESS FILE->OWNER.(".").FILE THEN OWNER=UINFS(1)
FINFO(OWNER.".".FILE,0,FR,FLAG)
IF FLAG=0 THEN FLAG=219; !FILE EXISTS - SHOULD NOT
!this test is not perfect - the file may be crated before the file
!gets back from ARCHIVE. Or may exist but not be permitted.
IF FLAG#218 THEN ->ERR; !SOME FAULT OTHER THAN DOES NOT EXIST
DATE=SPAR(2)
IF OWNER=UINFS(1) THEN FSYS=UINFI(1) ELSE FSYS=-1; !my FSYS or don't know
FLAG=DRESTORE(OWNER,FILE,DATE,FSYS,0)
IF FLAG=102 THEN FLAG=306 ELSE FLAG=DIRTOSS(FLAG)
IF DATE#"" THEN SETFNAME(FILE." dated ".DATE) ELSE SETFNAME(FILE)
!SPECIAL CASE FOR DUPLICATE REQUEST
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(65,FLAG)
END ; !OF RESTORE
!
!
EXTERNALROUTINE TELL(STRING (255) S)
CONSTINTEGER MAXMSIZE=2000; ! Max length of message
RECORD (FRF) FR
RECORD (RF) RR
STRING (31) FILE,USER
BYTEINTEGERARRAY IN(1:MAXMSIZE)
INTEGER FLAG,LEN,START,CH,NLSW,FSYS
STRING (11) TEMPLATE
TEMPLATE="USER,FILE="
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
IF 1#PARMAP#3 THENSTART
FLAG=263
->ERR
FINISH
USER=SPAR(1); ! Destination user
IF LENGTH(USER)#6 THEN FLAG=201 ELSESTART
FSYS=-1
FLAG=DIRTOSS(DFSYS(USER,FSYS)); ! See if user exists
FINISH
IF FLAG=201 THENSTART ; ! Invalid user name, or does not exist.
SETFNAME(USER)
->ERR
FINISH
FLAG=0
IF PARMAP=1 START ; ! Read from terminal
NLSW=1
PROMPT("Text:")
FOR LEN=1,1,MAXMSIZE CYCLE
READCH(CH)
IF NLSW=1 AND CH='*' AND NEXTCH=NL THENSTART
SKIPSYMBOL
EXIT
FINISH
IF CH=25 THENSTART ; ! End of file typed
FLAG=IOCP(12,0); ! Reset end of file from terminal
EXIT
FINISH
IN(LEN)=CH
IF CH=NL THEN NLSW=1 ELSE NLSW=0
REPEAT
LEN=LEN-1
START=ADDR(IN(1))
FLAG=0
FINISHELSESTART ; ! Read message from file
FILE=SPAR(2)
CONNECT(FILE,0,0,0,RR,FLAG); !{SEQ}
->ERR IF FLAG#0
IF NEWCONNECT#0 THEN SETUSE (LASTFN, -1, 0)
IF RR_FILETYPE#SSCHARFILETYPE THENSTART
FLAG=267
SETFNAME(FILE)
->ERR
FINISH
LEN=RR_DATAEND-RR_DATASTART
IF LEN>MAXMSIZE THEN LEN=MAXMSIZE
START=RR_CONAD+RR_DATASTART
FINISH
->ERR IF LEN=0; ! Ignore null message
FLAG=DMESSAGE2(USER,LEN,1,0,FSYS,START); ! Forward message
IF 0#FLAG#61 THENSTART ; ! Some sort of failure
FLAG=DIRTOSS(FLAG)
->ERR
FINISH
IF FLAG=0 THEN PRINTSTRING("Message sent to ".USER) ELSESTART
PRINTSTRING("Message stored for ".USER)
FLAG=0
FINISH
NEWLINE
ERR:
COMREG(24)=FLAG
IF FLAG#0 THEN PSYSMES(2,FLAG)
END ; !OF TELL
!
!
ROUTINE JOIN2(RECORD (JTABF) ARRAYNAME TAB, INTEGER FIRSTCELL,LASTCELL,
STRING (31) OUT, INTEGER FE,GAP, INTEGERNAME FLAG)
INTEGER OUTCONAD,OUTP,I,OUTLEN,FEF,HFL
FLAG=0; !DEFAULT REPLY
IF LASTCELL>=FIRSTCELL THENSTART ; ! (Do nothing if there are no files.)
! CALCULATE LENGTH OF OUT
OUTLEN=32+GAP<<1; ! HEADER LENGTH
FOR I=FIRSTCELL,1,LASTCELL CYCLE
OUTLEN=OUTLEN+TAB(I)_LENGTH
REPEAT
OUTFILE(OUT,OUTLEN,0,0,OUTCONAD,FLAG); !{SEQ} - CREATE THE OUTPUT FILE.
HFL = FLAG
IF FLAG=0 THENSTART
INTEGER(OUTCONAD)=OUTLEN-GAP; ! Logical dataend
INTEGER(OUTCONAD+12)=3; !DEFAULT - CHARACTER FILE
INTEGER(OUTCONAD+4)=32+GAP; ! Logical datastart
OUTP=OUTCONAD+32+GAP
FINISH
FOR I=FIRSTCELL,1,LASTCELL CYCLE
IF FLAG=0 THEN START
IF TAB(I)_TYPE=SSCHARFILETYPE THEN FEF=0 ELSE FEF=1
IF FEF=0=FE THEN MOVE(TAB(I)_LENGTH,TAB(I)_START,OUTP) C
ELSE FCONV(FE!FEF,TAB(I)_START,OUTP,0,FLAG)
OUTP=OUTP+TAB(I)_LENGTH; !UPDATE OUT POINTER
FINISH
IF NEWCONNECT#0 THEN SETUSE (CONFILE(TAB(I)_START), -1, 0)
REPEAT
IF NEWCONNECT#0 AND HFL=0 THEN DISCONNECT (OUT,HFL)
FINISH
END ; !OF JOIN
!
!
!
SYSTEMROUTINE JOIN(RECORD (JTABF) ARRAYNAME TAB, INTEGER FIRSTCELL,
LASTCELL, STRING (31) OUT, INTEGER FE, INTEGERNAME FLAG)
JOIN2(TAB,FIRSTCELL,LASTCELL,OUT,FE,32,FLAG)
RETURN
END ; ! OF JOIN
!
!
!
SYSTEMROUTINE JOINFILES(STRING (255) FILENAMES,
RECORD (JTABF) ARRAYNAME TAB, INTEGER MODE,FIRSTCELL,
INTEGERNAME LASTCELL,FLAG)
!***********************************************************************
!* *
!* This routine takes as input a string of the form A+B+C and builds *
!* an array for routine JOIN. The parameter FIRSTCELL enables us to *
!* leave room for additional information - for example heading for *
!* line printer listings. It is called from COMPILE,DEFINE,LIST etc. *
!* *
!***********************************************************************
INTEGER P,FE,NP,I
RECORD (RF) RR
STRING (31) FILE
FE=MODE&2; !FORMAT EFFECTOR
P=FIRSTCELL
NP = P
CYCLE
IF P>LASTCELL THENSTART ; ! TOO MANY FILES
FLAG=277
->ERR
FINISH
UNLESS FILENAMES->FILE.("+").FILENAMES THENSTART
FILE=FILENAMES
FILENAMES=""
FINISH
CONNECT(FILE,0,0,0,RR,FLAG); !{SEQ}
IF FLAG#0 THEN ->ERR; !FAIL TO CONNECT
NP = P + 1
IF RR_FILETYPE=SSCHARFILETYPE OR MODE&1=1 START
!TRULY CHARACTER OR BINARY TO BINARY DEVICE
!TEMP ****MUST SORT THIS OUT BETTER
IF FE#0 THENSTART
TAB(P)_START=RR_CONAD
TAB(P)_LENGTH=FLC(FE,RR_CONAD,0,FLAG) {file length}
->ERR IF FLAG#0
FINISHELSESTART
TAB(P)_START=RR_CONAD+RR_DATASTART
TAB(P)_LENGTH=RR_DATAEND-RR_DATASTART
FINISH
TAB(P)_TYPE=SSCHARFILETYPE
FINISHELSESTART
IF RR_FILETYPE#SSDATAFILETYPE THENSTART ; ! INVALID FILETYPE
FLAG=267
->ERR
FINISH
TAB(P)_START=RR_CONAD
TAB(P)_LENGTH=FLC(FE!1,RR_CONAD,0,FLAG) {file length}
->ERR IF FLAG#0
TAB(P)_TYPE=SSDATAFILETYPE
FINISH
P=NP
REPEATUNTIL FILENAMES=""
LASTCELL=P-1
IF NEWCONNECT#0 THEN -> ERRX
ERR:
IF NEWCONNECT#0 AND NP>FIRSTCELL THEN START
FOR I=FIRSTCELL,1,NP-1 CYCLE
SETUSE (CONFILE(TAB(P)_START), -1, 0)
REPEAT
FINISH
ERRX:
UNLESS 267#FLAG#311 THEN SETFNAME(FILE); !IDENTIFY CORRUPT FILE
END ; !OF JOINFILES
!
!
SYSTEMROUTINE COMPILE2(STRING (255) S, STRING (31) ENTRY, INTEGERNAME FLAG, C
INTEGER LOADTYPE)
!{SEQ} - which files should be sequential-connected for compilation?
! LOADTYPE should be set to 0 for the compiler to be permanently loaded,
! Anything else for temporary loading. Only affects new loader.
STRING (255) SOURCE,HOLDSOURCE
RECORD (JTABF) ARRAY TAB(1:16)
CONSTSTRING (6) SRCE="T#SRCE"
CONSTINTEGER CNUM=5;! no of compilers not requiring history info
OWNSTRING (15)ARRAY CNAMES(1:CNUM)="ICL9CEZIBMIMP","S#PERQIMP", C
"ICL9CEZPNXIMP","S#ACCIMP","ICL9CEZDRSIMP"
STRING (1) DUMMY
RECORD (FDF) NAME F
INTEGER ARRAY FORMAT LDATAAF (0:15)
INTEGER ARRAY NAME LDATAA
INTEGER LDA,P,OBJCONAD,L,TYPE
INTEGER DR0,DR1; !DR0 AND DR1 STAY TOGETHER
LONGINTEGERNAME DESC
RECORD (RF) RR
STRING (31) OBJECT,LISTING,ERRSTRM
INTEGER AWORK,REMOVEOK,AFD,CURIN,CUROUT,TOP,LOCLL,PRINTDATE,HISTAD
INTEGER FINDCOM,CHECKCOM; ! required by smh for history part
CONSTSTRING (32) TM0="SOURCE,OBJECT,LIST=T#LIST,ERROR="
STRING (43) TEMPLATE
DESC==LONGINTEGER(ADDR(DR0))
TEMPLATE=TM0.UINFS(8)
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
FILPS(TEMPLATE,S)
REMOVEOK=1; !BY DEFAULT DON'T DO INSERT
CURIN=INSTREAM
CUROUT=OUTSTREAM
IF PARMAP&3#3 OR PARMAP>=16 THENSTART ; ! WRONG NO OF PARAMS
FLAG=263
->ERR
FINISH
COMREG(24)=16; !FAILURE BY DEFAULT
COMREG(47)=0; !NO OF STATEMENTS OR FAULTS
SOURCE=SPAR(1)
IF SOURCE="*" OR SOURCE=".IN" THEN PRINTDATE = 0 ELSE START
PRINTDATE = -1
IF (LENGTH(SOURCE)<8 OR CHARNO(SOURCE,7)#'.') C
THEN SOURCE=UINFS(1).".".SOURCE
FINISH
HOLDSOURCE=SOURCE; !FOR LISTING AND OBJINFO
OBJECT=SPAR(2)
LISTING=SPAR(3)
ERRSTRM=SPAR(4); !COMPILER ERROR STREAM
IF SOURCE->S.("+").S THEN START ; !CONCATENATED INPUT
PRINTDATE = 0
TOP=16; !MAXIMUM VALUE FOR TOP
JOINFILES(SOURCE,TAB,0,1,TOP,FLAG)
->ERR IF FLAG#0
SOURCE=SRCE
JOIN(TAB,1,TOP,SOURCE,0,FLAG)
->ERR IF FLAG#0
FINISH
SETINPUT(SOURCE,FLAG)
->ERR IF FLAG#0
IF COMREG(28)&x'00000100'#0 THEN AWORK=SSMAXWORKSIZE ELSE AWORK=x'40000'
!MAX WORK SIZE IF PARM(MAXDICT) SELECTED
SETWORK(AWORK,FLAG)
IF FLAG#0 THEN ->ERR
COMREG(52)=ADDR(OBJECT)
IF OBJECT#".NULL" START
OUTFILE(OBJECT,-4096,0,0,OBJCONAD,FLAG); !CHECK THAT WE CAN CONNECT IN WRITE MODE ETC
IF FLAG#0 THENSTART
IF CHARNO(OBJECT,1)='.' THEN FLAG=220; !INVALID FILENAME
->ERR
FINISH
MODDIRFILE(6,SSOWN_AVD,"",OBJECT,0,0,0,REMOVEOK)
IF NEWCONNECT#0 THEN SETUSE (OBJECT, -1, 0)
!ATTEMPT TO REMOVE INFO FROM
! SS#DIR
FINISH
! %IF ERRSTRM="" %AND UINFS(8)#"" %THEN ERRSTRM = UINFS(8)
IF ERRSTRM=".NULL" THEN ERRSTRM=""
IF ERRSTRM#"" START
DEFINE(87,ERRSTRM,AFD,FLAG)
->ERR IF FLAG#0
COMREG(27)=COMREG(27)!x'200000'; !TEMPORARY INDICATOR
!SET BIT FOR COMPILER
COMREG(40)=87
SELECTOUTPUT(87)
SELECTOUTPUT(0)
FINISHELSESTART ; !NO ERROR STREAM
COMREG(27)=COMREG(27)&x'FFDFFFFF'
!TEMP - CLEAR ERRSTRM BIT
COMREG(40)=-1; !INDICATES NO ERROR STREAM
FINISH
! %IF LISTING = "" %THEN LISTING = "T#LIST"
IF NEWLOADER=0 THENSTART
LOAD(ENTRY,0,FLAG); !LOAD COMPILER
->ERR IF FLAG#0
FINDENTRY(ENTRY,0,0,DUMMY,DR0,DR1,FLAG)
FINISHELSESTART
TYPE=CODE
IF LOADTYPE#0 THEN LOCLL=CURRENTLL ELSE LOCLL=0
DESC=LOADEP(ENTRY,TYPE,FLAG,LOCLL); ! Load compiler
IF FLAG#0 THEN UNLOAD2(1,1); !unload all if compiler fails to load
FINISH
->ERR IF FLAG#0
! %IF LISTING # "" %START
DEFINE(82,LISTING,AFD,FLAG)
->ERR IF FLAG#0
F==RECORD(AFD)
F_MAXSIZE=CLISTSIZE; !MAXIMUM LISTING FILE SIZE
SELECTOUTPUT(82)
! %FINISH
!NOW PRINT HEADING FOR LISTING
PRINTSTRING("Source: ")
IF PRINTDATE=0 OR COMREG(46)=0 THEN START
PRINTSTRING (HOLDSOURCE)
SPACES (9)
FINISH ELSE START
PRINTDATE = INTEGER(COMREG(46)+20)
HOLDSOURCE = HOLDSOURCE." last altered ". C
UNPACKDATE(PRINTDATE)." ".UNPACKTIME(PRINTDATE)
PRINTSTRING (HOLDSOURCE)
NEWLINE
FINISH
PRINTSTRING("Compiled: ".DATE." ".TIME)
NEWLINE
PRINTSTRING("Object: ".OBJECT)
NEWLINES(2)
PRINTSTRING("Parms set: ")
PRINTSTRING(PRINTPARMS(LONGINTEGER(ADDR(COMREG(27)))))
NEWLINE
ENTER(1,DR0,DR1,""); !ENTER COMPILER - NO PARAMETER
SELECTOUTPUT(0)
IF COMREG(24)=0 START
IF COMREG(47)#0 START
WRITE(COMREG(47),1)
PRINTSTRING(" Statements compiled")
FINISHELSE PRINTSTRING("Compilation successful")
NEWLINE
IF OBJECT#".NULL" START
IF REMOVEOK=0 START
!Certain compilers do not need object file inserted into active directory
FOR FINDCOM=CNUM,-1,1 CYCLE
IF CNAMES(FINDCOM)=ENTRY THEN CHECKCOM=1 AND EXIT
CHECKCOM=0
REPEAT
!Checkcom of 0 means compiler is not one of the special cases
IF CHECKCOM=0 THEN MODDIRFILE(3,SSOWN_AVD,"",OBJECT,0,0,0,REMOVEOK)
!This flag not worth checking
FINISH
CONNECT(OBJECT,3,0,0,RR,FLAG)
IF FLAG=0 START
LDA=RR_CONAD+INTEGER(RR_CONAD+24); !Start of loaddata
LDATAA == ARRAY (LDA,LDATAAF)
HISTAD = LDATAA (12); ! Offset of start of history records.
IF HISTAD#0 THEN START
! There is some history already, planted by LPUT.
! Scan the history records and find where they end.
CYCLE
P = BYTE INTEGER (RR_CONAD+HISTAD)
EXIT IF P=0
HISTAD = HISTAD + 2 + BYTEINTEGER(RR_CONAD+HISTAD+1)
REPEAT
IF HISTAD+1#INTEGER(RR_CONAD) C
THEN HISTAD = -1 C
{That checks whether the existing history records are the}
{last things in the file. If they are, then we can tag on some}
{more history, but if they are not then we would have to put}
{our history records somewhere separate from the existing ones,}
{and since there is only one pointer to the history either one}
{lot of history or the other would be unfindable.}
ELSE INTEGER(RR_CONAD) = HISTAD
{Throw away the zero byte which}
{is the last thing in the file and which marks the end}
{of the history.}
FINISH
! HISTAD = 0 : Plant history AND plant a pointer to it.
! HISTAD = -1 : Plant no history.
! Other value : Plant history at RR_CONAD+HISTAD but plant no pointer.
IF HISTAD#-1 THEN START
L=INTEGER(RR_CONAD)
IF L&4095<13+LENGTH(HOLDSOURCE) THENSTART
IF NEWCONNECT#0 THEN START
SETUSE (OBJECT, -1, 0)
CHANGEFILESIZE (OBJECT, L+45, FLAG)
FINISH ELSE START
CHANGEFILESIZE(OBJECT,L+45,FLAG); !NEED MORE ROOM FOR HISTORY
IF FLAG=261 THENSTART ; !VM HOLE TOO SMALL
DISCONNECT(OBJECT,FLAG)
CHANGEFILESIZE(OBJECT,L+45,FLAG)
FINISH
FINISH
IF FLAG=0 THEN CONNECT(OBJECT,3,0,0,RR,FLAG)
! RECONNECT
IF FLAG#0 THEN ->ERR
FINISH
IF HISTAD=0 THEN LDATAA(12)=INTEGER(RR_CONAD); !SET POINTER TO END OF FILE
P=RR_CONAD+INTEGER(RR_CONAD)
BYTEINTEGER(P)=1; !TYPE=SOURCE
STRING(P+1)=HOLDSOURCE
P=P+LENGTH(HOLDSOURCE)+2
BYTEINTEGER(P)=2; !TYPE = PARM
BYTEINTEGER(P+1)=8; !LENGTH OF FIELD
MOVE(8,ADDR(COMREG(27)),P+2); !PARMS NOW IN COMREG(27) AND COMREG(28)
P=P+10
BYTEINTEGER(P)=0; !END OF LIST
INTEGER(RR_CONAD)=P-RR_CONAD+1; ! SET LENGTH
FINISH
IF NEWCONNECT#0 THEN SETUSE (OBJECT, -1, 0)
FINISH
FINISH
FINISHELSESTART
IF COMREG(47)#0 START
WRITE(COMREG(47),1)
PRINTSTRING(" Fault")
IF COMREG(47)>1 THEN PRINTSYMBOL('s')
!FOR THE PURISTS !
PRINTSTRING(" in compilation")
FINISHELSE PRINTSTRING("Compilation faulty")
NEWLINE
IF OBJECT#".NULL" START ; !SET TYPE OF OBJECT FILE TO CORRUPT OBJECT FILE
CONNECT(OBJECT,3,0,0,RR,FLAG)
IF FLAG=0 THEN INTEGER(RR_CONAD+12)=SSCORRUPTOBJFILETYPE
IF NEWCONNECT#0 THEN DISCONNECT (OBJECT,L)
FINISH
FINISH
IF NEWCONNECT=0 THEN DISCONNECT(OBJECT,L); !IGNORE FLAG
ERR:
CLOSEST(81); !SOURCE FILE
CLOSEST(82); !LISTING FILE
CLOSEST(87); !FAULT LIST
IF CURIN#INSTREAM THEN SELECTINPUT(CURIN)
IF CUROUT#OUTSTREAM THEN SELECTOUTPUT(CUROUT)
IF FLAG#0 THEN COMREG(24)=FLAG; !PUT FLAG INTO RETURNCODE
END ; !OF COMPILE2
!
!
SYSTEMROUTINE COMPILE(STRING (255) S, STRING (31) ENTRY, INTEGERNAME FLAG)
! Permanently loads the compiler
COMPILE2(S,ENTRY,FLAG,0)
RETURN
END ; ! OF COMPILE
!
!
EXTERNALROUTINE ASSEMBLE(STRING (255) S)
INTEGER FLAG
COMPILE(S,"S#ASSEMBLE",FLAG)
IF FLAG#0 THEN PSYSMES(4,FLAG)
END ; !OF ASSEMBLE
!
!
EXTERNALROUTINE NEWFORT77(STRING (255) S)
INTEGER FLAG
COMPILE(S,"ICL9CEF77T",FLAG)
IF FLAG#0 THEN PSYSMES(102,FLAG)
END ; !OF NEW FORT77
!
!
EXTERNALROUTINE FORT77(STRING (255) S)
INTEGER FLAG
COMPILE(S,"ICL9CEF77",FLAG)
IF FLAG#0 THEN PSYSMES(102,FLAG)
END ; !OF FORT77
!
!
EXTERNALROUTINE FORTE(STRING (255) S)
INTEGER HOLDPARM; !TEMP
INTEGER FLAG
HOLDPARM=COMREG(27); !TEMP
COMREG(27)=COMREG(27)&x'FFFFFBFF'; !TEMP AND OUT 'ZERO' BIT
COMPILE(S,"ICL9CEZFORTRAN",FLAG)
COMREG(27)=HOLDPARM; !TEMP - RESTORE PARM
IF FLAG#0 THEN PSYSMES(21,FLAG)
END ; !OF FORTE
!
!
EXTERNALROUTINE IMP(STRING (255) S)
INTEGER FLAG
COMPILE(S,"ICL9CEZIMP",FLAG)
IF FLAG#0 THEN PSYSMES(23,FLAG)
END ; !OF IMP
!
!
EXTERNALROUTINE IMP80(STRING (255) S)
INTEGER FLAG
COMPILE(S,"ICL9CEZIMP80",FLAG)
IF FLAG#0 THEN PSYSMES(103,FLAG)
END ; !OF IMP80
!
!
EXTERNALROUTINE IBMIMP(STRING (255) S)
INTEGER FLAG
COMPILE(S,"ICL9CEZIBMIMP",FLAG)
IF FLAG#0 THEN PSYSMES(104,FLAG)
END ; !OF IBMIMP
!
!
EXTERNALROUTINE IOPT(STRING (255) S)
INTEGER FLAG
COMPILE(S,"ICL9CEZIOPT",FLAG)
IF FLAG#0 THEN PSYSMES(110,FLAG)
END ; !OF IOPT
!
!
EXTERNALROUTINE REPORTON(INTEGER CHAN)
!This routine is used to re-route output on stream 0 to a nominated stream (chan)
!It is intended for re-routeing messages from e.g.COPY, and DIAGNOSTICS after
!program failure
STRING (31) FILE
INTEGER FLAG
IF CHAN=0 THEN DFDFOUT("",0,FLAG); !return to normal
IF 1<=CHAN<=80 START
!This next statement is needed to obtain the filename or device required for output.
DEFINFO(CHAN,FILE,FLAG); !ignore flag
DFDFOUT(FILE,CHAN,FLAG); !tell the subsystem
FINISH
END ; !of reporton
!
!
EXTERNALROUTINE SUPPRESS RECALL
!switches of recall until we are back at command: level
JOURNALOFF
END ; !of suppress recall
!
EXTERNALROUTINE SVSN(STRING (255) S)
PRINTSTRING(SEPVSN)
RETURN
END ; ! OF SVSN
!
ENDOFFILE