File Coverage

blib/lib/CodeGen/Cpppp/Enum.pm

Criterion	Covered	Total	%
statement	247	317	77.9
branch	46	82	56.1
condition	23	56	41.0
subroutine	26	35	74.2
pod	14	19	73.6
total	356	509	69.9

package CodeGen::Cpppp::Enum;

our $VERSION = '0.005'; # VERSION
# ABSTRACT: Helper for enumerations and generating related utility functions

use v5.20;
use warnings;
use Carp;
use experimental 'signatures', 'lexical_subs', 'postderef';
use Scalar::Util 'looks_like_number';
use List::Util 'any', 'min', 'max';
BEGIN { *uniqstr= List::Util->can('uniqstr') // sub { my %seen; grep !$seen{$_}++, @_ } }
use CodeGen::Cpppp::CParser;


sub new($class, %attrs) {
   my $self= bless {}, $class;
   # apply num_format first because it affects set_values
   $self->num_format(delete $attrs{num_format})
      if exists $attrs{num_format};
   $self->$_($attrs{$_}) for keys %attrs;
   return $self;
}


sub prefix($self, @val) {
   if (@val) { $self->{prefix}= $val[0]; return $self }
   $self->{prefix} // ''
}

sub macro_prefix($self, @val) {
   if (@val) { $self->{macro_prefix}= $val[0]; return $self }
   $self->{macro_prefix} // uc($self->prefix);
}

sub symbol_prefix($self, @val) {
   if (@val) { $self->{symbol_prefix}= $val[0]; return $self }
   $self->{symbol_prefix} // lc($self->prefix);
}

sub type($self, @val) {
   if (@val) { $self->{type}= $val[0]; return $self; }
   $self->{type} // 'int';
}

sub values($self, @val) {
   return $self->set_values(@val) if @val;
   @{ $self->{values} // [] }
}

sub set_values($self, @spec) {
   my @values;
   for (@spec == 1 && ref $spec[0]? @{$spec[0]} : @spec) {
      if ('ARRAY' eq ref) {
         push @values, [ @$_ ];
      } elsif (/^\w+$/) {
         push @values, [ $_ ];
      } else {
         defined $values[-1] or croak "Got an enum value '$_' before a name";
         defined $values[-1][1] and croak "'$_' is not a valid enum name";
         $values[-1][1]= $_;
      }
   }
   # Fill in missing values with next sequential integer
   my $prev= $values[0][1] //= 0;
   for (@values[1..$#values]) {
      if (!defined $_->[1]) {
         my ($base, $ofs, $fmt)= $self->_parse_value_expr($prev);
         $_->[1]= sprintf $fmt, $ofs+1;
      }
      $prev= $_->[1];
   }
   $self->{values}= \@values;
   $self->{_analysis}= undef;
   $self;
}

sub value_table_var($self, @val) {
   if (@val) {
      $self->{value_table_var}= $val[0];
      return $self;
   }
   $self->{value_table_var} // $self->symbol_prefix . 'value_table';
}

sub indent($self, @val) {
   if (@val) {
      $self->{indent}= $val[0];
      return $self;
   }
   $self->{indent} // '   ';
}

sub _current_indent {
   $CodeGen::Cpppp::INDENT // shift->indent;
}

sub num_format($self, @val) {
   if (@val) {
      $self->{num_format}= $val[0];
      $self->{_analysis}= undef;
      return $self;
   }
   $self->{num_format} // '%d';
}

sub max_waste_factor($self, @val) {
   if (@val) {
      $self->{max_waste_factor}= $val[0];
      $self->{_analysis}= undef;
      return $self;
   }
   $self->{max_waste_factor} // 2;
}


our %_algorithm= map +( $_ => 1 ), qw( bsearch hashtable switch );
sub algorithm($self, @val) {
   if (@val) {
      !defined $val[0] or $_algorithm{$val[0]}
         or croak "Unknown parse_design '$val[0]', expected one of ".join(', ', keys %_algorithm);
      $self->{algorithm}= $val[0];
      return $self;
   }
   $self->{algorithm}
}

sub _parse_value_expr($self, $val) {
   # Make the common case fast
   return '', +$val, '%d'
      if $val =~ /^[-+]?(?:0|[1-9][0-9]*)\Z/;
   # else need to parse the expression
   my @tokens= CodeGen::Cpppp::CParser->tokenize($val);
   my $type_pattern= join '', map $_->type, @tokens;
   # Recognize patterns where a +N occurs at the end of the expression
   # Else, the whole value is the expression and will get '+N' appended.
   return $val, 0, "($val+".($self->{num_format}//'%d').")"
      unless $type_pattern =~ /(^|[-+])integer\W*$/;
   my $context= $1;
   # walk backward to last 'integer' token
   my $i= $#tokens;
   $i-- while $tokens[$i]->type ne 'integer';
   # could be start of string, -N, +N, EXPR-N, EXPR+N, or EXPR OP -N
   my $fmt_str= $val;
   my ($pos, $pos2)= ($tokens[$i]->src_pos, $tokens[$i]->src_pos+$tokens[$i]->src_len);
   my $n= $tokens[$i]->value;
   # If start of string or preceeded by '+', nothing to do.
   # If preceeded by '-', need to convert that to '+' in format string
   if ($context eq '-') {
      $n= -$n;
      $pos= $tokens[$i-1]->src_pos + 1;
      substr($fmt_str, $tokens[$i-1]->src_pos, 1, '+');
   }
   my $num_str= substr($val, $tokens[$i]->src_pos, $tokens[$i]->src_len);
   my $notation= $self->{num_format}
      // $num_str =~ /^-?0x[0-9A-F]+$/? 'X'
       : $num_str =~ /^-?0x[0-9a-f]+$/? 'x'
       : $num_str =~ /^-?0[0-9]+/? 'o'
       : 'd';
   substr($fmt_str, $pos, $pos2-$pos, '%'.($pos2-$pos).$notation);
   # The "base" is everying to the left of the number minus the number of "("
   #  to match the number of ")" to the right of the number
   my $rparen= grep $_->type eq ')', @tokens[$i..$#tokens];
   shift @tokens while $tokens[0]->type eq '(' && $rparen--;
   my $base= substr($val, $tokens[0]->src_pos, $pos-$tokens[0]->src_pos);
   return ($base, $n, $fmt_str);
}


sub is_symbolic($self) {
   $self->_analysis->{base_expr} ne '';
}

sub is_sequential($self) {
   $self->_analysis->{is_seq}
}

sub is_nearly_sequential($self) {
   $self->_analysis->{is_nearly_seq}
}

sub _analysis($self) {
   $self->{_analysis} //= do {
      my @vals= map +[ $_->[0], $self->_parse_value_expr($_->[1]) ], $self->values;
      my $base_expr= $vals[0][1];
      my %seen_ofs= ( $vals[0][2] => 1 );
      for (@vals[1..$#vals]) {
         # Can't be sequential unless they share a symbolic base expression
         $base_expr= undef, last
            unless $_->[1] eq $base_expr;
         $seen_ofs{$_->[2]}++;
      }
      my %info= (
         vals => \@vals
      );
      if (defined $base_expr) {
         # Find the min/max
         my ($min, $max)= (min(keys %seen_ofs), max(keys %seen_ofs));
         # Is it sequential?
         my ($is_seq, $is_nearly_seq, $gap);
         # don't iterate unless the range is reasonable
         if (($max - $min - @vals) <= $self->max_waste_factor * @vals) {
            $gap= 0;
            for ($min .. $max) {
               $gap++ unless $seen_ofs{$_};
            }
            $is_seq= $gap == 0;
            $is_nearly_seq= $gap <= $self->max_waste_factor * ($max-$min+1-$gap);
         }
         $info{is_seq}= $is_seq;
         $info{is_nearly_seq}= $is_nearly_seq;
         $info{gap}= $gap;
         $info{min}= $min;
         $info{max}= $max;
         $info{base_expr}= $base_expr;
      }
      \%info
   };
}


sub generate_declaration($self, %options) {
   return join "\n", $self->_generate_declaration_macros(\%options);
}

sub _generate_declaration_macros($self, $options) {
   my @vals= $self->values;
   my $name_width= max map length($_->[0]), @vals;
   my $prefix= $self->macro_prefix;
   my $fmt= "#define $prefix%-${name_width}s %s";
   return map sprintf($fmt, $_->[0], $_->[1]), @vals;
}


sub generate_static_tables($self, %options) {
   return join "\n", _generate_enum_table($self, \%options);
}

sub _generate_enum_table($self, $options) {
   my $prefix= $self->prefix;
   my @names= map $prefix . $_->[0], $self->values;
   my $name_width= max map length, @names;
   my $indent= $self->_current_indent;
   my $fmt= $indent.$indent.'{ "%s",%*s %s },';
   my @code= (
      "const struct { const char *name; const ".$self->type." value; }",
      $indent . $self->value_table_var . "[] = {",
      (map sprintf($fmt, $_, $name_width-length, '', $_), @names),
      $indent . '};'
   );
   substr($code[-2], -1, 1, ''); # remove trailing comma
   return @code;
}


sub generate_lookup_by_value($self, %options) {
   return join "\n", $self->_generate_lookup_by_value_switch(\%options);
}

sub _generate_lookup_by_value_switch($self, $options) {
   my @vals= $self->values;
   my $name_width= max map length($_->[0]), @vals;
   my $info= $self->_analysis;
   my $val_variable= 'value';
   my $prefix= $self->macro_prefix;
   my $enum_table= $self->value_table_var;
   # Generate a switch() table to look them up
   my @code= "switch ($val_variable) {";
   my $fmt=  "case $prefix%s:%*s return ${enum_table}[%d].name;";
   for (0..$#vals) {
      push @code, sprintf($fmt, $vals[$_][0], $name_width - length($vals[$_][0]), '', $_);
   }
   push @code, 'default: return NULL;', '}';
   return @code;
}


sub generate_lookup_by_name($self, %options) {
   return join "\n", $self->_generate_lookup_by_name_switch(\%options);
}

sub _generate_lookup_by_name_switch($self, $options) {
   my @vals= $self->values;
   my $info= $self->_analysis;
   my $caseless= $options->{caseless};
   my $prefixless= $options->{prefixless};
   my $prefixlen= length($self->macro_prefix);
   my $indent= $self->_current_indent;
   my $len_var= $options->{len_var} // 'len';
   my $str_ptr= $options->{str_ptr} // 'str';
   my $enum_table= $self->value_table_var;
   my $strcmp= $caseless? "strcasecmp" : "strcmp";
   my $idx_type= @vals <= 0x7F? 'int8_t'
      : @vals <= 0x7FFF? 'int16_t'
      : @vals <= 0x7FFFFFFF? 'int32_t'
      : 'int64_t';
   my @search_set;
   for (0..$#vals) {
      push @search_set, [ $self->macro_prefix . $vals[$_][0], $_ ];
      push @search_set, [ $vals[$_][0], -$_ ] if $prefixless;
   }
   my %by_len;
   for (@search_set) {
      push @{ $by_len{length $_->[0]} }, $_;
   }
   my $longest= max(keys %by_len);
   my @code= (
      "$idx_type test_el= 0;",
      ("char str_buf[$longest+1];")x!!$caseless,
      "switch ($len_var) {",
   );
   # Generate one binary decision tree for each string length
   for (sort { $a <=> $b } keys %by_len) {
      my %pivot_pos;
      my @split_expr= $self->_binary_split($by_len{$_}, $caseless, $caseless? 'str_buf' : $str_ptr, \%pivot_pos);
      push @code,
         "case $_:",
         ($caseless? (
            map "${indent}str_buf[$_]= tolower(${str_ptr}[$_]);",
               sort { $a <=> $b } keys %pivot_pos
         ) : ()),
         (map "$indent$_", @split_expr),
         "${indent}break;",
   }
   push @code,
      "default:",
      "${indent}return false;",
      "}";
   # If allowing prefixless match, some test_el will be negative, meaning to
   # test str+prefixlen
   if ($prefixless) {
      push @code,
         "if (test_el < 0) {",
         "${indent}if ($strcmp($str_ptr, ${enum_table}[-test_el].name + $prefixlen) == 0) {",
         "${indent}${indent}if (value_out) *value_out= ${enum_table}[-test_el].value;",
         "${indent}${indent}return true;",
         "${indent}}",
         "${indent}return false;",
         "}";
   }
   push @code,
      "if ($strcmp($str_ptr, ${enum_table}[test_el].name) == 0) {",
      "${indent}if (value_out) *value_out= ${enum_table}[test_el].value;",
      "${indent}return true;",
      "}",
      "return false;";
   return @code;
}

sub _binary_split($self, $vals, $caseless, $str_var, $pivot_pos) {
   # Stop at length 1
   return qq{test_el= $vals->[0][1];}
      if @$vals == 1;
   # Find a character comparison that splits the list roughly in half.
   my $goal= .5 * scalar @$vals;
   # Test every possible character and keep track of the best.
   my ($best_i, $best_ch, $best_less);
   for (my $i= 0; $i < length $vals->[0][0]; ++$i) {
      if (!$caseless) {
         for my $ch (uniqstr map substr($_->[0], $i, 1), @$vals) {
            my @less= grep substr($_->[0], $i, 1) lt $ch, @$vals;
            ($best_i, $best_ch, $best_less)= ($i, $ch, \@less)
               if !defined $best_i || abs($goal - @less) < abs($goal - @$best_less);
         }
      } else {
         for my $ch (uniqstr map lc substr($_->[0], $i, 1), @$vals) {
            my @less= grep +(lc(substr($_->[0], $i, 1)) lt $ch), @$vals;
            ($best_i, $best_ch, $best_less)= ($i, $ch, \@less)
               if !defined $best_i || abs($goal - @less) < abs($goal - @$best_less);
         }
      }
   }
   $pivot_pos->{$best_i}++; # inform caller of which chars were used
   # Binary split the things less than the pivot character
   my @less_src= $self->_binary_split($best_less, $caseless, $str_var, $pivot_pos);
   # Binary split the things greater-or-equal to the pivot character
   my %less= map +($_->[0] => 1), @$best_less;
   my @ge_src= $self->_binary_split([ grep !$less{$_->[0]}, @$vals ], $caseless, $str_var, $pivot_pos);
   my $indent= $self->_current_indent;
   return (
      "if (${str_var}[$best_i] < '$best_ch') {",
      (map $indent.$_, @less_src),
      (@ge_src > 1
         # combine "else { if"
         ? ( '} else '.$ge_src[0], @ge_src[1..$#ge_src] )
         # else { statement }
         : ( '} else {', (map $indent.$_, @ge_src), '}' )
      )
   );
}

1;

__END__