C C C C LIST File Listing Utility C ========================= C C Author: William Wood 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: 2.0 C C Date: December 1, 1980 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 * THIS SOFTWARE WAS DESIGNED FOR USE ON A * C * PDP-11/70 OPERATING UNDER IAS V3.0 USING * C * THE FORTRAN-IV PLUS COMPILER. * C * * C ******************************************************* C C C C note the order of the next several defines is significant! C comment this out for export version C ICR ONLY define(NOTICR,# NOT ICR) C Local ICR functions supported by LIST: C Invoke LIST on SRD-selected files 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 if the SRD option is in use, file names may be selected by C an SRD pattern. LOGICAL FUNCTION GETFIL(FILE, ANS, NSELEC, PROMPT) BYTE FILE(1), ANS(2), TERMC, TFILE(134), FILIST(134) INTEGER NSELEC, NC, NAME, IP, J, I, NFILE LOGICAL PROMPT, ISLIST, INBRAK INTEGER BKSCAN, LENGTH BYTE CUPPER 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 2210 CONTINUE FILE(J - IP) = 0 IP = J NAME = 0 IF (.NOT.(FILE(1) .EQ. '@')) GOTO 2220 C Indirect file name? NAME = 2 GOTO 2230 2220 CONTINUE IF (.NOT.(FILE(BKSCAN(FILE, '/*?', 1)) .NE. 0)) GOTO 2240 C SRD wild card or switch? NAME = 1 2240 CONTINUE 2230 CONTINUE 2090 CONTINUE NC = 0 IF (.NOT.(NAME .EQ. 0 .AND. .NOT.ISLIST)) GOTO 2260 NFILE = 1 - NFILE GOTO 2270 2260 CONTINUE 2280 CONTINUE IF (.NOT.(NAME .EQ. 1)) GOTO 2310 CALL FNDFIL(5, FILE, TFILE, NFILE) GOTO 2320 2310 CONTINUE IF (.NOT.(NAME .EQ. 2)) GOTO 2330 CALL READF(5, FILE, TFILE, NFILE) GOTO 2340 2330 CONTINUE NFILE = 1 - NFILE CALL SCOPY(FILE, 1, TFILE, 1) 2340 CONTINUE 2320 CONTINUE IF (.NOT.(NFILE .GT. 0)) GOTO 2350 CALL SCOPY(TFILE, 1, FILE, 1) IF (.NOT.(PROMPT)) GOTO 2370 IF (.NOT.(ANS(1) .NE. 'G')) GOTO 2390 2410 CONTINUE CALL READPR(2, FILE, ANS, NC, 2, TERMC) 2420 IF (.NOT.(NC .EQ. -10 .OR. NC .GE. 0)) GOTO 2410 2430 CONTINUE ANS(1) = CUPPER(ANS(1)) GOTO 2400 2390 CONTINUE CALL PUT(2, FILE, LENGTH(FILE), IER) 2400 CONTINUE 2370 CONTINUE 2350 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 22 *80 2300 CONTINUE 2270 CONTINUE 2070 IF (.NOT.(NFILE .GT. 0 .OR. FILIST(IP) .EQ. 0 .OR. NC .EQ. -10)) * GOTO 2060 2080 CONTINUE GETFIL = NFILE .GT. 0 .AND. NC .NE. - 10 IF (.NOT.(GETFIL)) GOTO 2440 NSELEC = NSELEC + 1 2440 CONTINUE IF (.NOT.(NC .EQ. -10)) GOTO 2460 CLOSE(UNIT = 5) 2460 CONTINUE 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 2480 CALL DEFNAM(FILE(2), 0, 'SY:', 0, 0, '.', .FALSE.) CLOSE(UNIT = F) open(unit=f, name=file(2), type='old', readonly, shared, err=10) 2480 CONTINUE 2500 CONTINUE CALL GET(F, OUTFILE, 134 - 1, NC) 2510 IF (.NOT.(NC .NE. 0)) GOTO 2500 2520 CONTINUE IF (.NOT.(NC .LT. 0)) GOTO 2530 NSELEC = 0 CLOSE(UNIT = F) GOTO 2540 2530 CONTINUE NSELEC = NSELEC + 1 OUTFIL(NC + 1) = 0 2540 CONTINUE RETURN 10 CONTINUE CALL ERR(FILE, 2, 'Can''t open file.') RETURN END C opndef - open file for reading using defaults in file name LOGICAL FUNCTION OPNDEF(LUN, FILE) INTEGER LUN, I, IER BYTE FILE(1), FILE1(134) BYTE NODE(1), DEV(11), UIC(81), NAME(21), EXT(5) INTEGER CONCAT COMMON/CLIST/DOT, ODOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDOT *, LOWC, HIGHC, CC, OUTCC, MARKP, MARKB C current logical record; init: 1 INTEGER*4DOT C old value of dot INTEGER*4ODOT 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 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/ DATA DEV(1), DEV(2), DEV(3), DEV(4)/'S', 'Y', ':', 0/ DATA UIC(1)/0/ DATA NAME(1)/0/ DATA EXT(1), EXT(2), EXT(3), EXT(4), EXT(5)/'.', 'L', 'S', 'T', 0/ C try default file name first OPNDEF = .TRUE. CALL SCOPY(FILE, 1, FILE1, 1) CALL DEFNAM(FILE1, NODE, DEV, UIC, NAME, EXT, .TRUE.) OPEN(UNIT = LUN, NAME = FILE1, TYPE = 'old', READONLY, SHARED, ERR * = 10, BUFFERCOUNT = 4) C BLOCK IO call bopen(lun, file1, 'R', ier) C BLOCK IO if (ier ~= 0) C BLOCK IO goto 10 C return full file name CALL SCOPY(FILE1, 1, FILE, 1) GOTO 30 C now try file name as is, with SY: and . as default device and extension 10 CONTINUE CALL DEFNAM(FILE, 0, 'SY:', 0, 0, '.', .FALSE.) OPEN(UNIT = LUN, NAME = FILE, TYPE = 'old', READONLY, SHARED, ERR *= 20, BUFFERCOUNT = 4) C BLOCK IO call bopen(lun, file, '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(FILE, NODE, DEV, UIC, NAME, EXT, .TRUE.) GOTO 30 C here if unable to open file 20 CONTINUE OPNDEF = .FALSE. CALL SCOPY('LIST -- ERROR OPENING ', 1, FILE, 1) I = CONCAT(FILE, FILE1, 134) CALL PUT(2, FILE, I, IER) RETURN 30 CONTINUE CALL GFTYP(LUN, CC) RETURN 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(11), UIC(81), NAME(21), EXT(5) LOGICAL APPEND COMMON/CLIST/DOT, ODOT, TOPSCR, FOFF, FMAX, NXTREC, LSTRED, SAVDOT *, LOWC, HIGHC, CC, OUTCC, MARKP, MARKB C current logical record; init: 1 INTEGER*4DOT C old value of dot INTEGER*4ODOT 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 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 2550 C file redirection APPEND = .FALSE. FTMP = 4 IF (.NOT.(COMAND(J+1) .EQ. '>')) GOTO 2570 APPEND = .TRUE. J = J + 1 2570 CONTINUE IF (.NOT.(FOUT .EQ. FTMP)) GOTO 2590 C fout already redirected? CALL ERR(COMAND, J, 'Output is already redirected.') REDIR = ( - 1) RETURN 2590 CONTINUE IF (.NOT.(COMAND(J+1) .EQ. 0)) GOTO 2610 IF (.NOT.(DEV(1) .EQ. 0)) GOTO 2630 GOTO 10 2630 CONTINUE CALL DEFNAM(COMAND(J + 1), NODE, DEV, UIC, NAME, EXT, .FALSE.) GOTO 2620 2610 CONTINUE CALL DEFNAM(COMAND(J + 1), 0, 'SY:', 0, 0, '.', .FALSE.) 2620 CONTINUE IF (.NOT.(APPEND)) GOTO 2650 C need three open statements to get the proper C carriagecontrol when file is nonexistent. IF (.NOT.(CC .EQ. 1)) GOTO 2670 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'unknown', AC *CESS = 'append', BUFFERCOUNT = 2, CARRIAGECONTROL = 'list', RECORD *SIZE = 524, ERR = 10) GOTO 2680 2670 CONTINUE IF (.NOT.(CC .EQ. 3)) GOTO 2690 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'unknown', *ACCESS = 'append', BUFFERCOUNT = 2, CARRIAGECONTROL = 'fortran', R *ECORDSIZE = 524, ERR = 10) GOTO 2700 2690 CONTINUE OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'unknown', *ACCESS = 'append', BUFFERCOUNT = 2, CARRIAGECONTROL = 'none', RECO *RDSIZE = 524, ERR = 10) 2700 CONTINUE 2680 CONTINUE COMAND(J - 1) = 0 GOTO 2660 2650 CONTINUE IF (.NOT.(CC .EQ. 1)) GOTO 2710 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'new', BUFFER *COUNT = 2, CARRIAGECONTROL = 'list', RECORDSIZE = 524, ERR = 10) GOTO 2720 2710 CONTINUE IF (.NOT.(CC .EQ. 3)) GOTO 2730 OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'new', BUFF *ERCOUNT = 2, CARRIAGECONTROL = 'fortran', RECORDSIZE = 524, ERR = *10) GOTO 2740 2730 CONTINUE OPEN(UNIT = FTMP, NAME = COMAND(J + 1), TYPE = 'new', BUFF *ERCOUNT = 2, CARRIAGECONTROL = 'none', RECORDSIZE = 524, ERR = 10) 2740 CONTINUE 2720 CONTINUE COMAND(J) = 0 2660 CONTINUE FOUT = FTMP CALL GFTYP(FOUT, OUTCC) Creset defaults CALL DEFNAM(COMAND(J + 1), NODE, DEV, UIC, NAME, EXT, .TRUE.) 2550 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(125 + 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 2750 L1 = CONCAT(HDR, LISTCC, 125 + 32) GOTO 2760 2750 CONTINUE IF (.NOT.(FCC .EQ. 3)) GOTO 2770 L1 = CONCAT(HDR, FORTCC, 125 + 32) GOTO 2780 2770 CONTINUE L1 = CONCAT(HDR, NONECC, 125 + 32) 2780 CONTINUE 2760 CONTINUE L1 = CONCAT(HDR, '# LIST ', 125 + 32) L2 = CONCAT(HDR, FILE, 125 + 32) DO 2790 I = L1, L2 HDR(I) = CUPPER(HDR(I)) 2790 CONTINUE 2800 CONTINUE I = L2 + 1 2810 IF (.NOT.(I .LE. L1+33)) GOTO 2830 HDR(I) = ' ' 2820 I = I + 1 GOTO 2810 2830 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 PUT(2, COMAND, K, IER) ENCODE(J, 10, COMAND) 10 format(t,'^') CALL PUT(2, COMAND, J, IER) IF (.NOT.(K .LT. L)) GOTO 2840 CALL PUT(2, COMAND(K + 1), L - K, IER) 2840 CONTINUE CALL PUT(2, MSG, LENGTH(MSG), IER) COMAND(CP) = - 1 RETURN END