X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bdf1bb36db75d3871fd8ac7ace0bba5fcfb86259..84bafc024a74c819ac3d2b4406253dbe983e6502:/opcode.pl diff --git a/opcode.pl b/opcode.pl index bda960d..c65ced3 100755 --- a/opcode.pl +++ b/opcode.pl @@ -1,11 +1,13 @@ -#!/usr/bin/perl +#!/usr/bin/perl -w +use strict; + BEGIN { # Get function prototypes require 'regen_lib.pl'; } -$opcode_new = 'opcode.h-new'; -$opname_new = 'opnames.h-new'; +my $opcode_new = 'opcode.h-new'; +my $opname_new = 'opnames.h-new'; open(OC, ">$opcode_new") || die "Can't create $opcode_new: $!\n"; binmode OC; open(ON, ">$opname_new") || die "Can't create $opname_new: $!\n"; @@ -14,11 +16,15 @@ select OC; # Read data. +my %seen; +my (@ops, %desc, %check, %ckname, %flags, %args); + while () { chop; next unless $_; next if /^#/; - ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5); + my ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5); + $args = '' unless defined $args; warn qq[Description "$desc" duplicates $seen{$desc}\n] if $seen{$desc}; die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key}; @@ -33,15 +39,74 @@ while () { $args{$key} = $args; } +# Set up aliases + +my %alias; + +# Format is "this function" => "does these op names" +my @raw_alias = ( + Perl_do_kv => [qw( keys values )], + Perl_unimplemented_op => [qw(padany mapstart custom)], + # All the ops with a body of { return NORMAL; } + Perl_pp_null => [qw(scalar regcmaybe lineseq scope)], + + Perl_pp_goto => ['dump'], + Perl_pp_require => ['dofile'], + Perl_pp_untie => ['dbmclose'], + Perl_pp_sysread => [qw(read recv)], + Perl_pp_sysseek => ['seek'], + Perl_pp_ioctl => ['fcntl'], + Perl_pp_ssockopt => ['gsockopt'], + Perl_pp_getpeername => ['getsockname'], + Perl_pp_stat => ['lstat'], + Perl_pp_ftrowned => [qw(fteowned ftzero ftsock ftchr ftblk + ftfile ftdir ftpipe ftsuid ftsgid + ftsvtx)], + Perl_pp_fttext => ['ftbinary'], + Perl_pp_gmtime => ['localtime'], + Perl_pp_semget => [qw(shmget msgget)], + Perl_pp_semctl => [qw(shmctl msgctl)], + Perl_pp_ghostent => [qw(ghbyname ghbyaddr)], + Perl_pp_gnetent => [qw(gnbyname gnbyaddr)], + Perl_pp_gprotoent => [qw(gpbyname gpbynumber)], + Perl_pp_gservent => [qw(gsbyname gsbyport)], + Perl_pp_gpwent => [qw(gpwnam gpwuid)], + Perl_pp_ggrent => [qw(ggrnam ggrgid)], + Perl_pp_ftis => [qw(ftsize ftmtime ftatime ftctime)], + Perl_pp_chown => [qw(unlink chmod utime kill)], + Perl_pp_link => ['symlink'], + Perl_pp_ftrread => [qw(ftrwrite ftrexec fteread ftewrite + fteexec)], + Perl_pp_shmwrite => [qw(shmread msgsnd msgrcv semop)], + Perl_pp_send => ['syswrite'], + Perl_pp_defined => [qw(dor dorassign)], + Perl_pp_and => ['andassign'], + Perl_pp_or => ['orassign'], + Perl_pp_ucfirst => ['lcfirst'], + Perl_pp_sle => [qw(slt sgt sge)], + Perl_pp_print => ['say'], + Perl_pp_index => ['rindex'], + Perl_pp_oct => ['hex'], + Perl_pp_shift => ['pop'], + Perl_pp_sin => [qw(cos exp log sqrt)], + Perl_pp_bit_or => ['bit_xor'], + Perl_pp_rv2av => ['rv2hv'], + Perl_pp_akeys => ['avalues'], + ); + +while (my ($func, $names) = splice @raw_alias, 0, 2) { + $alias{$_} = $func for @$names; +} + # Emit defines. -$i = 0; print <<"END"; -/* +/* -*- buffer-read-only: t -*- + * * opcode.h * - * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -58,13 +123,17 @@ print <<"END"; #define Perl_pp_i_postinc Perl_pp_postinc #define Perl_pp_i_postdec Perl_pp_postdec +PERL_PPDEF(Perl_unimplemented_op) + END print ON <<"END"; -/* +/* -*- buffer-read-only: t -*- + * * opnames.h * - * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, by Larry Wall and others + * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, + * 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -78,6 +147,7 @@ print ON <<"END"; typedef enum opcode { END +my $i = 0; for (@ops) { print ON "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n"; } @@ -136,7 +206,6 @@ print <$pp_proto_new" or die "Error creating $pp_proto_new: $!"; binmode PP; @@ -318,7 +406,8 @@ open PPSYM, ">$pp_sym_new" or die "Error creating $pp_sym_new: $!"; binmode PPSYM; print PP <<"END"; -/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +/* -*- buffer-read-only: t -*- + !!!!!!! DO NOT EDIT THIS FILE !!!!!!! This file is built by opcode.pl from its data. Any changes made here will be lost! */ @@ -326,6 +415,7 @@ print PP <<"END"; END print PPSYM <<"END"; +# -*- buffer-read-only: t -*- # # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! # This file is built by opcode.pl from its data. Any changes made here @@ -349,6 +439,8 @@ for (@ops) { print PP "PERL_PPDEF(Perl_pp_$_)\n"; print PPSYM "Perl_pp_$_\n"; } +print PP "\n/* ex: set ro: */\n"; +print PPSYM "\n# ex: set ro:\n"; close PP or die "Error closing pp_proto.h: $!"; close PPSYM or die "Error closing pp.sym: $!"; @@ -367,7 +459,7 @@ END { ########################################################################### sub tab { - local($l, $t) = @_; + my ($l, $t) = @_; $t .= "\t" x ($l - (length($t) + 1) / 8); $t; } @@ -431,7 +523,8 @@ sub tab { __END__ -# New ops always go at the end, just before 'custom' +# New ops always go at the end +# The restriction on having custom as the last op has been removed # A recapitulation of the format of this file: # The file consists of five columns: the name of the op, an English @@ -502,10 +595,10 @@ bless bless ck_fun s@ S S? # Pushy I/O. -backtick quoted execution (``, qx) ck_open t% +backtick quoted execution (``, qx) ck_open tu% S? # glob defaults its first arg to $_ glob glob ck_glob t@ S? -readline ck_null t% F? +readline ck_readline t% F? rcatline append I/O operator ck_null t$ # Bindable operators. @@ -597,6 +690,8 @@ i_negate integer negation (-) ck_null ifsT1 S not not ck_null ifs1 S complement 1's complement (~) ck_bitop fst1 S +smartmatch smart match ck_smartmatch s2 + # High falutin' math. atan2 atan2 ck_fun fsT@ S S @@ -624,7 +719,7 @@ vec vec ck_fun ist@ S S S index index ck_index isT@ S S S? rindex rindex ck_index isT@ S S S? -sprintf sprintf ck_fun mfst@ S L +sprintf sprintf ck_fun mst@ S L formline formline ck_fun ms@ S L ord ord ck_fun ifsTu% S? chr chr ck_fun fsTu% S? @@ -642,11 +737,15 @@ aelemfast constant array element ck_null s$ A S aelem array element ck_null s2 A S aslice array slice ck_null m@ A L +aeach each on array ck_each % A +akeys keys on array ck_each t% A +avalues values on array ck_each t% A + # Hashes. -each each ck_fun % H -values values ck_fun t% H -keys keys ck_fun t% H +each each ck_each % H +values values ck_each t% H +keys keys ck_each t% H delete delete ck_delete % S exists exists ck_exists is% S rv2hv hash dereference ck_rvconst dt1 @@ -672,7 +771,7 @@ push push ck_fun imsT@ A L pop pop ck_shift s% A? shift shift ck_shift s% A? unshift unshift ck_fun imsT@ A L -sort sort ck_sort m@ C? L +sort sort ck_sort dm@ C? L reverse reverse ck_fun mt@ L grepstart grep ck_grep dm@ C L @@ -692,9 +791,11 @@ flop range (or flop) ck_null 1 and logical and (&&) ck_null | or logical or (||) ck_null | xor logical xor ck_null fs2 S S +dor defined or (//) ck_null | cond_expr conditional expression ck_null d| andassign logical and assignment (&&=) ck_null s| orassign logical or assignment (||=) ck_null s| +dorassign defined or assignment (//=) ck_null s| method method lookup ck_method d1 entersub subroutine entry ck_subr dmt1 L @@ -723,10 +824,15 @@ redo redo ck_null ds} dump dump ck_null ds} goto goto ck_null ds} exit exit ck_exit ds% S? -# continued below +setstate set statement info ck_null s; +method_named method with known name ck_null d$ -#nswitch numeric switch ck_null d -#cswitch character switch ck_null d +entergiven given() ck_null d| +leavegiven leave given block ck_null 1 +enterwhen when() ck_null d| +leavewhen leave when block ck_null 1 +break break ck_null 0 +continue continue ck_null 0 # I/O. @@ -754,6 +860,7 @@ leavewrite write exit ck_null 1 prtf printf ck_listiob ims@ F? L print print ck_listiob ims@ F? L +say say ck_listiob ims@ F? L sysopen sysopen ck_fun s@ F S S S? sysseek sysseek ck_fun s@ F S S @@ -801,30 +908,31 @@ fteread -r ck_ftst isu- F- ftewrite -w ck_ftst isu- F- fteexec -x ck_ftst isu- F- ftis -e ck_ftst isu- F- -fteowned -O ck_ftst isu- F- -ftrowned -o ck_ftst isu- F- -ftzero -z ck_ftst isu- F- ftsize -s ck_ftst istu- F- ftmtime -M ck_ftst stu- F- ftatime -A ck_ftst stu- F- ftctime -C ck_ftst stu- F- +ftrowned -O ck_ftst isu- F- +fteowned -o ck_ftst isu- F- +ftzero -z ck_ftst isu- F- ftsock -S ck_ftst isu- F- ftchr -c ck_ftst isu- F- ftblk -b ck_ftst isu- F- ftfile -f ck_ftst isu- F- ftdir -d ck_ftst isu- F- ftpipe -p ck_ftst isu- F- -ftlink -l ck_ftst isu- F- ftsuid -u ck_ftst isu- F- ftsgid -g ck_ftst isu- F- ftsvtx -k ck_ftst isu- F- +ftlink -l ck_ftst isu- F- fttty -t ck_ftst is- F- fttext -T ck_ftst isu- F- ftbinary -B ck_ftst isu- F- # File calls. -chdir chdir ck_fun isT% S? +# chdir really behaves as if it had both "S?" and "F?" +chdir chdir ck_chdir isT% S? chown chown ck_fun imsT@ L chroot chroot ck_fun isTu% S? unlink unlink ck_fun imsTu@ L @@ -889,9 +997,9 @@ msgrcv msgrcv ck_fun imst@ S S S S S # Semaphores. +semop semop ck_fun imst@ S S semget semget ck_fun imst@ S S S semctl semctl ck_fun imst@ S S S S -semop semop ck_fun imst@ S S # Eval. @@ -943,15 +1051,9 @@ syscall syscall ck_fun imst@ S L # For multi-threading lock lock ck_rfun s% R -threadsv per-thread value ck_null ds0 - -# Control (contd.) -setstate set statement info ck_null s; -method_named method with known name ck_null d$ -dor defined or (//) ck_null | -dorassign defined or assignment (//=) ck_null s| +# For state support -# Add new ops before this, the custom operator. +once once ck_null | custom unknown custom operator ck_null 0