Add R_GetBindingType based on proposals in PR18928.

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

Author: luke

doc/NEWS.Rd

@@ -429,6 +429,9 @@
       \code{SET_HASHTAB}, \code{SET_NAMED}, \code{SET_S4_OBJECT},
       \code{SET_TRUELENGTH}, \code{STDVEC_DATAPTR}, \code{TRUELENGTH},
       \code{UNSET_S4_OBJECT}, \code{XTRUELENGTH}.
+
+      \item New experimental function \code{R_GetBindingType} to support
+      inspecting environments without forcing delayed or active bindings.
     }
   }
 

doc/manual/R-exts.texi

@@ -17875,8 +17875,8 @@ most uses the functions @code{R_getVar} and @code{R_getVarEx} added in
 
 In rare cases package @R{} or C code may want to obtain more detailed
 information on a binding, such as whether the binding is delayed or
-not. This is currently not possible within the API, but is under
-consideration.
+not. An experimental function @code{R_GetBindingType} is now available.
+@eapifun R_GetBindingType
 
 @node Some backports
 @subsection Some backports

src/include/Internal.h

@@ -83,6 +83,7 @@ SEXP do_bcprofstop(SEXP, SEXP, SEXP, SEXP);
 SEXP do_begin(SEXP, SEXP, SEXP, SEXP);
 SEXP do_bincode(SEXP, SEXP, SEXP, SEXP);
 SEXP do_bind(SEXP, SEXP, SEXP, SEXP);
+SEXP do_bindingType(SEXP, SEXP, SEXP, SEXP);
 SEXP do_bindtextdomain(SEXP, SEXP, SEXP, SEXP);
 SEXP do_bitwise(SEXP, SEXP, SEXP, SEXP);
 SEXP do_body(SEXP, SEXP, SEXP, SEXP);

src/include/Rinternals.h

@@ -660,6 +660,17 @@ SEXP R_UnwindProtect(SEXP (*fun)(void *data), void *data,
                      void *cleandata, SEXP cont); // context.c
 
 /* Environment and Binding Features */
+typedef enum {
+    R_BindingTypeUnbound = 0,  // Unbound in this environment
+    R_BindingTypeValue = 1,    // Direct value binding
+    R_BindingTypeMissing = 2,  // Missing argument
+    R_BindingTypeDelayed = 3,  // Delayed (promise)
+    R_BindingTypeForced = 4,   // Forced (promise)
+    R_BindingTypeActive = 5,   // Active binding
+} R_BindingType_t;
+
+R_BindingType_t R_GetBindingType(SEXP sym, SEXP env);
+
 SEXP R_NewEnv(SEXP, int, int);
 Rboolean R_IsPackageEnv(SEXP rho); // envir.c
 SEXP R_PackageEnvName(SEXP rho);

src/main/envir.c

@@ -775,6 +775,78 @@ static SEXP R_GetGlobalCacheLoc(SEXP symbol)
 }
 #endif /* USE_GLOBAL_CACHE */
 
