C define(VAX) C location of system-wide "SYMBOLS." file C maximum field for integer strings C must be highest lu for standard files C C C C RATLIB utility routines - Get command line arguments C ==================================================== C C C Author: William P. Wood, Jr. C 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 18, 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 cmdget - get a line with prompt from CMDIN INTEGER FUNCTION CMDGET(BUF, PROMPT, SOURCE) BYTE BUF(1), PROMPT(1) INTEGER NC, SOURCE 2000 CONTINUE CALL GCMDLN(4, 0, PROMPT, BUF, NC, 134 - 1, SOURCE) IF (.NOT.(NC .LT. 0 .AND. NC .NE. -10)) GOTO 2030 CALL REMARK('error reading command line.') GOTO 2040 2030 CONTINUE GOTO 2020 2040 CONTINUE 2010 GOTO 2000 2020 CONTINUE IF (.NOT.(NC .EQ. -10)) GOTO 2050 CMDGET = - 10 BUF(1) = - 10 BUF(2) = 0 GOTO 2060 2050 CONTINUE CMDGET = NC + 1 BUF(CMDGET) = 10 BUF(CMDGET + 1) = 0 2060 CONTINUE RETURN END C gclin -- prompt user for arguments, redirect standard files SUBROUTINE GCLIN(PROMPT, SOURCE) BYTE PROMPT(1) INTEGER CMDGET, NC, SOURCE COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD NOREAD = .FALSE. 2070 CONTINUE NC = CMDGET(ARGSTR, PROMPT, SOURCE) IF (.NOT.(NC .EQ. -10 .OR. NC .EQ. 1)) GOTO 2100 GOTO 2090 2100 CONTINUE CALL DOREDR 2080 IF (.NOT.(ARGSTR(1) .NE. 10)) GOTO 2070 2090 CONTINUE RETURN END C garg - get an argument with prompt from CMDIN INTEGER FUNCTION GARG(PROMPT, NARG, BUF, BUFLEN) BYTE PROMPT(1), BUF(1) INTEGER NARG, BUFLEN, GTARG2, SOURCE LOGICAL EOFFLG DATA EOFFLG/.FALSE./ IF (.NOT.(EOFFLG .AND. NARG .EQ. 0)) GOTO 2120 GARG = - 10 BUF(1) = - 10 RETURN 2120 CONTINUE IF (.NOT.(NARG .EQ. 0)) GOTO 2140 GOTO 10 2140 CONTINUE GARG = GTARG2(NARG, BUF, BUFLEN) IF (.NOT.(GARG .NE. -10)) GOTO 2160 NARG = NARG + 1 GOTO 2170 2160 CONTINUE IF (.NOT.(BUF(1) .EQ. 10)) GOTO 2180 C really was a NEWLINE, not EOF 10 IF (.NOT.(PROMPT(1) .NE. 0)) GOTO 2200 CALL GCLIN(PROMPT, SOURCE) GARG = GTARG2(1, BUF, BUFLEN) IF (.NOT.(GARG .NE. -10)) GOTO 2220 NARG = 2 GOTO 2230 2220 CONTINUE IF (.NOT.(NARG .NE. 0 .AND. SOURCE .LT. 0 .AND. BUF(1) .NE. 10 *)) GOTO 2240 C don't reprompt when narg = 0 next time EOFFLG = .TRUE. C get past fake EOF on second gclin GOTO 10 2240 CONTINUE 2230 CONTINUE 2200 CONTINUE 2180 CONTINUE 2170 CONTINUE RETURN END C getarg -- interface to gtarg2 with read if none done already INTEGER FUNCTION GETARG(N, STRNG, SIZE) INTEGER N, SIZE BYTE STRNG(1) INTEGER GTARG2 COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD IF (.NOT.(NOREAD)) GOTO 2260 CALL GCLIN('> ', SOURCE) 2260 CONTINUE GETARG = GTARG2(N, STRNG, SIZE) RETURN END C gcmd - get command line from MCR, TIMESHARING, or terminal C This routine may be used by programs wishing to receive a C time sharing message (command line) from XEQ, a C command line from MCR, or a command line from the terminal C directly using a prompt. C C By William Wood, Sept 1980 C SUBROUTINE GCMD(LUN, PROMPT, BUF, LEN, MAXLEN, SOURCE) BYTE PROMPT(1), BUF(1) INTEGER LUN, LEN, MAXLEN, SOURCE INTEGER I, J, JUNK LOGICAL FIRST DATA FIRST/.TRUE./ LEN = 0 IF (.NOT.(FIRST)) GOTO 2280 FIRST = .FALSE. CALL GETMCR(BUF, LEN) IF (.NOT.(LEN .GT. 0)) GOTO 2300 SOURCE = - 2 I = 1 2320 IF (.NOT.(I .LT. LEN)) GOTO 2340 IF (.NOT.(BUF(I) .EQ. ' ' .OR. BUF(I+1) .EQ. '/')) GOTO 2350 GOTO 2340 2350 CONTINUE 2330 I = I + 1 GOTO 2320 2340 CONTINUE J = I I = I + 1 2370 IF (.NOT.(I .LE. LEN)) GOTO 2390 BUF(I - J) = BUF(I) 2380 I = I + 1 GOTO 2370 2390 CONTINUE LEN = LEN - J GOTO 2310 2300 CONTINUE CALL RECCML(BUF, LEN) SOURCE = - 1 2310 CONTINUE 2280 CONTINUE IF (.NOT.(LEN .LE. 0)) GOTO 2400 SOURCE = 0 IF (.NOT.(LUN .EQ. 0)) GOTO 2420 LEN = - 10 GOTO 2430 2420 CONTINUE 2440 CONTINUE CALL READPR(LUN, PROMPT, BUF, LEN, MAXLEN - 1, JUNK) 2450 IF (.NOT.(LEN .GE. 0 .OR. LEN .EQ. -10)) GOTO 2440 2430 CONTINUE 2400 CONTINUE BUF(MAX0(1, MIN0(MAXLEN, LEN + 1))) = 0 RETURN END C garg2 - get an argument with prompt INTEGER FUNCTION GARG2(PROMPT, NARG, BUF, BUFLEN, LUN) BYTE PROMPT(1), BUF(1) INTEGER NARG, BUFLEN, GTARG2, SOURCE, LUN, NC, I LOGICAL EOFFLG COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD DATA EOFFLG/.FALSE./ GARG2 = - 10 IF (.NOT.(EOFFLG .AND. NARG .EQ. 0)) GOTO 2470 BUF(1) = - 10 RETURN 2470 CONTINUE IF (.NOT.(NARG .NE. 0)) GOTO 2490 GARG2 = GTARG2(NARG, BUF, BUFLEN) NARG = NARG + 1 2490 CONTINUE IF (.NOT.((PROMPT(1) .NE. 0 .OR. NARG .EQ. 0) .AND. GARG2 .EQ. -10 *)) GOTO 2510 CALL GCMD(LUN, PROMPT, ARGSTR, NC, 134 - 1, SOURCE) IF (.NOT.(SOURCE .LT. 0)) GOTO 2530 C there was input from the command line EOFFLG = .TRUE. 2530 CONTINUE IF (.NOT.(NC .GE. 0)) GOTO 2550 I = NC + 1 GOTO 2560 2550 CONTINUE I = 1 2560 CONTINUE ARGSTR(I) = 10 ARGSTR(I + 1) = 0 GARG2 = GTARG2(1, BUF, BUFLEN) NARG = 2 2510 CONTINUE RETURN END C gtarg2 -- get the n-th argument and return its length or EOF INTEGER FUNCTION GTARG2(N, STRNG, SIZE) INTEGER N, SIZE, SOURCE BYTE STRNG(1) INTEGER I, J, K, M LOGICAL LB COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD J = 0 I = 1 LB = .FALSE. 2570 IF (.NOT.(J .LT. N)) GOTO 2580 2590 IF (.NOT.(ARGSTR(I) .EQ. ' ' .OR. ARGSTR(I) .EQ. 9 .OR. ARGSTR(I *) .EQ. ',')) GOTO 2600 I = I + 1 GOTO 2590 2600 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. -10 .OR. ARGSTR(I) .EQ. 10)) GOTO 2610 STRNG(1) = ARGSTR(I) GTARG2 = - 10 RETURN 2610 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. '/')) GOTO 2630 STRNG(1) = '/' K = 1 GOTO 2640 2630 CONTINUE K = 0 2640 CONTINUE 2650 CONTINUE K = K + 1 M = I + K - 1 IF (.NOT.(K .LT. SIZE)) GOTO 2680 STRNG(K) = ARGSTR(M) 2680 CONTINUE IF (.NOT.(ARGSTR(M) .EQ. 91)) GOTO 2700 LB = .TRUE. GOTO 2710 2700 CONTINUE IF (.NOT.(ARGSTR(M) .EQ. 93)) GOTO 2720 LB = .FALSE. 2720 CONTINUE 2710 CONTINUE 2660 IF (.NOT.(.NOT.LB .AND. (ARGSTR(M) .EQ. ' ' .OR. ARGSTR(M) .EQ. *9 .OR. ARGSTR(M) .EQ. 10 .OR. ARGSTR(M) .EQ. ',' .OR. ARGSTR(M) .E *Q. '/'))) GOTO 2650 STRNG(MIN0(K, SIZE)) = 0 I = M J = J + 1 GOTO 2570 2580 CONTINUE GTARG2 = MIN0(K, SIZE) IF (.NOT.(UPFLAG)) GOTO 2740 CALL UPPER(STRNG) 2740 CONTINUE RETURN END C delarg - delete the nth argument in the command line SUBROUTINE DELARG(N) INTEGER I, J, BEGSTR, N LOGICAL LB COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD J = 0 I = 1 LB = .FALSE. 2760 IF (.NOT.(J .LT. N)) GOTO 2770 BEGSTR = I 2780 IF (.NOT.(ARGSTR(I) .EQ. ' ' .OR. ARGSTR(I) .EQ. 9 .OR. ARGSTR(I *) .EQ. ',')) GOTO 2790 I = I + 1 GOTO 2780 2790 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. -10 .OR. ARGSTR(I) .EQ. 10)) GOTO 2800 RETURN 2800 CONTINUE 2820 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. 91)) GOTO 2850 LB = .TRUE. GOTO 2860 2850 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. 93)) GOTO 2870 LB = .FALSE. 2870 CONTINUE 2860 CONTINUE I = I + 1 2830 IF (.NOT.(.NOT.LB .AND. (ARGSTR(I) .EQ. ' ' .OR. ARGSTR(I) .EQ. *9 .OR. ARGSTR(I) .EQ. 10 .OR. ARGSTR(I) .EQ. ',' .OR. ARGSTR(I) .E *Q. '/'))) GOTO 2820 J = J + 1 GOTO 2760 2770 CONTINUE IF (.NOT.(BEGSTR .EQ. 1 .AND. ARGSTR(I) .NE. '/' .AND. ARGSTR(I) . *NE. 10)) GOTO 2890 I = I + 1 2890 CONTINUE CALL SCOPY(ARGSTR, I, ARGSTR, BEGSTR) RETURN END C chkarg - put out error message if spurious argument on cmd line SUBROUTINE CHKARG(N) INTEGER N, GTARG2, I, LENGTH COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD DO 2910 I = 1, N - 1 CALL DELARG(1) 2910 CONTINUE IF (.NOT.(GTARG2(1, I, 1) .NE. -10)) GOTO 2930 ARGSTR(LENGTH(ARGSTR)) = 0 CALL PUTLIN(ARGSTR, 3) CALL REMARK(': ignored') 2930 CONTINUE RETURN END C savarg - save current command line SUBROUTINE SAVARG(BUF) BYTE BUF(1) COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD CALL SCOPY(ARGSTR, 1, BUF, 1) RETURN END C rstarg - restore current command line SUBROUTINE RSTARG(BUF) BYTE BUF(1) COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD CALL SCOPY(BUF, 1, ARGSTR, 1) RETURN END C upcmd - reset fold commands to upper case flag SUBROUTINE UPCMD(FLAG) LOGICAL FLAG COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD UPFLAG = FLAG RETURN END C doredr -- do any redirection of std files required SUBROUTINE DOREDR BYTE BUF(134), OPNTYP INTEGER I, K, IER INTEGER GTARG2, INDEXX COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD CALL SCOPY(ARGSTR, 1, BUF, 1) K = 1 I = 1 2950 IF (.NOT.(BUF(I) .NE. 0)) GOTO 2970 IF (.NOT.(K .GT. 134-3)) GOTO 2980 CALL ERROR('command line overflow in doredr.') 2980 CONTINUE IF (.NOT.(INDEXX('<>?', BUF(I)) .NE. 0)) GOTO 3000 ARGSTR(K) = ' ' K = K + 1 IF (.NOT.((BUF(I) .EQ. '>' .AND. BUF(I+1) .EQ. '>') .OR. (BUF( *I) .EQ. '?' .AND. BUF(I+1) .EQ. '?'))) GOTO 3020 ARGSTR(K) = BUF(I) K = K + 1 I = I + 1 3020 CONTINUE 3000 CONTINUE ARGSTR(K) = BUF(I) K = K + 1 2960 I = I + 1 GOTO 2950 2970 CONTINUE ARGSTR(K) = 0 I = 1 3040 IF (.NOT.(GTARG2(I,BUF,134) .NE. -10)) GOTO 3060 IF (.NOT.(BUF(1) .EQ. '<')) GOTO 3070 CALL SCOPY(BUF, 2, BUF, 1) CALL OPNSTD(BUF, 5, 'R', 'TI:', 'F') CALL DELARG(I) GOTO 3080 3070 CONTINUE IF (.NOT.(BUF(1) .EQ. '>')) GOTO 3090 K = 2 OPNTYP = 'W' IF (.NOT.(BUF(2) .EQ. '>')) GOTO 3110 K = 3 OPNTYP = 'A' 3110 CONTINUE CALL SCOPY(BUF, K, BUF, 1) CALL OPNSTD(BUF, 2, OPNTYP, 'TI:', 'W') CALL DELARG(I) GOTO 3080 3090 CONTINUE IF (.NOT.(BUF(1) .EQ. '?')) GOTO 3130 K = 2 OPNTYP = 'W' IF (.NOT.(BUF(2) .EQ. '?')) GOTO 3150 K = 3 OPNTYP = 'A' 3150 CONTINUE CALL SCOPY(BUF, K, BUF, 1) CALL OPNSTD(BUF, 3, OPNTYP, 'TI:', 'W') CALL DELARG(I) C no redirection, bump counter GOTO 3080 3130 CONTINUE I = I + 1 3080 CONTINUE 3050 GOTO 3040 3060 CONTINUE RETURN END C opnstd - close and reopen standard files SUBROUTINE OPNSTD(BUF, UNIT, ACCESS, STDFIL, STDACC) BYTE BUF(1), STDFIL(1), ACCESS, STDACC INTEGER UNIT, CLOSEC, IER COMMON/FCOMR/MXFILE, IOLEN, LASTC, TIIN, ACTUN(6), IOIN(134) INTEGER MXFILE INTEGER IOLEN INTEGER LASTC LOGICAL TIIN BYTE ACTUN BYTE IOIN IF (.NOT.(CLOSEC(UNIT, 'S') .NE. -1)) GOTO 3170 IF (.NOT.(BUF(1) .EQ. 0)) GOTO 3190 C redirect back to standard file CALL OPN(UNIT, STDFIL, STDACC, IER) IF (.NOT.(IER .NE. 0)) GOTO 3210 CALL PUTLIN(STDFIL, 3) CALL ERROR(': can''t open in opnstd.') GOTO 3220 3210 CONTINUE IF (.NOT.(UNIT .EQ. 5)) GOTO 3230 C reading from terminal TIIN = .TRUE. 3230 CONTINUE 3220 CONTINUE GOTO 3200 3190 CONTINUE CALL DEFNAM(BUF, 0, 'SY:', 0, 0, '.', .FALSE.) CALL OPN(UNIT, BUF, ACCESS, IER) IF (.NOT.(IER .NE. 0)) GOTO 3250 CALL OPN(UNIT, STDFIL, STDACC, IER) IF (.NOT.(IER .NE. 0)) GOTO 3270 CALL PUTLIN(STDFIL, 3) CALL ERROR(': can''t open in opnstd.') GOTO 3280 3270 CONTINUE IF (.NOT.(UNIT .EQ. 5)) GOTO 3290 C reading from terminal TIIN = .TRUE. 3290 CONTINUE 3280 CONTINUE CALL PUTLIN(BUF, 3) CALL ERROR(': can''t open.') GOTO 3260 3250 CONTINUE IF (.NOT.(UNIT .EQ. 5)) GOTO 3310 C not reading from terminal TIIN = .FALSE. 3310 CONTINUE 3260 CONTINUE 3200 CONTINUE 3170 CONTINUE RETURN END C gcmdln - export version of gcmdln with no indirect command files SUBROUTINE GCMDLN(LUN, IDUM, PROMPT, BUF, LEN, MAXL, SOURCE) INTEGER LUN, IDUM, LEN, MAXL, SOURCE, IER BYTE PROMPT(1), BUF(1) COMMON/GCMD01/FIRST, OLDSRC LOGICAL FIRST INTEGER OLDSRC DATA FIRST/.TRUE./, OLDSRC/0/ IF (.NOT.(OLDSRC .LT. 0)) GOTO 3330 C emulate dummy EOF SOURCE = OLDSRC LEN = - 10 OLDSRC = 0 RETURN 3330 CONTINUE IF (.NOT.(FIRST)) GOTO 3350 FIRST = .FALSE. CALL OPN(LUN, 'TI:', 'R', IER) IF (.NOT.(IER .NE. 0)) GOTO 3370 CALL ERROR('can''t open CMDIN.') 3370 CONTINUE 3350 CONTINUE CALL GCMD(LUN, PROMPT, BUF, LEN, MAXL, SOURCE) OLDSRC = SOURCE RETURN END C reccml - stub for IAS specific receive timesharing message SUBROUTINE RECCML(BUF, LEN) BYTE BUF(1) INTEGER LEN LEN = - 80 RETURN END