home *** CD-ROM | disk | FTP | other *** search
/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / misc / strcomp.src < prev    next >
Encoding:
Text File  |  1988-05-03  |  44.5 KB  |  1,073 lines
  1. --::::::::::
  2. --strcomp.inc
  3. --::::::::::
  4. -- Documentation (including this Include File)
  5. strcomp.inc
  6. read.me
  7.  
  8. -- Source Files in Compilation Order
  9. latin1.a
  10. natascii.a
  11. strcomps.a
  12. strcompb.a
  13. define.a
  14. comline.a
  15. main.a
  16. --::::::::::
  17. --read.me
  18. --::::::::::
  19. The intention of this posting is not to provide a facility, but 
  20. rather to demonstrate a technique to do string comparisons 
  21. in a more sophisticated way than simply using ASCII values.
  22.  
  23. Comments, questions etc are very welcome to:
  24. Erland Sommarskog       
  25. ENEA Data, Stockholm    
  26. sommar@enea.UUCP        
  27.  
  28. The posting contains seven files that can be divided into three
  29. groups:
  30. I:   strcompS.a and strcompB.a
  31.      The core of the posting. They contain a package for string 
  32.      comparisons. It has a character-transscription table to be
  33.      loaded by the user and comparison operators for trans-
  34.      scripted string. The exported routines are described below. 
  35.      StrcompS is the specification, whereas strcompB contains
  36.      the package body.
  37. II:  latin1.a and natascii.a
  38.      They declare names for characters, to be used, for example,
  39.      when defining a collating sequence for the package above.
  40.      Latin1 declares names for the ISO standard 8859/1. Natascii
  41.      declares names for national replacements of the ordinary 
  42.      ASCII set.
  43. III: define.a, comline.a and main.a
  44.      An demonstration application that uses the string-comparison
  45.      package. Define.a loads the character collating sequence.
  46.        Comline.a reads the command line. Note that this file is
  47.      bound to Verdix Ada for Unix and must be rewritten for another
  48.      system.
  49.        Main.a is the main program. It reads lines from standard 
  50.      input or a named file and writes the sorted lines to standard
  51.      output when end-of-file is detected. 
  52.        You find a description of the options last in this file.
  53.        
  54. You should compile the files in the order: latin1, natascii,
  55. strcompS, strcompB, define, comline, main.
  56.  
  57. Four-dimensional sorting
  58. ------------------------
  59.        
  60. The string-comparison package compares strings at four levels:
  61. 1) Alphabetic
  62. 2) Accents
  63. 3) Non-letters
  64. 4) Difference in case 
  65. What is an alphabetic etc is up to the user. He may define "$" 
  66. being a letter with "(" as its lowercase variant if he likes. 
  67.  
  68. One level is only regarded if the level above have no difference.
  69. As an example I take 
  70.       T^ete-`a-t^ete
  71. (I assume a "normal" loading of the character table here.)
  72.   For the first level we use TETEATETE, thus we remove the accents
  73. and the hyphens. On the next we re-insert the accents so we get
  74.       T^ETE`AT^ETE
  75. On level three we only take the hyphens in regard. When comparing
  76. non-letters the package uses the simple ASCII values. The earlier
  77. a character comes, the lower is the sort value. Thus, "trans-scription"
  78. will precede "transscrip-tion". (Actually, as the implementation 
  79. is done, the position is more important than the ASCII value.)
  80.   On the last level we use 
  81.     T^ete`at^ete
  82. thus, the original writing with the hyphens removed. Note that the
  83. user can specify case to be insigificant.
  84.   (This isn't a description on how the package is implemented, just 
  85. a way of illustrating the result. In practice it's done a little
  86. more effective.)
  87.  
  88. When defining accented variants it is possible to let a character
  89. be a variant of a string, in this way the AE ligature can be sorted
  90. as "AE". The opposite is not possible, and what worse is, a string
  91. can't have an alphabetic value. Thus the package is not able to sort
  92. languages as Spanish (CH and LL) correctly.
  93.  
  94. The number characters are handled in a special way if you define them 
  95. as alphabetics. A sequence of figures will read as one number and sort 
  96. after all other alphabetics. (Even if they were defined as the first 
  97. characters.) So you will get
  98.    File1   File2   File10   File11
  99. instead of the usual
  100.    File1   File10  File11   File2
  101.   If you like to sort them as they are read, this is also possible.
  102. E.g. load "0" as a variant of "zero".
  103.  
  104. The package contains the following routines:
  105.  
  106. Load Operations
  107. ---------------
  108. PROCEDURE Load_alphabetic(ch : IN character);
  109. Loads ch as the next alphabetic character. The order of loading
  110. determines the sorting values.
  111.  
  112. PROCEDURE Load_variant(ch       : IN character;  
  113.                        Equ_ch   : IN character;
  114.                        Equ_kind : IN Equivalence_kind);
  115. TYPE Equivalence_kind IS (Exact, Case_diff, Accented);   
  116. PROCEDURE Load_variant(ch      : IN character;  
  117.                        Equ_str : IN string);  
  118. Load_variant loads ch as a variant of Equ_ch or Equ_str. The interpretation
  119. of Equ_kind is:
  120. Exact: Exactly the same. There is no difference. What you use when you
  121.        don't want case to be significant.
  122. Case_diff: Load ch as a lowercase variant of Equ_ch. There will be
  123.            difference at level 4.
  124. Accented:  Load ch as variant of Equ_ch at level 2.
  125. The latter version of Load_variant always loads ch at level 2.
  126.  
  127. For simplify loading, the package also provides routines for loading
  128. a character and its ASCII lowercase equivalent simultaneously:
  129. PROCEDURE Set_case_significance(Flag : boolean);
  130. PROCEDURE Alpha_both_cases(ch : IN character);  
  131. PROCEDURE Variant_both_cases(ch     : IN character;
  132.                              Equ_ch : IN character);
  133. PROCEDURE Variant_both_cases(ch      : IN character;       
  134.                              Equ_str : IN string);
  135. With Set_case_significant you determine whether case should be
  136. significant when loading the pairs. Variant_both_cases loads ch
  137. at level 2.
  138.  
  139. The loading operations raise Already_defined if an attempt is
  140. made to load a character twice. If Equ_ch or part of Equ_str is
  141. undefined, this gives the exception Undefined_equivalent.
  142.  
  143. Transscription operations
  144. -------------------------
  145. These routines translates a string to the internal coding. 
  146. TYPE Transscripted_string(Max_length : natural) IS PRIVATE;
  147. PROCEDURE Transscribe(ch        : IN character;
  148.                       Trans_str : OUT Transscripted_string);
  149. PROCEDURE Transscribe(Str       : IN string;
  150.                       Trans_str : OUT Transscripted_string);
  151. If the transscription is too long, the routines will raise
  152. Transscription_error.
  153.                       
  154. Comparison operators:
  155. ---------------------
  156. FUNCTION "<=" (Left, Right : Transscripted_string) RETURN boolean;
  157. FUNCTION "<"  (Left, Right : Transscripted_string) RETURN boolean;
  158. FUNCTION ">=" (Left, Right : Transscripted_string) RETURN boolean;
  159. FUNCTION ">"  (Left, Right : Transscripted_string) RETURN boolean;
  160.  
  161. I have only included operations for comparing transscripted 
  162. strings. Of course there could be a set for uncoded strings too.
  163.  
  164. Other function
  165. --------------
  166. FUNCTION Is_letter(ch : character) RETURN boolean;
  167.  
  168. The demonstration program
  169. -------------------------
  170. The program takes the options:
  171. -8  Use ISO/Latin-1. If not present, use 7-bit ASCII with national
  172.     replacements.
  173. -e  Case is significant. When omitted, case is not significant.
  174. -LX Selects language. X should be one of the following:
  175.     s or S: Swedish. (Default)
  176.     d or D: Danish
  177.     g:      German1: "A, "O and "U sorts as A, O and U.
  178.     G:      German2: "A, "O and "U sorts as AE, OE and UE.
  179.     f or F  French
  180.    
  181. In the definition routine I load space as the first alphabetic
  182. letter. This gives the result that "Smith, Tony" will sort
  183. before "Smithson, Alan".
  184. --::::::::::
  185. --latin1.a
  186. --::::::::::
  187. ----------------------------------------------------------------------
  188. --                     PACKAGE ISO_Latin_1                          --
  189. ----------------------------------------------------------------------
  190. -- This package defines names for the characters in the standard
  191. -- ISO 8859/1, known as Latin-1, that are not in the ASCII set, 
  192. -- i.e. characters with codes >= 160. (Control characters 128-159
  193. -- are excluded.
  194.  
  195. WITH Unchecked_conversion;
  196. PACKAGE ISO_Latin_1 IS
  197.    -- Implementation note: To define the constants within the existing 
  198.    -- character type I use Unchecked_conversion. Note that this is not 
  199.    -- legal Ada. Ada defines the character type as covering codes from 
  200.    -- 0 to 127. Thus, all these declarations should raise Constraint_error, 
  201.    -- however neither DEC Ada, nor Verdix for Unix do so. 
  202.    --   Note also that the Ada definition permits an implementation to 
  203.    -- restrict Unchecked_conversion.
  204.    -- The proper way would be define a new enumeration type, however this
  205.    -- requires more work, including a new Text_io.
  206.                           
  207.    TYPE Byte IS NEW integer RANGE 0..255;
  208.    FUNCTION Eight_bit IS NEW Unchecked_conversion(Byte, Character);
  209.     
  210.    No_break_space  : CONSTANT character := Eight_bit(160);
  211.    Exclaim_up_down : CONSTANT character := Eight_bit(161);
  212.    Cent            : CONSTANT character := Eight_bit(162);
  213.    Pound           : CONSTANT character := Eight_bit(163);
  214.    Gen_currency    : CONSTANT character := Eight_bit(164);
  215.    Yen             : CONSTANT character := Eight_bit(165);
  216.    Broken_bar      : CONSTANT character := Eight_bit(166);
  217.    Paragraph       : CONSTANT character := Eight_bit(167);
  218.    Diaraesis       : CONSTANT character := Eight_bit(168);
  219.    Copyright       : CONSTANT character := Eight_bit(169);
  220.    Fem_ordinal     : CONSTANT character := Eight_bit(170);
  221.    L_angle_quote   : CONSTANT character := Eight_bit(171);
  222.    Not_sign        : CONSTANT character := Eight_bit(172);
  223.    Soft_hyphen     : CONSTANT character := Eight_bit(173);
  224.    Reg_trade       : CONSTANT character := Eight_bit(174);
  225.    Macron          : CONSTANT character := Eight_bit(175);
  226.    Degree          : CONSTANT character := Eight_bit(176);
  227.    Plus_minus      : CONSTANT character := Eight_bit(177);
  228.    Super_2         : CONSTANT character := Eight_bit(178);
  229.    Super_3         : CONSTANT character := Eight_bit(179);
  230.    Acute           : CONSTANT character := Eight_bit(180);
  231.    Mu              : CONSTANT character := Eight_bit(181);
  232.    Pilcrow         : CONSTANT character := Eight_bit(182);
  233.    Middle_dot      : CONSTANT character := Eight_bit(183);
  234.    Cedilla         : CONSTANT character := Eight_bit(184);
  235.    Super_1         : CONSTANT character := Eight_bit(185);
  236.    Mask_ord        : CONSTANT character := Eight_bit(186);
  237.    R_angle_quote   : CONSTANT character := Eight_bit(187);
  238.    Quarter         : CONSTANT character := Eight_bit(188);
  239.    Half            : CONSTANT character := Eight_bit(189);
  240.    Three_quarter   : CONSTANT character := Eight_bit(190);
  241.    Query_up_down   : CONSTANT character := Eight_bit(191);
  242.    UC_A_grave      : CONSTANT character := Eight_bit(192);
  243.    UC_A_acute      : CONSTANT character := Eight_bit(193);
  244.    UC_A_circum     : CONSTANT character := Eight_bit(194);
  245.    UC_A_tilde      : CONSTANT character := Eight_bit(195);
  246.    UC_A_dots       : CONSTANT character := Eight_bit(196);
  247.    UC_A_ring       : CONSTANT character := Eight_bit(197);
  248.    UC_AE           : CONSTANT character := Eight_bit(198);
  249.    UC_C_cedilla    : CONSTANT character := Eight_bit(199);
  250.    UC_E_grave      : CONSTANT character := Eight_bit(200);
  251.    UC_E_acute      : CONSTANT character := Eight_bit(201);
  252.    UC_E_circum     : CONSTANT character := Eight_bit(202);
  253.    UC_E_dots       : CONSTANT character := Eight_bit(203);
  254.    UC_I_grave      : CONSTANT character := Eight_bit(204);
  255.    UC_I_acute      : CONSTANT character := Eight_bit(205);
  256.    UC_I_circum     : CONSTANT character := Eight_bit(206);
  257.    UC_I_dots       : CONSTANT character := Eight_bit(207);
  258.    UC_edh          : CONSTANT character := Eight_bit(208);
  259.    UC_N_tilde      : CONSTANT character := Eight_bit(209);
  260.    UC_O_grave      : CONSTANT character := Eight_bit(210);
  261.    UC_O_acute      : CONSTANT character := Eight_bit(211);
  262.    UC_O_circum     : CONSTANT character := Eight_bit(212);
  263.    UC_O_tilde      : CONSTANT character := Eight_bit(213);
  264.    UC_O_dots       : CONSTANT character := Eight_bit(214);
  265.    Mult_sign       : CONSTANT character := Eight_bit(215);
  266.    UC_O_oblique    : CONSTANT character := Eight_bit(216);
  267.    UC_U_grave      : CONSTANT character := Eight_bit(217);
  268.    UC_U_acute      : CONSTANT character := Eight_bit(218);
  269.    UC_U_circum     : CONSTANT character := Eight_bit(219);
  270.    UC_U_dots       : CONSTANT character := Eight_bit(220);
  271.    UC_Y_acute      : CONSTANT character := Eight_bit(221);
  272.    UC_thorn        : CONSTANT character := Eight_bit(222);
  273.    LC_s_sharp      : CONSTANT character := Eight_bit(223);
  274.    LC_a_grave      : CONSTANT character := Eight_bit(224);
  275.    LC_a_acute      : CONSTANT character := Eight_bit(225);
  276.    LC_a_circum     : CONSTANT character := Eight_bit(226);
  277.    LC_a_tilde      : CONSTANT character := Eight_bit(227);
  278.    LC_a_dots       : CONSTANT character := Eight_bit(228);
  279.    LC_a_ring       : CONSTANT character := Eight_bit(229);
  280.    LC_ae           : CONSTANT character := Eight_bit(230);
  281.    LC_c_cedilla    : CONSTANT character := Eight_bit(231);
  282.    LC_e_grave      : CONSTANT character := Eight_bit(232);
  283.    LC_e_acute      : CONSTANT character := Eight_bit(233);
  284.    LC_e_circum     : CONSTANT character := Eight_bit(234);
  285.    LC_e_dots       : CONSTANT character := Eight_bit(235);
  286.    LC_i_grave      : CONSTANT character := Eight_bit(236);
  287.    LC_i_acute      : CONSTANT character := Eight_bit(237);
  288.    LC_i_circum     : CONSTANT character := Eight_bit(238);
  289.    LC_i_dots       : CONSTANT character := Eight_bit(239);
  290.    LC_edh          : CONSTANT character := Eight_bit(240);
  291.    LC_n_tilde      : CONSTANT character := Eight_bit(241);
  292.    LC_o_grave      : CONSTANT character := Eight_bit(242);
  293.    LC_o_acute      : CONSTANT character := Eight_bit(243);
  294.    LC_o_circum     : CONSTANT character := Eight_bit(244);
  295.    LC_o_tilde      : CONSTANT character := Eight_bit(245);
  296.    LC_o_dots       : CONSTANT character := Eight_bit(246);
  297.    Div_sign        : CONSTANT character := Eight_bit(247);
  298.    LC_o_oblique    : CONSTANT character := Eight_bit(248);
  299.    LC_u_grave      : CONSTANT character := Eight_bit(249);
  300.    LC_u_acute      : CONSTANT character := Eight_bit(250);
  301.    LC_u_circum     : CONSTANT character := Eight_bit(251);
  302.    LC_u_dots       : CONSTANT character := Eight_bit(252);
  303.    LC_y_acute      : CONSTANT character := Eight_bit(253);
  304.    LC_thorn        : CONSTANT character := Eight_bit(254);
  305.    LC_y_dots       : CONSTANT character := Eight_bit(255);
  306. END ISO_latin_1;
  307. --::::::::::
  308. --natascii.a
  309. --::::::::::
  310. ----------------------------------------------------------------------
  311. --                      PACKAGE National ASCII                      --
  312. ----------------------------------------------------------------------
  313. -- This package declares alternate names for the ASCII codes
  314. -- 64, 91-94, 96 and 123-126 to be used when when these codes refers 
  315. -- to national characters. The names are restricted to letters. 
  316. -- Languages covered: Swedish/Finnish, Danish/Norwegian, German, 
  317. -- French and Italian.
  318.  
  319. PACKAGE National_ASCII IS
  320.  
  321. -- Swedish and Finnish
  322.    SW_UC_E_acute   : CONSTANT character := '@';
  323.    SW_UC_A_ring    : CONSTANT character := ']';
  324.    SW_UC_A_dots    : CONSTANT character := '[';
  325.    SW_UC_O_dots    : CONSTANT character := '\';
  326.    SW_UC_U_dots    : CONSTANT character := '^';
  327.    SW_LC_e_acute   : CONSTANT character := '`';
  328.    SW_LC_a_ring    : CONSTANT character := '}';
  329.    SW_LC_a_dots    : CONSTANT character := '{';
  330.    SW_LC_o_dots    : CONSTANT character := '|';
  331.    SW_LC_u_dots    : CONSTANT character := '~';
  332.                    
  333. -- Danish and Norwegian
  334.    DA_UC_AE        : CONSTANT character := '[';
  335.    DA_UC_O_oblique : CONSTANT character := '\';
  336.    DA_UC_A_ring    : CONSTANT character := ']';
  337.    DA_UC_U_dots    : CONSTANT character := '^';
  338.    DA_LC_ae        : CONSTANT character := '{';
  339.    DA_LC_o_oblique : CONSTANT character := '|';
  340.    DA_LC_a_ring    : CONSTANT character := '}';
  341.    DA_LC_u_dots    : CONSTANT character := '~';
  342.                    
  343. -- German          
  344.    GER_UC_A_dots   : CONSTANT character := '[';
  345.    GER_UC_O_dots   : CONSTANT character := '\';
  346.    GER_UC_U_dots   : CONSTANT character := ']';
  347.    GER_LC_a_dots   : CONSTANT character := '{';
  348.    GER_LC_o_dots   : CONSTANT character := '|';
  349.    GER_LC_u_dots   : CONSTANT character := '}';
  350.    GER_LC_s_sharp  : CONSTANT character := '~';
  351.                    
  352. -- French          
  353.    FR_LC_a_grave   : CONSTANT character := '@';
  354.    FR_LC_c_cedilla : CONSTANT character := '\';
  355.    FR_LC_e_acute   : CONSTANT character := '{';
  356.    FR_LC_u_grave   : CONSTANT character := '|';
  357.    FR_LC_e_grave   : CONSTANT character := '}';
  358.                    
  359. -- Italian         
  360.    IT_LC_A_ring    : CONSTANT character := ']';
  361.    IT_LC_u_grave   : CONSTANT character := '`';
  362.    IT_LC_a_grave   : CONSTANT character := '}';
  363.    IT_LC_o_grave   : CONSTANT character := '{';
  364.    IT_LC_e_grave   : CONSTANT character := '|';
  365.    IT_LC_i_grave   : CONSTANT character := '~';
  366.                    
  367. END National_ASCII;
  368. --::::::::::
  369. --strcomps.a
  370. --::::::::::
  371. ----------------------------------------------------------------------
  372. --                 SPECIFCATION String_comparison                   --
  373. ----------------------------------------------------------------------
  374. -- This package provides operations for comparing strings according to 
  375. -- a user-defined scheme.
  376. -- The package contains operations for load an internal coding table, 
  377. -- routines for coding strings and for comparing coded strings.
  378. PACKAGE String_comparison IS
  379.  
  380.    -- Load a character as the next in the primary colltating sequence
  381.    PROCEDURE Load_alphabetic(ch : IN character);
  382.    PROCEDURE Alpha_both_cases(ch : IN character);  
  383.    
  384.    -- Load a variant of a character in the main sequence, on accent
  385.    -- level, on case level or as exactly the same.
  386.    TYPE Equivalence_kind IS (Exact, Case_diff, Accented);   
  387.    PROCEDURE Load_variant(ch       : IN character;  
  388.                           Equ_ch   : IN character;
  389.                           Equ_kind : IN Equivalence_kind);
  390.    -- The three below always load on accent level.
  391.    PROCEDURE Load_variant(ch      : IN character;  
  392.                           Equ_str : IN string);  
  393.    PROCEDURE Variant_both_cases(ch     : IN character;
  394.                                 Equ_ch : IN character);
  395.    PROCEDURE Variant_both_cases(ch      : IN character;       
  396.                                 Equ_str : IN string);
  397.                          
  398.    -- Exceptions that can be raised by the load operations
  399.    Undefined_equivalent : EXCEPTION;
  400.    Already_defined      : EXCEPTION;
  401.  
  402.    -- Change case significance when loading both cases. Default is off.
  403.    PROCEDURE Set_case_significance(Flag : boolean);
  404.                                                        
  405.    -- Transscript type and coding operations
  406.    TYPE Transscripted_string(Max_length : natural) IS PRIVATE;
  407.    PROCEDURE Transscribe(ch        : IN character;
  408.                          Trans_str : OUT Transscripted_string);
  409.    PROCEDURE Transscribe(Str       : IN string;
  410.                          Trans_str : OUT Transscripted_string);
  411.    Transscription_error : EXCEPTION;
  412.  
  413.    -- Comparison operators
  414.    FUNCTION "<=" (Left, Right : Transscripted_string) RETURN boolean;
  415.    FUNCTION "<"  (Left, Right : Transscripted_string) RETURN boolean;
  416.    FUNCTION ">=" (Left, Right : Transscripted_string) RETURN boolean;
  417.    FUNCTION ">"  (Left, Right : Transscripted_string) RETURN boolean;
  418.  
  419.    -- Others
  420.    FUNCTION Is_letter(ch : character) RETURN boolean;
  421.    
  422. PRIVATE            
  423.    TYPE Natural_string IS ARRAY(integer RANGE <>) OF natural;
  424.    TYPE Boolean_string IS ARRAY(integer RANGE <>) OF boolean;
  425.    TYPE Transscripted_string(Max_length : natural) IS
  426.    RECORD
  427.       Length            : natural := 0;
  428.       Alphabetic        : Natural_string(1..Max_length) := (OTHERS => 0);
  429.       Accents           : Natural_string(1..Max_length) := (OTHERS => 0);
  430.       Case_part         : Boolean_string(1..Max_length) := (OTHERS => false);
  431.       Non_letter_length : natural := 0;
  432.       Non_letters       : Natural_string(1..Max_length) := (OTHERS => 256);
  433.    END RECORD;
  434. END String_comparison;
  435. --::::::::::
  436. --strcompb.a
  437. --::::::::::
  438. ----------------------------------------------------------------------
  439. --                    BODY string_comparison                        --
  440. ----------------------------------------------------------------------
  441. -- This file contains the implementation part of the string comparison
  442. -- package.
  443.  
  444. PACKAGE BODY string_comparison IS
  445.  
  446. --   CONTENTS
  447. --   --------
  448. --      Type declarations and simple functions
  449. --      Internal Load operations
  450. --      Exported load operations
  451. --      Internal routines for transscribing numbers
  452. --      Exported transscription operations
  453. --      Internal comparison procedures
  454. --      Exportered string comparators
  455.                      
  456. -- The transscription table
  457.    -- The translation of a character is a string. This is for characters 
  458.    -- like the AE ligature. Also useful is you want "0" = "zero".
  459.    TYPE Transscript_entry(Length : positive) IS 
  460.        RECORD    
  461.           Alphabetic   : Natural_string(1..Length) := (OTHERS => 0);
  462.           Accent       : Natural_string(1..Length) := (OTHERS => 0);
  463.           Case_variant : boolean := false;
  464.        END RECORD;                        
  465.    TYPE Entry_ptr IS ACCESS Transscript_entry; 
  466.    -- Pointer to allow different sizes 
  467.  
  468.    -- The index in the table is the ordinal number. Ada's character type is
  469.    -- limited to 127.
  470.    Char_table : ARRAY (0..255) OF Entry_ptr := (OTHERS => NULL);
  471.           
  472.  
  473. -- Other types
  474.    -- This type is for internal comparison functions
  475.    TYPE Relation_type IS (Less_than, Equal, Greater_than);
  476.  
  477.    -- Range for the number characters
  478.    SUBTYPE Numbers IS integer RANGE character'pos('0')..character'pos('9');
  479.  
  480. -- Variables
  481.    -- Case significance
  482.    Case_significant : boolean := true;
  483.  
  484.    -- Last used codes 
  485.    Last_alpha_code  : integer := 0; 
  486.    Last_accent_code : integer := 0; 
  487.    -- When storing an alphabetic we increment Last_alpha_code, when loading
  488.    -- a accent variant we increment Last_accent_code.
  489.  
  490. -- Simple functions
  491.    FUNCTION Is_letter(ch : character) RETURN boolean IS
  492.    BEGIN
  493.       RETURN Char_table(character'pos(ch)).Length > 0;
  494.    END;
  495.  
  496.    -- Set case significance for the double-case load operations
  497.    PROCEDURE Set_case_significance(Flag : boolean) IS
  498.    BEGIN
  499.       Case_significant := Flag;
  500.    END;
  501.  
  502. -- Internal Load operations
  503.    -- These take integer parametes. The exported routines call these.
  504.    -- We're having integer to avoid problems with characters over 127.
  505.    
  506.    PROCEDURE Load_alphabetic(ch : integer) IS
  507.    -- Load ch in the table as a one without any Accent part. If ch is already
  508.    -- defined, raise Already defined.
  509.    BEGIN
  510.       IF Char_table(ch) /= NULL THEN
  511.          RAISE Already_defined;   
  512.       END IF;                  
  513.       Char_table(ch) := NEW Transscript_entry(1); 
  514.       Last_alpha_code := Last_alpha_code + 1;
  515.       Char_table(ch).Alphabetic(1) := Last_alpha_code;
  516.    END Load_alphabetic;
  517.                                                           
  518.    PROCEDURE Load_variant(ch       : IN integer;
  519.                           Equ_ch   : IN integer;
  520.                           Equ_kind : IN Equivalence_kind) IS
  521.    -- Load ch as an variant of Equ_ch. Equ_ch must be defined or else 
  522.    -- we raise Undefined_equivalent.
  523.    BEGIN
  524.       IF Char_table(ch) /= NULL THEN     
  525.          RAISE Already_defined;   
  526.       END IF;
  527.       IF Char_table(Equ_ch) = NULL THEN
  528.          RAISE Undefined_equivalent;
  529.       END IF;                           
  530.       Char_table(ch) := NEW Transscript_entry(Char_table(Equ_ch).Length); 
  531.       Char_table(ch).Alphabetic   := Char_table(Equ_ch).Alphabetic;
  532.       Char_table(ch).Accent       := Char_table(Equ_ch).Accent;
  533.       Char_table(ch).Case_variant := Char_table(Equ_ch).Case_variant;
  534.       -- Actually: Char_table(ch).all := Char_table(Equ_ch).all;
  535.       -- Alas, Verdix Ada can't handle this properly
  536.       CASE Equ_kind IS
  537.          WHEN Exact     => NULL;                          
  538.          WHEN Case_diff => Char_table(ch).Case_variant := true;
  539.          WHEN Accented  => Last_accent_code         := Last_accent_code + 1;
  540.                            Char_table(ch).Accent(1) := Last_accent_code;
  541.       END CASE;
  542.    END Load_variant;
  543.  
  544.    PROCEDURE Load_variant(ch      : IN integer;
  545.                           Equ_str : IN Natural_string) IS
  546.    -- Load ch as an accented letter (digraph) of Equ_str. If not all 
  547.    -- characters in Equ_str are deifined, raise Undefined_equivalent.
  548.    BEGIN
  549.       IF Char_table(ch) /= NULL THEN     
  550.          RAISE Already_defined;   
  551.       END IF;
  552.       FOR i IN Equ_str'range LOOP
  553.          IF Char_table(Equ_str(i)) = NULL THEN
  554.             RAISE Undefined_equivalent;
  555.          END IF;
  556.       END LOOP;                      
  557.       Char_table(ch) := NEW Transscript_entry(Equ_str'length);
  558.       FOR i IN Equ_str'range LOOP
  559.          Char_table(ch).Alphabetic(i) := Char_table(Equ_str(i)).Alphabetic(1); 
  560.          Last_accent_code := Last_accent_code + 1;   
  561.          Char_table(ch).Accent(i) := Last_accent_code; 
  562.       END LOOP;                      
  563.    END Load_variant;
  564.  
  565. -- The exported load operations
  566.    PROCEDURE Load_alphabetic(ch : IN character) IS
  567.    BEGIN
  568.       Load_alphabetic(character'pos(ch));
  569.    END Load_alphabetic;
  570.  
  571.    PROCEDURE Load_variant(ch       : IN character;  
  572.                           Equ_ch   : IN character;
  573.                           Equ_kind : IN Equivalence_kind) IS
  574.    BEGIN
  575.       Load_variant(character'pos(ch), character'pos(Equ_ch), Equ_kind);
  576.    END Load_variant;
  577.  
  578.    PROCEDURE Load_variant(ch       : IN character;  
  579.                           Equ_str  : IN string) IS
  580.    Equ_int : Natural_string(Equ_str'range);
  581.    BEGIN
  582.       FOR i IN Equ_str'range LOOP
  583.          Equ_int(i) := character'pos(Equ_str(i));
  584.       END LOOP;
  585.       Load_variant(character'pos(ch), Equ_int);
  586.    END Load_variant;
  587.    
  588.  
  589. -- Exported double-case load operations. 
  590.    PROCEDURE Alpha_both_cases(ch : IN character) IS
  591.    Int_ch : integer := character'pos(ch);
  592.    BEGIN
  593.       Load_alphabetic(Int_ch);
  594.       IF Case_significant THEN
  595.          Load_variant(Int_ch + 32, Int_ch, Case_diff);
  596.       ELSE
  597.          Load_variant(Int_ch + 32, Int_ch, Exact);
  598.       END IF;
  599.    END Alpha_both_cases;
  600.  
  601.    PROCEDURE Variant_both_cases(ch     : IN character;
  602.                                 Equ_ch : IN character) IS
  603.    Int_ch : integer := character'pos(ch);
  604.    BEGIN                                    
  605.       Load_variant(Int_ch, character'pos(Equ_ch), Accented);
  606.       IF Case_significant THEN
  607.          Load_variant(Int_ch + 32, Int_ch, Case_diff);
  608.       ELSE
  609.          Load_variant(Int_ch + 32, Int_ch, Exact);
  610.       END IF;
  611.    END Variant_both_cases;
  612.                       
  613.    PROCEDURE Variant_both_cases(ch      : IN character;       
  614.                                 Equ_str : IN string) IS
  615.    Int_ch : integer := character'pos(ch);
  616.    BEGIN
  617.       Load_variant(ch, Equ_str);
  618.       IF Case_significant THEN
  619.          Load_variant(Int_ch + 32, Int_ch, Case_diff);
  620.       ELSE
  621.          Load_variant(Int_ch + 32, Int_ch, Exact);
  622.       END IF;
  623.    END Variant_both_cases;
  624.                                   
  625. -- Internal procedure for transscribing numbers
  626.    PROCEDURE Get_number(Str    : IN     string;
  627.                         Str_ix : IN OUT integer;
  628.                         Number : OUT    integer) IS
  629.    -- Assume Str(Str_ix) is a number. Read as long there are numbers.
  630.    -- Leave Str_ix at the last number character.
  631.    No_in_str : natural := 0;
  632.    ch        : integer := character'pos(Str(Str_ix));       
  633.    BEGIN
  634.       WHILE ch IN Numbers LOOP 
  635.          No_in_str := 10 * No_in_str + ch - Numbers'first;
  636.          IF Str_ix + 1 IN Str'range THEN
  637.             Str_ix := Str_ix + 1;      
  638.             ch := character'pos(Str(Str_ix));      
  639.          ELSE
  640.             ch := 0;
  641.          END IF;
  642.       END LOOP;
  643.       Number := No_in_str;
  644.    EXCEPTION
  645.       WHEN Numeric_error => RAISE Transscription_error;
  646.    END;            
  647.    
  648. -- Exported transscription operations
  649.    PROCEDURE Transscribe(ch        : IN  character;
  650.                          Trans_str : OUT Transscripted_string) IS
  651.    BEGIN                           
  652.       Transscribe( (1 => ch), Trans_str);
  653.    END Transscribe;
  654.  
  655.    
  656.    PROCEDURE Transscribe(Str       : IN  string;
  657.                          Trans_str : OUT Transscripted_string) IS
  658.    -- Transscribe Str using the table. If the transscription does  
  659.    -- not fit into the out parameter, raise Transscription_error.
  660.    -- Characters in Str that are not defined are regarded as non-letters.
  661.    -- Non-letters are always stored at the their index in Str. 
  662.    -- Numbers are stored specially.
  663.    ch        : natural;       -- Current character;                  
  664.    Tr_ix     : natural := 0;  -- Index in Trans_str except the non-letter part.
  665.    Str_ix    : integer := Str'first;  -- Index in Str and non-letter part.
  666.    No_in_str : natural;
  667.    BEGIN            
  668.       WHILE Str_ix IN Str'range LOOP
  669.          ch := character'pos(Str(Str_ix));
  670.          IF Char_table(ch) /= NULL THEN
  671.             IF Tr_ix + Char_table(ch).Length > Trans_str.Max_length THEN 
  672.                RAISE Transscription_error;
  673.             END IF;                                                         
  674.             IF ch NOT IN Numbers OR Char_table(ch).Accent(1) /= 0 THEN
  675.                FOR i IN 1..Char_table(ch).Length LOOP
  676.                   Tr_ix := Tr_ix + 1;
  677.                   Trans_str.Alphabetic(Tr_ix) := Char_table(ch).Alphabetic(i);
  678.                   Trans_str.Case_part(Tr_ix)  := Char_table(ch).Case_variant;
  679.                   Trans_str.Accents(Tr_ix)    := Char_table(ch).Accent(i);
  680.                END LOOP;
  681.             ELSE 
  682.                Get_number(Str, Str_ix, No_in_str);
  683.                Tr_ix := Tr_ix + 1;
  684.                Trans_str.Alphabetic(Tr_ix) := 1000 + No_in_str;
  685.             END IF;
  686.          ELSE
  687.             IF Str_ix > Trans_str.Max_length THEN
  688.                RAISE Transscription_error;
  689.             END IF;
  690.             Trans_str.Non_letters(Str_ix) := ch;
  691.             Trans_str.Non_letter_length   := Str_ix;
  692.          END IF;   
  693.          Str_ix := Str_ix + 1;
  694.       END LOOP;
  695.       Trans_str.Length := Tr_ix;
  696.    END Transscribe;
  697.  
  698. -- Internal comparison routines      
  699.  
  700.    FUNCTION Relation(Left, Right : Natural_string) RETURN Relation_type IS
  701.    -- This function is more os less obsolete. "<" etc should do the job.
  702.    -- Verdix Ada can't this on integer arrays, unfortunately.
  703.    i   : positive := 1;
  704.    Bug : EXCEPTION; -- Should not occur
  705.    BEGIN
  706.       WHILE (i <= Left'last AND i <= Right'last) AND THEN 
  707.             Left(i) = Right(i) LOOP
  708.          i := i + 1;
  709.       END LOOP;
  710.       IF i > Left'last AND i > Right'last THEN
  711.          RETURN Equal;
  712.       ELSIF i > Left'last THEN
  713.          RETURN Less_than;
  714.       ELSIF i > Right'last THEN
  715.          RETURN Greater_than;
  716.       ELSIF Left(i) < Right(i) THEN
  717.          RETURN Less_than;
  718.       ELSIF Left(i) > Right(i) THEN                            
  719.          RETURN Greater_than;
  720.       ELSE
  721.          RAISE Bug;   -- This should not occur.
  722.       END IF;
  723.    END Relation;
  724.  
  725.  
  726.    FUNCTION Relation(Left, Right : Transscripted_string) RETURN Relation_type IS
  727.    -- Compare the parts in order. Continue as long as there is unequallity.
  728.    Rel : Relation_type;
  729.    BEGIN                                                       
  730.       Rel := Relation(Left.Alphabetic(1..Left.Length), 
  731.                       Right.Alphabetic(1..Right.Length));
  732.       IF Rel /= Equal THEN
  733.          RETURN Rel;
  734.       END IF;
  735.       Rel := Relation(Left.Accents(1..Left.Length), 
  736.                       Right.Accents(1..Right.Length));
  737.       IF Rel /= Equal THEN
  738.          RETURN Rel;
  739.       END IF;
  740.       Rel := Relation(Left.Non_letters(1..Left.Non_letter_length), 
  741.                       Right.Non_letters(1..Right.Non_letter_length));
  742.       IF Rel /= Equal THEN
  743.          RETURN Rel;
  744.       END IF;
  745.       IF Left.Case_part(1..Left.Length) < 
  746.          Right.Case_part(1..Right.Length) THEN  
  747.          RETURN Less_than;
  748.       ELSIF Left.Case_part(1..Left.Length) >
  749.             Right.Case_part(1..Right.Length) THEN
  750.          RETURN Greater_than;
  751.       ELSE
  752.          RETURN Equal;
  753.       END IF;
  754.    END Relation;
  755.                      
  756. -- Exported comparison operators
  757.    FUNCTION "<=" (Left, Right : Transscripted_string) RETURN boolean IS
  758.    BEGIN
  759.       RETURN Relation(Left, Right) /= Greater_than;            
  760.    END;
  761.    
  762.    FUNCTION "<"  (Left, Right : Transscripted_string) RETURN boolean IS
  763.    BEGIN
  764.       RETURN Relation(Left, Right) = Less_than;
  765.    END;
  766.    
  767.    FUNCTION ">=" (Left, Right : Transscripted_string) RETURN boolean IS
  768.    BEGIN
  769.       RETURN Relation(Left, Right) /= Less_than;
  770.    END;
  771.    
  772.    FUNCTION ">"  (Left, Right : Transscripted_string) RETURN boolean IS
  773.    BEGIN
  774.       RETURN Relation(Left, Right) = Greater_than;
  775.    END;
  776.  
  777. END string_comparison;
  778. --::::::::::
  779. --define.a
  780. --::::::::::
  781. ----------------------------------------------------------------------
  782. --                  Define collating sequence                       --
  783. ----------------------------------------------------------------------
  784. -- This package contains a procedure with the same name that demon-
  785. -- strates the use of the load operations in the String_comparison 
  786. -- package. 
  787.  
  788.  
  789. PACKAGE Define IS
  790.    TYPE Languages IS (Swedish, Danish, German1, German2, French);
  791.    -- German1 sort "A, "O and "U as A, O  and U. German2 as AE, OE and UE.
  792.    PROCEDURE Collatting_sequence(Language         : IN Languages;
  793.                                  Case_significant : IN boolean;
  794.                                  Eightbit         : IN boolean);
  795. END Define;
  796.  
  797.  
  798. WITH String_comparison; USE String_comparison;
  799. WITH ISO_Latin_1;       USE ISO_Latin_1;
  800. WITH National_ASCII;    USE National_ASCII;
  801. PACKAGE BODY Define IS
  802.    PROCEDURE Collatting_sequence(Language         : IN Languages;
  803.                                  Case_significant : IN boolean;
  804.                                  Eightbit         : IN boolean) IS
  805.    BEGIN
  806.       -- Set the significane of case
  807.       Set_case_significance(Case_significant);
  808.    
  809.       -- Load space as the first letter and the A to Z
  810.       Load_alphabetic(' ');
  811.    
  812.       -- Load the letters from A to Z to begin with
  813.       FOR ch IN 'A'..'V' LOOP
  814.          Alpha_both_cases(ch);
  815.       END LOOP;
  816.       IF Language = Swedish THEN
  817.          Variant_both_cases('W', 'V');  
  818.       ELSE
  819.          Alpha_both_cases('W');
  820.       END IF;
  821.       FOR ch IN 'X'..'Z' LOOP
  822.          Alpha_both_cases(ch);
  823.       END LOOP;          
  824.    
  825.       -- And so for the specific letters. Begin with the seven-bits
  826.       IF NOT Eightbit THEN
  827.          CASE Language IS
  828.             WHEN Swedish =>  Alpha_both_cases(SW_UC_A_ring);
  829.                              Alpha_both_cases(SW_UC_A_dots);
  830.                              Alpha_both_cases(SW_UC_O_dots);
  831.                              Variant_both_cases(SW_UC_E_acute, 'E');
  832.                              Variant_both_cases(SW_UC_U_dots, 'Y');
  833.             WHEN Danish  =>  Alpha_both_cases(DA_UC_AE);
  834.                              Alpha_both_cases(DA_UC_O_oblique); 
  835.                              Alpha_both_cases(DA_UC_A_ring);
  836.             WHEN German1 =>  Variant_both_cases(GER_UC_A_dots, 'A');
  837.                              Variant_both_cases(GER_UC_O_dots, 'O');
  838.                              Variant_both_cases(GER_UC_U_dots, 'U');
  839.                              Load_variant(GER_LC_s_sharp, "ss");
  840.             WHEN German2 =>  Variant_both_cases(GER_UC_A_dots, "AE");
  841.                              Variant_both_cases(GER_UC_O_dots, "OE");
  842.                              Variant_both_cases(GER_UC_U_dots, "UE");
  843.                              Load_variant(GER_LC_s_sharp, "ss");
  844.             WHEN French  =>  Load_variant(FR_LC_a_grave, 'a', Accented);
  845.                              Load_variant(FR_LC_c_cedilla, 'c', Accented);
  846.                              Load_variant(FR_LC_e_acute, 'e', Accented);
  847.                              Load_variant(FR_LC_u_grave, 'u', Accented);
  848.                              Load_variant(FR_LC_e_grave, 'e', Accented);
  849.          END CASE;
  850. -- Now lets take the eightbit case, ISO-Latin/1.
  851.       ELSE                                          
  852.          -- First we take characters that differs from langauge to language
  853.          -- They are oA, "A, AE, "O, /O, and "U.
  854.          CASE Language IS
  855.             WHEN Swedish  => Alpha_both_cases(UC_A_ring);
  856.                              Alpha_both_cases(UC_A_dots);
  857.                              Variant_both_cases(UC_AE, UC_A_dots); 
  858.                              Alpha_both_cases(UC_O_dots);        
  859.                              Variant_both_cases(UC_O_oblique, UC_O_dots);
  860.                              Variant_both_cases(UC_U_dots, 'Y');
  861.             WHEN Danish   => Alpha_both_cases(UC_AE);
  862.                              Variant_both_cases(UC_A_dots, UC_AE);
  863.                              Alpha_both_cases(UC_O_oblique);
  864.                              Variant_both_cases(UC_O_dots, UC_O_oblique);
  865.                              Alpha_both_cases(UC_A_ring);
  866.                              Variant_both_cases(UC_U_dots, 'Y');       
  867.             WHEN German1 !
  868.                  French   => Variant_both_cases(UC_A_dots, 'A');
  869.                              Variant_both_cases(UC_O_dots, 'O');   
  870.                              Variant_both_cases(UC_U_dots, 'U');
  871.                              Variant_both_cases(UC_A_ring, 'A');
  872.                              Variant_both_cases(UC_O_oblique, 'O');
  873.                              Variant_both_cases(UC_AE, "AE"); 
  874.             WHEN German2  => Variant_both_cases(UC_A_dots, "AE");
  875.                              Variant_both_cases(UC_O_dots, "OE");   
  876.                              Variant_both_cases(UC_U_dots, "UE");
  877.                              Variant_both_cases(UC_A_ring, 'A');
  878.                              Variant_both_cases(UC_O_oblique, 'O');
  879.                              Variant_both_cases(UC_AE, "AE"); 
  880.          END CASE;
  881.        
  882.          -- All other variants 
  883.          Variant_both_cases(UC_A_grave, 'A');
  884.          Variant_both_cases(UC_A_acute, 'A');
  885.          Variant_both_cases(UC_A_circum, 'A');
  886.          Variant_both_cases(UC_A_tilde, 'A');
  887.          
  888.          Variant_both_cases(UC_C_cedilla, 'C');
  889.          
  890.          Variant_both_cases(UC_E_grave, 'E');
  891.          Variant_both_cases(UC_E_acute, 'E');
  892.          Variant_both_cases(UC_E_circum, 'E');
  893.          Variant_both_cases(UC_E_dots, 'E');
  894.                                    
  895.          Variant_both_cases(UC_Edh, 'D');
  896.          
  897.          Variant_both_cases(UC_I_grave, 'I');
  898.          Variant_both_cases(UC_I_acute, 'I');
  899.          Variant_both_cases(UC_I_circum, 'I');
  900.          Variant_both_cases(UC_I_dots, 'I');
  901.          
  902.          Variant_both_cases(UC_N_tilde, 'N');
  903.          
  904.          Variant_both_cases(UC_O_grave, 'O');
  905.          Variant_both_cases(UC_O_acute, 'O');
  906.          Variant_both_cases(UC_O_circum, 'O');
  907.          Variant_both_cases(UC_O_tilde, 'O');
  908.                         
  909.          Load_variant(LC_s_sharp, "ss");
  910.          
  911.          Variant_both_cases(UC_U_grave, 'U');
  912.          Variant_both_cases(UC_U_acute, 'U');
  913.          Variant_both_cases(UC_U_circum, 'U');
  914.              
  915.          Variant_both_cases(UC_Y_acute, 'Y');
  916.          Load_variant(LC_y_dots, 'y', Accented);
  917.       END IF;
  918.       
  919.       -- Finally the numbers
  920.       FOR ch IN '0'..'9' LOOP
  921.          Load_alphabetic(ch);
  922.       END LOOP;
  923.    END Collatting_sequence;
  924. END Define;
  925. --::::::::::
  926. --comline.a
  927. --::::::::::
  928. ----------------------------------------------------------------------
  929. --                 PROCEDURE Read_command_line                      --
  930. ----------------------------------------------------------------------
  931. -- This procedure reads the command line to get the options and the
  932. -- input file. You will probably have to replace it, unless you also
  933. -- use Verdix Ada system for Unix.
  934. WITH Define; Use Define;
  935. WITH Command_line; USE Command_line;       -- Verdix package
  936. WITH Text_io;
  937. WITH IO_exceptions;
  938. PROCEDURE Read_command_line(Language : OUT Define.Languages;
  939.                             Exact    : OUT boolean;
  940.                             Eightbit : OUT boolean) IS 
  941. BEGIN
  942.    FOR i IN 1..argc - 1 LOOP
  943.       IF argv(i).s(1) = '-' THEN
  944.          CASE argv(i).s(2) IS 
  945.             WHEN '8'       => Eightbit := true;
  946.             WHEN 'E' ! 'e' => Exact    := true;
  947.             WHEN 'L' ! 'l' => CASE argv(i).s(3) IS
  948.                                  WHEN 's' ! 'S' => Language := Swedish;
  949.                                  WHEN 'd' ! 'D' => Language := Danish;
  950.                                  WHEN 'g'       => Language := German1;
  951.                                  WHEN 'G'       => Language := German2;
  952.                                  WHEN 'f' ! 'F' => Language := French;
  953.                                  WHEN OTHERS    => NULL; 
  954.                               END CASE;                      
  955.             WHEN OTHERS    => Text_io.Put_line("Unknown option: " & argv(i).s);
  956.          END CASE;
  957.       ELSE
  958.          DECLARE
  959.             USE Text_io;
  960.             Infile : File_type;
  961.          BEGIN
  962.             Open(Infile, In_file, argv(i).s);
  963.             Set_input(Infile);
  964.          EXCEPTION
  965.             WHEN IO_exceptions.Name_error => 
  966.                  Put_line(argv(i).s & " does not exsist");
  967.          END;
  968.       END IF;
  969.    END LOOP;
  970. END Read_command_line;
  971. --::::::::::
  972. --main.a
  973. --::::::::::
  974. ----------------------------------------------------------------------
  975. --               Sort package and main program                      --
  976. ----------------------------------------------------------------------
  977. -- This file contains a sort package that uses the string-comparison
  978. -- package when sorting and the main program. The sort package is very 
  979. -- simple, it contains just one routine for inserting into the tree 
  980. -- and for writing the tree to standard output.  
  981. PACKAGE Sort_package IS 
  982.    PROCEDURE Insert(Str : IN string); 
  983.    PROCEDURE Write_tree;
  984. END Sort_package;
  985.                   
  986. -- The main program. Reads line from standard input and insert them
  987. -- into the sort package. When end-of-fils is detected, write the
  988. -- tree.
  989. WITH Text_io; 
  990. WITH IO_exceptions;
  991. WITH Sort_package;
  992. WITH Define; USE Define;
  993. WITH Read_command_line;
  994. PROCEDURE Main IS
  995.    Language : Define.Languages := Swedish;
  996.    Eightbit : boolean   := false;
  997.    Exact    : boolean   := false;
  998.    Line     : string(1..80);
  999.    Len      : natural;
  1000. BEGIN
  1001.    Read_command_line(Language, Exact, Eightbit);
  1002.    Define.collatting_sequence(Language, Exact, Eightbit);
  1003.    LOOP   
  1004.       Text_io.Get_line(Line, Len);
  1005.       Sort_package.Insert(Line(1..Len));
  1006.    END LOOP;                                    
  1007. EXCEPTION
  1008.    WHEN IO_exceptions.End_error => Sort_package.Write_tree;
  1009. END Main;
  1010.  
  1011. -- Below the body of the sort package
  1012. WITH Text_io;
  1013. WITH String_comparison; USE String_comparison;
  1014. PACKAGE BODY Sort_package IS 
  1015.    TYPE Tree_entry(Key_size : positive; Str_len  : natural);
  1016.    TYPE Tree_type IS ACCESS Tree_entry;
  1017.    TYPE Tree_entry(Key_size : positive; Str_len  : natural) IS 
  1018.         RECORD          
  1019.            Left   : Tree_type := NULL;
  1020.            Right  : Tree_type := NULL;
  1021.            Key    : Transscripted_string(Key_size);
  1022.            Str    : string(1..Str_len);
  1023.         END RECORD;
  1024.    Tree : Tree_type := NULL;
  1025.                 
  1026. -- Internal recursive insertion procedure. Called by the exported
  1027.    PROCEDURE Insert(Tree : IN OUT Tree_type;
  1028.                     Key  : IN Transscripted_string;
  1029.                     Str  : IN string) IS
  1030.    BEGIN
  1031.       IF Tree /= NULL THEN
  1032.          IF Key < Tree.Key THEN
  1033.             Insert(Tree.left, Key, Str);
  1034.          ELSIF Key > Tree.Key THEN 
  1035.             Insert(Tree.right, Key, Str);
  1036.          END IF;
  1037.       ELSE
  1038.          Tree     := NEW Tree_entry(Key.Max_length, Str'length); 
  1039.          Tree.Key := Key;
  1040.          Tree.Str := Str;
  1041.       END IF;
  1042.    END Insert;
  1043.  
  1044. -- Exported Insert
  1045.    PROCEDURE Insert(Str : IN string) IS
  1046.    Transscript : Transscripted_string(Str'length + 20);
  1047.    BEGIN
  1048.       Transscribe(Str, Transscript);   
  1049.       Insert(Tree, Transscript, Str);
  1050.    EXCEPTION
  1051.       WHEN Transscription_error =>
  1052.           Text_io.Put_line(Str);
  1053.           Text_io.Put_line("This line has too long transscription. Skipped.");
  1054.    END Insert;
  1055.  
  1056. -- This procedure travserse the tree and writes all entries on standard output
  1057.    PROCEDURE Write_tree(Tree : IN Tree_type) IS
  1058.    BEGIN                  
  1059.       IF Tree /= NULL THEN
  1060.          Write_tree(Tree.Left);
  1061.          Text_io.Put_line(Tree.Str);
  1062.          Write_tree(Tree.Right);
  1063.       END IF;
  1064.    END Write_tree;
  1065.  
  1066. -- Exported Write_tree;
  1067.    PROCEDURE Write_tree IS
  1068.    BEGIN
  1069.       Write_tree(Tree);
  1070.    END;
  1071.     
  1072. END Sort_package;
  1073.