X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/39c4defe660921fe7b772ebc0f18b2473a6c5a4c..f97008e2f5934e56fd1dbd3d685308da14fddb30:/regen/mk_invlists.pl diff --git a/regen/mk_invlists.pl b/regen/mk_invlists.pl index 369a987..fbec6c7 100644 --- a/regen/mk_invlists.pl +++ b/regen/mk_invlists.pl @@ -7,9 +7,13 @@ use Unicode::UCD qw(prop_aliases prop_value_aliases prop_invlist prop_invmap search_invlist + charprop + num ); require './regen/regen_lib.pl'; require './regen/charset_translations.pl'; +require './lib/unicore/Heavy.pl'; +use re "/aa"; # This program outputs charclass_invlists.h, which contains various inversion # lists in the form of C arrays that are to be used as-is for inversion lists. @@ -22,156 +26,47 @@ require './regen/charset_translations.pl'; # out-of-sync, or the wrong data structure being passed. Currently that # random number is: -# charclass_invlists.h now also has a partial implementation of inversion -# maps; enough to generate tables for the line break properties, such as GCB +# charclass_invlists.h now also contains inversion maps and enum definitions +# for those maps that have a finite number of possible values my $VERSION_DATA_STRUCTURE_TYPE = 148565664; # integer or float -my $numeric_re = qr/ ^ -? \d+ (:? \. \d+ )? $ /ax; +my $numeric_re = qr/ ^ -? \d+ (:? \. \d+ )? $ /x; + +my %keywords; +my $table_name_prefix = "PL_"; # Matches valid C language enum names: begins with ASCII alphabetic, then any # ASCII \w my $enum_name_re = qr / ^ [[:alpha:]] \w* $ /ax; my $out_fh = open_new('charclass_invlists.h', '>', - {style => '*', by => $0, + {style => '*', by => 'regen/mk_invlists.pl', from => "Unicode::UCD"}); -my $in_file_pound_if = 0; +my $in_file_pound_if = ""; my $max_hdr_len = 3; # In headings, how wide a name is allowed? print $out_fh "/* See the generating file for comments */\n\n"; +# enums that should be made public +my %public_enums = ( + _Perl_SCX => 1 + ); + # The symbols generated by this program are all currently defined only in a # single dot c each. The code knows where most of them go, but this hash # gives overrides for the exceptions to the typical place my %exceptions_to_where_to_define = - ( NonL1_Perl_Non_Final_Folds => 'PERL_IN_REGCOMP_C', - AboveLatin1 => 'PERL_IN_REGCOMP_C', - Latin1 => 'PERL_IN_REGCOMP_C', - UpperLatin1 => 'PERL_IN_REGCOMP_C', - _Perl_Any_Folds => 'PERL_IN_REGCOMP_C', - _Perl_Folds_To_Multi_Char => 'PERL_IN_REGCOMP_C', - _Perl_IDCont => 'PERL_IN_UTF8_C', - _Perl_IDStart => 'PERL_IN_UTF8_C', + ( + #_Perl_IVCF => 'PERL_IN_REGCOMP_C', ); -# This hash contains the properties with enums that have hard-coded references -# to them in C code. It is neeed to make sure that if perl is compiled -# with an older Unicode data set, that all the enum values the code is -# expecting will still be in the enum typedef. Thus the code doesn't have to -# change. The Unicode version won't have any code points that have the enum -# values not in that version, so the code that handles them will not get -# exercised. This is far better than having to #ifdef things. The names here -# should be the long names of the respective property values. The reason for -# this is because regexec.c uses them as case labels, and the long name is -# generally more understandable than the short. -my %hard_coded_enums = - ( gcb => [ - 'Control', - 'CR', - 'E_Base', - 'E_Base_GAZ', - 'E_Modifier', - 'Extend', - 'Glue_After_Zwj', - 'L', - 'LF', - 'LV', - 'LVT', - 'Other', - 'Prepend', - 'Regional_Indicator', - 'SpacingMark', - 'T', - 'V', - 'ZWJ', - ], - lb => [ - 'Alphabetic', - 'Break_After', - 'Break_Before', - 'Break_Both', - 'Break_Symbols', - 'Carriage_Return', - 'Close_Parenthesis', - 'Close_Punctuation', - 'Combining_Mark', - 'Contingent_Break', - 'E_Base', - 'E_Modifier', - 'Exclamation', - 'Glue', - 'H2', - 'H3', - 'Hebrew_Letter', - 'Hyphen', - 'Ideographic', - 'Infix_Numeric', - 'Inseparable', - 'JL', - 'JT', - 'JV', - 'Line_Feed', - 'Mandatory_Break', - 'Next_Line', - 'Nonstarter', - 'Numeric', - 'Open_Punctuation', - 'Postfix_Numeric', - 'Prefix_Numeric', - 'Quotation', - 'Regional_Indicator', - 'Space', - 'Word_Joiner', - 'ZWJ', - 'ZWSpace', - ], - sb => [ - 'ATerm', - 'Close', - 'CR', - 'Extend', - 'Format', - 'LF', - 'Lower', - 'Numeric', - 'OLetter', - 'Other', - 'SContinue', - 'Sep', - 'Sp', - 'STerm', - 'Upper', - ], - wb => [ - 'ALetter', - 'CR', - 'Double_Quote', - 'E_Base', - 'E_Base_GAZ', - 'E_Modifier', - 'Extend', - 'ExtendNumLet', - 'Format', - 'Glue_After_Zwj', - 'Hebrew_Letter', - 'Katakana', - 'LF', - 'MidLetter', - 'MidNum', - 'MidNumLet', - 'Newline', - 'Numeric', - 'Other', - 'Perl_Tailored_HSpace', - 'Regional_Indicator', - 'Single_Quote', - 'ZWJ', - ], -); +my %where_to_define_enums = (); + +my $applies_to_all_charsets_text = "all charsets"; my %gcb_enums; my @gcb_short_enums; @@ -185,6 +80,67 @@ my %wb_abbreviations; my @a2n; +my %prop_name_aliases; +# Invert this hash so that for each canonical name, we get a list of things +# that map to it (excluding itself) +foreach my $name (sort keys %utf8::loose_property_name_of) { + my $canonical = $utf8::loose_property_name_of{$name}; + push @{$prop_name_aliases{$canonical}}, $name if $canonical ne $name; +} + +# Output these tables in the same vicinity as each other, so that will get +# paged in at about the same time. These are also assumed to be the exact +# same list as those properties used internally by perl. +my %keep_together = ( + assigned => 1, + ascii => 1, + upper => 1, + lower => 1, + title => 1, + cased => 1, + uppercaseletter => 1, + lowercaseletter => 1, + titlecaseletter => 1, + casedletter => 1, + vertspace => 1, + xposixalnum => 1, + xposixalpha => 1, + xposixblank => 1, + xposixcntrl => 1, + xposixdigit => 1, + xposixgraph => 1, + xposixlower => 1, + xposixprint => 1, + xposixpunct => 1, + xposixspace => 1, + xposixupper => 1, + xposixword => 1, + xposixxdigit => 1, + posixalnum => 1, + posixalpha => 1, + posixblank => 1, + posixcntrl => 1, + posixdigit => 1, + posixgraph => 1, + posixlower => 1, + posixprint => 1, + posixpunct => 1, + posixspace => 1, + posixupper => 1, + posixword => 1, + posixxdigit => 1, + _perl_any_folds => 1, + _perl_folds_to_multi_char => 1, + _perl_idstart => 1, + _perl_idcont => 1, + _perl_charname_begin => 1, + _perl_charname_continue => 1, + _perl_problematic_locale_foldeds_start => 1, + _perl_problematic_locale_folds => 1, + _perl_quotemeta => 1, + ); +my %perl_tags; # So can find synonyms of the above properties + sub uniques { # Returns non-duplicated input values. From "Perl Best Practices: # Encapsulated Cleverness". p. 455 in first edition. @@ -205,36 +161,61 @@ sub a2n($) { sub end_file_pound_if { if ($in_file_pound_if) { print $out_fh "\n#endif\t/* $in_file_pound_if */\n"; - $in_file_pound_if = 0; + $in_file_pound_if = ""; } } -sub switch_pound_if ($$) { +sub end_charset_pound_if { + print $out_fh "\n" . get_conditional_compile_line_end(); +} + +sub switch_pound_if ($$;$) { my $name = shift; my $new_pound_if = shift; + my $charset = shift; + + my @new_pound_if = ref ($new_pound_if) + ? sort @$new_pound_if + : $new_pound_if; # Switch to new #if given by the 2nd argument. If there is an override # for this, it instead switches to that. The 1st argument is the - # static's name, used to look up the overrides + # static's name, used only to check if there is an override for this + # + # The 'charset' parmameter, if present, is used to first end the charset + # #if if we actually do a switch, and then restart it afterwards. This + # code, then assumes that the charset #if's are enclosed in the file ones. if (exists $exceptions_to_where_to_define{$name}) { - $new_pound_if = $exceptions_to_where_to_define{$name}; + @new_pound_if = $exceptions_to_where_to_define{$name}; } - # Exit current #if if the new one is different from the old - if ($in_file_pound_if - && $in_file_pound_if !~ /$new_pound_if/) - { - end_file_pound_if; + foreach my $element (@new_pound_if) { + $element = "defined($element)"; } + $new_pound_if = join " || ", @new_pound_if; + + # Change to the new one if different from old + if ($in_file_pound_if ne $new_pound_if) { + + end_charset_pound_if() if defined $charset; - # Enter new #if, if not already in it. - if (! $in_file_pound_if) { - $in_file_pound_if = "defined($new_pound_if)"; + # Exit any current #if + if ($in_file_pound_if) { + end_file_pound_if; + } + + $in_file_pound_if = $new_pound_if; print $out_fh "\n#if $in_file_pound_if\n"; + + start_charset_pound_if ($charset, 1) if defined $charset; } } +sub start_charset_pound_if ($;$) { + print $out_fh "\n" . get_conditional_compile_line_start(shift, shift); +} + sub output_invlist ($$;$) { my $name = shift; my $invlist = shift; # Reference to inversion list array @@ -254,8 +235,6 @@ sub output_invlist ($$;$) { } my $count = @$invlist; - switch_pound_if ($name, 'PERL_IN_PERL_C'); - print $out_fh "\nstatic const UV ${name}_invlist[] = {"; print $out_fh " /* for $charset */" if $charset; print $out_fh "\n"; @@ -294,81 +273,81 @@ sub output_invmap ($$$$$$$) { my $count = @$invmap; my $output_format; - my $declaration_type; + my $invmap_declaration_type; + my $enum_declaration_type; + my $aux_declaration_type; my %enums; my $name_prefix; - if ($input_format eq 's') { - my $orig_prop_name = $prop_name; + if ($input_format =~ / ^ [as] l? $ /x) { $prop_name = (prop_aliases($prop_name))[1] // $prop_name =~ s/^_Perl_//r; # Get full name my $short_name = (prop_aliases($prop_name))[0] // $prop_name; - my @enums; - if ($orig_prop_name eq $prop_name) { - @enums = prop_values($prop_name); - } - else { - @enums = uniques(@$invmap); - } - - - die "Only enum properties are currently handled; '$prop_name' isn't one" - unless @enums; - - my @expected_enums = @{$hard_coded_enums{lc $short_name}}; - my @canonical_input_enums; - if (@expected_enums) { - if (@expected_enums < @enums) { - die 'You need to update %hard_coded_enums to reflect new' - . " entries in this Unicode version\n" - . "Expected: " . join(", ", sort @expected_enums) . "\n" - . " Got: " . join(", ", sort @enums); + my @input_enums; + + # Find all the possible input values. These become the enum names + # that comprise the inversion map. For inputs that don't have sub + # lists, we can just get the unique values. Otherwise, we have to + # expand the sublists first. + if ($input_format !~ / ^ a /x) { + if ($input_format ne 'sl') { + @input_enums = sort(uniques(@$invmap)); } - - if (! defined prop_aliases($prop_name)) { - - # Convert the input enums into canonical form and - # save for use below - @canonical_input_enums = map { lc ($_ =~ s/_//gr) } - @enums; + else { + foreach my $element (@$invmap) { + if (ref $element) { + push @input_enums, @$element; + } + else { + push @input_enums, $element; + } + } + @input_enums = sort(uniques(@input_enums)); } - @enums = sort @expected_enums; } - # The internal enums come last, and in the order specified + # The internal enums come last, and in the order specified. + my @enums = @input_enums; my @extras; if ($extra_enums ne "") { @extras = split /,/, $extra_enums; - push @enums, @extras; + + # Don't add if already there. + foreach my $this_extra (@extras) { + next if grep { $_ eq $this_extra } @enums; + + push @enums, $this_extra; + } } - # Assign a value to each element of the enum. The default - # value always gets 0; the others are arbitrarily assigned. + # Assign a value to each element of the enum type we are creating. + # The default value always gets 0; the others are arbitrarily + # assigned. my $enum_val = 0; my $canonical_default = prop_value_aliases($prop_name, $default); $default = $canonical_default if defined $canonical_default; $enums{$default} = $enum_val++; + for my $enum (@enums) { $enums{$enum} = $enum_val++ unless exists $enums{$enum}; } - # Calculate the enum values for certain properties like - # _Perl_GCB and _Perl_LB, because we output special tables for - # them. + # Calculate the data for the special tables output for these properties. if ($name =~ / ^ _Perl_ (?: GCB | LB | WB ) $ /x) { + # The data includes the hashes %gcb_enums, %lb_enums, etc. + # Similarly we calculate column headings for the tables. + # # We use string evals to allow the same code to work on - # all tables we're doing. + # all the tables my $type = lc $prop_name; - # We use lowercase single letter names for any property - # values not in the release of Unicode being compiled now. my $placeholder = "a"; # Skip if we've already done this code, which populated # this hash if (eval "! \%${type}_enums") { - # For each enum ... + # For each enum in the type ... foreach my $enum (sort keys %enums) { my $value = $enums{$enum}; my $short; @@ -380,43 +359,47 @@ sub output_invmap ($$$$$$$) { $short = 'hs'; $abbreviated_from = $enum; } - elsif (grep { $_ eq $enum } @extras) { - - # The 'short' name for one of the property - # values added by this file is just the - # lowercase of it - $short = lc $enum; - } - elsif (grep {$_ eq lc ( $enum =~ s/_//gr) } - @canonical_input_enums) - { # On Unicode versions that predate the - # official property, we have set up this array - # to be the canonical form of each enum in the - # substitute property. If the enum we're - # looking at is canonically the same as one of - # these, use its name instead of generating a - # placeholder one in the next clause (which - # will happen because prop_value_aliases() - # will fail because it only works on official - # properties) - $short = $enum; - } else { - # Use the official short name for the other - # property values, which should all be - # official ones. + + # Use the official short name, if found. ($short) = prop_value_aliases($type, $enum); - # But create a placeholder for ones not in - # this Unicode version. - $short = $placeholder++ unless defined $short; + if (! defined $short) { + + # But if there is no official name, use the name + # that came from the data (if any). Otherwise, + # the name had to come from the extras list. + # There are two types of values in that list. + # + # First are those enums that are not part of the + # property, but are defined by this code. By + # convention these have all-caps names of at least + # 4 characters. We use the lowercased name for + # thse. + # + # Second are enums that are needed to get + # regexec.c to compile, but don't exist in all + # Unicode releases. To get here, we must be + # compiling an earlier Unicode release that + # doesn't have that enum, so just use a unique + # anonymous name for it. + if (grep { $_ eq $enum } @input_enums) { + $short = $enum + } + elsif ($enum !~ / ^ [A-Z]{4,} $ /x) { + $short = $placeholder++; + } + else { + $short = lc $enum; + } + } } # If our short name is too long, or we already # know that the name is an abbreviation, truncate # to make sure it's short enough, and remember - # that we did this so we can later place in a - # comment in the generated file + # that we did this so we can later add a comment in the + # generated file if ( $abbreviated_from || length $short > $max_hdr_len) { @@ -456,32 +439,253 @@ sub output_invmap ($$$$$$$) { } } - # Inversion map stuff is currently used only by regexec - switch_pound_if($name, 'PERL_IN_REGEXEC_C'); - # The short names tend to be two lower case letters, but it looks # better for those if they are upper. XXX $short_name = uc($short_name) if length($short_name) < 3 - || substr($short_name, 0, 1) =~ /[[:lower:]]/; + || substr($short_name, 0, 1) =~ /[[:lower:]]/; $name_prefix = "${short_name}_"; - my $enum_count = keys %enums; - print $out_fh "\n#define ${name_prefix}ENUM_COUNT ", scalar keys %enums, "\n"; - print $out_fh "\ntypedef enum {\n"; + # Start the enum definition for this map + my @enum_definition; my @enum_list; foreach my $enum (keys %enums) { $enum_list[$enums{$enum}] = $enum; } foreach my $i (0 .. @enum_list - 1) { + push @enum_definition, ",\n" if $i > 0; + my $name = $enum_list[$i]; - print $out_fh "\t${name_prefix}$name = $i"; - print $out_fh "," if $i < $enum_count - 1; + push @enum_definition, "\t${name_prefix}$name = $i"; + } + + # For an 'l' property, we need extra enums, because some of the + # elements are lists. Each such distinct list is placed in its own + # auxiliary map table. Here, we go through the inversion map, and for + # each distinct list found, create an enum value for it, numbered -1, + # -2, .... + my %multiples; + my $aux_table_prefix = "AUX_TABLE_"; + if ($input_format =~ /l/) { + foreach my $element (@$invmap) { + + # A regular scalar is not one of the lists we're looking for + # at this stage. + next unless ref $element; + + my $joined; + if ($input_format =~ /a/) { # These are already ordered + $joined = join ",", @$element; + } + else { + $joined = join ",", sort @$element; + } + my $already_found = exists $multiples{$joined}; + + my $i; + if ($already_found) { # Use any existing one + $i = $multiples{$joined}; + } + else { # Otherwise increment to get a new table number + $i = keys(%multiples) + 1; + $multiples{$joined} = $i; + } + + # This changes the inversion map for this entry to not be the + # list + $element = "use_$aux_table_prefix$i"; + + # And add to the enum values + if (! $already_found) { + push @enum_definition, ",\n\t${name_prefix}$element = -$i"; + } + } + } + + $enum_declaration_type = "${name_prefix}enum"; + + # Finished with the enum definition. Inversion map stuff is used only + # by regexec or utf-8 (if it is for code points) , unless it is in the + # enum exception list + my $where = (exists $where_to_define_enums{$name}) + ? $where_to_define_enums{$name} + : ($input_format =~ /a/) + ? 'PERL_IN_UTF8_C' + : 'PERL_IN_REGEXEC_C'; + + if (! exists $public_enums{$name}) { + switch_pound_if($name, $where, $charset); + } + else { + end_charset_pound_if; + end_file_pound_if; + start_charset_pound_if($charset, 1); + } + + # If the enum only contains one element, that is a dummy, default one + if (scalar @enum_definition > 1) { + + # Currently unneeded + #print $out_fh "\n#define ${name_prefix}ENUM_COUNT ", + # ..scalar keys %enums, "\n"; + + if ($input_format =~ /l/) { + print $out_fh + "\n", + "/* Negative enum values indicate the need to use an", + " auxiliary table\n", + " * consisting of the list of enums this one expands to.", + " The absolute\n", + " * values of the negative enums are indices into a table", + " of the auxiliary\n", + " * tables' addresses */"; + } + print $out_fh "\ntypedef enum {\n"; + print $out_fh join "", @enum_definition; print $out_fh "\n"; + print $out_fh "} $enum_declaration_type;\n"; } - $declaration_type = "${name_prefix}enum"; - print $out_fh "} $declaration_type;\n"; + + switch_pound_if($name, $where, $charset); + + $invmap_declaration_type = ($input_format =~ /s/) + ? $enum_declaration_type + : "int"; + $aux_declaration_type = ($input_format =~ /s/) + ? $enum_declaration_type + : "unsigned int"; $output_format = "${name_prefix}%s"; + + # If there are auxiliary tables, output them. + if (%multiples) { + + print $out_fh "\n#define HAS_${name_prefix}AUX_TABLES\n"; + + # Invert keys and values + my %inverted_mults; + while (my ($key, $value) = each %multiples) { + $inverted_mults{$value} = $key; + } + + # Output them in sorted order + my @sorted_table_list = sort { $a <=> $b } keys %inverted_mults; + + # Keep track of how big each aux table is + my @aux_counts; + + # Output each aux table. + foreach my $table_number (@sorted_table_list) { + my $table = $inverted_mults{$table_number}; + print $out_fh "\nstatic const $aux_declaration_type $name_prefix$aux_table_prefix$table_number\[] = {\n"; + + # Earlier, we joined the elements of this table together with a comma + my @elements = split ",", $table; + + $aux_counts[$table_number] = scalar @elements; + for my $i (0 .. @elements - 1) { + print $out_fh ",\n" if $i > 0; + if ($input_format =~ /a/) { + printf $out_fh "\t0x%X", $elements[$i]; + } + else { + print $out_fh "\t${name_prefix}$elements[$i]"; + } + } + print $out_fh "\n};\n"; + } + + # Output the table that is indexed by the absolute value of the + # aux table enum and contains pointers to the tables output just + # above + print $out_fh "\nstatic const $aux_declaration_type * const ${name_prefix}${aux_table_prefix}ptrs\[] = {\n"; + print $out_fh "\tNULL,\t/* Placeholder */\n"; + for my $i (1 .. @sorted_table_list) { + print $out_fh ",\n" if $i > 1; + print $out_fh "\t$name_prefix$aux_table_prefix$i"; + } + print $out_fh "\n};\n"; + + print $out_fh + "\n/* Parallel table to the above, giving the number of elements" + . " in each table\n * pointed to */\n"; + print $out_fh "static const U8 ${name_prefix}${aux_table_prefix}lengths\[] = {\n"; + print $out_fh "\t0,\t/* Placeholder */\n"; + for my $i (1 .. @sorted_table_list) { + print $out_fh ",\n" if $i > 1; + print $out_fh "\t$aux_counts[$i]\t/* $name_prefix$aux_table_prefix$i */"; + } + print $out_fh "\n};\n"; + } # End of outputting the auxiliary and associated tables + + # The scx property used in regexec.c needs a specialized table which + # is most convenient to output here, while the data structures set up + # above are still extant. This table contains the code point that is + # the zero digit of each script, indexed by script enum value. + if (lc $short_name eq 'scx') { + my @decimals_invlist = prop_invlist("Numeric_Type=Decimal"); + my %script_zeros; + + # Find all the decimal digits. The 0 of each range is always the + # 0th element, except in some early Unicode releases, so check for + # that. + for (my $i = 0; $i < @decimals_invlist; $i += 2) { + my $code_point = $decimals_invlist[$i]; + next if num(chr($code_point)) ne '0'; + + # Turn the scripts this zero is in into a list. + my @scripts = split ",", + charprop($code_point, "_Perl_SCX", '_perl_core_internal_ok'); + $code_point = sprintf("0x%x", $code_point); + + foreach my $script (@scripts) { + if (! exists $script_zeros{$script}) { + $script_zeros{$script} = $code_point; + } + elsif (ref $script_zeros{$script}) { + push $script_zeros{$script}->@*, $code_point; + } + else { # Turn into a list if this is the 2nd zero of the + # script + my $existing = $script_zeros{$script}; + undef $script_zeros{$script}; + push $script_zeros{$script}->@*, $existing, $code_point; + } + } + } + + # @script_zeros contains the zero, sorted by the script's enum + # value + my @script_zeros; + foreach my $script (keys %script_zeros) { + my $enum_value = $enums{$script}; + $script_zeros[$enum_value] = $script_zeros{$script}; + } + + print $out_fh + "\n/* This table, indexed by the script enum, gives the zero" + . " code point for that\n * script; 0 if the script has multiple" + . " digit sequences. Scripts without a\n * digit sequence use" + . " ASCII [0-9], hence are marked '0' */\n"; + print $out_fh "static const UV script_zeros[] = {\n"; + for my $i (0 .. @script_zeros - 1) { + my $code_point = $script_zeros[$i]; + if (defined $code_point) { + $code_point = " 0" if ref $code_point; + print $out_fh "\t$code_point"; + } + elsif (lc $enum_list[$i] eq 'inherited') { + print $out_fh "\t 0"; + } + else { # The only digits a script without its own set accepts + # is [0-9] + print $out_fh "\t'0'"; + } + print $out_fh "," if $i < @script_zeros - 1; + print $out_fh "\t/* $enum_list[$i] */"; + print $out_fh "\n"; + } + print $out_fh "};\n"; + } # End of special handling of scx } else { die "'$input_format' invmap() format for '$prop_name' unimplemented"; @@ -491,7 +695,8 @@ sub output_invmap ($$$$$$$) { && ref $invmap eq 'ARRAY' && $count; - print $out_fh "\nstatic const $declaration_type ${name}_invmap[] = {"; + # Now output the inversion map proper + print $out_fh "\nstatic const $invmap_declaration_type ${name}_invmap[] = {"; print $out_fh " /* for $charset */" if $charset; print $out_fh "\n"; @@ -499,8 +704,15 @@ sub output_invmap ($$$$$$$) { for my $i (0 .. $count - 1) { my $element = $invmap->[$i]; my $full_element_name = prop_value_aliases($prop_name, $element); + if ($input_format =~ /a/ && $element !~ /\D/) { + $element = ($element == 0) + ? 0 + : sprintf("0x%X", $element); + } + else { $element = $full_element_name if defined $full_element_name; $element = $name_prefix . $element; + } print $out_fh "\t$element"; print $out_fh "," if $i < $count - 1; print $out_fh "\n"; @@ -535,7 +747,7 @@ sub mk_invlist_from_sorted_cp_list { # Read in the Case Folding rules, and construct arrays of code points for the # properties we need. -my ($cp_ref, $folds_ref, $format) = prop_invmap("Case_Folding"); +my ($cp_ref, $folds_ref, $format, $default) = prop_invmap("Case_Folding"); die "Could not find inversion map for Case_Folding" unless defined $format; die "Incorrect format '$format' for Case_Folding inversion map" unless $format eq 'al' @@ -550,14 +762,195 @@ for my $i (0 .. @$folds_ref - 1) { # Add to the non-finals list each code point that is in a non-final # position for my $j (0 .. @{$folds_ref->[$i]} - 2) { - push @is_non_final_fold, $folds_ref->[$i][$j] - unless grep { $folds_ref->[$i][$j] == $_ } @is_non_final_fold; + push @is_non_final_fold, $folds_ref->[$i][$j]; } + @is_non_final_fold = uniques @is_non_final_fold; } sub _Perl_Non_Final_Folds { @is_non_final_fold = sort { $a <=> $b } @is_non_final_fold; - return mk_invlist_from_sorted_cp_list(\@is_non_final_fold); + my @return = mk_invlist_from_sorted_cp_list(\@is_non_final_fold); + return \@return; +} + +sub _Perl_IVCF { + + # This creates a map of the inversion of case folding. i.e., given a + # character, it gives all the other characters that fold to it. + # + # Inversion maps function kind of like a hash, with the inversion list + # specifying the buckets (keys) and the inversion maps specifying the + # contents of the corresponding bucket. Effectively this function just + # swaps the keys and values of the case fold hash. But there are + # complications. Most importantly, More than one character can each have + # the same fold. This is solved by having a list of characters that fold + # to a given one. + + my %new; + + # Go through the inversion list. + for (my $i = 0; $i < @$cp_ref; $i++) { + + # Skip if nothing folds to this + next if $folds_ref->[$i] == 0; + + # This entry which is valid from here to up (but not including) the + # next entry is for the next $count characters, so that, for example, + # A-Z is represented by one entry. + my $cur_list = $cp_ref->[$i]; + my $count = $cp_ref->[$i+1] - $cur_list; + + # The fold of [$i] can be not just a single character, but a sequence + # of multiple ones. We deal with those here by just creating a string + # consisting of them. Otherwise, we use the single code point [$i] + # folds to. + my $cur_map = (ref $folds_ref->[$i]) + ? join "", map { chr } $folds_ref->[$i]->@* + : $folds_ref->[$i]; + + # Expand out this range + while ($count > 0) { + push @{$new{$cur_map}}, $cur_list; + + # A multiple-character fold is a string, and shouldn't need + # incrementing anyway + if (ref $folds_ref->[$i]) { + die sprintf("Case fold for %x is multiple chars; should have" + . " a count of 1, but instead it was $count", $count) + unless $count == 1; + } + else { + $cur_map++; + $cur_list++; + } + $count--; + } + } + + # Now go through and make some adjustments. We add synthetic entries for + # two cases. + # 1) Two or more code points can fold to the same multiple character, + # sequence, as U+FB05 and U+FB06 both fold to 'st'. This code is only + # for single character folds, but FB05 and FB06 are single characters + # that are equivalent folded, so we add entries so that they are + # considered to fold to each other + # 2) If two or more above-Latin1 code points fold to the same Latin1 range + # one, we also add entries so that they are considered to fold to each + # other. This is so that under /aa or /l matching, where folding to + # their Latin1 range code point is illegal, they still can fold to each + # other. This situation happens in Unicode 3.0.1, but probably no + # other version. + foreach my $fold (keys %new) { + my $folds_to_string = $fold =~ /\D/; + + # If the bucket contains only one element, convert from an array to a + # scalar + if (scalar $new{$fold}->@* == 1) { + $new{$fold} = $new{$fold}[0]; + } + else { + + # Otherwise, sort numerically. This places the highest code point + # in the list at the tail end. This is because Unicode keeps the + # lowercase code points as higher ordinals than the uppercase, at + # least for the ones that matter so far. These are synthetic + # entries, and we want to predictably have the lowercase (which is + # more likely to be what gets folded to) in the same corresponding + # position, so that other code can rely on that. If some new + # version of Unicode came along that violated this, we might have + # to change so that the sort is based on upper vs lower instead. + # (The lower-comes-after isn't true of native EBCDIC, but here we + # are dealing strictly with Unicode values). + @{$new{$fold}} = sort { $a <=> $b } $new{$fold}->@* + unless $folds_to_string; + # We will be working with a copy of this sorted entry. + my @source_list = $new{$fold}->@*; + if (! $folds_to_string) { + + # This handles situation 2) listed above, which only arises if + # what is being folded-to (the fold) is in the Latin1 range. + if ($fold > 255 ) { + undef @source_list; + } + else { + # And it only arises if there are two or more folders that + # fold to it above Latin1. We look at just those. + @source_list = grep { $_ > 255 } @source_list; + undef @source_list if @source_list == 1; + } + } + + # Here, we've found the items we want to set up synthetic folds + # for. Add entries so that each folds to each other. + foreach my $cp (@source_list) { + my @rest = grep { $cp != $_ } @source_list; + if (@rest == 1) { + $new{$cp} = $rest[0]; + } + else { + push @{$new{$cp}}, @rest; + } + } + } + + # We don't otherwise deal with multiple-character folds + delete $new{$fold} if $folds_to_string; + } + + + # Now we have a hash that is the inversion of the case fold property. + # Convert it to an inversion map. + + my @sorted_folds = sort { $a <=> $b } keys %new; + my (@invlist, @invmap); + + # We know that nothing folds to the controls (whose ordinals start at 0). + # And the first real entries are the lowest in the hash. + push @invlist, 0, $sorted_folds[0]; + push @invmap, 0, $new{$sorted_folds[0]}; + + # Go through the remainder of the hash keys (which are the folded code + # points) + for (my $i = 1; $i < @sorted_folds; $i++) { + + # Get the current one, and the one prior to it. + my $fold = $sorted_folds[$i]; + my $prev_fold = $sorted_folds[$i-1]; + + # If the current one is not just 1 away from the prior one, we close + # out the range containing the previous fold, and know that the gap + # doesn't have anything that folds. + if ($fold - 1 != $prev_fold) { + push @invlist, $prev_fold + 1; + push @invmap, 0; + + # And start a new range + push @invlist, $fold; + push @invmap, $new{$fold}; + } + elsif ($new{$fold} - 1 != $new{$prev_fold}) { + + # Here the current fold is just 1 greater than the previous, but + # the new map isn't correspondingly 1 greater than the previous, + # the old range is ended, but since there is no gap, we don't have + # to insert anything else. + push @invlist, $fold; + push @invmap, $new{$fold}; + + } # else { Otherwise, this new entry just extends the previous } + + die "In IVCF: $invlist[-1] <= $invlist[-2]" + if $invlist[-1] <= $invlist[-2]; + } + + # And add an entry that indicates that everything above this, to infinity, + # does not have a case fold. + push @invlist, $sorted_folds[-1] + 1; + push @invmap, 0; + + # All Unicode versions have some places where multiple code points map to + # the same one, so the format always has an 'l' + return \@invlist, \@invmap, 'al', $default; } sub prop_name_for_cmp ($) { # Sort helper @@ -572,7 +965,8 @@ sub prop_name_for_cmp ($) { # Sort helper } sub UpperLatin1 { - return mk_invlist_from_sorted_cp_list([ 128 .. 255 ]); + my @return = mk_invlist_from_sorted_cp_list([ 128 .. 255 ]); + return \@return; } sub output_table_common { @@ -645,7 +1039,7 @@ sub output_table_common { for my $i (0 .. $size - 1) { no warnings 'numeric'; - $has_placeholder = 1 if $names_ref->[$i] =~ / ^ [[:lower:]] $ /ax; + $has_placeholder = 1 if $names_ref->[$i] =~ / ^ [[:lower:]] $ /x; $spacers[$i] = " " x (length($names_ref->[$i]) - $column_width); } @@ -1719,6 +2113,22 @@ sub output_WB_table() { \@wb_table, \@wb_short_enums, \%wb_abbreviations); } +sub sanitize_name ($) { + # Change the non-word characters in the input string to standardized word + # equivalents + # + my $sanitized = shift; + $sanitized =~ s/=/__/; + $sanitized =~ s/&/_AMP_/; + $sanitized =~ s/\./_DOT_/; + $sanitized =~ s/-/_MINUS_/; + $sanitized =~ s!/!_SLASH_!; + + return $sanitized; +} + +switch_pound_if ('ALL', 'PERL_IN_UTF8_C'); + output_invlist("Latin1", [ 0, 256 ]); output_invlist("AboveLatin1", [ 256 ]); @@ -1747,67 +2157,217 @@ end_file_pound_if; # An initial & means to use the subroutine from this file instead of an # official inversion list. -for my $charset (get_supported_code_pages()) { - print $out_fh "\n" . get_conditional_compile_line_start($charset); - - @a2n = @{get_a2n($charset)}; - no warnings 'qw'; - # Ignore non-alpha in sort - for my $prop (sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) } qw( - Assigned - ASCII - Cased - VertSpace - XPerlSpace - XPosixAlnum - XPosixAlpha - XPosixBlank - XPosixCntrl - XPosixDigit - XPosixGraph - XPosixLower - XPosixPrint - XPosixPunct - XPosixSpace - XPosixUpper - XPosixWord - XPosixXDigit - _Perl_Any_Folds - &NonL1_Perl_Non_Final_Folds - _Perl_Folds_To_Multi_Char - &UpperLatin1 - _Perl_IDStart - _Perl_IDCont - _Perl_GCB,EDGE - _Perl_LB,EDGE - _Perl_SB,EDGE - _Perl_WB,EDGE,UNKNOWN - ) - ) { - - # For the Latin1 properties, we change to use the eXtended version of the - # base property, then go through the result and get rid of everything not - # in Latin1 (above 255). Actually, we retain the element for the range - # that crosses the 255/256 boundary if it is one that matches the - # property. For example, in the Word property, there is a range of code - # points that start at U+00F8 and goes through U+02C1. Instead of - # artificially cutting that off at 256 because 256 is the first code point - # above Latin1, we let the range go to its natural ending. That gives us - # extra information with no added space taken. But if the range that - # crosses the boundary is one that doesn't match the property, we don't - # start a new range above 255, as that could be construed as going to - # infinity. For example, the Upper property doesn't include the character - # at 255, but does include the one at 256. We don't include the 256 one. - my $prop_name = $prop; - my $is_local_sub = $prop_name =~ s/^&//; - my $extra_enums = ""; - $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x; - my $lookup_prop = $prop_name; - my $l1_only = ($lookup_prop =~ s/^L1Posix/XPosix/ - or $lookup_prop =~ s/^L1//); - my $nonl1_only = 0; - $nonl1_only = $lookup_prop =~ s/^NonL1// unless $l1_only; - ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x; +# Below is the list of property names to generate. '&' means to use the +# subroutine to generate the inversion list instead of the generic code +# below. Some properties have a comma-separated list after the name, +# These are extra enums to add to those found in the Unicode tables. +no warnings 'qw'; + # Ignore non-alpha in sort +my @props; +push @props, sort { prop_name_for_cmp($a) cmp prop_name_for_cmp($b) } qw( + &NonL1_Perl_Non_Final_Folds + &UpperLatin1 + _Perl_GCB,E_Base,E_Base_GAZ,E_Modifier,Glue_After_Zwj,LV,Prepend,Regional_Indicator,SpacingMark,ZWJ,EDGE + _Perl_LB,Close_Parenthesis,Hebrew_Letter,Next_Line,Regional_Indicator,ZWJ,Contingent_Break,E_Base,E_Modifier,H2,H3,JL,JT,JV,Word_Joiner,EDGE, + _Perl_SB,SContinue,CR,Extend,LF,EDGE + _Perl_WB,CR,Double_Quote,E_Base,E_Base_GAZ,E_Modifier,Extend,Glue_After_Zwj,Hebrew_Letter,LF,MidNumLet,Newline,Regional_Indicator,Single_Quote,ZWJ,EDGE,UNKNOWN + _Perl_SCX,Latin,Inherited,Unknown,Kore,Jpan,Hanb,INVALID + Lowercase_Mapping + Titlecase_Mapping + Uppercase_Mapping + Simple_Case_Folding + Case_Folding + &_Perl_IVCF + ); + # NOTE that the convention is that extra enum values come + # after the property name, separated by commas, with the enums + # that aren't ever defined by Unicode coming last, at least 4 + # all-uppercase characters. The others are enum names that + # are needed by perl, but aren't in all Unicode releases. + +my @bin_props; +my @perl_prop_synonyms; +my %enums; +my @deprecated_messages = ""; # Element [0] is a placeholder +my %deprecated_tags; + +my $float_e_format = qr/ ^ -? \d \. \d+ e [-+] \d+ $ /x; + +# Create another hash that maps floating point x.yyEzz representation to what +# %stricter_to_file_of does for the equivalent rational. A typical entry in +# the latter hash is +# +# 'nv=1/2' => 'Nv/1_2', +# +# From that, this loop creates an entry +# +# 'nv=5.00e-01' => 'Nv/1_2', +# +# %stricter_to_file_of contains far more than just the rationals. Instead we +# use %utf8::nv_floating_to_rational which should have an entry for each +# nv in the former hash. +my %floating_to_file_of; +foreach my $key (keys %utf8::nv_floating_to_rational) { + my $value = $utf8::nv_floating_to_rational{$key}; + $floating_to_file_of{$key} = $utf8::stricter_to_file_of{"nv=$value"}; +} + +# Collect all the binary properties from data in lib/unicore +# Sort so that complements come after the main table, and the shortest +# names first, finally alphabetically. Also, sort together the tables we want +# to be kept together, and prefer those with 'posix' in their names, which is +# what the C code is expecting their names to be. +foreach my $property (sort + { exists $keep_together{lc $b} <=> exists $keep_together{lc $a} + or $b =~ /posix/i <=> $a =~ /posix/i + or $b =~ /perl/i <=> $a =~ /perl/i + or $a =~ $float_e_format <=> $b =~ $float_e_format + or $a =~ /!/ <=> $b =~ /!/ + or length $a <=> length $b + or $a cmp $b + } keys %utf8::loose_to_file_of, + keys %utf8::stricter_to_file_of, + keys %floating_to_file_of +) { + + # These two hashes map properties to values that can be considered to + # be checksums. If two properties have the same checksum, they have + # identical entries. Otherwise they differ in some way. + my $tag = $utf8::loose_to_file_of{$property}; + $tag = $utf8::stricter_to_file_of{$property} unless defined $tag; + $tag = $floating_to_file_of{$property} unless defined $tag; + + # The tag may contain an '!' meaning it is identical to the one formed + # by removing the !, except that it is inverted. + my $inverted = $tag =~ s/!//; + + # This hash is lacking the property name + $property = "nv=$property" if $property =~ $float_e_format; + + # The list of 'prop=value' entries that this single entry expands to + my @this_entries; + + # Split 'property=value' on the equals sign, with $lhs being the whole + # thing if there is no '=' + my ($lhs, $rhs) = $property =~ / ( [^=]* ) ( =? .*) /x; + + # $lhs then becomes the property name. See if there are any synonyms + # for this property. + if (exists $prop_name_aliases{$lhs}) { + + # If so, do the combinatorics so that a new entry is added for + # each legal property combined with the property value (which is + # $rhs) + foreach my $alias (@{$prop_name_aliases{$lhs}}) { + + # But, there are some ambiguities, like 'script' is a synonym + # for 'sc', and 'sc' can stand alone, meaning something + # entirely different than 'script'. 'script' cannot stand + # alone. Don't add if the potential new lhs is in the hash of + # stand-alone properties. + no warnings 'once'; + next if $rhs eq "" && grep { $alias eq $_ } + keys %utf8::loose_property_to_file_of; + + my $new_entry = $alias . $rhs; + push @this_entries, $new_entry; + } + } + + # Above, we added the synonyms for the base entry we're now + # processing. But we haven't dealt with it yet. If we already have a + # property with the identical characteristics, this becomes just a + # synonym for it. + if (exists $enums{$tag}) { + push @this_entries, $property; + } + else { # Otherwise, create a new entry. + + # Add to the list of properties to generate inversion lists for. + push @bin_props, uc $property; + + # Create a rule for the parser + if (! exists $keywords{$property}) { + $keywords{$property} = token_name($property); + } + + # And create an enum for it. + $enums{$tag} = $table_name_prefix . uc sanitize_name($property); + + $perl_tags{$tag} = 1 if exists $keep_together{lc $property}; + + # Some properties are deprecated. This hash tells us so, and the + # warning message to raise if they are used. + if (exists $utf8::why_deprecated{$tag}) { + $deprecated_tags{$enums{$tag}} = scalar @deprecated_messages; + push @deprecated_messages, $utf8::why_deprecated{$tag}; + } + + # Our sort above should have made sure that we see the + # non-inverted version first, but this makes sure. + warn "$property is inverted!!!" if $inverted; + } + + # Everything else is #defined to be the base enum, inversion is + # indicated by negating the value. + my $defined_to = ""; + $defined_to .= "-" if $inverted; + $defined_to .= $enums{$tag}; + + # Go through the entries that evaluate to this. + @this_entries = uniques @this_entries; + foreach my $define (@this_entries) { + + # There is a rule for the parser for each. + $keywords{$define} = $defined_to; + + # And a #define for all simple names equivalent to a perl property, + # except those that begin with 'is' or 'in'; + if (exists $perl_tags{$tag} && $property !~ / ^ i[ns] | = /x) { + push @perl_prop_synonyms, "#define " + . $table_name_prefix + . uc(sanitize_name($define)) + . " $defined_to"; + } + } +} + +@bin_props = sort { exists $keep_together{lc $b} <=> exists $keep_together{lc $a} + or $a cmp $b + } @bin_props; +@perl_prop_synonyms = sort(uniques(@perl_prop_synonyms)); +push @props, @bin_props; + +foreach my $prop (@props) { + + # For the Latin1 properties, we change to use the eXtended version of the + # base property, then go through the result and get rid of everything not + # in Latin1 (above 255). Actually, we retain the element for the range + # that crosses the 255/256 boundary if it is one that matches the + # property. For example, in the Word property, there is a range of code + # points that start at U+00F8 and goes through U+02C1. Instead of + # artificially cutting that off at 256 because 256 is the first code point + # above Latin1, we let the range go to its natural ending. That gives us + # extra information with no added space taken. But if the range that + # crosses the boundary is one that doesn't match the property, we don't + # start a new range above 255, as that could be construed as going to + # infinity. For example, the Upper property doesn't include the character + # at 255, but does include the one at 256. We don't include the 256 one. + my $prop_name = $prop; + my $is_local_sub = $prop_name =~ s/^&//; + my $extra_enums = ""; + $extra_enums = $1 if $prop_name =~ s/, ( .* ) //x; + my $lookup_prop = $prop_name; + $prop_name = sanitize_name($prop_name); + $prop_name = $table_name_prefix . $prop_name if grep { lc $lookup_prop eq lc $_ } @bin_props; + my $l1_only = ($lookup_prop =~ s/^L1Posix/XPosix/ + or $lookup_prop =~ s/^L1//); + my $nonl1_only = 0; + $nonl1_only = $lookup_prop =~ s/^NonL1// unless $l1_only; + ($lookup_prop, my $has_suffixes) = $lookup_prop =~ / (.*) ( , .* )? /x; + + for my $charset (get_supported_code_pages()) { + @a2n = @{get_a2n($charset)}; my @invlist; my @invmap; @@ -1815,9 +2375,19 @@ for my $charset (get_supported_code_pages()) { my $map_default; my $maps_to_code_point; my $to_adjust; + my $same_in_all_code_pages; if ($is_local_sub) { - @invlist = eval $lookup_prop; + my @return = eval $lookup_prop; die $@ if $@; + my $invlist_ref = shift @return; + @invlist = @$invlist_ref; + if (@return) { # If has other values returned , must be an + # inversion map + my $invmap_ref = shift @return; + @invmap = @$invmap_ref; + $map_format = shift @return; + $map_default = shift @return; + } } else { @invlist = prop_invlist($lookup_prop, '_perl_core_internal_ok'); @@ -1833,27 +2403,24 @@ for my $charset (get_supported_code_pages()) { # in scalar context to differentiate my $count = prop_invlist($lookup_prop, '_perl_core_internal_ok'); + if (defined $count) { + # Short-circuit an empty inversion list. + output_invlist($prop_name, \@invlist, $charset); + last; + } die "Could not find inversion list for '$lookup_prop'" - unless defined $count; } else { @invlist = @$list_ref; @invmap = @$map_ref; $map_format = $format; $map_default = $default; - $maps_to_code_point = $map_format =~ /x/; + $maps_to_code_point = $map_format =~ / a ($ | [^r] ) /x; $to_adjust = $map_format =~ /a/; } } } - - # Short-circuit an empty inversion list. - if (! @invlist) { - output_invlist($prop_name, \@invlist, $charset); - next; - } - # Re-order the Unicode code points to native ones for this platform. # This is only needed for code points below 256, because native code # points are only in that range. For inversion maps of properties @@ -1876,40 +2443,42 @@ for my $charset (get_supported_code_pages()) { # of 0..256, as the remap will also include all of 0..256 (256 not # 255 because a re-ordering could cause 256 to need to be in the same # range as 255.) - if ((@invmap && $maps_to_code_point) - || (! $nonl1_only || ($invlist[0] < 256 - && ! ($invlist[0] == 0 && $invlist[1] > 256)))) + if ( (@invmap && $maps_to_code_point) + || ( @invlist + && $invlist[0] < 256 + && ( $invlist[0] != 0 + || (scalar @invlist != 1 && $invlist[1] < 256)))) { - + $same_in_all_code_pages = 0; if (! @invmap) { # Straight inversion list - # Look at all the ranges that start before 257. - my @latin1_list; - while (@invlist) { - last if $invlist[0] > 256; - my $upper = @invlist > 1 - ? $invlist[1] - 1 # In range - - # To infinity. You may want to stop much much - # earlier; going this high may expose perl - # deficiencies with very large numbers. - : $Unicode::UCD::MAX_CP; - for my $j ($invlist[0] .. $upper) { - push @latin1_list, a2n($j); - } + # Look at all the ranges that start before 257. + my @latin1_list; + while (@invlist) { + last if $invlist[0] > 256; + my $upper = @invlist > 1 + ? $invlist[1] - 1 # In range + + # To infinity. You may want to stop much much + # earlier; going this high may expose perl + # deficiencies with very large numbers. + : 256; + for my $j ($invlist[0] .. $upper) { + push @latin1_list, a2n($j); + } - shift @invlist; # Shift off the range that's in the list - shift @invlist; # Shift off the range not in the list - } + shift @invlist; # Shift off the range that's in the list + shift @invlist; # Shift off the range not in the list + } - # Here @invlist contains all the ranges in the original that start - # at code points above 256, and @latin1_list contains all the - # native code points for ranges that start with a Unicode code - # point below 257. We sort the latter and convert it to inversion - # list format. Then simply prepend it to the list of the higher - # code points. - @latin1_list = sort { $a <=> $b } @latin1_list; - @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list); - unshift @invlist, @latin1_list; + # Here @invlist contains all the ranges in the original that + # start at code points above 256, and @latin1_list contains + # all the native code points for ranges that start with a + # Unicode code point below 257. We sort the latter and + # convert it to inversion list format. Then simply prepend it + # to the list of the higher code points. + @latin1_list = sort { $a <=> $b } @latin1_list; + @latin1_list = mk_invlist_from_sorted_cp_list(\@latin1_list); + unshift @invlist, @latin1_list; } else { # Is an inversion map @@ -1930,7 +2499,11 @@ for my $charset (get_supported_code_pages()) { # to look at the whole of the inversion map (or at least to # above Unicode; as the maps of code points above that should # all be to the default). - my $upper_limit = ($maps_to_code_point) ? 0x10FFFF : 256; + my $upper_limit = (! $maps_to_code_point) + ? 256 + : (Unicode::UCD::UnicodeVersion() eq '1.1.5') + ? 0xFFFF + : 0x10FFFF; my %mapped_lists; # A hash whose keys are the buckets. while (@invlist) { @@ -1938,19 +2511,16 @@ for my $charset (get_supported_code_pages()) { # This shouldn't actually happen, as prop_invmap() returns # an extra element at the end that is beyond $upper_limit - die "inversion map that extends to infinity is unimplemented" unless @invlist > 1; + die "inversion map (for $prop_name) that extends to infinity is unimplemented" unless @invlist > 1; my $bucket; # A hash key can't be a ref (we are only expecting arrays # of scalars here), so convert any such to a string that # will be converted back later (using a vertical tab as - # the separator). Even if the mapping is to code points, - # we don't translate to native here because the code - # output_invmap() calls to output these arrays assumes the - # input is Unicode, not native. + # the separator). if (ref $invmap[0]) { - $bucket = join "\cK", @{$invmap[0]}; + $bucket = join "\cK", map { a2n($_) } @{$invmap[0]}; } elsif ($maps_to_code_point && $invmap[0] =~ $numeric_re) { @@ -2003,9 +2573,9 @@ for my $charset (get_supported_code_pages()) { # originals that start with code points above $upper_limit. # Each bucket in %mapped_lists contains all the code points # that map to that bucket. If the bucket is for a map to a - # single code point is a single code point, the bucket has - # been converted to native. If something else (including - # multiple code points), no conversion is done. + # single code point, the bucket has been converted to native. + # If something else (including multiple code points), no + # conversion is done. # # Now we recreate the inversion map into %xlated, but this # time for the native character set. @@ -2031,7 +2601,17 @@ for my $charset (get_supported_code_pages()) { @{$xlated{$range_start}} = split /\cK/, $bucket; } else { - $xlated{$range_start} = $bucket; + # If adjusting, and there is more than one thing + # that maps to the same thing, they must be split + # so that later the adjusting doesn't think the + # subsequent items can go away because of the + # adjusting. + my $range_end = ($to_adjust && $bucket != $map_default) + ? $mapped_lists{$bucket}->[1] - 1 + : $range_start; + for my $i ($range_start .. $range_end) { + $xlated{$i} = $bucket; + } } shift @{$mapped_lists{$bucket}}; # Discard odd ranges shift @{$mapped_lists{$bucket}}; # Get ready for next @@ -2073,6 +2653,13 @@ for my $charset (get_supported_code_pages()) { unshift @invlist, @new_invlist; } } + elsif (@invmap) { # inversion maps can't cope with this variable + # being true, even if it could be true + $same_in_all_code_pages = 0; + } + else { + $same_in_all_code_pages = 1; + } # prop_invmap() returns an extra final entry, which we can now # discard. @@ -2127,16 +2714,81 @@ for my $charset (get_supported_code_pages()) { $found_nonl1 = 1; last; } - die "No non-Latin1 code points in $lookup_prop" unless $found_nonl1; + if (! $found_nonl1) { + warn "No non-Latin1 code points in $prop_name"; + output_invlist($prop_name, []); + last; + } } - output_invlist($prop_name, \@invlist, $charset); - output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, $map_default, $extra_enums, $charset) if @invmap; + switch_pound_if ($prop_name, 'PERL_IN_UTF8_C'); + start_charset_pound_if($charset, 1) unless $same_in_all_code_pages; + + output_invlist($prop_name, \@invlist, ($same_in_all_code_pages) + ? $applies_to_all_charsets_text + : $charset); + + if (@invmap) { + output_invmap($prop_name, \@invmap, $lookup_prop, $map_format, + $map_default, $extra_enums, $charset); + } + + last if $same_in_all_code_pages; + end_charset_pound_if; } - end_file_pound_if; - print $out_fh "\n" . get_conditional_compile_line_end(); } +switch_pound_if ('binary_property_tables', 'PERL_IN_UTF8_C'); + +print $out_fh "\nconst char * deprecated_property_msgs[] = {\n\t"; +print $out_fh join ",\n\t", map { "\"$_\"" } @deprecated_messages; +print $out_fh "\n};\n"; + +my @enums = sort values %enums; + +# Save a copy of these before modification +my @invlist_names = map { "${_}_invlist" } @enums; + +# Post-process the enums for deprecated properties. +if (scalar keys %deprecated_tags) { + my $seen_deprecated = 0; + foreach my $enum (@enums) { + if (grep { $_ eq $enum } keys %deprecated_tags) { + + # Change the enum name for this deprecated property to a + # munged one to act as a placeholder in the typedef. Then + # make the real name be a #define whose value is such that + # its modulus with the number of enums yields the index into + # the table occupied by the placeholder. And so that dividing + # the #define value by the table length gives an index into + # the table of deprecation messages for the corresponding + # warning. + my $revised_enum = "${enum}_perl_aux"; + if (! $seen_deprecated) { + $seen_deprecated = 1; + print $out_fh "\n"; + } + print $out_fh "#define $enum ($revised_enum + (MAX_UNI_KEYWORD_INDEX * $deprecated_tags{$enum}))\n"; + $enum = $revised_enum; + } + } +} + +print $out_fh "\ntypedef enum {\n\tPERL_BIN_PLACEHOLDER = 0,\n\t"; +print $out_fh join ",\n\t", @enums; +print $out_fh "\n"; +print $out_fh "} binary_invlist_enum;\n"; +print $out_fh "\n#define MAX_UNI_KEYWORD_INDEX $enums[-1]\n"; + +print $out_fh "\n/* Synonyms for perl properties */\n"; +print $out_fh join "\n", @perl_prop_synonyms, "\n"; + +print $out_fh "\nstatic const UV * const PL_uni_prop_ptrs\[] = {\n"; +print $out_fh "\tNULL,\t/* Placeholder */\n\t"; +print $out_fh join ",\n\t", @invlist_names; +print $out_fh "\n"; +print $out_fh "};\n"; + switch_pound_if('Boundary_pair_tables', 'PERL_IN_REGEXEC_C'); output_GCB_table(); @@ -2146,10 +2798,12 @@ output_WB_table(); end_file_pound_if; my $sources_list = "lib/unicore/mktables.lst"; -my @sources = ($0, qw(lib/unicore/mktables - lib/Unicode/UCD.pm - regen/charset_translations.pl - )); +my @sources = qw(regen/mk_invlists.pl + lib/unicore/mktables + lib/Unicode/UCD.pm + regen/charset_translations.pl + regen/mk_PL_charclass.pl + ); { # Depend on mktables’ own sources. It’s a shorter list of files than # those that Unicode::UCD uses. @@ -2168,3 +2822,30 @@ my @sources = ($0, qw(lib/unicore/mktables } read_only_bottom_close_and_rename($out_fh, \@sources); + +require './regen/mph.pl'; + +sub token_name +{ + my $name = sanitize_name(shift); + warn "$name contains non-word" if $name =~ /\W/; + + return "$table_name_prefix\U$name" +} + +my $keywords_fh = open_new('uni_keywords.h', '>', + {style => '*', by => 'regen/mk_invlists.pl', + from => "mph.pl"}); + +no warnings 'once'; +print $keywords_fh <<"EOF"; +/* The precisionn to use in "%.*e" formats */ +#define PL_E_FORMAT_PRECISION $utf8::e_precision + +EOF + +my ($second_level, $seed1, $length_all_keys, $smart_blob, $rows) = MinimalPerfectHash::make_mph_from_hash(\%keywords); +print $keywords_fh MinimalPerfectHash::make_algo($second_level, $seed1, $length_all_keys, $smart_blob, $rows, undef, undef, undef, 'match_uniprop' ); + +push @sources, 'regen/mph.pl'; +read_only_bottom_close_and_rename($keywords_fh, \@sources);