<![CDATA[
/* Copyright (c) 1996 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 HEX GENERIC
(HEXG WHEN (GRAPHIC),
HEXC WHEN (CHARACTER),
HEXF WHEN (FLOAT),
HEXFB WHEN (FIXED BINARY),
HEXC2 WHEN (CHARACTER, CHARACTER),
HEX2_graphic WHEN (GRAPHIC, *),
HEXF2 WHEN (FLOAT, CHARACTER),
HEXFB2 WHEN (FIXED BINARY, CHARACTER) );
/* Add others as appropriate. */
/* This function procedure returns the hexadecimal image of the character argument. */
HEXC:
PROCEDURE (STRING) RETURNS (CHARACTER (1000) VARYING);
DECLARE STRING CHARACTER (*);
DECLARE S CHARACTER (2*LENGTH(STRING) );
DECLARE Byte BIT (8);
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
K = 1;
DO J = 1 TO LENGTH (STRING);
Byte = TRUE_BYTE (SUBSTR(STRING, J, 1) );
Nibble = SUBSTR (Byte, 1, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Byte, 5, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
END;
RETURN (S);
END HEXC;
/* This function procedure returns the hexadecimal image of the graphic argument. */
HEXG:
PROCEDURE (STRING) RETURNS (CHARACTER (1000) VARYING);
DECLARE STRING GRAPHIC (*);
DECLARE S CHARACTER (4*LENGTH(STRING) );
DECLARE Double_Byte BIT (16);
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
K = 1;
DO J = 1 TO LENGTH (STRING);
Double_Byte = UNSPEC (SUBSTR(STRING, J, 1) );
Nibble = SUBSTR (Double_Byte, 1, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Double_Byte, 5, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Double_Byte, 9, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Double_Byte, 13, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
END;
RETURN (S);
END HEXG;
/* This function procedure returns the hexadecimal image of the floating-point argument. */
HEXF:
PROCEDURE (FPN) RETURNS (CHARACTER (100) VARYING);
DECLARE FPN FLOAT (16);
DECLARE S CHARACTER (100) VARYING;
DECLARE B BIT (8*LENGTH(FPN) );
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
B = UNSPEC (FPN); K = 1;
DO J = 1 TO LENGTH (B) BY 4;
Nibble = SUBSTR (B, J, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
END;
RETURN (S);
END HEXF;
/* This function procedure returns the hexadecimal image of the fixed-point binary argument. */
HEXFB:
PROCEDURE (FB) RETURNS (CHARACTER (16) VARYING);
DECLARE FB FIXED BINARY (31);
DECLARE S CHARACTER (16) VARYING;
DECLARE B BIT (32);
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
B = UNSPEC (FB); K = 1;
DO J = 1 TO LENGTH (B) BY 4;
Nibble = SUBSTR (B, J, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
END;
RETURN (S);
END HEXFB;
/* This function procedure returns the hexadecimal image of the character argument. */
/* After every 8 characters of the hexadecimal image, the character Gap is inserted. */
HEXC2:
PROCEDURE (STRING, Gap) RETURNS (CHARACTER (1000) VARYING);
/* INCOMING: STRING = the string to be displayed in hexadecimal. */
/* Gap = a spacing character, to be inserted in the hexadecimal string */
/* every eighth digit. */
DECLARE STRING CHARACTER (*);
DECLARE Gap CHARACTER (1);
DECLARE S CHARACTER (2*LENGTH(STRING)+ (LENGTH(STRING)+7)/8);
DECLARE Byte BIT (8);
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
K = 1;
DO J = 1 TO LENGTH (STRING);
Byte = TRUE_BYTE (SUBSTR(STRING, J, 1) );
Nibble = SUBSTR (Byte, 1, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Byte, 5, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
IF MOD(J, 8) = 0 THEN /* 8 hex digits written; insert the character Gap.*/
DO;
K = K + 1;
SUBSTR(S, K, 1) = Gap;
END;
K = K + 1;
END;
RETURN (S);
END HEXC2;
/* This function procedure returns the hexadecimal image of the graphic argument. */
/* After every 8 characters of the hexadecimal image, the character Gap is inserted. */
HEX2_graphic:
PROCEDURE (STRING, Gap) RETURNS (CHARACTER (1000) VARYING);
/* INCOMING: STRING = the string to be displayed in hexadecimal. */
/* Gap = a spacing character, to be inserted in the hexadecimal string */
/* every eighth digit. */
DECLARE STRING GRAPHIC (*);
DECLARE Gap CHARACTER (1);
DECLARE S CHARACTER (4*LENGTH(STRING)+ (LENGTH(STRING)+7)/8);
DECLARE Double_Byte BIT (16);
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
K = 1;
DO J = 1 TO LENGTH (STRING);
Double_Byte = UNSPEC (SUBSTR(STRING, J, 1) );
Nibble = SUBSTR (Double_Byte, 1, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Double_Byte, 5, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Double_Byte, 9, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
Nibble = SUBSTR (Double_Byte, 13, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
IF MOD(J, 8) = 0 THEN /* 8 hex digits written; insert the character Gap.*/
DO;
K = K + 1;
SUBSTR(S, K, 1) = Gap;
END;
K = K + 1;
END;
RETURN (S);
END HEX2_graphic;
/* This function procedure returns the hexadecimal image of the floating-point argument. */
HEXF2:
PROCEDURE (FPN, Gap) RETURNS (CHARACTER (100) VARYING);
DECLARE FPN FLOAT (16);
DECLARE Gap CHARACTER (1);
DECLARE S CHARACTER (100) VARYING;
DECLARE B BIT (8*LENGTH(FPN) );
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
B = UNSPEC (FPN); K = 1;
DO J = 1 TO LENGTH (B) BY 4;
Nibble = SUBSTR (B, J, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
END;
RETURN (S);
END HEXF2;
/* This function procedure returns the hexadecimal image of the fixed-point binary argument. */
HEXFB2:
PROCEDURE (FB, Gap) RETURNS (CHARACTER (16) VARYING);
DECLARE FB FIXED BINARY (31);
DECLARE Gap CHARACTER (1);
DECLARE S CHARACTER (16);
DECLARE B BIT (32);
DECLARE Nibble BIT (4);
DECLARE (J, K) FIXED BINARY (31);
DECLARE Hex_digit(0:15) CHARACTER (1) STATIC INITIAL
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' );
B = UNSPEC (FB); K = 1;
DO J = 1 TO LENGTH (B) BY 4;
Nibble = SUBSTR (B, J, 4);
SUBSTR (S, K, 1) = Hex_digit (Nibble);
K = K + 1;
END;
RETURN (S);
END HEXFB2;
]]>