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