C%A-RCB-0077-SL-14 LSTOPN -- FILE OPENING ROUTINE SUBROUTINE LSTOPN(LUT,LUDI,LUDO) IMPLICIT LOGICAL*1 (B) COMMON /LSTOPN/ DEVIN,BNAMIN(32),DEVOUT,BNAMOU(32),PROMPT, 1 DEFALT,EXTN,BOLD,BMCR C C ARGUMENT DEFINITIONS C C LUT LUN for TI C LUDI LUN to be assigned to input file C LUDO LUN to be assigned to output file C C COMMON PARAMETERS C C DEVIN Default device for input -- user should set to 'SY:' C BNAMIN On return, contains name of input file, with extension C inserted. C DEVOUT Default device for output -- user should set as desired. C BNAMOU On return, contains name of output file, with extension C inserted. C PROMPT Prompt -- 3 characters stored in a real variable C DEFALT Default file extension -- 3 characters in a real C EXTN Actual file extension of 'infil' C BOLD Logical variable -- .TRUE. if 'infil' exists. C BMCR " " -- .TRUE. if command was on MCR line. C C FUNCTION C C This program gets the MCR command line, or prompts on LUT using C the 3-character PROMPT given by the caller. It accepts a command C string in the forms C C outfil=infil C =infil C infil C C where 'outfil' and 'infil' are standard RSX file specifiers. These strings C are interpreted as follows: C C outfil=infil C 'infil' is opened for reading on LUDI. 'outfil' is assigned on LUDO. C If 'infil' does not exist, a message is given followed by a prompt for C another command string. C C =infil C 'infil' is opened for reading on LUDI. A new version of 'infil' is C assigned on LUDO. If 'infil' does not exist, a message is given C followed by a prompt for another command string. C C infil C 'infil' is opened for reading on LUDI. A new version of 'infil' is C assigned on LUDO. If 'infil' does not exist, OLDFIL is set FALSE. C This may be used by the user to trigger a 'creating new file' message. C C In all cases, LUDI and LUDO default to 'SY:'. The input file extension C defaults to DEFALT if not specified. The output file extension defaults C to match the input, if not specified. OLDFIL is set true is 'infil' exists. C C This program is a version of GETCOM, extensively modified for LST. C It defaults the output file to LP: unless a name is given, in which C case it directs it to SY: C%%A-RCB-0077-SL-14 LSTOPN -- PROGRAM LISTING C DATA DEFINITIONS DIMENSION BUFFER(80) DIMENSION BJUMP(4,18) BYTE CR EQUIVALENCE (BLANK,DUMMY) C DATA CR /"15/ DATA NEVEN, NSTAT/ 1 3, 18/ DATA BJUMP/ 16, 4,14,0, 10, 3,0,0, 8, 8,11,0, 1 1, 11,5,10, 3, 6,0,0, 4, 12,2,7, 2 10, 8,0,0, 6, 9,13,11, 9, 0,0,0, 3 17, 14,0,0, 2, 5,14,11, 5, 8,0,0, 4 14, 11,0,0, 15, 0,0,0, 0, 0,0,0, 5 0, 0,0,0, 0, 0,0,0, 0, 0,0,0/ C DATA DUMMY/' '/ DATA NUMBUF/2/ C C PROGRAM ENTRY ISTATE = 1 IEVENT = 1 CALL ERRSET(29,,.FALSE.,,.FALSE.) CALL ERRSET(43,,.FALSE.,,.FALSE.) C C START OF MAIN LOOP 10 CONTINUE IF(IEVENT.LE.0.OR.IEVENT.GT.NEVEN) GO TO 9000 INEXT = BJUMP(IEVENT+1,ISTATE) D WRITE(LUT,30) PROMPT,ISTATE,IEVENT,INEXT !DEBUG D30 FORMAT(' ',A3,': STATE',I3,' EVENT',I2,' NEXT STATE',I3) !DEBUG IF(INEXT.LE.0.OR.INEXT.GT.NSTAT) GO TO 9100 ISTATE = INEXT IJUMP = BJUMP(1,ISTATE) GO TO ( 100, 200, 300, 400, 500, 600, 700, 800, 900,1000, 1 1100,1200,1300,1400,1500,1600,1700,1800) IJUMP C C Issue GETMCR C Events: 1 Failure C 2 Success C 3 Directive error C 100 IEVENT = 3 BMCR = .FALSE. IPOSN = 4 CALL GETMCR(BUFFER,IDS) IF(IDS.EQ.-80) IEVENT = 1 IF(IDS.LT.0) GO TO 10 IEVENT = 2 NCHAR = IDS IF(NCHAR.LE.4) IEVENT = 1 IF(IEVENT.EQ.2) BMCR = .TRUE. GO TO 10 C C Prompt and read line C Events: 1 Success C 2 EOF from TI C 3 Null line C 200 IEVENT = 2 IPOSN = 1 WRITE(LUT,210) CR, PROMPT 210 FORMAT('$',A1,A3,'>') READ(LUT,230,END=10) NCHAR,BUFFER 230 FORMAT(Q,80A1) IEVENT = 1 IF(NCHAR.EQ.0) IEVENT = 3 GO TO 10 C C Clear name buffers C Event: 1 C 300 IEVENT = 1 DO 320 I = 1,32 BNAMIN(I) = BLANK BNAMOU(I) = BLANK 320 CONTINUE CALL CLOSE(LUDI) CALL FDBSET(LUDI,'READONLY',,NUMBUF) CALL ASSIGN(LUDI,DEVIN,4) CALL CLOSE(LUDO) CALL FDBSET(LUDO,,,NUMBUF) CALL ASSIGN(LUDO,DEVOUT,4) GO TO 10 C C Move BUFFER to BNAMOU C Events: 1 '=' not encountered C 2 '=' encountered C 3 '=' was first character examined C 400 IEVENT = 2 CALL BMOVE(BUFFER,BNAMOU,IPOSN,NCHAR,DUMMY,EXTN,ILAST,NOUT) IPOSN = ILAST + 1 IF(NOUT.EQ.0) IEVENT = 3 IF(ILAST.EQ.NCHAR) IEVENT = 1 GO TO 10 C C Move BNAMOU to BNAMIN C Event: 1 C 500 IEVENT = 1 CALL BMOVE(BNAMOU,BNAMIN,1,NOUT,DEFALT,EXTN,ILAST,NIN) GO TO 10 C C Attempt to open input file C Events: 1 Success C 2 Failure C 3 Bad name, disk or file system error C 600 IEVENT = 1 D WRITE(LUT,610) (BNAMIN(I), I=1,NIN) D610 FORMAT(' INPUT = ',32A1) BOLD = .TRUE. CALL ERRTST(43,I) CALL ASSIGN(LUDI,BNAMIN,NIN) CALL ERRTST(43,I) IF(I.NE.1) GO TO 625 IEVENT = 3 WRITE(LUT,615) PROMPT,(BNAMIN(I), I=1,NIN) 615 FORMAT('0',A3,': INVALID INPUT FILE NAME ',32A1/) GO TO 10 625 READ(LUDI,630,ERR=660) I 630 FORMAT(A1) REWIND LUDI GO TO 10 660 IEVENT = 2 BOLD = .FALSE. CALL ERRTST(29,I) IF(I.EQ.1) GO TO 10 IEVENT = 3 WRITE(LUT,670) PROMPT,(BNAMIN(I), I=1,NIN) 670 FORMAT('0',A3,': I/O ERROR ON INPUT FILE ',32A1/) GO TO 10 C C 'CREATING NEW FILE' C Event: 1 C 700 IEVENT = -1 GO TO 900 C C Open output file C Events: 1 Success C 2 Failure C 800 IEVENT = 1 CALL BMOVE(BNAMOU,BNAMOU,1,NOUT,EXTN,X,I,NOUT) D WRITE(LUT,810) (BNAMOU(I), I=1,NOUT) D810 FORMAT(' OUTPUT = ',32A1) CALL CLOSE(LUDO) CALL FDBSET(LUDO,,,NUMBUF) CALL ASSIGN(LUDO,DEVIN,4) CALL ASSIGN(LUDO,BNAMOU,NOUT) CALL ERRTST(43,I) IF(I.NE.1) GO TO 10 IEVENT = 2 WRITE(LUT,830) PROMPT,(BNAMOU(I), I=1,NOUT) 830 FORMAT('0',A3,': INVALID OUTPUT FILE NAME ',32A1/) GO TO 10 C C RETURN C C Reset errors 29 and 43 to default states. C 900 CALL ERRSET(29,,.TRUE.,,.TRUE.) CALL ERRSET(43,,.TRUE.,,.TRUE.) RETURN C C Copy BUFFER to BNAMIN C Event: 1 C 1000 IEVENT = 1 CALL BMOVE(BUFFER,BNAMIN,IPOSN,NCHAR,DEFALT,EXTN,I,NIN) C SHOULD CHECK FOR ERROR IF NIN=0 GO TO 10 C 1100 GO TO 9200 1200 GO TO 9200 1300 GO TO 9200 C C 'NONEXISTENT INPUT FILE' C Event: 1 C 1400 IEVENT = 1 WRITE(LUT,1410) PROMPT,(BNAMIN(I), I=1,NIN) 1410 FORMAT('0',A3,': NONEXISTENT INPUT FILE ',32A1/) GO TO 10 C C CALL EXIT C 1500 CALL EXIT C C Initial entry C Events: 1 First time C 2 Not first time C 1600 IEVENT = 2 WRITE(LUT,1610) PROMPT 1610 FORMAT('0',A3,': LSTOPN STATE 16 ENCOUNTERED -- EXIT CALLED'/) GO TO 10 C C MCR directive error C Event: 1 C 1700 IEVENT = 1 WRITE(LUT,1710) PROMPT,IDS 1710 FORMAT('0',A3,': GETMCR ERROR',I4,' -- EXIT CALLED'/) GO TO 10 C C Disk I/O error C Event: 1 C 1800 IEVENT = 1 WRITE(LUT,1810) PROMPT 1810 FORMAT('0',A3,': FATAL DISK ERROR -- EXIT CALLED'/) GO TO 10 C C Error messages -- tables have been corrupted 9000 WRITE(LUT,9010) PROMPT,ISTATE,IEVENT 9010 FORMAT ('0',A3,': LSTOPN ST',I3,' EV',I3,' BAD -- EXIT CALLED'/) CALL EXIT 9100 WRITE(LUT,9110) PROMPT,ISTATE,IEVENT,INEXT 9110 FORMAT('0',A3,': LSTOPN ST',I3,' EV',I3,' NX',I3,' BAD --', 1 ' EXIT CALLED'/) CALL EXIT 9200 WRITE(LUT,9210) PROMPT,ISTATE,IJUMP 9210 FORMAT('0',A3,': LSTOPN ST',I3,' UNIMPLEMENTED FUNCTION',I3/ 1 ' EXIT CALLED') CALL EXIT END C%%A-RCB-0077-SL-14 LSTOPN -- BMOVE COPY ROUTINE SUBROUTINE BMOVE(BIN,BOUT,ISTRT,ISTOP,DEFALT,EXTN,ILAST,NCHAR) C IMPLICIT LOGICAL*1 (B) PARAMETER MAXNAM=32 C C ARGUMENT DEFINITIONS C C BIN Input string -- byte array C BOUT Output string -- " C ISTRT Starting position in BIN C ISTOP Stopping position in BIN C DEFALT Default file extension C EXTN Actual file extension (=DEFALT if default is used) C ILAST Position in BIN of last character examined. C NCHAR Position in BOUT of last character copied. C C FUNCTION C C Copies bytes from BIN to BOUT, starting at position ISTRT of BIN C and position 1 of BOUT. Stops at position ISTOP of BIN, unless an C equals (=) sign is encountered. An equals sign terminates the copy C operation. On return, ILAST contains the position of the last C character examined. Thus, for the string C C =FRED ILAST = position of (=); NCHAR=0 C FRED=BOB = position of (=) C FRED = ISTOP C C All blanks are ignored and are not copied. NCHAR is the position of C the last character in BOUT. It is zero if nothing was copied. C C Any lower case characters encountered are shifted to upper case. C [ Revision for V6B, made August 1977. ] C C DEFALT is the default file extension, stored as 3 characters in a C real variable. EXTN is the actual extension, stored in the same way. C If the string does not include an extension (identified by a leading C period), the default will be appended to the name. But, if DEFALT is C blank, it will not be used. C C If ISTRT>ISTOP, the program returns with ILAST=0 and NCHAR=0. C C DECLARATIONS DIMENSION BIN(1),BOUT(MAXNAM),BDEF(4),BEXT(4) EQUIVALENCE (BDEF,DEF),(BEXT,EXT) C C INTERNAL DATA DATA BLANK, BEQUAL, BPOINT, RBLANK/ 1 ' ', '=', '.', ' '/ C C PROGRAM DEF = DEFALT EXT = RBLANK ICHAR = 0 IF(ISTRT.GT.ISTOP) GO TO 9000 IPUT = 0 BFLAG = .FALSE. DO 2000 IPOSN = ISTRT,ISTOP ILAST = IPOSN BCHAR = BIN(IPOSN) IF(BCHAR.EQ.BLANK) GO TO 2000 IF(BCHAR.EQ.BEQUAL) GO TO 2100 IF (BCHAR.GE."141) BCHAR = BCHAR - 32 IF(.NOT.BFLAG) GO TO 1500 IPUT = IPUT + 1 IF(IPUT.LE.3) BEXT(IPUT) = BCHAR 1500 IF(BCHAR.EQ.BPOINT) BFLAG = .TRUE. IF(ICHAR.LT.MAXNAM) ICHAR = ICHAR + 1 BOUT(ICHAR) = BCHAR 2000 CONTINUE 2100 IF(BFLAG.OR.ICHAR.EQ.0) GO TO 3000 IF(BDEF(1).EQ.BLANK) GO TO 3000 IF(ICHAR.LT.MAXNAM) ICHAR = ICHAR + 1 BOUT(ICHAR) = BPOINT EXT = DEFALT DO 2200 I = 1,3 IF(ICHAR.LT.MAXNAM) ICHAR = ICHAR + 1 BOUT(ICHAR) = BDEF(I) 2200 CONTINUE 3000 NCHAR = ICHAR EXTN = EXT RETURN C C ERROR 9000 ILAST = 0 NCHAR = ICHAR RETURN END