Re: [Rd] print.closure at the R level

[Romain Francois]

Duncan Murdoch wrote:

On 18/04/2009 10:12 AM, Romain Francois wrote:

Hello,

Could the code that auto prints a function/closure be extracted from print.c so that there would be a print.closure function. I would like to be able to mask a print.closure function so that I have a custom auto-print. One reason for that is I plan to have syntax highlighting within the R console.

The class of a closure is "function", so you'd want the method to be print.function. Currently that doesn't work for auto printing, so your suggestion is still interesting. (I'm not sure why auto printing is special here...)

Duncan Murdoch

The attached patch implements exposing the print.function at the R level.

Romain

--
Romain Francois
Independent R Consultant
+33(0) 6 28 91 30 30
http://romainfrancois.blog.free.fr



Index: src/include/Internal.h
===================================================================
--- src/include/Internal.h	(revision 48350)
+++ src/include/Internal.h	(working copy)
@@ -370,6 +370,7 @@
 SEXP do_printdefault(SEXP, SEXP, SEXP, SEXP);
 SEXP do_printDeferredWarnings(SEXP, SEXP, SEXP, SEXP);
 SEXP do_printdf(SEXP, SEXP, SEXP, SEXP);
+SEXP do_printfunction(SEXP, SEXP, SEXP, SEXP);
 SEXP do_prmatrix(SEXP, SEXP, SEXP, SEXP);
 SEXP do_proctime(SEXP, SEXP, SEXP, SEXP);
 SEXP do_psort(SEXP, SEXP, SEXP, SEXP);
Index: src/library/base/R/print.R
===================================================================
--- src/library/base/R/print.R	(revision 48350)
+++ src/library/base/R/print.R	(working copy)
@@ -85,3 +85,8 @@
     print(noquote(cbind("_"=unlist(x))), ...)
 
 `[.simple.list` <- `[.listof`
+
+print.function <- function( x, useSource=TRUE, ...){
+	.Internal( print.function( x, useSource, ... ) )
+}
+
Index: src/main/names.c
===================================================================
--- src/main/names.c	(revision 48350)
+++ src/main/names.c	(working copy)
@@ -631,6 +631,7 @@
 {"readline",	do_readln,	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
 {"menu",	do_menu,	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
 {"print.default",do_printdefault,0,	111,	9,	{PP_FUNCALL, PREC_FN,	0}},
+{"print.function",do_printfunction,0,	111,	3,	{PP_FUNCALL, PREC_FN,	0}},
 {"prmatrix",	do_prmatrix,	0,	111,	6,	{PP_FUNCALL, PREC_FN,	0}},
 {"invisible",	do_invisible,	0,	101,	1,	{PP_FUNCALL, PREC_FN,	0}},
 {"gc",		do_gc,		0,	11,	2,	{PP_FUNCALL, PREC_FN,	0}},
Index: src/main/print.c
===================================================================
--- src/main/print.c	(revision 48350)
+++ src/main/print.c	(working copy)
@@ -154,6 +154,34 @@
     return x;
 }/* do_prmatrix */
 
+
+/* .Internal( print.function( f,useSource,... ) ) */
+SEXP attribute_hidden do_printfunction( SEXP call, SEXP op, SEXP args, SEXP rho){
+	SEXP s,t;
+	Rboolean useSource = TRUE; 
+	s=CAR(args);
+	args = CDR(args);	useSource=asLogical(CAR(args));
+	
+	int i;
+	if( ! (TYPEOF(s) == CLOSXP || TYPEOF(s) == LANGSXP ) ) return R_NilValue;
+	t = getAttrib(s, R_SourceSymbol);
+	if (!isString(t) || !useSource)
+	    t = deparse1(s, 0, useSource | DEFAULTDEPARSE);
+	for (i = 0; i < LENGTH(t); i++)
+	    Rprintf("%s\n", CHAR(STRING_ELT(t, i))); /* translated */
+#ifdef BYTECODE
+	if (TYPEOF(s) == CLOSXP && isByteCode(BODY(s)))
+	    Rprintf("<bytecode: %p>\n", BODY(s));
+#endif
+	if (TYPEOF(s) == CLOSXP) {
+	    t = CLOENV(s);
+	    if (t != R_GlobalEnv)
+		Rprintf("%s\n", EncodeEnvironment(t));
+	}
+	return R_NilValue;
+}
+
+
 /* .Internal(print.default(x, digits, quote, na.print, print.gap,
 			   right, max, useS4)) */
 SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
@@ -646,23 +674,15 @@
     case EXPRSXP:
 	PrintExpression(s);
 	break;
+    case LANGSXP:
     case CLOSXP:
-    case LANGSXP:
-	t = getAttrib(s, R_SourceSymbol);
-	if (!isString(t) || !R_print.useSource)
-	    t = deparse1(s, 0, R_print.useSource | DEFAULTDEPARSE);
-	for (i = 0; i < LENGTH(t); i++)
-	    Rprintf("%s\n", CHAR(STRING_ELT(t, i))); /* translated */
-#ifdef BYTECODE
-	if (TYPEOF(s) == CLOSXP && isByteCode(BODY(s)))
-	    Rprintf("<bytecode: %p>\n", BODY(s));
-#endif
-	if (TYPEOF(s) == CLOSXP) {
-	    t = CLOENV(s);
-	    if (t != R_GlobalEnv)
-		Rprintf("%s\n", EncodeEnvironment(t));
+	{
+		SEXP call;
+		PROTECT( call = lang2(install("print.function"), s));
+		eval(call,env);
+		UNPROTECT(1);
+		break;
 	}
-	break;
     case ENVSXP:
 	Rprintf("%s\n", EncodeEnvironment(s));
 	break;
@@ -905,7 +925,13 @@
 	    PROTECT(call = lang2(install("print"), s));
 	eval(call, env);
 	UNPROTECT(1);
-    } else PrintValueRec(s, env);
+    } else if( TYPEOF(s) == CLOSXP || TYPEOF(s) == LANGSXP){
+		SEXP call; 
+		PROTECT(call = lang2(install("print.function"), s));
+		eval(call,env);
+	} else {
+		PrintValueRec(s, env);
+	}
     UNPROTECT(1);
 }
 
@@ -1009,3 +1035,4 @@
     buf[6] = '\0';
     error(_("BLAS/LAPACK routine '%6s' gave error code %d"), buf, -(*info));
 }
+

______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel