View | Details | Raw Unified | Return to bug 17398 | Differences between
and this patch

Collapse All | Expand All

(-)doc/NEWS.Rd (+8 lines)
Lines 630-635 Link Here
630
      \item The indexing tags of recursive data structures are now
630
      \item The indexing tags of recursive data structures are now
631
      printed correctly in complex cases.
631
      printed correctly in complex cases.
632
632
633
      \item Arguments supplied to \code{print()} are now properly
634
      forwarded to print methods when printing lists, pairlists or
635
      attributes containing S3 objects.
636
637
      \item The print parameters are now preserved when printing S3
638
      objects or deparsing symbols and calls. Before this fix printing
639
      lists containing S3 objects or expressions would reset these
640
      parameters.
633
    }
641
    }
634
  }
642
  }
635
}
643
}
(-)src/include/Print.h (+1 lines)
Lines 51-56 typedef struct { Link Here
51
    SEXP na_string_noquote;
51
    SEXP na_string_noquote;
52
    int useSource;
52
    int useSource;
53
    int cutoff; // for deparsed language objects
53
    int cutoff; // for deparsed language objects
54
    SEXP callArgs;
54
} R_print_par_t;
55
} R_print_par_t;
55
extern R_print_par_t R_print;
56
extern R_print_par_t R_print;
56
57
(-)src/library/base/R/print.R (-4 / +23 lines)
Lines 23-33 print.default <- function(x, digits = NULL, quote = TRUE, na.print = NULL, Link Here
23
                          print.gap = NULL, right = FALSE, max = NULL,
23
                          print.gap = NULL, right = FALSE, max = NULL,
24
                          useSource = TRUE, ...)
24
                          useSource = TRUE, ...)
25
{
25
{
26
    noOpt <- missing(digits) && missing(quote) && missing(na.print) &&
26
    missings <- c(missing(digits), missing(quote), missing(na.print),
27
	missing(print.gap) && missing(right) && missing(max) &&
27
                  missing(print.gap), missing(right), missing(max),
28
	missing(useSource) && missing(...)
28
                  missing(useSource))
29
30
    # Need to be a bit careful with argument matching. We need to
31
    # capture the pairlist of arguments actually supplied by the user.
32
    # We check for missingness instead of using match.call() tricks
33
    # because arguments should be evaluated only once.
34
    userArgs <- list(
35
        digits = digits,
36
        quote = quote,
37
        na.print = na.print,
38
        print.gap = print.gap,
39
        right = right,
40
        max = max,
41
        useSource = useSource
42
    )
43
    userArgs <- c(userArgs[!missings], list(...))
44
    userArgs <- as.pairlist(userArgs)
45
46
    noOpt <- all(missings) && missing(...)
47
29
    .Internal(print.default(x, digits, quote, na.print, print.gap, right, max,
48
    .Internal(print.default(x, digits, quote, na.print, print.gap, right, max,
30
			    useSource, noOpt))
49
                            useSource, noOpt, userArgs))
31
}
50
}
32
51
33
prmatrix <-
52
prmatrix <-
(-)src/main/names.c (-1 / +1 lines)
Lines 681-687 FUNTAB R_FunTab[] = Link Here
681
{"dump",	do_dump,	0,	111,	5,	{PP_FUNCALL, PREC_FN,	0}},
681
{"dump",	do_dump,	0,	111,	5,	{PP_FUNCALL, PREC_FN,	0}},
682
{"quit",	do_quit,	0,	111,	3,	{PP_FUNCALL, PREC_FN,	0}},
682
{"quit",	do_quit,	0,	111,	3,	{PP_FUNCALL, PREC_FN,	0}},
683
{"readline",	do_readln,	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
683
{"readline",	do_readln,	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
684
{"print.default",do_printdefault,0,	111,	9,	{PP_FUNCALL, PREC_FN,	0}},
684
{"print.default",do_printdefault,0,	111,   10,	{PP_FUNCALL, PREC_FN,	0}},
685
{"print.function",do_printfunction,0,	111,	-1,	{PP_FUNCALL, PREC_FN,	0}},
685
{"print.function",do_printfunction,0,	111,	-1,	{PP_FUNCALL, PREC_FN,	0}},
686
{"prmatrix",	do_prmatrix,	0,	111,	6,	{PP_FUNCALL, PREC_FN,	0}},
686
{"prmatrix",	do_prmatrix,	0,	111,	6,	{PP_FUNCALL, PREC_FN,	0}},
687
{"gc",		do_gc,		0,	11,	3,	{PP_FUNCALL, PREC_FN,	0}},
687
{"gc",		do_gc,		0,	11,	3,	{PP_FUNCALL, PREC_FN,	0}},
(-)src/main/print.c (-60 / +32 lines)
Lines 53-62 Link Here
53
 *  Also ./printvector.c,  ./printarray.c
53
 *  Also ./printvector.c,  ./printarray.c
54
 *
54
 *
55
 *  do_sink moved to connections.c as of 1.3.0
55
 *  do_sink moved to connections.c as of 1.3.0
56
 *
57
 *  <FIXME> These routines are not re-entrant: they reset the
58
 *  global R_print.
59
 *  </FIXME>
60
 */
56
 */
61
57
62
#ifdef HAVE_CONFIG_H
58
#ifdef HAVE_CONFIG_H
Lines 105-110 void PrintDefaults(void) Link Here
105
    R_print.width = GetOptionWidth();
101
    R_print.width = GetOptionWidth();
106
    R_print.useSource = USESOURCE;
102
    R_print.useSource = USESOURCE;
107
    R_print.cutoff = GetOptionCutoff();
103
    R_print.cutoff = GetOptionCutoff();
104
    R_print.callArgs = R_NilValue;
108
}
105
}
109
106
110
SEXP attribute_hidden do_invisible(SEXP call, SEXP op, SEXP args, SEXP rho)
107
SEXP attribute_hidden do_invisible(SEXP call, SEXP op, SEXP args, SEXP rho)
Lines 191-197 static void PrintLanguageEtc(SEXP s, Rboolean useSource, Rboolean isClosure) Link Here
191
	t = eval(t, R_BaseEnv);
