| 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 scalar sort |
| 12 | split study sub tr tie tied use undef until untie unless when while |
| 13 | 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 err 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 say 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 time times telldir truncate uc utime umask unpack |
| 35 | unlink unshift ucfirst values vec warn wait write waitpid wantarray |
| 36 | x xor); |
| 37 | |
| 38 | my %feature_kw = ( |
| 39 | given => 'switch', |
| 40 | when => 'switch', |
| 41 | default => 'switch', |
| 42 | # continue is already a keyword |
| 43 | break => 'switch', |
| 44 | |
| 45 | say => 'say', |
| 46 | |
| 47 | err => 'err', |
| 48 | ); |
| 49 | |
| 50 | my %pos = map { ($_ => 1) } @pos; |
| 51 | |
| 52 | my $t = Devel::Tokenizer::C->new( TokenFunc => \&perl_keyword |
| 53 | , TokenString => 'name' |
| 54 | , StringLength => 'len' |
| 55 | , MergeSwitches => 1 |
| 56 | ); |
| 57 | |
| 58 | $t->add_tokens(@pos, @neg, 'elseif'); |
| 59 | |
| 60 | my $switch = $t->generate(Indent => ' '); |
| 61 | |
| 62 | print <<END; |
| 63 | /* |
| 64 | * The following code was generated by $0. |
| 65 | */ |
| 66 | |
| 67 | I32 |
| 68 | Perl_keyword (pTHX_ const char *name, I32 len) |
| 69 | { |
| 70 | dVAR; |
| 71 | $switch |
| 72 | unknown: |
| 73 | return 0; |
| 74 | } |
| 75 | END |
| 76 | |
| 77 | sub perl_keyword |
| 78 | { |
| 79 | my $k = shift; |
| 80 | my $sign = $pos{$k} ? '' : '-'; |
| 81 | |
| 82 | if ($k eq 'elseif') { |
| 83 | return <<END; |
| 84 | if(ckWARN_d(WARN_SYNTAX)) |
| 85 | Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif"); |
| 86 | END |
| 87 | } |
| 88 | elsif (my $feature = $feature_kw{$k}) { |
| 89 | $feature =~ s/([\\"])/\\$1/g; |
| 90 | return <<END; |
| 91 | return (FEATURE_IS_ENABLED("$feature") ? ${sign}KEY_$k : 0); |
| 92 | END |
| 93 | } |
| 94 | return <<END; |
| 95 | return ${sign}KEY_$k; |
| 96 | END |
| 97 | } |