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