Merge win32 and ansiperl branches post _55 tweaks from Sarathy.

p4raw-id: //depot/ansiperl@314

25 files changed, 82 insertions, 65 deletions

diff --git a/EXTERN.h b/EXTERN.h
index 228ed52406..1c10f643b9 100644
--- a/EXTERN.h
+++ b/EXTERN.h
@@ -24,7 +24,7 @@
 #  define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
 #else
 #  if (defined(_MSC_VER) && defined(_WIN32)) || (defined(__BORLANDC__) && defined(__WIN32__))
-#    ifdef PERLDLL
+#    ifdef PERL_CORE
 #      define EXT extern __declspec(dllexport)
 #      define dEXT 
 #      define EXTCONST extern __declspec(dllexport) const
diff --git a/XSUB.h b/XSUB.h
index c7c3f6d80e..054b4cc7f7 100644
--- a/XSUB.h
+++ b/XSUB.h
@@ -15,7 +15,11 @@
 
 #define dXSI32 I32 ix = XSANY.any_i32
 
-#define XSRETURN(off) stack_sp = stack_base + ax + ((off) - 1); return
+#define XSRETURN(off)					\
+    STMT_START {					\
+	stack_sp = stack_base + ax + ((off) - 1);	\
+	return;						\
+    } STMT_END
 
 /* Simple macros to put new mortal values onto the stack.   */
 /* Typically used to return values from XS functions.       */
diff --git a/embed.h b/embed.h
index b577200f98..541fcf757e 100644
--- a/embed.h
+++ b/embed.h
@@ -254,7 +254,6 @@
 #define he_root			Perl_he_root
 #define hexdigit		Perl_hexdigit
 #define hints			Perl_hints
-#define hoistmust		Perl_hoistmust
 #define hv_clear		Perl_hv_clear
 #define hv_delayfree_ent	Perl_hv_delayfree_ent
 #define hv_delete		Perl_hv_delete
@@ -911,6 +910,8 @@
 #define rsignal_save		Perl_rsignal_save
 #define rsignal_state		Perl_rsignal_state
 #define runops			Perl_runops
+#define runops_debug		Perl_runops_debug
+#define runops_standard		Perl_runops_standard
 #define rxres_free		Perl_rxres_free
 #define rxres_restore		Perl_rxres_restore
 #define rxres_save		Perl_rxres_save
diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c
index 58006789ef..422b3d1bf9 100644
--- a/ext/DynaLoader/dlutils.c
+++ b/ext/DynaLoader/dlutils.c
@@ -26,7 +26,7 @@ static int dl_debug = 0;	/* value copied from $DynaLoader::dl_error */
 
 
 static void
