Hello,
Sorry if I have waisted any time of people truing this patch. There was
an issue with debugging (use of debug and browser that caused an
infinite recursion). I think this is now fixed.
At the R level, I have now this :
> print.function
function (x, useSource = TRUE, ...)
{
invisible(.Internal(print.function(x, useSource, ...)))
}
<environment: namespace:base>
and the PrintValueRec dispatches like this at the C level:
case LANGSXP:
PrintLanguage(s, FALSE) ;
break;
case CLOSXP:
{
SEXP call;
PROTECT( call = lang2(install("print.function"), s));
eval(call,env);
UNPROTECT(1);
break;
}
so that LANGSXP are printed using the PrintLanguage function and CLOSXP
are printed using the R function print.function which in turns calls the
PrintClosure function (unless it is masked in R)
Romain
Romain Francois wrote:
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
------------------------------------------------------------------------
______________________________________________
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 48365)
+++ 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/include/Print.h
===================================================================
--- src/include/Print.h (revision 48365)
+++ src/include/Print.h (working copy)
@@ -80,4 +80,7 @@
#define R_MIN_DIGITS_OPT 1
#define R_MAX_DIGITS_OPT 22
+void PrintClosure( SEXP, Rboolean) ;
+void PrintLanguage( SEXP, Rboolean) ;
+
#endif
Index: src/library/base/R/print.R
===================================================================
--- src/library/base/R/print.R (revision 48365)
+++ 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, ...){
+ invisible( .Internal( print.function( x, useSource, ... ) ) )
+}
+
Index: src/main/names.c
===================================================================
--- src/main/names.c (revision 48365)
+++ 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 48365)
+++ src/main/print.c (working copy)
@@ -154,6 +154,56 @@
return x;
}/* do_prmatrix */
+
+/* .Internal( print.function( f, useSource,... ) ) */
+SEXP attribute_hidden do_printfunction( SEXP call, SEXP op, SEXP args, SEXP rho){
+ SEXP s;
+ Rboolean useSource = TRUE;
+ s=CAR(args);
+ args = CDR(args); useSource=asLogical(CAR(args));
+
+ PrintClosure( s, useSource ) ;
+ return R_NilValue;
+}
+
+void PrintClosure( SEXP s, Rboolean useSource ){
+ SEXP t;
+ int i;
+ if( TYPEOF(s) != CLOSXP ) return ;
+ 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 (isByteCode(BODY(s))){
+ Rprintf("<bytecode: %p>\n", BODY(s));
+ }
+#endif
+ t = CLOENV(s);
+ if (t != R_GlobalEnv){
+ Rprintf("%s\n", EncodeEnvironment(t));
+ }
+ printAttributes( s, t, FALSE ) ;
+
+}
+
+void PrintLanguage( SEXP s, Rboolean useSource ){
+ SEXP t;
+ int i;
+ if( TYPEOF(s) != LANGSXP ) return ;
+ 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 */
+ }
+ printAttributes( s, t, FALSE ) ;
+}
+
/* .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 +696,17 @@
case EXPRSXP:
PrintExpression(s);
break;
- 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));
+ PrintLanguage(s, FALSE) ;
+ break;
+ case CLOSXP:
+ {
+ SEXP call;
+ PROTECT( call = lang2(install("print.function"), s));
+ eval(call,env);
+ UNPROTECT(1);
+ break;
}
- break;
case ENVSXP:
Rprintf("%s\n", EncodeEnvironment(s));
break;
@@ -877,35 +921,38 @@
tagbuf[0] = '\0';
PROTECT(s);
if(isObject(s)) {
- /*
- The intention here is to call show() on S4 objects, otherwise
- print(), so S4 methods for show() have precedence over those for
- print() to conform with the "green book", p. 332
- */
- SEXP call, showS;
- if(isMethodsDispatchOn() && IS_S4_OBJECT(s)) {
- /*
- Note that we cannot assume that show() is visible from
- 'env', but we can assume there is a loaded "methods"
- namespace. It is tempting to cache the value of show in
- the namespace, but the latter could be unloaded and
- reloaded in a session.
- */
- showS = findVar(install("show"), env);
- if(showS == R_UnboundValue) {
- SEXP methodsNS = R_FindNamespace(mkString("methods"));
- if(methodsNS == R_UnboundValue)
- error("missing methods namespace: this should not happen");
- showS = findVarInFrame3(methodsNS, install("show"), TRUE);
- if(showS == R_UnboundValue)
- error("missing show() in methods namespace: this should not happen");
- }
- PROTECT(call = lang2(showS, s));
- } else
- PROTECT(call = lang2(install("print"), s));
- eval(call, env);
- UNPROTECT(1);
- } else PrintValueRec(s, env);
+ /*
+ The intention here is to call show() on S4 objects, otherwise
+ print(), so S4 methods for show() have precedence over those for
+ print() to conform with the "green book", p. 332
+ */
+ SEXP call, showS;
+ if(isMethodsDispatchOn() && IS_S4_OBJECT(s)) {
+ /*
+ Note that we cannot assume that show() is visible from
+ 'env', but we can assume there is a loaded "methods"
+ namespace. It is tempting to cache the value of show in
+ the namespace, but the latter could be unloaded and
+ reloaded in a session.
+ */
+ showS = findVar(install("show"), env);
+ if(showS == R_UnboundValue) {
+ SEXP methodsNS = R_FindNamespace(mkString("methods"));
+ if(methodsNS == R_UnboundValue)
+ error("missing methods namespace: this should not happen");
+ showS = findVarInFrame3(methodsNS, install("show"), TRUE);
+ if(showS == R_UnboundValue)
+ error("missing show() in methods namespace: this should not happen");
+ }
+ PROTECT(call = lang2(showS, s));
+ } else {
+ PROTECT(call = lang2(install("print"), s));
+ }
+ eval(call, env);
+ UNPROTECT(1);
+ } else {
+ PrintValueRec(s, env);
+ }
UNPROTECT(1);
}
@@ -1009,3 +1056,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
