perl_keyword.pl

   1
   2 # How to generate the logic of the lookup table Perl_keyword() in toke.c
   3
   4 use Devel::Tokenizer::C 0.05;
   5 use strict;
   6 use warnings;
   7
   8 my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY default defined
   9             delete do END else eval elsif exists for format foreach given grep
  10             goto glob INIT if last local m my map next no our pos print printf
  11             package prototype q qr qq qw qx redo return require s say scalar sort
  12             split state study sub tr use undef UNITCHECK until
  13             unless when while y);
  14
  15 my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
  16             break bind binmode CORE cmp chr cos chop close chdir chomp chmod
  17             chown crypt chroot caller connect closedir continue die dump
  18             dbmopen dbmclose eq eof exp exit exec each endgrent endpwent
  19             endnetent endhostent endservent endprotoent fork fcntl flock fileno
  20             formline getppid getpgrp getpwent getpwnam getpwuid getpeername
  21             getprotoent getpriority getprotobyname getprotobynumber
  22             gethostbyname gethostbyaddr gethostent getnetbyname getnetbyaddr
  23             getnetent getservbyname getservbyport getservent getsockname
  24             getsockopt getgrent getgrnam getgrgid getlogin getc gt ge gmtime
  25             hex int index ioctl join keys kill lt le lc log link lock lstat
  26             length listen lcfirst localtime mkdir msgctl msgget msgrcv msgsnd
  27             ne not or ord oct open opendir pop push pack pipe quotemeta ref
  28             read rand recv rmdir reset rename rindex reverse readdir readlink
  29             readline readpipe rewinddir seek send semop select semctl semget
  30             setpgrp seekdir setpwent setgrent setnetent setsockopt sethostent
  31             setservent setpriority setprotoent shift shmctl shmget shmread
  32             shmwrite shutdown sin sleep socket socketpair sprintf splice sqrt
  33             srand stat substr system symlink syscall sysopen sysread sysseek
  34             syswrite tell tie tied time times telldir truncate uc utime
  35             umask unpack unlink unshift untie ucfirst values vec warn wait
  36             write waitpid wantarray
  37             x xor);
  38
  39 my %feature_kw = (
  40         given   => 'switch',
  41         when    => 'switch',
  42         default => 'switch',
  43         # continue is already a keyword
  44         break   => 'switch',
  45
  46         say     => 'say',
  47
  48         state   => 'state',
  49         );
  50
  51 my %pos = map { ($_ => 1) } @pos;
  52
  53 my $t = Devel::Tokenizer::C->new( TokenFunc     => \&perl_keyword
  54                                 , TokenString   => 'name'
  55                                 , StringLength  => 'len'
  56                                 , MergeSwitches => 1
  57                                 );
  58
  59 $t->add_tokens(@pos, @neg, 'elseif');
  60
  61 my $switch = $t->generate(Indent => '  ');
  62
  63 print <<END;
  64 /*
  65  *  The following code was generated by $0.
  66  */
  67
  68 I32
  69 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
  70 {
  71     dVAR;
  72 $switch
  73 unknown:
  74   return 0;
  75 }
  76 END
  77
  78 sub perl_keyword
  79 {
  80   my $k = shift;
  81   my $sign = $pos{$k} ? '' : '-';
  82
  83   if ($k eq 'elseif') {
  84     return <<END;
  85 if(ckWARN_d(WARN_SYNTAX))
  86   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
  87 END
  88   }
  89   elsif (my $feature = $feature_kw{$k}) {
  90     $feature =~ s/([\\"])/\\$1/g;
  91     return <<END;
  92 return (all_keywords || FEATURE_IS_ENABLED("$feature") ? ${sign}KEY_$k : 0);
  93 END
  94   }
  95   return <<END;
  96 return ${sign}KEY_$k;
  97 END
  98 }