This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regen/ebcdic.pl: Add capability to generate a dfa table
[perl5.git] / regen / ebcdic.pl
1 use v5.16.0;
2 use strict;
3 use warnings;
4 use integer;
5
6 BEGIN { unshift @INC, '.' }
7
8 require './regen/regen_lib.pl';
9 require './regen/charset_translations.pl';
10
11 # Generates the EBCDIC translation tables that were formerly hard-coded into
12 # utfebcdic.h
13
14 my $out_fh = open_new('ebcdic_tables.h', '>',
15         {style => '*', by => $0, });
16
17 sub get_column_headers ($$;$) {
18     my ($row_hdr_len, $field_width, $dfa_columns) = @_;
19     my $format;
20     my $final_column_format;
21     my $num_columns;
22
23     if (defined $dfa_columns) {
24         $num_columns = $dfa_columns;
25
26         # Trailing blank to correspond with commas in the rows below
27         $format = "%${field_width}d ";
28     }
29     else {  # Is a regular table
30         $num_columns = 16;
31
32         # Use blanks to separate the fields
33         $format = " " x ( $field_width
34                         - 2);               # For the '_X'
35         $format .= "_%X ";  # Again, trailing blank over the commas below
36     }
37
38     my $header = "/*" . " " x ($row_hdr_len - length "/*");
39
40     # All but the final column
41     $header .= sprintf($format, $_) for 0 .. $num_columns - 2;
42
43      # Get rid of trailing blank, so that the final column takes up one less
44      # space so that the "*/" doesn't extend past the commas in the rows below
45     chop $header;
46     $header .= sprintf $format, $num_columns - 1;
47
48     # Again, remove trailing blank
49     chop $header;
50
51     return $header . "*/\n";
52 }
53
54 sub output_table ($$;$) {
55     my $table_ref = shift;
56     my $name = shift;
57
58     # 0 => print in decimal
59     # 1 => print in hex (translates code point to code point)
60     # >= 2 => is a dfa table, like http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
61     #      The number is how many columns in the part after the code point
62     #      portion.
63     #
64     # code point tables in hex areasier to debug, but don't fit into 80
65     # columns
66     my $type = shift // 1;
67
68     my $print_in_hex = $type == 1;
69     my $is_dfa = ($type >= 2) ? $type : 0;
70     my $columns_after_256 = 16;
71
72     die "Requres 256 entries in table $name, got @$table_ref"
73                                 if ! $is_dfa && @$table_ref != 256;
74     if (! $is_dfa) {
75         die "Requres 256 entries in table $name, got @$table_ref"
76                                                         if @$table_ref != 256;
77     }
78     else {
79         $columns_after_256 = $is_dfa;
80
81         print $out_fh <<'EOF';
82
83 /* The table below is adapted from
84  *      http://bjoern.hoehrmann.de/utf-8/decoder/dfa/
85  * See copyright notice at the beginning of this file.
86  */
87
88 EOF
89     }
90
91     # Highest number in the table
92     my $max_entry = 0;
93     $max_entry = map { $_ > $max_entry ? $_ : $max_entry } @$table_ref;
94
95     # We assume that every table has at least one two digit entry, and none
96     # are more than three digit.
97     my $field_width = ($print_in_hex)
98                       ? 4
99                       : (($max_entry) > 99 ? 3 : 2);
100
101     my $row_hdr_length;
102     my $node_number_field_width;
103     my $node_value_field_width;
104
105     # dfa tables have a special header for the rows in the transitions part of
106     # the table.  It is longer than the regular one.
107     if ($is_dfa) {
108         my $max_node_number = ($max_entry - 256) / $columns_after_256 - 1;
109         $node_number_field_width = ($max_node_number > 9) ? 2 : 1;
110         $node_value_field_width = ($max_node_number * $columns_after_256 > 99)
111                                   ? 3 : 2;
112         # The header starts with this template, and adds in the number of
113         # digits needed to represent the maximum node number and its value
114         $row_hdr_length = length("/*N=*/")
115                         + $node_number_field_width
116                         + $node_value_field_width;
117     }
118     else {
119         $row_hdr_length = length "/*_X*/";  # Template for what the header
120                                             # looks like
121     }
122
123     # The table may not be representable in 8 bits.
124     my $TYPE = 'U8';
125     $TYPE = 'U16' if grep { $_ > 255 } @$table_ref;
126
127     my $declaration = "EXTCONST $TYPE $name\[\]";
128     print $out_fh <<EOF;
129 #  ifndef DOINIT
130 #    $declaration;
131 #  else
132 #    $declaration = {
133 EOF
134
135     # First the headers for the columns
136     print $out_fh get_column_headers($row_hdr_length, $field_width);
137
138     # Now the table body
139     my $count = @$table_ref;
140     my $last_was_nl = 1;
141
142     # Print each element individually, arranged in rows of columns
143     for my $i (0 .. $count - 1) {
144
145         # Node number for here is -1 until get into the dfa state transitions
146         my $node = ($i < 256) ? -1 : ($i - 256) / $columns_after_256;
147
148         # Print row header at beginning of each row
149         if ($last_was_nl) {
150             if ($node >= 0) {
151                 printf $out_fh "/*N%-*d=%*d*/", $node_number_field_width, $node,
152                                                $node_value_field_width, $i - 256;
153             }
154             else {  # Otherwise is regular row; print its number
155                 printf $out_fh "/*%X_", $i / 16;
156
157                 # These rows in a dfa table require extra space so columns
158                 # will align vertically (because the Ndd=ddd requires extra
159                 # space)
160                 if ($is_dfa) {
161                     print  $out_fh " " x (  $node_number_field_width
162                                           + $node_value_field_width);
163                 }
164                 print  $out_fh "*/";
165             }
166         }
167
168         if ($print_in_hex) {
169             printf $out_fh "0x%02X", $table_ref->[$i];
170         }
171         else {
172             printf $out_fh "%${field_width}d", $table_ref->[$i];
173         }
174
175         print $out_fh ",", if $i < $count -1;   # No comma on final entry
176
177         # Add \n if at end of row, which is 16 columns until we get to the
178         # transitions part
179         if (   ($node < 0 && $i % 16 == 15)
180             || ($node >= 0 && ($i -256) % $columns_after_256
181                                                     == $columns_after_256 - 1))
182         {
183             print $out_fh "\n";
184             $last_was_nl = 1;
185         }
186         else {
187             $last_was_nl = 0;
188         }
189     }
190
191     # Print column footer
192     print $out_fh get_column_headers($row_hdr_length, $field_width,
193                                      ($is_dfa) ? $columns_after_256 : undef);
194
195     print $out_fh "};\n#  endif\n\n";
196 }
197
198 print $out_fh <<END;
199
200 #ifndef PERL_EBCDIC_TABLES_H_   /* Guard against nested #includes */
201 #define PERL_EBCDIC_TABLES_H_   1
202
203 /* This file contains definitions for various tables used in EBCDIC handling.
204  * More info is in utfebcdic.h */
205 END
206
207 my @charsets = get_supported_code_pages();
208 shift @charsets;    # ASCII is the 0th, and we don't deal with that here.
209 foreach my $charset (@charsets) {
210     # we process the whole array several times, make a copy
211     my @a2e = @{get_a2n($charset)};
212
213     print $out_fh "\n" . get_conditional_compile_line_start($charset);
214     print $out_fh "\n";
215
216     print $out_fh "/* Index is ASCII platform code point; value is $charset equivalent */\n";
217     output_table(\@a2e, "PL_a2e");
218
219     { # Construct the inverse
220         my @e2a;
221         for my $i (0 .. 255) {
222             $e2a[$a2e[$i]] = $i;
223         }
224         print $out_fh "/* Index is $charset code point; value is ASCII platform equivalent */\n";
225         output_table(\@e2a, "PL_e2a");
226     }
227
228     my @i82utf = @{get_I8_2_utf($charset)};
229     print $out_fh <<END;
230 /* (Confusingly named) Index is $charset I8 byte; value is
231  * $charset UTF-EBCDIC equivalent */
232 END
233     output_table(\@i82utf, "PL_utf2e");
234
235     { #Construct the inverse
236         my @utf2i8;
237         for my $i (0 .. 255) {
238             $utf2i8[$i82utf[$i]] = $i;
239         }
240         print $out_fh <<END;
241 /* (Confusingly named) Index is $charset UTF-EBCDIC byte; value is
242  * $charset I8 equivalent */
243 END
244         output_table(\@utf2i8, "PL_e2utf");
245     }
246
247     {
248         my @utf8skip;
249
250         # These are invariants or continuation bytes.
251         for my $i (0 .. 0xBF) {
252             $utf8skip[$i82utf[$i]] = 1;
253         }
254
255         # These are start bytes;  The skip is the number of consecutive highest
256         # order 1-bits (up to 7)
257         for my $i (0xC0 .. 255) {
258             my $count;
259             if ($i == 0b11111111) {
260                 no warnings 'once';
261                 $count = $CHARSET_TRANSLATIONS::UTF_EBCDIC_MAXBYTES;
262             }
263             elsif (($i & 0b11111110) == 0b11111110) {
264                 $count= 7;
265             }
266             elsif (($i & 0b11111100) == 0b11111100) {
267                 $count= 6;
268             }
269             elsif (($i & 0b11111000) == 0b11111000) {
270                 $count= 5;
271             }
272             elsif (($i & 0b11110000) == 0b11110000) {
273                 $count= 4;
274             }
275             elsif (($i & 0b11100000) == 0b11100000) {
276                 $count= 3;
277             }
278             elsif (($i & 0b11000000) == 0b11000000) {
279                 $count= 2;
280             }
281             else {
282                 die "Something wrong for UTF8SKIP calculation for $i";
283             }
284             $utf8skip[$i82utf[$i]] = $count;
285         }
286
287         print $out_fh <<END;
288 /* Index is $charset UTF-EBCDIC byte; value is UTF8SKIP for start bytes
289  * (including for overlongs); 1 for continuation.  Adapted from the shadow
290  * flags table in tr16.  The entries marked 9 in tr16 are continuation bytes
291  * and are marked as length 1 here so that we can recover. */
292 END
293         output_table(\@utf8skip, "PL_utf8skip", 0);  # The 0 means don't print
294                                                      # in hex
295     }
296
297     use feature 'unicode_strings';
298
299     {
300         my @lc;
301         for my $i (0 .. 255) {
302             $lc[$a2e[$i]] = $a2e[ord lc chr $i];
303         }
304         print $out_fh
305         "/* Index is $charset code point; value is its lowercase equivalent */\n";
306         output_table(\@lc, "PL_latin1_lc");
307     }
308
309     {
310         my @uc;
311         for my $i (0 .. 255) {
312             my $uc = uc chr $i;
313             if (length $uc > 1 || ord $uc > 255) {
314                 $uc = "\N{LATIN SMALL LETTER Y WITH DIAERESIS}";
315             }
316             $uc[$a2e[$i]] = $a2e[ord $uc];
317         }
318         print $out_fh <<END;
319 /* Index is $charset code point; value is its uppercase equivalent.
320  * The 'mod' in the name means that codepoints whose uppercase is above 255 or
321  * longer than 1 character map to LATIN SMALL LETTER Y WITH DIARESIS */
322 END
323         output_table(\@uc, "PL_mod_latin1_uc");
324     }
325
326     { # PL_fold
327         my @ascii_fold;
328         for my $i (0 .. 255) {  # Initialise to identity map
329             $ascii_fold[$i] = $i;
330         }
331
332         # Overwrite the entries that aren't identity
333         for my $chr ('A' .. 'Z') {
334             $ascii_fold[$a2e[ord $chr]] = $a2e[ord lc $chr];
335         }
336         for my $chr ('a' .. 'z') {
337             $ascii_fold[$a2e[ord $chr]] = $a2e[ord uc $chr];
338         }
339         print $out_fh <<END;
340 /* Index is $charset code point; For A-Z, value is a-z; for a-z, value
341  * is A-Z; all other code points map to themselves */
342 END
343         output_table(\@ascii_fold, "PL_fold");
344     }
345
346     {
347         my @latin1_fold;
348         for my $i (0 .. 255) {
349             my $char = chr $i;
350             my $lc = lc $char;
351
352             # lc and uc adequately proxy for fold-case pairs in this 0-255
353             # range
354             my $uc = uc $char;
355             $uc = $char if length $uc > 1 || ord $uc > 255;
356             if ($lc ne $char) {
357                 $latin1_fold[$a2e[$i]] = $a2e[ord $lc];
358             }
359             elsif ($uc ne $char) {
360                 $latin1_fold[$a2e[$i]] = $a2e[ord $uc];
361             }
362             else {
363                 $latin1_fold[$a2e[$i]] = $a2e[$i];
364             }
365         }
366         print $out_fh <<END;
367 /* Index is $charset code point; value is its other fold-pair equivalent
368  * (A => a; a => A, etc) in the 0-255 range.  If no such equivalent, value is
369  * the code point itself */
370 END
371         output_table(\@latin1_fold, "PL_fold_latin1");
372     }
373
374     print $out_fh get_conditional_compile_line_end();
375 }
376
377 print $out_fh "\n#endif /* PERL_EBCDIC_TABLES_H_ */\n";
378
379 read_only_bottom_close_and_rename($out_fh);