Implement dots interface

Author: shikokuchuo

src/include/Rinternals.h

@@ -708,6 +708,22 @@ Rboolean R_BindingIsActive(SEXP sym, SEXP env); // envir.c
 SEXP R_ActiveBindingFunction(SEXP sym, SEXP env);
 Rboolean R_HasFancyBindings(SEXP rho); // envir.c
 
+/* Dots interface */
+typedef enum {
+    R_DotTypeValue = 0,     
+    R_DotTypeMissing = 1, 
+    R_DotTypeDelayed = 2,    
+    R_DotTypeForced = 3    
+} R_DotType;
+
+Rboolean R_DotsExist(SEXP env); // envir.c
+int R_DotsLength(SEXP env);
+SEXP R_DotsNames(SEXP env);
+SEXP R_DotsElt(int i, SEXP env);
+
+SEXP R_DotDelayedExpression(int i, SEXP env); // envir.c
+SEXP R_DotDelayedEnvironment(int i, SEXP env);
+SEXP R_DotForcedExpression(int i, SEXP env); 
 
 /* ../main/errors.c : */
 /* needed for R_load/savehistory handling in front ends */

src/main/envir.c

@@ -1425,6 +1425,11 @@ static int ddVal(SEXP symbol)
 
 #define length_DOTS(_v_) (TYPEOF(_v_) == DOTSXP ? length(_v_) : 0)
 
+Rboolean R_DotsExist(SEXP env)
+{
+    return R_findVar(R_DotsSymbol, env) != R_UnboundValue;
+}
+
 SEXP ddfind(int i, SEXP rho)
 {
     if(i <= 0)
@@ -1453,6 +1458,11 @@ SEXP ddfindVar(SEXP symbol, SEXP rho)
     return ddfind(i, rho);
 }
 
+SEXP R_DotsElt(int i, SEXP env)
+{
+    return eval(ddfind(i, env), env);
+}
+
 attribute_hidden SEXP do_dotsElt(SEXP call, SEXP op, SEXP args, SEXP env)
 {
     checkArity(op, args);
@@ -1465,23 +1475,26 @@ attribute_hidden SEXP do_dotsElt(SEXP call, SEXP op, SEXP args, SEXP env)
     return eval(ddfind(i, env), env);
 }
 
-attribute_hidden SEXP do_dotsLength(SEXP call, SEXP op, SEXP args, SEXP env)
+int R_DotsLength(SEXP env)
 {
-    checkArity(op, args);
     SEXP vl = R_findVar(R_DotsSymbol, env);
     if (vl == R_UnboundValue)
-	error(_("incorrect context: the current call has no '...' to look in"));
+        error(_("incorrect context: the current call has no '...' to look in"));
     // else
-    return ScalarInteger(length_DOTS(vl));
+    return length_DOTS(vl);
 }
 
-attribute_hidden SEXP do_dotsNames(SEXP call, SEXP op, SEXP args, SEXP env)
+attribute_hidden SEXP do_dotsLength(SEXP call, SEXP op, SEXP args, SEXP env)
 {
     checkArity(op, args);
+    return ScalarInteger(R_DotsLength(env));
+}
+
+SEXP R_DotsNames(SEXP env) {
     SEXP vl = R_findVar(R_DotsSymbol, env);
     PROTECT(vl);
     if (vl == R_UnboundValue)
-	error(_("incorrect context: the current call has no '...' to look in"));
+	    error(_("incorrect context: the current call has no '...' to look in"));
     // else
     SEXP out;
     int n = length_DOTS(vl);
@@ -1504,6 +1517,63 @@ attribute_hidden SEXP do_dotsNames(SEXP call, SEXP op, SEXP args, SEXP env)
     return out;
 }
 
+attribute_hidden SEXP do_dotsNames(SEXP call, SEXP op, SEXP args, SEXP env)
+{
+    checkArity(op, args);
+    return R_DotsNames(env);
+}
+
+// Dot helpers
+// For all helpers:
+// - If dots don't exist, should error, as you should use `R_DotsExist()` first
+// - OOB indexing should error, as you should use `R_DotsLength()` first
+
+R_DotType R_GetDotType(int i, SEXP env)
+{
+    SEXP value = ddfind(i, env);
+
+    if (value == R_MissingArg)
+        return R_DotTypeMissing;
+
+    if (TYPEOF(value) == PROMSXP) {
+	    if (PROMISE_IS_EVALUATED(value))
+	        return R_DotTypeForced;
+	    else
+	        return R_DotTypeDelayed;
+    }
+
+    return R_DotTypeValue;
+}
+
+// For `R_DotTypeDelayed`
+SEXP R_DotDelayedExpression(int i, SEXP env)
+{
+    SEXP value = ddfind(i, env);
+    if (TYPEOF(value) != PROMSXP || PROMISE_IS_EVALUATED(value))
+        error(_("not a delayed promise"));
+
+    return R_PromiseExpr(value);
+}
+
+SEXP R_DotDelayedEnvironment(int i, SEXP env)
+{
+    SEXP value = ddfind(i, env);
+    if (TYPEOF(value) != PROMSXP || PROMISE_IS_EVALUATED(value))
+        error(_("not a delayed promise"));
+
+    return PRENV(value);
+}
+
+// For `R_DotTypeForced`
+SEXP R_DotForcedExpression(int i, SEXP env)
+{
+    SEXP value = ddfind(i, env);
+    if (TYPEOF(value) != PROMSXP || !PROMISE_IS_EVALUATED(value))
+        error(_("not a forced promise"));
+
+    return R_PromiseExpr(value);
+}
+
 #undef length_DOTS
 
 /*----------------------------------------------------------------------