C C C C C C maximum field for integer strings C max card size C must be 2 more than MAXCARD C C must be highest lu for standard files C C C C C gcmd - get command line from MCR, TS, 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 C$define(MESSAGE,-1) 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 2000 FIRST = .FALSE. CALL GETMCR(BUF, LEN) IF (.NOT.(LEN .GT. 0)) GOTO 2020 SOURCE = - 2 I = 1 2040 IF (.NOT.(I .LT. LEN)) GOTO 2060 IF (.NOT.(BUF(I) .EQ. ' ')) GOTO 2070 GOTO 2060 2070 CONTINUE 2050 I = I + 1 GOTO 2040 2060 CONTINUE J = I I = I + 1 2090 IF (.NOT.(I .LE. LEN)) GOTO 2110 BUF(I - J) = BUF(I) 2100 I = I + 1 GOTO 2090 2110 CONTINUE LEN = LEN - J C$ else { C$ call reccml(buf, len) C$ source = MESSAGE C$ } 2020 CONTINUE 2000 CONTINUE IF (.NOT.(LEN .LE. 0)) GOTO 2120 SOURCE = 0 IF (.NOT.(LUN .EQ. 0)) GOTO 2140 LEN = - 10 GOTO 2150 2140 CONTINUE 2160 CONTINUE CALL READPR(LUN, PROMPT, BUF, LEN, MAXLEN - 1, JUNK) 2170 IF (.NOT.(LEN .GE. 0 .OR. LEN .EQ. -10)) GOTO 2160 2180 CONTINUE 2150 CONTINUE 2120 CONTINUE BUF(MAX0(1, MIN0(MAXLEN, LEN + 1))) = 0 RETURN END C cmdget - get a line with prompt from CMDIN INTEGER FUNCTION CMDGET(BUF, PROMPT, SOURCE) BYTE BUF(1), PROMPT(1) INTEGER NC, SOURCE 2190 CONTINUE CALL GCMD(4, PROMPT, BUF, NC, 134 - 1, SOURCE) IF (.NOT.(NC .LT. 0 .AND. NC .NE. -10)) GOTO 2220 CALL REMARK('error reading command line.') GOTO 2230 2220 CONTINUE GOTO 2210 2230 CONTINUE 2200 GOTO 2190 2210 CONTINUE IF (.NOT.(NC .EQ. -10)) GOTO 2240 CMDGET = - 10 BUF(1) = - 10 BUF(2) = 0 GOTO 2250 2240 CONTINUE CMDGET = NC + 1 BUF(CMDGET) = 13 BUF(CMDGET + 1) = 0 2250 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. 2260 CONTINUE NC = CMDGET(ARGSTR, PROMPT, SOURCE) IF (.NOT.(NC .EQ. -10 .OR. NC .EQ. 1)) GOTO 2290 GOTO 2280 2290 CONTINUE CALL DOREDR 2270 IF (.NOT.(ARGSTR(1) .NE. 13)) GOTO 2260 2280 CONTINUE RETURN END C getarg -- interface to gtarg2 with read if none done already INTEGER FUNCTION GETARG(N, STRING, SIZE) INTEGER N, SIZE BYTE STRING(1) INTEGER GTARG2 COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD IF (.NOT.(NOREAD)) GOTO 2310 CALL GCLIN('> ', SOURCE) 2310 CONTINUE GETARG = GTARG2(N, STRING, SIZE) RETURN END C gtarg2 -- get the n-th argument and return its length or EOF INTEGER FUNCTION GTARG2(N, STRING, SIZE) INTEGER N, SIZE, SOURCE BYTE STRING(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. 2330 IF (.NOT.(J .LT. N)) GOTO 2340 2350 IF (.NOT.(ARGSTR(I) .EQ. ' ' .OR. ARGSTR(I) .EQ. 9 .OR. ARGSTR(I *) .EQ. ',')) GOTO 2360 I = I + 1 GOTO 2350 2360 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. -10 .OR. ARGSTR(I) .EQ. 13)) GOTO 2370 STRING(1) = ARGSTR(I) GTARG2 = - 10 RETURN 2370 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. '/')) GOTO 2390 STRING(1) = '/' K = 1 GOTO 2400 2390 CONTINUE K = 0 2400 CONTINUE 2410 CONTINUE K = K + 1 M = I + K - 1 IF (.NOT.(K .LT. SIZE)) GOTO 2440 STRING(K) = ARGSTR(M) 2440 CONTINUE IF (.NOT.(ARGSTR(M) .EQ. 91)) GOTO 2460 LB = .TRUE. GOTO 2470 2460 CONTINUE IF (.NOT.(ARGSTR(M) .EQ. 93)) GOTO 2480 LB = .FALSE. 2480 CONTINUE 2470 CONTINUE 2420 IF (.NOT.(.NOT.LB .AND. (ARGSTR(M) .EQ. ' ' .OR. ARGSTR(M) .EQ *. 9 .OR. ARGSTR(M) .EQ. 13 .OR. ARGSTR(M) .EQ. ',' .OR. ARGSTR(M) *.EQ. '/'))) GOTO 2410 2430 CONTINUE STRING(MIN0(K, SIZE)) = 0 I = M J = J + 1 GOTO 2330 2340 CONTINUE GTARG2 = MIN0(K, SIZE) IF (.NOT.(UPFLAG)) GOTO 2500 CALL UPPER(STRING) 2500 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. 2520 IF (.NOT.(J .LT. N)) GOTO 2530 BEGSTR = I 2540 IF (.NOT.(ARGSTR(I) .EQ. ' ' .OR. ARGSTR(I) .EQ. 9 .OR. ARGSTR(I *) .EQ. ',')) GOTO 2550 I = I + 1 GOTO 2540 2550 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. -10 .OR. ARGSTR(I) .EQ. 13)) GOTO 2560 RETURN 2560 CONTINUE 2580 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. 91)) GOTO 2610 LB = .TRUE. GOTO 2620 2610 CONTINUE IF (.NOT.(ARGSTR(I) .EQ. 93)) GOTO 2630 LB = .FALSE. 2630 CONTINUE 2620 CONTINUE I = I + 1 2590 IF (.NOT.(.NOT.LB .AND. (ARGSTR(I) .EQ. ' ' .OR. ARGSTR(I) .EQ *. 9 .OR. ARGSTR(I) .EQ. 13 .OR. ARGSTR(I) .EQ. ',' .OR. ARGSTR(I) *.EQ. '/'))) GOTO 2580 2600 CONTINUE J = J + 1 GOTO 2520 2530 CONTINUE IF (.NOT.(BEGSTR .EQ. 1 .AND. ARGSTR(I) .NE. '/' .AND. ARGSTR(I) . *NE. 13)) GOTO 2650 I = I + 1 2650 CONTINUE CALL SCOPY(ARGSTR, I, ARGSTR, BEGSTR) RETURN END C doredr -- do any redirection of std files required SUBROUTINE DOREDR BYTE BUF(134), OPNTYP INTEGER I, K, IER INTEGER GTARG2, INDEX COMMON/CARG/ARGSTR(134), UPFLAG, NOREAD BYTE ARGSTR LOGICAL UPFLAG, NOREAD CALL SCOPY(ARGSTR, 1, BUF, 1) K = 1 I = 1 2670 IF (.NOT.(BUF(I) .NE. 0)) GOTO 2690 IF (.NOT.(K .GT. 134-3)) GOTO 2700 CALL ERROR('command line overflow in doredr.') 2700 CONTINUE IF (.NOT.(INDEX('<>?', BUF(I)) .NE. 0)) GOTO 2720 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 2740 ARGSTR(K) = BUF(I) K = K + 1 I = I + 1 2740 CONTINUE 2720 CONTINUE ARGSTR(K) = BUF(I) K = K + 1 2680 I = I + 1 GOTO 2670 2690 CONTINUE ARGSTR(K) = 0 I = 1 2760 IF (.NOT.(GTARG2(I,BUF,134) .NE. -10)) GOTO 2780 IF (.NOT.(BUF(1) .EQ. '<')) GOTO 2790 CALL SCOPY(BUF, 2, BUF, 1) CALL OPNSTD(BUF, 5, 'R', 'TI:', 'F') CALL DELARG(I) GOTO 2800 2790 CONTINUE IF (.NOT.(BUF(1) .EQ. '>')) GOTO 2810 K = 2 OPNTYP = 'W' IF (.NOT.(BUF(2) .EQ. '>')) GOTO 2830 K = 3 OPNTYP = 'A' 2830 CONTINUE CALL SCOPY(BUF, K, BUF, 1) CALL OPNSTD(BUF, 2, OPNTYP, 'TI:', 'W') CALL DELARG(I) GOTO 2820 2810 CONTINUE IF (.NOT.(BUF(1) .EQ. '?')) GOTO 2850 K = 2 OPNTYP = 'W' IF (.NOT.(BUF(2) .EQ. '?')) GOTO 2870 K = 3 OPNTYP = 'A' 2870 CONTINUE CALL SCOPY(BUF, K, BUF, 1) CALL OPNSTD(BUF, 3, OPNTYP, 'TI:', 'W') CALL DELARG(I) GOTO 2860 2850 CONTINUE C no redirection, bump counter I = I + 1 2860 CONTINUE 2820 CONTINUE 2800 CONTINUE 2770 GOTO 2760 2780 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, ACTUN(6) BYTE ACTUN INTEGER MXFILE COMMON/FCOMR2/TIIN LOGICAL TIIN IF (.NOT.(CLOSEC(UNIT, 'S') .NE. -1)) GOTO 2890 IF (.NOT.(BUF(1) .EQ. 0)) GOTO 2910 C redirect back to standard file CALL OPN(UNIT, STDFIL, STDACC, IER) IF (.NOT.(IER .NE. 0)) GOTO 2930 CALL PUTLIN(STDFIL, 3) CALL ERROR(': can''t open in opnstd.') GOTO 2940 2930 CONTINUE IF (.NOT.(UNIT .EQ. 5)) GOTO 2950 C reading from terminal TIIN = .TRUE. 2950 CONTINUE 2940 CONTINUE GOTO 2920 2910 CONTINUE CALL DEFNAM(BUF, 'SY:', 0, 0) CALL OPN(UNIT, BUF, ACCESS, IER) IF (.NOT.(IER .NE. 0)) GOTO 2970 CALL OPN(UNIT, STDFIL, STDACC, IER) IF (.NOT.(IER .NE. 0)) GOTO 2990 CALL PUTLIN(STDFIL, 3) CALL ERROR(': can''t open in opnstd.') GOTO 3000 2990 CONTINUE IF (.NOT.(UNIT .EQ. 5)) GOTO 3010 C reading from terminal TIIN = .TRUE. 3010 CONTINUE 3000 CONTINUE CALL PUTLIN(BUF, 3) CALL REMARK(': can''t open.') GOTO 2980 2970 CONTINUE IF (.NOT.(UNIT .EQ. 5)) GOTO 3030 C not reading from terminal TIIN = .FALSE. 3030 CONTINUE 2980 CONTINUE 2920 CONTINUE 2890 CONTINUE RETURN END