Yesterday's patch did not print the attributes. This one seems fine:
> f <- function(){}
> attr( f, "yada" ) <- function( ) "lobster bisk"
> f
function(){}
attr(,"yada")
function( ) "lobster bisk"
Romain
Romain Francois wrote:
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
__
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
--
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,35 @@
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("\n", BODY(s));
+#endif
+ if (TYPEOF(s) == CLOSXP) {
+ t = CLOENV(s);
+ if (t != R_GlobalEnv)
+ Rprintf("%s\n", EncodeEnvironment(t));
+ printAttributes( s, t, FALSE ) ;
+ }
+ 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 +675,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("\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 +926,13 @@
PROTECT(call = lang2(install("print"), s));
eval(call, env);
UNPROTECT(1);
-} else PrintValueRec(s, e
