from 88060: environment(<primitive) <- <not_NULL> now deprecated + no-op

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

Author: maechler

src/library/base/man/environment.Rd

@@ -1,6 +1,6 @@
 % File src/library/base/man/environment.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2012 R Core Team
+% Copyright 1995-2012, 2025 R Core Team
 % Distributed under GPL 2 or later
 
 \name{environment}
@@ -67,6 +67,8 @@ env.profile(env)
 
   The replacement form sets the environment of the function or formula
   \code{fun} to the \code{value} given.
+  Note that \code{\link{primitive}} functions \code{fun} have no environment and
+  trying to set it to a non-\code{NULL} value is deprecated.
 
   \code{is.environment(obj)} returns \code{TRUE} if and only if
   \code{obj} is an \code{environment}.

src/main/builtin.c

@@ -290,6 +290,7 @@ attribute_hidden SEXP do_bodyCode(SEXP call, SEXP op, SEXP args, SEXP rho)
 #define simple_as_environment(arg) (IS_S4_OBJECT(arg) && (TYPEOF(arg) == OBJSXP) ? R_getS4DataSlot(arg, ENVSXP) : arg)
 
 
+// environment(fun)
 attribute_hidden SEXP do_envir(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
     checkArity(op, args);
@@ -300,16 +301,15 @@ attribute_hidden SEXP do_envir(SEXP call, SEXP op, SEXP args, SEXP rho)
     else return getAttrib(CAR(args), R_DotEnvSymbol);
 }
 
+// environment(fun) <-  <env>
 attribute_hidden SEXP do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
 {
-    SEXP env, s = CAR(args);
-
     checkArity(op, args);
-    check1arg(args, call, "x");
-
-    env = CADR(args);
+    /* check1arg(args, call, "x"); as it had no effect: should be "fun" */
+    SEXP s  = CAR(args),
+	env = CADR(args);
 
-    if (TYPEOF(CAR(args)) == CLOSXP
+    if (TYPEOF(s) == CLOSXP
 	&& (isEnvironment(env) ||
 	    isEnvironment(env = simple_as_environment(env)) ||
 	    isNull(env))) {
@@ -321,12 +321,17 @@ attribute_hidden SEXP do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
 	    s = duplicate(s);
 	if (TYPEOF(BODY(s)) == BCODESXP)
 	    /* switch to interpreted version if compiled */
-	    SET_BODY(s, R_ClosureExpr(CAR(args)));
+	    SET_BODY(s, R_ClosureExpr(s));
 	SET_CLOENV(s, env);
     }
     else if (isNull(env) || isEnvironment(env) ||
 	isEnvironment(env = simple_as_environment(env)))
-	setAttrib(s, R_DotEnvSymbol, env);
+    {
+	if(!isNull(env) && isPrimitive(s)) // temporary, to become error()
+	    warning(_("setting environment(<primitive function>) is not possible and trying it is deprecated"));
+	else
+	    setAttrib(s, R_DotEnvSymbol, env);
+    }
     else
 	error(_("replacement object is not an environment"));
     return s;

tests/reg-tests-1e.R

@@ -1941,6 +1941,12 @@ stopifnot(identical(attr(t3, "specials"),
 ## was unchanged  y ~ x1 + (x2 | f) + (x3 | g)
 
 
+## setting environment(<primitive>) -- was mutilating the base object (in R <= 4.4.x)
+s <- sum   ; assertWarnV(environment(s) <- baseenv())
+environment(s) <- NULL # no warning (and no effect)
+r <- return; assertWarnV(environment(r) <- baseenv())
+## then an error for about one day; now is deprecated (and no longer mutating).
+
 
 
 ## keep at end