part of the platform changes for IMPLICIT_CONTEXT

p4raw-id: //depot/perl@3531

diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c
index 07eb80e..ae03f21 100644 (file)
--- a/djgpp/djgpp.c
+++ b/djgpp/djgpp.c
@@ -117,10 +117,10 @@ pclose (FILE *pp)
 #define EXECF_EXEC 1
 
 static int
-convretcode (int rc,char *prog,int fl)
+convretcode (pTHX_ int rc,char *prog,int fl)
 {
     if (rc < 0 && PL_dowarn)
-        warn ("Can't %s \"%s\": %s",fl ? "exec" : "spawn",prog,Strerror (errno));
+        Perl_warn (aTHX_ "Can't %s \"%s\": %s",fl ? "exec" : "spawn",prog,Strerror (errno));
     if (rc > 0)
         return rc <<= 8;
     if (rc < 0)
@@ -129,7 +129,7 @@ convretcode (int rc,char *prog,int fl)
 }
 
 int
-do_aspawn (SV *really,SV **mark,SV **sp)
+do_aspawn (pTHX_ SV *really,SV **mark,SV **sp)
 {
     dTHR;
     int  rc;
@@ -164,7 +164,7 @@ do_aspawn (SV *really,SV **mark,SV **sp)
 #define EXTRA "\x00\x00\x00\x00\x00\x00"
 
 int
-do_spawn2 (char *cmd,int execf)
+do_spawn2 (pTHX_ char *cmd,int execf)
 {
     char **a,*s,*shell,*metachars;
     int  rc,unixysh;
@@ -232,15 +232,15 @@ doshell:
 }
 
 int
-do_spawn (char *cmd)
+do_spawn (pTHX_ char *cmd)
 {
-    return do_spawn2 (cmd,EXECF_SPAWN);
+    return do_spawn2 (aTHX_ cmd,EXECF_SPAWN);
 }
 
 bool
-do_exec (char *cmd)
+Perl_do_exec (pTHX_ char *cmd)
 {
-    do_spawn2 (cmd,EXECF_EXEC);
+    do_spawn2 (aTHX_ cmd,EXECF_EXEC);
     return FALSE;
 }
 
@@ -361,7 +361,7 @@ XS(dos_GetCwd)
     dXSARGS;
 
     if (items)
-        croak ("Usage: Dos::GetCwd()");
+        Perl_croak (aTHX_ "Usage: Dos::GetCwd()");
     {
         char tmp[PATH_MAX+2];
         ST(0)=sv_newmortal ();
@@ -379,7 +379,7 @@ XS(dos_UseLFN)
 }
 
 void
-init_os_extras()
+Perl_init_os_extras(pTHX)
 {
     char *file = __FILE__;
 

diff --git a/jpl/JNI/JNI.xs b/jpl/JNI/JNI.xs
index 8a3015a..678e81c 100644 (file)
--- a/jpl/JNI/JNI.xs
+++ b/jpl/JNI/JNI.xs
@@ -20,11 +20,12 @@ extern int jpldebug;
 static void
 call_my_exit(jint status)
 {
+    dTHX;
     my_exit(status);
 }
 
 jvalue*
-makeargs(char *sig, SV** svp, int items)
+makeargs(pTHX_ char *sig, SV** svp, int items)
 {
     jvalue* jv = (jvalue*)safemalloc(sizeof(jvalue) * items);
     int ix = 0;
@@ -399,16 +400,16 @@ makeargs(char *sig, SV** svp, int items)
            }
            break;
        case ')':
-           croak("too many arguments, signature: %s", sig);
+           Perl_croak(aTHX_ "too many arguments, signature: %s", sig);
            goto cleanup;
        default:
-           croak("panic: malformed signature: %s", s-1);
+           Perl_croak(aTHX_ "panic: malformed signature: %s", s-1);
            goto cleanup;
        }
 
     }
     if (*s != ')') {
-       croak("not enough arguments, signature: %s", sig);
+       Perl_croak(aTHX_ "not enough arguments, signature: %s", sig);
        goto cleanup;
     }
     return jv;
