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: March 26, 1982 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) # comment this out for PDP11 C Invoke LIST on wild card file names C note the order of the next several defines is significant! C Record or Block i/o. C or to "define(RECORDIO,#)" for block io C define(BLOCKIO,# BLOCK IO) C define(MARKSIZE,4) # size of buffer for mark/point C command line switch flags 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 LOGICAL LITRAL LITRAL = .FALSE. J = 1 2000 IF (.NOT.(COMAND(J) .NE. 0 .AND. (LITRAL .OR. (COMAND(J) .NE. ' ' *.AND. (J .EQ. 1 .OR. COMAND(1) .NE. '/' .OR. COMAND(J) .NE. '/'))) *)) GOTO 2020 IF (.NOT.(COMAND(J) .EQ. '"')) GOTO 2030 IF (.NOT.(COMAND(J+1) .EQ. '"')) GOTO 2050 ARG(J) = '"' J = J + 1 GOTO 2060 2050 CONTINUE LITRAL = .NOT.LITRAL 2060 CONTINUE 2030 CONTINUE IF (.NOT.(LITRAL)) GOTO 2070 ARG(J) = COMAND(J) GOTO 2080 2070 CONTINUE ARG(J) = CUPPER(COMAND(J)) 2080 CONTINUE 2010 J = J + 1 GOTO 2000 2020 CONTINUE ARG(J) = 0 IF (.NOT.(COMAND(J) .EQ. ' ')) GOTO 2090 J = J + 1 2090 CONTINUE CALL SCOPY(COMAND, J, COMAND, 1) RETURN END C matswi - match a switch LOGICAL FUNCTION MATSWI(SWTCH, TEMPL, LER, ERRMSG, N, CBUF, CSIZE) BYTE SWTCH(1), TEMPL(1), ERRMSG(1), CBUF(1), CUPPER INTEGER*4N, NTMP INTEGER CSIZE, BS, ES, I, J LOGICAL LER I = 1 J = 1 2110 IF (.NOT.(TEMPL(J) .NE. 0 .AND. TEMPL(J) .NE. '=')) GOTO 2130 IF (.NOT.(CUPPER(SWTCH(I)) .EQ. CUPPER(TEMPL(J)) .AND. I .EQ. J) *) GOTO 2140 I = I + 1 GOTO 2150 2140 CONTINUE IF (.NOT.(.NOT.(TEMPL(J) .GE. 'a' .AND. TEMPL(J) .LE. 'z'))) GOT *O 2160 MATSWI = (.FALSE.) RETURN 2160 CONTINUE 2150 CONTINUE 2120 J = J + 1 GOTO 2110 2130 CONTINUE IF (.NOT.(TEMPL(J) .EQ. 0)) GOTO 2180 IF (.NOT.(SWTCH(I) .EQ. 0)) GOTO 2200 MATSWI = (.TRUE.) RETURN 2200 CONTINUE IF (.NOT.(SWTCH(I) .EQ. '=')) GOTO 2220 CALL ERR(SWTCH, I, 'No switch argument expected.') LER = .TRUE. MATSWI = (.FALSE.) RETURN 2220 CONTINUE 2210 CONTINUE 2180 CONTINUE IF (.NOT.(SWTCH(I) .NE. '=')) GOTO 2240 IF (.NOT.(SWTCH(I) .NE. 0)) GOTO 2260 MATSWI = (.FALSE.) RETURN 2260 CONTINUE IF (.NOT.(ERRMSG(1) .NE. 0)) GOTO 2280 CALL ERR(SWTCH, I, 'Switch argument expected.') 2280 CONTINUE LER = .TRUE. MATSWI = (.FALSE.) RETURN 2240 CONTINUE BS = I + 1 ES = LENGTH(SWTCH) + 1 I2300 = (TEMPL(J+1)) GOTO 2300 2320 CONTINUE DECODE(ES-BS, 2330, SWTCH(BS), ERR=10) NTMP 2330 FORMAT(I) GOTO 2310 2340 CONTINUE IF (.NOT.(SWTCH(BS) .NE. '"')) GOTO 2350 GOTO 10 2350 CONTINUE I = BS + 1 J = 1 2370 IF (.NOT.(SWTCH(I) .NE. 0 .AND. J .LE. CSIZE)) GOTO 2390 IF (.NOT.(SWTCH(I) .EQ. '"')) GOTO 2400 I = I + 1 IF (.NOT.(SWTCH(I) .NE. '"')) GOTO 2420 GOTO 2390 2420 CONTINUE 2400 CONTINUE CBUF(J) = SWTCH(I) 2380 I = I + 1 J = J + 1 GOTO 2370 2390 CONTINUE IF (.NOT.(SWTCH(I) .NE. 0 .OR. J .GT. CSIZE .OR. J .LE. 1)) GOTO * 2440 GOTO 10 2440 CONTINUE CBUF(J) = 0 NTMP = J - 1 GOTO 2310 2460 CONTINUE GOTO 10 1 CONTINUE GOTO 2310 2300 CONTINUE IF (I2300 .EQ. 34) GOTO 2340 IF (I2300 .EQ. 35) GOTO 2320 GOTO 2460 2310 CONTINUE N = NTMP MATSWI = (.TRUE.) RETURN 10 IF (.NOT.(ERRMSG(1) .NE. 0)) GOTO 2470 CALL ERR(SWTCH, BS, ERRMSG) 2470 CONTINUE LER = .TRUE. MATSWI = (.FALSE.) RETURN END C redir - redirect output from LIST INTEGER FUNCTION REDIR(FOUT, COMAND, STAT) INTEGER FOUT, STAT, J BYTE COMAND(1) LOGICAL CHSCAN COMMON/CLIST/DOT, BCLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVD *OT, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MRKINT, XSTAT, RANDAC, FL *AGS, MARKB, ERRBUF C current logical record INTEGER*4DOT C dot at beginning of command line INTEGER*4BCLDOT C top of last screen INTEGER*4TOPSCR C offset in file of logical line 1 INTEGER*4FOFF C highest line number of logical file INTEGER*4FMAX C next record on file INTEGER*4NXTREC C last record read INTEGER*4LSTRED C value of dot saved by the = command 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 INTEGER MARKP C interval in lines between file marks INTEGER MRKINT C exit status INTEGER XSTAT C .true. if input is random access device LOGICAL RANDAC C command line switch flags LOGICAL FLAGS(4) C points to every mrkint line in file INTEGER*2MARKB(3, 0:500) C buffer for constructing error messages BYTE ERRBUF(80) DATA XSTAT/1/ J = 1 STAT = 0 IF (.NOT.(CHSCAN(COMAND, J, '>'))) GOTO 2490 C file redirection STAT = STAT .OR. (1) IF (.NOT.(COMAND(J+1) .EQ. '>')) GOTO 2510 STAT = STAT .OR. (2) J = J + 1 2510 CONTINUE IF (.NOT.(FOUT .EQ. 4)) GOTO 2530 C fout already redirected? CALL ERR(COMAND, J, 'Output is already redirected.') REDIR = ( - 1) RETURN 2530 CONTINUE CALL GOFN(COMAND(J + 1), STAT) IF (.NOT.((((STAT) .AND. (2)) .NE. 0))) GOTO 2550 C need 3 open statements to get the proper C carriagecontrol when file is nonexistent. IF (.NOT.(CC .EQ. 1)) GOTO 2570 OPEN(UNIT = 4, NAME = COMAND(J + 1), TYPE = 'unknown', CARRI *AGECONTROL = 'list', ERR = 10, SHARED, ACCESS = 'append') GOTO 2580 2570 CONTINUE IF (.NOT.(CC .EQ. 3)) GOTO 2590 OPEN(UNIT = 4, NAME = COMAND(J + 1), TYPE = 'unknown', CARRI *AGECONTROL = 'fortran', ERR = 10, SHARED, ACCESS = 'append') GOTO 2580 2590 CONTINUE OPEN(UNIT = 4, NAME = COMAND(J + 1), TYPE = 'unknown', CARRI *AGECONTROL = 'none', ERR = 10, SHARED, ACCESS = 'append') 2580 CONTINUE COMAND(J - 1) = 0 GOTO 2560 2550 CONTINUE IF (.NOT.(CC .EQ. 1)) GOTO 2610 OPEN(UNIT = 4, NAME = COMAND(J + 1), TYPE = 'new', CARRIAGEC *ONTROL = 'list', ERR = 10, SHARED) GOTO 2620 2610 CONTINUE IF (.NOT.(CC .EQ. 3)) GOTO 2630 OPEN(UNIT = 4, NAME = COMAND(J + 1), TYPE = 'new', CARRIAGEC *ONTROL = 'fortran', ERR = 10, SHARED) GOTO 2620 2630 CONTINUE OPEN(UNIT = 4, NAME = COMAND(J + 1), TYPE = 'new', CARRIAGEC *ONTROL = 'none', ERR = 10, SHARED) 2620 CONTINUE COMAND(J) = 0 2560 CONTINUE FOUT = 4 CALL GCCTYP(FOUT, OUTCC) 2490 CONTINUE REDIR = (1) RETURN 10 CONTINUE CALL ERR(COMAND, J + 1, 'Can''t open file.') REDIR = ( - 1) RETURN END C gofn - get output file name for file redirection SUBROUTINE GOFN(FILE, STAT) BYTE FILE(1) INTEGER STAT, INDEXQ C files - common area for file defaults and names COMMON/FILES/LFILE, NODE, DEV, UIC, NAME, EXT, CNODE, CDEV, CUIC, *CNAME, CEXT, CVER C current output file spec BYTE LFILE(99) C defaults constructed from input file spec on command line BYTE NODE(66) BYTE UIC(10) BYTE NAME(10) BYTE DEV(6) BYTE EXT(5) C current open input file spec fields BYTE CNODE(66) BYTE CDEV(6) BYTE CUIC(10) BYTE CNAME(10) BYTE CEXT(5) BYTE CVER(7) DATA LFILE(1)/0/ DATA NODE(1)/0/ DATA UIC(1)/0/ DATA NAME(1)/0/ 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 CNODE(1)/0/ DATA CDEV(1)/0/ DATA CUIC(1)/0/ DATA CNAME(1)/0/ DATA CEXT(1)/0/ DATA CVER(1)/0/ IF (.NOT.(FILE(1) .EQ. 0)) GOTO 2650 C use last file name CALL SCOPY(LFILE, 1, FILE, 1) GOTO 2660 2650 CONTINUE LFILE(1) = 0 C set last file CALL CONCAT(LFILE, FILE, 99) 2660 CONTINUE IF (.NOT.(INDEXQ(FILE, '*') .NE. 0)) GOTO 2670 C replace asterisks with input file fields CALL FPARSE(FILE, CNODE, CDEV, CUIC, CNAME, CEXT, CVER, .FALSE., * .TRUE.) STAT = STAT .OR. (4) 2670 CONTINUE CALL DEFNAM(FILE, 0, 'SY:', 0, 'LIST', '.LST', .FALSE.) RETURN END C puthdr - put out LIST file name header to output file SUBROUTINE PUTHDR(F, FILE) INTEGER F, L1, L2, I BYTE FILE(1), HDR(182) BYTE LISTCC(2), FORTCC(2), NONECC(4) INTEGER CONCAT BYTE CUPPER COMMON/CLIST/DOT, BCLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVD *OT, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MRKINT, XSTAT, RANDAC, FL *AGS, MARKB, ERRBUF C current logical record INTEGER*4DOT C dot at beginning of command line INTEGER*4BCLDOT C top of last screen INTEGER*4TOPSCR C offset in file of logical line 1 INTEGER*4FOFF C highest line number of logical file INTEGER*4FMAX C next record on file INTEGER*4NXTREC C last record read INTEGER*4LSTRED C value of dot saved by the = command 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 INTEGER MARKP C interval in lines between file marks INTEGER MRKINT C exit status INTEGER XSTAT C .true. if input is random access device LOGICAL RANDAC C command line switch flags LOGICAL FLAGS(4) C points to every mrkint line in file INTEGER*2MARKB(3, 0:500) C buffer for constructing error messages BYTE ERRBUF(80) DATA XSTAT/1/ DATA LISTCC/12, 0/, FORTCC/'1', 0/, NONECC/13, 10, 12, 0/ HDR(1) = 0 IF (.NOT.(OUTCC .EQ. 1)) GOTO 2690 L1 = CONCAT(HDR, LISTCC, 182) GOTO 2700 2690 CONTINUE IF (.NOT.(OUTCC .EQ. 3)) GOTO 2710 L1 = CONCAT(HDR, FORTCC, 182) GOTO 2700 2710 CONTINUE L1 = CONCAT(HDR, NONECC, 182) 2700 CONTINUE L1 = CONCAT(HDR, '# LIST ', 182) L2 = CONCAT(HDR, FILE, 182) DO 2730 I = L1, L2 HDR(I) = CUPPER(HDR(I)) 2730 CONTINUE I = L2 + 1 2750 IF (.NOT.(I .LE. L1+49)) GOTO 2770 HDR(I) = ' ' 2760 I = I + 1 GOTO 2750 2770 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) = 13 HDR(I + 20) = 10 CALL PUT(F, HDR, I + 20, 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, HLF, AUTOCR C current screen size; init: SCRLENGTH INTEGER*4SCRSIZ 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 true if hardware after col 80 (see gttyp) LOGICAL HLF C true if term set for auto carriagereturn (see gttyp) LOGICAL AUTOCR COMMON/CLIST/DOT, BCLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVD *OT, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MRKINT, XSTAT, RANDAC, FL *AGS, MARKB, ERRBUF C current logical record INTEGER*4DOT C dot at beginning of command line INTEGER*4BCLDOT C top of last screen INTEGER*4TOPSCR C offset in file of logical line 1 INTEGER*4FOFF C highest line number of logical file INTEGER*4FMAX C next record on file INTEGER*4NXTREC C last record read INTEGER*4LSTRED C value of dot saved by the = command 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 INTEGER MARKP C interval in lines between file marks INTEGER MRKINT C exit status INTEGER XSTAT C .true. if input is random access device LOGICAL RANDAC C command line switch flags LOGICAL FLAGS(4) C points to every mrkint line in file INTEGER*2MARKB(3, 0:500) C buffer for constructing error messages BYTE ERRBUF(80) DATA XSTAT/1/ J = MOD(CP - 1, SCRWID) + 1 L = LENGTH(COMAND) K = MIN0(CP + SCRWID - J, L) CALL TTPUT(COMAND, K) ENCODE(J, 2780, COMAND) 2780 FORMAT(T,'^') CALL TTPUT(COMAND, J) IF (.NOT.(K .LT. L)) GOTO 2790 CALL TTPUT(COMAND(K + 1), L - K) 2790 CONTINUE CALL TTPUT(MSG, 0) COMAND(CP) = - 1 XSTAT = 2 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, BCLDOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVD *OT, LOWC, HIGHC, TTCC, CC, OUTCC, MARKP, MRKINT, XSTAT, RANDAC, FL *AGS, MARKB, ERRBUF C current logical record INTEGER*4DOT C dot at beginning of command line INTEGER*4BCLDOT C top of last screen INTEGER*4TOPSCR C offset in file of logical line 1 INTEGER*4FOFF C highest line number of logical file INTEGER*4FMAX C next record on file INTEGER*4NXTREC C last record read INTEGER*4LSTRED C value of dot saved by the = command 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 INTEGER MARKP C interval in lines between file marks INTEGER MRKINT C exit status INTEGER XSTAT C .true. if input is random access device LOGICAL RANDAC C command line switch flags LOGICAL FLAGS(4) C points to every mrkint line in file INTEGER*2MARKB(3, 0:500) C buffer for constructing error messages BYTE ERRBUF(80) DATA XSTAT/1/ INTEGER NCH, IER, LEN, LENGTH BYTE BUF(1), CRLF(2) DATA CRLF/13, 10/ IER = 0 IF (.NOT.(NCH .EQ. 0)) GOTO 2810 LEN = LENGTH(BUF) GOTO 2820 2810 CONTINUE LEN = NCH 2820 CONTINUE IF (.NOT.(TTCC .EQ. 2)) GOTO 2830 CALL PUT(3, CRLF, 2, IER, .TRUE.) 2830 CONTINUE IF (.NOT.(IER .EQ. 0)) GOTO 2850 CALL PUT(3, BUF, LEN, IER, .TRUE.) 2850 CONTINUE RETURN END