<![CDATA[
/* Copyright (c) 1996, 1998 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 EDIT GENERIC
(EDIT_DECIMAL WHEN (FIXED DECIMAL, *),
EDIT_char WHEN (CHARACTER, *) );
/* This function provides only an approximation to the facilities of the EDIT built-in */
/* function for decimal data. */
/* The following PICTURE characters are implemented for DECIMAL data: */
/* +, -, S, Z, 9, comma (,), period (.), slash (/), B, V, $, Cr, and DB. */
/* A user-defined currency symbol is also allowed: e.g., in the picture '<Fr>>>>9V.99'. */
/* +, -, S, $, and a user-defined currency symbol are allowed as drifting characters. */
/* This function implement signs and a static user-defined currency symbol at the end */
/* of a value. */
/* It does not implement the scale factor F or exponent E or K facility. */
/* NOTE: the declaration of VALUE may need to be altered depending on the attributes */
/* of the corresponding argument. */
/* Written by R. A. Vowels. */
/* Date extended: 12 July 1998. Amended 5 January 1999. */
EDIT_DECIMAL:
PROCEDURE (VALUE, LAYOUT) RETURNS (CHARACTER(100) VARYING);
/* INCOMING: VALUE = the FIXED DECIMAL value to be converted; */
/* LAYOUT = the PICTURE specification as required by the EDIT built-in function. */
DECLARE VALUE FIXED DECIMAL (15,7); /* The value to be edited. */
DECLARE LAYOUT CHARACTER (*); /* A PICTURE specification. */
DECLARE SVALUE CHARACTER (LENGTH(VALUE) );
DECLARE TEMP CHARACTER (LENGTH(LAYOUT) );
DECLARE (J, J1, K, K1, N) FIXED BINARY;
DECLARE (CH, CH2, CH3, CH4) CHARACTER (1);
DECLARE (SIGN, CRDB) BIT (1);
DECLARE Currency_Symbol CHARACTER (10) VARYING INITIAL ('');
DECLARE Trailing_Currency_Symbol CHARACTER (10) VARYING INITIAL ('');
DECLARE (Zero, Drifting) BIT (1);
DECLARE Seen_Drifting_Specifier BIT (1);
TEMP = LAYOUT;
N = LENGTH (LAYOUT);
IF INDEX(TEMP, ' ') > 0 THEN /* Blanks are'nt allowed in the pattern. */
/* We must check here, because we introduce blanks*/
/* if a user-defined currency symbol is present.*/
SIGNAL ERROR;
/* If there is a user-defined currency symbol, extract it. */
IF SUBSTR(TEMP, 1, 1) = '<' THEN /* There is a user-defined currency symbol. */
DO;
K = INDEX(TEMP, '>');
IF K = 0 THEN
SIGNAL ERROR; /* There is no closing right angle bracket (>). */
IF K <= 2 THEN
SIGNAL ERROR; /* The user-defined character(s) is/are missing.*/
Currency_Symbol = SUBSTR(TEMP, 2, K-2);
SUBSTR (TEMP, 1, K-1) = ' '; /* Replace the '<' and currency symbol with blanks. */
END;
ELSE IF SUBSTR(TEMP, LENGTH(TEMP), 1) = '>' THEN /* We have a trailing currency symbol. */
DO;
K = INDEX (TEMP, '<' ); /* Find the start of the trailing symbol. */
IF K = 0 THEN /* The opening angle bracket is missing. */
SIGNAL ERROR;
Trailing_Currency_Symbol = SUBSTR (TEMP, K+1, LENGTH(TEMP)-1-K);
SUBSTR(TEMP, K) = ''; /* Remove the currency symbol temporarily. */
END;
SIGN = (INDEX (TEMP, '-') + INDEX (TEMP, '+' ) + INDEX (TEMP, 's' ) + INDEX (TEMP, 'S' )) > 0;
CRDB = (INDEX (TEMP, 'CR' ) + INDEX (TEMP, 'DB' )) > 0;
IF ^CRDB THEN
CRDB = (INDEX (TEMP, 'cr' ) + INDEX (TEMP, 'db' )) > 0;
IF SIGN & CRDB THEN /* Cannot have both a sign and CR or DB in the */
SIGNAL ERROR; /* picture Specification. */
IF (VALUE < 0) & CRDB THEN
SVALUE = ABS (VALUE);
ELSE
SVALUE = VALUE;
/* Look for a leading zero in the argument SVALUE, and delete it if present. */
OUTER:
DO J = 1 TO LENGTH(SVALUE)-2;
IF SUBSTR (SVALUE, J, 1) ^= ' ' THEN
IF SUBSTR (SVALUE, J, 2) = '0.' THEN
DO;
SUBSTR (SVALUE, J, 1) = ' ';
LEAVE OUTER;
END;
ELSE IF SUBSTR (SVALUE, J, 3) = '-0.' THEN
DO;
SUBSTR (SVALUE, J, 2) = ' -';
LEAVE OUTER;
END;
ELSE LEAVE;
END OUTER;
K = INDEX (SVALUE, '.' ); /* Home in on the decimal point. */
J = INDEX (LAYOUT, 'V') + INDEX (LAYOUT, 'v' );
IF J = 0 THEN /* Assume a decimal point at the RH end of the field. */
J = N;
SIGN = (INDEX (TEMP, '-') + INDEX (TEMP, 's' ) + INDEX (TEMP, 'S' )) > 0;
/* Now we require that SIGN be true when the */
/* picture allows negative values to be expressed.*/
IF (VALUE < 0) & ( ^SIGN) & (^CRDB) THEN
SIGNAL SIZE; /* Negative values require a minus sign in */
/* the layout, or CR or DB in the layout. */
IF VERIFY (TEMP, '$Ss+-0123456789/.,ZVCRDBzvcrdb> *' ) > 0 THEN
SIGNAL ERROR; /* An invalid layout. */
/* To process the digits to the right of the decimal point. */
K1 = K+1; /* A copy of the position of one column past */
/* the decimal place. */
DO J1 = J+1 TO N;
CH = SUBSTR (TEMP, J1, 1); /* Take one character of the PICTURE pattern. */
IF CH = '9' | CH = '*' THEN
DO;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 = ' ' THEN /* Force a zero into the field. */
SUBSTR (TEMP, J1, 1) = '0';
ELSE
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 + 1;
END;
IF (CH = 'Z') | (CH = 'z') THEN
DO;
SUBSTR (TEMP, J1, 1) = SUBSTR (SVALUE, K1, 1);
/* Take a digit and insert it in the result. */
K1 = K1 +1;
END;
END;
/* Section to determine what, if any, drifting character is used. */
Drifting = '0'B;
IF COUNT(Layout, '>') > 1 THEN DO; Drifting = '1'B; CH3 = '>'; END;
IF COUNT(LAYOUT, '$') > 1 THEN DO; Drifting = '1'B; CH3 = '$'; END;
IF COUNT(LAYOUT, '-') > 1 THEN DO; Drifting = '1'B; CH3 = '-'; END;
IF COUNT(LAYOUT, '+') > 1 THEN DO; Drifting = '1'B; CH3 = '+'; END;
TEMP = TRANSLATE (TEMP, 'BS', 'bs'); /* Capitalize any small 's', small 'b'. */
IF COUNT(LAYOUT, 'S') > 1 THEN DO; Drifting = '1'B; CH3 = 'S'; END;
IF COUNT(LAYOUT, '*') > 1 THEN DO; Drifting = '1'B; CH3 = '*'; END;
/* To process the digits to the left of the decimal point. */
Seen_Drifting_Specifier = '0'B;
K1 = K-1; /* A copy of the position of one column before */
/* the decimal place. */
DO J1 = J TO 1 BY -1;
K1 = MAX(K1, 1); /* For safety. */
CH = SUBSTR (TEMP, J1, 1); /* Take one character of the PICTURE pattern. */
IF CH = '9' THEN
DO;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 = ' ' THEN /* Force a zero into the field. */
DO;
SUBSTR (TEMP, J1, 1) = '0';
K1 = K1 - 1;
END;
ELSE IF CH2 = '-' THEN
SUBSTR (TEMP, J1, 1) = '0'; /* Force a zero, but don't adjust K1, */
/* because we need to keep our eye on the minus sign.*/
ELSE
DO;
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 - 1;
END;
END;
IF (CH = 'Z') | (CH = 'z') THEN
DO;
SUBSTR (TEMP, J1, 1) = SUBSTR (SVALUE, K1, 1);
K1 = K1 - 1;
END;
IF (CH = '$') | (CH = '*') THEN /* A dollar sign, or asterisk. */
DO;
Seen_Drifting_Specifier = '1'B;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 ^= ' ' THEN
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 - 1;
END;
IF CH = '>' THEN /* A user-defined currency symbol. */
DO;
Seen_Drifting_Specifier = '1'B;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 ^= ' ' THEN
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 - 1;
END;
IF CH = '-' THEN
DO;
Seen_Drifting_Specifier = '1'B;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 ^= ' ' | VALUE >= 0 THEN
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 - 1;
END;
ELSE IF CH = '+' THEN
DO;
Seen_Drifting_Specifier = '1'B;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 ^= ' ' | VALUE < 0 THEN
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 - 1;
END;
ELSE IF (CH = 'S') | (CH = 's') THEN
DO;
Seen_Drifting_Specifier = '1'B;
CH2 = SUBSTR (SVALUE, K1, 1);
IF CH2 ^= ' ' THEN
SUBSTR (TEMP, J1, 1) = CH2;
K1 = K1 - 1;
END;
ELSE IF (CH = '/') | (CH = 'B') | (CH = '.') | (CH = ',') THEN
/* We have an insertion character. */
DO;
CH2 = SUBSTR (SVALUE, K1, 1);
IF Drifting & Seen_Drifting_Specifier & (CH2 = '-') THEN
/* We have a drifting field, and only a minus sign to insert. */
DO; /* The insertion character [ / B . , ] behaves as a drifting sign. */
SUBSTR(TEMP, J1, 1) = CH2; /* Insert the minus sign. */
K1 = K1 - 1;
END;
END;
END; /* of loop to process the digits to the left of the decimal point. */
/* Section to check for a zero value, and to suppress the entire field if */
/* there is no '9' digit specifier in the pattern. */
Zero = '1'B;
DO J = 1 TO N;
IF SUBSTR (LAYOUT, J, 1) = '9' THEN
Zero = '0'B;
END;
IF Zero THEN /* The pattern has no digit force. */
DO; /* Check whether the value is zero. */
DO J = 1 TO N;
IF SUBSTR(TEMP, J, 1) >= '1' & SUBSTR (TEMP, J, 1) <= '9' THEN
Zero = '0'B;
END;
IF Zero THEN /* The value is zero, so prepare to suppress. */
DO;
IF SUBSTR(TEMP, 1, 1) = '/' THEN
IF CH3 = '*' THEN
SUBSTR (TEMP, 2) = REPEAT('*', LENGTH(TEMP)-1);
/* Fill the field with asterisks. */
ELSE
SUBSTR(TEMP, 2) = ' '; /* Suppress all but the first character. */
ELSE
IF CH3 = '*' THEN
TEMP = REPEAT('*', LENGTH(TEMP)-1); /* Replace the field with asterisks. */
ELSE
TEMP = ' '; /* Suppress the whole field. */
END;
END;
IF Drifting THEN
DO;
DO J = 1 TO N;
CH4 = SUBSTR(TEMP, J, 1);
IF CH4 >= '0' & CH4 <= '9' THEN
LEAVE;
IF CH4 = 'V' | CH4 = 'v' THEN /* The combination 'V.', 'V,', or 'V/' are special in*/
LEAVE; /* that the point, comma or slash are not suppressed.*/
/* unless the whole subfield field to the right is suppressed.*/
END;
/* At this point, J holds the position of the first digit, or the position of 'V'. */
/* The insertion characters slash (/), comma (,), period (.), etc that appear */
/* before position J behave as the specified drifting character. */
IF (CH3 = '-') & (VALUE >= 0) THEN
SUBSTR(TEMP, 1, J-1) = ' ';
ELSE
SUBSTR(TEMP, 1, J-1) =
TRANSLATE (SUBSTR(TEMP, 1, J-1), CH3 || CH3 || CH3, '/.,' );
END;
/* Section to check for SIZE error. */
IF CH = '+' | CH = '-' | CH = 'S' | CH = 's' THEN
IF CH2 >= '0' & CH2 <= '9' THEN /* Cannot have a digit in the first sign position. */
SIGNAL SIZE;
IF K1 > 1 THEN
IF (SUBSTR (SVALUE, K1, 1) >= '0') & (SUBSTR (SVALUE, K1, 1) <= '9') THEN
SIGNAL SIZE; /* Significant digit lost. */
/* If there are at least two drifting currency symbols remaining, remove one of them. */
DO UNTIL (J = 0);
J = INDEX (TEMP, '>>');
IF J > 0 THEN
SUBSTR (TEMP, J, 1) = ' ';
END;
/* If there are at least two $ signs remaining, remove one of them. */
DO UNTIL (J = 0);
J = INDEX (TEMP, '$$');
IF J > 0 THEN
SUBSTR (TEMP, J, 1) = ' ';
END;
/* If there are at least two minus signs remaining, remove one of them. */
DO UNTIL (J = 0);
J = INDEX (TEMP, '--');
IF J > 0 THEN
SUBSTR (TEMP, J, 1) = ' ';
END;
/* If there are at least two plus signs remaining, remove one of them. */
DO UNTIL (J = 0);
J = INDEX (TEMP, '++');
IF J > 0 THEN
SUBSTR (TEMP, J, 1) = ' ';
END;
IF INDEX(TEMP, 'S') + INDEX(TEMP, 's') > 0 THEN /* An S symbol requires a + or - sign. */
DO;
/* If there are at least two S symbols remaining, remove one of them. */
DO UNTIL (J = 0);
J = INDEX (TEMP, 'SS');
IF J > 0 THEN
SUBSTR (TEMP, J, 1) = ' ';
END;
J = INDEX(TEMP, 'S'); /* Find where the leading S is. */
IF VALUE >= 0 THEN /* Replace it with a sign (+ or blank). */
SUBSTR(TEMP, J, 1) = '+';
ELSE
SUBSTR(TEMP, J, 1) = ' '; /* A minus sign for a negative value is already present. */
END;
TEMP = TRANSLATE (TEMP, ' ', 'bB');
/* Replace any picture characters "b" and "B" with a blank.*/
/* Processing for CR and DB picture characters. */
N = INDEX (TRANSLATE (LAYOUT, 'CR', 'cr'), 'CR' );
IF N > 0 THEN
IF VALUE < 0 THEN
SUBSTR (TEMP, N, 2) = 'CR'; /* CR is displayed only when the value is negative. */
ELSE
SUBSTR (TEMP, N, 2) = ' ';
N = INDEX (TRANSLATE (LAYOUT, 'DB', 'db'), 'DB' );
IF N > 0 THEN
IF VALUE < 0 THEN /* DB is displayed only when the value is negative. */
SUBSTR (TEMP, N, 2) = 'DB';
ELSE
SUBSTR (TEMP, N, 2) = ' ';
/* Processing for +, -, S at the end of the layout. (subset implementation) */
CH3 = SUBSTR (Layout, LENGTH(Layout), 1);
IF ^Drifting THEN
SELECT (Ch3);
WHEN ('-') IF VALUE > 0 THEN
SUBSTR(TEMP, LENGTH(TEMP), 1) = ' ';
ELSE
SUBSTR(TEMP, LENGTH(TEMP), 1) = '-';
WHEN ('+') IF VALUE >= 0 THEN
SUBSTR(TEMP, LENGTH(TEMP), 1) = '+';
ELSE
SUBSTR(TEMP, LENGTH(TEMP), 1) = ' ';
WHEN ('S', 's') IF VALUE >= 0 THEN
SUBSTR(TEMP, LENGTH(TEMP), 1) = '+';
ELSE
SUBSTR(TEMP, LENGTH(TEMP), 1) = '-';
OTHERWISE;
END;
IF LENGTH(Currency_Symbol) > 0 THEN /* There is a user-defined currency symbol. */
DO; /* Install it. */
K = VERIFY (TEMP, ' ' );
IF K = 0 THEN
SIGNAL ERROR;
SUBSTR (TEMP, K-LENGTH(Currency_Symbol)+1, LENGTH (Currency_Symbol) ) = Currency_Symbol;
END;
IF LENGTH (Trailing_Currency_Symbol) > 0 THEN /* Append it to the result. */
DO;
SUBSTR(TEMP, LENGTH(TEMP)-LENGTH(Trailing_Currency_Symbol)-1) =
Trailing_Currency_Symbol;
TEMP = SUBSTR(TEMP, 1, LENGTH(TEMP)-2);
END;
N = INDEX (LAYOUT, 'v' ) + INDEX (LAYOUT, 'V' ); /* Is there a non-printing code? */
IF N > 0 THEN
DO;
SUBSTR (TEMP, N) = SUBSTR (TEMP, N+1);
N = LENGTH (LAYOUT) - 1;
IF LENGTH(Currency_Symbol) = 0 THEN
RETURN ( SUBSTR (TEMP, 1, N) );
ELSE
RETURN (SUBSTR(TEMP, 3, N-2) ); /* Left adjust. */
END;
IF LENGTH(Currency_Symbol) = 0 THEN
RETURN (TEMP);
ELSE
RETURN (SUBSTR(TEMP, 3 ) ); /* Left adjust. */
END EDIT_DECIMAL;
/* A procedure to count the number of occurrences of the character CH in LAYOUT. */
/* Ch must be one of the drifting characters +, -, S, $, or one of * and Z. */
/* COUNT counts the number of valid drifting characters in Layout. The search */
/* terminates as soon as a '9' is encountered. */
COUNT:
PROCEDURE (Layout, Ch) RETURNS (FIXED BINARY);
/* INCOMING: Layout = a PICTURE string to be searched; */
/* Ch = the character with which to search. */
DECLARE (Layout, Ch) CHARACTER (*);
DECLARE (J, Tally, tally2) FIXED BINARY;
DECLARE C CHARACTER (1);
Tally = 0;
DO J = 1 TO LENGTH (Layout);
C = SUBSTR(Layout, J, 1);
IF C = Ch THEN
Tally = Tally + 1;
ELSE IF C = '9' | C = 'Z' | C = 'z' THEN LEAVE;
/* A digit specifier terminates a drifting character field. */
END;
/* Check whether Ch occurs after the last valid occurrence of Ch in Layout. */
IF Tally > 0 THEN /* We have at least one occurrence of the characher Ch. */
DO;
Tally2 = 0;
DO J = J TO LENGTH(Layout);
IF SUBSTR(Layout, J, 1) = Ch THEN
Tally2 = Tally2 + 1;
END;
IF Tally = 1 & Tally2 = 0 & SUBSTR(Layout, LENGTH(Layout), 1) = Ch THEN
/* All is well. */
RETURN (Tally); /* One occurrence of +, -, S is allowed at the */
/* end of the pattern. */
IF Tally2 > 0 THEN /* The drifing character cannot appear */
DO; /* after the first digit position. */
PUT SKIP EDIT ('**ERROR, the picture specification ''', Layout,
''' has a drifting ''', Ch, ''' as well as a static ''', Ch, '.' ) (A);
SIGNAL ERROR;
END;
END;
RETURN (Tally);
END COUNT;
/* This function procedure implements the EDIT built-in function, for character string */
/* data. */
/* The following PICTURE characters are implemented for CHARACTER data: */
/* A, X, 9. */
EDIT_char:
PROCEDURE (VALUE, LAYOUT) RETURNS (CHARACTER(100) VARYING);
/* INCOMING: VALUE = the CHARACTER value to be displayed according to the LAYOUT; */
/* LAYOUT = the PICTURE specification as required by the EDIT built-in function. */
DECLARE VALUE CHARACTER (*); /* The value to be edited. */
DECLARE LAYOUT CHARACTER (*); /* A PICTURE specification. */
DECLARE TEMP CHARACTER (LENGTH(LAYOUT) );
DECLARE (CH, CH2) CHARACTER (1);
DECLARE J FIXED BINARY;
TEMP = TRANSLATE (LAYOUT, 'AX', 'ax' );
J = VERIFY (TEMP, 'AX9' );
IF J > 0 THEN
SIGNAL ERROR;
/* Section to process the A, X, and 9 characters in the picture format. */
DO J = 1 TO LENGTH (TEMP);
CH = SUBSTR (TEMP, J, 1);
CH2 = SUBSTR (VALUE, J, 1);
IF CH = 'A' THEN
IF VERIFY (CH2, ' abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ$@#' ) = 0 THEN
SUBSTR (TEMP, J, 1) = SUBSTR (VALUE, J, 1);
ELSE
SIGNAL CONVERSION;
ELSE IF CH = 'X' THEN
SUBSTR (TEMP, J, 1) = SUBSTR (VALUE, J, 1);
ELSE IF CH = '9' THEN
IF ((CH2 >= '0') & (CH2 <= '9' )) | (CH = ' ') THEN
SUBSTR (TEMP, J, 1) = CH2;
ELSE
SIGNAL CONVERSION;
END;
RETURN (TEMP);
END EDIT_char;
]]>