+
+/*----------------------------------------------------------------------
+  R_GetBindingType
+*/
+
+static R_BindingType_t BINDING_TYPE(SEXP cell)
+{
+    if (BNDCELL_TAG(cell))
+	// avoid expanding immediate values
+        return R_BindingTypeValue;
+    else if (IS_ACTIVE_BINDING(cell))
+        return R_BindingTypeActive;
+    else {
+	SEXP value = CAR(cell);
+	if (value == R_MissingArg)
+	    return R_BindingTypeMissing;
+	else if (TYPEOF(value) == PROMSXP) {
+	    if (PROMISE_IS_EVALUATED(value))
+		return R_BindingTypeForced;
+	    else
+		return R_BindingTypeDelayed;
+	}
+	else 
+	    return R_BindingTypeValue;
+    }
+}
+
+static R_BindingType_t SYMBOL_BINDING_TYPE(SEXP cell)
+{
+    // probably no need to support symbol bindings
+    error("symbol bindings not supported yet");
+}
+
+attribute_hidden
+R_BindingType_t R_GetVarLocType(R_varloc_t vl)
+{
+    SEXP cell = vl.cell;
+    if (cell == NULL || cell == R_UnboundValue)
+        return R_BindingTypeUnbound;
+    else if (TYPEOF(cell) == SYMSXP)
+	return SYMBOL_BINDING_TYPE(cell);
+    else
+	return BINDING_TYPE(cell);
+}
+
+R_BindingType_t R_GetBindingType(SEXP sym, SEXP env) {
+    if (TYPEOF(sym) != SYMSXP)
+	error(_("not a symbol"));
+    if (TYPEOF(env) != ENVSXP)
+	error(_("not an environment"));
+
+    R_varloc_t loc = R_findVarLocInFrame(env, sym);
+    return R_GetVarLocType(loc);
+}
+
+attribute_hidden SEXP do_bindingType(SEXP call, SEXP op, SEXP args, SEXP rho)
+{
+    checkArity(op, args);
+    SEXP sym = CAR(args);
+    SEXP env = CADR(args);
+    switch(R_GetBindingType(sym, env)) {
+    case R_BindingTypeUnbound: return mkString("unbound");
+    case R_BindingTypeValue: return mkString("value");
+    case R_BindingTypeMissing: return mkString("missing");
+    case R_BindingTypeDelayed: return mkString("delayed");
+    case R_BindingTypeForced: return mkString("forced");
+    case R_BindingTypeActive: return mkString("active");
+    default: error("unknown binding type; should not happen");
+    }
+}
+
+
 /*----------------------------------------------------------------------
 
   unbindVar

src/main/names.c

@@ -922,6 +922,7 @@ FUNTAB R_FunTab[] =
 {"makeActiveBinding", do_mkActiveBnd,	0, 111,	3,      {PP_FUNCALL, PREC_FN,	0}},
 {"bindingIsActive", do_bndIsActive,	0, 11,	2,      {PP_FUNCALL, PREC_FN,	0}},
 {"activeBindingFunction", do_activeBndFun,	0, 11,	2,      {PP_FUNCALL, PREC_FN,	0}},
+{"getBindingType", do_bindingType,	0, 11,	2,      {PP_FUNCALL, PREC_FN,	0}},
 {"mkUnbound",	do_mkUnbound,		0, 111,	1,      {PP_FUNCALL, PREC_FN,	0}},
 {"isNamespaceEnv",do_isNSEnv,		0, 11,	1,      {PP_FUNCALL, PREC_FN,	0}},
 {"registerNamespace",do_regNS,		0, 11,	2,      {PP_FUNCALL, PREC_FN,	0}},

tests/reg-tests-1e.R

@@ -2614,6 +2614,29 @@ stopifnot(identical(strX2 , strX2. ), noListof(strX2. ),
           identical(strXs2, strXs2.), noListof(strXs2.))
 ## strXs?2. did have 'List of' in R <= 4.5.z
 
+## simple test for R_GetBindingType
+local({
+    getBindingType <- function(sym, env) {
+        if (is.character(sym)) 
+            sym <- as.name(sym)
+        .Internal(getBindingType(sym, env))
+    }
+    f0 <- function() getBindingType("x", environment())
+    stopifnot(f0() == "unbound")
+    f1 <- function() { x <- 1; getBindingType("x", environment())}
+    stopifnot(f1() == "value")
+    f2 <- function(x) getBindingType("x", environment())
+    stopifnot(f2() == "missing")
+    f3 <- function(x) getBindingType("x", environment())
+    stopifnot(f3(1) == "delayed")
+    f4 <- function(x) { x; getBindingType("x", environment())}
+    stopifnot(f4(1) == "forced")
+    f5 <- function() {
+        makeActiveBinding("x", \(x) 1, environment())
+        getBindingType("x", environment())
+    }
+    stopifnot(f5() == "active")
+})
 
 
 ## keep at end