C***************************************************************** C C Program : U C L (User Command Language) C C Author : H. Reints C AKZO PHARMA bv, Oss, Netherlands C dept. SDA C C Date : 05-Sep-85 C C Compilation : FORTRAN/NOSWAP/EXTEND[/ONDEBUG] UCL C Linking : LINK/BOTTOM:2000/EXECUTE:SY: UCL,SY:(SYSLIB,FORSIM) C C Description : When UCL is run normally, the current user C command definitions are listed on the terminal. C When UCL is chained by KMON, the command line passed to UCL is C treated as a command definition when "==" is found in the line, C or as an executable command when not. Defining commands is done C by typing "COMMAND==xxxxxx". Spaces and tabs are treated as word C separators. Deleting a command is done by typing "COMMAND==". C When a command is deleted or redefined, UCL prompts for C confirmation unless the "==" is immediately followed by a "*". C In the command definition, some special symbols can be used: "#" C will be replaced by "@", "`" is a command separator, "^$" will C be replaced by the entire actual command line, "^*" by the C command line except the first word, and "^N" (0 =< N =< 9) will C be replaced by the Nth word of the actual command line ("^0" is C the command itself). When passing a parameter, "-" and "&" are C replaced by a space or tab respectively. When the very first C character of the expansion is a double quote ("), the expansion C will be typed on the terminal instead of being passed to KMON. C In that case, the reversed quote (`) is a line separator. In C each line, the first character is treated as a FORTRAN vertical C format controller. The underscore character (_) can be used to C ignore the meaning of these special characters except the VFC, C thus being a special character too. Every time when the commands C are listed, the data file SY:UCL.DAT is renamed to SY:UCLBAK.DAT C and when a command is defined or deleted, the file is renamed to C SY:UCLOLD.DAT, and a new data file is created. All commands will C be alphabetized before being written into the data file. A C defining command line may contain up to 80 characters and will C be stored in SY:UCL.DAT exactly as typed, thus making the data C file a normal ASCII file, which can be edited. Executing a C command can be done by typing the first few characters, as much C as are necessary to uniquely distinguish it from other commands. C When UCL is compiled with /ONDEBUG, invalid UCL command lines C are passed to KMON with a preceding at sign (@), thus trying to C invoke an indirect command file; without /ONDEBUG, a fatal error C message will be generated if the command line is invalid. C C***************************************************************** PROGRAM UCL C BYTE ERR BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA LCMD,NCMD,MAX,CMD,UCLDAT,ERR /0,0,60,82*0,4920*0,0/ DATA DATFIL /'S','Y',':','U','C','L','.','D','A','T',6*0/ DATA RENAME /12RSY UCL DAT,12RSY UCLBAKDAT,12RSY UCLOLDDAT/ DATA IWMSG,IBLKEY /0,"256/ C CALL UCLCHN(ICHAIN) C CALL LOCK ! Get exclusive use of the USR and force to read CALL IPUT(IBLKEY,0) ! directory segment, see SSM 2.2.3.2(5.) C C This code is necessary because UCL sometimes cannot open C the data file when it is chained, because some channels DO 10, ICHAN=0,15 ! are already open for some CALL CLOSEC(ICHAN+0) ! obscure reason (?). It may for CALL IFREEC(ICHAN+0) ! example occur when a program is 10 CONTINUE ! aborted with ^C^C. C OPEN(UNIT=1,NAME=DATFIL,TYPE='OLD',READONLY,ERR=40) NCMD=1 30 CONTINUE CALL GETSTR(1,UCLDAT(1,NCMD),80,ERR) IF (UCLDAT(1,NCMD).NE.0) NCMD=NCMD+1 IF (ERR.EQ.0.AND.NCMD.LE.MAX) GOTO 30 CLOSE(UNIT=1) NCMD=NCMD-1 40 CONTINUE CALL UNLOCK C IF (NCMD.EQ.0) CALL UCLERR(1) IF (ICHAIN.NE.0) GOTO 50 CALL UCLALP CALL UCLLST(-1) GOTO 80 50 IF (INDEX(CMD,'==').EQ.0) GOTO 60 CALL UCLALP CALL UCLDEF CALL UCLLST(0) GOTO 70 60 CALL UCLEXE 70 CONTINUE 80 CONTINUE C CALL EXIT END ! UCL SUBROUTINE UCLALP C C This routine alphabetizes the user defined commands in the C UCLDAT buffer. Only the commands are alphabetized, not the C expansions. C BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG C DO 30, I=1,NCMD CALL UCLWRD(UCLDAT(1,I),0,W1,L1,-1) DO 20, J=I,NCMD CALL UCLWRD(UCLDAT(1,J),0,W2,L2,-1) IF (ISCOMP(W1,W2).LE.0) GOTO 10 CALL SCOPY(W2,W1) CALL SCOPY(UCLDAT(1,I),W2 ,80) CALL SCOPY(UCLDAT(1,J),UCLDAT(1,I),80) CALL SCOPY(W2 ,UCLDAT(1,J),80) 10 CONTINUE 20 CONTINUE 30 CONTINUE C RETURN END ! UCLALP SUBROUTINE UCLCHN(ICHAIN) C C This routine checks wether UCL is chained or not and C reads the command line from the chain area if chained. C BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA JSWADR,ICHBIT,LCHADR,ICHADR /"44,"400,"510,"512/ C JSW=IPEEK(JSWADR) ICHAIN=JSW.AND.ICHBIT JSW=JSW.AND.(.NOT.ICHBIT) CALL IPOKE(JSWADR,JSW) C IF (ICHAIN.EQ.0) GOTO 20 LCMD=MIN0(80,IPEEK(LCHADR)) J=ICHADR DO 10, I=1,LCMD CMD(I)=IPEEKB(J) J=J+1 10 CONTINUE CMD(LCMD+1)=0 CALL UCLTRM 20 CONTINUE C RETURN END ! UCLCHN SUBROUTINE UCLDEF C C This routine inserts new command definitions in the C UCLDAT buffer. It asks for a confimation if a previous C command definition will be deleted or overwritten, C unless the "==" is immediately followed by a "*". C BYTE ERR BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA INS,IQRY,IDEL /1,0,0/ C IDEF=INDEX(CMD,'==')+2 IF (CMD(IDEF).EQ.'*') IQRY=1 IF (CMD(IDEF+IQRY).EQ.0) IDEL=1 C IF (NCMD.EQ.0) GOTO 40 CALL UCLFND(ICMD) IF (ICMD.GT.0.AND.ICMD.LE.MAX) > CALL UCLQRY(ICMD,IQRY,IDEL) CONTINUE IF (IDEL.EQ.1) GOTO 30 IF (NCMD.GE.MAX) CALL UCLERR(2) CALL UCLWRD(CMD,0,W1,L1,-1) INS=0 10 CONTINUE INS=INS+1 CALL UCLWRD(UCLDAT(1,INS),0,W2,L2,-1) IF (ISCOMP(W1,W2).GE.0.AND.INS.LE.NCMD) GOTO 10 DO 20, I=NCMD,INS,-1 CALL SCOPY(UCLDAT(1,I),UCLDAT(1,I+1)) 20 CONTINUE 30 CONTINUE 40 CONTINUE C IF (IDEL.EQ.1) GOTO 80 NCMD=NCMD+1 I=1 IF (IQRY.EQ.1) CALL SCOPY(CMD(IDEF+IQRY),CMD(IDEF)) L=LEN(CMD)+1 50 IF (I.GT.L) GOTO 70 IF (I.LT.IDEF.OR.CMD(I).NE.'#') GOTO 60 IF (CMD(I-1).NE.'_') CMD(I)='@' 60 CONTINUE UCLDAT(I,INS)=CMD(I) I=I+1 GOTO 50 70 CONTINUE 80 CONTINUE C RETURN END ! UCLDEF SUBROUTINE UCLERR(I) C C This routine generates the fatal error messages C BYTE ERRSEV(12),ERR BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA ERRSEV /'W','F','F','F','F','W','F','W','F','W','W','W'/ DATA IERBYT,IWARN,IFATAL /"53,"2,"10/ C IF (I.NE.9) TYPE 1,ERRSEV(I) 1 FORMAT('$?UCL-',A1,'-') GOTO (10,20,30,40,50,60,70,80,90,100,110,120) I 10 CALL PUTSTR(7,'Data file empty or unavailable','+',ERR) IWMSG=-1 GOTO 1000 20 TYPE 21,MAX 21 FORMAT('+Exceeding maximum of ',I2,' UCL commands') GOTO 1000 30 CALL PUTSTR(7,'Multiple command definition','+',ERR) GOTO 1000 40 CALL PUTSTR(7,'Ambiguous abbreviation','+',ERR) GOTO 1000 50 CALL PUTSTR(7,'Invalid command','+',ERR) GOTO 1000 60 CALL PUTSTR(7,'Unable to rename old data file','+',ERR) GOTO 1000 70 CALL PUTSTR(7,'Unable to create new data file','+',ERR) GOTO 1000 80 CALL PUTSTR(7,'Data file initialized','+',ERR) GOTO 1000 90 CONTINUE ! no confirmation on query GOTO 1000 100 CALL PUTSTR(7,'Command redefined','+',ERR) GOTO 1000 110 CALL PUTSTR(7,'Command deleted','+',ERR) GOTO 1000 120 CALL PUTSTR(7,'Dirty word','+',ERR) IWMSG=-1 1000 CONTINUE C IUERR=IPEEKB(IERBYT) IF (ERRSEV(I).EQ.'W') IUERR=IUERR.OR.IWARN IF (ERRSEV(I).EQ.'F') IUERR=IUERR.OR.IFATAL CALL IPOKEB(IERBYT,IUERR) IF (ERRSEV(I).EQ.'F') CALL EXIT END ! UCLERR SUBROUTINE UCLEXE C C This routine expands the UCL command and passes the C expansion to KMON. C BYTE ERR BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA JSWADR,KMONCH,LCHADR,ICHADR /"44,"4040,"510,"512/ C CALL UCLFND(ICMD) IF (ICMD.EQ.-1) CALL UCLERR(3) IF (ICMD.EQ.-2) CALL UCLERR(4) IF (ICMD.GT.0) GOTO 40 C IF (D-lines not compiled) GOTO 20 D CALL IPOKEB(ICHADR,'@') D L=LEN(CMD)+1 D CALL IPOKE(LCHADR,L+1) D J=ICHADR+1 D DO 10, I=1,L D CALL IPOKEB(J,CMD(I)) D J=J+1 D10 CONTINUE D GOTO 30 20 CALL UCLERR(5) D30 CONTINUE GOTO 50 40 CALL UCLXPN(ICMD,NCHAR) CALL IPOKE(LCHADR,NCHAR) 50 CONTINUE C IF (NCHAR.LT.0) GOTO 60 IF (IWMSG.NE.0) CALL PUTSTR(7,' ',' ',ERR) JSW=IPEEK(JSWADR) CALL IPOKE(JSWADR,JSW.OR.KMONCH) GOTO 90 60 NCHAR=-NCHAR I=1 J=ICHADR DO 80, N=1,NCHAR W1(I)=IPEEKB(J) IF (W1(I).NE.0) GOTO 70 CALL PUTSTR(7,W1,0,ERR) I=0 70 CONTINUE I=I+1 J=J+1 80 CONTINUE IF (W1(1).NE.'$') CALL PUTSTR(7,' ',' ',ERR) 90 CONTINUE C RETURN END ! UCLEXE SUBROUTINE UCLFND(ICMD) C C This routine searches for the keybord command in the C list of user defined commands. It returns in ICMD: C N when the Nth command is found exactly, C N+MAX when the Nth command is found abbreviated, C 0 when the command is not found, C -1 when the command is found more than once exactly C -2 when the command is not found exactly, but more C than once abbreviated. C BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG C CALL UCLWRD(CMD,0,W1,L1,-1) C IABREV=0 IEXACT=0 NABREV=0 NEXACT=0 DO 40, I=1,NCMD CALL UCLWRD(UCLDAT(1,I),0,W2,L2,-1) IF (INDEX(W2,W1).NE.1) GOTO 30 IF (L1.EQ.L2) GOTO 10 IABREV=I NABREV=NABREV+1 GOTO 20 10 IEXACT=I NEXACT=NEXACT+1 20 CONTINUE 30 CONTINUE 40 CONTINUE C ICMD=0 IF (NEXACT.EQ.0) GOTO 50 IF (NEXACT.GT.1) ICMD=-1 IF (NEXACT.EQ.1) ICMD=IEXACT GOTO 60 50 IF (NABREV.GT.1) ICMD=-2 IF (NABREV.EQ.1) ICMD=IABREV+MAX 60 CONTINUE C RETURN END ! UCLFND SUBROUTINE UCLLST(K) C C This routine lists the UCL command definitions on the C terminal unless K=0 and writes them back into the data C file in alphabetical order. C BYTE VFC,ERR BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA VFC /'+'/ C 1 FORMAT('0*** U s e r C o m m a n d L a n g u a g e ***', > ' (c) H.Reints, 1985'/) 2 FORMAT(X,I2,' user defined commands;', > ' maximum permitted = ',I2) C IF (K.NE.0) TYPE 1 IF (NCMD.EQ.0) GOTO 50 CALL SCCA(ISCCFL) ! disable ^C abortion during write back IF (K.EQ.0) RENAME(2)=RENAME(3) IF (IRENAM(IGETC(),RENAME).EQ.3) CALL UCLERR(6) OPEN(UNIT=1,NAME=DATFIL,TYPE='NEW', > INITIALSIZE=(82*NCMD+511)/512,ERR=30) DO 20, I=1,NCMD IF (UCLDAT(1,I).EQ.0) GOTO 10 CALL PUTSTR(1,UCLDAT(1,I),VFC,ERR) VFC=' ' IF (K.NE.0.AND.ISCCFL.EQ.0) > CALL PUTSTR(7,UCLDAT(1,I),VFC,ERR) CONTINUE 10 CONTINUE 20 CONTINUE CLOSE(UNIT=1) IF (ISCCFL.EQ.0.OR.K.EQ.0) GOTO 24 CALL ITTINR CALL ITTINR CALL PUTSTR(7,'^C^C','0',ERR) 24 CONTINUE IF (K.NE.0) CALL PUTSTR(7,' ',' ',ERR) GOTO 40 30 CALL UCLERR(7) 40 CONTINUE CALL SCCA ! enable ^C abortion 50 CONTINUE IF (K.EQ.0) GOTO 60 TYPE 2,NCMD,MAX D CALL PUTSTR(7,'Invalid commands --> @','0',ERR) CALL PUTSTR(7,' ',' ',ERR) GOTO 70 60 IF (NCMD.EQ.1) CALL UCLERR(8) 70 CONTINUE C RETURN END ! UCLLST SUBROUTINE UCLQRY(ICMD,IQRY,IDEL) C C This routine performs a query when a command is C deleted or redefined. C BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG C IF (IQRY.EQ.1) GOTO 30 IF (IDEL.EQ.0) GOTO 10 CALL SCOPY('Delete',W2) GOTO 20 10 CALL SCOPY('Redefine',W2) 20 CONTINUE CALL CONCAT(W2,' UCL command; are you sure? ',W2,80) CALL PUTSTR(7,W2,'$',ERR) CALL GETSTR(5,W2, 80,ERR) IF (W2(1).NE.'Y'.AND.W2(1).NE.'y') CALL UCLERR(9) 30 CONTINUE C NCMD=NCMD-1 DO 40, I=ICMD,NCMD CALL SCOPY(UCLDAT(1,I+1),UCLDAT(1,I)) 40 CONTINUE UCLDAT(1,I)=0 C IF (IQRY.NE.0) CALL UCLERR(10+IDEL) C RETURN END ! UCLQRY SUBROUTINE UCLRPL(C,J) BYTE C C C This routine replaces the ^ parameters by the C corresponding part of the command line. C BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG C IF (C.EQ.'$') CALL SCOPY(CMD,W2) IF (C.NE.'*') GOTO 10 IPOS=1 CALL UCLWRD(CMD,IPOS,W2,L2,0) CALL SCOPY(CMD(IPOS),W2) 10 CONTINUE L2=LEN(W2) C N=C-'0' IF (N.LT.0) GOTO 30 IPOS=1 DO 20, K=0,N CALL UCLWRD(CMD,IPOS,W2,L2,0) 20 CONTINUE 30 CONTINUE C K=1 40 IF (K.GT.L2) GOTO 50 IF (W2(K).EQ.'-') W2(K)=' ' IF (W2(K).EQ.'&') W2(K)= 9 IF (W2(K).EQ.'_') K=K+1 CALL IPOKEB(J,W2(K)) IF (W2(K).NE.0) J=J+1 K=K+1 GOTO 40 50 CONTINUE C RETURN END ! UCLRPL SUBROUTINE UCLTRM C C This routine removes trailing spaces and tabs from C the command line. C BYTE DTW(30),ERR DIMENSION IDTW(6) BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA NDTW,LDTW,IDTW /6,30,1,5,9,14,19,24/ DATA DTW /"264,"252,"253,"377,"263,"252,"263,"377, > "264,"260,"261,"253,"377,"257,"260,"272, > "257,"377,"254,"267,"266,"253,"377,"271, > "252,"274,"264,"377,"377,"377/ C 10 IF (CMD(LCMD).NE.32.AND.CMD(LCMD).NE.9 > .AND.CMD(LCMD).NE.0) GOTO 20 CMD(LCMD)=0 LCMD=LCMD-1 GOTO 10 20 CONTINUE C C check for dirty words DO 30, I=1,LDTW DTW(I)=.NOT.DTW(I) 30 CONTINUE IPOS=1 CALL UCLWRD(CMD,IPOS,W1,L,-1) 40 IF (L.EQ.0) GOTO 70 DO 60, I=1,NDTW IF (ISCOMP(W1,DTW(IDTW(I))).EQ.0) GOTO 100 60 CONTINUE CALL UCLWRD(CMD,IPOS,W1,L,-1) GOTO 40 70 CONTINUE C RETURN C 100 CALL UCLERR(12) RETURN END ! UCLTRM SUBROUTINE UCLWRD(S,I,W,L,ICASE) BYTE S(1),W(1) C C This routine reads a word from string S into array W, C starting at position I and returns the length of W in L. C When I>0 it is updated to point to the next word in S, C when I=<0 searching starts at position 1 and I is not C updated. Leading and trailing spaces and tabs are skipped. C When ICASE is non-zero, lower to upper case conversion C is performed on the output word. C J=1 IF (I.GT.0) J=I C 10 IF (S(J).NE.32.AND.S(J).NE.9) GOTO 20 J=J+1 GOTO 10 20 CONTINUE C L=1 30 IF (INDEX(S,'==').EQ.J .OR. > S(J).EQ.32 .OR. S(J).EQ.9 .OR. S(J).EQ.0) GOTO 40 W(L)=S(J) L=L+1 J=J+1 GOTO 30 40 CONTINUE W(L)=0 L=L-1 C IF (I.LE.0) GOTO 70 I=J 50 IF (S(I).NE.32.AND.S(I).NE.9) GOTO 60 I=I+1 GOTO 50 60 CONTINUE IF (INDEX(S,'==*').EQ.I) I=I+3 IF (INDEX(S,'==' ).EQ.I) I=I+2 70 CONTINUE C IF (ICASE.EQ.0) GOTO 90 DO 80, J=1,L IF (W(J).GE.97.AND.W(J).LE.122) W(J)=W(J)-32 80 CONTINUE 90 CONTINUE C RETURN END ! UCLWRD SUBROUTINE UCLXPN(ICMD,NCHAR) C C This routine does the actual expansion C of a UCL command. C BYTE DATFIL(16),CMD(82),UCLDAT(82,60),W1(82),W2(82) REAL*8 RENAME(3) COMMON DATFIL,RENAME,LCMD,NCMD,MAX,CMD,UCLDAT,W1,W2,IWMSG DATA I,IPR,ICHADR /1,0,"512/ C IF (ICMD.GT.MAX) ICMD=ICMD-MAX IDEF=INDEX(UCLDAT(1,ICMD),'==')+2 IF (UCLDAT(IDEF,ICMD).EQ.'*') IDEF=IDEF+1 CALL SCOPY(UCLDAT(IDEF,ICMD),W1) 10 IF (W1(I).NE.32.AND.W1(I).NE.9) GOTO 20 I=I+1 GOTO 10 20 CONTINUE IF (W1(I).EQ.'"') IPR=1 I=I+IPR L1=LEN(W1)+1 J=ICHADR 30 IF (I.GT.L1) GOTO 110 IF (W1(I).EQ.'^') GOTO 40 IF (W1(I).EQ.'#') W1(I)='@' IF (W1(I).EQ.'`') W1(I)= 0 IF (W1(I).EQ.'_') I=I+1 CALL IPOKEB(J,W1(I)) I=I+1 J=J+1 GOTO 100 40 K=I+1 IF ((W1(K).LT.'0'.OR.W1(K).GT.'9') > .AND.W1(K).NE.'*'.AND.W1(K).NE.'$') GOTO 80 I=I+2 CALL UCLRPL(W1(K),J) GOTO 90 80 CALL IPOKEB(J,W1(I)) J=J+1 I=I+1 90 CONTINUE 100 CONTINUE GOTO 30 110 CONTINUE C NCHAR=J-ICHADR IF (IPR.NE.0) NCHAR=-NCHAR C RETURN END ! UCLXPN