-dl_generic_private_init()	/* called by dl_*.xs dl_private_init() */
+dl_generic_private_init(void)	/* called by dl_*.xs dl_private_init() */
 {
     char *perl_dl_nonlazy;
 #ifdef DEBUGGING
@@ -44,16 +44,8 @@ dl_generic_private_init()	/* called by dl_*.xs dl_private_init() */
 
 
 /* SaveError() takes printf style args and saves the result in LastError */
-#ifdef STANDARD_C
 static void
 SaveError(char* pat, ...)
-#else
-/*VARARGS0*/
-static void
-SaveError(pat, va_alist)
-    char *pat;
-    va_dcl
-#endif
 {
     va_list args;
     char *message;
diff --git a/ext/SDBM_File/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h
index 5bc629f402..ac2dc36b01 100644
--- a/ext/SDBM_File/sdbm/sdbm.h
+++ b/ext/SDBM_File/sdbm/sdbm.h
@@ -49,7 +49,7 @@ typedef struct {
 
 extern datum nullitem;
 
-#if defined(__STDC__) || defined(__cplusplus)
+#if defined(__STDC__) || defined(__cplusplus) || defined(CAN_PROTOTYPE)
 #define proto(p) p
 #else
 #define proto(p) ()
diff --git a/hv.c b/hv.c
index c68b09ddfb..079e95297b 100644
--- a/hv.c
+++ b/hv.c
@@ -16,8 +16,8 @@
 
 static void hsplit _((HV *hv));
 static void hfreeentries _((HV *hv));
-
-static HE* more_he(void);
+static void hv_magic_check _((HV *hv, bool *needs_copy, bool *needs_store));
+static HE* more_he _((void));
 
 static HE*
 new_he(void)
diff --git a/mg.c b/mg.c
index b7b09d34a1..8a7cfdda14 100644
--- a/mg.c
+++ b/mg.c
@@ -1733,10 +1733,10 @@ Signal_t
 sighandler(int sig)
 {
     dSP;
-    GV *gv;
+    GV *gv = Nullgv;
     HV *st;
     SV *sv, *tSv = Sv;
-    CV *cv;
+    CV *cv = Nullcv;
     AV *oldstack;
     OP *myop = op;
     U32 flags = 0;
@@ -1788,8 +1788,11 @@ sighandler(int sig)
     if (!cv || !CvROOT(cv)) {
 	if (dowarn)
 	    warn("SIG%s handler \"%s\" not defined.\n",
-		sig_name[sig], GvENAME(gv) );
-	return;
+		sig_name[sig], (gv ? GvENAME(gv)
+				: ((cv && CvGV(cv))
+				   ? GvENAME(CvGV(cv))
+				   : "__ANON__")));
+	goto cleanup;
     }
 
     oldstack = curstack;
@@ -1812,6 +1815,7 @@ sighandler(int sig)
     perl_call_sv((SV*)cv, G_DISCARD);
 
     SWITCHSTACK(signalstack, oldstack);
+cleanup:
     if (flags & 1)
 	savestack_ix -= 8; /* Unprotect save in progress. */
     if (flags & 2) {
diff --git a/op.c b/op.c
index 590aa006c9..35fd3a04c1 100644
--- a/op.c
+++ b/op.c
@@ -531,9 +531,9 @@ find_threadsv(char *name)
 	case '\'':
 	    sawampersand = TRUE;
 	    SvREADONLY_on(sv);
+	    /* FALL THROUGH */
 	default:
 	    sv_magic(sv, 0, 0, name, 1); 
-	    break;
 	}
 	DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 			      "find_threadsv: new SV %p for $%s%c\n",
@@ -3433,18 +3433,15 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
 	if (PERLDB_SUBLINE && curstash != debstash) {
 	    SV *sv = NEWSV(0,0);
 	    SV *tmpstr = sv_newmortal();
-	    static GV *db_postponed;
+	    GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
 	    CV *cv;
 	    HV *hv;
 
-	    sv_setpvf(sv, "%_:%ld-%ld", GvSV(curcop->cop_filegv),
-		    (long)(subline < 0 ? -subline : subline),
-		    (long)curcop->cop_line);
+	    sv_setpvf(sv, "%_:%ld-%ld",
+		    GvSV(curcop->cop_filegv),
+		    (long)subline, (long)curcop->cop_line);
 	    gv_efullname3(tmpstr, gv, Nullch);
 	    hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
-	    if (!db_postponed) {
-		db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
-	    }
 	    hv = GvHVn(db_postponed);
 	    if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
 		  && (cv = GvCV(db_postponed))) {
@@ -4413,7 +4410,7 @@ ck_shift(OP *o)
 	
 	op_free(o);
 #ifdef USE_THREADS
-	if (subline > 0) {
+	if (!CvUNIQUE(compcv)) {
 	    argop = newOP(OP_PADAV, OPf_REF);
 	    argop->op_targ = 0;		/* curpad[0] is @_ */
 	}
@@ -4424,7 +4421,7 @@ ck_shift(OP *o)
 	}
 #else
 	argop = newUNOP(OP_RV2AV, 0,
-	    scalar(newGVOP(OP_GV, 0, subline > 0 ?
+	    scalar(newGVOP(OP_GV, 0, !CvUNIQUE(compcv) ?
 			   defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
 #endif /* USE_THREADS */
 	return newUNOP(type, 0, scalar(argop));
diff --git a/perl.h b/perl.h
index c05d4a91c3..7f69913d09 100644
--- a/perl.h
+++ b/perl.h
@@ -254,6 +254,8 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 #   include <stdlib.h>
 #endif
 
+#define MEM_SIZE Size_t
+
 /* This comes after <stdlib.h> so we don't try to change the standard
  * library prototypes; we'll use our own in proto.h instead. */
 
@@ -264,12 +266,20 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 #	define calloc  Mycalloc
 #	define realloc Myremalloc
 #	define free    Myfree
+Malloc_t Mymalloc _((MEM_SIZE nbytes));
+Malloc_t Mycalloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t Myrealloc _((Malloc_t where, MEM_SIZE nbytes));
+Free_t   Myfree _((Malloc_t where));
 #   endif
 #   ifdef EMBEDMYMALLOC
 #	define malloc  Perl_malloc
 #	define calloc  Perl_calloc
 #	define realloc Perl_realloc
 #	define free    Perl_free
+Malloc_t Perl_malloc _((MEM_SIZE nbytes));
+Malloc_t Perl_calloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t Perl_realloc _((Malloc_t where, MEM_SIZE nbytes));
+Free_t   Perl_free _((Malloc_t where));
 #   endif
 
 #   undef safemalloc
@@ -283,8 +293,6 @@ register struct op *op asm(stringify(OP_IN_REGISTER));
 
 #endif /* MYMALLOC */
 
-#define MEM_SIZE Size_t
-
 #if defined(STANDARD_C) && defined(I_STDDEF)
 #   include <stddef.h>
 #   define STRUCT_OFFSET(s,m)  offsetof(s,m)
diff --git a/perly.c b/perly.c
index 9ae4211943..7117566c20 100644
--- a/perly.c
+++ b/perly.c
@@ -1767,7 +1767,7 @@ case 56:
 { char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na);
 			  if (strEQ(name, "BEGIN") || strEQ(name, "END")
 			      || strEQ(name, "INIT"))
-			  { CvUNIQUE_on(compcv); subline = -subline; }
+			      CvUNIQUE_on(compcv);
 			  yyval.opval = yyvsp[0].opval; }
 break;
 case 57:
diff --git a/perly.y b/perly.y
index fa0e0f5f59..481a2ccad6 100644
--- a/perly.y
+++ b/perly.y
@@ -291,7 +291,7 @@ startformsub:	/* NULL */	/* start a format subroutine scope */
 subname	:	WORD	{ char *name = SvPV(((SVOP*)$1)->op_sv, na);
 			  if (strEQ(name, "BEGIN") || strEQ(name, "END")
 			      || strEQ(name, "INIT"))
-			  { CvUNIQUE_on(compcv); subline = -subline; }
+			      CvUNIQUE_on(compcv);
 			  $$ = $1; }
 	;
 
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index aa1e82eac8..887f827381 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -2856,10 +2856,12 @@ argument.
 Shifts the first value of the array off and returns it, shortening the
 array by 1 and moving everything down.  If there are no elements in the
 array, returns the undefined value.  If ARRAY is omitted, shifts the
-@ARGV array in the main program, and the @_ array in subroutines.
-(This is determined lexically.)  See also unshift(), push(), and pop().
-Shift() and unshift() do the same thing to the left end of an array
-that pop() and push() do to the right end.
+@_ array within the lexical scope of subroutines and formats, and the
+@ARGV array at file scopes or within the lexical scopes established by
+the C<eval ''>, C<BEGIN {}>, C<END {}>, and C<INIT {}> constructs.
+See also unshift(), push(), and pop().  Shift() and unshift() do the
+same thing to the left end of an array that pop() and push() do to the
+right end.
 
 =item shmctl ID,CMD,ARG
 
diff --git a/pp_ctl.c b/pp_ctl.c
index d9f985e8e4..834f0c0dad 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1050,11 +1050,14 @@ die_where(char *message)
 	    if (svp) {
 		if (!SvIOK(*svp)) {
 		    static char prefix[] = "\t(in cleanup) ";
+		    SV *err = ERRSV;
 		    sv_upgrade(*svp, SVt_IV);
 		    (void)SvIOK_only(*svp);
-		    SvGROW(ERRSV, SvCUR(ERRSV)+sizeof(prefix)+klen);
-		    sv_catpvn(ERRSV, prefix, sizeof(prefix)-1);
-		    sv_catpvn(ERRSV, message, klen);
+		    if (!SvPOK(err))
+			sv_setpv(err,"");
+		    SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+		    sv_catpvn(err, prefix, sizeof(prefix)-1);
+		    sv_catpvn(err, message, klen);
 		}
 		sv_inc(*svp);
 	    }
diff --git a/proto.h b/proto.h
index 202331be98..7b47a93099 100644
--- a/proto.h
+++ b/proto.h
@@ -568,13 +568,6 @@ int	yylex _((void));
 int	yyparse _((void));
 int	yywarn _((char* s));
 
-#if defined(MYMALLOC) || !defined(STANDARD_C)
-Malloc_t malloc _((MEM_SIZE nbytes));
-Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size));
-Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes));
-Free_t   free _((Malloc_t where));
-#endif
-
 #ifndef MYMALLOC
 Malloc_t safemalloc _((MEM_SIZE nbytes));
 Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size));
diff --git a/regcomp.h b/regcomp.h
index 2a00d40b6f..fe29b2dd06 100644
--- a/regcomp.h
+++ b/regcomp.h
@@ -440,12 +440,6 @@ const static char reg_off_by_arg[] = {
 };
 #endif
 
-struct reg_data {
-    U32 count;
-    U8 *what;
-    void* data[1];
-};
-
 #define REG_SEEN_ZERO_LEN	1
 #define REG_SEEN_LOOKBEHIND	2
 #define REG_SEEN_GPOS		4
diff --git a/regexp.h b/regexp.h
index 2f7aa02b3d..7137ffc329 100644
--- a/regexp.h
+++ b/regexp.h
@@ -17,6 +17,12 @@ struct regnode {
 
 typedef struct regnode regnode;
 
+struct reg_data {
+    U32 count;
+    U8 *what;
+    void* data[1];
+};
+
 typedef struct regexp {
 	I32 refcnt;
 	char **startp;
diff --git a/t/op/sort.t b/t/op/sort.t
index c792bbb48e..a6829e01e4 100755
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $
 
-print "1..19\n";
+print "1..21\n";
 
 sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
 
@@ -91,3 +91,14 @@ print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n");
 	       };
 eval { @b = sort twoface 4,1 };
 print $@ ? "$@" : "not ok 19\n";
+
+eval <<'CODE';
+    my @result = sort main'backwards 'one', 'two';
+CODE
+print $@ ? "not ok 20\n# $@" : "ok 20\n";
+
+eval <<'CODE';
+    # "sort 'one', 'two'" should not try to parse "'one" as a sort sub
+    my @result = sort 'one', 'two';
+CODE
+print $@ ? "not ok 21\n# $@" : "ok 21\n";
diff --git a/toke.c b/toke.c
index 95be7df498..dbb273a263 100644
--- a/toke.c
+++ b/toke.c
@@ -500,7 +500,7 @@ force_next(I32 type)
 }
 
 static char *
-force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_tick)
+force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 {
     register char *s;
     STRLEN len;
@@ -509,7 +509,7 @@ force_word(register char *start, int token, int check_keyword, int allow_pack, i
     s = start;
     if (isIDFIRST(*s) ||
 	(allow_pack && *s == ':') ||
-	(allow_tick && *s == '\'') )
+	(allow_initial_tick && *s == '\'') )
     {
 	s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
 	if (check_keyword && keyword(tokenbuf, len))
@@ -3542,7 +3542,7 @@ yylex(void)
 	    if (*s == ';' || *s == ')')		/* probably a close */
 		croak("sort is now a reserved word");
 	    expect = XTERM;
-	    s = force_word(s,WORD,TRUE,TRUE,TRUE);
+	    s = force_word(s,WORD,TRUE,TRUE,FALSE);
 	    LOP(OP_SORT,XREF);
 
 	case KEY_split:
diff --git a/vms/perly_c.vms b/vms/perly_c.vms
index e3c100b45d..7514f16803 100644
--- a/vms/perly_c.vms
+++ b/vms/perly_c.vms
@@ -1770,7 +1770,7 @@ case 56:
 { char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, na);
 			  if (strEQ(name, "BEGIN") || strEQ(name, "END")
 			      || strEQ(name, "INIT"))
-			  { CvUNIQUE_on(compcv); subline = -subline; }
+			      CvUNIQUE_on(compcv);
 			  yyval.opval = yyvsp[0].opval; }
 break;
 case 57:
diff --git a/win32/Makefile b/win32/Makefile
index 91a417da2f..e2d3d446c2 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -52,7 +52,7 @@ RUNTIME  = -MD
 INCLUDES = -I.\include -I. -I..
 #PCHFLAGS = -Fp"$(INTDIR)/modules.pch" -YX 
 DEFINES  = -DWIN32 -D_CONSOLE $(BUILDOPT)
-LOCDEFS  = -DPERLDLL $(CORECCOPT)
+LOCDEFS  = -DPERLDLL -DPERL_CORE $(CORECCOPT)
 SUBSYS   = console
 
 !IF "$(RUNTIME)" == "-MD"
diff --git a/win32/dl_win32.xs b/win32/dl_win32.xs
index 7b227e299c..cf6797e5fe 100644
--- a/win32/dl_win32.xs
+++ b/win32/dl_win32.xs
@@ -28,7 +28,7 @@ calls.
 #include "dlutils.c"	/* SaveError() etc	*/
 
 static void
-dl_private_init()
+dl_private_init(void)
 {
     (void)dl_generic_private_init();
 }
diff --git a/win32/makefile.mk b/win32/makefile.mk
index 03788c731e..7bbf0bb426 100644
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -55,7 +55,7 @@ CCLIBDIR = $(CCHOME)\lib
 CC = bcc32
 LINK32 = tlink32
 LIB32 = tlib
-IMPLIB = implib
+IMPLIB = implib -c
 
 #
 # Options
@@ -64,7 +64,7 @@ RUNTIME  = -D_RTLDLL
 INCLUDES = -I.\include -I. -I.. -I$(CCINCDIR)
 #PCHFLAGS = -H -H$(INTDIR)\bcmoduls.pch 
 DEFINES  = -DWIN32 $(BUILDOPT) 
-LOCDEFS  = -DPERLDLL
+LOCDEFS  = -DPERLDLL -DPERL_CORE
 SUBSYS   = console
 LIBC = cw32mti.lib
 LIBFILES = import32.lib $(LIBC) odbc32.lib odbccp32.lib
@@ -97,7 +97,7 @@ RUNTIME  = -MD
 INCLUDES = -I.\include -I. -I..
 #PCHFLAGS = -Fp$(INTDIR)\vcmoduls.pch -YX 
 DEFINES  = -DWIN32 -D_CONSOLE $(BUILDOPT)
-LOCDEFS  = -DPERLDLL
+LOCDEFS  = -DPERLDLL -DPERL_CORE
 SUBSYS   = console
 
 .IF "$(RUNTIME)" == "-MD"
diff --git a/win32/win32.h b/win32/win32.h
index 2e31d0e3ba..d0dde7e53f 100644
--- a/win32/win32.h
+++ b/win32/win32.h
@@ -151,7 +151,7 @@ typedef  char *		caddr_t;	/* In malloc.c (core address). */
 /* #define PERL_SBRK_VIA_MALLOC	/**/
 #endif
 
-#ifdef PERLDLL
+#if defined(PERLDLL) && !defined(PERL_CORE)
 #define PERL_CORE
 #endif
 
diff --git a/win32/win32iop.h b/win32/win32iop.h
index bd70def18e..533370e99e 100644
--- a/win32/win32iop.h
+++ b/win32/win32iop.h
@@ -220,7 +220,7 @@ END_EXTERN_C
 #define getchar			win32_getchar
 #define putchar			win32_putchar
 
-#if !defined(MYMALLOC) || !defined(PERLDLL)
+#if !defined(MYMALLOC) || !defined(PERL_CORE)
 #undef malloc
 #undef calloc
 #undef realloc
diff --git a/win32/win32thread.h b/win32/win32thread.h
index f8fbd2001a..591184b007 100644
--- a/win32/win32thread.h
+++ b/win32/win32thread.h
@@ -97,6 +97,7 @@ typedef HANDLE perl_mutex;
 	}							\
     } STMT_END
 
+
 #define THREAD_CREATE(t, f)	Perl_thread_create(t, f)
 #define THREAD_POST_CREATE(t)	NOOP
 #define THREAD_RET_TYPE		DWORD WINAPI
@@ -121,6 +122,7 @@ int Perl_thread_create _((struct perl_thread *thr, thread_func_t *fn));
 void Perl_set_thread_self _((struct perl_thread *thr));
 struct perl_thread *Perl_getTHR _((void));
 void Perl_setTHR _((struct perl_thread *t));
+
 END_EXTERN_C
 
 #define INIT_THREADS NOOP