removeSource() also in formals() & in sub-fun`s

git-svn-id: https://svn.r-project.org/R/trunk@85735 00db46b3-68df-0310-9c12-caf00c1e9a41

doc/NEWS.Rd

@@ -513,6 +513,10 @@
       w/o arguments and atomic \emph{constant} \code{body(f)}.
 
       \item Correct \code{as.function(<invalid list>, .)}'s error message.
+
+      \item \code{removeSource()} is yet more thorough in finding and
+      removing \code{"srcref"} and the other source references from parsed
+      \R language chunks, fixing \PR{18638} thanks to Andrew Simmons.
     }
   }
 }

src/library/utils/R/sourceutils.R

@@ -1,7 +1,7 @@
 #  File src/library/utils/R/sourceutils.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2018 The R Core Team
+#  Copyright (C) 1995-2023 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -21,9 +21,17 @@ removeSource <- function(fn) {
 
     recurse <- function(part) {
         if (is.name(part)) return(part)  # handles missing arg, PR#15957
+        if (inherits(part, "srcref")) return(NULL)
         attr(part, "srcref") <- NULL
         attr(part, "wholeSrcref") <- NULL
         attr(part, "srcfile") <- NULL
+
+        if (is.pairlist(part)) { # source references from formal arguments of sub-functions
+            ## PR#18638, Andrew Simmons
+            for (i in seq_along(part))
+                part[i] <- list(recurse(part[[i]]))
+            return(as.pairlist(part))
+        }
 	if (is.language(part) && is.recursive(part)) {
 	    for (i in seq_along(part))
 		part[i] <- list(recurse(part[[i]])) # recurse(*) may be NULL
@@ -36,6 +44,7 @@ removeSource <- function(fn) {
             attr(fn, "srcref") <- NULL
             ## `body<-`(f, *) drops all attributes of f
             at <- attributes(fn)
+            formals(fn) <- recurse(formals(fn))
             attr(body(fn), "wholeSrcref") <- NULL
             attr(body(fn), "srcfile") <- NULL
             body(fn) <- recurse(body(fn))
@@ -50,6 +59,7 @@ removeSource <- function(fn) {
 	stop("argument is not a function or language object:", typeof(fn))
 }
 
+
 getSrcFilename <- function(x, full.names=FALSE, unique=TRUE) {
     srcref <- getSrcref(x)
     if (is.list(srcref))
@@ -138,9 +148,8 @@ getParseData <- function(x, includeText = NA) {
     srcfile <- if(inherits(x, "srcfile")) x else getSrcfile(x)
     if (is.null(srcfile))
     	return(NULL)
-    else
-    	data <- srcfile$parseData
-
+
+    data <- srcfile$parseData
     if (is.null(data) && !is.null(srcfile$original))
         data <- srcfile$original$parseData
 

tests/reg-tests-1e.R

@@ -1139,6 +1139,37 @@ stopifnot(!englishMsgs || grepl("invalid formal argument list", msg),
 ## had "function" wrongly in R <= 4.3.x
 
 
+## removeSource() checking *formals* incl in sub-functions -- PR#18638
+f <- function(x = {}) {
+    function(y = {}) { NULL }
+}
+str(lapply(formals(f), attributes)) # list(x = list(srcref = .., srcfile = .. wholeSrcref = ..))
+f0 <- removeSource(f) # was unchanged in R <= 4.3.2
+## in sub function {not atttrib}:
+(toplev <- !sys.nframe())
+op <- options(keep.source = TRUE)
+qf <- quote(function() NULL)
+str(qf4 <- qf[[4]]) # srcref, now removed:
+qf0 <- removeSource(qf)
+stopifnot(exprs = {
+    ## no "srcref" anymore for the formals of f0 or its result:
+    identical(lapply(formals(f0),   attributes), list(x = NULL))
+    identical(lapply(formals(f0()), attributes), list(y = NULL))
+    ##
+    length(qf) == 4L
+    length(qf0)== 4L
+    is.integer(qf4)
+    length(qf4) >= 8
+    if(toplev) # e.g., when source()d
+        qf4 == c(1L, 13L, 1L, 27L, 13L, 27L, 1L, 1L) # in qf[] but not in qf0[]
+    else
+        qf4 >= 1L
+    is.null(qf0[[4L]])
+})
+options(op)
+## f0 and qf0 were unchanged, keeping srcref in R <= 4.3.*
+
+
 
 ## keep at end
 rbind(last =  proc.time() - .pt,