188
	t = eval(t, R_BaseEnv);
192
	UNPROTECT(1);
189
	UNPROTECT(1);
193
    } else {
190
    } else {
191
        /* Save parameters as deparsing calls PrintDefaults() */
192
        R_print_par_t pars = R_print;
194
	t = deparse1w(s, 0, useSource | DEFAULTDEPARSE);
193
	t = deparse1w(s, 0, useSource | DEFAULTDEPARSE);
194
        R_print = pars;
195
    }
195
    }
196
    PROTECT(t);
196
    PROTECT(t);
197
    for (i = 0; i < LENGTH(t); i++) {
197
    for (i = 0; i < LENGTH(t); i++) {
Lines 223-229 void PrintLanguage(SEXP s, Rboolean useSource) Link Here
223
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
223
SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho)
224
{
224
{
225
    SEXP x, naprint;
225
    SEXP x, naprint;
226
    int tryS4;
227
226
228
    checkArity(op, args);
227
    checkArity(op, args);
229
    PrintDefaults();
228
    PrintDefaults();
Lines 280-291 SEXP attribute_hidden do_printdefault(SEXP call, SEXP op, SEXP args, SEXP rho) Link Here
280
    if(R_print.useSource) R_print.useSource = USESOURCE;
279
    if(R_print.useSource) R_print.useSource = USESOURCE;
281
    args = CDR(args);
280
    args = CDR(args);
282
281
283
    tryS4 = asLogical(CAR(args));
282
    int noParams = asLogical(CAR(args)); args = CDR(args);
284
    if(tryS4 == NA_LOGICAL)
283
    if (noParams == NA_LOGICAL)
285
	error(_("invalid 'tryS4' internal argument"));
284
        error(_("invalid 'noParams' internal argument"));
285
286
    R_print.callArgs = CAR(args);
286
287
287
    tagbuf[0] = '\0';
288
    tagbuf[0] = '\0';
288
    if (tryS4 && IS_S4_OBJECT(x) && isMethodsDispatchOn())
289
    if (noParams && IS_S4_OBJECT(x) && isMethodsDispatchOn())
289
        PrintObject(x, rho);
290
        PrintObject(x, rho);
290
    else
291
    else
291
        PrintValueRec(x, rho);
292
        PrintValueRec(x, rho);
Lines 332-344 static void PrintObjectS3(SEXP s, SEXP env) Link Here
332
    SEXP mask = PROTECT(NewEnvironment(R_NilValue, R_NilValue, env));
333
    SEXP mask = PROTECT(NewEnvironment(R_NilValue, R_NilValue, env));
333
    defineVar(xsym, s, mask);
334
    defineVar(xsym, s, mask);
334
335
336
    /* Forward user-supplied arguments to print() */
335
    SEXP fun = findVar(install("print"), R_BaseNamespace);
337
    SEXP fun = findVar(install("print"), R_BaseNamespace);
336
    SEXP call = PROTECT(lang2(fun, xsym));
338
    SEXP args = PROTECT(cons(xsym, R_print.callArgs));
339
    SEXP call = PROTECT(lcons(fun, args));
337
340
338
    eval(call, mask);
341
    eval(call, mask);
339
342
340
    defineVar(xsym, R_NilValue, mask); /* To eliminate reference to s */
343
    defineVar(xsym, R_NilValue, mask); /* To eliminate reference to s */
341
    UNPROTECT(2);
344
    UNPROTECT(3);
342
}
345
}
343
346
344
static void PrintObject(SEXP s, SEXP env)
347
static void PrintObject(SEXP s, SEXP env)
Lines 348-358 static void PrintObject(SEXP s, SEXP env) Link Here
348
    char save[TAGBUFLEN0];
351
    char save[TAGBUFLEN0];
349
    strcpy(save, tagbuf);
352
    strcpy(save, tagbuf);
350
353
354
    /* Save the R_print structure since it might be reset by print.default() */
355
    R_print_par_t pars = R_print;
356
351
    if (isMethodsDispatchOn() && IS_S4_OBJECT(s))
357
    if (isMethodsDispatchOn() && IS_S4_OBJECT(s))
352
        PrintObjectS4(s, env);
358
        PrintObjectS4(s, env);
353
    else
359
    else
354
        PrintObjectS3(s, env);
360
        PrintObjectS3(s, env);
355
361
362
    R_print = pars;
356
    strcpy(tagbuf, save);
363
    strcpy(tagbuf, save);
357
}
364
}
358
365
Lines 683-689 static void PrintExpression(SEXP s) Link Here
683
    SEXP u;
