[rkward-cvs] rkward/rkward/rbackend rembedinternal.cpp,1.30,1.31

[Thomas Friedrichsmeier]

Update of /cvsroot/rkward/rkward/rkward/rbackend
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4222/rkward/rbackend

Modified Files:
	rembedinternal.cpp 
Log Message:
Workaround for cases where Rf_PrintValue would cause an R error->longjmp->crash

Index: rembedinternal.cpp
===================================================================
RCS file: /cvsroot/rkward/rkward/rkward/rbackend/rembedinternal.cpp,v
retrieving revision 1.30
retrieving revision 1.31
diff -C2 -d -r1.30 -r1.31
*** rembedinternal.cpp	4 Nov 2005 13:30:58 -0000	1.30
--- rembedinternal.cpp	8 Nov 2005 13:13:16 -0000	1.31
***************
*** 48,51 ****
--- 48,52 ----
  extern int R_CollectWarnings;
  extern int R_interrupts_pending;
+ extern Rboolean R_Visible;
  }
  
***************
*** 412,417 ****
  		}
  
- 		UNPROTECT(1); /* pr */
- 
  		if (r_error) {
  			*error = REmbedInternal::OtherError;
--- 413,416 ----
***************
*** 429,448 ****
  	}
  
  	return exp;
  }
  
  void REmbedInternal::runCommandInternal (const char *command, RKWardRError *error, bool print_result) {
  	if (!print_result) {
  		runCommandInternalBase (command, error);
  	} else {
- 		extern Rboolean R_Visible;
  		R_Visible = (Rboolean) 1;
  
  		SEXP exp;
  		PROTECT (exp = runCommandInternalBase (command, error));
  		if (R_Visible) {
! 			if (*error == NoError) Rf_PrintValue (exp);
  		}
! 		UNPROTECT (1);
  
  		/* See the comment in the corresponding code in runCommandInternalBase. And yes, apparently, we need this at both places! */
--- 428,479 ----
  	}
  
+ //	SET_SYMVALUE(R_LastvalueSymbol, exp);
+ 	UNPROTECT(1); /* pr */
+ 
  	return exp;
  }
  
+ /* Basically a safe version of Rf_PrintValue, as yes, Rf_PrintValue may lead to an error and long_jump->crash!
+ For example in help (function, htmlhelp=TRUE), when no HTML-help is installed!
+ SEXP exp should be PROTECTed prior to calling this function.
+ //TODO: I don't think it's meant to be this way. Maybe nag the R-devels about it one day. */
+ void tryPrintValue (SEXP exp, REmbedInternal::RKWardRError *error) {
+ 	int ierror = 0;
+ 	SEXP tryprint, e;
+ 
+ // Basically, we call 'print (expression)' (but inside a tryEval)
+ 	tryprint = Rf_findFun (Rf_install ("print"),  R_GlobalEnv);
+ 	PROTECT (tryprint);
+ 	e = allocVector (LANGSXP, 2);
+ 	PROTECT (e);
+ 	SETCAR (e, tryprint);
+ 	SETCAR (CDR (e), exp);
+ 	R_tryEval (e, R_GlobalEnv, &ierror);
+ 	UNPROTECT (2);	/* e, tryprint */
+ 
+ 	if (ierror) {
+ 		*error = REmbedInternal::OtherError;
+ 	} else {
+ 		*error = REmbedInternal::NoError;
+ 	}
+ }
+ 
  void REmbedInternal::runCommandInternal (const char *command, RKWardRError *error, bool print_result) {
  	if (!print_result) {
  		runCommandInternalBase (command, error);
  	} else {
  		R_Visible = (Rboolean) 1;
  
  		SEXP exp;
  		PROTECT (exp = runCommandInternalBase (command, error));
+ /*		char dummy[100];
+ 		sprintf (dummy, "type: %d", TYPEOF (exp));
+ 		Rprintf (dummy, 100); */
  		if (R_Visible) {
! 			if (*error == NoError) {
! 				tryPrintValue (exp, error);
! 			}
  		}
! 		UNPROTECT (1); /* exp */
  
  		/* See the comment in the corresponding code in runCommandInternalBase. And yes, apparently, we need this at both places! */
***************
*** 452,456 ****
  			Rf_PrintWarnings ();
  		}
! 	}
  }
  
--- 483,487 ----
  			Rf_PrintWarnings ();
  		}
! 	} 
  }