The R Project SVN – R – Diff – /branches/R-groups/src/main/errors.c

     jump_to_top_ex(FALSE, FALSE, TRUE, TRUE, TRUE);
+}
 /* #define DEBUG_GETTEXT 1 */
+#ifdef DEBUG_GETTEXT
+# include <Print.h>
+# define GETT_PRINT(...) REprintf(__VA_ARGS__)
+#else
+# define GETT_PRINT(...) do {} while(0)
+#endif
 /* Called from do_gettext() and do_ngettext() */
-static char * determine_domain_gettext(SEXP domain_)
+static char * determine_domain_gettext(SEXP domain_, Rboolean up)
+{
     const char *domain = "";
     char *buf; // will be returned
-    /* If cptr->cloenv is not R_GlobalEnv,
+    /* If TYPEOF(cptr->callfun) == CLOSXP (not .Primitive("eval")),
      * ENCLOS(cptr->cloenv) is CLOENV(cptr->callfun) */
     /* R_findParentContext(cptr, 1)->cloenv == cptr->sysparent */
     if(isNull(domain_)) {
-	RCNTXT *cptr = R_findParentContext(R_GlobalContext, 1);
+	RCNTXT *cptr;
-	SEXP rho = cptr ? CLOENV(cptr->callfun) : R_EmptyEnv;
+	GETT_PRINT(">> determine_domain_gettext(), first rho=%s\n", EncodeEnvironment(rho));
 	/* stop() etc have internal call to .makeMessage */
 	/* gettextf calls gettext */
-	if (rho == R_BaseNamespace) {
+	SEXP rho = R_EmptyEnv;
+	if(R_GlobalContext->callflag & CTXT_FUNCTION) {
+	    if(up) {
-	    SEXP call = getCurrentCall(), cfn = CAR(call);
+		SEXP call = R_GlobalContext->call;
+		/* The call is of the form
+		   <symbol>(<symbol>, domain = domain [possible other argument]) */
+		rho =
+		    (isSymbol(CAR(call)) && (call = CDR(call)) != R_NilValue &&
-	    if (TYPEOF(cfn) == SYMSXP && !streql(CHAR(PRINTNAME(cfn)), "ngettext") &&
+		     TAG(call) == R_NilValue && isSymbol(CAR(call)) &&
-		TYPEOF(CADR(call)) == SYMSXP) {
+		     (call = CDR(call)) != R_NilValue &&
+		     isSymbol(TAG(call)) && streql(CHAR(PRINTNAME(TAG(call))), "domain") &&
+		     isSymbol(CAR(call)) && streql(CHAR(PRINTNAME(CAR(call))), "domain") &&
-		cptr = R_findParentContext(cptr, 1);
+		     (cptr = R_findParentContext(R_GlobalContext, 1)))
+		    ? cptr->sysparent
-		rho = cptr ? CLOENV(cptr->callfun) : R_EmptyEnv;
+		    : R_GlobalContext->sysparent;
+	    }
+	    else
+		rho = R_GlobalContext->sysparent;
+	}
+	GETT_PRINT(" .. rho1_domain_ => rho=%s\n", EncodeEnvironment(rho));
 	SEXP ns = R_NilValue;
+	int cnt = 0;
 	    while(rho != R_EmptyEnv) {
 		if (rho == R_GlobalEnv) break;
 		else if (R_IsNamespaceEnv(rho)) {
 		    ns = R_NamespaceEnvSpec(rho);
 		    break;
+		}
+		if(++cnt <= 5 || cnt > 99) { // diagnose "inf." loop
+		    GETT_PRINT("  cnt=%4d, rho=%s\n", cnt, EncodeEnvironment(rho));
+		    if(cnt > 111) break;
+		}
-		if(rho == ENCLOS(rho)) break; // *does* happen
+		if(rho == ENCLOS(rho)) break; // *did* happen; now keep for safety
 		rho = ENCLOS(rho);
+	    }
 	if (!isNull(ns)) {
 	    PROTECT(ns);
 	    domain = translateChar(STRING_ELT(ns, 0));
 	    if (strlen(domain)) {
 		size_t len = strlen(domain)+3;
 		buf = R_alloc(len, sizeof(char));
 		Rsnprintf_mbcs(buf, len, "R-%s", domain);
 		UNPROTECT(1); /* ns */
-#ifdef DEBUG_GETTEXT
-		REprintf("Managed to determine 'domain' from environment as: '%s'\n", buf);
+		GETT_PRINT("Managed to determine 'domain' from environment as: '%s'\n", buf);
-#endif
 		return buf;
+	    }
 	    UNPROTECT(1); /* ns */
+	}
 	return NULL;
     } else if(isString(domain_)) {
 	domain = translateChar(STRING_ELT(domain_, 0));
 	if (!strlen(domain))
 	    return NULL;
 	buf = R_alloc(strlen(domain) + 1, sizeof(char));
 	strcpy(buf, domain);
 	return buf;
     } else if(isLogical(domain_) && LENGTH(domain_) == 1 && LOGICAL(domain_)[0] == NA_LOGICAL)
 	return NULL;
     else error(_("invalid '%s' value"), "domain");
+}
     if(isNull(string) || !n) return string;
     if(!isString(string)) error(_("invalid '%s' value"), "string");
-    char * domain = determine_domain_gettext(CAR(args));
+    char * domain = determine_domain_gettext(CAR(args), /*up*/TRUE);
     if(domain && strlen(domain)) {
 	SEXP ans = PROTECT(allocVector(STRSXP, n));
 	for(int i = 0; i < n; i++) {
 	    int ihead = 0, itail = 0;
 		strcpy(tail, tmp+strlen(tmp)-itail);
 		tmp[strlen(tmp)-itail] = '\0';
+	    }
 	    if(strlen(tmp)) {
-#ifdef DEBUG_GETTEXT
-		REprintf("translating '%s' in domain '%s'\n", tmp, domain);
+		GETT_PRINT("translating '%s' in domain '%s'\n", tmp, domain);
-#endif
 		tr = dgettext(domain, tmp);
  		R_CheckStack2(        strlen(tr) + ihead + itail + 1);
 		tmp = (char *) alloca(strlen(tr) + ihead + itail + 1);
 		tmp[0] ='\0';
 		if(ihead > 0) strcat(tmp, head);
 	error(_("'%s' must be a character string"), "msg1");
     if(!isString(msg2) || LENGTH(msg2) != 1)
 	error(_("'%s' must be a character string"), "msg2");
 #ifdef ENABLE_NLS
-    char * domain = determine_domain_gettext(CADDDR(args));
+    char * domain = determine_domain_gettext(CADDDR(args), /*up*/FALSE);
     if(domain && strlen(domain)) {
 	/* libintl seems to malfunction if given a message of "" */
 	if(length(STRING_ELT(msg1, 0))) {
 	    char *fmt = dngettext(domain,
     if(isNull(CADR(args))) {
 	res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)), NULL);
     } else {
 	if(!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
 	    error(_("invalid '%s' value"), "dirname");
-	res = bindtextdomain(translateChar(STRING_ELT(CAR(args),0)),
+	res = bindtextdomain(translateChar(STRING_ELT(CAR (args),0)),
 			     translateChar(STRING_ELT(CADR(args),0)));
+    }
     if(res) return mkString(res);
     /* else this failed */
 #endif

The R Project SVN R

(root)/branches/R-groups/src/main/errors.c – Rev 81060 → 81095