690
    SEXP u;
684
    int i, n;
691
    int i, n;
685
692
693
    /* Save parameters as deparsing calls PrintDefaults() */
694
    R_print_par_t pars = R_print;
686
    u = PROTECT(deparse1w(s, 0, R_print.useSource | DEFAULTDEPARSE));
695
    u = PROTECT(deparse1w(s, 0, R_print.useSource | DEFAULTDEPARSE));
696
    R_print = pars;
697
687
    n = LENGTH(u);
698
    n = LENGTH(u);
688
    for (i = 0; i < n; i++)
699
    for (i = 0; i < n; i++)
689
	Rprintf("%s\n", CHAR(STRING_ELT(u, i))); /*translated */
700
	Rprintf("%s\n", CHAR(STRING_ELT(u, i))); /*translated */
Lines 712-718 static void PrintSpecial(SEXP s) Link Here
712
    if(s2 != R_UnboundValue) {
723
    if(s2 != R_UnboundValue) {
713
	SEXP t;
724
	SEXP t;
714
	PROTECT(s2);
725
	PROTECT(s2);
726
        /* Save parameters as deparsing calls PrintDefaults() */
727
        R_print_par_t pars = R_print;
715
	t = deparse1(s2, 0, DEFAULTDEPARSE);
728
	t = deparse1(s2, 0, DEFAULTDEPARSE);
729
        R_print = pars;
716
	Rprintf("%s ", CHAR(STRING_ELT(t, 0))); /* translated */
730
	Rprintf("%s ", CHAR(STRING_ELT(t, 0))); /* translated */
717
	Rprintf(".Primitive(\"%s\")\n", PRIMNAME(s));
731
	Rprintf(".Primitive(\"%s\")\n", PRIMNAME(s));
718
	UNPROTECT(1);
732
	UNPROTECT(1);
Lines 757-767 void attribute_hidden PrintValueRec(SEXP s, SEXP env) Link Here
757
    case NILSXP:
771
    case NILSXP:
758
	Rprintf("NULL\n");
772
	Rprintf("NULL\n");
759
	break;
773
	break;
760
    case SYMSXP: /* Use deparse here to handle backtick quotification
774
    case SYMSXP: {
761
		  * of "weird names" */
775
        /* Use deparse here to handle backtick quotification of "weird names".
776
           Save parameters as deparsing calls PrintDefaults(). */
777
        R_print_par_t pars = R_print;
762
	t = deparse1(s, 0, SIMPLEDEPARSE);
778
	t = deparse1(s, 0, SIMPLEDEPARSE);
779
        R_print = pars;
763
	Rprintf("%s\n", CHAR(STRING_ELT(t, 0))); /* translated */
780
	Rprintf("%s\n", CHAR(STRING_ELT(t, 0))); /* translated */
764
	break;
781
	break;
782
    }
765
    case SPECIALSXP:
783
    case SPECIALSXP:
766
    case BUILTINSXP:
784
    case BUILTINSXP:
767
	PrintSpecial(s);
785
	PrintSpecial(s);
Lines 928-980 static void printAttributes(SEXP s, SEXP env, Rboolean useSlots) Link Here
928
		UNPROTECT(1);
946
		UNPROTECT(1);
929
		goto nextattr;
947
		goto nextattr;
930
	    }
