X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=opcode.pl;h=7549844bb8a9eb32e727f2c44bb495b772ac039a;hb=f41e638c7a0c7db031616e2ca0a9a12cbf46dded;hp=79237971343695795c86cedb94ec8786e4a2c1ad;hpb=97aff369fa5580e7a888d4fa4c86be74ab000409;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/opcode.pl b/opcode.pl
index 7923797..7549844 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 (<DATA>) {
     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};
@@ -40,7 +46,7 @@ my %alias;
 # Format is "this function" => "does these op names"
 my @raw_alias = (
 		 Perl_do_kv => [qw( keys values )],
-		 Perl_unimplemented_op => [qw(padany threadsv mapstart)],
+		 Perl_unimplemented_op => [qw(padany mapstart custom)],
 		 # All the ops with a body of { return NORMAL; }
 		 Perl_pp_null => [qw(scalar regcmaybe lineseq scope)],
 
@@ -79,6 +85,12 @@ my @raw_alias = (
 		 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'],
 		);
 
 while (my ($func, $names) = splice @raw_alias, 0, 2) {
@@ -87,14 +99,13 @@ while (my ($func, $names) = splice @raw_alias, 0, 2) {
 
 # 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, 2006 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.
@@ -120,7 +131,8 @@ print ON <<"END";
  *
  *    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.
@@ -134,6 +146,7 @@ print ON <<"END";
 typedef enum opcode {
 END
 
+my $i = 0;
 for (@ops) {
     print ON "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
 }
@@ -227,7 +240,6 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
 END
 
 for (@ops) {
-    $_ eq "custom" and next;
     if (my $name = $alias{$_}) {
 	print "\tMEMBER_TO_FPTR($name),\t/* Perl_pp_$_ */\n";
     }
@@ -281,22 +293,22 @@ print <<END;
 #ifndef PERL_GLOBAL_STRUCT_INIT
 
 #ifndef DOINIT
-EXT const U32 PL_opargs[];
+EXTCONST U32 PL_opargs[];
 #else
-EXT const U32 PL_opargs[] = {
+EXTCONST U32 PL_opargs[] = {
 END
 
-%argnum = (
-    S,	1,		# scalar
-    L,	2,		# list
-    A,	3,		# array value
-    H,	4,		# hash value
-    C,	5,		# code value
-    F,	6,		# file value
-    R,	7,		# scalar reference
+my %argnum = (
+    'S',  1,		# scalar
+    'L',  2,		# list
+    'A',  3,		# array value
+    'H',  4,		# hash value
+    'C',  5,		# code value
+    'F',  6,		# file value
+    'R',  7,		# scalar reference
 );
 
-%opclass = (
+my %opclass = (
     '0',  0,		# baseop
     '1',  1,		# unop
     '2',  2,		# binop
@@ -317,8 +329,8 @@ my %OP_IS_SOCKET;
 my %OP_IS_FILETEST;
 
 for (@ops) {
-    $argsum = 0;
-    $flags = $flags{$_};
+    my $argsum = 0;
+    my $flags = $flags{$_};
     $argsum |= 1 if $flags =~ /m/;		# needs stack mark
     $argsum |= 2 if $flags =~ /f/;		# fold constants
     $argsum |= 4 if $flags =~ /s/;		# always produces scalar
@@ -330,13 +342,13 @@ for (@ops) {
     $argsum |= 128 if $flags =~ /u/;		# defaults to $_
     $flags =~ /([\W\d_])/ or die qq[Opcode "$_" has no class indicator];
     $argsum |= $opclass{$1} << 9;
-    $mul = 0x2000;				# 2 ^ OASHIFT
-    for $arg (split(' ',$args{$_})) {
+    my $mul = 0x2000;				# 2 ^ OASHIFT
+    for my $arg (split(' ',$args{$_})) {
 	if ($arg =~ /^F/) {
            $OP_IS_SOCKET{$_}   = 1 if $arg =~ s/s//;
            $OP_IS_FILETEST{$_} = 1 if $arg =~ s/-//;
         }
-	$argnum = ($arg =~ s/\?//) ? 8 : 0;
+	my $argnum = ($arg =~ s/\?//) ? 8 : 0;
         die "op = $_, arg = $arg\n" unless length($arg) == 1;
 	$argnum += $argnum{$arg};
 	warn "# Conflicting bit 32 for '$_'.\n"
@@ -352,9 +364,10 @@ print <<END;
 };
 #endif
 
+#endif /* !PERL_GLOBAL_STRUCT_INIT */
+
 END_EXTERN_C
 
-#endif /* !PERL_GLOBAL_STRUCT_INIT */
 END
 
 if (keys %OP_IS_SOCKET) {
@@ -383,8 +396,8 @@ foreach ('opcode.h', 'opnames.h') {
 safer_rename $opcode_new, 'opcode.h';
 safer_rename $opname_new, 'opnames.h';
 
-$pp_proto_new = 'pp_proto.h-new';
-$pp_sym_new  = 'pp.sym-new';
+my $pp_proto_new = 'pp_proto.h-new';
+my $pp_sym_new  = 'pp.sym-new';
 
 open PP, ">$pp_proto_new" or die "Error creating $pp_proto_new: $!";
 binmode PP;
@@ -445,7 +458,7 @@ END {
 
 ###########################################################################
 sub tab {
-    local($l, $t) = @_;
+    my ($l, $t) = @_;
     $t .= "\t" x ($l - (length($t) + 1) / 8);
     $t;
 }
@@ -509,7 +522,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
@@ -580,10 +594,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	<HANDLE>		ck_null		t%	F?
+readline	<HANDLE>		ck_readline	t%	F?
 rcatline	append I/O operator	ck_null		t$
 
 # Bindable operators.
@@ -675,6 +689,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
@@ -770,9 +786,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
@@ -801,10 +819,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.
 
@@ -832,6 +855,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
@@ -879,30 +903,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
@@ -967,9 +992,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.
 
@@ -1021,25 +1046,5 @@ 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|
-
-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
-smartmatch	smart match		ck_smartmatch	s2
-
-say		say			ck_say		ims@	F? L
-
-# Add new ops before this, the custom operator.
 
 custom		unknown custom operator		ck_null		0