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

Collapse All | Expand All

(-)doc/NEWS.Rd (+3 lines)
Lines 638-643 Link Here
638
      objects or deparsing symbols and calls. Before this fix printing
638
      objects or deparsing symbols and calls. Before this fix printing
639
      lists containing S3 objects or expressions would reset these
639
      lists containing S3 objects or expressions would reset these
640
      parameters.
640
      parameters.
641
642
      \item Printing lists, pairlists or attributes containing
643
      functions now uses \code{srcref} attributes if present.
641
    }
644
    }
642
  }
645
  }
643
}
646
}
(-)src/library/base/R/print.R (-1 / +1 lines)
Lines 124-130 print.simple.list <- function(x, ...) Link Here
124
    print(noquote(cbind("_"=unlist(x))), ...)
124
    print(noquote(cbind("_"=unlist(x))), ...)
125
125
126
print.function <- function(x, useSource = TRUE, ...)
126
print.function <- function(x, useSource = TRUE, ...)
127
    .Internal(print.function(x, useSource, ...))
127
    print.default(x, useSource = useSource, ...)
128
128
129
## used for getenv()
129
## used for getenv()
130
print.Dlist <- function(x, ...)
130
print.Dlist <- function(x, ...)
(-)src/main/names.c (-1 lines)
Lines 682-688 FUNTAB R_FunTab[] = Link Here
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,   10,	{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}},
686
{"prmatrix",	do_prmatrix,	0,	111,	6,	{PP_FUNCALL, PREC_FN,	0}},
685
{"prmatrix",	do_prmatrix,	0,	111,	6,	{PP_FUNCALL, PREC_FN,	0}},
687
{"gc",		do_gc,		0,	11,	3,	{PP_FUNCALL, PREC_FN,	0}},
686
{"gc",		do_gc,		0,	11,	3,	{PP_FUNCALL, PREC_FN,	0}},
688
{"gcinfo",	do_gcinfo,	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
687
{"gcinfo",	do_gcinfo,	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
(-)src/main/print.c (-47 / +11 lines)
Lines 71-77 R_print_par_t R_print; Link Here
71
71
72
static void printAttributes(SEXP, SEXP, Rboolean);
72
static void printAttributes(SEXP, SEXP, Rboolean);
73
static void PrintSpecial(SEXP);
73
static void PrintSpecial(SEXP);
74
static void PrintLanguageEtc(SEXP, Rboolean, Rboolean);
75
static void PrintObject(SEXP, SEXP);
74
static void PrintObject(SEXP, SEXP);
76
75
77
76
Lines 156-184 SEXP attribute_hidden do_prmatrix(SEXP call, SEXP op, SEXP args, SEXP rho) Link Here
156
    return x;
155
    return x;
157
}/* do_prmatrix */
156
}/* do_prmatrix */
158
157
159
/* .Internal( print.function(f, useSource, ...)) */
158
static void PrintLanguage(SEXP s, Rboolean useSource)
160
SEXP attribute_hidden do_printfunction(SEXP call, SEXP op, SEXP args, SEXP rho)
161
{
162
    checkArity(op,args);
163
    SEXP s = CAR(args);
164
    switch (TYPEOF(s)) {
165
    case CLOSXP:
166
	PrintLanguageEtc(s, asLogical(CADR(args)), /*is closure = */ TRUE);
167
	printAttributes(s, rho, FALSE);
168
	break;
169
    case BUILTINSXP:
170
    case SPECIALSXP:
171
	PrintSpecial(s);
172
	break;
173
174
    default: /* if(!isFunction(s)) */
175
	error(_("non-function argument to .Internal(print.function(.))"));
176
    }
177
    return s;
178
}
179
180
/* PrintLanguage() or PrintClosure() : */
181
static void PrintLanguageEtc(SEXP s, Rboolean useSource, Rboolean isClosure)
182
{
159
{
183
    int i;
160
    int i;
184
    SEXP t = getAttrib(s, R_SrcrefSymbol);
161
    SEXP t = getAttrib(s, R_SrcrefSymbol);
Lines 198-221 static void PrintLanguageEtc(SEXP s, Rboolean useSource, Rboolean isClosure) Link Here
198
 	Rprintf("%s\n", translateChar(STRING_ELT(t, i))); // translate: for srcref part (PR#16732)
175
 	Rprintf("%s\n", translateChar(STRING_ELT(t, i))); // translate: for srcref part (PR#16732)
199
    }
176
    }