948
	    }
931
	    if (isMethodsDispatchOn() && IS_S4_OBJECT(CAR(a))) {
949
            PrintDispatch(CAR(a), env);
932
                PrintObject(CAR(a), env);
933
	    } else if (isObject(CAR(a))) {
934
		/* Need to construct a call to
935
		   print(CAR(a), digits)
936
		   based on the R_print structure, then eval(call, env).
937
		   See do_docall for the template for this sort of thing.
938
939
		   quote, right, gap should probably be included if
940
		   they have non-missing values.
941
942
		   This will not dispatch to show() as 'digits' is supplied.
943
		*/
944
		SEXP s, t, na_string = R_print.na_string,
945
		    na_string_noquote = R_print.na_string_noquote;
946
		int quote = R_print.quote,
947
		    digits = R_print.digits, gap = R_print.gap,
948
		    na_width = R_print.na_width,
949
		    na_width_noquote = R_print.na_width_noquote;
950
		Rprt_adj right = R_print.right;
951
952
                /* Prevent evaluation of calls, see PrintObject() */
953
                SEXP xsym = install("x");
954
                SEXP mask = PROTECT(NewEnvironment(R_NilValue, R_NilValue, env));
955
                defineVar(xsym, CAR(a), mask);
956
957
		PROTECT(t = s = allocList(3));
958
		SET_TYPEOF(s, LANGSXP);
959
		SETCAR(t, install("print")); t = CDR(t);
960
		SETCAR(t,  xsym); t = CDR(t);
961
		SETCAR(t, ScalarInteger(digits));
962
		SET_TAG(t, install("digits"));
963
964
                eval(s, mask);
965
                defineVar(xsym, R_NilValue, mask); /* To eliminate reference to s */
966
                UNPROTECT(2);
967
968
		R_print.quote = quote;
969
		R_print.right = right;
970
		R_print.digits = digits;
971
		R_print.gap = gap;
972
		R_print.na_width = na_width;
973
		R_print.na_width_noquote = na_width_noquote;
974
		R_print.na_string = na_string;
975
		R_print.na_string_noquote = na_string_noquote;
976
	    } else
977
		PrintValueRec(CAR(a), env);
978
	nextattr:
950
	nextattr:
979
	    *ptag = '\0';
951
	    *ptag = '\0';
980
	    a = CDR(a);
952
	    a = CDR(a);
