perl_keyword.pl

   1 #!./perl -w
   2
   3 # How to generate the logic of the lookup table Perl_keyword() in toke.c
   4
   5 use strict;
   6 package Toke;
   7 use vars qw(@ISA %types);
   8 require ExtUtils::Constant::Base;
   9 @ISA = 'ExtUtils::Constant::Base';
  10
  11 %types = (pos => "KEY_", neg => "-KEY_");
  12
  13 # We're allowing scalar references to produce evil customisation.
  14 sub valid_type {
  15   defined $types{$_[1]} or ref $_[1];
  16 }
  17
  18
  19 # This might actually be a return statement
  20 sub assignment_clause_for_type {
  21   my ($self, $args, $value) = @_;
  22   my ($type, $item) = @{$args}{qw(type item)};
  23   my $comment = '';
  24   $comment = " /* Weight $item->{weight} */" if defined $item->{weight};
  25   return "return $types{$type}$value;$comment" if $types{$type};
  26   "$$type$value;$comment";
  27 }
  28
  29 sub return_statement_for_notfound {
  30   "return 0;"
  31 }
  32
  33 # Ditch the default "const"
  34 sub C_constant_name_param_definition {
  35   "char *" . $_[0]->name_param;
  36 }
  37
  38 sub C_constant_return_type {
  39   "I32";
  40 }
  41
  42
  43 sub C_constant_prefix_param {
  44   "aTHX_ ";
  45 }
  46
  47 sub C_constant_prefix_param_defintion {
  48   "pTHX_ ";
  49 }
  50
  51 sub C_constant_namelen_param_definition {
  52   'I32 ' . $_[0] -> C_constant_namelen_param;
  53 }
  54
  55 package main;
  56
  57 my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY do delete defined
  58              END else eval elsif exists for format foreach grep goto glob INIT
  59              if last local m my map next no our pos print printf package
  60              prototype q qr qq qw qx redo return require s scalar sort split
  61              study sub tr tie tied use undef until untie unless while y);
  62
  63 my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
  64              bind binmode CORE cmp chr cos chop close chdir chomp chmod chown
  65              crypt chroot caller connect closedir continue die dump dbmopen
  66              dbmclose eq eof err exp exit exec each endgrent endpwent
  67              endnetent endhostent endservent endprotoent fork fcntl flock
  68              fileno formline getppid getpgrp getpwent getpwnam getpwuid
  69              getpeername getprotoent getpriority getprotobyname
  70              getprotobynumber gethostbyname gethostbyaddr gethostent
  71              getnetbyname getnetbyaddr getnetent getservbyname getservbyport
  72              getservent getsockname getsockopt getgrent getgrnam getgrgid
  73              getlogin getc gt ge gmtime hex int index ioctl join keys kill lt
  74              le lc log link lock lstat length listen lcfirst localtime mkdir
  75              msgctl msgget msgrcv msgsnd ne not or ord oct open opendir pop
  76              push pack pipe quotemeta ref read rand recv rmdir reset rename
  77              rindex reverse readdir readlink readline readpipe rewinddir seek
  78              send semop select semctl semget setpgrp seekdir setpwent setgrent
  79              setnetent setsockopt sethostent setservent setpriority
  80              setprotoent shift shmctl shmget shmread shmwrite shutdown sin
  81              sleep socket socketpair sprintf splice sqrt srand stat substr
  82              system symlink syscall sysopen sysread sysseek syswrite tell time
  83              times telldir truncate uc utime umask unpack unlink unshift
  84              ucfirst values vec warn wait write waitpid wantarray x xor);
  85
  86 my %frequencies = (map {/(.*):\t(.*)/} <DATA>);
  87
  88 my @names;
  89 push @names, map {{name=>$_, type=>"pos", weight=>$frequencies{$_}}} @pos;
  90 push @names, map {{name=>$_, type=>"neg", weight=>$frequencies{$_}}} @neg;
  91 push @names, {name=>'elseif', type=>\"", value=><<'EOC'};
  92 /* This is somewhat hacky.  */
  93 if(ckWARN_d(WARN_SYNTAX))
  94   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
  95 break;
  96 EOC
  97
  98 print Toke->C_constant ({subname=>'Perl_keyword', breakout=>~0}, @names);
  99
 100 __DATA__
 101 my:     3785925
 102 if:     2482605
 103 sub:    2053554
 104 return: 1401629
 105 unless: 913955
 106 shift:  904125
 107 eq:     797065
 108 defined:        694277
 109 use:    686081
 110 else:   527806
 111 qw:     415641
 112 or:     405163
 113 s:      403691
 114 require:        375220
 115 ref:    347102
 116 elsif:  322365
 117 undef:  311156
 118 and:    284867
 119 foreach:        281720
 120 local:  262973
 121 push:   256975
 122 package:        245661
 123 print:  220904
 124 our:    194417
 125 die:    192203
 126 length: 163975
 127 next:   153355
 128 m:      148776
 129 caller: 148457
 130 exists: 145939
 131 eval:   136977
 132 keys:   131427
 133 join:   130820
 134 substr: 121344
 135 while:  120305
 136 for:    118158
 137 map:    115207
 138 ne:     112906
 139 __END__:        112636
 140 vec:    110566
 141 goto:   109258
 142 do:     96004
 143 last:   95078
 144 split:  93678
 145 warn:   91372
 146 grep:   75912
 147 delete: 74966
 148 sprintf:        72704
 149 q:      69076
 150 bless:  62111
 151 no:     61989
 152 not:    55868
 153 qq:     55149
 154 index:  51465
 155 CORE:   47391
 156 pop:    46933
 157 close:  44077
 158 scalar: 43953
 159 wantarray:      43024
 160 open:   39060
 161 x:      38549
 162 lc:     38487
 163 __PACKAGE__:    36767
 164 stat:   36702
 165 unshift:        36504
 166 sort:   36394
 167 chr:    35654
 168 time:   32168
 169 qr:     28519
 170 splice: 25143
 171 BEGIN:  24125
 172 tr:     22665
 173 chomp:  22337
 174 ord:    22221
 175 chdir:  20317
 176 unlink: 18616
 177 int:    18549
 178 chmod:  18455
 179 each:   18414
 180 uc:     16961
 181 pack:   14491
 182 lstat:  13859
 183 binmode:        12301
 184 select: 12209
 185 closedir:       11986
 186 readdir:        11716
 187 reverse:        10571
 188 chop:   10172
 189 tie:    10131
 190 values: 10110
 191 tied:   9749
 192 read:   9434
 193 opendir:        9007
 194 fileno: 8591
 195 exit:   8262
 196 localtime:      7993
 197 unpack: 7849
 198 abs:    7767
 199 printf: 6874
 200 cmp:    6808
 201 ge:     5666
 202 pos:    5503
 203 redo:   5219
 204 rindex: 5005
 205 rename: 4918
 206 syswrite:       4437
 207 system: 4326
 208 lock:   4210
 209 oct:    4195
 210 le:     4052
 211 gmtime: 4040
 212 utime:  3849
 213 sysread:        3729
 214 hex:    3629
 215 END:    3565
 216 quotemeta:      3120
 217 mkdir:  2951
 218 continue:       2925
 219 AUTOLOAD:       2713
 220 tell:   2578
 221 write:  2525
 222 rmdir:  2493
 223 seek:   2174
 224 glob:   2172
 225 study:  1933
 226 rand:   1824
 227 format: 1735
 228 umask:  1658
 229 eof:    1618
 230 prototype:      1602
 231 readlink:       1537
 232 truncate:       1351
 233 fcntl:  1257
 234 sysopen:        1230
 235 ucfirst:        1012
 236 getc:   981
 237 gethostbyname:  970
 238 ioctl:  967
 239 formline:       959
 240 gt:     897
 241 __FILE__:       888
 242 until:  818
 243 sqrt:   766
 244 getprotobyname: 755
 245 sysseek:        721
 246 getpeername:    713
 247 getpwuid:       681
 248 xor:    619
 249 y:      567
 250 syscall:        560
 251 CHECK:  538
 252 connect:        526
 253 err:    522
 254 sleep:  519
 255 sin:    499
 256 send:   496
 257 getpwnam:       483
 258 cos:    447
 259 exec:   429
 260 link:   425
 261 exp:    423
 262 untie:  420
 263 INIT:   418
 264 waitpid:        414
 265 __DATA__:       395
 266 symlink:        386
 267 kill:   382
 268 setsockopt:     356
 269 atan2:  350
 270 pipe:   344
 271 lt:     335
 272 fork:   327
 273 times:  310
 274 getservbyname:  299
 275 telldir:        294
 276 bind:   290
 277 dump:   274
 278 flock:  260
 279 recv:   250
 280 getsockopt:     243
 281 getsockname:    235
 282 accept: 233
 283 getprotobynumber:       232
 284 rewinddir:      218
 285 __LINE__:       209
 286 qx:     177
 287 lcfirst:        165
 288 getlogin:       158
 289 reset:  127
 290 gethostbyaddr:  68
 291 getgrgid:       67
 292 srand:  41
 293 chown:  34
 294 seekdir:        20
 295 readline:       19
 296 semctl: 17
 297 getpwent:       12
 298 getgrnam:       11
 299 getppid:        10
 300 crypt:  8
 301 DESTROY:        7
 302 getpriority:    5
 303 getservent:     4
 304 gethostent:     3
 305 setpriority:    2
 306 setnetent:      1