This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make Perl_keyword() another 30% faster.
[perl5.git] / perl_keyword.pl
index a8c015e..b06527c 100644 (file)
@@ -1,58 +1,9 @@
-#!./perl -w
 
 # How to generate the logic of the lookup table Perl_keyword() in toke.c
 
+use Devel::Tokenizer::C 0.04;
 use strict;
-package Toke;
-use vars qw(@ISA %types);
-require ExtUtils::Constant::Base;
-@ISA = 'ExtUtils::Constant::Base';
-
-%types = (pos => "KEY_", neg => "-KEY_");
-
-# We're allowing scalar references to produce evil customisation.
-sub valid_type {
-  defined $types{$_[1]} or ref $_[1];
-}
-
-
-# This might actually be a return statement
-sub assignment_clause_for_type {
-  my ($self, $args, $value) = @_;
-  my ($type, $item) = @{$args}{qw(type item)};
-  my $comment = '';
-  $comment = " /* Weight $item->{weight} */" if defined $item->{weight};
-  return "return $types{$type}$value;$comment" if $types{$type};
-  "$$type$value;$comment";
-}
-
-sub return_statement_for_notfound {
-  "return 0;"
-}
-
-# Ditch the default "const"
-sub C_constant_name_param_definition {
-  "char *" . $_[0]->name_param;
-}
-
-sub C_constant_return_type {
-  "I32";
-}
-
-
-sub C_constant_prefix_param {
-  "aTHX_ ";
-}
-
-sub C_constant_prefix_param_defintion {
-  "pTHX_ ";
-}
-
-sub C_constant_namelen_param_definition {
-  'I32 ' . $_[0] -> C_constant_namelen_param;
-}
-
-package main;
+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
@@ -83,224 +34,45 @@ my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
             times telldir truncate uc utime umask unpack unlink unshift
             ucfirst values vec warn wait write waitpid wantarray x xor);
 
-my %frequencies = (map {/(.*):\t(.*)/} <DATA>);
+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 @names;
-push @names, map {{name=>$_, type=>"pos", weight=>$frequencies{$_}}} @pos;
-push @names, map {{name=>$_, type=>"neg", weight=>$frequencies{$_}}} @neg;
-push @names, {name=>'elseif', type=>\"", value=><<'EOC'};
-/* This is somewhat hacky.  */
+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");
-break;
-EOC
-
-print Toke->C_constant ({subname=>'Perl_keyword', breakout=>~0}, @names);
+END
+  }
 
-__DATA__
-my:    3785925
-if:    2482605
-sub:   2053554
-return:        1401629
-unless:        913955
-shift: 904125
-eq:    797065
-defined:       694277
-use:   686081
-else:  527806
-qw:    415641
-or:    405163
-s:     403691
-require:       375220
-ref:   347102
-elsif: 322365
-undef: 311156
-and:   284867
-foreach:       281720
-local: 262973
-push:  256975
-package:       245661
-print: 220904
-our:   194417
-die:   192203
-length:        163975
-next:  153355
-m:     148776
-caller:        148457
-exists:        145939
-eval:  136977
-keys:  131427
-join:  130820
-substr:        121344
-while: 120305
-for:   118158
-map:   115207
-ne:    112906
-__END__:       112636
-vec:   110566
-goto:  109258
-do:    96004
-last:  95078
-split: 93678
-warn:  91372
-grep:  75912
-delete:        74966
-sprintf:       72704
-q:     69076
-bless: 62111
-no:    61989
-not:   55868
-qq:    55149
-index: 51465
-CORE:  47391
-pop:   46933
-close: 44077
-scalar:        43953
-wantarray:     43024
-open:  39060
-x:     38549
-lc:    38487
-__PACKAGE__:   36767
-stat:  36702
-unshift:       36504
-sort:  36394
-chr:   35654
-time:  32168
-qr:    28519
-splice:        25143
-BEGIN: 24125
-tr:    22665
-chomp: 22337
-ord:   22221
-chdir: 20317
-unlink:        18616
-int:   18549
-chmod: 18455
-each:  18414
-uc:    16961
-pack:  14491
-lstat: 13859
-binmode:       12301
-select:        12209
-closedir:      11986
-readdir:       11716
-reverse:       10571
-chop:  10172
-tie:   10131
-values:        10110
-tied:  9749
-read:  9434
-opendir:       9007
-fileno:        8591
-exit:  8262
-localtime:     7993
-unpack:        7849
-abs:   7767
-printf:        6874
-cmp:   6808
-ge:    5666
-pos:   5503
-redo:  5219
-rindex:        5005
-rename:        4918
-syswrite:      4437
-system:        4326
-lock:  4210
-oct:   4195
-le:    4052
-gmtime:        4040
-utime: 3849
-sysread:       3729
-hex:   3629
-END:   3565
-quotemeta:     3120
-mkdir: 2951
-continue:      2925
-AUTOLOAD:      2713
-tell:  2578
-write: 2525
-rmdir: 2493
-seek:  2174
-glob:  2172
-study: 1933
-rand:  1824
-format:        1735
-umask: 1658
-eof:   1618
-prototype:     1602
-readlink:      1537
-truncate:      1351
-fcntl: 1257
-sysopen:       1230
-ucfirst:       1012
-getc:  981
-gethostbyname: 970
-ioctl: 967
-formline:      959
-gt:    897
-__FILE__:      888
-until: 818
-sqrt:  766
-getprotobyname:        755
-sysseek:       721
-getpeername:   713
-getpwuid:      681
-xor:   619
-y:     567
-syscall:       560
-CHECK: 538
-connect:       526
-err:   522
-sleep: 519
-sin:   499
-send:  496
-getpwnam:      483
-cos:   447
-exec:  429
-link:  425
-exp:   423
-untie: 420
-INIT:  418
-waitpid:       414
-__DATA__:      395
-symlink:       386
-kill:  382
-setsockopt:    356
-atan2: 350
-pipe:  344
-lt:    335
-fork:  327
-times: 310
-getservbyname: 299
-telldir:       294
-bind:  290
-dump:  274
-flock: 260
-recv:  250
-getsockopt:    243
-getsockname:   235
-accept:        233
-getprotobynumber:      232
-rewinddir:     218
-__LINE__:      209
-qx:    177
-lcfirst:       165
-getlogin:      158
-reset: 127
-gethostbyaddr: 68
-getgrgid:      67
-srand: 41
-chown: 34
-seekdir:       20
-readline:      19
-semctl:        17
-getpwent:      12
-getgrnam:      11
-getppid:       10
-crypt: 8
-DESTROY:       7
-getpriority:   5
-getservent:    4
-gethostent:    3
-setpriority:   2
-setnetent:     1
+  return <<END;
+return ${sign}KEY_$k;
+END
+}