FUNCTION IPSKIP() ! Skip blanks and tabs. INCLUDE 'IPCOMM' INTEGER*2 IILO ! Character. IILOC = IPSLOC ! Save location. GO TO 1010 ! "Pre-test" loop. 1000 IPSLOC = IPSLOC + 1 ! Go to next IPSLEN = IPSLEN - 1 ! char. 1010 IF (IPSLEN .LE. 0) GO TO 1020 ! If at end, done. IILO = IPBUF(IPSLOC) .AND. "177 ! Get next char. IF (IILO .EQ. "40) GO TO 1000 ! If a space, skip. IF (IILO .EQ. "11) GO TO 1000 ! If a tab, skip. 1020 IPSKIP = (IILOC .NE. IPSLOC) ! Tell if anything skpd. RETURN ! Return. END FUNCTION IPCHAR(ICH) ! Match a byte. LOGICAL*1 ICH ! Character to match. INCLUDE 'IPCOMM' INTEGER*2 IILOC ! Initial string location. INTEGER*2 IILEN ! Initial string length. IPCHAR = .FALSE. ! Assume no match. IILOC = IPSLOC ! Save current location. IILEN = IPSLEN ! Save current length. IF (IPSKFG) ! If blanks and tabs are ignored, 1 CALL IPSKIP ! skip over leading ones. IPLOC = IPSLOC ! Save byte location. IPLEN = IPSLEN ! Save byte length. IF (IPSLEN .LE. 0) GO TO 9000 ! If out of string, no match. IPMCH = IPBUF(IPLOC) ! Get the character. IF (ICH .NE. IPMCH) GO TO 9000 ! If no match, no match. IPSLOC = IPSLOC + 1 ! Update location in string. IPSLEN = IPSLEN - 1 ! Update length. IPLEN = IPLEN - IPSLEN ! Length for action. IPCHAR = .TRUE. ! Return a match. RETURN ! Return to caller. 9000 IPSLOC = IILOC ! Restore string location IPSLEN = IILEN ! and length. IPLOC = IPSLOC ! Set syntax element loc and IPLEN = 0 ! length to standard values. RETURN ! Return to caller. END FUNCTION IPNUM(IRDX) ! Match a number. INTEGER*2 IRDX ! Radix. INCLUDE 'IPCOMM' INTEGER*2 IIDGIT ! Next digit of number. INTEGER*2 IILOC ! Initial string location. INTEGER*2 IILEN ! Initial string length. INTEGER*2 IINUS ! .TRUE. to accept a null string. INTEGER*2 IIRDX ! Actual radix. IPNUM = .FALSE. ! Assume no match. IILOC = IPSLOC ! Save current location. IILEN = IPSLEN ! Save current length. IF (IPSKFG) ! If blanks and tabs are ignored, 1 CALL IPSKIP ! skip over leading ones. IPLOC = IPSLOC ! Save string location. IPLEN = IPSLEN ! Save string length. IF (IPSLEN .LE. 0) GO TO 9000 ! If out of string, no match. IINUS = (IRDX .LT. 0) ! Pick up null string flag. IIRDX = ABS(IRDX) ! Absolute value of radix. IIRDX = MAX(IRDX,2) ! Radix must be >= 2. IPVALU = 0 ! Init the value. 2000 CONTINUE ! Top of loop. IIDGIT = IPBUF(IPSLOC) ! Get the next digit. IIDGIT = IIDGIT - "60 ! Knock off ASCII zero. IF (IIDGIT .LT. 0) GO TO 2200 ! If not legal, done. IF (IIDGIT .LE. 9) GO TO 2020 ! If a normal number, OK. IF (IIDGIT .LE. 16) GO TO 2200 ! If non-numeric, done. IIDGIT = IIDGIT - 7 ! Adjust for radix > 10. 2020 IF (IIDGIT .GE. IIRDX) ! If digit not legal in this 1 GO TO 2200 ! radix, done. IPVALU = IPVALU*IIRDX + IIDGIT ! Accumulate. IPSLOC = IPSLOC + 1 ! Update buffer location IPSLEN = IPSLEN - 1 ! and length. IF (IPSLEN .GT. 0) GO TO 2000 ! If have more, proceed. 2200 CONTINUE IPLEN = IPLEN - IPSLEN ! Length for action. IF (IPLEN .LE. 0 .AND. ! If null, and if null illegal, 1 .NOT. IINUS) GO TO 9000 ! no match. IPNUM = .TRUE. ! Return a match. RETURN ! Return to caller. 9000 IPSLOC = IILOC ! Restore string location IPSLEN = IILEN ! and length. IPLOC = IPSLOC ! Set syntax element loc and IPLEN = 0 ! length to standard values. RETURN ! Return to caller. END FUNCTION IPSTR(ISIZ,IMAT,IALEN) ! Match a string. INTEGER*2 ISIZ ! Size of string to match. INTEGER*2 IALEN ! Maximum allowed length. LOGICAL*1 IMAT(ISIZ) ! String to match. (Decl. deferred). INCLUDE 'IPCOMM' INTEGER*2 IILOC ! Initial string location. INTEGER*2 IILEN ! Initial string length. INTEGER*2 IISX ! String index. IPSTR = .FALSE. ! Assume false. IILOC = IPSLOC ! Save current location. IILEN = IPSLEN ! Save current length. IF (IPSKFG) ! If blanks and tabs are ignored, 1 CALL IPSKIP ! skip over leading ones. IPLOC = IPSLOC ! Save string location. IPLEN = IPSLEN ! Save string length. IF (IPSLEN .LE. 0) GO TO 9000 ! If out of string, no match. IISX = 0 ! Init. the string index. IPSLOC = IPSLOC - 1 ! Init. buffer location IPSLEN = IPSLEN + 1 ! and length. 4000 IISX = IISX + 1 ! Bump the string index. IPSLOC = IPSLOC + 1 ! Update buffer location IPSLEN = IPSLEN - 1 ! and length. IF (IISX .GT. ISIZ) GO TO 4500 ! If end of match string, exit. IF (IPSLEN .LE. 0) GO TO 4400 ! If at end of buffer, exit. IF (IMAT(IISX) .EQ. IPBUF(IPSLOC)) ! If a match, 1 GO TO 4000 ! loop. 4400 IF (IALEN .LE. 0) GO TO 9000 ! If wanted exact match, failed. IF (IISX .LE. IALEN) GO TO 9000 ! If not enough chars, failed. GO TO 4900 ! Got a match. 4500 IF (IALEN .LE. 0) GO TO 4900 ! We have our exact match. IF (IISX .LE. IALEN) GO TO 9000 ! If not enough chars, failed. GO TO 4900 ! Got a match. 4900 IF (IPSLEN .LE. 0) GO TO 4950 ! If at end of buffer, OK. IF (IPBUF(IPSLOC) .LT. 48) ! If next character in buffer 1 GO TO 4950 ! not alphanumeric, OK. IF (IPBUF(IPSLOC) .LT. 58) ! If next character in buffer 1 GO TO 9000 ! is numeric, an error. IF (IPBUF(IPSLOC) .LT. 65) ! If next character in buffer 1 GO TO 4950 ! not alphanumeric, OK. IF (IPBUF(IPSLOC) .LT. 91) ! If next character in buffer 1 GO TO 9000 ! alphabetic, an error. 4950 IPLEN = IPLEN - IPSLEN ! Length for action. IPSTR = .TRUE. ! Return a match. RETURN ! Return to caller. 9000 IPSLOC = IILOC ! Restore string location IPSLEN = IILEN ! and length. IPLOC = IPSLOC ! Set syntax element loc and IPLEN = 0 ! length to standard values. RETURN ! Return to caller. END FUNCTION IPMSET(IALEN,IMASK) ! Match arbitrary ASCII subset. INTEGER*2 IALEN ! Maximum allowed length. INTEGER*2 IMASK(8) ! Mask to match. INCLUDE 'IPCOMM' INTEGER*2 IIBITS(16) ! Bits in mask. INTEGER*2 IIHI ! Most signif. bits in byte. INTEGER*2 IILO ! Least signif. bits in byte. INTEGER*2 IILOC ! Initial string location. INTEGER*2 IILEN ! Initial string length. DATA IIBITS /"1,"2,"4,"10,"20,"40,"100,"200,"400,"1000, 1 "2000,"4000,"10000,"20000,"40000,"100000/ IPMSET = .FALSE. ! Assume no match. IILOC = IPSLOC ! Save current location. IILEN = IPSLEN ! Save current length. IF (IPSKFG) ! If blanks and tabs are ignored, 1 CALL IPSKIP ! skip over leading ones. IPLOC = IPSLOC ! Save byte location. IPLEN = IPSLEN ! Save byte length. IF (IPSLEN .LE. 0) GO TO 9000 ! If out of string, no match. 1400 IILO = IPBUF(IPSLOC) .AND. "177 ! Get the character. IIHI = IILO/16 ! Get table offset. IILO = IILO - (IIHI*16) + 1 ! Get bit number. IIHI = IIHI + 1 ! Get table entry no. IF ((IMASK(IIHI) .AND. IIBITS(IILO)) ! If no match, 1 .EQ. 0) GO TO 1450 ! get out of loop. IPSLOC = IPSLOC + 1 ! Update position and IPSLEN = IPSLEN - 1 ! length of string. IF (IPSLEN .GT. 0) GO TO 1400 ! If more, check it. 1450 IPLEN = IPLEN - IPSLEN ! Length for action. IF (IPLEN .GT. IALEN ! If too long and 1 .AND. IALEN .GT. 0) ! length checking enabled, 2 GO TO 9000 ! quit. IF (IPSLOC .LE. IPLOC) ! If matched nothing, 1 GO TO 9000 ! quit. IPMSET = .TRUE. ! Return a match. RETURN ! Return to caller. 9000 IPSLOC = IILOC ! Restore string location IPSLEN = IILEN ! and length. IPLOC = IPSLOC ! Set syntax element loc and IPLEN = 0 ! length to standard values. RETURN ! Return to caller. END FUNCTION IPALFA(IALEN) ! Match an alphabetic. INTEGER*2 IALEN ! Maximum allowed length. INCLUDE 'IPCOMM' INTEGER*2 IALMSK(8) ! Alphabetic match mask. INTEGER*2 IANMSK(8) ! Alphanumeric match mask. INTEGER*2 IR5MSK(8) ! Rad-50 match mask. DATA IALMSK /0,0,0,0,"177776,"3777,0,0/ DATA IANMSK /0,0,0,"1777,"177776,"3777,0,0/ DATA IR5MSK /0,0,"40020,"1777,"177776,"3777,0,0/ IPALFA = IPMSET(IALEN,IALMSK) ! Let general string matcher C ! do all the work. RETURN ! Return to caller. ENTRY IPANUM ! Match an alphanumeric. IPALFA = IPMSET(IALEN,IANMSK) ! Let general string matcher C ! do all the work. RETURN ! Return to caller. ENTRY IPR50 ! Match RAD-50. IPALFA = IPMSET(IALEN,IR5MSK) ! Let general string matcher C ! do all the work. RETURN ! Return to caller. END FUNCTION IPANY() ! Match any character. INCLUDE 'IPCOMM' IPANY = .TRUE. ! Assume we have one. IISIZ = 1 ! Want one char. for match. GO TO 100 ! Enter common code. ENTRY IPEOS ! Match end-of-string. IPANY = .FALSE. ! Assume no match. IISIZ = 0 ! Want no char. for match. 100 IPLOC = IPSLOC ! Assume the location IPLEN = 0 ! for a nomatch. IILOC = IPSLOC ! Save current location. IILEN = IPSLEN ! Save current length. IF (IPSKFG) ! If blanks and tabs are ignored, 1 CALL IPSKIP ! skip over leading ones. IF (IPSLEN .LE. 0) ! If none left, 1 IPANY = .NOT. IPANY ! Negate result. IF (.NOT. IPANY) GO TO 900 ! If no match, quit. IPLOC = IPSLOC ! Get location IPLEN = IISIZ ! and length IF (IISIZ .LE. 0) GO TO 890 ! If no char, return. IPMCH = IPBUF(IPLOC) ! Get the char. IPSLOC = IPSLOC + 1 ! Skip over the IPSLEN = IPSLEN - 1 ! character. 890 RETURN ! Success. 900 IPSLOC = IILOC ! Restore the original location IPSLEN = IILEN ! and length. RETURN ! Return to caller. END