migration to .Internal

git-svn-id: https://svn.r-project.org/R/trunk@60411 00db46b3-68df-0310-9c12-caf00c1e9a41
wch · Aug 25, 2012 · 6e12f50 · 6e12f50
1 parent 12a01e6
commit 6e12f50
Show file tree

Hide file tree

Showing 17 changed files with 101 additions and 95 deletions.
diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd
@@ -273,6 +273,9 @@
       \code{.C}/\code{.Fortran}/\code{.Call} calls copied from earlier
       versions of \R no longer work -- but they were never part of the
       API.  [In progress.]
+      
+      \item Many \code{.Call()} calls in package \pkg{base} have been
+      migrated to \code{.Internal()} calls.
     }
   }
 

diff --git a/src/gnuwin32/Rdll.hide b/src/gnuwin32/Rdll.hide
@@ -573,10 +573,12 @@
  do_bcclose
  do_bcversion
  do_begin
+ do_bincode
  do_bind
  do_bindtextdomain
  do_bndIsActive
  do_bndIsLocked
+ do_bitwise
  do_body
  do_bodyCode
  do_break
@@ -612,6 +614,7 @@
  do_copyDFattr
  do_contourLines
  do_countfields
+ do_crc64
  do_cum
  do_dataentry
  do_dataviewer
@@ -676,6 +679,7 @@
  do_filerename
  do_fileshow
  do_filesymlink
+ do_findinterval
  do_first_min
  do_flush
  do_flushconsole
@@ -914,6 +918,7 @@
  do_seq
  do_seq_along
  do_seq_len
+ do_serialize
  do_serializeToConn
  do_set
  do_setFileTime
@@ -982,6 +987,7 @@
  do_systime
  do_sysumask
  do_syswhich
+ do_tabulate
  do_tempdir
  do_tempfile
  do_textconnection

diff --git a/src/include/Internal.h b/src/include/Internal.h
@@ -119,8 +119,10 @@ SEXP do_attributesgets(SEXP, SEXP, SEXP, SEXP);
 SEXP do_backsolve(SEXP, SEXP, SEXP, SEXP);
 SEXP do_basename(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_bindtextdomain(SEXP, SEXP, SEXP, SEXP);
+SEXP do_bitwise(SEXP, SEXP, SEXP, SEXP);
 SEXP do_body(SEXP, SEXP, SEXP, SEXP);
 SEXP do_bodyCode(SEXP, SEXP, SEXP, SEXP);
 SEXP do_break(SEXP, SEXP, SEXP, SEXP);
@@ -148,6 +150,7 @@ SEXP do_complex(SEXP, SEXP, SEXP, SEXP);
 SEXP do_contourLines(SEXP, SEXP, SEXP, SEXP);
 SEXP do_countfields(SEXP, SEXP, SEXP, SEXP);
 SEXP do_copyDFattr(SEXP, SEXP, SEXP, SEXP);
+SEXP do_crc64(SEXP, SEXP, SEXP, SEXP);
 SEXP do_Cstack_info(SEXP, SEXP, SEXP, SEXP);
 SEXP do_cum(SEXP, SEXP, SEXP, SEXP);
 SEXP do_D2POSIXlt(SEXP, SEXP, SEXP, SEXP);
@@ -209,6 +212,7 @@ SEXP do_fileremove(SEXP, SEXP, SEXP, SEXP);
 SEXP do_filerename(SEXP, SEXP, SEXP, SEXP);
 SEXP do_fileshow(SEXP, SEXP, SEXP, SEXP);
 SEXP do_filesymlink(SEXP, SEXP, SEXP, SEXP);
+SEXP do_findinterval(SEXP, SEXP, SEXP, SEXP);
 SEXP do_first_min(SEXP, SEXP, SEXP, SEXP);
 SEXP do_flatContour(SEXP, SEXP, SEXP, SEXP);
 SEXP do_flush(SEXP, SEXP, SEXP, SEXP);
@@ -403,6 +407,7 @@ SEXP do_search(SEXP, SEXP, SEXP, SEXP);
 SEXP do_seq(SEXP, SEXP, SEXP, SEXP);
 SEXP do_seq_along(SEXP, SEXP, SEXP, SEXP);
 SEXP do_seq_len(SEXP, SEXP, SEXP, SEXP);
+SEXP do_serialize(SEXP, SEXP, SEXP, SEXP);
 SEXP do_serializeToConn(SEXP, SEXP, SEXP, SEXP);
 SEXP do_set(SEXP, SEXP, SEXP, SEXP);
 SEXP do_setFileTime(SEXP, SEXP, SEXP, SEXP);
@@ -463,6 +468,7 @@ SEXP do_sysbrowser(SEXP, SEXP, SEXP, SEXP);
 SEXP do_sysgetpid(SEXP, SEXP, SEXP, SEXP);
 SEXP do_system(SEXP, SEXP, SEXP, SEXP);
 SEXP do_systime(SEXP, SEXP, SEXP, SEXP);
+SEXP do_tabulate(SEXP, SEXP, SEXP, SEXP);
 SEXP do_tempdir(SEXP, SEXP, SEXP, SEXP);
 SEXP do_tempfile(SEXP, SEXP, SEXP, SEXP);
 SEXP do_tilde(SEXP, SEXP, SEXP, SEXP);

diff --git a/src/library/base/R/cut.R b/src/library/base/R/cut.R
@@ -65,5 +65,5 @@ cut.default <-
 {
     if(!is.double(x)) storage.mode(x) <- "double"
     if(!is.double(breaks)) storage.mode(breaks) <- "double"
-    .Call(.C_BinCode, x, breaks, right, include.lowest)
+    .Internal(bincode(x, breaks, right, include.lowest))
 }
diff --git a/src/library/base/R/findInt.R b/src/library/base/R/findInt.R
@@ -27,6 +27,6 @@ findInterval <- function(x, vec, rightmost.closed = FALSE, all.inside = FALSE)
 	stop("'vec' contains NAs")
     if(is.unsorted(vec))
 	stop("'vec' must be sorted non-decreasingly")
-    .Call(.C_FindIntervVec, as.double(vec), as.double(x),
-          rightmost.closed, all.inside)
+    .Internal(findInterval(as.double(vec), as.double(x),
+                           rightmost.closed, all.inside))
 }
