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