200
    UNPROTECT(1);
177
    UNPROTECT(1);
201
    if (isClosure) {
202
	if (isByteCode(BODY(s))) Rprintf("<bytecode: %p>\n", BODY(s));
203
	t = CLOENV(s);
204
	if (t != R_GlobalEnv)
205
	    Rprintf("%s\n", EncodeEnvironment(t));
206
    }
207
}
178
}
208
179
209
static
180
static void PrintClosure(SEXP s, Rboolean useSource)
210
void PrintClosure(SEXP s, Rboolean useSource)
211
{
181
{
212
    PrintLanguageEtc(s, useSource, TRUE);
182
    PrintLanguage(s, useSource);
213
}
214
183
215
static
184
    if (isByteCode(BODY(s)))
216
void PrintLanguage(SEXP s, Rboolean useSource)
185
        Rprintf("<bytecode: %p>\n", BODY(s));
217
{
186
    SEXP t = CLOENV(s);
218
    PrintLanguageEtc(s, useSource, FALSE);
187
    if (t != R_GlobalEnv)
188
        Rprintf("%s\n", EncodeEnvironment(t));
219
}
189
}
220
190
221
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
191
/* .Internal(print.default(x, digits, quote, na.print, print.gap,
Lines 794-803 void attribute_hidden PrintValueRec(SEXP s, SEXP env) Link Here
794
	PrintExpression(s);
764
	PrintExpression(s);
795
	break;
765
	break;
796
    case LANGSXP:
766
    case LANGSXP:
797
	PrintLanguage(s, FALSE);
767
	PrintLanguage(s, R_print.useSource);
798
	break;
768
	break;
799
    case CLOSXP:
769
    case CLOSXP:
800
	PrintClosure(s, FALSE);
770
	PrintClosure(s, R_print.useSource);
801
	break;
771
	break;
802
    case ENVSXP:
772
    case ENVSXP:
803
	Rprintf("%s\n", EncodeEnvironment(s));
773
	Rprintf("%s\n", EncodeEnvironment(s));
Lines 965-977 void attribute_hidden PrintValueEnv(SEXP s, SEXP env) Link Here
965
    tagbuf[0] = '\0';
935
    tagbuf[0] = '\0';
966
    PROTECT(s);
936
    PROTECT(s);
967
937
968
    /* FIXME: Functions are printed via base::print() in order to allow
938
    PrintDispatch(s, env);
969
       user-defined print.function() methods. This is covered by unit
970
       tests but is this needed? Why make an exception for that type? */
971
    if (isFunction(s))
972
        PrintObject(s, env);
973
    else
974
        PrintDispatch(s, env);
975
939
976
    UNPROTECT(1);
940
    UNPROTECT(1);
977
}
941
}
(-)tests/reg-tests-2.R (-4 / +5 lines)
Lines 2344-2356 attr(foo, "srcref") <- NULL Link Here
2344
foo
2344
foo
2345
(f <- structure(function(){}, note = "just a note",
2345
(f <- structure(function(){}, note = "just a note",
2346
                yada = function() "not the same"))
2346
                yada = function() "not the same"))
