C C C+ C SQUISH - Sequence field and trailing blank/tab trimmer. C C >SQUish filespec or C >SQUish filespec/WI:width (decimal width <= 132) C C >SQUish C SQUISH>filespec or C SQUISH>filespec/WI:width C C RUN $SQUISH C SQUISH>filespec C SQUISH>filespec/WI:width C C >FOR SQUISH,SQUISH/-SP=SQUISH C C >TKB C TKB>SQUISH,SQUISH/-SP/SH/CP=SQUISH,SY:[1,1]SYSLIB/LB:$SHORT C TKB>/ C ENTER OPTIONS: C TKB>UNITS=3 C TKB>ACTFIL=3 C TKB>ASG=TI:3 C TKB>EXTSCT=$$FSR1:2270 C TKB>TASK=...SQU C TKB>// C C >INS SQUISH C C- C LOGICAL*1 BUFFER(132), MCRBUF(80), PROMPT, WIDTH(3) LOGICAL*1 BLANK, TAB, SLASH, ZERO, NINE, CHAR LOGICAL*1 UPPER C DATA BUFFER/132*' '/ DATA PROMPT/.FALSE./ DATA BLANK/' '/, TAB/"11/, SLASH/'/'/, ZERO/'0'/, NINE/'9'/ DATA WIDTH/'W','I',':'/ C CALL ERRSET(29,,.FALSE.,,.FALSE.) CALL ERRSET(43,,.FALSE.,,.FALSE.) C C... Get invoking command line. CALL GETMCR(MCRBUF,NCHARS) IF (NCHARS .LE. 0) GOTO 1900 C C... Skip over program name. DO 1100 ICHAR = 1,NCHARS IF (MCRBUF(ICHAR) .EQ. BLANK) GOTO 3000 1100 CONTINUE C... All blanks, fall through to prompt. 1900 PROMPT = .TRUE. C C... Prompt for another command. 2000 WRITE(3,301) READ(3,302,END=9000) NCHARS, (MCRBUF(J), J = 1,NCHARS) IF (NCHARS .LE. 0) GOTO 2000 ICHAR = 1 C... Trim leading blanks/tabs off filespec. 3000 DO 3100 J = ICHAR,NCHARS IF (MCRBUF(J) .EQ. BLANK) GOTO 3100 IF (MCRBUF(J) .NE. TAB) GOTO 3200 3100 CONTINUE C... All blanks or tabs (only possible if PROMPT = .TRUE.) GOTO 2000 C C... Scan through file spec for trailing blank/tab or slash. 3200 ICHAR = J DO 3300 J = ICHAR,NCHARS IF ((MCRBUF(J) .EQ. BLANK) .OR. 1 (MCRBUF(J) .EQ. TAB) .OR. 2 (MCRBUF(J) .EQ. SLASH)) GOTO 3400 3300 CONTINUE J = NCHARS + 1 C... Recompute NCHARS for assigns. 3400 NFILE = J - ICHAR MAXW = 72 C C... Look for /WI:width switch. IF (J .GE. NCHARS) GOTO 3500 IF (MCRBUF(J) .EQ. BLANK) GOTO 3500 IF (MCRBUF(J) .EQ. TAB) GOTO 3500 C... Got something, decode it. DO 3410 I = 1,3 J = J + 1 IF (J .GE. NCHARS) GOTO 3490 IF (UPPER(MCRBUF(J)) .NE. WIDTH(I)) GOTO 3490 3410 CONTINUE C... No more than 3 characters for width (prevents overflow). IDIG = NCHARS - J IF ((IDIG .LE. 0) .OR. (IDIG .GT. 3)) GOTO 3490 C... Decode 3 digits (decimal only). MAXW = 0 DO 3420 I = 1,IDIG CHAR = MCRBUF(J+I) IF ((CHAR .LT. ZERO) .OR. 1 (CHAR .GT. NINE)) GOTO 3490 3420 MAXW = (10*MAXW) + (CHAR-ZERO) C... No greater than 132. IF (MAXW .LE. 132) GOTO 3500 C... Switch specification error. 3490 WRITE(3,303) IF (PROMPT) GOTO 2000 GOTO 9000 C C... Reset default device to SY: (INStall freezes LUNs) 3500 CALL ASNLUN(1,'SY',0) CALL ASNLUN(2,'SY',0) C... Open input and output files. MCRBUF(ICHAR+NFILE) = 0 OPEN(UNIT=1,NAME=MCRBUF(ICHAR),TYPE='OLD',READONLY,ERR=3510) OPEN(UNIT=2,NAME=MCRBUF(ICHAR),TYPE='NEW',CARRIAGECONTROL='LIST', 1 ERR=3510) GOTO 4000 C C... Error opening files. 3510 WRITE(3,304) IF (PROMPT) GOTO 2000 GOTO 9000 C C... Commence transfer. C 4000 READ(1,101,END=5000,ERR=4300) NCHARS, (BUFFER(J), J = 1,NCHARS) C C... Trim trailing blanks/tabs. MAXCH = NCHARS IF (NCHARS .GT. MAXW) MAXCH = MAXW DO 4100 J = 1,MAXCH NCHARS = MAXCH + 1 - J IF (BUFFER(NCHARS) .EQ. BLANK) GOTO 4100 IF (BUFFER(NCHARS) .NE. TAB) GOTO 4200 4100 CONTINUE C C... Null line. WRITE(2,201) GOTO 4000 C C... Write remaining text. 4200 WRITE(2,201) (BUFFER(J), J = 1,NCHARS) GOTO 4000 C C... End of transfer loop. C C... Input file error, terminate transfer. 4300 WRITE(3,305) C C... Close files and try again if PROMPT = .TRUE. C 5000 CLOSE(UNIT=1) CLOSE(UNIT=2) IF (PROMPT) GOTO 2000 C 9000 CALL EXIT C 101 FORMAT (Q, 132A1) 201 FORMAT (132A1) 301 FORMAT ('$SQUISH>') 302 FORMAT (Q, 80A1) 303 FORMAT (' SQUISH -- Switch specification error.'/) 304 FORMAT (' SQUISH -- File specification error.'/) 305 FORMAT (' SQUISH -- Input file I/O error.'/) C END