C C C C LIST File Listing Utility C ========================= C C Author: William P. Wood, Jr. C C Address: Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 3.0 C C Date: December 29, 1981 C C C C ******************************************************* C * * C * THIS SOFTWARE WAS DEVELOPED WITH SUPPORT * C * FROM THE NATIONAL INSTITUTES OF HEALTH: * C * NIH CA06927 * C * NIH CA22780 * C * * C * DIRECT INQUIRIES TO: * C * COMPUTER CENTER * C * THE INSTITUTE FOR CANCER RESEARCH * C * 7701 BURHOLME AVENUE * C * PHILADELPHIA, PENNSYLVANIA 19111 * C * * C * NO WARRANTY OR REPRESENTATION, EXPRESS OR * C * IMPLIED, IS MADE WITH RESPECT TO THE * C * CORRECTNESS, COMPLETENESS, OR USEFULNESS * C * OF THIS SOFTWARE, NOR THAT USE OF THIS * C * SOFTWARE MIGHT NOT INFRINGE PRIVATELY * C * OWNED RIGHTS. * C * * C * NO LIABILITY IS ASSUMED WITH RESPECT TO * C * THE USE OF, OR FOR DAMAGES RESULTING FROM * C * THE USE OF THIS SOFTWARE * C * * C ******************************************************* C C C define(VAX) C note the order of the next several defines is significant! C ICR ONLY define(NOTICR,# NOT ICR) C Local ICR functions supported by LIST: C Invoke LIST on wild card file names C Route output to printer port of DT80 C Invoke HELP facility for LIST C Allow screen widths other than SCRWIDTH C Record or Block i/o. C set to define(RECORDIO,) for record io C size of buffer for mark/point C BLOCK IO define(MARKSIZE,3) C parse - return first arg in comand and delete it from comand SUBROUTINE PARSE(COMAND, ARG) BYTE COMAND(1), ARG(1) INTEGER J BYTE CUPPER J = 1 2000 IF (.NOT.(COMAND(J) .NE. ' ' .AND. COMAND(J) .NE. 0 .AND. (COMAND( *J) .NE. '/' .OR. J .EQ. 1 .OR. COMAND(1) .NE. '/'))) GOTO 2010 ARG(J) = CUPPER(COMAND(J)) J = J + 1 GOTO 2000 2010 CONTINUE ARG(J) = 0 IF (.NOT.(COMAND(J) .EQ. ' ')) GOTO 2020 J = J + 1 2020 CONTINUE CALL SCOPY(COMAND, J, COMAND, 1) RETURN END C getfil - return selected file names one at a time from a list of file specs C separated by commas. C File specs may be a simple file name, or they may reference C an indirect file if @ is specified, or C file names may be selected by wild cards and/or switches. LOGICAL FUNCTION GETFIL(FILE, ANS, NSELEC, PROMPT) IMPLICIT INTEGER(A - Z) BYTE FILE(1), ANS(2), TERMC, TFILE(134), FILIST(134) LOGICAL PROMPT, ISLIST, INBRAK, WILD BYTE CUPPER COMMON/DEFALT/NODE, DEV, UIC, NAME, EXT BYTE NODE(1) BYTE UIC(10) BYTE NAME(10) BYTE DEV(6) BYTE EXT(5) DATA DEV(1)/83/,DEV(2)/89/,DEV(3)/58/,DEV(4)/0/ DATA EXT(1)/46/,EXT(2)/76/,EXT(3)/83/,EXT(4)/84/,EXT(5)/0/ DATA NODE(1)/0/ DATA UIC(1)/0/ DATA NAME(1)/0/ IF (.NOT.(NSELEC .EQ. 0)) GOTO 2040 IP = 0 CALL SCOPY(FILE, 1, FILIST, 1) NFILE = 0 ISLIST = .FALSE. 2040 CONTINUE 2060 CONTINUE IF (.NOT.(NFILE .EQ. 0)) GOTO 2090 INBRAK = .FALSE. J = IP + 1 2110 IF (.NOT.(FILIST(J) .NE. 0 .AND. (INBRAK .OR. FILIST(J) .NE. ' *,'))) GOTO 2130 IF (.NOT.(FILIST(J) .EQ. '[')) GOTO 2140 INBRAK = .TRUE. GOTO 2150 2140 CONTINUE IF (.NOT.(FILIST(J) .EQ. ']')) GOTO 2160 INBRAK = .FALSE. 2160 CONTINUE 2150 CONTINUE 2120 J = J + 1 GOTO 2110 2130 CONTINUE IF (.NOT.(FILIST(J) .EQ. ',')) GOTO 2180 C this is a list of file names ISLIST = .TRUE. 2180 CONTINUE DO 2200 I = IP + 1, J FILE(I - IP) = FILIST(I) 2200 CONTINUE FILE(J - IP) = 0 IP = J IF (.NOT.(FILE(1) .EQ. '@')) GOTO 2220 C Indirect file name? NAMTYP = 2 GOTO 2230 2220 CONTINUE CALL SCOPY(FILE, 1, TFILE, 1) TFILE(BKSCAN(TFILE, '/', 1)) = 0 CALL DEFNAM(TFILE, NODE, DEV, UIC, NAME, EXT, .TRUE.) CALL CONCAT(TFILE, FILE(BKSCAN(FILE, '/', 1)), 134) NAMTYP = 0 IF (.NOT.(WILD(TFILE))) GOTO 2240 C wild card or switch? NAMTYP = 1 CALL SCOPY(TFILE, 1, FILE, 1) 2240 CONTINUE 2230 CONTINUE 2090 CONTINUE NC = 0 IF (.NOT.(NAMTYP .EQ. 0 .AND. .NOT.ISLIST)) GOTO 2260 NFILE = 1 - NFILE GOTO 2270 2260 CONTINUE 2280 CONTINUE IF (.NOT.(NAMTYP .EQ. 1)) GOTO 2310 IF (.NOT.(NFILE .EQ. 0)) GOTO 2330 CALL FNDFIL(5, FILE, TFILE, NFILE) IF (.NOT.(NFILE .EQ. 0)) GOTO 2350 CALL SCOPY('LIST -- ERROR OPENING ', 1, TFILE, 1) I = CONCAT(TFILE, FILE, 134) CALL TTPUT(TFILE, I) 2350 CONTINUE GOTO 2340 2330 CONTINUE CALL FNDFIL(5, FILE, TFILE, NFILE) 2340 CONTINUE GOTO 2320 2310 CONTINUE IF (.NOT.(NAMTYP .EQ. 2)) GOTO 2370 CALL READF(5, FILE, TFILE, NFILE) GOTO 2320 2370 CONTINUE NFILE = 1 - NFILE CALL SCOPY(FILE, 1, TFILE, 1) 2320 CONTINUE IF (.NOT.(NFILE .GT. 0)) GOTO 2390 CALL SCOPY(TFILE, 1, FILE, 1) IF (.NOT.(PROMPT)) GOTO 2410 IF (.NOT.(ANS(1) .NE. 'G')) GOTO 2430 2450 CONTINUE CALL READPR(2, FILE, ANS, NC, 2, TERMC) 2460 IF (.NOT.(NC .EQ. -10 .OR. NC .GE. 0)) GOTO 2450 ANS(1) = CUPPER(ANS(1)) GOTO 2440 2430 CONTINUE CALL TTPUT(FILE, LENGTH(FILE)) 2440 CONTINUE 2410 CONTINUE 2390 CONTINUE 2290 IF (.NOT.(NFILE .LE. 0 .OR. NC .EQ. -10 .OR. ANS(1) .EQ. 'G' . *OR. (NC .GT. 0 .AND. ANS(1) .EQ. 'Y') .OR. .NOT.PROMPT)) GOTO 2280 2270 CONTINUE 2070 IF (.NOT.(NFILE .GT. 0 .OR. FILIST(IP) .EQ. 0 .OR. NC .EQ. -10)) G *OTO 2060 GETFIL = NFILE .GT. 0 .AND. NC .NE. - 10 IF (.NOT.(GETFIL)) GOTO 2480 NSELEC = NSELEC + 1 IF (.NOT.(NAMTYP .NE. 1)) GOTO 2500 CALL SCOPY(FILE, 1, TFILE, 1) CALL DEFNAM(TFILE, NODE, DEV, UIC, NAME, EXT, .TRUE.) 2500 CONTINUE 2480 CONTINUE IF (.NOT.(NC .EQ. -10)) GOTO 2520 CLOSE(UNIT = 5) 2520 CONTINUE RETURN END C wild - return true if file name contains wild card characters or switches LOGICAL FUNCTION WILD(FILE) BYTE FILE(1) INTEGER BKSCAN IF (.NOT.(FILE(BKSCAN(FILE, '/*?', 1)) .NE. 0)) GOTO 2540 WILD = (.TRUE.) RETURN 2540 CONTINUE WILD = (.FALSE.) RETURN END C readf - read in file names from indirect file SUBROUTINE READF(F, FILE, OUTFIL, NSELEC) INTEGER F, NSELEC, NC BYTE FILE(1), OUTFIL(1) IF (.NOT.(NSELEC .EQ. 0)) GOTO 2560 CALL DEFNAM(FILE(2), 0, 'SY:', 0, 0, '.CMD', .FALSE.) CLOSE(UNIT = F) OPEN(UNIT = F, NAME = FILE(2), TYPE = 'old', READONLY, SHARED, E *RR = 10) 2560 CONTINUE 2580 CONTINUE CALL GET(F, OUTFIL, 134 - 1, NC) 2590 IF (.NOT.(NC .NE. 0)) GOTO 2580 IF (.NOT.(NC .LT. 0)) GOTO 2610 NSELEC = 0 CLOSE(UNIT = F) GOTO 2620 2610 CONTINUE NSELEC = NSELEC + 1 OUTFIL(NC + 1) = 0 2620 CONTINUE RETURN 10 CONTINUE CALL ERR(FILE, 2, 'Can''t open file.') RETURN END C opndef - find and open file for reading using defaults in file name LOGICAL FUNCTION OPNDEF(LUN, FILE, ANS, NSELEC, PROMPT) IMPLICIT INTEGER(A - Z) BYTE FILE(1), ANS(1), FILE1(134) LOGICAL PROMPT, GETFIL COMMON/CLIST/DOT, OLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDO *T, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MARKB C current logical record; init: 1 INTEGER*4DOT C old value of dot INTEGER*4OLDOT C top of last screen; init: 1 INTEGER*4TOPSCR C offset in file of logical line 1; init: 0 INTEGER*4FOFF C highest line number of logical file; init: MAXINT-1 INTEGER*4FMAX C next record on file; init: 1 INTEGER*4NXTREC C last record read; init: 0 INTEGER*4LSTRED C value of dot saved by the = command; init: 1 INTEGER*4SAVDOT C low value of record column range INTEGER LOWC C high value of record column range INTEGER HIGHC C carriagecontrol type of standard output INTEGER TTCC C carriagecontrol type of input file INTEGER CC C carriagecontrol type of output file INTEGER OUTCC C index of highest line number in markb; init:0 INTEGER MARKP C points to every 100th line on file INTEGER MARKB(4, 0:1000) COMMON/DEFALT/NODE, DEV, UIC, NAME, EXT BYTE NODE(1) BYTE UIC(10) BYTE NAME(10) BYTE DEV(6) BYTE EXT(5) DATA DEV(1)/83/,DEV(2)/89/,DEV(3)/58/,DEV(4)/0/ DATA EXT(1)/46/,EXT(2)/76/,EXT(3)/83/,EXT(4)/84/,EXT(5)/0/ DATA NODE(1)/0/ DATA UIC(1)/0/ DATA NAME(1)/0/ 2630 CONTINUE IF (.NOT.(GETFIL(FILE, ANS, NSELEC, PROMPT))) GOTO 2660 C try opening file with defaults applied CALL SCOPY(FILE, 1, FILE1, 1) CALL DEFNAM(FILE, NODE, DEV, UIC, NAME, EXT, .FALSE.) OPEN(UNIT = LUN, NAME = FILE, TYPE = 'old', READONLY, SHARED, *ERR = 10, BLOCKSIZE = 2048) C BLOCK IO call bopen(lun, file, 'R', ier) C BLOCK IO if (ier ~= 0) C BLOCK IO goto 10 GOTO 30 C now try file name as is, with DEFAULT$DISK and . as C default device and extension 10 CONTINUE CALL DEFNAM(FILE1, 0, 'SY:', 0, 0, '.', .FALSE.) OPEN(UNIT = LUN, NAME = FILE1, TYPE = 'old', READONLY, SHARED, * ERR = 20, BLOCKSIZE = 2048) C BLOCK IO call bopen(lun, file1, 'R', ier) C BLOCK IO if (ier ~= 0) C BLOCK IO goto 20 NODE(1) = 0 DEV(1) = 0 UIC(1) = 0 NAME(1) = 0 EXT(1) = 0 C reset defaults CALL DEFNAM(FILE1, NODE, DEV, UIC, NAME, EXT, .TRUE.) C return full file name CALL SCOPY(FILE1, 1, FILE, 1) C got one! 30 CONTINUE CALL GFTYP(LUN, CC) OPNDEF = (.TRUE.) RETURN C here if unable to open a file 20 CONTINUE CALL SCOPY('LIST -- ERROR OPENING ', 1, FILE1, 1) I = CONCAT(FILE1, FILE, 134) CALL TTPUT(FILE1, I) GOTO 2670 2660 CONTINUE OPNDEF = (.FALSE.) RETURN 2670 CONTINUE C go try next file 2640 GOTO 2630 END C redir - redirect output from LIST INTEGER FUNCTION REDIR(FOUT, COMAND) INTEGER FOUT, J, FTMP INTEGER CHSCAN BYTE COMAND(1) BYTE NODE(1), DEV(6), UIC(10), NAME(10), EXT(5) LOGICAL APPEND COMMON/CLIST/DOT, OLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDO *T, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MARKB C current logical record; init: 1 INTEGER*4DOT C old value of dot INTEGER*4OLDOT C top of last screen; init: 1 INTEGER*4TOPSCR C offset in file of logical line 1; init: 0 INTEGER*4FOFF C highest line number of logical file; init: MAXINT-1 INTEGER*4FMAX C next record on file; init: 1 INTEGER*4NXTREC C last record read; init: 0 INTEGER*4LSTRED C value of dot saved by the = command; init: 1 INTEGER*4SAVDOT C low value of record column range INTEGER LOWC C high value of record column range INTEGER HIGHC C carriagecontrol type of standard output INTEGER TTCC C carriagecontrol type of input file INTEGER CC C carriagecontrol type of output file INTEGER OUTCC C index of highest line number in markb; init:0 INTEGER MARKP C points to every 100th line on file INTEGER MARKB(4, 0:1000) DATA NODE(1)/0/, DEV(1)/0/, UIC(1)/0/, NAME(1)/0/, EXT(1)/0/ J = 1 IF (.NOT.(CHSCAN(COMAND, J, '>') .EQ. 1)) GOTO 2680 C file redirection APPEND = .FALSE. FTMP = 4 IF (.NOT.(COMAND(J+1) .EQ. '>')) GOTO 2700 APPEND = .TRUE. J = J + 1 2700 CONTINUE IF (.NOT.(FOUT .EQ. FTMP)) GOTO 2720 C fout already redirected? CALL ERR(COMAND, J, 'Output is already redirected.') REDIR = ( - 1) RETURN 2720 CONTINUE IF (.NOT.(COMAND(J+1) .EQ. 0)) GOTO 2740 IF (.NOT.(DEV(1) .EQ. 0)) GOTO 2760 GOTO 10 2760 CONTINUE CALL DEFNAM(COMAND(J + 1), NODE, DEV, UIC, NAME, EXT, .FALSE.) GOTO 2750 2740 CONTINUE CALL DEFNAM(COMAND(J + 1), 0, 'SY:', 0, 0, '.LST', .FALSE.) 2750 CONTINUE IF (.NOT.(APPEND)) GOTO 2780 C need three open statements to get the proper C carriagecontrol when file is nonexistent. IF (.NOT.(CC .EQ. 1)) GOTO 2800 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'unknown', AC *CESS = 'append', BLOCKSIZE = 1024, CARRIAGECONTROL = 'list', RECOR *DSIZE = 524, ERR = 10) GOTO 2810 2800 CONTINUE IF (.NOT.(CC .EQ. 3)) GOTO 2820 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'unknown', AC *CESS = 'append', BLOCKSIZE = 1024, CARRIAGECONTROL = 'fortran', RE *CORDSIZE = 524, ERR = 10) GOTO 2810 2820 CONTINUE OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'unknown', AC *CESS = 'append', BLOCKSIZE = 1024, CARRIAGECONTROL = 'none', RECOR *DSIZE = 524, ERR = 10) 2810 CONTINUE COMAND(J - 1) = 0 GOTO 2790 2780 CONTINUE IF (.NOT.(CC .EQ. 1)) GOTO 2840 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'new', BLOCKS *IZE = 1024, CARRIAGECONTROL = 'list', RECORDSIZE = 524, ERR = 10) GOTO 2850 2840 CONTINUE IF (.NOT.(CC .EQ. 3)) GOTO 2860 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'new', BLOCKS *IZE = 1024, CARRIAGECONTROL = 'fortran', RECORDSIZE = 524, ERR = 1 *0) GOTO 2850 2860 CONTINUE OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'new', BLOCKS *IZE = 1024, CARRIAGECONTROL = 'none', RECORDSIZE = 524, ERR = 10) 2850 CONTINUE COMAND(J) = 0 2790 CONTINUE FOUT = FTMP CALL GFTYP(FOUT, OUTCC) C reset defaults CALL DEFNAM(COMAND(J + 1), NODE, DEV, UIC, NAME, EXT, .TRUE.) 2680 CONTINUE REDIR = (1) RETURN 10 CONTINUE CALL ERR(COMAND, J + 1, 'Can''t open file.') REDIR = ( - 1) RETURN END C puthdr - put out LIST file name header to output file SUBROUTINE PUTHDR(F, FILE) INTEGER F, FCC, L1, L2, I BYTE FILE(1), HDR(34 + 32) BYTE LISTCC(2), FORTCC(2), NONECC(4) INTEGER CONCAT BYTE CUPPER DATA LISTCC/12, 0/, FORTCC/'1', 0/, NONECC/13, 10, 12, 0/ C get carriagecontrol type CALL GFTYP(F, FCC) HDR(1) = 0 IF (.NOT.(FCC .EQ. 1)) GOTO 2880 L1 = CONCAT(HDR, LISTCC, 34 + 32) GOTO 2890 2880 CONTINUE IF (.NOT.(FCC .EQ. 3)) GOTO 2900 L1 = CONCAT(HDR, FORTCC, 34 + 32) GOTO 2890 2900 CONTINUE L1 = CONCAT(HDR, NONECC, 34 + 32) 2890 CONTINUE L1 = CONCAT(HDR, '# LIST ', 34 + 32) L2 = CONCAT(HDR, FILE, 34 + 32) DO 2920 I = L1, L2 HDR(I) = CUPPER(HDR(I)) 2920 CONTINUE I = L2 + 1 2940 IF (.NOT.(I .LE. L1+33)) GOTO 2960 HDR(I) = ' ' 2950 I = I + 1 GOTO 2940 2960 CONTINUE HDR(I) = ' ' HDR(I + 1) = ' ' I = I + 2 CALL DATE(HDR(I)) HDR(I + 9) = ' ' HDR(I + 10) = ' ' CALL TIME(HDR(I + 11)) HDR(I + 19) = 10 CALL PUT(F, HDR, I + 19, IER) RETURN END C err - put out error message SUBROUTINE ERR(COMAND, CP, MSG) INTEGER CP, IER, J, K, L INTEGER LENGTH BYTE COMAND(1), MSG(1) COMMON/TERM/SCRSIZ, SCRWID, SYSWID, SAVTAB, HLF, AUTOCR C current screen size; init: SCRLENGTH INTEGER SCRSIZ C (SCRLENGTH = real screen length-1 = 23) C current screen width; init: syswid INTEGER SCRWID C screen width from terminal driver (see gttyp) INTEGER SYSWID C saves value of system's hardware tabs flag INTEGER SAVTAB C true if hardware after col 80 (see gttyp) LOGICAL HLF C true if term set for auto carriagreturn (see gttyp) LOGICAL AUTOCR J = MOD(CP - 1, SCRWID) + 1 L = LENGTH(COMAND) K = MIN0(CP + SCRWID - J, L) CALL TTPUT(COMAND, K) ENCODE(J, 2970, COMAND) 2970 FORMAT(T,'^') CALL TTPUT(COMAND, J) IF (.NOT.(K .LT. L)) GOTO 2980 CALL TTPUT(COMAND(K + 1), L - K) 2980 CONTINUE CALL TTPUT(MSG, LENGTH(MSG)) COMAND(CP) = - 1 RETURN END C ttput - put a line with carriagecontrol to the standard output file C - inefficient version for error messages, etc. SUBROUTINE TTPUT(BUF, NCH) COMMON/CLIST/DOT, OLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDO *T, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MARKB C current logical record; init: 1 INTEGER*4DOT C old value of dot INTEGER*4OLDOT C top of last screen; init: 1 INTEGER*4TOPSCR C offset in file of logical line 1; init: 0 INTEGER*4FOFF C highest line number of logical file; init: MAXINT-1 INTEGER*4FMAX C next record on file; init: 1 INTEGER*4NXTREC C last record read; init: 0 INTEGER*4LSTRED C value of dot saved by the = command; init: 1 INTEGER*4SAVDOT C low value of record column range INTEGER LOWC C high value of record column range INTEGER HIGHC C carriagecontrol type of standard output INTEGER TTCC C carriagecontrol type of input file INTEGER CC C carriagecontrol type of output file INTEGER OUTCC C index of highest line number in markb; init:0 INTEGER MARKP C points to every 100th line on file INTEGER MARKB(4, 0:1000) INTEGER NCH, IER BYTE BUF(1), CRLF(2) DATA CRLF/13, 10/ IER = 0 IF (.NOT.(TTCC .EQ. 2)) GOTO 3000 CALL PUT(3, CRLF, 2, IER) 3000 CONTINUE IF (.NOT.(IER .EQ. 0)) GOTO 3020 CALL PUT(3, BUF, NCH, IER) 3020 CONTINUE RETURN END