2347
print(f, useSource = TRUE)
2347
print(f, useSource = FALSE) # must print attributes
2348
print(f, useSource = FALSE) # must print attributes
2348
print.function <- function(x, ...) { str(x,...); invisible(x) }
2349
print.function
2350
f
2351
rm(print.function)
2352
## auto-printing and printing differed up to R 2.9.x
2349
## auto-printing and printing differed up to R 2.9.x
2353
2350
2351
# Make sure deparsing does not reset parameters
2352
print(list(f, expression(foo), f, quote(foo), f, base::list, f), useSource = FALSE)
2353
2354
2354
printCoefmat(cbind(0,1))
2355
printCoefmat(cbind(0,1))
2355
## would print NaN up to R 2.9.0
2356
## would print NaN up to R 2.9.0
2356
2357
(-)tests/reg-tests-2.Rout.save (-19 / +61 lines)
Lines 6378-6385 function(){} Link Here
6378
attr(,"note")
6378
attr(,"note")
6379
[1] "just a note"
6379
[1] "just a note"
6380
attr(,"yada")
6380
attr(,"yada")
6381
function () 
6381
function() "not the same"
6382
"not the same"
6382
> print(f, useSource = TRUE)
6383
function(){}
6384
attr(,"note")
6385
[1] "just a note"
6386
attr(,"yada")
6387
function() "not the same"
6383
> print(f, useSource = FALSE) # must print attributes
6388
> print(f, useSource = FALSE) # must print attributes
6384
function () 
6389
function () 
6385
{
6390
{
Lines 6389-6410 attr(,"note") Link Here
6389
attr(,"yada")
6394
attr(,"yada")
6390
function () 
6395
function () 
6391
"not the same"
6396
"not the same"
6392
> print.function <- function(x, ...) { str(x,...); invisible(x) }
6393
> print.function
6394
function (x, ...)  
6395
 - attr(*, "srcref")= 'srcref' int [1:8] 1 19 1 63 19 63 1 1
6396
  ..- attr(*, "srcfile")=Classes 'srcfilecopy', 'srcfile' <environment: 0x2bad828> 
6397
> f
6398
function ()  
6399
 - attr(*, "srcref")= 'srcref' int [1:8] 1 17 1 28 17 28 1 1
6400
  ..- attr(*, "srcfile")=Classes 'srcfilecopy', 'srcfile' <environment: 0x2684440> 
6401
 - attr(*, "note")= chr "just a note"
6402
 - attr(*, "yada")=function ()  
6403
  ..- attr(*, "srcref")= 'srcref' int [1:8] 2 24 2 48 24 48 2 2
6404
  .. ..- attr(*, "srcfile")=Classes 'srcfilecopy', 'srcfile' <environment: 0x2684440> 
6405
> rm(print.function)
6406
> ## auto-printing and printing differed up to R 2.9.x
6397
> ## auto-printing and printing differed up to R 2.9.x
6407
> 
6398
> 
6399
> # Make sure deparsing does not reset parameters
6400
> print(list(f, expression(foo), f, quote(foo), f, base::list, f), useSource = FALSE)
6401
[[1]]
6402
function () 
6403
{
6404
}
6405
attr(,"note")
6406
[1] "just a note"
6407
attr(,"yada")
6408
function () 
6409
"not the same"
6410
6411
[[2]]
6412
expression(foo)
6413
6414
[[3]]
6415
function () 
6416
{
6417
}
6418
attr(,"note")
6419
[1] "just a note"
6420
attr(,"yada")
6421
function () 
6422
"not the same"
6423
6424
[[4]]
6425
foo
6426
6427
[[5]]
6428
function () 
6429
{
6430
}
6431
attr(,"note")
6432
[1] "just a note"
6433
attr(,"yada")
6434
function () 
6435
"not the same"
6436
6437
[[6]]
6438
function (...)  .Primitive("list")
6439
6440
[[7]]
6441
function () 
6442
{
6443
}
6444
attr(,"note")
6445
[1] "just a note"
6446
attr(,"yada")
6447
function () 
6448
"not the same"
6449
6450
> 
6451
> 
6408
> printCoefmat(cbind(0,1))
6452
> printCoefmat(cbind(0,1))
6409
     [,1] [,2]
6453
     [,1] [,2]
6410
[1,]    0    1
6454
[1,]    0    1
Lines 7032-7039 x %^% (y %^% z) Link Here
7032
> 
7076
> 
7033
> ## Anonymous function calls were not deparsed properly
7077
> ## Anonymous function calls were not deparsed properly
7034
> substitute(f(x), list(f = function(x) x + 1))
7078
> substitute(f(x), list(f = function(x) x + 1))
7035
(function (x) 
7079
(function(x) x + 1)(x)
7036
x + 1)(x)
7037
> substitute(f(x), list(f = quote(function(x) x + 1)))
7080
> substitute(f(x), list(f = quote(function(x) x + 1)))
7038
(function(x) x + 1)(x)
7081
(function(x) x + 1)(x)
7039
> substitute(f(x), list(f = quote(f+g)))
7082
> substitute(f(x), list(f = quote(f+g)))
7040
- 

Return to bug 17398