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 ******************************************************* IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM' INCLUDE 'CPLGBLSWI.INI' BYTE COMAND(80),FILNAM(30),COMLIN(80) EXTERNAL EXITST C C INITIALIZE CALL ERRSET(43,.TRUE.,.FALSE.,.FALSE.,.FALSE.) CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.) CALL ERRSET(30,.TRUE.,.FALSE.,.TRUE.,.FALSE.) CALL ERRSET(37,.TRUE.,.FALSE.,.TRUE.,.FALSE.) C CPLSTA = 1 RATCOM = 1 !SPECIAL 2 PHASE RAT COMPILATION NBSCOM = 1 !SPECIAL 2 PHASE NBS PASCAL CCOM = 1 !SPECIAL 4 PHASE C COMPILATION BASCOM = 1 !SPECIAL 2 PHASE BASIC+2 COMPILATION C C DECLARE USER EXIT ROUTINE (EXIT WITH STATUS) CALL USEREX(EXITST) C C LOOP UNTIL EOF ON INPUT 10 CONTINUE CALL NXTCOM(COMLIN,FILNAM,FILLEN,COMAND,CMDLEN) IF(CMDLEN.LT.0)GOTO 70 20 CONTINUE CALL EXECOM(FILNAM,FILLEN,COMAND,CMDLEN,COMSTA,.TRUE.) C C KEEP WORST STATUS (-1 NONE, 0 WARNING, 1 SUCCESS, 2 ERROR, 4 SEVERE ERROR) IF(COMSTA.EQ.CPLSTA)GOTO 30 IF(COMSTA.EQ.-1)GO TO 30 IF((COMSTA.LT.CPLSTA.AND.CPLSTA.EQ.1).OR.(COMSTA.GT.CPLSTA.AND. 1 COMSTA.NE.1))CPLSTA = COMSTA C C EXECUTE SECONDARY PASSES OF MULTI-PASS COMPILERS 30 CONTINUE C C EXECUTE PHASE 2 OF RAT COMPILATION IF (RATCOM.EQ.1) GO TO 40 CALL RATMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) IF (RATCOM.NE.1) GO TO 20 GO TO 65 C C EXECUTE PHASE 2 OF NBS PASCAL COMPILATION 40 CONTINUE IF (NBSCOM.EQ.1) GO TO 50 CALL NBSMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) IF (NBSCOM.NE.1) GO TO 20 GO TO 65 C C EXECUTE PHASE 2,3,4 OF C COMPILATION 50 CONTINUE IF (CCOM.EQ.1) GO TO 60 CALL CMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) IF (CCOM.NE.1) GO TO 20 GO TO 65 C C EXECUTE PHASE 2 OF BASIC+2 COMPILATION 60 CONTINUE IF (BASCOM.EQ.1) GO TO 65 CALL BASMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) IF (BASCOM.NE.1) GO TO 20 GO TO 65 C C ACCUMULATE MODULES FOR THE LIBRARIAN 65 CONTINUE IF (ISSET(LBSW).AND.COMSTA.LE.1) 1 CALL LBRMAK(.FALSE.,FILNAM,FILLEN,COMAND,CMDLEN) GO TO 10 C C EOF 70 CONTINUE CALL EXIT END SUBROUTINE NXTCOM(COMLIN,FILNAM,FILLEN,COMAND,CMDLEN) IMPLICIT INTEGER (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE COMAND(1),COMLIN(80),PROMPT(7),FILNAM(1) REAL COMNAM LOGICAL NEDCOM,COMPIL DATA COMLEN/-1/,COMPOS/0/,PROMPT/"15,"12,'C','P','L','>',' '/ C C GET NEXT COMMAND LINE OR CONTINUE WITH LAST ONE 10 CONTINUE C C IF LAST COMMAND CREATED A CONCATENATED SOURCE FILE, DELETE IT IF (.NOT.ISSET(DEIS)) GO TO 20 GBLSW(1,1) = GBLSW(1,1).AND.(.NOT.DEIS) DPOS = 1 CALL MOVE('PIP ',1,4,COMAND,DPOS) CALL MOVFIL(FILNAM,FILLEN,'.CPL;*/DE',9,COMAND,DPOS) CALL EXECOM(FILNAM,FILLEN,COMAND,DPOS-1,COMSTA,.FALSE.) 20 CONTINUE IF(COMPOS.LE.COMLEN)GOTO 90 30 CONTINUE C C EXECUTE BASIC+2 COMPILATION IF PENDING IF (.NOT.ISSET(BPIS)) GO TO 35 CALL BASIC (.FALSE.,.TRUE.,COMLIN,FILNAM,FILLEN,COMAND,CMDLEN) IF (CMDLEN.GT.0) RETURN GO TO 40 C C EXECUTE LIBRARIAN COMMANDS IF PENDING 35 CONTINUE IF (.NOT.NEDLBR) GO TO 40 CALL LBRMAK(.TRUE.,FILNAM,FILLEN,COMAND,CMDLEN) RETURN C C GET NEXT COMMAND LINE 40 CONTINUE IF (ISSET(RCIS)) CLOSE (UNIT=4) !CLOSE PREVIOUS REDIRECT FILE GBLNM = 1 GBLSW(1,1) = 0 CALL GTLIN(COMLIN,COMLEN,3,PROMPT,7) IF(COMLEN+1)130,180,50 50 CONTINUE IF(COMLEN.EQ.0)GOTO 40 C C CHECK FOR COMMAND LINE REDIRECTION ( >FILE ) COMPOS = 1 CALL BREAK(COMLIN,COMLEN,COMPOS,'>',1,MATCH,MATPOS) IF (MATCH.NE.1) GO TO 80 COMLIN(COMLEN+1) = 0 IF (COMLIN(MATPOS+1).EQ.'>') GO TO 60 OPEN (UNIT=4,NAME=COMLIN(MATPOS+1),TYPE='NEW',CARRIAGECONTROL='LIST', 1 ERR=160) GO TO 70 60 CONTINUE OPEN (UNIT=4,NAME=COMLIN(MATPOS+2),TYPE='UNKNOWN',ACCESS='APPEND', 1 CARRIAGECONTROL='LIST',RECORDSIZE=132,ERR=150) 70 CONTINUE GBLSW(1,1) = GBLSW(1,1).OR.(RCIS.OR.FCSW) COMLEN = MATPOS-1 IF (COMLEN.EQ.0) GO TO 30 C C GET ANY GLOBAL SWITCHES 80 CONTINUE CALL GETSWI(COMLIN,COMLEN,COMPOS,GBLSW,GBLNM) C C GET NEXT FILE SPECIFICATION 90 CONTINUE LCLNM = 1 LCLSW(1,1) = 0 CALL GETFIL(COMLIN,COMLEN,COMPOS,FILNAM,FILLEN,PREFIX) IF(COMPOS.GE.COMLEN)GOTO 100 C C GET ANY LOCAL SWITCHES CALL GETSWI(COMLIN,COMLEN,COMPOS,LCLSW,LCLNM) C C CHECK IF FILE NEEDS COMPILE 100 CONTINUE COMNAM = 0 COMPIL = NEDCOM(COMLIN,FILNAM,FILLEN,COMNAM) IF (STREQU(COMNAM,BASCMD,3)) GO TO 120 !ACCUMULATE BASIC COMMANDS C C MAKE COMAND LINE IF FILE NEEDS COMPILATION 110 CONTINUE CATPOS = 0 !INCLUDE FILE IN BASIC BUILD IF (ISSET(BUSW)) 1 CALL BASIC (.FALSE.,.FALSE.,COMLIN,FILNAM,FILLEN,COMAND,CMDLEN) IF (.NOT.COMPIL) GO TO 10 CALL MAKCOM(COMLIN,COMNAM,FILNAM,FILLEN,COMAND,CMDLEN) RETURN C C BASIC+2 - JUST ACCUMULATE COMMAND LINES 120 CONTINUE CALL BASIC (COMPIL,.FALSE.,COMLIN,FILNAM,FILLEN,COMAND,CMDLEN) GO TO 10 C C COMMAND I/O ERROR 130 CONTINUE TYPE 140 140 FORMAT(' CPL -- COMMAND I/O ERROR') CPLSTA = 4 GOTO 40 C C REDIRECTION FILE OPEN ERROR 150 CONTINUE MATPOS = MATPOS+1 160 CONTINUE TYPE 170,(COMLIN(I),I=MATPOS+1,COMLEN) 170 FORMAT (' CPL -- REDIRECTION FILE OPEN FAILURE - ',30A1) CPLSTA = 4 GO TO 40 C C EOF 180 CONTINUE CMDLEN = -1 RETURN END SUBROUTINE EXECOM(FILNAM,FILLEN,COMAND,CMDLEN,COMSTA,REPORT) IMPLICIT INTEGER (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE COMAND(1),FILNAM(1) INTEGER ASCPNT(2,5) BYTE ASCSTA(35) REAL*4 DATSTA(9) REAL*8 TIMBUF LOGICAL REPORT EQUIVALENCE (DATSTA,ASCSTA) DATA DATSTA/'NONE','WARN','INGS','UCCE','SSER','RORS','EVER', 1 'E ER','ROR '/ DATA ASCPNT/1,4,5,11,12,18,19,23,24,35/ C C WRITE COMMAND TO REDIRECTION FILE IF SELECTED IF (.NOT.ISSET(RCIS)) GO TO 20 WRITE (4,10) (COMAND(I),I=1,CMDLEN) 10 FORMAT (80A1) COMSTA = 1 RETURN C C EXECUTE COMPILE COMAND 20 CONTINUE COMSTA = 4 CALL RUNSYS(COMAND,CMDLEN,IER) IF (IER.GE.0) COMSTA = WAITSY() C C REPORT COMMAND COMPLETION IF (.NOT.REPORT) RETURN IF (STREQU(COMAND,BASCMD,3)) GO TO 50 ST = COMSTA+2 IF(ST.LE.0 .OR. ST.GE.6)ST = 5 CALL TIME(TIMBUF) TYPE 40,TIMBUF,(FILNAM(I),I = 1,FILLEN),(COMAND(I),I = 1,3), 1 (ASCSTA(I),I = ASCPNT(1,ST),ASCPNT(2,ST)) 40 FORMAT(1X,A8,2X,A1,T23,3A1,' Status: ',12A1) RETURN C C BASIC STATUS REPORT 50 CONTINUE CALL BASSTA (COMAND,ASCSTA,ASCPNT,COMSTA) RETURN END SUBROUTINE GETFIL(COMLIN,COMLEN,COMPOS,FILNAM,FILLEN,PREFIX) IMPLICIT INTEGER (A - Z) INTEGER PREFIX(3,10) BYTE FILNAM(1),COMLIN(1) C FILLEN = 0 DO 10 I = 1,10 !CHECK FOR PREFIX FILES CALL BREAK(COMLIN,COMLEN,COMPOS,'+ ,/',4,MATCH,MATPOS) IF (MATCH.NE.1) GO TO 20 PREFIX(1,I) = COMPOS PREFIX(2,I) = MATPOS-1 COMPOS = MATPOS+1 10 CONTINUE 20 CONTINUE IF (I.LE.10) PREFIX(1,I) = 0 DPOS = 1 CALL MOVE(COMLIN,COMPOS,MATPOS-1,FILNAM,DPOS) FILLEN = DPOS-1 COMPOS = MATPOS+1 IF(COMLIN(MATPOS).EQ.'/')COMPOS = MATPOS RETURN END SUBROUTINE GETSWI(COMLIN,COMLEN,COMPOS,SWTAB,SWNUM) IMPLICIT INTEGER (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE COMLIN(1) INTEGER SWTAB(5,1) C C CHECK FOR SWITCHES IF (COMLIN(COMPOS).NE.'/') RETURN MATPOS = COMPOS C C CHECK FOR CPL SWITCHES 10 CONTINUE POS = MATPOS+1 CALL BREAK(COMLIN,COMLEN,POS,':, /',4,MATCH,MATPOS) IF(MATCH.EQ.1)GOTO 30 SWLEN = MIN0(4,MATPOS-POS) DO 20 I = 1,GBLSWN IF (.NOT.STREQU(COMLIN(POS),GBLSWB(1,I),SWLEN)) GO TO 20 SWTAB(1,1) = SWTAB(1,1).OR.GBLSW4(2,I) IF(MATCH.LT.4)GOTO 70 GOTO 10 20 CONTINUE C C MUST BE A COMPILER SWITCH SWNUM = SWNUM+1 SWTAB(1,SWNUM) = POS-1 SWTAB(2,SWNUM) = POS+1 SWTAB(5,SWNUM) = MATPOS-1 IF (STREQU(COMLIN(POS),'NO',2)) SWTAB(2,SWNUM) = POS+SWLEN-1 !/NO... SWTAB(3,SWNUM) = 0 SWTAB(4,SWNUM) = 0 IF(MATCH.LT.4)GOTO 70 GOTO 10 C C GET SWITCH ARGUMENT 30 CONTINUE TPOS = POS TMAT = MATPOS BRAKET = 0 40 CONTINUE POS = MATPOS+1 CALL BREAK(COMLIN,COMLEN,POS,'[]+, /',6,MATCH,MATPOS) IF (MATCH.LT.1.OR.MATCH.GT.4) GO TO 50 IF (MATCH.EQ.1) BRAKET = BRAKET+1 IF (MATCH.EQ.2) BRAKET = BRAKET-1 IF (MATCH.EQ.3) COMLIN(MATPOS) = ',' IF (MATCH.NE.4.OR.BRAKET.NE.0) GO TO 40 50 CONTINUE IF (STREQU(COMLIN(TPOS),BUIL,MIN0(4,TMAT-TPOS))) GO TO 60 IF (STREQU(COMLIN(TPOS),LIBR,MIN0(4,TMAT-TPOS))) GO TO 65 SWNUM = SWNUM+1 SWTAB(1,SWNUM) = TPOS-1 SWTAB(2,SWNUM) = TPOS+1 SWTAB(5,SWNUM) = TMAT-1 SWTAB(3,SWNUM) = TMAT SWTAB(4,SWNUM) = MATPOS-1 GO TO 69 C C SPECIAL BUILD CPL SWITCH WITH ARGUMENTS FOR BASIC+2 60 CONTINUE SWTAB(1,1) = SWTAB(1,1).OR.BUSW BSWPOS = TMAT+1 BSWEND = MATPOS-1 GO TO 69 C C SPECIAL LIBRIAN CPL SWITCH WITH ARGUMENT (FILENAME) 65 CONTINUE SWTAB(1,1) = SWTAB(1,1).OR.LBSW LBRPOS = 1 CALL MOVE ('LBR ',1,4,LBRLIN,LBRPOS) CALL MOVE (COMLIN,TMAT+1,MATPOS-1,LBRLIN,LBRPOS) CALL MOVE ('/RP=',1,4,LBRLIN,LBRPOS) C 69 CONTINUE IF (MATCH.EQ.6) GO TO 10 C C END OF SWITCHES 70 CONTINUE IF(MATCH.NE.0)COMPOS = MATPOS+1 IF(MATCH.EQ.0)COMPOS = MATPOS RETURN END LOGICAL FUNCTION NEDCOM(COMLIN,FILNAM,FILLEN,COMNAM) IMPLICIT INTEGER (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE FILNAM(1),COMLIN(1) LOGICAL*1 UNIT1,UNIT2 REAL COMNAM C UNIT1 = .FALSE. UNIT2 = .FALSE. IF(FILLEN.EQ.0)GOTO 110 C C MOVE IN EXTENSION AND TRY TO OPEN FILE DO 10 I = 1,NOCOM IF (COMNAM.NE.0.AND.COMNAM.NE.COMEXT(I)) GO TO 10 DPOS = FILLEN+1 CALL MOVE(COMEXT(I),1,4,FILNAM,DPOS) FILNAM(DPOS) = 0 OPEN(UNIT=1,NAME=FILNAM,TYPE='OLD',READONLY,SHARED,ERR=10) UNIT1 = .TRUE. COMI = I GOTO 20 10 CONTINUE C GOTO 120 C C PREPARE CONCATENATE COMMAND IF THERE ARE PREFIX FILES 20 CONTINUE CATPOS = 1 IF (PREFIX(1,1).EQ.0) GO TO 50 CALL MOVE('PIP ',1,4,CATLIN,CATPOS) !PREPARE CONCATENATE COMMAND CALL MOVFIL (FILNAM,FILLEN,'.CPL/ME=',8,CATLIN,CATPOS) DO 30 I = 1,10 POS = CATPOS IF (PREFIX(1,I).EQ.0) GO TO 40 CALL MOVE(COMLIN,PREFIX(1,I),PREFIX(2,I),CATLIN,CATPOS) PREFIX(3,I) = CATPOS-1 CALL BREAK(CATLIN,CATPOS-1,POS,'.',1,MATCH,MATPOS) IF (MATCH.NE.1) CALL MOVE(COMEXT(COMI),1,4,CATLIN,CATPOS) CALL MOVE(',',1,1,CATLIN,CATPOS) PREFIX(1,I) = POS PREFIX(2,I) = CATPOS-1 30 CONTINUE 40 CONTINUE CALL MOVFIL (FILNAM,FILLEN,COMEXT(COMI),4,CATLIN,CATPOS) C C TRY TO FIND AN OBJ FILE UNLESS /FORCE OR /NOOBJ 50 CONTINUE IF (ISSET(FCSW.OR.NBSW)) GO TO 80 DPOS = FILLEN+1 CALL MOVE('.OBJ',1,4,FILNAM,DPOS) FILNAM(DPOS) = 0 OPEN(UNIT=2,NAME=FILNAM,TYPE='OLD',READONLY,SHARED,ERR=80) UNIT2 = .TRUE. C C OBJ EXISTS SO CHECK CREATION DATES IF(CKDATE(1,2))60,60,80 C C CHECK PREFIX FILE DATES IF ANY 60 CONTINUE DO 70 I = 1,10 IF (PREFIX(1,I).EQ.0) GO TO 110 CATLIN(PREFIX(2,I)) = 0 CLOSE (UNIT=1) UNIT1 = .FALSE. OPEN (UNIT=1,NAME=CATLIN(PREFIX(1,I)),TYPE='OLD',READONLY,SHARED, 1 ERR=150) UNIT1 = .TRUE. CATLIN(PREFIX(2,I)) = ',' IF(CKDATE(1,2))70,70,80 70 CONTINUE GO TO 110 C C FILE MUST BE COMPILED - CREATE CONCATENATED SOURCE IF NECESSARY 80 CONTINUE IF ((CATPOS.EQ.1).OR.(STREQU(COMCMD(COMI),BASCMD,3))) GO TO 90 GBLSW(1,1) = GBLSW(1,1).OR.DEIS !SET CONCATENATED FILE FOR DELETE CALL EXECOM(FILNAM,FILLEN,CATLIN,CATPOS-1,COMSTA,.FALSE.) IF (COMSTA.GT.1) GO TO 170 90 CONTINUE NEDCOM = .TRUE. COMNAM = COMCMD(COMI) 100 CONTINUE IF(UNIT1)CLOSE(UNIT=1) IF(UNIT2)CLOSE(UNIT=2) RETURN C C FILE NEED NOT BE COMPILED 110 CONTINUE NEDCOM = .FALSE. COMNAM = 0 GOTO 100 C C NO SUCH FILE 120 CONTINUE TYPE 130,(FILNAM(I),I = 1,FILLEN),(COMEXT(I),I = 1,NOCOM) 130 FORMAT(' CPL -- FILE NOT FOUND - ',A1,('(',A4,')')) 140 CONTINUE CPLSTA = 4 GOTO 110 C C PREFIX FILE NOT FOUND 150 CONTINUE TYPE 160,(CATLIN(J),J = PREFIX(1,I),PREFIX(2,I)-1) 160 FORMAT (' CPL -- PREFIX FILE NOT FOUND - ',30A1) GO TO 140 C C CONCATENATION FILE I/O ERROR 170 CONTINUE TYPE 180 180 FORMAT (' CPL -- CONCATENATION FILE ERROR') GO TO 140 END SUBROUTINE MAKCOM(COMLIN,COMNAM,FILNAM,FILLEN,COMAND,CMDLEN) IMPLICIT INTEGER (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE COMNAM(4),FILNAM(1),COMAND(80) C COMSTA = 1 C C SPECIAL RAT COMMAND LINE CONSTRUCTION IF (.NOT.STREQU(COMNAM,RATCMD,3)) GO TO 10 CALL RATMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) GO TO 70 C C SPECIAL NBS COMAND LINE CONSTRUCTION 10 CONTINUE IF (.NOT.STREQU(COMNAM,NBSCMD,2)) GO TO 20 CALL NBSMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) GO TO 70 C C SPECIAL C COMMAND LINE CONSTRUCTION 20 CONTINUE IF (.NOT.STREQU(COMNAM,CCMD,2)) GO TO 30 CALL CMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) GO TO 70 C C SPECIAL BASIC+2 COMMAND LINE CONSTRUCTION 30 CONTINUE IF (.NOT.STREQU(COMNAM,BASCMD,3)) GO TO 40 CALL BASMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,CMDLEN) GO TO 70 C C MCR COMMAND LINE CONSTRUCTION C C MOVE IN COMPILER NAME 40 CONTINUE DPOS = 1 CALL MOVE(COMNAM,1,4,COMAND,DPOS) C C MOVE IN OBJECT FILE UNLESS NBSW IF(.NOT.ISSET(NBSW))CALL MOVE(FILNAM,1,FILLEN,COMAND,DPOS) C C MOVE IN LISTING FILE IF LISW IF (CCOM.EQ.5) GO TO 60 IF(.NOT.ISSET(LISW))GOTO 50 CALL MOVE(',',1,1,COMAND,DPOS) CALL MOVE(FILNAM,1,FILLEN,COMAND,DPOS) IF(COMNAM(1).NE.'P')CALL MOVE('/-SP',1,4,COMAND,DPOS) IF(COMNAM(1).EQ.'P')CALL MOVE('/-U',1,3,COMAND,DPOS) GOTO 60 C C MOVE CL: SPOOLED LISTING IF PRSW 50 CONTINUE IF(.NOT.ISSET(PRSW))GOTO 60 CALL MOVE(',',1,1,COMAND,DPOS) CALL MOVE('CL0:',1,4,COMAND,DPOS) IF(COMNAM(1).NE.'P')CALL MOVE('/SP',1,3,COMAND,DPOS) IF(COMNAM(1).EQ.'P')CALL MOVE('/U',1,2,COMAND,DPOS) C C MOVE IN SOURCE FILE 60 CONTINUE CALL MOVE('=',1,1,COMAND,DPOS) CALL MOVE(FILNAM,1,FILLEN,COMAND,DPOS) IF (ISSET(DEIS).AND.RATCOM.EQ.1.AND.CCOM.NE.5) 1 CALL MOVE('.CPL',1,4,COMAND,DPOS) IF (CCOM.EQ.5) CALL MOVE('.CP2',1,4,COMAND,DPOS) IF (STREQU(COMNAM,SWECMD,3)) CALL MOVE(SWEEXT,1,4,COMAND,DPOS) C C MOVE IN USER SWITCHES CALL MOVSWI (COMLIN,2,COMAND,DPOS) C C RETURN COMMAND LENGTH CMDLEN = DPOS-1 70 CONTINUE RETURN END SUBROUTINE RATMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,DPOS) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE FILNAM(1),COMAND(1) C C SPECIAL RAT COMMAND LINE CONSTRUCTION DPOS = 1 IF (COMSTA.GT.1) GO TO 30 GO TO (10,20,30) RATCOM C C PASS 1 10 CONTINUE RATCOM = 2 CALL MOVE (RATCMD,1,4,COMAND,DPOS) IF (ISSET(SYSW)) CALL MOVE('/SYMBOLS ',1,9,COMAND,DPOS) CALL MOVE(FILNAM,1,FILLEN,COMAND,DPOS) !MOVE IN RAT SOURCE IF (ISSET(DEIS)) CALL MOVE('.CPL >',1,6,COMAND,DPOS) IF (.NOT.ISSET(DEIS)) CALL MOVE('.RAT >',1,6,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.FTN',4,COMAND,DPOS) DPOS = DPOS-1 RETURN C C PASS 2 20 CONTINUE RATCOM = 3 CALL MAKCOM (COMLIN,RATCM1,FILNAM,FILLEN,COMAND,DPOS) RETURN C C CLEAN UP AFTER RAT COMPILATION 30 CONTINUE RATCOM = 1 IF (ISSET(KESW).OR.(COMSTA.GT.1)) GO TO 40 CALL MOVE('PIP ',1,4,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.FTN;*/DE',9,COMAND,DPOS) CALL EXECOM(FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) 40 CONTINUE RETURN END SUBROUTINE NBSMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,DPOS) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE FILNAM(1),COMAND(1) C C SPECIAL NBS COMMAND LINE CONSTRUCTION DPOS = 1 IF (COMSTA.GT.1) GO TO 60 GO TO (10,40,60) NBSCOM C C PASS 1 10 CONTINUE NBSCOM = 2 CALL MOVE(NBSCMD,1,4,COMAND,DPOS) CALL MOVE('- ',1,2,COMAND,DPOS) CALL MOVE(FILNAM,1,FILLEN,COMAND,DPOS) IF (ISSET(DEIS)) CALL MOVE('.CPL ',1,5,COMAND,DPOS) IF (.NOT.ISSET(DEIS)) CALL MOVE('.PAS ',1,5,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.INT ',5,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.TMP ',5,COMAND,DPOS) IF (.NOT.ISSET(PRSW)) GO TO 20 CALL MOVE('CL0:',1,4,COMAND,DPOS) GO TO 30 20 CONTINUE CALL MOVFIL (FILNAM,FILLEN,'.LST',4,COMAND,DPOS) 30 CONTINUE DPOS = DPOS-1 RETURN C C PASS 2 40 CONTINUE NBSCOM = 3 CALL MOVE(NBSCM1,1,4,COMAND,DPOS) CALL MOVE('- ',1,2,COMAND,DPOS) IF (.NOT.ISSET(XTSW)) GO TO 50 DPOS = DPOS-1 CALL MOVE('X ',1,2,COMAND,DPOS) 50 CONTINUE CALL MOVFIL (FILNAM,FILLEN,'.INT ',5,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.TMP ',5,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.OBJ',4,COMAND,DPOS) GO TO 30 C C CLEAN UP AFTER NBS COMPILATION 60 CONTINUE NBSCOM = 1 IF (COMSTA.GT.1) LCLSW(1,1) = LCLSW(1,1).OR.LISW IF (ISSET(LISW).AND.ISSET(KESW)) GO TO 90 CALL MOVE('PIP ',1,4,COMAND,DPOS) IF (ISSET(LISW.OR.PRSW)) GO TO 70 CALL MOVFIL (FILNAM,FILLEN,'.LST;0/DE,',10,COMAND,DPOS) 70 CONTINUE IF (ISSET(KESW)) GO TO 80 CALL MOVFIL (FILNAM,FILLEN,'.INT;*/DE,.TMP;*,',17,COMAND,DPOS) 80 CONTINUE CALL EXECOM(FILNAM,FILLEN,COMAND,DPOS-2,TMPSTA,.FALSE.) 90 CONTINUE RETURN END SUBROUTINE CMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,DPOS) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE FILNAM(1),COMAND(1) REAL INTEXT(2:4),ERREXT(2:4) DATA INTEXT /'.CPP','.CP1','.CP2'/,ERREXT /'.CEP','.CE1','.CE2'/ C C SPECIAL C COMMAND LINE CONSTRUCTION DPOS = 1 IF (COMSTA.GT.1) GO TO 60 GO TO (10,30,40,50,60) CCOM C C PREPROCESSOR 10 CONTINUE CCOM = 2 CALL MOVE (CCMD,1,4,COMAND,DPOS) CALL MOVE ('-X -I LB:[1,1] -O ',1,18,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.CPP ',5,COMAND,DPOS) CALL MOVE (FILNAM,1,FILLEN,COMAND,DPOS) IF (.NOT.ISSET(DEIS))CALL MOVE ('.C',1,2,COMAND,DPOS) IF (ISSET(DEIS)) CALL MOVE('.CPL',1,4,COMAND,DPOS) 15 CONTINUE IF (.NOT.ISSET(LISW)) GO TO 20 CALL MOVE (' >',1,2,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,ERREXT(CCOM),4,COMAND,DPOS) 20 CONTINUE DPOS = DPOS-1 RETURN C C PASS 1 30 CONTINUE CCOM = 3 CALL MOVE (CCM1,1,4,COMAND,DPOS) CALL MOVE ('-O ',1,3,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.CP1 ',5,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.CPP',4,COMAND,DPOS) GO TO 15 C C PASS 2 40 CONTINUE CCOM = 4 CALL MOVE (CCM2,1,4,COMAND,DPOS) IF (.NOT.ISSET(INSW)) CALL MOVE('-F ',1,3,COMAND,DPOS) CALL MOVE ('-O ',1,3,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.CP2 ',5,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.CP1',4,COMAND,DPOS) GO TO 15 C C PASS 3 50 CONTINUE CCOM = 5 CALL MAKCOM (COMLIN,CCM3,FILNAM,FILLEN,COMAND,DPOS) RETURN C C INVOKE C LISTING UTILITY IF LISW AND CLEAN UP AFTER C COMPILATION 60 CONTINUE IF (.NOT.ISSET(LISW)) GO TO 65 CALL MOVE (CCM4,1,4,COMAND,DPOS) CALL MOVE (FILNAM,1,FILLEN,COMAND,DPOS) IF (.NOT.ISSET(DEIS)) CALL MOVE ('.C',1,2,COMAND,DPOS) IF (ISSET(DEIS)) CALL MOVE ('.CPL',1,4,COMAND,DPOS) DO 62 I = 2,MIN0(4,CCOM) CALL MOVE (' ',1,1,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,ERREXT(I),4,COMAND,DPOS) 62 CONTINUE CALL MOVE (' >',1,2,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.LST',4,COMAND,DPOS) CALL EXECOM (FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) 65 CONTINUE IF (ISSET(KESW)) GO TO 70 DPOS = 1 CALL MOVE('PIP ',1,4,COMAND,DPOS) CALL MOVE(FILNAM,1,FILLEN,COMAND,DPOS) DO 67 I = 2,MIN0(4,CCOM) CALL MOVE (INTEXT(I),1,4,COMAND,DPOS) CALL MOVE (';*,',1,3,COMAND,DPOS) IF (.NOT.ISSET(LISW)) GO TO 67 CALL MOVE (ERREXT(I),1,4,COMAND,DPOS) CALL MOVE (';*,',1,3,COMAND,DPOS) 67 CONTINUE DPOS = DPOS-1 CALL MOVE ('/DE',1,3,COMAND,DPOS) CALL EXECOM(FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) 70 CONTINUE CCOM = 1 RETURN END SUBROUTINE BASMAK (COMLIN,COMSTA,FILNAM,FILLEN,COMAND,DPOS) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' BYTE FILNAM(1),COMAND(1) C C SPECIAL BASIC+2 COMMAND LINE CONSTRUCTION DPOS = 1 GO TO (10,20) BASCOM 10 CONTINUE BASCOM = 2 CALL MOVE (BASCMD,1,4,COMAND,DPOS) CALL MOVE ('@COMPILE.CPL',1,12,COMAND,DPOS) DPOS = DPOS-1 RETURN C C SLP EDIT OF BASIC+2 ODL FILE FOR FASTER LINK 20 CONTINUE IF ((.NOT.ISSET(BUSW)).OR.(COMSTA.GT.1)) GO TO 50 OPEN (UNIT=6,NAME='SLIPPER.CPL',TYPE='NEW',CARRIAGECONTROL='LIST') WRITE (6,30) ((FILNAM(I),I = 1,FILLEN),J = 1,2) 30 FORMAT (A1,'.ODL=',A1,'.ODL') WRITE (6,40) 40 FORMAT ('\',/ 1 '-/RMSALL/,.',/ 1 ' .ROOT BASIC2-USER-LB:[1,1]RMSLIB/LB',/ 1 '-/RMS11X/,.',/ 1 '/') CLOSE (UNIT=6) CALL MOVE ('SLP @SLIPPER.CPL',1,16,COMAND,DPOS) CALL EXECOM (FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) DPOS = 1 C C CLEAN UP AFTER BASIC+2 COMPILATION 50 CONTINUE BASCOM = 1 IF (.NOT.NEDBAS) GO TO 80 CALL MOVE ('PIP COMPILE.CPL;*/DE',1,20,COMAND,DPOS) IF (ISSET(BUSW).AND.(COMSTA.EQ.1)) 1 CALL MOVE (',SLIPPER;*',1,10,COMAND,DPOS) CALL EXECOM (FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) IF (.NOT.ISSET(BUSW)) GO TO 80 DPOS = 5 IF (COMSTA.GT.1) GO TO 60 CALL MOVFIL (FILNAM,FILLEN,'.BLD;0/RE=',10,COMAND,DPOS) CALL MOVFIL (FILNAM,FILLEN,'.CMD',4,COMAND,DPOS) CALL EXECOM (FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) DPOS = 5+FILLEN CALL MOVE ('.ODL/PU,.BLD',1,12,COMAND,DPOS) GO TO 70 60 CONTINUE CALL MOVFIL (FILNAM,FILLEN,'.CMD;0/DE,.ODL;*',16,COMAND,DPOS) 70 CONTINUE CALL EXECOM (FILNAM,FILLEN,COMAND,DPOS-1,TMPSTA,.FALSE.) 80 CONTINUE RETURN END SUBROUTINE BASIC (COMPIL,BUILD,COMLIN,FILNAM,FILLEN,COMAND,CMDLEN) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' LOGICAL COMPIL,BUILD BYTE COMLIN(1),FILNAM(1),COMAND(1) INTEGER*4 LOC,OLD,APP,COM,BUI,EXI DATA LOC,OLD,APP,COM,BUI,EXI/'LOC ','OLD ','APP ','COM ','BUI ', 1 'EXI '/ C C OPEN COMMAND FILE UNLESS BASIC COMPILATION IS ALREADY PENDING IF (BUILD) GO TO 60 IF (ISSET(BPIS)) GO TO 10 GBLSW(1,1) = GBLSW(1,1).OR.BPIS NEDBAS = .FALSE. BLDPOS = 1 OPEN (UNIT=6,NAME='COMPILE.CPL',TYPE='NEW',CARRIAGECONTROL='LIST') C C ADD ANY NECESSARY COMMANDS 10 CONTINUE IF (.NOT.(COMPIL.OR.ISSET(BUSW))) GO TO 30 C C PREPARE LOC SWITCH AND ADD IT TO COMMAND FILE NEDBAS = .TRUE. LOCPOS = 1 CALL MOVSWI(COMLIN,5,COMAND,LOCPOS) IF (LOCPOS.EQ.1) GO TO 30 WRITE (6,20) LOC,(COMAND(I),I = 1,LOCPOS-1) 20 FORMAT (A4,80A1) C C ADD OLD, APPEND, AND COMPILE COMMANDS 30 CONTINUE IF (COMPIL) WRITE (6,20) OLD,(FILNAM(I),I = 1,FILLEN) CALL MOVFIL (FILNAM,FILLEN,',',1,BLDLIN,BLDPOS) IF (CATPOS.LE.1) GO TO 50 C C CONCATENATED COMPILATION IF (.NOT.COMPIL) GO TO 110 DO 40 J = 1,10 IF (PREFIX(1,J).EQ.0) GO TO 50 WRITE (6,20) APP,(CATLIN(I),I = PREFIX(1,J),PREFIX(3,J)) 40 CONTINUE 50 CONTINUE IF (COMPIL) WRITE (6,20) COM GO TO 110 C C ADD BUILD COMMAND AND SET COMMAND FILE TO EXECUTE 60 CONTINUE IF (.NOT.ISSET(BUSW)) GO TO 80 NEDBAS = .TRUE. IF (BSWPOS.LE.0) GO TO 70 CALL MOVE (COMLIN,BSWPOS,BSWEND,BLDLIN,BLDPOS) BLDPOS = BLDPOS+1 BSWPOS = 0 70 CONTINUE WRITE (6,20) BUI,(BLDLIN(I),I=1,BLDPOS-2) CALL BREAK (BLDLIN,BLDPOS-1,1,',',1,MATCH,MATPOS) FILLEN = 1 CALL MOVE (BLDLIN,1,MATPOS-1,FILNAM,FILLEN) FILLEN = FILLEN-1 80 CONTINUE IF (.NOT.NEDBAS) GO TO 100 WRITE (6,20) EXI CLOSE (UNIT=6) CALL MAKCOM (COMLIN,BASCMD,FILNAM,FILLEN,COMAND,CMDLEN) 90 CONTINUE GBLSW(1,1) = GBLSW(1,1).AND.(.NOT.BPIS) GO TO 110 C C NOTHING TO COMPILE OR BUILD 100 CONTINUE CLOSE (UNIT=6,DISPOSE='DELETE') CMDLEN = 0 GO TO 90 110 CONTINUE RETURN END SUBROUTINE BASSTA (BUFFER,ASCSTA,ASCPNT,COMSTA) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' LOGICAL NEDCOM,COMPIL BYTE BUFFER(80),ASCSTA(1) INTEGER ASCPNT(2,1) REAL COMNAM REAL*8 TIMBUF C C DETERMINE BASIC+2 STATUS BY READING COMMAND FILE COMSTA = 1 PREFIX(1,1) = 0 !NO PREFIX FILES FOR NEDCOM GBLSW(1,1) = GBLSW(1,1).AND.(.NOT.FCSW) !NO FORCE SWITCH FOR NEDCOM LCLSW(1,1) = LCLSW(1,1).AND.(.NOT.FCSW) C C FIND EACH OLD COMMAND IN FILE AND SEE IF AN OBJ WAS CREATED FOR THE FILE OPEN (UNIT=6,NAME='COMPILE.CPL',TYPE='OLD') 10 CONTINUE READ (6,20,END = 50) BUFLEN,BUFFER 20 FORMAT (Q,80A1) IF (.NOT.STREQU(BUFFER,'OLD',3)) GO TO 10 CALL TIME (TIMBUF) NUMOLD = NUMOLD+1 COMNAM = BASEXT COMPIL = NEDCOM(BUFFER,BUFFER(5),BUFLEN-4,COMNAM) IF (COMPIL) GO TO 40 TYPE 30,TIMBUF,(BUFFER(I),I = 5,BUFLEN),BASCMD, 1 (ASCSTA(I),I = ASCPNT(1,3),ASCPNT(2,3)) 30 FORMAT (1X,A8,2X,A1,T23,A4,' Status: ',12A1) IF (ISSET(LBSW)) 1 CALL LBRMAK(.FALSE.,BUFFER(5),BUFLEN-4,BUFFER,I) GO TO 10 40 CONTINUE TYPE 30,TIMBUF,(BUFFER(I),I = 5,BUFLEN),BASCMD, 1 (ASCSTA(I),I = ASCPNT(1,5),ASCPNT(2,5)) COMSTA = 4 GO TO 10 50 CONTINUE CLOSE (UNIT=6) RETURN END SUBROUTINE LBRMAK (EXECUT,FILNAM,FILLEN,COMAND,CMDLEN) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' LOGICAL EXECUT BYTE FILNAM(1),COMAND(1) C IF (EXECUT) GO TO 20 NEDLBR = .TRUE. CALL MOVFIL (FILNAM,FILLEN,',',1,LBRLIN,LBRPOS) RETURN 20 CONTINUE NEDLBR = .FALSE. GBLSW(1,1) = GBLSW(1,1).AND.(.NOT.LBSW) CMDLEN = 1 CALL MOVE (LBRLIN,1,LBRPOS-2,COMAND,CMDLEN) CMDLEN = CMDLEN-1 LBRPOS = 0 FILLEN = 1 FILNAM(1) = ' ' RETURN END SUBROUTINE MOVSWI (COMLIN,SWIEND,COMAND,DPOS) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' C BYTE COMLIN(1),COMAND(1) C IF(GBLNM.LE.1)GOTO 20 DO 10 I = 2,GBLNM CALL MOVE(COMLIN,GBLSW(1,I),GBLSW(SWIEND,I),COMAND,DPOS) IF(GBLSW(3,I).EQ.0)GOTO 10 CALL MOVE(COMLIN,GBLSW(3,I),GBLSW(4,I),COMAND,DPOS) 10 CONTINUE C 20 CONTINUE IF(LCLNM.LE.1)GOTO 40 DO 30 I = 2,LCLNM CALL MOVE(COMLIN,LCLSW(1,I),LCLSW(SWIEND,I),COMAND,DPOS) IF(LCLSW(3,I).EQ.0)GOTO 30 CALL MOVE(COMLIN,LCLSW(3,I),LCLSW(4,I),COMAND,DPOS) 30 CONTINUE 40 CONTINUE RETURN END INTEGER FUNCTION CKDATE(LUN1,LUN2) IMPLICIT INTEGER (A - Z) INCLUDE 'QIOSYS.FTN/NOLIST' INCLUDE 'FHSYM.FTN/NOLIST' BYTE HDRBUF(0:511) INTEGER DPB(6),ATTLST(3),IOST(2) BYTE DATE(13,2),MONTHS(48) REAL RMONTH(12) INTEGER CMPDAT(6,2),LUN(2) LOGICAL STREQU EQUIVALENCE (MONTHS,RMONTH) DATA RMONTH/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG', 1 'SEP','OCT','NOV','DEC'/ C DATA DPB/6*0/,ATTLST/"366,0,0/ DATA HDRBUF/512*1HX/ C C GET CREATION DATES LUN(1) = LUN1 LUN(2) = LUN2 CALL GETADR(ATTLST(2),HDRBUF) CALL GETADR(DPB(2),ATTLST) DO 10 I = 1,2 CALL WTQIO(IORAT,LUN(I),1,,IOST,DPB,DSW) DPOS = 1 CALL MOVE(HDRBUF(HDRBUF(HIDOF)*2),ICRDT+1,ICRTI+6,DATE(1,I),DPOS) 10 CONTINUE C C CHECK DATES DO 40 I = 1,2 C C DECODE DAY,YEAR,HOUR,MINUTE,SECOND DECODE(13,20,DATE(1,I))CMPDAT(3,I),CMPDAT(1,I),CMPDAT(4,I),CMPDAT(5,I), 1 CMPDAT(6,I) 20 FORMAT(I2,3X,4I2) C C DECODE MONTH DO 30 J = 1,48,4 IF (.NOT.STREQU(MONTHS(J),DATE(3,I),3)) GO TO 30 CMPDAT(2,I) = J/4+1 GOTO 40 30 CONTINUE 40 CONTINUE C C RETURN DIFFERENCE DO 50 I = 1,6 CKDATE = CMPDAT(I,1)-CMPDAT(I,2) IF(CKDATE)60,50,60 50 CONTINUE C C CKDATE HAS DIFFENENCE 60 CONTINUE RETURN END SUBROUTINE MOVFIL (FILNAM,FILLEN,EXT,EXTLEN,COMAND,DPOS) C ROUTINE TO MOVE A FILNAME/EXTENTION INTO THE COMMAND LINE C IMPLICIT INTEGER*2 (A - Z) C CALL MOVE (FILNAM,1,FILLEN,COMAND,DPOS) CALL MOVE (EXT,1,EXTLEN,COMAND,DPOS) RETURN END SUBROUTINE MOVE(SOURCE,SBEG,SEND,DESTIN,DPOS) C ROUTINE TO MOVE CHARACTERS FROM SOURCE TO DESTIN C C INPUTS C SOURCE - SOURCE CHARACTER STRING C SBEG - STARTING POINT IN SOURCE OF MOVE C SEND - ENDING POINT C DPOS - STARTING POINT IN DESTIN OF MOVE C C OUTPUTS C DESTIN - TARGET CHARACTER STRING CONTAINING SOURCE C DPOS - ENDING POINT+1 OF DESTIN C IMPLICIT INTEGER (A - Z) BYTE SOURCE(1),DESTIN(1) C IF(SBEG.GT.SEND)GOTO 20 DO 10 I = SBEG,SEND DESTIN(DPOS) = SOURCE(I) DPOS = DPOS+1 10 CONTINUE C 20 CONTINUE RETURN END SUBROUTINE BREAK(LINE,LEN,POS,BRKSTR,BRKLEN,MATCH,MATPOS) C ROUTINE TO BREAK (IN SNOBOL FASHION) ON ENCOUNTERING A GIVEN C CHARACTER FROM BRKSTR IN LINE C C INPUTS C LINE - STRING CONTAINING CHARACTERS TO BE MATCHED C LEN - LENGTH OF LINE C POS - POSITION TO START STRING MATCH SEARCH C BRKSTR - STRING CONTAINING CHARACTERS TO MATCH C BRKLEN - LENGTH OF BRKSTR C C OUTPUTS C MATCH - CHARACTER POSITION IN BRK THAT MATCHED C MATPOS - CHARACTER POSITION IN LINE THAT MATCHED BRKSTR(MATCH) C IMPLICIT INTEGER (A - Z) BYTE LINE(LEN),BRKSTR(BRKLEN) C IF(POS.GT.LEN)GOTO 40 DO 20 I = POS,LEN DO 10 J = 1,BRKLEN IF(LINE(I).EQ.BRKSTR(J))GOTO 30 10 CONTINUE 20 CONTINUE GOTO 40 C 30 CONTINUE MATCH = J MATPOS = I RETURN C 40 CONTINUE MATCH = 0 MATPOS = LEN+1 RETURN END FUNCTION ISSET(SWITCH) IMPLICIT INTEGER*2 (A - Z) INCLUDE 'CPLGBLSWI.COM/NOLIST' C ISSET = ((GBLSW(1,1).OR.LCLSW(1,1)).AND.SWITCH).NE.0 RETURN END LOGICAL FUNCTION STREQU (STR1,STR2,LEN) IMPLICIT INTEGER*2 (A - Z) BYTE STR1(1),STR2(1) C STREQU = .FALSE. DO 10 I = 1,LEN IF (STR1(I).NE.STR2(I)) RETURN 10 CONTINUE STREQU = .TRUE. RETURN END