home *** CD-ROM | disk | FTP | other *** search
/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / misc / cset.src < prev    next >
Encoding:
Text File  |  1988-05-03  |  16.4 KB  |  471 lines
  1. --::::::::::
  2. --character_set.pro
  3. --::::::::::
  4. -------- SIMTEL20 Ada Software Repository Prologue ------------
  5. --                                                           -*
  6. -- Unit name    : CHARACTER_SET
  7. -- Version      : 2.0
  8. -- Author       : Joseph M. Orost
  9. --              : Concurrent Computer Corporation
  10. --              : 106 Apple Street
  11. --              : Tinton Falls, NJ 07724
  12. -- DDN Address  : vax135!petsd!joe@BERKELEY.ARPA
  13. -- Date created : 15 Feb 85
  14. -- Release date : 15 Feb 85
  15. -- Last update  : 12 Mar 87
  16. -- Machine/System Compiled/Run on : CCUR 3200MPS, C3ADA R00-01/BETA
  17. --                                                           -*
  18. ---------------------------------------------------------------
  19. --                                                           -*
  20. -- Keywords     :
  21. ----------------: character, character set
  22. --
  23. -- Abstract     : CHARACTER_SET provides a number of test routines
  24. ----------------: which determine if a given character falls into
  25. -- a particular class of characters.  See the visible section for
  26. -- details.  It also provides routines for character and string
  27. -- letter case conversion (to lower case, to upper case) and for
  28. -- naming control characters.
  29. --                                                           -*
  30. ------------------ Revision history ---------------------------
  31. --                                                           -*
  32. -- DATE         VERSION AUTHOR               HISTORY
  33. -- 2/15/85      1.0     Richard Conn         Initial Release
  34. -- 2/25/85      1.1     Richard Conn         Cosmetic, Readability Changes
  35. -- 3/12/87      2.0     Joseph M. Orost      Rewrite for better performance.
  36. --                                           Replaced functions with arrays.
  37. --                                           Source compatible unless
  38. --                                           named notation was used for
  39. --                                           function calls:
  40. --                                           IS_LOWER(CH => C) no longer works,
  41. --                                           but IS_LOWER(C) is OK.
  42. --                                                           -*
  43. ------------------ Distribution and Copyright -----------------
  44. --                                                           -*
  45. -- This software is released to the Ada community.
  46. -- This software is released to the Public Domain (note:
  47. --   software released to the Public Domain is not subject
  48. --   to copyright protection).
  49. -- Restrictions on use or distribution:  NONE
  50. --                                                           -*
  51. ------------------ Disclaimer ---------------------------------
  52. --                                                           -*
  53. -- This software and its documentation are provided "AS IS" and
  54. -- without any expressed or implied warranties whatsoever.
  55. -- No warranties as to performance, merchantability, or fitness
  56. -- for a particular purpose exist.
  57. --
  58. -- Because of the diversity of conditions and hardware under
  59. -- which this software may be used, no warranty of fitness for
  60. -- a particular purpose is offered.  The user is advised to
  61. -- test the software thoroughly before relying on it.  The user
  62. -- must assume the entire risk and liability of using this
  63. -- software.
  64. --
  65. -- In no event shall any person or organization of people be
  66. -- held responsible for any direct, indirect, consequential
  67. -- or inconsequential damages or lost profits.
  68. --                                                           -*
  69. -------------------END-PROLOGUE--------------------------------
  70. --::::::::::
  71. --character_set.ada
  72. --::::::::::
  73. --
  74. -- Components Package CHARACTER_SET
  75. -- by Joseph M. Orost, Concurrent Computer Corporation
  76. -- Version 2.0, Date 12 Mar 87
  77. -- by Richard Conn, TI Ada Technology Branch
  78. -- Version 1.1, Date 25 Feb 85
  79. -- Version 1.0, Date 13 Feb 85
  80. --
  81.  
  82. package CHARACTER_SET is
  83.  
  84. --
  85. -- These routines test for the following subsets of ASCII
  86. --
  87. -- Routine              Subset tested for
  88. -- =======              =================
  89. -- ALPHA                'a'..'z' | 'A'..'Z'
  90. -- ALPHA_NUMERIC        ALPHA | '0'..'9'
  91. -- CONTROL              < ' ' | DEL
  92. -- DIGIT                '0'..'9'
  93. -- GRAPHIC              ' ' < ch < DEL (does not include space)
  94. -- HEXADECIMAL          DIGIT | 'A'..'F' | 'a'..'f'
  95. -- LOWER                'a'..'z'
  96. -- PRINTABLE            GRAPHIC | ' '
  97. -- PUNCTUATION          GRAPHIC and not ALPHA_NUMERIC
  98. -- SPACE                HT | LF | VT | FF | CR | ' '
  99. -- UPPER                'A'..'Z'
  100. --
  101.  
  102.    use  ASCII;
  103.  
  104.    type BIT_ARRAY is array (CHARACTER) of BOOLEAN;
  105.    pragma PACK (BIT_ARRAY);
  106.    pragma BIT_PACK (BIT_ARRAY);  --Compiler dependent
  107.  
  108.    IS_ALPHA         : constant BIT_ARRAY :=
  109.       BIT_ARRAY'('a' .. 'z' => TRUE, 'A' .. 'Z' => TRUE, others => FALSE);
  110.  
  111.    IS_ALPHA_NUMERIC : constant BIT_ARRAY :=
  112.       BIT_ARRAY'
  113.          ('a' .. 'z' => TRUE, 'A' .. 'Z' => TRUE, '0' .. '9' => TRUE,
  114.           others => FALSE   );
  115.  
  116.    IS_CONTROL       : constant BIT_ARRAY :=
  117.       BIT_ARRAY'(NUL .. US => TRUE, DEL => TRUE, others => FALSE);
  118.  
  119.    IS_DIGIT         : constant BIT_ARRAY :=
  120.                          BIT_ARRAY'('0' .. '9' => TRUE, others => FALSE);
  121.  
  122.    IS_GRAPHIC       : constant BIT_ARRAY :=
  123.                          BIT_ARRAY'('!' .. '~' => TRUE, others => FALSE);
  124.  
  125.    IS_HEXADECIMAL   : constant BIT_ARRAY :=
  126.       BIT_ARRAY'
  127.          ('0' .. '9' => TRUE, 'A' .. 'F' => TRUE, 'a' .. 'f' => TRUE,
  128.           others => FALSE   );
  129.  
  130.    IS_LOWER         : constant BIT_ARRAY :=
  131.                          BIT_ARRAY'('a' .. 'z' => TRUE, others => FALSE);
  132.  
  133.    IS_PRINTABLE     : constant BIT_ARRAY :=
  134.                          BIT_ARRAY'(' ' .. '~' => TRUE, others => FALSE);
  135.  
  136.    IS_PUNCTUATION   : constant BIT_ARRAY :=
  137.       BIT_ARRAY'
  138.          ('!' .. '/' => TRUE, ':' .. '@' => TRUE, '[' .. '`' => TRUE,
  139.           '{' .. '~' => TRUE, others => FALSE   );
  140.  
  141.    IS_SPACE         : constant BIT_ARRAY :=
  142.       BIT_ARRAY'
  143.          (HT => TRUE     , LF => TRUE     , VT => TRUE     , FF => TRUE     ,
  144.           CR => TRUE     , ' ' => TRUE    , others => FALSE);
  145.  
  146.    IS_UPPER         : constant BIT_ARRAY :=
  147.                          BIT_ARRAY'('A' .. 'Z' => TRUE, others => FALSE);
  148.  
  149. --
  150. -- These routines convert characters and strings to upper- or lower-case
  151. --
  152.  
  153.    type TRANSLATION_ARRAY is array (CHARACTER) of CHARACTER;
  154.    pragma PACK (TRANSLATION_ARRAY);
  155.  
  156.    --
  157.    -- LOWER can be used in place of TO_LOWER.  (Ada won't allow overloading
  158.    -- of an object vs. a procedure.)
  159.    --
  160.    LOWER            : constant TRANSLATION_ARRAY :=
  161.       (NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS , HT , LF , VT , FF , CR ,
  162.        SO , SI , DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EM , SUB, ESC,
  163.        FS , GS , RS , US , ' ', '!', '"', '#', '$', '%', '&', ''', '(', ')',
  164.        '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7',
  165.        '8', '9', ':', ';', '<', '=', '>', '?', '@', 'a', 'b', 'c', 'd', 'e',
  166.        'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's',
  167.        't', 'u', 'v', 'w', 'x', 'y', 'z', '[', '\', ']', '^', '_', '`', 'a',
  168.        'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
  169.        'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '{', '|', '}',
  170.        '~', DEL);
  171.  
  172.    function  TO_LOWER (CH : in CHARACTER) return CHARACTER;
  173.  
  174.    procedure TO_LOWER (CH : in out CHARACTER);
  175.  
  176.    procedure TO_LOWER (STR : in out STRING);
  177.  
  178.    --
  179.    -- UPPER can be used in place of TO_UPPER
  180.    --
  181.    UPPER            : constant TRANSLATION_ARRAY :=
  182.       (NUL, SOH, STX, ETX, EOT, ENQ, ACK, BEL, BS , HT , LF , VT , FF , CR ,
  183.        SO , SI , DLE, DC1, DC2, DC3, DC4, NAK, SYN, ETB, CAN, EM , SUB, ESC,
  184.        FS , GS , RS , US , ' ', '!', '"', '#', '$', '%', '&', ''', '(', ')',
  185.        '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7',
  186.        '8', '9', ':', ';', '<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E',
  187.        'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S',
  188.        'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '[', '\', ']', '^', '_', '`', 'A',
  189.        'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
  190.        'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '{', '|', '}',
  191.        '~', DEL);
  192.  
  193.    function  TO_UPPER (CH : in CHARACTER) return CHARACTER;
  194.  
  195.    procedure TO_UPPER (CH : in out CHARACTER);
  196.  
  197.    procedure TO_UPPER (STR : in out STRING);
  198.  
  199. --
  200. -- These routines return the names of the control characters
  201. --
  202.  
  203.    subtype CONTROL_CHARACTER_NAME_2 is STRING (1 .. 2);
  204.  
  205.    subtype CONTROL_CHARACTER_NAME_3 is STRING (1 .. 3);
  206.  
  207. --
  208.  
  209.    function  CC_NAME_2 (CH : CHARACTER) return CONTROL_CHARACTER_NAME_2;
  210.  
  211.    function  CC_NAME_3 (CH : CHARACTER) return CONTROL_CHARACTER_NAME_3;
  212.  
  213. end CHARACTER_SET;
  214.  
  215. package body CHARACTER_SET is
  216.  
  217.    function  TO_LOWER (CH : in CHARACTER) return CHARACTER is
  218.    begin
  219.       return LOWER (CH);
  220.    end TO_LOWER;
  221.  
  222.    procedure TO_LOWER (CH : in out CHARACTER) is
  223.    begin
  224.       CH := LOWER (CH);
  225.    end TO_LOWER;
  226.  
  227.    procedure TO_LOWER (STR : in out STRING) is
  228.    begin
  229.       for I in STR'FIRST .. STR'LAST loop
  230.          STR (I) := LOWER (STR (I));
  231.       end loop;
  232.    end TO_LOWER;
  233.  
  234.    function  TO_UPPER (CH : in CHARACTER) return CHARACTER is
  235.    begin
  236.       return UPPER (CH);
  237.    end TO_UPPER;
  238.  
  239.    procedure TO_UPPER (CH : in out CHARACTER) is
  240.    begin
  241.       CH := UPPER (CH);
  242.    end TO_UPPER;
  243.  
  244.    procedure TO_UPPER (STR : in out STRING) is
  245.    begin
  246.       for I in STR'FIRST .. STR'LAST loop
  247.          STR (I) := UPPER (STR (I));
  248.       end loop;
  249.    end TO_UPPER;
  250.  
  251.    function  CC_NAME_2 (CH : CHARACTER) return CONTROL_CHARACTER_NAME_2 is
  252.       NAME : CONTROL_CHARACTER_NAME_2;
  253.    begin
  254.       case CH is
  255.          when ASCII.NUL => NAME := "^@";
  256.          when ASCII.SOH => NAME := "^A";
  257.          when ASCII.STX => NAME := "^B";
  258.          when ASCII.ETX => NAME := "^C";
  259.          when ASCII.EOT => NAME := "^D";
  260.          when ASCII.ENQ => NAME := "^E";
  261.          when ASCII.ACK => NAME := "^F";
  262.          when ASCII.BEL => NAME := "^G";
  263.          when ASCII.BS  => NAME := "^H";
  264.          when ASCII.HT  => NAME := "^I";
  265.          when ASCII.LF  => NAME := "^J";
  266.          when ASCII.VT  => NAME := "^K";
  267.          when ASCII.FF  => NAME := "^L";
  268.          when ASCII.CR  => NAME := "^M";
  269.          when ASCII.SO  => NAME := "^N";
  270.          when ASCII.SI  => NAME := "^O";
  271.          when ASCII.DLE => NAME := "^P";
  272.          when ASCII.DC1 => NAME := "^Q";
  273.          when ASCII.DC2 => NAME := "^R";
  274.          when ASCII.DC3 => NAME := "^S";
  275.          when ASCII.DC4 => NAME := "^T";
  276.          when ASCII.NAK => NAME := "^U";
  277.          when ASCII.SYN => NAME := "^V";
  278.          when ASCII.ETB => NAME := "^W";
  279.          when ASCII.CAN => NAME := "^X";
  280.          when ASCII.EM  => NAME := "^Y";
  281.          when ASCII.SUB => NAME := "^Z";
  282.          when ASCII.ESC => NAME := "^[";
  283.          when ASCII.FS  => NAME := "^\";
  284.          when ASCII.GS  => NAME := "^]";
  285.          when ASCII.RS  => NAME := "^^";
  286.          when ASCII.US  => NAME := "^_";
  287.          when ASCII.DEL => NAME := "^`";
  288.          when others =>
  289.             NAME := "  ";
  290.             NAME (2) := CH;
  291.       end case;
  292.       return NAME;
  293.    end CC_NAME_2;
  294.  
  295.    function  CC_NAME_3 (CH : CHARACTER) return CONTROL_CHARACTER_NAME_3 is
  296.       NAME : CONTROL_CHARACTER_NAME_3;
  297.    begin
  298.       case CH is
  299.          when ASCII.NUL => NAME := "NUL";
  300.          when ASCII.SOH => NAME := "SOH";
  301.          when ASCII.STX => NAME := "STX";
  302.          when ASCII.ETX => NAME := "ETX";
  303.          when ASCII.EOT => NAME := "EOT";
  304.          when ASCII.ENQ => NAME := "ENQ";
  305.          when ASCII.ACK => NAME := "ACK";
  306.          when ASCII.BEL => NAME := "BEL";
  307.          when ASCII.BS  => NAME := "BS ";
  308.          when ASCII.HT  => NAME := "HT ";
  309.          when ASCII.LF  => NAME := "LF ";
  310.          when ASCII.VT  => NAME := "VT ";
  311.          when ASCII.FF  => NAME := "FF ";
  312.          when ASCII.CR  => NAME := "CR ";
  313.          when ASCII.SO  => NAME := "SO ";
  314.          when ASCII.SI  => NAME := "SI ";
  315.          when ASCII.DLE => NAME := "DLE";
  316.          when ASCII.DC1 => NAME := "DC1";
  317.          when ASCII.DC2 => NAME := "DC2";
  318.          when ASCII.DC3 => NAME := "DC3";
  319.          when ASCII.DC4 => NAME := "DC4";
  320.          when ASCII.NAK => NAME := "NAK";
  321.          when ASCII.SYN => NAME := "SYN";
  322.          when ASCII.ETB => NAME := "ETB";
  323.          when ASCII.CAN => NAME := "CAN";
  324.          when ASCII.EM  => NAME := "EM ";
  325.          when ASCII.SUB => NAME := "SUB";
  326.          when ASCII.ESC => NAME := "ESC";
  327.          when ASCII.FS  => NAME := "FS ";
  328.          when ASCII.GS  => NAME := "GS ";
  329.          when ASCII.RS  => NAME := "RS ";
  330.          when ASCII.US  => NAME := "US ";
  331.          when ASCII.DEL => NAME := "DEL";
  332.          when others =>
  333.             NAME := "   ";
  334.             NAME (2) := CH;
  335.       end case;
  336.       return NAME;
  337.    end CC_NAME_3;
  338. end CHARACTER_SET;
  339.  
  340. --::::::::::
  341. --tcset.ada
  342. --::::::::::
  343. --
  344. -- Test for routines in CHARACTER_SET
  345. -- by Richard Conn, TI Ada Technology Branch
  346. --
  347.  
  348. with CHARACTER_SET;
  349. use  CHARACTER_SET;
  350. with TEXT_IO;
  351. use  TEXT_IO;
  352.  
  353. procedure TCSET is
  354.    LST_FILE : FILE_TYPE;
  355.    INCHAR   : CHARACTER;
  356.    INDEX    : NATURAL;
  357.  
  358.    procedure MARK (BOOLEAN_VALUE : BOOLEAN) is
  359.    begin
  360.       if BOOLEAN_VALUE then
  361.          PUT (LST_FILE, "  x ");
  362.       else
  363.          PUT (LST_FILE, "    ");
  364.       end if;
  365.    end MARK;
  366.  
  367.    procedure BANNER is
  368.    begin
  369.       PUT (LST_FILE, ASCII.FF);
  370.       NEW_LINE (LST_FILE);
  371.       PUT (LST_FILE, "           ");
  372.       PUT (LST_FILE, "  A ");
  373.       PUT (LST_FILE, "  A ");
  374.       PUT (LST_FILE, "  C ");
  375.       PUT (LST_FILE, "  D ");
  376.       PUT (LST_FILE, "  G ");
  377.       PUT (LST_FILE, "  H ");
  378.       PUT (LST_FILE, "  L ");
  379.       PUT (LST_FILE, "  P ");
  380.       PUT (LST_FILE, "  P ");
  381.       PUT (LST_FILE, "  S ");
  382.       PUT (LST_FILE, "  U ");
  383.       NEW_LINE (LST_FILE);
  384.       PUT (LST_FILE, "           ");
  385.       PUT (LST_FILE, "  l ");
  386.       PUT (LST_FILE, "  l ");
  387.       PUT (LST_FILE, "  n ");
  388.       PUT (LST_FILE, "  i ");
  389.       PUT (LST_FILE, "  r ");
  390.       PUT (LST_FILE, "  e ");
  391.       PUT (LST_FILE, "  o ");
  392.       PUT (LST_FILE, "  r ");
  393.       PUT (LST_FILE, "  u ");
  394.       PUT (LST_FILE, "  p ");
  395.       PUT (LST_FILE, "  p ");
  396.       NEW_LINE (LST_FILE);
  397.       PUT (LST_FILE, "ASCII      ");
  398.       PUT (LST_FILE, "  p ");
  399.       PUT (LST_FILE, "  n ");
  400.       PUT (LST_FILE, "  t ");
  401.       PUT (LST_FILE, "  g ");
  402.       PUT (LST_FILE, "  a ");
  403.       PUT (LST_FILE, "  x ");
  404.       PUT (LST_FILE, "  w ");
  405.       PUT (LST_FILE, "  i ");
  406.       PUT (LST_FILE, "  n ");
  407.       PUT (LST_FILE, "  a ");
  408.       PUT (LST_FILE, "  p ");
  409.       NEW_LINE (LST_FILE);
  410.       PUT (LST_FILE, " Code      ");
  411.       PUT (LST_FILE, "  h ");
  412.       PUT (LST_FILE, "  u ");
  413.       PUT (LST_FILE, "  r ");
  414.       PUT (LST_FILE, "  i ");
  415.       PUT (LST_FILE, "  p ");
  416.       PUT (LST_FILE, "  n ");
  417.       PUT (LST_FILE, "  e ");
  418.       PUT (LST_FILE, "  n ");
  419.       PUT (LST_FILE, "  c ");
  420.       PUT (LST_FILE, "  c ");
  421.       PUT (LST_FILE, "  e ");
  422.       NEW_LINE (LST_FILE);
  423.       PUT (LST_FILE, "           ");
  424.       PUT (LST_FILE, "  a ");
  425.       PUT (LST_FILE, "  m ");
  426.       PUT (LST_FILE, "  l ");
  427.       PUT (LST_FILE, "  t ");
  428.       PUT (LST_FILE, "  h ");
  429.       PUT (LST_FILE, "  m ");
  430.       PUT (LST_FILE, "  r ");
  431.       PUT (LST_FILE, "  t ");
  432.       PUT (LST_FILE, "  t ");
  433.       PUT (LST_FILE, "  e ");
  434.       PUT (LST_FILE, "  r ");
  435.       NEW_LINE (LST_FILE);
  436.       NEW_LINE (LST_FILE);
  437.    end BANNER;
  438. begin
  439.    CREATE (LST_FILE, OUT_FILE, "TCSET.OUT");
  440.    INDEX := 0;
  441.    for CH in CHARACTER'FIRST .. CHARACTER'LAST loop
  442.       if INDEX mod 40 = 0 then
  443.          BANNER;
  444.       else
  445.          if INDEX mod 5 = 0 then
  446.             NEW_LINE (LST_FILE);
  447.          end if;
  448.       end if;
  449.       INDEX := INDEX + 1;
  450.       PUT (LST_FILE, ' ');
  451.       PUT (LST_FILE, CC_NAME_3 (CH));
  452.       PUT (LST_FILE, "  ");
  453.       PUT (LST_FILE, CC_NAME_2 (CH));
  454.       PUT (LST_FILE, " | ");
  455.       MARK (IS_ALPHA (CH));
  456.       MARK (IS_ALPHA_NUMERIC (CH));
  457.       MARK (IS_CONTROL (CH));
  458.       MARK (IS_DIGIT (CH));
  459.       MARK (IS_GRAPHIC (CH));
  460.       MARK (IS_HEXADECIMAL (CH));
  461.       MARK (IS_LOWER (CH));
  462.       MARK (IS_PRINTABLE (CH));
  463.       MARK (IS_PUNCTUATION (CH));
  464.       MARK (IS_SPACE (CH));
  465.       MARK (IS_UPPER (CH));
  466.       NEW_LINE (LST_FILE);
  467.    end loop;
  468.    CLOSE (LST_FILE);
  469. end TCSET;
  470.  
  471.