@@ -419,9 +420,9 @@ cleanup:
 }
 
 static int
-not_here(char *s)
+not_here(pTHX_ char *s)
 {
-    croak("%s not implemented on this architecture", s);
+    Perl_croak(aTHX_ "%s not implemented on this architecture", s);
     return -1;
 }
 
@@ -739,7 +740,7 @@ NewObject(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->NewObjectA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -809,7 +810,7 @@ CallObjectMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -840,7 +841,7 @@ CallBooleanMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -871,7 +872,7 @@ CallByteMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -902,7 +903,7 @@ CallCharMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -933,7 +934,7 @@ CallShortMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -964,7 +965,7 @@ CallIntMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -995,7 +996,7 @@ CallLongMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -1026,7 +1027,7 @@ CallFloatMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -1057,7 +1058,7 @@ CallDoubleMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -1088,7 +1089,7 @@ CallVoidMethod(obj,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            (*env)->CallVoidMethodA(env, obj,methodID,args);
            RESTOREENV;
        }
@@ -1116,7 +1117,7 @@ CallNonvirtualObjectMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1149,7 +1150,7 @@ CallNonvirtualBooleanMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1182,7 +1183,7 @@ CallNonvirtualByteMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1215,7 +1216,7 @@ CallNonvirtualCharMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1248,7 +1249,7 @@ CallNonvirtualShortMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1281,7 +1282,7 @@ CallNonvirtualIntMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1314,7 +1315,7 @@ CallNonvirtualLongMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1347,7 +1348,7 @@ CallNonvirtualFloatMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1380,7 +1381,7 @@ CallNonvirtualDoubleMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1413,7 +1414,7 @@ CallNonvirtualVoidMethod(obj,clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args);
            RESTOREENV;
        }
@@ -1712,7 +1713,7 @@ CallStaticObjectMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1743,7 +1744,7 @@ CallStaticBooleanMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1774,7 +1775,7 @@ CallStaticByteMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1805,7 +1806,7 @@ CallStaticCharMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1836,7 +1837,7 @@ CallStaticShortMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1867,7 +1868,7 @@ CallStaticIntMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1898,7 +1899,7 @@ CallStaticLongMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1929,7 +1930,7 @@ CallStaticFloatMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1960,7 +1961,7 @@ CallStaticDoubleMethod(clazz,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args);
            RESTOREENV;
        }
@@ -1991,7 +1992,7 @@ CallStaticVoidMethod(cls,methodID,...)
        int                     argoff = $min_args;
     CODE:
        {
-           jvalue * args = makeargs(sig, &ST(argoff), items - argoff);
+           jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff);
            (*env)->CallStaticVoidMethodA(env, cls,methodID,args);
            RESTOREENV;
        }
@@ -2884,9 +2885,9 @@ SetBooleanArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetBooleanArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -2903,9 +2904,9 @@ SetByteArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetByteArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -2922,9 +2923,9 @@ SetCharArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetCharArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -2941,9 +2942,9 @@ SetShortArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetShortArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -2960,9 +2961,9 @@ SetIntArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetIntArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -2979,9 +2980,9 @@ SetLongArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetLongArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -2998,9 +2999,9 @@ SetFloatArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetFloatArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -3017,9 +3018,9 @@ SetDoubleArrayRegion(array,start,len,buf)
     CODE:
        {
            if (buf_len_ < len)
-               croak("string is too short");
+               Perl_croak(aTHX_ "string is too short");
            else if (buf_len_ > len && PL_dowarn)
-               warn("string is too long");
+               Perl_warn(aTHX_ "string is too long");
            (*env)->SetDoubleArrayRegion(env, array,start,len,buf);
            RESTOREENV;
        }
@@ -3092,7 +3093,7 @@ GetJavaVM(...)
 
                if (!dlopen("libjava.so", RTLD_LAZY|RTLD_GLOBAL)) {
                    if (lib && !dlopen(lib, RTLD_LAZY|RTLD_GLOBAL))
-                       croak("Can't load libjava.so");
+                       Perl_croak(aTHX_ "Can't load libjava.so");
                }
 
                JNI_GetDefaultJavaVMInitArgs(&vm_args);
