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 XEQ C === C C C Author: William Wood C Computer Center C Institute For Cancer Research C 7701 Burholme Ave. C Philadelphia, Pa. 19111 C (215) 728 2760 C C Version: 1.0 C C Date: June 2, 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 * 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 PROGRAM XEQ BYTE PROG(134) INTEGER I INTEGER PMATCH, GCMD, GTARG2, EQUAL C$ integer length CALL INITR4 IF (.NOT.(GCMD() .EQ. -10)) GOTO 2000 CALL ENDR4 2000 CONTINUE IF (.NOT.(GTARG2(1, PROG, 134) .EQ. -10)) GOTO 2020 CALL ENDR4 2020 CONTINUE C convert to upper case CALL UPPER(PROG) IF (.NOT.(PMATCH(PROG, '/SET_DEFAULTS') .EQ. 1)) GOTO 2040 CALL WHOZON(PROG, 0, 0, 0) CALL INIUSR(PROG, 2, .TRUE.) CALL LISTD GOTO 2050 2040 CONTINUE IF (.NOT.(PMATCH(PROG, '/APPEND') .EQ. 1)) GOTO 2060 CALL WHOZON(PROG, 0, 0, 0) CALL INIUSR(PROG, 2, .FALSE.) CALL LISTD C$ else if (equal(prog, '/UPDATE') == YES) { C$ if (gtarg2(2, prog, 13) ~= EOF) { C$ do i = length(prog)+1, 13 C$ prog(i) = EOS C$ call iniusr(prog, 3, .true.) C$ } C$ } C$ else if (equal(prog, '/UPDATE_APPEND') == YES) { C$ if (gtarg2(2, prog, 13) ~= EOF) { C$ do i = length(prog)+1, 13 C$ prog(i) = EOS C$ call iniusr(prog, 3, .false.) C$ } C$ } GOTO 2050 2060 CONTINUE IF (.NOT.(PMATCH(PROG, '/LIST') .EQ. 1)) GOTO 2080 CALL LISTD GOTO 2050 2080 CONTINUE IF (.NOT.(EQUAL(PROG, '/PEEK') .EQ. 1)) GOTO 2100 CALL PEEK GOTO 2050 2100 CONTINUE CALL RUNPRG(PROG) 2050 CONTINUE CALL ENDR4 END C runprg - search for and run the program SUBROUTINE RUNPRG(PROG) BYTE PROG(1), TSK(134), USER(12), ARGS(134) INTEGER ISFILE, MAKTSK, LENGTH, LOOKUP INTEGER I, USRIND COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST CALL DELARG(1) CALL SAVARG(ARGS) C delete NEWLINE ARGS(LENGTH(ARGS)) = 0 CALL DEFNAM(PROG, 0, 0, 0, 0, '.TSK', .FALSE.) CALL WHOZON(USER, 0, 0, 0) USRIND = LOOKUP(USER) I = DLIST(USRIND) 2120 IF (.NOT.(MAKTSK(PROG,TSK,I) .EQ. 1)) GOTO 2140 IF (.NOT.(ISFILE(TSK) .EQ. 1)) GOTO 2150 CALL CHAINR(TSK, ARGS) RETURN 2150 CONTINUE 2130 I = DLIST(I) GOTO 2120 2140 CONTINUE CALL PUTLIN(PROG, 3) CALL ERROR(': can''t run.') RETURN END C iniusr - insert new search directories SUBROUTINE INIUSR(USER, NN, FLAG) BYTE USER(12), DIR(134) INTEGER DIRIND, USRIND, N, J, NN, DSAVE INTEGER GTARG2, INITD, LOOKUP LOGICAL FLAG COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST USRIND = LOOKUP(USER) IF (.NOT.(FLAG)) GOTO 2170 DIRIND = DLIST(USRIND) 2190 IF (.NOT.(DIRIND .NE. 0)) GOTO 2210 DSAVE = DLIST(DIRIND) DLIST(DIRIND) = - 1 2200 DIRIND = DSAVE GOTO 2190 2210 CONTINUE DLIST(USRIND) = 0 DIRIND = USRIND GOTO 2180 2170 CONTINUE DSAVE = USRIND 2220 IF (.NOT.(DSAVE .NE. 0)) GOTO 2240 DIRIND = DSAVE 2230 DSAVE = DLIST(DSAVE) GOTO 2220 2240 CONTINUE 2180 CONTINUE N = NN 2250 IF (.NOT.(GTARG2(N,DIR,134) .NE. -10)) GOTO 2270 IF (.NOT.(INITD(DIR, DLIST(DIRIND)) .NE. -1)) GOTO 2280 DIRIND = DLIST(DIRIND) 2280 CONTINUE 2260 N = N + 1 GOTO 2250 2270 CONTINUE RETURN END C listd - list the default directories for this user SUBROUTINE LISTD BYTE USER(12), DIR(15) INTEGER USRIND, DIRIND INTEGER LOOKUP COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST CALL WHOZON(USER, 0, 0, 0) USRIND = LOOKUP(USER) DIRIND = DLIST(USRIND) 2300 IF (.NOT.(DIRIND .NE. 0)) GOTO 2320 CALL GETDIR(DIR, DIRIND) CALL OUTLIN(DIR, 2) 2310 DIRIND = DLIST(DIRIND) GOTO 2300 2320 CONTINUE RETURN END C peek - see what's what in XEQCOM SUBROUTINE PEEK BYTE DIR(15), USRNUM(4), USER(13), OUTFIL(34) INTEGER USRIND, DIRIND, I, F INTEGER ITOCRJ, OPENC, GTARG2 COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST IF (.NOT.(GTARG2(2, OUTFIL, 34) .EQ. -10)) GOTO 2330 F = 2 GOTO 2340 2330 CONTINUE F = OPENC(OUTFIL, 'W') IF (.NOT.(F .EQ. -1)) GOTO 2350 RETURN 2350 CONTINUE 2340 CONTINUE DO 2370 USRIND = 1, 256 IF (.NOT.(USERS(1, USRIND) .NE. 0)) GOTO 2390 I = ITOCRJ(USRIND, USRNUM, 4) CALL PUTLIN(USRNUM, F) CALL PUTLIN('> ', F) DO 2410 I = 1, 12 USER(I) = USERS(I, USRIND) 2410 CONTINUE USER(13) = 0 CALL PUTLIN(USER, F) DIRIND = DLIST(USRIND) 2430 IF (.NOT.(DIRIND .NE. 0)) GOTO 2450 CALL GETDIR(DIR, DIRIND) CALL PUTLIN(' ', F) CALL PUTLIN(DIR, F) 2440 DIRIND = DLIST(DIRIND) GOTO 2430 2450 CONTINUE CALL PUTCH(10, F) 2390 CONTINUE 2370 CONTINUE IF (.NOT.(F .NE. 2)) GOTO 2460 CALL CLOSEC(F, 'S') 2460 CONTINUE RETURN END C lookup - lookup user's search path index INTEGER FUNCTION LOOKUP(USER) BYTE USER(12), OFFSET INTEGER I, START, J INTEGER INITD COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST DATA OFFSET/'A'/ START = USER(1) - OFFSET START = 10*START + 1 I = START 2480 CONTINUE J = 1 2510 IF (.NOT.(J .LE. 12)) GOTO 2530 IF (.NOT.(USER(J) .NE. USERS(J, I))) GOTO 2540 GOTO 2530 2540 CONTINUE 2520 J = J + 1 GOTO 2510 2530 CONTINUE IF (.NOT.(J .GT. 12)) GOTO 2560 LOOKUP = I RETURN 2560 CONTINUE I = MOD(I, 256) + 1 2490 IF (.NOT.(I .EQ. START)) GOTO 2480 2580 CONTINUE C user not found - new user IF (.NOT.(USERS(1, I) .EQ. 0)) GOTO 2610 GOTO 2600 2610 CONTINUE I = MOD(I, 256) + 1 IF (.NOT.(I .EQ. START)) GOTO 2630 CALL ERROR('XEQ -- MAXIMUM NUMBER OF USERS EXCEEDED - CONTACT *SYSTEM MANAGER!!') 2630 CONTINUE 2590 GOTO 2580 2600 CONTINUE C insert user in XEQCOM DO 2650 J = 1, 12 USERS(J, I) = USER(J) 2650 CONTINUE J = INITD('SY:', DLIST(I)) J = INITD('LB:[22,2]', DLIST(DLIST(I))) LOOKUP = I RETURN END C maktsk - build up a task name INTEGER FUNCTION MAKTSK(PROG, TSK, DIRIND) BYTE PROG(1), TSK(1) INTEGER DIRIND, I INTEGER CONCAT, INDEX LOGICAL FIRST COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST DATA FIRST/.TRUE./ MAKTSK = 0 IF (.NOT.(INDEX(PROG, ':') .NE. 0)) GOTO 2670 IF (.NOT.(FIRST)) GOTO 2690 CALL SCOPY(PROG, 1, TSK, 1) MAKTSK = 1 2690 CONTINUE GOTO 2680 2670 CONTINUE IF (.NOT.(DIRIND .EQ. 0)) GOTO 2710 GOTO 2680 2710 CONTINUE CALL GETDIR(TSK, DIRIND) I = CONCAT(TSK, PROG, 134) MAKTSK = 1 2680 CONTINUE FIRST = .FALSE. RETURN END C initd - insert new search directory in XEQCOM INTEGER FUNCTION INITD(DIR, DIRIND) BYTE DIR(1), TDIR(15) INTEGER DIRIND, I INTEGER ASCW50, LENGTH INTEGER*2W50DIR(5) COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST DIRIND = 0 I = LENGTH(DIR) IF (.NOT.(I .GT. 14)) GOTO 2730 CALL PUTLIN(DIR, 3) CALL REMARK(': search directory too long.') INITD = - 1 RETURN 2730 CONTINUE CALL SCOPY(DIR, 1, TDIR, 1) CALL UPPER(TDIR) I = I + 1 2750 IF (.NOT.(I .LE. 14)) GOTO 2770 C pad with ',' TDIR(I) = ',' 2760 I = I + 1 GOTO 2750 2770 CONTINUE IF (.NOT.(ASCW50(14, TDIR, W50DIR) .EQ. -1)) GOTO 2780 CALL PUTLIN(DIR, 3) CALL REMARK(': illegal character in search directory.') INITD = - 1 GOTO 2790 2780 CONTINUE DIRIND = 256 + 1 2800 IF (.NOT.(DIRIND .LE. 380+256)) GOTO 2820 IF (.NOT.(DLIST(DIRIND) .EQ. -1)) GOTO 2830 GOTO 2820 2830 CONTINUE 2810 DIRIND = DIRIND + 1 GOTO 2800 2820 CONTINUE IF (.NOT.(DIRIND .GT. 380+256)) GOTO 2850 DIRIND = 0 CALL ERROR('XEQ -- TOO MANY DIRECTORY ENTRIES - CONTACT SYSTEM * MANAGER!!') 2850 CONTINUE DO 2870 I = 1, 5 DIRECT(I, DIRIND - 256) = W50DIR(I) 2870 CONTINUE DLIST(DIRIND) = 0 INITD = 1 2790 CONTINUE RETURN END C getdir - get a directory entry SUBROUTINE GETDIR(DIR, DIRIND) BYTE DIR(1) INTEGER DIRIND, I INTEGER W50ASC COMMON/XEQCOM/USERS(12, 256), DIRECT(5, 380), DLIST(256 + 380) BYTE USERS INTEGER*2DIRECT INTEGER*2DLIST IF (.NOT.(W50ASC(14, DIRECT(1, DIRIND-256), DIR) .EQ. -1)) GOTO 28 *90 CALL ERROR('XEQ -- BAD DIRECTORY ENTRY') 2890 CONTINUE I = 14 2910 IF (.NOT.(I .GT. 0)) GOTO 2930 C unpad IF (.NOT.(DIR(I) .NE. ',')) GOTO 2940 GOTO 2930 2940 CONTINUE 2920 I = I - 1 GOTO 2910 2930 CONTINUE DIR(I + 1) = 0 RETURN END C C the restricted char set used here is: C A-Z C 0-9 C :[], C C ascw50 - convert from ascii to restricted char set INTEGER FUNCTION ASCW50(N, ASCBUF, W50BUF) BYTE ASCBUF(1), ASC INTEGER N, NW50, IASC, IW50, I INTEGER*2INT2, W50BUF(1), W50I2 INTEGER*4INT4, EXP50(3) EQUIVALENCE(INT2, INT4) DATA EXP50/1600, 40, 1/ NW50 = (N + 2)/3 IF (.NOT.(NW50 .LE. 0)) GOTO 2960 ASCW50 = - 1 GOTO 2970 2960 CONTINUE IASC = 0 DO 2980 IW50 = 1, NW50 INT4 = 0 DO 3000 I = 1, 3 IF (.NOT.(I+IASC .GT. N)) GOTO 3020 GOTO 3010 3020 CONTINUE ASC = ASCBUF(I + IASC) IF (.NOT.(ASC .GE. 'A' .AND. ASC .LE. 'Z')) GOTO 3040 W50I2 = ASC - 'A' GOTO 3050 3040 CONTINUE IF (.NOT.(ASC .GE. '0' .AND. ASC .LE. '9')) GOTO 3060 W50I2 = (ASC - '0') + 26 GOTO 3050 3060 CONTINUE IF (.NOT.(ASC .EQ. ',')) GOTO 3080 W50I2 = 36 GOTO 3050 3080 CONTINUE IF (.NOT.(ASC .EQ. ':')) GOTO 3100 W50I2 = 37 GOTO 3050 3100 CONTINUE IF (.NOT.(ASC .EQ. '[')) GOTO 3120 W50I2 = 38 GOTO 3050 3120 CONTINUE IF (.NOT.(ASC .EQ. ']')) GOTO 3140 W50I2 = 39 GOTO 3050 3140 CONTINUE ASCW50 = - 1 RETURN 3050 CONTINUE INT4 = INT4 + (W50I2*EXP50(I)) 3000 CONTINUE 3010 CONTINUE W50BUF(IW50) = INT2 IASC = IASC + 3 2980 CONTINUE ASCW50 = 1 2970 CONTINUE RETURN END C w50asc - convert from restricted char set to ascii INTEGER FUNCTION W50ASC(N, W50BUF, ASCBUF) BYTE ASCBUF(1), CHRBUF(4) INTEGER N, NW50, IASC, IW50, I INTEGER*2W50BUF(1), INT2, W50I2 INTEGER*4INT4, EXP50(3) EQUIVALENCE(INT2, INT4) DATA EXP50/1600, 40, 1/ DATA CHRBUF/',', ':', '[', ']'/ NW50 = (N + 2)/3 IF (.NOT.(NW50 .LE. 0)) GOTO 3160 W50ASC = - 1 GOTO 3170 3160 CONTINUE IASC = 0 DO 3180 IW50 = 1, NW50 INT4 = 0 INT2 = W50BUF(IW50) IF (.NOT.(INT4 .GE. 64000)) GOTO 3200 W50ASC = - 1 RETURN 3200 CONTINUE DO 3220 I = 1, 3 IF (.NOT.(I+IASC .GT. N)) GOTO 3240 GOTO 3230 3240 CONTINUE W50I2 = INT4/EXP50(I) INT4 = INT4 - (W50I2*EXP50(I)) IF (.NOT.(W50I2 .GE. 0 .AND. W50I2 .LE. 25)) GOTO 3260 ASCBUF(I + IASC) = W50I2 + 'A' GOTO 3270 3260 CONTINUE IF (.NOT.(W50I2 .GE. 26 .AND. W50I2 .LE. 35)) GOTO 3280 ASCBUF(I + IASC) = (W50I2 - 26) + '0' GOTO 3270 3280 CONTINUE ASCBUF(I + IASC) = CHRBUF(W50I2 - 35) 3270 CONTINUE 3220 CONTINUE 3230 CONTINUE IASC = IASC + 3 3180 CONTINUE W50ASC = 1 3170 CONTINUE RETURN END C chainr - chain to tsk, sending msg to chained task SUBROUTINE CHAINR(TSK, MSG) BYTE TSK(1), MSG(1) BYTE TTSK(134), TMSG(134), BMSG(3), BTSK(2) INTEGER LENGTH INTEGER*2MLEN EQUIVALENCE(TMSG(1), BMSG(3)), (MLEN, BMSG(1)) EQUIVALENCE(TTSK(1), BTSK(2)) DATA BTSK(1)/' '/ CALL SCOPY(TSK, 1, TTSK, 1) CALL SCOPY(MSG, 1, TMSG, 1) MLEN = LENGTH(MSG) IF (.NOT.(MLEN .EQ. 0)) GOTO 3300 CALL CHAIN(BTSK) GOTO 3310 3300 CONTINUE CALL CHAIN(BTSK, BMSG) 3310 CONTINUE RETURN END C isfile - see if file exists INTEGER FUNCTION ISFILE(FILE) BYTE FILE(1) INTEGER OPEN, CLOSEL INTEGER JUNK, F F = OPEN(FILE, 'R') IF (.NOT.(F .NE. -1)) GOTO 3320 JUNK = CLOSEL(F, 'S') ISFILE = 1 GOTO 3330 3320 CONTINUE ISFILE = 0 3330 CONTINUE RETURN END C gcmd - get a command line INTEGER FUNCTION GCMD() BYTE CMDLIN(134) INTEGER NC, I INTEGER INDEX GCMD = - 10 CALL GETMCR(CMDLIN, NC) IF (.NOT.(NC .GE. 0)) GOTO 3340 CMDLIN(NC + 1) = 10 CMDLIN(NC + 2) = 0 I = INDEX(CMDLIN, ' ') IF (.NOT.(I .NE. 0)) GOTO 3360 CALL RSTARG(CMDLIN(I + 1)) GCMD = 1 3360 CONTINUE 3340 CONTINUE RETURN END