diff --git a/src/library/base/R/octhex.R b/src/library/base/R/octhex.R
@@ -115,21 +115,21 @@ as.hexmode <- function(x)
 
 
 `!.octmode` <- function(a)
-    as.octmode(.Call(.C_bitwiseNot, as.octmode(a)))
+    as.octmode(.Internal(bitwiseNot(as.octmode(a))))
 
 `&.octmode` <- function(a, b)
-    as.octmode(.Call(.C_bitwiseAnd, as.octmode(a), as.octmode(b)))
+    as.octmode(.Internal(bitwiseAnd(as.octmode(a), as.octmode(b))))
 `|.octmode` <- function(a, b)
-    as.octmode(.Call(.C_bitwiseOr, as.octmode(a), as.octmode(b)))
+    as.octmode(.Internal(bitwiseOr(as.octmode(a), as.octmode(b))))
 xor.octmode <- function(a, b)
-    as.octmode(.Call(.C_bitwiseXor, as.octmode(a), as.octmode(b)))
+    as.octmode(.Internal(bitwiseXor(as.octmode(a), as.octmode(b))))
 
 `!.hexmode` <- function(a)
-    as.hexmode(.Call(.C_bitwiseNot, as.hexmode(a)))
+    as.hexmode(.Internal(bitwiseNot(as.hexmode(a))))
 
 `&.hexmode` <- function(a, b)
-    as.hexmode(.Call(.C_bitwiseAnd, as.hexmode(a), as.hexmode(b)))
+    as.hexmode(.Internal(bitwiseAnd(as.hexmode(a), as.hexmode(b))))
 `|.hexmode` <- function(a, b)
-    as.hexmode(.Call(.C_bitwiseOr, as.hexmode(a), as.hexmode(b)))
+    as.hexmode(.Internal(bitwiseOr(as.hexmode(a), as.hexmode(b))))
 xor.hexmode <- function(a, b)
-    as.hexmode(.Call(.C_bitwiseXor, as.hexmode(a), as.hexmode(b)))
+    as.hexmode(.Internal(bitwiseXor(as.hexmode(a), as.hexmode(b))))
diff --git a/src/library/base/R/serialize.R b/src/library/base/R/serialize.R
@@ -59,10 +59,10 @@ serialize <-
         if (missing(ascii)) ascii <- summary(connection)$text == "text"
     }
     if (!ascii && inherits(connection, "sockconn"))