@@ -3127,7 +3128,7 @@ GetJavaVM(...)
                    else if (strEQ(s, "debugPort"))
                        vm_args.debugPort = (jint)SvIV(*++mark);
                    else
-                       croak("unrecognized option: %s", s);
+                       Perl_croak(aTHX_ "unrecognized option: %s", s);
                }
                JNI_CreateJavaVM(&RETVAL, &jplcurenv, &vm_args);
            }

diff --git a/jpl/JNI/typemap b/jpl/JNI/typemap
index 9bd0691..6b97cf4 100644 (file)
--- a/jpl/JNI/typemap
+++ b/jpl/JNI/typemap
@@ -55,13 +55,13 @@ T_JVALUELIST
            AV* av = (AV*)SvRV($arg);
            if (SvTYPE(av) == SVt_PVAV) {
                I32 maxarg = AvFILL(av) + 1;
-               $var = makeargs(sig, AvARRAY(av), maxarg);
+               $var = makeargs(aTHX_ sig, AvARRAY(av), maxarg);
            }
            else
-               croak(\"$var is not an array reference\");
+               Perl_croak(aTHX_ \"$var is not an array reference\");
        }
        else
-           croak(\"$var is not a reference\")
+           Perl_croak(aTHX_ \"$var is not a reference\")
 T_JIDSIG
        {
            $var = ($type)SvIV($arg);
@@ -73,7 +73,7 @@ T_JPTROBJ
            $var = ($type) tmp;
        }
        else
-           croak(\"$var is not of type ${ntype}\")
+           Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 
 OUTPUT
 T_JMEM
@@ -152,22 +152,22 @@ T_JPTROBJ
 #              if (sv_isa($arg, \"${ntype}\"))
 #                  $var = (SV*)SvRV($arg);
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_AVREF
 #              if (sv_isa($arg, \"${ntype}\"))
 #                  $var = (AV*)SvRV($arg);
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_HVREF
 #              if (sv_isa($arg, \"${ntype}\"))
 #                  $var = (HV*)SvRV($arg);
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_CVREF
 #              if (sv_isa($arg, \"${ntype}\"))
 #                  $var = (CV*)SvRV($arg);
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_SYSRET
 #              $var NOT IMPLEMENTED
 #      T_IV
@@ -208,28 +208,28 @@ T_JPTROBJ
 #                  $var = ($type) tmp;
 #              }
 #              else
-#                  croak(\"$var is not a reference\")
+#                  Perl_croak(aTHX_ \"$var is not a reference\")
 #      T_REF_IV_REF
 #              if (sv_isa($arg, \"${type}\")) {
 #                  IV tmp = SvIV((SV*)SvRV($arg));
 #                  $var = *($type *) tmp;
 #              }
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_REF_IV_PTR
 #              if (sv_isa($arg, \"${type}\")) {
 #                  IV tmp = SvIV((SV*)SvRV($arg));
 #                  $var = ($type) tmp;
 #              }
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_PTROBJ
 #              if (sv_derived_from($arg, \"${ntype}\")) {
 #                  IV tmp = SvIV((SV*)SvRV($arg));
 #                  $var = ($type) tmp;
 #              }
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_PTRDESC
 #              if (sv_isa($arg, \"${ntype}\")) {
 #                  IV tmp = SvIV((SV*)SvRV($arg));
@@ -237,21 +237,21 @@ T_JPTROBJ
 #                  $var = ${type}_desc->ptr;
 #              }
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_REFREF
 #              if (SvROK($arg)) {
 #                  IV tmp = SvIV((SV*)SvRV($arg));
 #                  $var = *($type) tmp;
 #              }
 #              else
-#                  croak(\"$var is not a reference\")
+#                  Perl_croak(aTHX_ \"$var is not a reference\")
 #      T_REFOBJ
 #              if (sv_isa($arg, \"${ntype}\")) {
 #                  IV tmp = SvIV((SV*)SvRV($arg));
 #                  $var = *($type) tmp;
 #              }
 #              else
-#                  croak(\"$var is not of type ${ntype}\")
+#                  Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
 #      T_OPAQUE
 #              $var NOT IMPLEMENTED
 #      T_OPAQUEPTR

diff --git a/jpl/PerlInterpreter/PerlInterpreter.c b/jpl/PerlInterpreter/PerlInterpreter.c
index ad85ca2..b229d13 100644 (file)
--- a/jpl/PerlInterpreter/PerlInterpreter.c
+++ b/jpl/PerlInterpreter/PerlInterpreter.c
@@ -16,7 +16,7 @@
 #  endif
 #endif
 
-static void xs_init (void);
+static void xs_init (pTHX);
 static PerlInterpreter *my_perl;
 
 int jpldebug = 0;
@@ -46,8 +46,6 @@ Java_PerlInterpreter_init(JNIEnv *env, jobject obj, jstring js)
     if (PL_curinterp)
        return;
 
-    perl_init_i18nl10n(1);
-
     if (!PL_do_undump) {
        my_perl = perl_alloc();
        if (!my_perl)
@@ -64,20 +62,21 @@ Java_PerlInterpreter_init(JNIEnv *env, jobject obj, jstring js)
 }
 
 JNIEXPORT void JNICALL
-Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js)
+Java_PerlInterpreter_eval(void *perl, JNIEnv *env, jobject obj, jstring js)
 {
     SV* envsv;
     SV* objsv;
     dSP;
     jbyte* jb;
+    dTHXa(perl);
 
     ENTER;
     SAVETMPS;
 
     jplcurenv = env;
-    envsv = perl_get_sv("JPL::_env_", 1);
+    envsv = get_sv("JPL::_env_", 1);
     sv_setiv(envsv, (IV)(void*)env);
-    objsv = perl_get_sv("JPL::_obj_", 1);
+    objsv = get_sv("JPL::_obj_", 1);
     sv_setiv(objsv, (IV)(void*)obj);
 
     jb = (jbyte*)(*env)->GetStringUTFChars(env,js,0);
@@ -85,7 +84,7 @@ Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js)
     if (jpldebug)
        fprintf(stderr, "eval %s\n", (char*)jb);
 
-    perl_eval_pv( (char*)jb, 0 );
+    eval_pv( (char*)jb, 0 );
 
     if (SvTRUE(ERRSV)) {
        jthrowable newExcCls;
@@ -106,10 +105,11 @@ Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js)
 
 /*
 JNIEXPORT jint JNICALL
-Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jint ji)
+Java_PerlInterpreter_eval(void *perl, JNIEnv *env, jobject obj, jint ji)
 {
+    dTHXa(perl);
     op = (OP*)(void*)ji;
-    op = (*op->op_ppaddr)();
+    op = (*op->op_ppaddr)(pTHX);
     return (jint)(void*)op;
 }
 */
@@ -117,11 +117,11 @@ Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jint ji)
 /* Register any extra external extensions */
 
 /* Do not delete this line--writemain depends on it */
-EXTERN_C void boot_DynaLoader (CV* cv);
-EXTERN_C void boot_JNI (CV* cv);
+EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
+EXTERN_C void boot_JNI (pTHX_ CV* cv);
 
 static void
-xs_init()
+xs_init(pTHX)
 {
     char *file = __FILE__;
     dXSUB_SYS;

diff --git a/jpl/PerlInterpreter/PerlInterpreter.h b/jpl/PerlInterpreter/PerlInterpreter.h
index 22fdf52..4927a5f 100644 (file)
--- a/jpl/PerlInterpreter/PerlInterpreter.h
+++ b/jpl/PerlInterpreter/PerlInterpreter.h
@@ -21,7 +21,7 @@ JNIEXPORT void JNICALL Java_PerlInterpreter_init
  * Signature: (Ljava/lang/String;)V
  */
 JNIEXPORT void JNICALL Java_PerlInterpreter_eval
-  (JNIEnv *, jobject, jstring);
+  (void *perl, JNIEnv *, jobject, jstring);
 
 #ifdef __cplusplus
 }

diff --git a/os2/OS2/ExtAttr/ExtAttr.xs b/os2/OS2/ExtAttr/ExtAttr.xs
index 566b659..a69a01c 100644 (file)
--- a/os2/OS2/ExtAttr/ExtAttr.xs
+++ b/os2/OS2/ExtAttr/ExtAttr.xs
@@ -11,14 +11,14 @@ extern "C" {
 #include "myea.h"
 
 SV *
-my_eadvalue(_ead ead, int index)
+my_eadvalue(pTHX_ _ead ead, int index)
 {
     SV *sv;
     int size = _ead_value_size(ead, index);
     void *p;
 
     if (size == -1) {
-       die("Error getting size of EA: %s", strerror(errno));
+       Perl_die(aTHX_ "Error getting size of EA: %s", strerror(errno));
     }
     p = _ead_get_value(ead, index);
     return  newSVpv((char*)p, size);
@@ -37,6 +37,10 @@ SV *
 my_eadvalue(ead, index)
        _ead    ead
        int     index
+    CODE:
+       RETVAL = my_eadvalue(aTHX_ ead, index);
+    OUTPUT:
+       RETVAL
 
 int
 my_eadreplace(ead, index, sv, flag = 0)

diff --git a/os2/OS2/PrfDB/PrfDB.xs b/os2/OS2/PrfDB/PrfDB.xs
index 2ba836c..e747fcf 100644 (file)
--- a/os2/OS2/PrfDB/PrfDB.xs
+++ b/os2/OS2/PrfDB/PrfDB.xs
@@ -15,7 +15,7 @@ extern "C" {
 #define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini)))
 
 SV *
-Prf_Get(HINI hini, PSZ app, PSZ key) {
+Prf_Get(pTHX_ HINI hini, PSZ app, PSZ key) {
     ULONG len;
     BOOL rc;
     SV *sv;
@@ -51,7 +51,7 @@ Prf_GetLength(HINI hini, PSZ app, PSZ key) {
          : HINI_PROFILE)
 
 SV*
-Prf_Profiles()
+Prf_Profiles(pTHX)
 {
     AV *av = newAV();
     SV *rv;
@@ -70,7 +70,7 @@ Prf_Profiles()
 }
 
 BOOL
-Prf_SetUser(SV *sv)
+Prf_SetUser(pTHX_ SV *sv)
 {
     char user[257];
     char system[257];
@@ -101,6 +101,10 @@ Prf_Get(hini, app, key)
  HINI hini;
  PSZ app;
  PSZ key;
+CODE:
+    RETVAL = Prf_Get(aTHX_ hini, app, key);
+OUTPUT:
+    RETVAL
 
 int
 Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1))
@@ -122,10 +126,18 @@ Prf_System(key)
 
 SV*
 Prf_Profiles()
+CODE:
+    RETVAL = Prf_Profiles(aTHX);
+OUTPUT:
+    RETVAL
 
 BOOL
 Prf_SetUser(sv)
  SV *sv
+CODE:
+    RETVAL = Prf_SetUser(aTHX_ sv);
+OUTPUT:
+    RETVAL
 
 BOOT:
        Acquire_hab();

diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs
index c16d15d..16b494d 100644 (file)
--- a/os2/OS2/Process/Process.xs
+++ b/os2/OS2/Process/Process.xs
@@ -7,18 +7,8 @@
 #define INCL_DOSERRORS
 #include <os2.h>
 
-static int
-not_here(s)
-char *s;
-{
-    croak("%s not implemented on this architecture", s);
-    return -1;
-}
-
 static unsigned long
-constant(name, arg)
-char *name;
-int arg;
+constant(char *name, int arg)
 {
     errno = 0;
     if (name[0] == 'P' && name[1] == '_') {

diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs
index 60266f4..9f23714 100644 (file)
--- a/os2/OS2/REXX/REXX.xs
+++ b/os2/OS2/REXX/REXX.xs
@@ -44,7 +44,7 @@ static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING
 static long incompartment;
 
 static SV*
-exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
+exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler)
 {
     dTHR;
     HMODULE hRexx, hRexxAPI;
@@ -61,7 +61,8 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
     LONG rc;
     SV *res;
 
-    if (incompartment) die ("Attempt to reenter into REXX compartment");
+    if (incompartment)
+       Perl_die(aTHX_ "Attempt to reenter into REXX compartment");
     incompartment = 1;
 
     if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
@@ -71,7 +72,7 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
                            (PFN *)&pRexxRegisterFunctionExe)
        || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
                            (PFN *)&pRexxDeregisterFunction)) {
-       die("REXX not available\n");
+       Perl_die(aTHX_ "REXX not available\n");
     }
 
     if (handlerName)
@@ -97,9 +98,9 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
     if (rc || SvTRUE(GvSV(PL_errgv))) {
        if (SvTRUE(GvSV(PL_errgv))) {
            STRLEN n_a;
-           die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
+           Perl_die(aTHX_ "Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ;
        }
-       die ("REXX compartment returned non-zero status %li", rc);
+       Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc);
     }
 
     return res;
@@ -113,16 +114,17 @@ PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
     return PERLCALL(NULL, argc, argv, queue, ret);
 }
 
-#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \
+#define in_rexx_compartment() exec_in_REXX(aTHX_ "return StartPerl()\r\n", \
                                           "StartPerl", PERLSTART)
 #define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
 #define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv),          \
-                                     exec_in_REXX(cmd,name,PERLSTART))
+                                     exec_in_REXX(aTHX_ cmd,name,PERLSTART))
 #define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
 
 static ULONG
 PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
 {
+    dTHX;
     EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
     int i, rc;
     unsigned long len;
@@ -217,17 +219,7 @@ initialize(void)
 }
 
 static int
-not_here(s)
-char *s;
-{
-    croak("%s not implemented on this architecture", s);
-    return -1;
-}
-
-static int
-constant(name, arg)
-char *name;
-int arg;
+constant(char *name, int arg)
 {
     errno = EINVAL;
     return 0;

diff --git a/perl.h b/perl.h
index b4cbb11..d8a035e 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1502,34 +1502,33 @@ typedef pthread_key_t   perl_key;
 #ifdef PERL_IMPLICIT_CONTEXT
 #  ifdef USE_THREADS
 struct perl_thread;
-#    define pTHX struct perl_thread *thr
-#    define pTHX_ pTHX,
-#    define _pTHX ,pTHX
-#    define aTHX thr
-#    define aTHX_ aTHX,
-#    define _aTHX ,aTHX
-#    define dTHX pTHX = (struct perl_thread *)SvPVX(PL_thrsv)
-#    define dTHR dNOOP
+#    define pTHX       struct perl_thread *thr
+#    define aTHX       thr
+#    define dTHXa(a)   pTHX = (struct perl_thread *)a
+#    define dTHX       dTHXa(SvPVX(PL_thrsv))
+#    define dTHR       dNOOP
 #  else
 #    define MULTIPLICITY
-#    define pTHX PerlInterpreter *my_perl
-#    define pTHX_ pTHX,
-#    define _pTHX ,pTHX
-#    define aTHX my_perl
-#    define aTHX_ aTHX,
-#    define _aTHX ,aTHX
-#    define dTHX pTHX = PL_curinterp
+#    define pTHX       PerlInterpreter *my_perl
+#    define aTHX       my_perl
+#    define dTHXa(a)   pTHX = (PerlInterpreter *)a
+#    define dTHX       dTHXa(PL_curinterp)
 #  endif
+#  define pTHX_                pTHX,
+#  define _pTHX                ,pTHX
+#  define aTHX_                aTHX,
+#  define _aTHX                ,aTHX
 #endif
 
 #ifndef pTHX
-#  define pTHX void
+#  define pTHX         void
 #  define pTHX_
 #  define _pTHX
 #  define aTHX
 #  define aTHX_
 #  define _aTHX
-#  define dTHX dNOOP
+#  define dTHXa(a)     dNOOP
+#  define dTHX         dNOOP
 #endif
 
 #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END