<![CDATA[
/* Copyright (c) 1995 by R. A. Vowels, from "Introduction to PL/I, Algorithms, and */
/* Structured Programming". Permission is given to reproduce and to use these procedures */
/* as part of a program, and to include them as part of a larger work to be sold for profit. */
/* However, the user is not permitted to sell the procedures separately. Provided always */
/* that these procedures and this copyright notice are reproduced in full. */
DECLARE VERIFYR GENERIC
(VERIFYR_all_graphic WHEN (GRAPHIC, GRAPHIC),
VERIFYR_all_graphic WHEN (GRAPHIC, *),
VERIFYR_all_graphic WHEN (GRAPHIC, GRAPHIC),
VERIFYR_all WHEN (*,*),
VERIFYR_sub_graphic WHEN (GRAPHIC, GRAPHIC,*),
VERIFYR_sub_graphic WHEN (GRAPHIC, *,*),
VERIFYR_sub_graphic WHEN (*, GRAPHIC, *),
VERIFYR_sub WHEN (*,*,*) );
/* Strategy for GRAPHIC arguments: The look-up table is large. To avoid initializing */
/* it on each call, it is initialized at compile time. On entry, a small number of table */
/* entries are set in preparation for the search. These entries are reset before exit, */
/* so that the table is already prepared for the next function reference. */
/* If these functions are called with a very long second argument, use the strategy of */
/* VERIFYR_sub. */
/* This function procedure searches the first string STRING for any characters that do */
/* not exist in second string SUB. If there are any such characters, the function returns */
/* the position of the right-most. */
VERIFYR_all:
PROCEDURE (STRING, SUB) OPTIONS (REORDER)
RETURNS (FIXED BINARY (31));
/* INCOMING: STRING = the string to be searched; */
/* SUB = contains characters to look for. */
DECLARE (STRING, SUB) CHARACTER (*);
DECLARE Table (0:255) BIT (1) STATIC ALIGNED;
DECLARE (J, K) FIXED BINARY (31);
IF LENGTH (STRING) = 0 THEN /* There's nothing to search. */
RETURN (0);
IF LENGTH (SUB) = 0 THEN /* Nothing with which to search. */
RETURN (LENGTH(String));
IF LENGTH (SUB) = 1 THEN /* Looking for one character is fast. */
DO;
DO J = LENGTH (String) TO 1 BY -1;
IF SUBSTR(STRING, J, 1) ^= SUB THEN
RETURN (J);
END;
RETURN (0); /* Unsuccessful search. */
END;
/* SETS UP A LOOK-UP TABLE (which is independent of character set). */
Table = '1'B; /* All entries are TRUE. */
DO J = 1 TO LENGTH (Sub);
K = UNSPEC (SUBSTR (Sub, J, 1));
Table (K) = '0'B; /* Table(k) is FALSE for each character in SUB. */
END;
/* CONDUCT THE SEARCH (backwards). */
DO J = LENGTH (STRING) TO 1 BY -1;
K = UNSPEC (SUBSTR (STRING, J, 1));
IF Table(K) THEN /* TRUE when a SUB character does not match one */
RETURN (J); /* in STRING. */
END;
RETURN (0); /* Unsuccessful search. */
END VERIFYR_all;
/* This function procedure searches the first string STRING for any characters that do */
/* not exist in second string SUB. If there are any such characters, the function returns */
/* the position of the right-most. */
/* The search is performed from right to left, commencing from character position POSITION. */
VERIFYR_sub:
PROCEDURE (STRING, SUB, POSITION) OPTIONS (REORDER)
RETURNS (FIXED BINARY (31));
/* INCOMING: STRING = the string to be searched; */
/* SUB = contains characters to look for; */
/* POSITION = where to start the search (measured from the left-hand end of */
/* STRING). */
DECLARE (STRING, SUB) CHARACTER (*);
DECLARE POSITION FIXED BINARY (31);
DECLARE Table (0:255) BIT (1) STATIC ALIGNED;
DECLARE (J, K) FIXED BINARY (31);
IF (Position > LENGTH (String) ) | (Position < 0) THEN
DO;
SIGNAL STRINGRANGE;
RETURN (0);
END;
IF LENGTH (STRING) = 0 THEN /* There's nothing to search. */
RETURN (0);
IF LENGTH (SUB) = 0 THEN /* Nothing with which to search. */
RETURN (Position);
IF LENGTH (SUB) = 1 THEN /* Looking for one character is fast. */
DO;
DO J = POSITION TO 1 BY -1;
IF SUBSTR(STRING, J, 1) ^= SUB THEN
RETURN (J);
END;
RETURN (0); /* Unsuccessful search. */
END;
/* SETS UP A LOOK-UP TABLE (which is independent of character set). */
Table = '1'B; /* All entries are TRUE. */
DO J = 1 TO LENGTH (Sub);
K = UNSPEC (SUBSTR (Sub, J, 1));
Table (K) = '0'B; /* Table(k) is FALSE for each character in SUB. */
END;
/* CONDUCT THE SEARCH (backwards). */
DO J = POSITION TO 1 BY -1;
K = UNSPEC (SUBSTR (STRING, J, 1));
IF Table(K) THEN /* TRUE when a SUB character does not match one */
RETURN (J); /* in STRING. */
END;
RETURN (0); /* Unsuccessful search. */
END VERIFYR_sub;
/* This function procedure searches the first string STRING for any graphic characters that */
/* do not exist in second string SUB. If there are any such characters, the function */
/* returns the position of the right-most. */
VERIFYR_all_graphic:
PROCEDURE (STRING, SUB) OPTIONS (REORDER)
RETURNS (FIXED BINARY (31));
/* INCOMING: STRING = the string to be searched; */
/* SUB = contains characters to look for. */
DECLARE (STRING, SUB) GRAPHIC (*);
DECLARE Table (0:65535) BIT (1) STATIC ALIGNED INITIAL ( (65536)(1)'1'B ),
Table_Set BIT(1) STATIC INITIAL ( '1'B);
DECLARE (J, K, L) FIXED BINARY (31);
IF LENGTH (STRING) = 0 THEN /* There's nothing to search. */
RETURN (0);
IF LENGTH (SUB) = 0 THEN /* Nothing with which to search. */
RETURN (LENGTH(String));
IF LENGTH (SUB) = 1 THEN /* Looking for one character is fast. */
DO;
DO J = LENGTH (String) TO 1 BY -1;
IF SUBSTR(STRING, J, 1) ^= SUB THEN
RETURN (J);
END;
RETURN (0); /* Unsuccessful search. */
END;
/* SETS UP A LOOK-UP TABLE (which is independent of character set). */
IF ^Table_Set THEN
Table = '1'B; /* All entries are TRUE. */
Table_Set = '0'B;
DO L = 1 TO LENGTH (Sub);
K = UNSPEC (SUBSTR (Sub, L, 1));
Table (K) = '0'B; /* Table(k) is FALSE for each character in SUB. */
END;
/* CONDUCT THE SEARCH (backwards). */
DO J = LENGTH (STRING) TO 1 BY -1;
K = UNSPEC (SUBSTR (STRING, J, 1));
IF Table(K) THEN /* TRUE when a SUB character does not match one */
LEAVE; /* in STRING. */
END;
/* RESTORE THE TABLE */
DO L = 1 TO LENGTH (Sub);
K = UNSPEC (SUBSTR (Sub, L, 1));
Table (K) = '1'B; /* Table(k) is TRUE for each character in SUB. */
END;
Table_Set = '1'B;
RETURN (J);
END VERIFYR_all_graphic;
/* This function procedure searches the first string STRING for any graphic characters that */
/* do not exist in second string SUB. If there are any such characters, the function */
/* returns the position of the right-most. */
/* The search is performed from right to left, commencing from character position POSITION. */
VERIFYR_sub_graphic:
PROCEDURE (STRING, SUB, POSITION) OPTIONS (REORDER)
RETURNS (FIXED BINARY (31));
/* INCOMING: STRING = the string to be searched; */
/* SUB = contains characters to look for; */
/* POSITION = where to start the search (measured from the left-hand end of */
/* STRING). */
DECLARE (STRING, SUB) GRAPHIC (*);
DECLARE POSITION FIXED BINARY (31);
DECLARE Table (0:65535) BIT (1) STATIC ALIGNED INITIAL ( (65536)(1)'1'B ),
Table_Set BIT (1) STATIC INITIAL ( '1'B );
DECLARE (J, K, L) FIXED BINARY (31);
IF (Position > LENGTH (String) ) | (Position < 0) THEN
DO;
SIGNAL STRINGRANGE;
RETURN (0);
END;
IF LENGTH (STRING) = 0 THEN /* There's nothing to search. */
RETURN (0);
IF LENGTH (SUB) = 0 THEN /* Nothing with which to search. */
RETURN (Position);
IF LENGTH (SUB) = 1 THEN /* Looking for one character is fast. */
DO;
DO J = POSITION TO 1 BY -1;
IF SUBSTR(STRING, J, 1) ^= SUB THEN
RETURN (J);
END;
RETURN (0); /* Unsuccessful search. */
END;
/* SETS UP A LOOK-UP TABLE (which is independent of character set). */
IF ^Table_Set THEN
Table = '1'B; /* All entries are TRUE. */
Table_Set = '0'B;
DO L = 1 TO LENGTH (Sub);
K = UNSPEC (SUBSTR (Sub, L, 1));
Table (K) = '0'B; /* Table(k) is FALSE for each character in SUB. */
END;
/* CONDUCT THE SEARCH (backwards). */
DO J = POSITION TO 1 BY -1;
K = UNSPEC (SUBSTR (STRING, J, 1));
IF Table(K) THEN /* TRUE when a SUB character does not match one */
RETURN (J); /* in STRING. */
END;
DO L = 1 TO LENGTH (Sub);
K = UNSPEC (SUBSTR (Sub, L, 1));
Table (K) = '1'B; /* Table(k) is TRUE for each character in SUB. */
END;
Table_Set = '1'B;
RETURN (J);
END VERIFYR_sub_graphic;
]]>