Patches needed to get _60 building with

To: vmsperl@perl.org, perl5-porters@perl.org,
	sarathy@activestate.com, bailey@newman.upenn.edu
	threads on VMS
Message-ID: <Pine.LNX.4.10.9908101631030.18266-100000@tuatha.sidhe.org>

p4raw-id: //depot/cfgperl@3955

diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs
index 2917421..e5b7788 100644 (file)
--- a/ext/Devel/DProf/DProf.xs
+++ b/ext/Devel/DProf/DProf.xs
@@ -35,6 +35,7 @@ static U32 dprof_ticks;
 #  include <starlet.h>  /* prototype for sys$gettim() */
    clock_t dprof_times(struct tms *bufptr) {
         clock_t retval;
+       dTHX;
         /* Get wall time and convert to 10 ms intervals to
          * produce the return value dprof expects */
 #  if defined(__DECC) && defined (__ALPHA)

diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs
index d83d532..1024c41 100644 (file)
--- a/ext/DynaLoader/dl_vms.xs
+++ b/ext/DynaLoader/dl_vms.xs
@@ -112,6 +112,7 @@ dl_set_error(sts,stv)
     vmssts  stv;
 {
     vmssts vec[3];
+    dTHX;
 
     vec[0] = stv ? 2 : 1;
     vec[1] = sts;  vec[2] = stv;
@@ -121,6 +122,7 @@ dl_set_error(sts,stv)
 static unsigned int
 findsym_handler(void *sig, void *mech)
 {
+    dTHX;
     unsigned long int myvec[8],args, *usig = (unsigned long int *) sig;
     /* Be paranoid and assume signal vector passed in might be readonly */
     myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1;

diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 9cca0e3..cc3f0c1 100644 (file)
--- a/ext/POSIX/POSIX.xs
+++ b/ext/POSIX/POSIX.xs
@@ -81,6 +81,7 @@
    /* The non-POSIX CRTL times() has void return type, so we just get the
       current time directly */
    clock_t vms_times(struct tms *PL_bufptr) {
+       dTHX;
        clock_t retval;
        /* Get wall time and convert to 10 ms intervals to
         * produce the return value that the POSIX standard expects */

diff --git a/pp.c b/pp.c
index 8a0f0f7..3cc9759 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -28,37 +28,6 @@ static double UV_MAX_cxux = ((double)UV_MAX);
 #endif
 
 /*
- * Types used in bitwise operations.
- *
- * Normally we'd just use IV and UV.  However, some hardware and
- * software combinations (e.g. Alpha and current OSF/1) don't have a
- * floating-point type to use for NV that has adequate bits to fully
- * hold an IV/UV.  (In other words, sizeof(long) == sizeof(double).)
- *
- * It just so happens that "int" is the right size almost everywhere.
- */
-typedef int IBW;
-typedef unsigned UBW;
-
-/*
- * Mask used after bitwise operations.
- *
- * There is at least one realm (Cray word machines) that doesn't
- * have an integral type (except char) small enough to be represented
- * in a double without loss; that is, it has no 32-bit type.
- */
-#if LONGSIZE > 4  && defined(_CRAY) && !defined(_CRAYMPP)
-#  define BW_BITS  32
-#  define BW_MASK  ((1 << BW_BITS) - 1)
-#  define BW_SIGN  (1 << (BW_BITS - 1))
-#  define BWi(i)  (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
-#  define BWu(u)  ((u) & BW_MASK)
-#else
-#  define BWi(i)  (i)
-#  define BWu(u)  (u)
-#endif
-
-/*
  * Offset for integer pack/unpack.
  *
  * On architectures where I16 and I32 aren't really 16 and 32 bits,
@@ -931,6 +900,7 @@ PP(pp_pow)
 PP(pp_multiply)
 {
     djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+    tryIVIVbin(*);
     {
       dPOPTOPnnrl;
       SETn( left * right );
@@ -941,6 +911,16 @@ PP(pp_multiply)
 PP(pp_divide)
 {
     djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+    if (TOPIOKbin) {
+      dPOPTOPiirl_ul;
+      if (right == 0)
+       DIE(aTHX_ "Illegal division by zero");
+      if ((left % right) && !(PL_op->op_private & HINT_INTEGER))
+       SETn( (NV)left / (NV)right );
+      else
+       SETi( left / right );
+      RETURN;
+    }
     {
       dPOPPOPnnrl;
       NV value;
@@ -1120,6 +1100,7 @@ PP(pp_repeat)
 PP(pp_subtract)
 {
     djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+    tryIVIVbin(-);
     {
       dPOPTOPnnrl_ul;
       SETn( left - right );
@@ -1131,16 +1112,14 @@ PP(pp_left_shift)
 {
     djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
     {
-      IBW shift = POPi;
+      IV shift = POPi;
       if (PL_op->op_private & HINT_INTEGER) {
-       IBW i = TOPi;
-       i = BWi(i) << shift;
-       SETi(BWi(i));
+       IV i = TOPi;
+       SETi(i << shift);
       }
       else {
-       UBW u = TOPu;
-       u <<= shift;
-       SETu(BWu(u));
+       UV u = TOPu;
+       SETu(u << shift);
       }
       RETURN;
     }
@@ -1150,16 +1129,14 @@ PP(pp_right_shift)
 {
     djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
     {
-      IBW shift = POPi;
+      IV shift = POPi;
       if (PL_op->op_private & HINT_INTEGER) {
-       IBW i = TOPi;
-       i = BWi(i) >> shift;
-       SETi(BWi(i));
+       IV i = TOPi;
+       SETi(i >> shift);
       }
       else {
-       UBW u = TOPu;
-       u >>= shift;
-       SETu(BWu(u));
+       UV u = TOPu;
+       SETu(u >> shift);
       }
       RETURN;
     }
@@ -1329,12 +1306,12 @@ PP(pp_bit_and)
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
-         IBW value = SvIV(left) & SvIV(right);
-         SETi(BWi(value));
+         IV value = SvIV(left) & SvIV(right);
+         SETi(value);
        }
        else {
-         UBW value = SvUV(left) & SvUV(right);
-         SETu(BWu(value));
+         UV value = SvUV(left) & SvUV(right);
+         SETu(value);
        }
       }
       else {
@@ -1352,12 +1329,12 @@ PP(pp_bit_xor)
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
-         IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
-         SETi(BWi(value));
+         IV value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+         SETi(value);
        }
        else {
-         UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
-         SETu(BWu(value));
+         UV value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+         SETu(value);
        }
       }
       else {
@@ -1375,12 +1352,12 @@ PP(pp_bit_or)
       dPOPTOPssrl;
       if (SvNIOKp(left) || SvNIOKp(right)) {
        if (PL_op->op_private & HINT_INTEGER) {
-         IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
-         SETi(BWi(value));
+         IV value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+         SETi(value);
        }
        else {
-         UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
-         SETu(BWu(value));
+         UV value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+         SETu(value);
        }
       }
       else {
@@ -1441,12 +1418,12 @@ PP(pp_complement)
       dTOPss;
       if (SvNIOKp(sv)) {
        if (PL_op->op_private & HINT_INTEGER) {
-         IBW value = ~SvIV(sv);
-         SETi(BWi(value));
+         IV value = ~SvIV(sv);
+         SETi(value);
        }
        else {
-         UBW value = ~SvUV(sv);
-         SETu(BWu(value));
+         UV value = ~SvUV(sv);
+         SETu(value);
        }
       }
       else {

diff --git a/pp.h b/pp.h
index 0eac5a5..adf3cc9 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -143,6 +143,18 @@
 #define dPOPTOPiirl    dPOPXiirl(TOP)
 #define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
 
+#define TOPIOKbin (SvIOK(TOPs) && SvIOK(*(sp-1)))
+#define tryIVIVbin(op) \
+       if (TOPIOKbin) { \
+               dPOPTOPiirl_ul; \
+               NV result = (NV)left op (NV)right; \
+               if (result >= (NV)IV_MIN && result <= (NV)IV_MAX) \
+                       SETi( left op right ); \
+               else \
+                       SETn( result ); \
+               RETURN; \
+       }
+
 #define RETPUSHYES     RETURNX(PUSHs(&PL_sv_yes))
 #define RETPUSHNO      RETURNX(PUSHs(&PL_sv_no))
 #define RETPUSHUNDEF   RETURNX(PUSHs(&PL_sv_undef))

diff --git a/pp_hot.c b/pp_hot.c
index 78f07a1..a7ce618 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -248,6 +248,7 @@ PP(pp_or)
 PP(pp_add)
 {
     djSP; dATARGET; tryAMAGICbin(add,opASSIGN); 
+    tryIVIVbin(+);
     {
       dPOPTOPnnrl_ul;
       SETn( left + right );

diff --git a/vms/vms.c b/vms/vms.c
index 031f1c6..0845ff9 100644 (file)
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -109,7 +109,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
 #if defined(USE_THREADS)
     /* We jump through these hoops because we can be called at */
     /* platform-specific initialization time, which is before anything is */
-    /* set up--we can't even do a plain dTHR since that relies on the */
+    /* set up--we can't even do a plain dTHX since that relies on the */
     /* interpreter structure to be initialized */
     struct perl_thread *thr;
     if (PL_curinterp) {
@@ -142,7 +142,7 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
           int i;
           if (!environ) {
             ivenv = 1; 
-            warn("Can't read CRTL environ\n");
+            Perl_warn(aTHX_ "Can't read CRTL environ\n");
             continue;
           }
           retsts = SS$_NOLOGNAM;
@@ -179,11 +179,11 @@ vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
              if (thr && PL_curcop) {
 #endif
                if (ckWARN(WARN_MISC)) {
-                 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+                 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
                }
 #if defined(USE_THREADS)
              } else {
-                 warner(WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
+                 Perl_warner(aTHX_ WARN_MISC,"Value of CLI symbol \"%s\" too long",lnm);
              }
 #endif
              
@@ -238,7 +238,7 @@ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)
  */
 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
 char *
-my_getenv(const char *lnm, bool sys)
+Perl_my_getenv(pTHX_ const char *lnm, bool sys)
 {
     static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
     char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
@@ -285,6 +285,7 @@ my_getenv(const char *lnm, bool sys)
 char *
 my_getenv_len(const char *lnm, unsigned long *len, bool sys)
 {
+    dTHX;
     char *buf, *cp1, *cp2;
     unsigned long idx = 0;
     static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
@@ -338,7 +339,7 @@ prime_env_iter(void)
  * find, in preparation for iterating over it.
  */
 {
-  dTHR;
+  dTHX;
   static int primed = 0;
   HV *seenhv = NULL, *envhv;
   char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
@@ -387,7 +388,7 @@ prime_env_iter(void)
       for (j = 0; environ[j]; j++) { 
         if (!(start = strchr(environ[j],'='))) {
           if (ckWARN(WARN_INTERNAL)) 
-            warner(WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
+            Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
         }
         else {
           start++;
@@ -451,12 +452,12 @@ prime_env_iter(void)
       buf[retlen] = '\0';
       if (iosb[1] != subpid) {
         if (iosb[1]) {
-          croak("Unknown process %x sent message to prime_env_iter: %s",buf);
+          Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
         }
         continue;
       }
       if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
-        warner(WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
+        Perl_warner(aTHX_ WARN_INTERNAL,"Buffer overflow in prime_env_iter: %s",buf);
 
       for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
       if (*cp1 == '(' || /* Logical name table name */
@@ -477,7 +478,7 @@ prime_env_iter(void)
         cp1--;  /* stop on last non-space char */
       }
       if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
-        warner(WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
+        Perl_warner(aTHX_ WARN_INTERNAL,"Ill-formed message in prime_env_iter: |%s|",buf);
         continue;
       }
       PERL_HASH(hash,key,keylen);
@@ -524,6 +525,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
                             tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
     $DESCRIPTOR(crtlenv,"CRTL_ENV");  $DESCRIPTOR(clisym,"CLISYM");
     $DESCRIPTOR(local,"_LOCAL");
+    dTHX;
 
     for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
       *cp2 = _toupper(*cp1);
@@ -549,7 +551,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
           ivenv = 1; retsts = SS$_NOLOGNAM;
 #else
               if (ckWARN(WARN_INTERNAL))
-                warner(WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
+                Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't reset CRTL environ elements (%s)",lnm);
               ivenv = 1; retsts = SS$_NOSUCHPGM;
               break;
             }
@@ -584,7 +586,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
         return setenv(lnm,eqv,1) ? vaxc$errno : 0;
 #else
         if (ckWARN(WARN_INTERNAL))
-          warner(WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
+          Perl_warner(aTHX_ WARN_INTERNAL,"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
         retsts = SS$_NOSUCHPGM;
 #endif
       }
@@ -643,7 +645,7 @@ vmssetenv(char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
 /*{{{ void  my_setenv(char *lnm, char *eqv)*/
 /* This has to be a function since there's a prototype for it in proto.h */
 void
-my_setenv(char *lnm,char *eqv)
+Perl_my_setenv(pTHX_ char *lnm,char *eqv)
 {
   if (lnm && *lnm && strlen(lnm) == 7) {
     char uplnm[8];
@@ -757,6 +759,7 @@ kill_file(char *name)
     char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
     unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
     unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
+    dTHX;
     struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
     struct myacedef {
       unsigned char myace$b_length;
@@ -858,6 +861,7 @@ int
 my_mkdir(char *dir, Mode_t mode)
 {
   STRLEN dirlen = strlen(dir);
+  dTHX;
 
   /* CRTL mkdir() doesn't tolerate trailing /, since that implies
    * null file name/type.  However, it's commonplace under Unix,
@@ -879,6 +883,7 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
 {
   static unsigned long int mbxbufsiz;
   long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
+  dTHX;
   
   if (!mbxbufsiz) {
     /*
@@ -929,6 +934,7 @@ pipe_eof(FILE *fp, int immediate)
   char devnam[NAM$C_MAXRSS+1], *cp;
   unsigned long int chan, iosb[2], retsts, retsts2;
   struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
+  dTHX;
 
   if (fgetname(fp,devnam,1)) {
     /* It oughta be a mailbox, so fgetname should give just the device
@@ -954,6 +960,7 @@ pipe_exit_routine()
     struct pipe_details *info;
     unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
     int sts, did_stuff;
+    dTHX;
 
     /* 
      first we try sending an EOF...ignore if doesn't work, make sure we
@@ -1021,6 +1028,7 @@ safe_popen(char *cmd, char *mode)
     char mbxname[64];
     unsigned short int chan;
     unsigned long int flags=1;  /* nowait - gnu c doesn't allow &1 */
+    dTHX;
     struct pipe_details *info;
     struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
                                       DSC$K_CLASS_S, mbxname},
@@ -1078,7 +1086,7 @@ safe_popen(char *cmd, char *mode)
 
 /*{{{  FILE *my_popen(char *cmd, char *mode)*/
 FILE *
-my_popen(char *cmd, char *mode)
+Perl_my_popen(pTHX_ char *cmd, char *mode)
 {
     TAINT_ENV();
     TAINT_PROPER("popen");
@@ -1089,7 +1097,7 @@ my_popen(char *cmd, char *mode)
 /*}}}*/
 
 /*{{{  I32 my_pclose(FILE *fp)*/
-I32 my_pclose(FILE *fp)
+I32 Perl_my_pclose(pTHX_ FILE *fp)
 {
     struct pipe_details *info, *last = NULL;
     unsigned long int retsts;
@@ -1127,7 +1135,7 @@ Pid_t
 my_waitpid(Pid_t pid, int *statusp, int flags)
 {
     struct pipe_details *info;
-    dTHR;
+    dTHX;
     
     for (info = open_pipes; info != NULL; info = info->next)
         if (info->pid == pid) break;
@@ -1150,7 +1158,7 @@ my_waitpid(Pid_t pid, int *statusp, int flags)
         _ckvmssts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
         _ckvmssts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
         if (ownerpid != mypid)
-          warner(WARN_EXEC,"pid %x not a child",pid);
+          Perl_warner(aTHX_ WARN_EXEC,"pid %x not a child",pid);
       }
 
       _ckvmssts(sys$bintim(&intdsc,interval));
@@ -2746,6 +2754,7 @@ vms_image_init(int *argcp, char ***argvp)
   unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
   unsigned short int dummy, rlen;
   struct dsc$descriptor_s **tabvec;
+  dTHX;
   struct itmlst_3 jpilist[4] = { {sizeof iprv,    JPI$_IMAGPRIV, iprv, &dummy},
                                  {sizeof rlst,  JPI$_RIGHTSLIST, rlst,  &rlen},
                                  { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
@@ -3093,6 +3102,7 @@ collectversions(dd)
     char *p, *text, buff[sizeof dd->entry.d_name];
     int i;
     unsigned long context, tmpsts;
+    dTHX;
 
     /* Convenient shorthand. */
     e = &dd->entry;
@@ -3208,6 +3218,7 @@ void
 seekdir(DIR *dd, long count)
 {
     int vms_wantversions;
+    dTHX;
 
     /* If we haven't done anything yet... */
     if (dd->count == 0)
@@ -3288,7 +3299,7 @@ vms_execfree() {
 static char *
 setup_argstr(SV *really, SV **mark, SV **sp)
 {
-  dTHR;
+  dTHX;
   char *junk, *tmps = Nullch;
   register size_t cmdlen = 0;
   size_t rlen;
@@ -3340,6 +3351,7 @@ setup_cmddsc(char *cmd, int check_img)
   unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
   register char *s, *rest, *cp;
   register int isdcl = 0;
+  dTHX;
 
   s = cmd;
   while (*s && isspace(*s)) s++;
@@ -3402,12 +3414,12 @@ setup_cmddsc(char *cmd, int check_img)
 bool
 vms_do_aexec(SV *really,SV **mark,SV **sp)
 {
-  dTHR;
+  dTHX;
   if (sp > mark) {
     if (vfork_called) {           /* this follows a vfork - act Unixish */
       vfork_called--;
       if (vfork_called < 0) {
-        warn("Internal inconsistency in tracking vforks");
+        Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
         vfork_called = 0;
       }
       else return do_aexec(really,mark,sp);
@@ -3426,11 +3438,11 @@ bool
 vms_do_exec(char *cmd)
 {
 
-  dTHR;
+  dTHX;
   if (vfork_called) {             /* this follows a vfork - act Unixish */
     vfork_called--;
     if (vfork_called < 0) {
-      warn("Internal inconsistency in tracking vforks");
+      Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
       vfork_called = 0;
     }
     else return do_exec(cmd);
@@ -3462,7 +3474,7 @@ vms_do_exec(char *cmd)
     }
     set_vaxc_errno(retsts);
     if (ckWARN(WARN_EXEC)) {
-      warner(WARN_EXEC,"Can't exec \"%*s\": %s",
+      Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
              VMScmd.dsc$w_length, VMScmd.dsc$a_pointer, Strerror(errno));
     }
     vms_execfree();
@@ -3479,7 +3491,7 @@ unsigned long int do_spawn(char *);
 unsigned long int
 do_aspawn(void *really,void **mark,void **sp)
 {
-  dTHR;
+  dTHX;
   if (sp > mark) return do_spawn(setup_argstr((SV *)really,(SV **)mark,(SV **)sp));
 
   return SS$_ABORT;
@@ -3491,7 +3503,7 @@ unsigned long int
 do_spawn(char *cmd)
 {
   unsigned long int sts, substs, hadcmd = 1;
-  dTHR;
+  dTHX;
 
   TAINT_ENV();
   TAINT_PROPER("spawn");
@@ -3522,7 +3534,7 @@ do_spawn(char *cmd)
     }
     set_vaxc_errno(sts);
     if (ckWARN(WARN_EXEC)) {
-      warner(WARN_EXEC,"Can't spawn \"%*s\": %s",
+      Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%*s\": %s",
              hadcmd ? VMScmd.dsc$w_length :  0,
              hadcmd ? VMScmd.dsc$a_pointer : "",
              Strerror(errno));
@@ -3637,6 +3649,7 @@ static char __pw_namecache[UAI$S_IDENT+1];
  */
 static int fillpasswd (const char *name, struct passwd *pwd)
 {
+    dTHX;
     static struct {
         unsigned char length;
         char pw_gecos[UAI$S_OWNER+1];
@@ -3695,7 +3708,7 @@ static int fillpasswd (const char *name, struct passwd *pwd)
         pwd->pw_gid= uic.uic$v_group;
     }
     else
-      warn("getpwnam returned invalid UIC %#o for user \"%s\"");
+      Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
     pwd->pw_passwd=  pw_passwd;
     pwd->pw_gecos=   owner.pw_gecos;
     pwd->pw_dir=     defdev.pw_dir;
@@ -3721,6 +3734,7 @@ struct passwd *my_getpwnam(char *name)
     struct dsc$descriptor_s name_desc;
     union uicdef uic;
     unsigned long int status, sts;
+    dTHX;
                                   
     __pwdcache = __passwd_empty;
     if (!fillpasswd(name, &__pwdcache)) {
@@ -3760,6 +3774,7 @@ struct passwd *my_getpwuid(Uid_t uid)
     unsigned short lname;
     union uicdef uic;
     unsigned long int status;
+    dTHX;
 
     if (uid == (unsigned int) -1) {
       do {
@@ -3821,6 +3836,7 @@ struct passwd *my_getpwent()
 /*{{{void my_endpwent()*/
 void my_endpwent()
 {
+    dTHX;
     if (contxt) {
       _ckvmssts(sys$finish_rdb(&contxt));
       contxt= 0;
@@ -3990,7 +4006,7 @@ static time_t toloc_dst(time_t utc) {
 /*{{{time_t my_time(time_t *timep)*/
 time_t my_time(time_t *timep)
 {
-  dTHR;
+  dTHX;
   time_t when;
   struct tm *tm_p;
 
@@ -4007,7 +4023,7 @@ time_t my_time(time_t *timep)
       gmtime_emulation_type++;
       if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
         gmtime_emulation_type++;
-        warn("no UTC offset information; assuming local time is UTC");
+        Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
       }
       else { utc_offset_secs = atol(off); }
     }
@@ -4043,7 +4059,7 @@ time_t my_time(time_t *timep)
 struct tm *
 my_gmtime(const time_t *timep)
 {
-  dTHR;
+  dTHX;
   char *p;
   time_t when;
   struct tm *rsltmp;
@@ -4074,7 +4090,7 @@ my_gmtime(const time_t *timep)
 struct tm *
 my_localtime(const time_t *timep)
 {
-  dTHR;
+  dTHX;
   time_t when;
   struct tm *rsltmp;
 
@@ -4131,7 +4147,7 @@ static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
 int my_utime(char *file, struct utimbuf *utimes)
 {
-  dTHR;
+  dTHX;
   register int i;
   long int bintime[2], len = 2, lowbit, unixtime,
            secscale = 10000000; /* seconds --> 100 ns intervals */
@@ -4315,6 +4331,7 @@ static mydev_t encode_dev (const char *dev)
   mydev_t enc;
   char c;
   const char *q;
+  dTHX;
 
   if (!dev || !dev[0]) return 0;
 
@@ -4360,6 +4377,7 @@ static int
 is_null_device(name)
     const char *name;
 {
+    dTHX;
     /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
        The underscore prefix, controller letter, and unit number are
        independently optional; for our purposes, the colon punctuation
@@ -4380,9 +4398,8 @@ is_null_device(name)
  */
 /*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
 I32
-cando(I32 bit, I32 effective, Stat_t *statbufp)
+Perl_cando(pTHX_ I32 bit, I32 effective, Stat_t *statbufp)
 {
-  dTHR;
   if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
   else {
     char fname[NAM$C_MAXRSS+1];
@@ -4404,7 +4421,7 @@ cando(I32 bit, I32 effective, Stat_t *statbufp)
       return cando_by_name(bit,effective,fname);
     }
     else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
-      warn("Can't get filespec - stale stat buffer?\n");
+      Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
       return FALSE;
     }
     _ckvmssts(retsts);
@@ -4424,6 +4441,7 @@ cando_by_name(I32 bit, I32 effective, char *fname)
   char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
   unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
   unsigned short int retlen;
+  dTHX;
   struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
   union prvdef curprv;
   struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
@@ -4516,7 +4534,7 @@ cando_by_name(I32 bit, I32 effective, char *fname)
 int
 flex_fstat(int fd, Stat_t *statbufp)
 {
-  dTHR;
+  dTHX;
   if (!fstat(fd,(stat_t *) statbufp)) {
     if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
     statbufp->st_dev = encode_dev(statbufp->st_devnam);
@@ -4550,7 +4568,7 @@ flex_fstat(int fd, Stat_t *statbufp)
 int
 flex_stat(const char *fspec, Stat_t *statbufp)
 {
-    dTHR;
+    dTHX;
     char fileified[NAM$C_MAXRSS+1];
     char temp_fspec[NAM$C_MAXRSS+300];
     int retval = -1;
@@ -4819,14 +4837,14 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
  */
 
 void
-rmsexpand_fromperl(CV *cv)
+rmsexpand_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *fspec, *defspec = NULL, *rslt;
   STRLEN n_a;
 
   if (!items || items > 2)
-    croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+    Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
   fspec = SvPV(ST(0),n_a);
   if (!fspec || !*fspec) XSRETURN_UNDEF;
   if (items == 2) defspec = SvPV(ST(1),n_a);
@@ -4838,13 +4856,13 @@ rmsexpand_fromperl(CV *cv)
 }
 
 void
-vmsify_fromperl(CV *cv)
+vmsify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *vmsified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::vmsify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
   vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
@@ -4852,13 +4870,13 @@ vmsify_fromperl(CV *cv)
 }
 
 void
-unixify_fromperl(CV *cv)
+unixify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *unixified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::unixify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
   unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
@@ -4866,13 +4884,13 @@ unixify_fromperl(CV *cv)
 }
 
 void
-fileify_fromperl(CV *cv)
+fileify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *fileified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::fileify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
   fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
@@ -4880,13 +4898,13 @@ fileify_fromperl(CV *cv)
 }
 
 void
-pathify_fromperl(CV *cv)
+pathify_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *pathified;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::pathify(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
   pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
@@ -4894,13 +4912,13 @@ pathify_fromperl(CV *cv)
 }
 
 void
-vmspath_fromperl(CV *cv)
+vmspath_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *vmspath;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::vmspath(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
   vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
@@ -4908,13 +4926,13 @@ vmspath_fromperl(CV *cv)
 }
 
 void
-unixpath_fromperl(CV *cv)
+unixpath_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char *unixpath;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::unixpath(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
   unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
   ST(0) = sv_newmortal();
   if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
@@ -4922,7 +4940,7 @@ unixpath_fromperl(CV *cv)
 }
 
 void
-candelete_fromperl(CV *cv)
+candelete_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char fspec[NAM$C_MAXRSS+1], *fsp;
@@ -4930,7 +4948,7 @@ candelete_fromperl(CV *cv)
   IO *io;
   STRLEN n_a;
 
-  if (items != 1) croak("Usage: VMS::Filespec::candelete(spec)");
+  if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
 
   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
   if (SvTYPE(mysv) == SVt_PVGV) {
@@ -4954,7 +4972,7 @@ candelete_fromperl(CV *cv)
 }
 
 void
-rmscopy_fromperl(CV *cv)
+rmscopy_fromperl(pTHX_ CV *cv)
 {
   dXSARGS;
   char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
@@ -4967,7 +4985,7 @@ rmscopy_fromperl(CV *cv)
   STRLEN n_a;
 
   if (items < 2 || items > 3)
-    croak("Usage: File::Copy::rmscopy(from,to[,date_flag])");
+    Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
 
   mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
   if (SvTYPE(mysv) == SVt_PVGV) {
@@ -5011,6 +5029,7 @@ void
 init_os_extras()
 {
   char* file = __FILE__;
+  dTHX;
 
   newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
   newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");

diff --git a/vms/vmsish.h b/vms/vmsish.h
index 709e34e..1f7e2c9 100644 (file)
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -93,11 +93,16 @@
 /* Our own contribution to PerlShr's global symbols . . . */
 #define vmstrnenv              Perl_vmstrnenv
 #define my_trnlnm              Perl_my_trnlnm
-#define my_getenv              Perl_my_getenv
 #define my_getenv_len          Perl_my_getenv_len
 #define prime_env_iter Perl_prime_env_iter
 #define vmssetenv              Perl_vmssetenv
+#if !defined(PERL_IMPLICIT_CONTEXT)
 #define my_setenv              Perl_my_setenv
+#define my_getenv              Perl_my_getenv
+#else
+#define my_setenv(a,b)         Perl_my_setenv(aTHX_ a,b)
+#define my_getenv(a,b)         Perl_my_getenv(aTHX_ a,b)
+#endif
 #define my_crypt               Perl_my_crypt
 #define my_waitpid             Perl_my_waitpid
 #define my_gconvert            Perl_my_gconvert
@@ -225,7 +230,7 @@
 #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \
   if (!((__ckvms_sts=(call))&1)) { \
   set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
-  croak("Fatal VMS error (status=%d) at %s, line %d", \
+  Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d", \
   __ckvms_sts,__FILE__,__LINE__); } } STMT_END
 
 /* Same thing, but don't call back to Perl's croak(); useful for errors
@@ -584,7 +589,11 @@ void       init_os_extras ();
 typedef char  __VMS_PROTOTYPES__;
 int    vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int);
 int    my_trnlnm (const char *, char *, unsigned long int);
-char * my_getenv (const char *, bool);
+#if !defined(PERL_IMPLICIT_CONTEXT)
+char * Perl_my_getenv (const char *, bool);
+#else
+char * Perl_my_getenv (pTHX_ const char *, bool);
+#endif
 char * my_getenv_len (const char *, unsigned long *, bool);
 int    vmssetenv (char *, char *, struct dsc$descriptor_s **);
 char * my_crypt (const char *, const char *);

diff --git a/vms/writemain.pl b/vms/writemain.pl
index b08bf1d..1843b30 100644 (file)
--- a/vms/writemain.pl
+++ b/vms/writemain.pl
@@ -34,7 +34,7 @@ if (!$ok) {
 print OUT <<'EOH';
 
 static void
-xs_init()
+xs_init(pTHX)
 {
 EOH
 
@@ -50,7 +50,7 @@ if (@exts) {
   foreach $ext (@exts) {
     my($subname) = $ext;
     $subname =~ s/::/__/g;
-    print OUT "extern void     boot_${subname} (CV* cv);\n"
+    print OUT "extern void     boot_${subname} (pTHX_ CV* cv);\n"
   }
   # May not actually be a declaration, so put after other declarations
   print OUT "  dXSUB_SYS;\n";