File Coverage

blib/lib/CodeGen/Cpppp/CParser.pm

Criterion	Covered	Total	%
statement	54	63	85.7
branch	10	20	50.0
condition	20	33	60.6
subroutine	10	11	90.9
pod	1	2	50.0
total	95	129	73.6

package CodeGen::Cpppp::CParser;

our $VERSION = '0.005'; # VERSION
# ABSTRACT: C Parser Utility Library

use v5.20;
use warnings;
use Carp;
use experimental 'signatures', 'postderef';

sub new {
   my $class= shift;
   my $self= bless {
      !(@_ & 1)? @_
      : @_ == 1 && ref $_[0] eq 'HASH'? %{$_[0]}
      : Carp::croak("Expected hashref or even-length list")
   }, $class;
}


sub tokenize {
   my ($class, undef, $tok_lim)= @_;
   my $textref= ref $_[1] eq 'SCALAR'? $_[1] : \$_[1];
   $class->_get_tokens($textref, $tok_lim);
}

sub CodeGen::Cpppp::CParser::Token::type    { $_[0][0] }
sub CodeGen::Cpppp::CParser::Token::value   { $_[0][1] }
sub CodeGen::Cpppp::CParser::Token::src_pos { $_[0][2] }
sub CodeGen::Cpppp::CParser::Token::src_len { $_[0][3] }

our %keywords= map +($_ => 1), qw(
   auto break case char const continue default do double else enum extern
   float for goto if int long register return short signed sizeof static
   struct switch typedef union unsigned void volatile while

   inline _Bool _Complex _Imaginary

   __FUNCTION__ __PRETTY_FUNCTION__ __alignof __alignof__ __asm
   __asm__ __attribute __attribute__ __builtin_offsetof __builtin_va_arg
   __complex __complex__ __const __extension__ __func__ __imag __imag__
   __inline __inline__ __label__ __null __real __real__
   __restrict __restrict__ __signed __signed__ __thread __typeof
   __volatile __volatile__

   restrict
);
our %named_escape= (
   a => "\a", b => "\b", e => "\e", f => "\f",
   n => "\n", r => "\r", t => "\t", v => "\x0B"
);
our %tokens_before_infix_minus= map +($_ => 1), (
   ']', ')', 'integer','real','ident',
);
sub _get_tokens {
   my ($class, $textref, $tok_lim)= @_;
   pos($$textref)= 0 unless defined pos($$textref);
   my @tokens;
   local our $_type;
   local our $_value;
   local our $_error;
   while ((!defined $tok_lim || --$tok_lim >= 0)
      && $$textref =~ m{
         \G
         (?> \s* ) \K # ignore whitespace
         (?|
            # single-line comment
            // ( [^\r\n]* )
            (?{ $_type= 'comment' })

            # block comment
         |  /\* ( (?: [^*]+ | \* (?=[^/]) )* ) ( \*/ | \Z )
            (?{ $_type= 'comment'; $_error= "Reached end of input looking for '*/'" unless $2 })

            # Preprocessor directive
         |  \# \s* ( (?: [^\r\n\\]+ | \\ \r? \n | \\ (?=[^\r\n]) )* )
            (?{ $_type= 'directive' })

            # string literal
         |  " (?{ '' })
               (?|
                  ([^"\\]+)          (?{ $^R . $1 })
               |  \\x ([0-9A-Fa-f]+) (?{ $^R . chr(hex $1) })
               |  \\ ([0-9]{1,3})    (?{ $^R . chr(oct $1) })
               |  \\ \r?\n
               |  \\ (.)             (?{ $^R . ($named_escape{$1} // $1) })
               )*
            ( " | \Z )
            (?{ $_type= 'string'; $_value= $^R; $_error= q{Reached end of input looking for '"'} unless $2 })

            # character constant
         |  '  (?|
                  ([^'\\])           (?{ $1 })
               |  \\x ([0-9A-Fa-f]+) (?{ chr(hex $1) })
               |  \\ ([0-9]{1,3})    (?{ chr(oct $1) })
               |  \\ (.)             (?{ $named_escape{$1} // $1 })
               )
            ( '? )
            (?{ $_type= 'char'; $_value= $^R; $_error= q{Unterminated character constant} unless $2 })

            # identifier
         |  ( [A-Za-z_] \w* )
            (?{ $_type= $keywords{$1}? 'keyword' : 'ident' })

            # real number
         |  ( (?: [0-9]+ \. [0-9]* | \. [0-9]+ ) (?: e -? [0-9]+ )? [lLfF]? )
            (?{ $_type= 'real' })

         |  # integer
            (?|
               0x([A-Fa-f0-9]+) (?{ $_value= hex($1) })
            |  0([0-7]+)        (?{ $_value= oct($1) })
            |  ([0-9]+)
            )
            [uU]?[lL]*
            (?{ $_type= 'integer' })

         |  # punctuation and operators
            ( \+\+ | -- | -> | \+=? | -=? | \*=? | /=? | %=? | >>=? | >=? | <<=? | <=?
            | \&\&=? | \&=? | \|\|=? | \|=? | \^=? | ==? | !=? | \? | ~
            | [\[\]\(\)\{\};,.:]
            )
            (?{ $_type= $1 })

         |  # all other characters
            (.) (?{ $_type= 'unknown'; $_error= q{parse error} })
         )
      }xcg
   ) {
      my @token= ($_type, $_value // $1, $-[0], $+[0] - $-[0], defined $_error? ($_error) : ());
      # disambiguate negative number from minus operator
      if (($_type eq 'integer' || $_type eq 'real')
         && @tokens && $tokens[-1][0] eq '-'
         && (@tokens == 1 || !$tokens_before_infix_minus{$tokens[-2]->type})
      ) {
         $token[1]= -$token[1];
         $token[2]= $tokens[-1][2];
         $token[3]= $+[0] - $tokens[-1][2];
         @{$tokens[-1]}= @token;
      } else {
         push @tokens, bless \@token, 'CodeGen::Cpppp::CParser::Token';
      }
      ($_error, $_value)= (undef, undef);
   }
   return @tokens;
}

1;

__END__