(-)tests/print-tests.R (+32 lines)
Lines 311-313 print(c) Link Here
311
print(d)
311
print(d)
312
312
313
rm(print.foo, obj, a, b, c, d)
313
rm(print.foo, obj, a, b, c, d)
314
315
316
## Print dispatch does not reset parameters
317
local({
318
    obj <- structure(list(), class = "foo")
319
    num <- 0.123456789
320
    print(list(num, obj, num), digits = 2)
321
})
322
323
324
## User-supplied arguments are forwarded on print-dispatch
325
obj <- structure(list(), class = "foo")
326
print.foo <- function(x, other = FALSE, digits = 0L, ...) {
327
    cat("digits: ", digits, "\n")
328
    stopifnot(other, digits == 4L)
329
    stopifnot(!length(list(...)))
330
}
331
332
a <- list(obj)
333
b <- pairlist(obj)
334
c <- structure(list(), attr = obj)
335
d <- list(list(obj, pairlist(obj, structure(list(obj), attr = obj)), NULL))
336
337
print(a, digits = 4L, other = TRUE)
338
print(b, digits = 4L, other = TRUE)
339
print(c, digits = 4L, other = TRUE)
340
print(d, digits = 4L, other = TRUE)
341
342
## Make sure deparsing does not reset parameters
343
print(list(a, expression(foo), b, quote(foo), c, base::list, d), digits = 4L, other = TRUE)
344
345
rm(print.foo, obj, a, b, c, d)
(-)tests/print-tests.Rout.save (-1 / +116 lines)
Lines 829-834 NULL Link Here
829
829
830
> 
830
> 
831
> rm(print.foo, obj, a, b, c, d)
831
> rm(print.foo, obj, a, b, c, d)
832
> 
833
> 
834
> ## Print dispatch does not reset parameters
835
> local({
836
+     obj <- structure(list(), class = "foo")
837
+     num <- 0.123456789
838
+     print(list(num, obj, num), digits = 2)
839
+ })
840
[[1]]
841
[1] 0.12
842
843
[[2]]
844
list()
845
attr(,"class")
846
[1] "foo"
847
848
[[3]]
849
[1] 0.12
850
851
> 
852
> 
853
> ## User-supplied arguments are forwarded on print-dispatch
854
> obj <- structure(list(), class = "foo")
855
> print.foo <- function(x, other = FALSE, digits = 0L, ...) {
856
+     cat("digits: ", digits, "\n")
857
+     stopifnot(other, digits == 4L)
858
+     stopifnot(!length(list(...)))
859
+ }
860
> 
861
> a <- list(obj)
862
> b <- pairlist(obj)
863
> c <- structure(list(), attr = obj)
864
> d <- list(list(obj, pairlist(obj, structure(list(obj), attr = obj)), NULL))
865
> 
866
> print(a, digits = 4L, other = TRUE)
867
[[1]]
868
digits:  4 
869
870
> print(b, digits = 4L, other = TRUE)
871
[[1]]
872
digits:  4 
873
874
> print(c, digits = 4L, other = TRUE)
875
list()
876
attr(,"attr")
877
digits:  4 
878
> print(d, digits = 4L, other = TRUE)
879
[[1]]
880
[[1]][[1]]
881
digits:  4 
882
883
[[1]][[2]]
884
[[1]][[2]][[1]]
885
digits:  4 
886
887
[[1]][[2]][[2]]
888
[[1]][[2]][[2]][[1]]
889
digits:  4 
890
891
attr(,"attr")
892
digits:  4 
893
894
895
[[1]][[3]]
896
NULL
897
898
899
> 
900
> ## Make sure deparsing does not reset parameters
901
> print(list(a, expression(foo), b, quote(foo), c, base::list, d), digits = 4L, other = TRUE)
902
[[1]]
903
[[1]][[1]]
904
digits:  4 
905
906
907
[[2]]
908
expression(foo)
909
910
[[3]]
911
[[3]][[1]]
912
digits:  4 
913
914
915
[[4]]
916
foo
917
918
[[5]]
919
list()
920
attr(,"attr")
921
digits:  4 
922
923
[[6]]
924
function (...)  .Primitive("list")
925
926
[[7]]
927
[[7]][[1]]
928
[[7]][[1]][[1]]
929
digits:  4 
930
931
[[7]][[1]][[2]]
932
[[7]][[1]][[2]][[1]]
933
digits:  4 
934
935
[[7]][[1]][[2]][[2]]
936
[[7]][[1]][[2]][[2]][[1]]
937
digits:  4 
938
939
attr(,"attr")
940
digits:  4 
941
942
943
[[7]][[1]][[3]]
944
NULL
945
946
947
832
> 
948
> 
833
> rm(print.foo, obj, a, b, c, d)
949
> rm(print.foo, obj, a, b, c, d)
834
> 
950
> 
835
- 

Return to bug 17398