-        .Call(.C_R_serializeb, object, connection, xdr, version, refhook)
+        .Internal(serializeb(object, connection, xdr, version, refhook))
     else {
         if (!isTRUE(ascii) && !xdr) ascii <- NA
-        .Call(.C_R_serialize, object, connection, ascii, version, refhook)
+        .Internal(serialize(object, connection, ascii, version, refhook))
     }
 }
 
@@ -72,5 +72,5 @@ unserialize <- function(connection, refhook = NULL)
         !is.character(connection) &&
         !inherits(connection, "connection"))
         stop("'connection' must be a connection")
-    .Call(.C_R_unserialize, connection, refhook)
+    .Internal(unserialize(connection, refhook))
 }
diff --git a/src/library/base/R/tabulate.R b/src/library/base/R/tabulate.R
@@ -26,5 +26,5 @@ tabulate <- function(bin, nbins = max(1L, bin, na.rm = TRUE))
         stop("attempt to make a table with >= 2^31 elements")
     nbins <- as.integer(nbins)
     if (is.na(nbins)) stop("invalid value of 'nbins'")
-    .Call(.C_R_Tabulate, bin, nbins)
+    .Internal(tabulate(bin, nbins))
 }
diff --git a/src/library/base/man/base-internal.Rd b/src/library/base/man/base-internal.Rd
@@ -32,8 +32,6 @@
 \alias{.methodsNamespace} % created by the methods package ....
 \alias{.popath}
 
-\alias{.C_BinCode}
-\alias{.C_FindIntervVec}
 \alias{.C_La_chol}
 \alias{.C_La_chol2inv}
 \alias{.C_La_dgecon}
@@ -51,29 +49,18 @@
 \alias{.C_La_zgeqp3}
 \alias{.C_La_zgesv}
 \alias{.C_La_ztrcon}
-\alias{.C_R_Tabulate}
 \alias{.C_R_addTaskCallback}
-\alias{.C_R_compress1}
-\alias{.C_R_decompress1}
 \alias{.C_R_getTaskCallbackNames}
 \alias{.C_R_getbcprofcounts}
 \alias{.C_R_pretty}
 \alias{.C_R_removeTaskCallback}
-\alias{.C_R_serialize}
-\alias{.C_R_serializeb}
 \alias{.C_R_setS4Object}
 \alias{.C_R_startbcprof}
 \alias{.C_R_stopbcprof}
 \alias{.C_R_traceOnOff}
-\alias{.C_R_unserialize}
 \alias{.C_Rrowsum_df}
 \alias{.C_Rrowsum_matrix}
 \alias{.C_bincode}
-\alias{.C_bitwiseAnd}
-\alias{.C_bitwiseNot}
-\alias{.C_bitwiseOr}
-\alias{.C_bitwiseXor}
-\alias{.C_crc64ToString}
 \alias{.C_det_ge_real}
 \alias{.C_qr_coef_cmplx}
 \alias{.C_qr_coef_real}

diff --git a/src/library/utils/R/packages.R b/src/library/utils/R/packages.R
@@ -551,7 +551,7 @@ installed.packages <-
             base <- paste(c(lib, fields), collapse = ",")
             ## add length and 64-bit CRC in hex (in theory, seems
             ## it is actually 32-bit on some systems)
