From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 24 Jan 2005 22:06:05 +0000 (+0000)
Subject: A script to regenerate Perl_keyword()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d30bcfc16b8d58581237bdcf9a2169c169d9b26f;p=p5sagit%2Fp5-mst-13.2.git
A script to regenerate Perl_keyword()
p4raw-id: //depot/perl@23877
---
diff --git a/MANIFEST b/MANIFEST
index 3db53b5..493acb0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2180,6 +2180,7 @@ perly.c parser code (NOT derived from perly.y)
perly.h header file for perly.c; derived from perly.y
perly.tab parser state tables; derived from perly.y
perly.y Yacc grammar for perl
+perl_keyword.pl A script to generate Perl_keyword() in toke.c
plan9/aperl Shell to make Perl error messages Acme-friendly
plan9/arpa/inet.h Plan9 port: replacement C header file
plan9/buildinfo Plan9 port: configuration information
diff --git a/perl_keyword.pl b/perl_keyword.pl
new file mode 100644
index 0000000..a8c015e
--- /dev/null
+++ b/perl_keyword.pl
@@ -0,0 +1,306 @@
+#!./perl -w
+
+# How to generate the logic of the lookup table Perl_keyword() in toke.c
+
+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;
+
+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);
+
+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 err 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 %frequencies = (map {/(.*):\t(.*)/} <DATA>);
+
+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. */
+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);
+
+__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