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