-            enc <- sprintf("%d_%s", nchar(base), .Call(.C_crc64ToString, base))
+            enc <- sprintf("%d_%s", nchar(base), .Internal(crc64(base)))
             dest <- file.path(tempdir(), paste0("libloc_", enc, ".rds"))
             if(file.exists(dest) &&
                file.info(dest)$mtime > file.info(lib)$mtime &&

diff --git a/src/main/basedecl.h b/src/main/basedecl.h
@@ -27,6 +27,7 @@ void Rsocklisten(int *, char **, int *);
 void Rsockclose(int *);
 void Rsockread(int *, char **, int *);
 void Rsockwrite(int *, char **, int *, int *, int *);
+
 SEXP La_svd(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
 SEXP La_rs(SEXP, SEXP);
 SEXP La_rg(SEXP, SEXP);
@@ -64,28 +65,6 @@ void F77_SYMBOL(dchdc)(double *, int *, int *, double *, int *, int *, int *);
 void F77_SYMBOL(dpbfa)(double *, int *, int *, int *, int *);
 void F77_SYMBOL(dpbsl)(double *, int *, int *, int *, double *);
 
-SEXP R_compress1(SEXP);
-SEXP R_decompress1(SEXP);
-
-SEXP R_serializeb(SEXP, SEXP, SEXP, SEXP, SEXP);
-SEXP R_serialize(SEXP, SEXP, SEXP, SEXP, SEXP);
-SEXP R_unserialize(SEXP, SEXP);
-
-//SEXP R_getVarsFromFrame(SEXP, SEXP, SEXP);
-//SEXP R_lazyLoadDBinsertValue(SEXP, SEXP, SEXP, SEXP, SEXP);
-//SEXP R_lazyLoadDBflush(SEXP);
-
 SEXP R_getbcprofcounts(void);
 SEXP R_startbcprof(void);
 SEXP R_stopbcprof(void);
-
-SEXP bitwiseNot(SEXP);
-SEXP bitwiseAnd(SEXP, SEXP);
-SEXP bitwiseOr(SEXP, SEXP);
-SEXP bitwiseXor(SEXP, SEXP);
-SEXP crc64ToString(SEXP);
-
-SEXP BinCode(SEXP x, SEXP breaks, SEXP right, SEXP lowest);
-SEXP R_Tabulate(SEXP in, SEXP nbin);
-SEXP FindIntervVec(SEXP xt, SEXP x, SEXP right, SEXP inside);
-
diff --git a/src/main/names.c b/src/main/names.c
@@ -995,6 +995,17 @@ FUNTAB R_FunTab[] =
 {"lazyLoadDBflush",do_lazyLoadDBflush,0,11,	1,	{PP_FUNCALL, PREC_FN,	0}},
 {"getVarsFromFrame",do_getVarsFromFrame, 0,	11,	3,	{PP_FUNCALL, PREC_FN,	0}},
 {"lazyLoadDBinsertValue",do_lazyLoadDBinsertValue, 0,	11,	5,	{PP_FUNCALL, PREC_FN,	0}},
+{"bincode",	do_bincode,	 0,	11,	4,	{PP_FUNCALL, PREC_FN,	0}},
+{"tabulate",	do_tabulate,	 0,	11,	2,	{PP_FUNCALL, PREC_FN,	0}},
+{"findInterval",do_findinterval, 0,	11,	4,	{PP_FUNCALL, PREC_FN,	0}},
+{"crc64",	do_crc64, 	0,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
+{"bitwiseAnd",	do_bitwise, 	1,	11,	2,	{PP_FUNCALL, PREC_FN,	0}},
+{"bitwiseNot",	do_bitwise, 	2,	11,	1,	{PP_FUNCALL, PREC_FN,	0}},
+{"bitwiseOr",	do_bitwise, 	3,	11,	2,	{PP_FUNCALL, PREC_FN,	0}},
+{"bitwiseXor",	do_bitwise, 	4,	11,	2,	{PP_FUNCALL, PREC_FN,	0}},
+{"serialize",	do_serialize, 	0,	11,	5,	{PP_FUNCALL, PREC_FN,	0}},
+{"serializeb",	do_serialize, 	1,	11,	5,	{PP_FUNCALL, PREC_FN,	0}},
+{"unserialize",	do_serialize, 	2,	11,	2,	{PP_FUNCALL, PREC_FN,	0}},
 
 {NULL,		NULL,		0,	0,	0,	{PP_INVALID, PREC_FN,	0}},
 };

diff --git a/src/main/registration.c b/src/main/registration.c
@@ -137,31 +137,10 @@ static R_CallMethodDef callMethods [] = {
     CALLDEF(R_traceOnOff, 1),
     CALLDEF(R_setS4Object, 3),
 
-    /* compression and serialization routines */
-    CALLDEF(R_compress1, 1),
-    CALLDEF(R_decompress1, 1),
-    CALLDEF(R_serializeb, 5),
-    CALLDEF(R_serialize, 5),
-    CALLDEF(R_unserialize, 2),
-
-    /* lazy loading support */
-//    CALLDEF(R_getVarsFromFrame, 3),
-//    CALLDEF(R_lazyLoadDBinsertValue, 5),
-//    CALLDEF(R_lazyLoadDBflush, 1),
-
     CALLDEF(R_getbcprofcounts, 0),
     CALLDEF(R_startbcprof, 0),
     CALLDEF(R_stopbcprof, 0),
 
-    CALLDEF(bitwiseNot, 1),
-    CALLDEF(bitwiseAnd, 2),
-    CALLDEF(bitwiseOr,  2),
-    CALLDEF(bitwiseXor, 2),
-
-    CALLDEF(crc64ToString, 1),
-    CALLDEF(BinCode, 4),
-    CALLDEF(R_Tabulate, 2),
-    CALLDEF(FindIntervVec, 4),
 
     {NULL, NULL, 0}
 };

diff --git a/src/main/relop.c b/src/main/relop.c
@@ -638,7 +638,7 @@ static SEXP raw_relop(RELOP_TYPE code, SEXP s1, SEXP s2)
 }
 
 
-SEXP bitwiseNot(SEXP a)
+static SEXP bitwiseNot(SEXP a)
 {
     R_xlen_t  i, m = XLENGTH(a);
     SEXP ans = allocVector(INTSXP, m);
@@ -647,7 +647,7 @@ SEXP bitwiseNot(SEXP a)
 }
 
 #define mymax(x, y) ((x >= y) ? x : y)
-SEXP bitwiseAnd(SEXP a, SEXP b)
+static SEXP bitwiseAnd(SEXP a, SEXP b)
 {
     R_xlen_t  i, m = XLENGTH(a), n = XLENGTH(b), mn = (m && n) ? mymax(m, n) : 0;
     SEXP ans = allocVector(INTSXP, mn);
@@ -656,7 +656,7 @@ SEXP bitwiseAnd(SEXP a, SEXP b)
     return ans;
 }
 
-SEXP bitwiseOr(SEXP a, SEXP b)
+static SEXP bitwiseOr(SEXP a, SEXP b)
 {
     R_xlen_t  i, m = XLENGTH(a), n = XLENGTH(b), mn = (m && n) ? mymax(m, n) : 0;
     SEXP ans = allocVector(INTSXP, mn);
@@ -665,11 +665,24 @@ SEXP bitwiseOr(SEXP a, SEXP b)
     return ans;
 }
 
-SEXP bitwiseXor(SEXP a, SEXP b)
+static SEXP bitwiseXor(SEXP a, SEXP b)
 {
     R_xlen_t i,  m = XLENGTH(a), n = XLENGTH(b), mn = (m && n) ? mymax(m, n) : 0;
     SEXP ans = allocVector(INTSXP, mn);
     for(i = 0; i < mn; i++)
 	INTEGER(ans)[i] = INTEGER(a)[i%m] ^ INTEGER(b)[i%n];
     return ans;
 }
+
+SEXP attribute_hidden do_bitwise(SEXP call, SEXP op, SEXP args, SEXP env)
+{
+    checkArity(op, args);
+    SEXP ans = R_NilValue; /* -Wall */
+    switch(PRIMVAL(op)) {
+    case 1: ans = bitwiseAnd(CAR(args), CADR(args)); break;
+    case 2: ans = bitwiseNot(CAR(args)); break;
+    case 3: ans = bitwiseOr(CAR(args), CADR(args)); break;
+    case 4: ans = bitwiseXor(CAR(args), CADR(args)); break;
+    }
+    return ans;
+}
diff --git a/src/main/serialize.c b/src/main/serialize.c
@@ -2680,6 +2680,7 @@ SEXP attribute_hidden R_getVarsFromFrame(SEXP vars, SEXP env, SEXP forcesxp)
     return val;
 }
 
+/* from connections.c */
 SEXP R_compress1(SEXP in);
 SEXP R_decompress1(SEXP in);
 SEXP R_compress2(SEXP in);
@@ -2768,3 +2769,22 @@ do_lazyLoadDBinsertValue(SEXP call, SEXP op, SEXP args, SEXP env)
     hook = CAR(args); args = CDR(args);
     return R_lazyLoadDBinsertValue(value, file, ascii, compsxp, hook);
 }
+
+SEXP attribute_hidden
+do_serialize(SEXP call, SEXP op, SEXP args, SEXP env)
+{
+    checkArity(op, args);
+    if (PRIMVAL(op) == 2) return R_unserialize(CAR(args), CADR(args));
+
+    SEXP object, icon, type, ver, fun;
+    object = CAR(args); args = CDR(args);
+    icon = CAR(args); args = CDR(args);
+    type = CAR(args); args = CDR(args); // ascii or xdr
+    ver = CAR(args); args = CDR(args);
+    fun = CAR(args);
+
+    if(PRIMVAL(op) == 1)
+	return R_serializeb(object, icon, type, ver, fun);
+    else
+	return R_serialize(object, icon, type, ver, fun);
+}