C............................................................................. C C Walter L. Battaglia C YOLO EXPERT SOFTWARE C 1111 Kennedy Place, Suite 4 C Davis, CA 95616 C C (916) 758-8940 C C............................................................................. C C LICENSE & DISCLAIMER C C The programs and procedures described herein were designed and written by C Walter L. Battaglia (hereafter, the writer). The writer reserves the right C to make use of this material in other applications, and all rights of sale C and distribution. C C The writer herewith grants the right to use this program to the Digital C Equipment Computer User's Society (DECUS), its affiliates, and members. C C These programs and materials are distributed without warranty. The writer C assumes no liability whatever for their use in any application. C C............................................................................. C C ACKNOWLEDGEMENTS C C "DEC", "RT-11", "RSX-11/M", "VAX", "VMS", "VT52", "VT100", "VT220", "LA100", C "LA120", "PDP-11", and "LSI-11/23" are trademarks and/or products of the C DIGITAL EQUIPMENT CORP., MAYNARD, MASS. C C "TSX-PLUS" and "COBOL-PLUS" are trademarks and/or products of S&H COMPUTERS, C NASHVILLE, TENN. C C............................................................................. PROGRAM STRIP C C Program to read a source file and create output file(s) containing C program comments, and another containing the source code only. C LOGICAL*1 OPEN1,OPEN2,OPEN3 C BYTE FILNAM(16),COMFIL(16),SRCFIL(16),BUFFER(136), &FILTYP,COMENT C INTEGER*2 IQ C REAL*8 PROMPT C 1 CONTINUE TYPE 2 2 FORMAT (////'1STRIP SOURCE'/'0This program will read the file & you specify, splitting it into two files'/' on the device(s) & you name. The first file will contain the comments, and'/ &' the second file will have the stripped source code.'/) 10 CONTINUE TYPE 11 11 FORMAT (' Enter the file type: obol, ortran, acro. & Default: F ',$) READ (5,12,ERR=17) IQ,FILTYP 12 FORMAT (Q,1A1) COMENT = '!' ! Default comment byte IF (IQ .LT. 1) GO TO 19 IF (FILTYP .EQ. 'F') GO TO 20 COMENT = '*' ! Default comment byte IF (FILTYP .EQ. 'C') GO TO 20 COMENT = ';' ! Default comment byte IF (FILTYP .EQ. 'M') GO TO 20 15 CONTINUE TYPE 16 16 FORMAT (/' ? Undefined source type. Re-specify.') 17 CONTINUE CALL TTERR GO TO 10 19 CONTINUE FILTYP = 'F' 20 CONTINUE C C get the input file name C OPEN1 = .FALSE. PROMPT = ' source ' CALL GETNAM (FILNAM,PROMPT,IQ) C C If no entry - program done C IF (IQ .LT. 1) GO TO 890 OPEN2 = .FALSE. OPEN3 = .FALSE. ! set defaults for other files C C See if the file exists?? C PAUSE 'Press when the source device is ready' C OPEN (UNIT=1,NAME=FILNAM,TYPE='OLD',ERR=80,READONLY, &RECORDSIZE=136,CARRIAGECONTROL='LIST',FORM='FORMATTED', &DISP='KEEP') OPEN1 = .TRUE. 30 CONTINUE C C get the comment file name C PROMPT = ' comment' CALL GETNAM (COMFIL,PROMPT,IQ) C C If no entry - no comment file C IF (IQ .LT. 1) GO TO 40 C C Start file C PAUSE 'Press when the comment file device is ready' C OPEN (UNIT=2,NAME=COMFIL,TYPE='NEW',BUFFERCOUNT=1, &RECORDSIZE=136,CARRIAGECONTROL='LIST',FORM='FORMATTED', &ACCESS='SEQUENTIAL',ERR=70) C OPEN2 = .TRUE. 40 CONTINUE C C get the code file name C PROMPT = ' code ' CALL GETNAM (SRCFIL,PROMPT,IQ) C C If no entry - no code file C IF (IQ .LT. 1) GO TO 50 C C Start file C PAUSE 'Press when the code file device is ready' C OPEN (UNIT=3,NAME=SRCFIL,TYPE='NEW',BUFFERCOUNT=1, &RECORDSIZE=136,CARRIAGECONTROL='LIST',FORM='FORMATTED', &ACCESS='SEQUENTIAL',ERR=60) C OPEN3 = .TRUE. GO TO 100 50 CONTINUE C Check for at least one output file IF (OPEN2) GO TO 100 C No output files - error, stop TYPE 51 51 FORMAT (/' ? No output files were specified.'/) GO TO 900 60 CONTINUE TYPE 61 61 FORMAT (/' ? Unable to start code file. Try another.') GO TO 40 70 CONTINUE TYPE 71 71 FORMAT (/' ? Unable to start comment file. Try another.') GO TO 30 80 CONTINUE TYPE 81 81 FORMAT (/' ? Unable to locate input file. Try another.') GO TO 20 100 CONTINUE C C Read a line and transfer it to the appropriate output C READ (1,101,ERR=820,END=850) IQ,(BUFFER(I),I=1,IQ) 101 FORMAT (Q,136A1) C C Empty line - skip it C IF (IQ .LT. 1) GO TO 100 C C Find the file type, and check for output type accordingly C IF (FILTYP .EQ. 'C') GO TO 600 IF (FILTYP .EQ. 'M') GO TO 200 C C File type is FORTRAN - if 1st character is "C", comment line C IF (BUFFER(1) .EQ. 'C') GO TO 700 C C Set up search for comments in rest of line C GO TO 210 200 CONTINUE C C File type is MACRO - if 1st character is ";", comment line C IF (BUFFER(1) .EQ. COMENT) GO TO 700 C C Otherwise - check whether any comment occurs in the line C 210 CONTINUE I = 1 ! Index to line 211 CONTINUE IF (BUFFER(I) .EQ. COMENT) GO TO 220 ! Comment found I = I + 1 IF (I .LE. IQ) GO TO 211 C Uncommented line goes to code output GO TO 750 220 CONTINUE C C Create two lines - code and comment - write code now C K = I - 1 ! End of code line IF (K) 225,225,222 222 CONTINUE IF (OPEN3) WRITE (3,701,ERR=840) (BUFFER(J),J=1,K) 225 CONTINUE C C Now write the comments C K = IQ - I ! Comment length IF (K) 230,230,227 227 CONTINUE IF (OPEN2) WRITE (2,701,ERR=830) (BUFFER(J),J=I,IQ) 230 CONTINUE GO TO 100 600 CONTINUE C C File type is COBOL - If 1st character is "*", comment line, else code C IF (BUFFER(1) .NE. COMENT) GO TO 750 700 CONTINUE C C Write a line in the comment file, if any C IF (OPEN2) WRITE (2,701,ERR=830) (BUFFER(I),I=1,IQ) 701 FORMAT (136A1) GO TO 100 750 CONTINUE C C Write a line in the code file, if any C IF (OPEN3) WRITE (3,701,ERR=840) (BUFFER(I),I=1,IQ) GO TO 100 C C File errors C 820 CONTINUE TYPE 821 821 FORMAT (/' Error reading source file.'/) GO TO 900 830 CONTINUE TYPE 831 831 FORMAT (/' Error writing comment file - deleted.'/) CLOSE (UNIT=2,DISP='DELETE') OPEN2 = .FALSE. GO TO 900 840 CONTINUE TYPE 841 841 FORMAT (/' Error writing code file - deleted.'/) CLOSE (UNIT=3,DISP='DELETE') OPEN3 = .FALSE. GO TO 900 850 CONTINUE TYPE 851 851 FORMAT (/' Reached end of input file.'/) GO TO 900 890 CONTINUE TYPE 891 891 FORMAT (/' ? No input file specified.'/) 900 CONTINUE TYPE 901 901 FORMAT (/' Program ended.'/) 940 CONTINUE IF (OPEN1) CLOSE (UNIT=1) 950 CONTINUE IF (OPEN2) CLOSE (UNIT=2) 960 CONTINUE IF (OPEN3) CLOSE (UNIT=3) CALL EXIT END SUBROUTINE GETNAM (FILNAM,LINE,IQ) C C Subroutine to read terminal and get next file name C BYTE FILNAM(16),LINE(8) C INTEGER*2 IQ C 1 CONTINUE TYPE 2,(LINE(I),I=1,8) 2 FORMAT (/' Enter the device and file name of the ',8A1, &' file. Default: none'/' * ',$) READ (5,3,ERR=10) IQ,(FILNAM(I),I=1,14) 3 FORMAT (Q,16A1) IF (IQ .LT. 1) RETURN ! No file IF (IQ .LT. 3) GO TO 5 ! Name too short IF (IQ .GT. 14) GO TO 5 ! Name too long FILNAM (IQ+1) = "0 RETURN 5 CONTINUE TYPE 6 6 FORMAT (/' ? File name error. Too long or short.') 10 CONTINUE CALL TTERR GO TO 1 END SUBROUTINE TTERR C C Sends error message to terminal C TYPE 2 2 FORMAT (/' Terminal or entry error - re-specify.') RETURN END