Commit | Line | Data |
d30bcfc1 |
1 | |
2 | # How to generate the logic of the lookup table Perl_keyword() in toke.c |
3 | |
35175a9c |
4 | use Devel::Tokenizer::C 0.05; |
d30bcfc1 |
5 | use strict; |
4c3bbe0f |
6 | use warnings; |
d30bcfc1 |
7 | |
0d863452 |
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 |
952306ac |
12 | split state study sub tr tie tied use undef until untie unless when |
13 | while y); |
d30bcfc1 |
14 | |
15 | my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless |
0d863452 |
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', |
bc9b29db |
46 | |
47 | err => 'err', |
712d05cf |
48 | |
49 | state => 'state', |
0d863452 |
50 | ); |
d30bcfc1 |
51 | |
4c3bbe0f |
52 | my %pos = map { ($_ => 1) } @pos; |
53 | |
54 | my $t = Devel::Tokenizer::C->new( TokenFunc => \&perl_keyword |
55 | , TokenString => 'name' |
56 | , StringLength => 'len' |
57 | , MergeSwitches => 1 |
58 | ); |
59 | |
60 | $t->add_tokens(@pos, @neg, 'elseif'); |
d30bcfc1 |
61 | |
4c3bbe0f |
62 | my $switch = $t->generate(Indent => ' '); |
63 | |
64 | print <<END; |
65 | /* |
66 | * The following code was generated by $0. |
67 | */ |
68 | |
69 | I32 |
672994ce |
70 | Perl_keyword (pTHX_ const char *name, I32 len) |
4c3bbe0f |
71 | { |
97aff369 |
72 | dVAR; |
4c3bbe0f |
73 | $switch |
74 | unknown: |
75 | return 0; |
76 | } |
77 | END |
78 | |
79 | sub perl_keyword |
80 | { |
81 | my $k = shift; |
82 | my $sign = $pos{$k} ? '' : '-'; |
83 | |
84 | if ($k eq 'elseif') { |
85 | return <<END; |
d30bcfc1 |
86 | if(ckWARN_d(WARN_SYNTAX)) |
87 | Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif"); |
4c3bbe0f |
88 | END |
89 | } |
0d863452 |
90 | elsif (my $feature = $feature_kw{$k}) { |
0d863452 |
91 | $feature =~ s/([\\"])/\\$1/g; |
92 | return <<END; |
72085112 |
93 | return (FEATURE_IS_ENABLED("$feature") ? ${sign}KEY_$k : 0); |
0d863452 |
94 | END |
95 | } |
4c3bbe0f |
96 | return <<END; |
97 | return ${sign}KEY_$k; |
98 | END |
99 | } |