regen/ebcdic.pl

   1 use v5.16.0;
   2 use strict;
   3 use warnings;
   4 require 'regen/regen_lib.pl';
   5 require 'regen/charset_translations.pl';
   6
   7 # Generates the EBCDIC translation tables that were formerly hard-coded into
   8 # utfebcdic.h
   9
  10 my $out_fh = open_new('ebcdic_tables.h', '>',
  11         {style => '*', by => $0, });
  12
  13 sub output_table ($$;$) {
  14     my $table_ref = shift;
  15     my $name = shift;
  16
  17     # Tables in hex easier to debug, but don't fit into 80 columns
  18     my $print_in_hex = shift // 1;
  19
  20     die "Requres 256 entries in table $name, got @$table_ref" if @$table_ref != 256;
  21
  22     print $out_fh "EXTCONST U8 $name\[\] = {\n";
  23
  24     my $column_numbers= "/*_0   _1   _2   _3   _4   _5   _6   _7   _8   _9   _A   _B   _C   _D   _E  _F*/\n";
  25     print $out_fh $column_numbers if $print_in_hex;
  26     for my $i (0 .. 255) {
  27         if ($print_in_hex) {
  28             # No row headings, so will fit in 80 cols.
  29             #printf $out_fh "/* %X_ */ ", $i / 16 if $i % 16 == 0;
  30             printf $out_fh "0x%02X", $table_ref->[$i];
  31         }
  32         else {
  33             printf $out_fh "%4d", $table_ref->[$i];
  34         }
  35         print $out_fh ",", if $i < 255;
  36         #print $out_fh ($i < 255) ? "," : " ";
  37         #printf $out_fh " /* %X_ */", $i / 16 if $print_in_hex && $i % 16 == 15;
  38         print $out_fh "\n" if $i % 16 == 15;
  39     }
  40     print $out_fh $column_numbers if $print_in_hex;
  41     print $out_fh "};\n\n";
  42 }
  43
  44 print $out_fh <<END;
  45
  46 #ifndef H_EBCDIC_TABLES   /* Guard against nested #includes */
  47 #define H_EBCDIC_TABLES   1
  48
  49 /* This file contains definitions for various tables used in EBCDIC handling.
  50  * More info is in utfebcdic.h */
  51 END
  52
  53 my @charsets = get_supported_code_pages();
  54 shift @charsets;    # ASCII is the 0th, and we don't deal with that here.
  55 foreach my $charset (@charsets) {
  56     # we process the whole array several times, make a copy
  57     my @a2e = @{get_a2n($charset)};
  58
  59     print $out_fh "\n" . get_conditional_compile_line_start($charset);
  60     print $out_fh "\n";
  61
  62     print $out_fh "/* Index is ASCII platform code point; value is $charset equivalent */\n";
  63     output_table(\@a2e, "PL_a2e");
  64
  65     { # Construct the inverse
  66         my @e2a;
  67         for my $i (0 .. 255) {
  68             $e2a[$a2e[$i]] = $i;
  69         }
  70         print $out_fh "/* Index is $charset code point; value is ASCII platform equivalent */\n";
  71         output_table(\@e2a, "PL_e2a");
  72     }
  73
  74     my @i82utf = @{get_I8_2_utf($charset)};
  75     print $out_fh <<END;
  76 /* (Confusingly named) Index is $charset I8 byte; value is
  77  * $charset UTF-EBCDIC equivalent */
  78 END
  79     output_table(\@i82utf, "PL_utf2e");
  80
  81     { #Construct the inverse
  82         my @utf2i8;
  83         for my $i (0 .. 255) {
  84             $utf2i8[$i82utf[$i]] = $i;
  85         }
  86         print $out_fh <<END;
  87 /* (Confusingly named) Index is $charset UTF-EBCDIC byte; value is
  88  * $charset I8 equivalent */
  89 END
  90         output_table(\@utf2i8, "PL_e2utf");
  91     }
  92
  93     {
  94         my @utf8skip;
  95
  96         # These are invariants or continuation bytes.
  97         for my $i (0 .. 0xBF) {
  98             $utf8skip[$i82utf[$i]] = 1;
  99         }
 100
 101         # These are start bytes;  The skip is the number of consecutive highest
 102         # order 1-bits (up to 7)
 103         for my $i (0xC0 .. 255) {
 104             my $count;
 105             if ($i == 0b11111111) {
 106                 no warnings 'once';
 107                 $count = $CHARSET_TRANSLATIONS::UTF_EBCDIC_MAXBYTES;
 108             }
 109             elsif (($i & 0b11111110) == 0b11111110) {
 110                 $count= 7;
 111             }
 112             elsif (($i & 0b11111100) == 0b11111100) {
 113                 $count= 6;
 114             }
 115             elsif (($i & 0b11111000) == 0b11111000) {
 116                 $count= 5;
 117             }
 118             elsif (($i & 0b11110000) == 0b11110000) {
 119                 $count= 4;
 120             }
 121             elsif (($i & 0b11100000) == 0b11100000) {
 122                 $count= 3;
 123             }
 124             elsif (($i & 0b11000000) == 0b11000000) {
 125                 $count= 2;
 126             }
 127             else {
 128                 die "Something wrong for UTF8SKIP calculation for $i";
 129             }
 130             $utf8skip[$i82utf[$i]] = $count;
 131         }
 132
 133         print $out_fh <<END;
 134 /* Index is $charset UTF-EBCDIC byte; value is UTF8SKIP for start bytes;
 135  * 1 for continuation.  Adapted from the shadow flags table in tr16.  The
 136  * entries marked 9 in tr16 are continuation bytes and are marked as length 1
 137  * here so that we can recover. */
 138 END
 139         output_table(\@utf8skip, "PL_utf8skip", 0);  # The 0 means don't print
 140                                                      # in hex
 141     }
 142
 143     use feature 'unicode_strings';
 144
 145     {
 146         my @lc;
 147         for my $i (0 .. 255) {
 148             $lc[$a2e[$i]] = $a2e[ord lc chr $i];
 149         }
 150         print $out_fh "/* Index is $charset code point; value is its lowercase equivalent */\n";
 151         output_table(\@lc, "PL_latin1_lc");
 152     }
 153
 154     {
 155         my @uc;
 156         for my $i (0 .. 255) {
 157             my $uc = uc chr $i;
 158             if (length $uc > 1 || ord $uc > 255) {
 159                 $uc = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}";
 160             }
 161             $uc[$a2e[$i]] = $a2e[ord $uc];
 162         }
 163         print $out_fh <<END;
 164 /* Index is $charset code point; value is its uppercase equivalent.
 165  * The 'mod' in the name means that codepoints whose uppercase is above 255 or
 166  * longer than 1 character map to LATIN SMALL LETTER Y WITH DIARESIS */
 167 END
 168         output_table(\@uc, "PL_mod_latin1_uc");
 169     }
 170
 171     { # PL_fold
 172         my @ascii_fold;
 173         for my $i (0 .. 255) {  # Initialise to identity map
 174             $ascii_fold[$i] = $i;
 175         }
 176
 177         # Overwrite the entries that aren't identity
 178         for my $chr ('A' .. 'Z') {
 179             $ascii_fold[$a2e[ord $chr]] = $a2e[ord lc $chr];
 180         }
 181         for my $chr ('a' .. 'z') {
 182             $ascii_fold[$a2e[ord $chr]] = $a2e[ord uc $chr];
 183         }
 184         print $out_fh <<END;
 185 /* Index is $charset code point; For A-Z, value is a-z; for a-z, value
 186  * is A-Z; all other code points map to themselves */
 187 END
 188         output_table(\@ascii_fold, "PL_fold");
 189     }
 190
 191     {
 192         my @latin1_fold;
 193         for my $i (0 .. 255) {
 194             my $char = chr $i;
 195             my $lc = lc $char;
 196
 197             # lc and uc adequately proxy for fold-case pairs in this 0-255
 198             # range
 199             my $uc = uc $char;
 200             $uc = $char if length $uc > 1 || ord $uc > 255;
 201             if ($lc ne $char) {
 202                 $latin1_fold[$a2e[$i]] = $a2e[ord $lc];
 203             }
 204             elsif ($uc ne $char) {
 205                 $latin1_fold[$a2e[$i]] = $a2e[ord $uc];
 206             }
 207             else {
 208                 $latin1_fold[$a2e[$i]] = $a2e[$i];
 209             }
 210         }
 211         print $out_fh <<END;
 212 /* Index is $charset code point; value is its other fold-pair equivalent
 213  * (A => a; a => A, etc) in the 0-255 range.  If no such equivalent, value is
 214  * the code point itself */
 215 END
 216         output_table(\@latin1_fold, "PL_fold_latin1");
 217     }
 218
 219     print $out_fh get_conditional_compile_line_end();
 220 }
 221
 222 print $out_fh "\n#endif /* H_EBCDIC_TABLES */\n";
 223
 224 read_only_bottom_close_and_rename($out_fh);