From 256646587ada9b5ccbefc0b150b8fcb549adcac4 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 20:12:40 -0400 Subject: [PATCH 01/22] define OBJSXP --- src/include/Rinternals.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/include/Rinternals.h b/src/include/Rinternals.h index 17affccb12b..6a1244304fe 100644 --- a/src/include/Rinternals.h +++ b/src/include/Rinternals.h @@ -129,7 +129,8 @@ typedef unsigned int SEXPTYPE; #define EXTPTRSXP 22 /* external pointer */ #define WEAKREFSXP 23 /* weak reference */ #define RAWSXP 24 /* raw bytes */ -#define S4SXP 25 /* S4, non-vector */ +#define OBJSXP 25 /* Object, non-vector */ +#define S4SXP 25 /* Same as OBJSXP, name retained for backwards compatability */ /* used for detecting PROTECT issues in memory.c */ #define NEWSXP 30 /* fresh node created in new page */ From 34403eed3d95487f13a475379a2744fa2d861a61 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 20:15:26 -0400 Subject: [PATCH 02/22] ad-hoc OBJSXP constructor (for testing) --- src/include/Internal.h | 2 ++ src/main/names.c | 5 +++++ src/main/objects.c | 15 +++++++++++++++ 3 files changed, 22 insertions(+) diff --git a/src/include/Internal.h b/src/include/Internal.h index 5f64413a381..7ea9ab99166 100644 --- a/src/include/Internal.h +++ b/src/include/Internal.h @@ -466,6 +466,8 @@ SEXP R_do_data_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_do_set_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_getS4DataSlot(SEXP obj, SEXPTYPE type); +SEXP do_dot_new_object(SEXP, SEXP, SEXP, SEXP); + /* hash tables (temporary support for R-level experimenting and debugging) */ SEXP do_vhash(SEXP, SEXP, SEXP, SEXP); diff --git a/src/main/names.c b/src/main/names.c index 8c96092ffae..ac7d5363c5e 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -159,6 +159,7 @@ FUNTAB R_FunTab[] = {"getNamespaceValue", do_getNSValue, 0, 211, 3, {PP_FUNCALL, PREC_FN, 0}}, + /* Binary Operators, all primitives */ /* these are group generic and so need to eval args */ {"+", do_arith, PLUSOP, 1, -1, {PP_BINARY, PREC_SUM, 0}}, @@ -1006,6 +1007,10 @@ FUNTAB R_FunTab[] = {"curlDownload",do_curlDownload, 0, 11, 6, {PP_FUNCALL, PREC_FN, 0}}, {"compilerVersion",do_compilerVersion, 0, 11, 0, {PP_FUNCALL, PREC_FN, 0}}, + +{".new_object", do_dot_new_object, 0, 0, 1, {PP_FUNCALL, PREC_FN, 0}}, + + {NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}, }; diff --git a/src/main/objects.c b/src/main/objects.c index a4369697009..131272eac1c 100644 --- a/src/main/objects.c +++ b/src/main/objects.c @@ -1021,6 +1021,21 @@ attribute_hidden SEXP do_inherits(SEXP call, SEXP op, SEXP args, SEXP env) return inherits3(x, what, which); } +attribute_hidden SEXP do_dot_new_object(SEXP call, SEXP op, SEXP args, SEXP env) +{ + // returns an S4SXP/OBJSXP object. If the first arg is a character vector, + // it is set as the class of the object. The S4 bit is not set. + checkArity(op, args); + SEXP class = CAR(args); + + SEXP obj = PROTECT(Rf_allocSExp(OBJSXP)); + + if (TYPEOF(class) == STRSXP && LENGTH(class) >= 1) + Rf_classgets(obj, class); + UNPROTECT(1); + + return obj; +} /* ============================================================== From 582d24699805a50b39ae220ff18d8002a63628a1 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 20:16:34 -0400 Subject: [PATCH 03/22] swap some `TYPEOF(S4SXP)` with `IS_S4_OBJECT()` --- src/library/methods/src/methods_list_dispatch.c | 2 +- src/main/attrib.c | 6 +++--- src/main/objects.c | 10 +++++----- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/library/methods/src/methods_list_dispatch.c b/src/library/methods/src/methods_list_dispatch.c index c7df2834c45..e45695a64bf 100644 --- a/src/library/methods/src/methods_list_dispatch.c +++ b/src/library/methods/src/methods_list_dispatch.c @@ -984,7 +984,7 @@ SEXP R_getClassFromCache(SEXP class, SEXP table) else /* may return a list if multiple instances of class */ return value; } - else if(TYPEOF(class) != S4SXP) { + else if(!IS_S4_OBJECT(class)) { error(_("class should be either a character-string name or a class definition")); return R_NilValue; /* NOT REACHED */ } else /* assumes a class def, but might check */ diff --git a/src/main/attrib.c b/src/main/attrib.c index 312390c0c48..72b36b68990 100644 --- a/src/main/attrib.c +++ b/src/main/attrib.c @@ -914,7 +914,7 @@ attribute_hidden SEXP do_namesgets(SEXP call, SEXP op, SEXP args, SEXP env) if (MAYBE_SHARED(CAR(args)) || ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args)))) SETCAR(args, R_shallow_duplicate_attr(CAR(args))); - if (TYPEOF(CAR(args)) == S4SXP) { + if (IS_S4_OBJECT(CAR(args))) { const char *klass = CHAR(STRING_ELT(R_data_class(CAR(args), FALSE), 0)); error(_("invalid to use names()<- on an S4 object of class '%s'"), klass); @@ -1169,7 +1169,7 @@ attribute_hidden SEXP do_dimnames(SEXP call, SEXP op, SEXP args, SEXP env) } SEXP R_dim(SEXP call, SEXP op, SEXP args, SEXP env) -{ +{ SEXP ans; /* DispatchOrEval internal generic: dim */ if (DispatchOrEval(call, op, "dim", args, env, &ans, 0, /* argsevald: */ 1)) @@ -1775,7 +1775,7 @@ int R_has_slot(SEXP obj, SEXP name) { if(isString(name)) name = installTrChar(STRING_ELT(name, 0)) R_SLOT_INIT; - if(name == s_dot_Data && TYPEOF(obj) != S4SXP) + if(name == s_dot_Data && !IS_S4_OBJECT(obj)) return(1); /* else */ return(getAttrib(obj, name) != R_NilValue); diff --git a/src/main/objects.c b/src/main/objects.c index 131272eac1c..8c57bf1a0cc 100644 --- a/src/main/objects.c +++ b/src/main/objects.c @@ -272,13 +272,13 @@ SEXP R_LookupMethod(SEXP method, SEXP rho, SEXP callrho, SEXP defrho) PROTECT(table); REPROTECT(val = findVarInFrame3(table, method, TRUE), validx); UNPROTECT(1); /* table */ - if (TYPEOF(val) == PROMSXP) + if (TYPEOF(val) == PROMSXP) REPROTECT(val = eval(val, rho), validx); if(val != R_UnboundValue) { UNPROTECT(2); /* top, val */ return val; } - } + } if (top == R_GlobalEnv) top = R_BaseEnv; @@ -1066,7 +1066,7 @@ int R_check_class_and_super(SEXP x, const char **valid, SEXP rho) UNPROTECT(1); /* cl */ return ans; } - /* if not found directly, then look for a match among the nonvirtual + /* if not found directly, then look for a match among the nonvirtual superclasses, possibly after finding the environment 'rho' in which class(x) is defined */ if(IS_S4_OBJECT(x)) { @@ -1095,8 +1095,8 @@ int R_check_class_and_super(SEXP x, const char **valid, SEXP rho) } SEXP classDef = PROTECT(R_getClassDef(class)); PROTECT(classExts = R_do_slot(classDef, s_contains)); - /* .selectSuperClasses(getClassDef(class)@contains, - * dropVirtual = TRUE, namesOnly = TRUE, + /* .selectSuperClasses(getClassDef(class)@contains, + * dropVirtual = TRUE, namesOnly = TRUE, * directOnly = FALSE, simpleOnly = TRUE): */ PROTECT(_call = lang6(s_selectSuperCl, classExts, From 59fef7eb5f1b026c194fef0df19e7d181601d5ca Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 20:36:22 -0400 Subject: [PATCH 04/22] update print.c --- src/main/print.c | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/main/print.c b/src/main/print.c index 79a7f63c0b4..cb3c5c5b0b7 100644 --- a/src/main/print.c +++ b/src/main/print.c @@ -387,7 +387,7 @@ static void save_tagbuf(char *save, size_t n) else error("tagbuf overflow"); } - + static void PrintObject(SEXP s, R_PrintData *data) { /* Save the tagbuffer to restore indexing tags after evaluation @@ -482,7 +482,7 @@ static void PrintGenericVector(SEXP s, R_PrintData *data) } else snprintf(pbuf, 115, "numeric,%d", LENGTH(s_i)); break; - case CPLXSXP: + case CPLXSXP: if (LENGTH(s_i) == 1) { const Rcomplex *x = COMPLEX_RO(s_i); if (ISNA(x[0].r) || ISNA(x[0].i)) @@ -967,11 +967,16 @@ attribute_hidden void PrintValueRec(SEXP s, R_PrintData *data) case WEAKREFSXP: Rprintf("\n"); break; - case S4SXP: - /* we got here because no show method, usually no class. - Print the "slots" as attributes, since we don't know the class. - */ - Rprintf("\n"); + case OBJSXP: + if(IS_S4_OBJECT(s)) { + /* we got here because no show method, usually no class. + Print the "slots" as attributes, since we don't know the class. + */ + Rprintf("\n"); + } else { + /* OBJSXP type, S4 obj bit not set*/ + Rprintf("\n"); + } break; default: UNIMPLEMENTED_TYPE("PrintValueRec", s); From 30353951733e26519b429bc3e92292078e47c296 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 20:41:24 -0400 Subject: [PATCH 05/22] update dput() for OBJSXP --- src/main/deparse.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/deparse.c b/src/main/deparse.c index 67b1db699e2..6c9a20159ef 100644 --- a/src/main/deparse.c +++ b/src/main/deparse.c @@ -1506,9 +1506,11 @@ static void deparse2buff(SEXP s, LocalParseData *d) d->sourceable = FALSE; print2buff("", d); break; - case S4SXP: { - error("'S4SXP': should not happen - please report"); - break; + case OBJSXP: { + // d->sourceable = FALSE; + // print2buff("", d); + print2buff(".new_object()", d); + break; } default: d->sourceable = FALSE; From 5be92e18f74d015cac11d630f9d1d88c4bcf4e13 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 20:58:08 -0400 Subject: [PATCH 06/22] rename `.new_object` -> `object` --- src/main/deparse.c | 2 +- src/main/names.c | 4 +--- src/main/objects.c | 6 +++--- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/main/deparse.c b/src/main/deparse.c index 6c9a20159ef..9a69114c7c3 100644 --- a/src/main/deparse.c +++ b/src/main/deparse.c @@ -1509,7 +1509,7 @@ static void deparse2buff(SEXP s, LocalParseData *d) case OBJSXP: { // d->sourceable = FALSE; // print2buff("", d); - print2buff(".new_object()", d); + print2buff("object()", d); break; } default: diff --git a/src/main/names.c b/src/main/names.c index ac7d5363c5e..b8423c5f5fc 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -1007,9 +1007,7 @@ FUNTAB R_FunTab[] = {"curlDownload",do_curlDownload, 0, 11, 6, {PP_FUNCALL, PREC_FN, 0}}, {"compilerVersion",do_compilerVersion, 0, 11, 0, {PP_FUNCALL, PREC_FN, 0}}, - -{".new_object", do_dot_new_object, 0, 0, 1, {PP_FUNCALL, PREC_FN, 0}}, - +{"object", do_dot_new_object, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, {NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}, }; diff --git a/src/main/objects.c b/src/main/objects.c index 8c57bf1a0cc..45f931c677a 100644 --- a/src/main/objects.c +++ b/src/main/objects.c @@ -1021,10 +1021,10 @@ attribute_hidden SEXP do_inherits(SEXP call, SEXP op, SEXP args, SEXP env) return inherits3(x, what, which); } -attribute_hidden SEXP do_dot_new_object(SEXP call, SEXP op, SEXP args, SEXP env) +attribute_hidden SEXP do_object(SEXP call, SEXP op, SEXP args, SEXP env) { - // returns an S4SXP/OBJSXP object. If the first arg is a character vector, - // it is set as the class of the object. The S4 bit is not set. + // returns an SXP with type S4SXP/OBJSXP. If the first arg is a character vector, + // it is set as the (S3) class attr of the object. The S4 bit is not set. checkArity(op, args); SEXP class = CAR(args); From 341d87063e4d4eb6bb75747efc7b870f61471e3f Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 21:11:26 -0400 Subject: [PATCH 07/22] checkin stray 'object' rename --- src/include/Internal.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/include/Internal.h b/src/include/Internal.h index 7ea9ab99166..2dc484d1bcc 100644 --- a/src/include/Internal.h +++ b/src/include/Internal.h @@ -466,7 +466,7 @@ SEXP R_do_data_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_do_set_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_getS4DataSlot(SEXP obj, SEXPTYPE type); -SEXP do_dot_new_object(SEXP, SEXP, SEXP, SEXP); +SEXP do_object(SEXP, SEXP, SEXP, SEXP); /* hash tables (temporary support for R-level experimenting and debugging) */ SEXP do_vhash(SEXP, SEXP, SEXP, SEXP); From a4d81b63ef4584029577118d4de227ce341bd533 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 21:12:21 -0400 Subject: [PATCH 08/22] Add `object()` closure to base namespace --- src/library/base/R/New-Internal.R | 2 ++ src/main/names.c | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/library/base/R/New-Internal.R b/src/library/base/R/New-Internal.R index abd38560589..ef09cc77ba0 100644 --- a/src/library/base/R/New-Internal.R +++ b/src/library/base/R/New-Internal.R @@ -223,6 +223,8 @@ capabilities <- function(what = NULL, inherits <- function(x, what, which = FALSE) .Internal(inherits(x, what, which)) +object <- function(class = NULL) .Internal(object(class)) + isa <- function(x, what) { if(isS4(x)) methods::is(x, what) diff --git a/src/main/names.c b/src/main/names.c index b8423c5f5fc..3676ac48f6b 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -1007,7 +1007,7 @@ FUNTAB R_FunTab[] = {"curlDownload",do_curlDownload, 0, 11, 6, {PP_FUNCALL, PREC_FN, 0}}, {"compilerVersion",do_compilerVersion, 0, 11, 0, {PP_FUNCALL, PREC_FN, 0}}, -{"object", do_dot_new_object, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, +{"object", do_object, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, {NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}, }; From 54a1efc5a6ef8480d9f65c7dfb47ae0b3752960b Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Tue, 6 Jun 2023 22:30:08 -0400 Subject: [PATCH 09/22] comment / TODO > dput(object()) object() > dput(object('foo')) object() --- src/main/deparse.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/deparse.c b/src/main/deparse.c index 9a69114c7c3..8062bce0485 100644 --- a/src/main/deparse.c +++ b/src/main/deparse.c @@ -1510,6 +1510,7 @@ static void deparse2buff(SEXP s, LocalParseData *d) // d->sourceable = FALSE; // print2buff("", d); print2buff("object()", d); + // if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); break; } default: From ffa2e6785005d72795e278a6c319caa94bd42711 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 7 Jun 2023 00:17:10 -0400 Subject: [PATCH 10/22] make `dput()` actually useful for `object()` --- src/library/base/R/New-Internal.R | 7 ++++++- src/main/deparse.c | 7 +++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/library/base/R/New-Internal.R b/src/library/base/R/New-Internal.R index ef09cc77ba0..0ea40f3f71e 100644 --- a/src/library/base/R/New-Internal.R +++ b/src/library/base/R/New-Internal.R @@ -223,7 +223,12 @@ capabilities <- function(what = NULL, inherits <- function(x, what, which = FALSE) .Internal(inherits(x, what, which)) -object <- function(class = NULL) .Internal(object(class)) +object <- function(class = NULL, ...) { + if(...length()) + structure(.Internal(object(class)), ...) + else + .Internal(object(class)) +} isa <- function(x, what) { if(isS4(x)) diff --git a/src/main/deparse.c b/src/main/deparse.c index 8062bce0485..bbdc1f40b56 100644 --- a/src/main/deparse.c +++ b/src/main/deparse.c @@ -1507,10 +1507,9 @@ static void deparse2buff(SEXP s, LocalParseData *d) print2buff("", d); break; case OBJSXP: { - // d->sourceable = FALSE; - // print2buff("", d); - print2buff("object()", d); - // if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); + print2buff("object(", d); + if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); + print2buff(")", d); break; } default: From d3192c07787dc1dc2b9554015a3de19188a1bf49 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 7 Jun 2023 10:56:11 -0400 Subject: [PATCH 11/22] prefer `attributes<-` over `structure()` --- src/library/base/R/New-Internal.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/library/base/R/New-Internal.R b/src/library/base/R/New-Internal.R index 0ea40f3f71e..cf3a8bd63f9 100644 --- a/src/library/base/R/New-Internal.R +++ b/src/library/base/R/New-Internal.R @@ -224,9 +224,12 @@ inherits <- function(x, what, which = FALSE) .Internal(inherits(x, what, which)) object <- function(class = NULL, ...) { - if(...length()) - structure(.Internal(object(class)), ...) - else + if(...length()) { + out <- .Internal(object(NULL)) + attributes(out) <- if(is.null(class)) + list(...) else list(class = class, ...) + out + } else .Internal(object(class)) } From 32689c7e3c90c7d89bdb5c13638720fb125795bd Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 7 Jun 2023 19:37:41 -0400 Subject: [PATCH 12/22] update `typeof()` --- src/main/coerce.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/main/coerce.c b/src/main/coerce.c index 8a528dc6bb6..63391624746 100644 --- a/src/main/coerce.c +++ b/src/main/coerce.c @@ -1955,7 +1955,11 @@ Rcomplex asComplex(SEXP x) attribute_hidden SEXP do_typeof(SEXP call, SEXP op, SEXP args, SEXP rho) { checkArity(op, args); - return type2rstr(TYPEOF(CAR(args))); + SEXP x = CAR(args); + if(TYPEOF(x) == S4SXP && !IS_S4_OBJECT(x)) + return mkString("object"); + else + return type2rstr(TYPEOF(x)); } /* Define many of the "is.xxx" functions : From a47a1a3278c893eb0be724d7532bfbbe3d4561ad Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Wed, 7 Jun 2023 20:03:55 -0400 Subject: [PATCH 13/22] update inspect() --- src/main/inspect.c | 2 ++ src/main/memory.c | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/inspect.c b/src/main/inspect.c index 59da140914d..07f71355a28 100644 --- a/src/main/inspect.c +++ b/src/main/inspect.c @@ -67,6 +67,8 @@ static void pp(int pre) { } static const char *typename(SEXP v) { + if(TYPEOF(v) == OBJSXP && IS_S4_OBJECT(v)) + return "S4SXP"; return sexptype2char(TYPEOF(v)); // -> memory.c } diff --git a/src/main/memory.c b/src/main/memory.c index d6add5eed57..3d271312177 100644 --- a/src/main/memory.c +++ b/src/main/memory.c @@ -215,7 +215,7 @@ const char *sexptype2char(SEXPTYPE type) { case BCODESXP: return "BCODESXP"; case EXTPTRSXP: return "EXTPTRSXP"; case WEAKREFSXP: return "WEAKREFSXP"; - case S4SXP: return "S4SXP"; + case OBJSXP: return "OBJSXP"; case RAWSXP: return "RAWSXP"; case NEWSXP: return "NEWSXP"; /* should never happen */ case FREESXP: return "FREESXP"; @@ -1039,7 +1039,7 @@ static void TryToReleasePages(void) maxrel = R_GenHeap[i].AllocCount; for (gen = 0; gen < NUM_OLD_GENERATIONS; gen++) - maxrel -= (int)((1.0 + R_MaxKeepFrac) * + maxrel -= (int)((1.0 + R_MaxKeepFrac) * R_GenHeap[i].OldCount[gen]); maxrel_pages = maxrel > 0 ? maxrel / page_count : 0; @@ -3101,7 +3101,7 @@ attribute_hidden void R_check_thread(const char *s) } } # else -/* This could be implemented for Windows using their threading API */ +/* This could be implemented for Windows using their threading API */ attribute_hidden void R_check_thread(const char *s) {} # endif #endif From 9eea3469e142676ac0cb0a1dedb78dbd7ded2012 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 8 Jun 2023 11:10:47 -0400 Subject: [PATCH 14/22] revert updating checks in S4 This will require a more careful approach; the S4 bit can be set on non-S4SXP types too. --- src/library/methods/src/methods_list_dispatch.c | 2 +- src/main/attrib.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/library/methods/src/methods_list_dispatch.c b/src/library/methods/src/methods_list_dispatch.c index e45695a64bf..c7df2834c45 100644 --- a/src/library/methods/src/methods_list_dispatch.c +++ b/src/library/methods/src/methods_list_dispatch.c @@ -984,7 +984,7 @@ SEXP R_getClassFromCache(SEXP class, SEXP table) else /* may return a list if multiple instances of class */ return value; } - else if(!IS_S4_OBJECT(class)) { + else if(TYPEOF(class) != S4SXP) { error(_("class should be either a character-string name or a class definition")); return R_NilValue; /* NOT REACHED */ } else /* assumes a class def, but might check */ diff --git a/src/main/attrib.c b/src/main/attrib.c index 72b36b68990..b15014caae6 100644 --- a/src/main/attrib.c +++ b/src/main/attrib.c @@ -914,7 +914,7 @@ attribute_hidden SEXP do_namesgets(SEXP call, SEXP op, SEXP args, SEXP env) if (MAYBE_SHARED(CAR(args)) || ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args)))) SETCAR(args, R_shallow_duplicate_attr(CAR(args))); - if (IS_S4_OBJECT(CAR(args))) { + if (TYPEOF(CAR(args)) == S4SXP) { const char *klass = CHAR(STRING_ELT(R_data_class(CAR(args), FALSE), 0)); error(_("invalid to use names()<- on an S4 object of class '%s'"), klass); @@ -1775,7 +1775,7 @@ int R_has_slot(SEXP obj, SEXP name) { if(isString(name)) name = installTrChar(STRING_ELT(name, 0)) R_SLOT_INIT; - if(name == s_dot_Data && !IS_S4_OBJECT(obj)) + if(name == s_dot_Data && TYPEOF(obj) != S4SXP) return(1); /* else */ return(getAttrib(obj, name) != R_NilValue); From 6f61944a689e9c4d3431bb890a54cecd28d21b61 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 8 Jun 2023 11:12:09 -0400 Subject: [PATCH 15/22] use `OBJSXP` instead of `S4SXP` for clarity --- src/main/coerce.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/coerce.c b/src/main/coerce.c index 63391624746..4ee4b82234f 100644 --- a/src/main/coerce.c +++ b/src/main/coerce.c @@ -1956,7 +1956,7 @@ attribute_hidden SEXP do_typeof(SEXP call, SEXP op, SEXP args, SEXP rho) { checkArity(op, args); SEXP x = CAR(args); - if(TYPEOF(x) == S4SXP && !IS_S4_OBJECT(x)) + if(TYPEOF(x) == OBJSXP && !IS_S4_OBJECT(x)) return mkString("object"); else return type2rstr(TYPEOF(x)); From 279e86fbb88acaa699dc7abdc9601cc770fb8cf0 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 8 Jun 2023 11:15:36 -0400 Subject: [PATCH 16/22] cosmetic --- src/main/memory.c | 2 +- src/main/print.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/memory.c b/src/main/memory.c index 3d271312177..bdcaec7c5a2 100644 --- a/src/main/memory.c +++ b/src/main/memory.c @@ -215,7 +215,7 @@ const char *sexptype2char(SEXPTYPE type) { case BCODESXP: return "BCODESXP"; case EXTPTRSXP: return "EXTPTRSXP"; case WEAKREFSXP: return "WEAKREFSXP"; - case OBJSXP: return "OBJSXP"; + case OBJSXP: return "OBJSXP"; case RAWSXP: return "RAWSXP"; case NEWSXP: return "NEWSXP"; /* should never happen */ case FREESXP: return "FREESXP"; diff --git a/src/main/print.c b/src/main/print.c index cb3c5c5b0b7..d442c20bc1c 100644 --- a/src/main/print.c +++ b/src/main/print.c @@ -975,7 +975,7 @@ attribute_hidden void PrintValueRec(SEXP s, R_PrintData *data) Rprintf("\n"); } else { /* OBJSXP type, S4 obj bit not set*/ - Rprintf("\n"); + Rprintf("\n"); } break; default: From 2657ca3f27ecede60513516a53bd30d3421c2763 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 8 Jun 2023 11:21:22 -0400 Subject: [PATCH 17/22] comment out `object()` constructor --- src/include/Internal.h | 2 +- src/library/base/R/New-Internal.R | 18 +++++++++--------- src/main/deparse.c | 6 +++++- src/main/names.c | 2 +- src/main/objects.c | 5 +++-- 5 files changed, 19 insertions(+), 14 deletions(-) diff --git a/src/include/Internal.h b/src/include/Internal.h index 2dc484d1bcc..37706ec02df 100644 --- a/src/include/Internal.h +++ b/src/include/Internal.h @@ -466,7 +466,7 @@ SEXP R_do_data_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_do_set_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_getS4DataSlot(SEXP obj, SEXPTYPE type); -SEXP do_object(SEXP, SEXP, SEXP, SEXP); +/* SEXP do_object(SEXP, SEXP, SEXP, SEXP); */ /* hash tables (temporary support for R-level experimenting and debugging) */ SEXP do_vhash(SEXP, SEXP, SEXP, SEXP); diff --git a/src/library/base/R/New-Internal.R b/src/library/base/R/New-Internal.R index cf3a8bd63f9..8f59f454f23 100644 --- a/src/library/base/R/New-Internal.R +++ b/src/library/base/R/New-Internal.R @@ -223,15 +223,15 @@ capabilities <- function(what = NULL, inherits <- function(x, what, which = FALSE) .Internal(inherits(x, what, which)) -object <- function(class = NULL, ...) { - if(...length()) { - out <- .Internal(object(NULL)) - attributes(out) <- if(is.null(class)) - list(...) else list(class = class, ...) - out - } else - .Internal(object(class)) -} +# object <- function(class = NULL, ...) { +# if(...length()) { +# out <- .Internal(object(NULL)) +# attributes(out) <- if(is.null(class)) +# list(...) else list(class = class, ...) +# out +# } else +# .Internal(object(class)) +# } isa <- function(x, what) { if(isS4(x)) diff --git a/src/main/deparse.c b/src/main/deparse.c index bbdc1f40b56..b4dcbd0a7dc 100644 --- a/src/main/deparse.c +++ b/src/main/deparse.c @@ -1507,9 +1507,13 @@ static void deparse2buff(SEXP s, LocalParseData *d) print2buff("", d); break; case OBJSXP: { + /* print2buff("object(", d); if(attr >= STRUC_ATTR) attr2(s, d, (attr == STRUC_ATTR)); - print2buff(")", d); + print2buff(")", d); + */ + d->sourceable = FALSE; + print2buff("", d); break; } default: diff --git a/src/main/names.c b/src/main/names.c index 3676ac48f6b..ac3105dcf72 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -1007,7 +1007,7 @@ FUNTAB R_FunTab[] = {"curlDownload",do_curlDownload, 0, 11, 6, {PP_FUNCALL, PREC_FN, 0}}, {"compilerVersion",do_compilerVersion, 0, 11, 0, {PP_FUNCALL, PREC_FN, 0}}, -{"object", do_object, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, +/* {"object", do_object, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, */ {NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}, }; diff --git a/src/main/objects.c b/src/main/objects.c index 45f931c677a..dc3c92f2c75 100644 --- a/src/main/objects.c +++ b/src/main/objects.c @@ -1021,9 +1021,9 @@ attribute_hidden SEXP do_inherits(SEXP call, SEXP op, SEXP args, SEXP env) return inherits3(x, what, which); } -attribute_hidden SEXP do_object(SEXP call, SEXP op, SEXP args, SEXP env) +/* attribute_hidden SEXP do_object(SEXP call, SEXP op, SEXP args, SEXP env) { - // returns an SXP with type S4SXP/OBJSXP. If the first arg is a character vector, + // returns an S4SXP/OBJSXP. If the first arg is a character vector, // it is set as the (S3) class attr of the object. The S4 bit is not set. checkArity(op, args); SEXP class = CAR(args); @@ -1036,6 +1036,7 @@ attribute_hidden SEXP do_object(SEXP call, SEXP op, SEXP args, SEXP env) return obj; } +*/ /* ============================================================== From e742aa141f622fca4a21c5ccc0b5d892335b43e0 Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Thu, 27 Jul 2023 12:30:18 -0400 Subject: [PATCH 18/22] patch from Martin Maechler --- src/include/Rinternals.h | 4 ++-- src/main/coerce.c | 9 ++++----- src/main/memory.c | 2 +- src/main/print.c | 20 ++++++++++---------- src/main/util.c | 4 ++++ 5 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/include/Rinternals.h b/src/include/Rinternals.h index 6a1244304fe..1a1281a2a64 100644 --- a/src/include/Rinternals.h +++ b/src/include/Rinternals.h @@ -129,8 +129,8 @@ typedef unsigned int SEXPTYPE; #define EXTPTRSXP 22 /* external pointer */ #define WEAKREFSXP 23 /* weak reference */ #define RAWSXP 24 /* raw bytes */ -#define OBJSXP 25 /* Object, non-vector */ -#define S4SXP 25 /* Same as OBJSXP, name retained for backwards compatability */ +#define OBJSXP 25 /* object, non-vector */ +#define S4SXP 25 /* same as OBJSXP, retained for back compatability */ /* used for detecting PROTECT issues in memory.c */ #define NEWSXP 30 /* fresh node created in new page */ diff --git a/src/main/coerce.c b/src/main/coerce.c index 4ee4b82234f..1cd901750e0 100644 --- a/src/main/coerce.c +++ b/src/main/coerce.c @@ -1955,11 +1955,10 @@ Rcomplex asComplex(SEXP x) attribute_hidden SEXP do_typeof(SEXP call, SEXP op, SEXP args, SEXP rho) { checkArity(op, args); - SEXP x = CAR(args); - if(TYPEOF(x) == OBJSXP && !IS_S4_OBJECT(x)) - return mkString("object"); - else - return type2rstr(TYPEOF(x)); + if(TYPEOF(CAR(args)) == OBJSXP && !IS_S4_OBJECT(CAR(args))) + return mkString("object"); + else + return type2rstr(TYPEOF(CAR(args))); } /* Define many of the "is.xxx" functions : diff --git a/src/main/memory.c b/src/main/memory.c index bdcaec7c5a2..85d3cf8bad6 100644 --- a/src/main/memory.c +++ b/src/main/memory.c @@ -215,7 +215,7 @@ const char *sexptype2char(SEXPTYPE type) { case BCODESXP: return "BCODESXP"; case EXTPTRSXP: return "EXTPTRSXP"; case WEAKREFSXP: return "WEAKREFSXP"; - case OBJSXP: return "OBJSXP"; + case OBJSXP: return "OBJSXP"; /* was S4SXP */ case RAWSXP: return "RAWSXP"; case NEWSXP: return "NEWSXP"; /* should never happen */ case FREESXP: return "FREESXP"; diff --git a/src/main/print.c b/src/main/print.c index d442c20bc1c..6c00832775e 100644 --- a/src/main/print.c +++ b/src/main/print.c @@ -1,6 +1,6 @@ /* * R : A Computer Language for Statistical Data Analysis - * Copyright (C) 2000-2022 The R Core Team. + * Copyright (C) 2000-2023 The R Core Team. * Copyright (C) 1995-1998 Robert Gentleman and Ross Ihaka. * * This program is free software; you can redistribute it and/or modify @@ -968,15 +968,15 @@ attribute_hidden void PrintValueRec(SEXP s, R_PrintData *data) Rprintf("\n"); break; case OBJSXP: - if(IS_S4_OBJECT(s)) { - /* we got here because no show method, usually no class. - Print the "slots" as attributes, since we don't know the class. - */ - Rprintf("\n"); - } else { - /* OBJSXP type, S4 obj bit not set*/ - Rprintf("\n"); - } + if(IS_S4_OBJECT(s)) { + /* we got here because no show method, usually no class. + Print the "slots" as attributes, since we don't know the class. + */ + Rprintf("\n"); + } else { + /* OBJSXP type, S4 obj bit not set*/ + Rprintf("\n"); + } break; default: UNIMPLEMENTED_TYPE("PrintValueRec", s); diff --git a/src/main/util.c b/src/main/util.c index 52f90342ea3..2896fdf54b1 100644 --- a/src/main/util.c +++ b/src/main/util.c @@ -219,6 +219,7 @@ TypeTable[] = { { "weakref", WEAKREFSXP }, { "raw", RAWSXP }, { "S4", S4SXP }, + { "object", OBJSXP }, /* == S4SXP */ /* aliases : */ { "numeric", REALSXP }, { "name", SYMSXP }, @@ -234,6 +235,9 @@ SEXPTYPE str2type(const char *s) if (!strcmp(s, TypeTable[i].str)) return (SEXPTYPE) TypeTable[i].type; } + if (!strcmp(s, "object")) + return (SEXPTYPE) OBJSXP; + /* SEXPTYPE is an unsigned int, so the compiler warns us w/o the cast. */ return (SEXPTYPE) -1; } From 46ee1667c15ab0b3cdbf9ced0c9e622c480a734c Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Fri, 28 Jul 2023 11:59:55 -0400 Subject: [PATCH 19/22] updated patch from Martin --- configure | 7 +++ doc/NEWS.Rd | 6 +++ src/include/Internal.h | 2 - src/include/Rinlinedfuns.h | 4 +- src/include/Rinternals.h | 4 ++ src/library/base/R/New-Internal.R | 10 ---- src/library/base/man/InternalMethods.Rd | 2 +- .../methods/src/methods_list_dispatch.c | 2 +- src/library/parallel/src/fork.c | 16 +++++- src/library/stats/src/complete_cases.c | 10 ++-- src/library/stats/src/deriv.c | 2 +- src/library/stats/src/model.c | 4 +- src/library/tools/R/Rd2HTML.R | 13 +++-- src/library/utils/R/str.R | 4 +- src/main/RNG.c | 2 +- src/main/altclasses.c | 2 +- src/main/array.c | 4 +- src/main/attrib.c | 12 ++--- src/main/bind.c | 10 ++-- src/main/builtin.c | 2 +- src/main/coerce.c | 22 ++++---- src/main/dotcode.c | 4 +- src/main/errors.c | 4 +- src/main/eval.c | 8 +-- src/main/identical.c | 2 +- src/main/logic.c | 2 +- src/main/memory.c | 50 +++++++++---------- src/main/names.c | 3 -- src/main/objects.c | 28 +++-------- src/main/print.c | 6 +-- src/main/radixsort.c | 4 +- src/main/seq.c | 6 +-- src/main/subscript.c | 8 +-- src/main/subset.c | 19 +++---- src/main/summary.c | 4 +- src/main/sysutils.c | 2 +- src/main/util.c | 15 ++++++ src/scripts/BATCH | 2 +- src/scripts/COMPILE | 2 +- src/scripts/LINK | 2 +- src/scripts/config | 2 +- src/scripts/javareconf.in | 2 +- src/scripts/rtags.in | 2 +- 43 files changed, 163 insertions(+), 154 deletions(-) diff --git a/configure b/configure index d16e0b25c53..7df6b061c85 100755 --- a/configure +++ b/configure @@ -29207,10 +29207,17 @@ if test "${ac_cv_fc_compiler_gnu}" = yes; then R_SYSTEM_ABI="${R_SYSTEM_ABI},gfortran,gfortran" else case "${FC}" in + *flang-new) + R_SYSTEM_ABI="${R_SYSTEM_ABI},flang-new,flang-new" + ;; ## This means Classic flang *flang) R_SYSTEM_ABI="${R_SYSTEM_ABI},flang,flang" ;; + ## we do not consider ifort as it will be disconinued in 2023. + *ifx) + R_SYSTEM_ABI="${R_SYSTEM_ABI},ifx,ifx" + ;; *) case "${host_os}" in solaris*) diff --git a/doc/NEWS.Rd b/doc/NEWS.Rd index d9735141106..8604a6cbae3 100644 --- a/doc/NEWS.Rd +++ b/doc/NEWS.Rd @@ -203,6 +203,12 @@ argument descriptions when they spanned multiple lines, including those generated by \code{prompt()}. These cases are now noted by \command{R CMD check}. + + \item Communication between parent and child processes in + \code{multicore} part of \code{parallel} could fail on platforms + that do not support arbitrarily large payload in system functions + \code{read()}/\code{write()} on pipes (seen on macOS). The payload + is now split into 1Gb chunks to avoid that problem. \PR{18571} } } } diff --git a/src/include/Internal.h b/src/include/Internal.h index 37706ec02df..5f64413a381 100644 --- a/src/include/Internal.h +++ b/src/include/Internal.h @@ -466,8 +466,6 @@ SEXP R_do_data_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_do_set_class(SEXP call, SEXP op, SEXP args, SEXP env); SEXP R_getS4DataSlot(SEXP obj, SEXPTYPE type); -/* SEXP do_object(SEXP, SEXP, SEXP, SEXP); */ - /* hash tables (temporary support for R-level experimenting and debugging) */ SEXP do_vhash(SEXP, SEXP, SEXP, SEXP); diff --git a/src/include/Rinlinedfuns.h b/src/include/Rinlinedfuns.h index 03ab50c1db7..9f36975a7a4 100644 --- a/src/include/Rinlinedfuns.h +++ b/src/include/Rinlinedfuns.h @@ -1,7 +1,7 @@ /* * R : A Computer Language for Statistical Data Analysis + * Copyright (C) 1999--2023 The R Core Team. * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka - * Copyright (C) 1999-2017 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 @@ -108,7 +108,7 @@ INLINE_FUN void CHKVEC(SEXP x) { case WEAKREFSXP: break; default: - error("cannot get data pointer of '%s' objects", type2char(TYPEOF(x))); + error("cannot get data pointer of '%s' objects", R_typeToChar(x)); } } #else diff --git a/src/include/Rinternals.h b/src/include/Rinternals.h index 1a1281a2a64..231783cb177 100644 --- a/src/include/Rinternals.h +++ b/src/include/Rinternals.h @@ -562,6 +562,10 @@ SEXP Rf_topenv(SEXP, SEXP); const char * Rf_translateChar(SEXP); const char * Rf_translateCharUTF8(SEXP); const char * Rf_type2char(SEXPTYPE); +const char * R_typeToChar(SEXP); +#ifdef USE_TYPE2CHAR_2 +const char * R_typeToChar2(SEXP, SEXPTYPE); +#endif SEXP Rf_type2rstr(SEXPTYPE); SEXP Rf_type2str(SEXPTYPE); SEXP Rf_type2str_nowarn(SEXPTYPE); diff --git a/src/library/base/R/New-Internal.R b/src/library/base/R/New-Internal.R index 7c42f7acf30..eb5d673e1fc 100644 --- a/src/library/base/R/New-Internal.R +++ b/src/library/base/R/New-Internal.R @@ -223,16 +223,6 @@ capabilities <- function(what = NULL, inherits <- function(x, what, which = FALSE) .Internal(inherits(x, what, which)) -# object <- function(class = NULL, ...) { -# if(...length()) { -# out <- .Internal(object(NULL)) -# attributes(out) <- if(is.null(class)) -# list(...) else list(class = class, ...) -# out -# } else -# .Internal(object(class)) -# } - isa <- function(x, what) { if(isS4(x)) methods::is(x, what) diff --git a/src/library/base/man/InternalMethods.Rd b/src/library/base/man/InternalMethods.Rd index a170870942f..0d37c92f70a 100644 --- a/src/library/base/man/InternalMethods.Rd +++ b/src/library/base/man/InternalMethods.Rd @@ -128,7 +128,7 @@ \code{.S3PrimitiveGenerics} is a character vector listing the primitives which are internal generic and not \link{group generic}, - (not only for {S3} but also {S4}). + (not only for S3 but also S4). Similarly, the \code{.internalGenerics} character vector contains the names of the internal (via \code{\link{.Internal}(..)}) non-primitive functions which are internally generic. diff --git a/src/library/methods/src/methods_list_dispatch.c b/src/library/methods/src/methods_list_dispatch.c index cb4e48a334d..6dad2451366 100644 --- a/src/library/methods/src/methods_list_dispatch.c +++ b/src/library/methods/src/methods_list_dispatch.c @@ -127,7 +127,7 @@ static SEXP R_conditionMessage(SEXP cond) /* Type check return value so callers can safely extract a C string */ if (TYPEOF(out) != STRSXP) error(_("unexpected type '%s' for condition message"), - type2char(TYPEOF(out))); + R_typeToChar(out)); if (length(out) != 1) error(_("condition message must be length 1")); diff --git a/src/library/parallel/src/fork.c b/src/library/parallel/src/fork.c index 1008cb7387d..5f3d29cdec1 100644 --- a/src/library/parallel/src/fork.c +++ b/src/library/parallel/src/fork.c @@ -49,6 +49,12 @@ #include /* for R_Interactive */ #include /* for R_SelectEx */ +/* read()/write() on pipes may not support arbitrary lengths, so + this is the largest chunk we'll ever send with one call between + a child and the parent. On macOS empirically this has to be at + most a 32-bit number. Current default is 1Gb. */ +#define MC_MAX_CHUNK 0x40000000 + #ifdef MC_DEBUG /* NOTE: the logging is not safe to use in signal handler because printf is not async-signal-safe */ @@ -769,7 +775,10 @@ SEXP mc_send_master(SEXP what) } ssize_t n; for (R_xlen_t i = 0; i < len; i += n) { - n = writerep(master_fd, b + i, len - i); + size_t to_send = len - i; + if (to_send > MC_MAX_CHUNK) + to_send = MC_MAX_CHUNK; + n = writerep(master_fd, b + i, to_send); if (n < 1) { close(master_fd); master_fd = -1; @@ -986,7 +995,10 @@ static SEXP read_child_ci(child_info_t *ci) unsigned char *rvb = RAW(rv); R_xlen_t i = 0; while (i < len) { - n = readrep(fd, rvb + i, len - i); + size_t to_read = len - i; + if (to_read > MC_MAX_CHUNK) + to_read = MC_MAX_CHUNK; + n = readrep(fd, rvb + i, to_read); #ifdef MC_DEBUG Dprintf("read_child_ci(%d) - read %lld at %lld returned %lld\n", ci->pid, (long long)len-i, (long long)i, (long long)n); diff --git a/src/library/stats/src/complete_cases.c b/src/library/stats/src/complete_cases.c index 4fd75fadd93..239ec1a1506 100644 --- a/src/library/stats/src/complete_cases.c +++ b/src/library/stats/src/complete_cases.c @@ -62,7 +62,7 @@ SEXP compcases(SEXP args) goto bad; } else - error(R_MSG_type, type2char(TYPEOF(CAR(t)))); + error(R_MSG_type, R_typeToChar(CAR(t))); } /* FIXME : Need to be careful with the use of isVector() */ /* since this includes lists and expressions. */ @@ -113,7 +113,7 @@ SEXP compcases(SEXP args) goto bad; } else - error(R_MSG_type, type2char(TYPEOF(CAR(s)))); + error(R_MSG_type, R_typeToChar(CAR(s))); } if (len < 0) @@ -151,7 +151,7 @@ SEXP compcases(SEXP args) break; default: UNPROTECT(1); - error(R_MSG_type, type2char(TYPEOF(u))); + error(R_MSG_type, R_typeToChar(u)); } } } @@ -183,7 +183,7 @@ SEXP compcases(SEXP args) break; default: UNPROTECT(1); - error(R_MSG_type, type2char(TYPEOF(u))); + error(R_MSG_type, R_typeToChar(u)); } } } @@ -211,7 +211,7 @@ SEXP compcases(SEXP args) break; default: UNPROTECT(1); - error(R_MSG_type, type2char(TYPEOF(u))); + error(R_MSG_type, R_typeToChar(u)); } } } diff --git a/src/library/stats/src/deriv.c b/src/library/stats/src/deriv.c index 4291fecbb4d..3aa42ede85b 100644 --- a/src/library/stats/src/deriv.c +++ b/src/library/stats/src/deriv.c @@ -786,7 +786,7 @@ SEXP doD(SEXP args) if (isExpression(CAR(args))) expr = VECTOR_ELT(CAR(args), 0); else expr = CAR(args); if (!(isLanguage(expr) || isSymbol(expr) || isNumeric(expr) || isComplex(expr))) - error(_("expression must not be type '%s'"), type2char(TYPEOF(expr))); + error(_("expression must not be type '%s'"), R_typeToChar(expr)); SEXP var = CADR(args); if (!isString(var) || length(var) < 1) error(_("variable must be a character string")); diff --git a/src/library/stats/src/model.c b/src/library/stats/src/model.c index 40ad9da388e..558fb8de6be 100644 --- a/src/library/stats/src/model.c +++ b/src/library/stats/src/model.c @@ -154,7 +154,7 @@ SEXP modelframe(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: error(_("invalid type (%s) for variable '%s'"), - type2char(TYPEOF(ans)), + R_typeToChar(ans), translateChar(STRING_ELT(names, i))); } if (nrows(ans) != nr) @@ -667,7 +667,7 @@ SEXP modelmatrix(SEXP call, SEXP op, SEXP args, SEXP rho) } } else error(_("variables of type '%s' are not allowed in model matrices"), - type2char(TYPEOF(var_i))); + R_typeToChar(var_i)); indx /= ll; } } diff --git a/src/library/tools/R/Rd2HTML.R b/src/library/tools/R/Rd2HTML.R index c4635b8edfd..91e93aa7047 100644 --- a/src/library/tools/R/Rd2HTML.R +++ b/src/library/tools/R/Rd2HTML.R @@ -1299,16 +1299,15 @@ function(dir) x <- fsub("<", "<", x) x <- fsub(">", ">", x) if(a) { - ## CRAN also transforms - ## "<(URL: *)?((https?|ftp)://[^[:space:]]+)[[:space:]]*>" - ## - ## Sync regexp with what we use in .DESCRIPTION_to_latex()? - x <- trfm("([^>\"])((https?|ftp)://[[:alnum:]/.:@+\\_~%#?=&;,-]+[[:alnum:]/])", - "\\1\\2", + ## URL regexp as in .DESCRIPTION_to_latex(). CRAN uses + ## <(URL: *)?((https?|ftp)://[^[:space:]]+)[[:space:]]*> + ## ([^>\"])((https?|ftp)://[[:alnum:]/.:@+\\_~%#?=&;,-]+[[:alnum:]/]) + ## (also used in toRd.citation(). + x <- trfm("<(http://|ftp://|https://)([^[:space:],>]+)>", + "\\1\\2", x, urlify, 2L) - ## } if(d) { x <- trfm("<(DOI|doi):[[:space:]]*([^<[:space:]]+[[:alnum:]])>", diff --git a/src/library/utils/R/str.R b/src/library/utils/R/str.R index 0b5a67b8e18..2c8725c35e4 100644 --- a/src/library/utils/R/str.R +++ b/src/library/utils/R/str.R @@ -1,7 +1,7 @@ # File src/library/utils/R/str.R # Part of the R package, https://www.R-project.org # -# Copyright (C) 1995-2021 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 @@ -474,7 +474,7 @@ str.default <- ) } } else if(typeof(object) %in% - c("externalptr", "weakref", "environment", "bytecode")) { + c("externalptr", "weakref", "environment", "bytecode", "object")) { ## Careful here, we don't want to change pointer objects if(has.class) cat(pClass(cl)) diff --git a/src/main/RNG.c b/src/main/RNG.c index d685768d782..817ba3ac686 100644 --- a/src/main/RNG.c +++ b/src/main/RNG.c @@ -354,7 +354,7 @@ static Rboolean GetRNGkind(SEXP seeds) if (seeds == R_MissingArg) /* How can this happen? */ error(_("'.Random.seed' is a missing argument with no default")); warning(_("'.Random.seed' is not an integer vector but of type '%s', so ignored"), - type2char(TYPEOF(seeds))); + R_typeToChar(seeds)); goto invalid; } is = INTEGER(seeds); diff --git a/src/main/altclasses.c b/src/main/altclasses.c index 9187dbc8541..96aa7a6c14d 100644 --- a/src/main/altclasses.c +++ b/src/main/altclasses.c @@ -1125,7 +1125,7 @@ static Rboolean mmap_Inspect(SEXP x, int pre, int deep, int pvec, Rboolean ptrOK = MMAP_PTROK(x); Rboolean wrtOK = MMAP_WRTOK(x); Rboolean serOK = MMAP_SEROK(x); - Rprintf(" mmaped %s", type2char(TYPEOF(x))); + Rprintf(" mmaped %s", R_typeToChar(x)); Rprintf(" [ptr=%d,wrt=%d,ser=%d]\n", ptrOK, wrtOK, serOK); return TRUE; } diff --git a/src/main/array.c b/src/main/array.c index 0a4b8197890..6e566d82bb1 100644 --- a/src/main/array.c +++ b/src/main/array.c @@ -84,7 +84,7 @@ attribute_hidden SEXP do_matrix(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: error(_("'data' must be of a vector type, was '%s'"), - type2char(TYPEOF(vals))); + R_typeToChar(vals)); } lendat = XLENGTH(vals); snr = CAR(args); args = CDR(args); @@ -2071,7 +2071,7 @@ attribute_hidden SEXP do_array(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: error(_("'data' must be of a vector type, was '%s'"), - type2char(TYPEOF(vals))); + R_typeToChar(vals)); } lendat = XLENGTH(vals); dims = CADR(args); diff --git a/src/main/attrib.c b/src/main/attrib.c index b15014caae6..f4cb057d526 100644 --- a/src/main/attrib.c +++ b/src/main/attrib.c @@ -75,7 +75,7 @@ static SEXP row_names_gets(SEXP vec, SEXP val) } } else if(!isString(val)) error(_("row names must be 'character' or 'integer', not '%s'"), - type2char(TYPEOF(val))); + R_typeToChar(val)); PROTECT(vec); PROTECT(val); ans = installAttrib(vec, R_RowNamesSymbol, val); @@ -135,7 +135,7 @@ attribute_hidden SEXP getAttrib0(SEXP vec, SEXP name) } else error(_("getAttrib: invalid type (%s) for TAG"), - type2char(TYPEOF(TAG(vec)))); + R_typeToChar(TAG(vec))); } UNPROTECT(1); if (any) { @@ -401,7 +401,7 @@ static void checkNames(SEXP x, SEXP s) if (isVector(x) || isList(x) || isLanguage(x)) { if (!isVector(s) && !isList(s)) error(_("invalid type (%s) for 'names': must be vector or NULL"), - type2char(TYPEOF(s))); + R_typeToChar(s)); if (xlength(x) != xlength(s)) error(_("'names' attribute [%d] must be the same length as the vector [%d]"), length(s), length(x)); } @@ -1011,7 +1011,7 @@ SEXP namesgets(SEXP vec, SEXP val) installAttrib(vec, R_NamesSymbol, val); else error(_("invalid type (%s) to set 'names' attribute"), - type2char(TYPEOF(vec))); + R_typeToChar(vec)); UNPROTECT(2); return vec; } @@ -1131,7 +1131,7 @@ SEXP dimnamesgets(SEXP vec, SEXP val) if (_this != R_NilValue) { if (!isVector(_this)) error(_("invalid type (%s) for 'dimnames' (must be a vector)"), - type2char(TYPEOF(_this))); + R_typeToChar(_this)); if (INTEGER(dims)[i] != LENGTH(_this) && LENGTH(_this) != 0) error(_("length of 'dimnames' [%d] not equal to array extent"), i+1); @@ -1597,7 +1597,7 @@ attribute_hidden SEXP do_attrgets(SEXP call, SEXP op, SEXP args, SEXP env) } else { error(_("invalid type '%s' for slot name"), - type2char(TYPEOF(nlist))); + R_typeToChar(nlist)); return R_NilValue; /*-Wall*/ } diff --git a/src/main/bind.c b/src/main/bind.c index e0881cecc15..b89343f59c9 100644 --- a/src/main/bind.c +++ b/src/main/bind.c @@ -293,7 +293,7 @@ LogicalAnswer(SEXP x, struct BindData *data, SEXP call) break; default: errorcall(call, _("type '%s' is unimplemented in '%s'"), - type2char(TYPEOF(x)), "LogicalAnswer"); + R_typeToChar(x), "LogicalAnswer"); } } @@ -329,7 +329,7 @@ IntegerAnswer(SEXP x, struct BindData *data, SEXP call) break; default: errorcall(call, _("type '%s' is unimplemented in '%s'"), - type2char(TYPEOF(x)), "IntegerAnswer"); + R_typeToChar(x), "IntegerAnswer"); } } @@ -378,7 +378,7 @@ RealAnswer(SEXP x, struct BindData *data, SEXP call) break; default: errorcall(call, _("type '%s' is unimplemented in '%s'"), - type2char(TYPEOF(x)), "RealAnswer"); + R_typeToChar(x), "RealAnswer"); } } @@ -451,7 +451,7 @@ ComplexAnswer(SEXP x, struct BindData *data, SEXP call) default: errorcall(call, _("type '%s' is unimplemented in '%s'"), - type2char(TYPEOF(x)), "ComplexAnswer"); + R_typeToChar(x), "ComplexAnswer"); } } @@ -479,7 +479,7 @@ RawAnswer(SEXP x, struct BindData *data, SEXP call) break; default: errorcall(call, _("type '%s' is unimplemented in '%s'"), - type2char(TYPEOF(x)), "RawAnswer"); + R_typeToChar(x), "RawAnswer"); } } diff --git a/src/main/builtin.c b/src/main/builtin.c index a2ba2a70cce..6ddbd9c159a 100644 --- a/src/main/builtin.c +++ b/src/main/builtin.c @@ -667,7 +667,7 @@ attribute_hidden SEXP do_cat(SEXP call, SEXP op, SEXP args, SEXP rho) #endif else error(_("argument %d (type '%s') cannot be handled by 'cat'"), - 1+iobj, type2char(TYPEOF(s))); + 1+iobj, R_typeToChar(s)); /* FIXME : cat(...) should handle ANYTHING */ size_t w = strlen(p); cat_sepwidth(sepr, &sepw, ntot); diff --git a/src/main/coerce.c b/src/main/coerce.c index 1cd901750e0..a3ee8ce907a 100644 --- a/src/main/coerce.c +++ b/src/main/coerce.c @@ -413,7 +413,7 @@ static SEXP coerceToSymbol(SEXP v) int warn = 0; if (length(v) <= 0) error(_("invalid data of mode '%s' (too short)"), - type2char(TYPEOF(v))); + R_typeToChar(v)); PROTECT(v); switch(TYPEOF(v)) { case LGLSXP: @@ -1014,7 +1014,7 @@ static SEXP coercePairList(SEXP v, SEXPTYPE type) } else error(_("'%s' object cannot be coerced to type '%s'"), - type2char(TYPEOF(v)), type2char(type)); + R_typeToChar(v), type2char(type)); /* If any tags are non-null then we */ /* need to add a names attribute. */ @@ -1269,7 +1269,7 @@ SEXP coerceVector(SEXP v, SEXPTYPE type) #define COERCE_ERROR_STRING "cannot coerce type '%s' to vector of type '%s'" #define COERCE_ERROR \ - error(_(COERCE_ERROR_STRING), type2char(TYPEOF(v)), type2char(type)) + error(_(COERCE_ERROR_STRING), R_typeToChar(v), type2char(type)) switch (type) { case SYMSXP: @@ -1397,7 +1397,7 @@ static SEXP ascommon(SEXP call, SEXP u, SEXPTYPE type) return v; } else errorcall(call, _(COERCE_ERROR_STRING), - type2char(TYPEOF(u)), type2char(type)); + R_typeToChar(u), type2char(type)); return u;/* -Wall */ } @@ -2159,7 +2159,7 @@ attribute_hidden SEXP do_isvector(SEXP call, SEXP op, SEXP args, SEXP rho) } /* So this allows any type, including undocumented ones such as "closure", but not aliases such as "name" and "function". */ - else if (streql(stype, type2char(TYPEOF(x)))) { + else if (streql(stype, R_typeToChar(x))) { LOGICAL0(ans)[0] = 1; } else @@ -2313,7 +2313,7 @@ attribute_hidden SEXP do_isna(SEXP call, SEXP op, SEXP args, SEXP rho) case NILSXP: break; default: warningcall(call, _("%s() applied to non-(list or vector) of type '%s'"), - "is.na", type2char(TYPEOF(x))); + "is.na", R_typeToChar(x)); for (i = 0; i < n; i++) pa[i] = 0; } @@ -2431,7 +2431,7 @@ static Rboolean anyNA(SEXP call, SEXP op, SEXP args, SEXP env) default: error("anyNA() applied to non-(list or vector) of type '%s'", - type2char(TYPEOF(x))); + R_typeToChar(x)); } return FALSE; } // anyNA() @@ -2509,7 +2509,7 @@ attribute_hidden SEXP do_isnan(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: errorcall(call, _("default method not implemented for type '%s'"), - type2char(TYPEOF(x))); + R_typeToChar(x)); } copyDimAndNames(x, ans); UNPROTECT(2); /* args, ans*/ @@ -2570,7 +2570,7 @@ attribute_hidden SEXP do_isfinite(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: errorcall(call, _("default method not implemented for type '%s'"), - type2char(TYPEOF(x))); + R_typeToChar(x)); } if (dims != R_NilValue) setAttrib(ans, R_DimSymbol, dims); @@ -2646,7 +2646,7 @@ attribute_hidden SEXP do_isinfinite(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: errorcall(call, _("default method not implemented for type '%s'"), - type2char(TYPEOF(x))); + R_typeToChar(x)); } if (!isNull(dims)) setAttrib(ans, R_DimSymbol, dims); @@ -3014,7 +3014,7 @@ static SEXP R_set_class(SEXP obj, SEXP value, SEXP call) } else if(valueType != TYPEOF(obj)) error(_("\"%s\" can only be set as the class if the object has this type; found \"%s\""), - valueString, type2char(TYPEOF(obj))); + valueString, R_typeToChar(obj)); /* else, leave alone */ } else if(!strcmp("numeric", valueString)) { diff --git a/src/main/dotcode.c b/src/main/dotcode.c index d6b6bf32ab3..3b8a400ee1f 100644 --- a/src/main/dotcode.c +++ b/src/main/dotcode.c @@ -395,7 +395,7 @@ static SEXP naokfind(SEXP args, int * len, int *naok, DllReference *dll) dll->dll = (HINSTANCE) R_ExternalPtrAddr(VECTOR_ELT(s, 4)); } else error("incorrect type (%s) of PACKAGE argument\n", - type2char(TYPEOF(CAR(s)))); + R_typeToChar(CAR(s))); } } else { nargs++; @@ -542,7 +542,7 @@ static SEXP check_retval(SEXP call, SEXP val) return val; } - + attribute_hidden SEXP do_External(SEXP call, SEXP op, SEXP args, SEXP env) { DL_FUNC ofun = NULL; diff --git a/src/main/errors.c b/src/main/errors.c index 9d9bba5e19c..8a0ff380619 100644 --- a/src/main/errors.c +++ b/src/main/errors.c @@ -2339,7 +2339,7 @@ R_BadValueInRCode(SEXP value, SEXP call, SEXP rho, const char *rawmsg, REprintf(" --- R stacktrace ---\n"); printwhere(); REprintf(" --- value of length: %d type: %s ---\n", - length(value), type2char(TYPEOF(value))); + length(value), R_typeToChar(value)); PrintValue(value); REprintf(" --- function from context --- \n"); if (R_GlobalContext->callfun != NULL && @@ -2792,7 +2792,7 @@ attribute_hidden SEXP R_makeNotSubsettableError(SEXP x, SEXP call) { SEXP cond = R_makeErrorCondition(call, "notSubsettableError", NULL, 1, - R_MSG_ob_nonsub, type2char(TYPEOF(x))); + R_MSG_ob_nonsub, R_typeToChar(x)); PROTECT(cond); R_setConditionField(cond, 2, "object", x); UNPROTECT(1); diff --git a/src/main/eval.c b/src/main/eval.c index 0f63a62a43d..4bac8d9ea9b 100644 --- a/src/main/eval.c +++ b/src/main/eval.c @@ -970,7 +970,7 @@ SEXP eval(SEXP e, SEXP rho) error("'rho' cannot be C NULL: detected in C-level eval"); if (!isEnvironment(rho)) error("'rho' must be an environment not %s: detected in C-level eval", - type2char(TYPEOF(rho))); + R_typeToChar(rho)); /* Save the current srcref context. */ @@ -2062,7 +2062,7 @@ SEXP applyClosure(SEXP call, SEXP op, SEXP arglist, SEXP rho, SEXP suppliedvars) "'rho' cannot be C NULL: detected in C-level applyClosure"); if (!isEnvironment(rho)) errorcall(call, "'rho' must be an environment not %s: detected in C-level applyClosure", - type2char(TYPEOF(rho))); + R_typeToChar(rho)); formals = FORMALS(op); savedrho = CLOENV(op); @@ -3612,12 +3612,12 @@ attribute_hidden SEXP do_eval(SEXP call, SEXP op, SEXP args, SEXP rho) frame = asInteger(env); if (frame == NA_INTEGER) error(_("invalid '%s' argument of type '%s'"), - "envir", type2char(TYPEOF(env))); + "envir", R_typeToChar(env)); PROTECT(env = R_sysframe(frame, R_GlobalContext)); break; default: error(_("invalid '%s' argument of type '%s'"), - "envir", type2char(TYPEOF(env))); + "envir", R_typeToChar(env)); } /* isLanguage include NILSXP, and that does not need to be diff --git a/src/main/identical.c b/src/main/identical.c index edc5d089425..52dbbc3b278 100644 --- a/src/main/identical.c +++ b/src/main/identical.c @@ -364,7 +364,7 @@ R_compute_identical(SEXP x, SEXP y, int flags) default: /* these are all supposed to be types that represent constant entities, so no further testing required ?? */ - printf("Unknown Type in identical(): %s (%x)\n", type2char(TYPEOF(x)), TYPEOF(x)); + printf("Unknown Type in identical(): %s (%x)\n", R_typeToChar(x), TYPEOF(x)); return TRUE; } } diff --git a/src/main/logic.c b/src/main/logic.c index 293439793f5..445066b2b93 100644 --- a/src/main/logic.c +++ b/src/main/logic.c @@ -482,7 +482,7 @@ attribute_hidden SEXP do_logic3(SEXP call, SEXP op, SEXP args, SEXP env) if(TYPEOF(t) != INTSXP) warningcall(call, _("coercing argument of type '%s' to logical"), - type2char(TYPEOF(t))); + R_typeToChar(t)); t = coerceVector(t, LGLSXP); } val = checkValues(PRIMVAL(op), narm, t, XLENGTH(t)); diff --git a/src/main/memory.c b/src/main/memory.c index 85d3cf8bad6..16a2f0b28fd 100644 --- a/src/main/memory.c +++ b/src/main/memory.c @@ -3817,7 +3817,7 @@ void (MARK_ASSIGNMENT_CALL)(SEXP x) { MARK_ASSIGNMENT_CALL(CHK(x)); } void (SET_ATTRIB)(SEXP x, SEXP v) { if(TYPEOF(v) != LISTSXP && TYPEOF(v) != NILSXP) error("value of 'SET_ATTRIB' must be a pairlist or NULL, not a '%s'", - type2char(TYPEOF(v))); + R_typeToChar(v)); FIX_REFCNT(x, ATTRIB(x), v); CHECK_OLD_TO_NEW(x, v); ATTRIB(x) = v; @@ -3875,7 +3875,7 @@ static R_INLINE SEXP CHK2(SEXP x) { x = CHK(x); if(nvec[TYPEOF(x)]) - error("LENGTH or similar applied to %s object", type2char(TYPEOF(x))); + error("LENGTH or similar applied to %s object", R_typeToChar(x)); return x; } @@ -3890,7 +3890,7 @@ void (SETLENGTH)(SEXP x, R_xlen_t v) error("SETLENGTH() cannot be applied to an ALTVEC object."); if (! isVector(x)) error(_("SETLENGTH() can only be applied to a standard vector, " - "not a '%s'"), type2char(TYPEOF(x))); + "not a '%s'"), R_typeToChar(x)); SET_STDVEC_LENGTH(CHK2(x), v); } @@ -3908,14 +3908,14 @@ R_xlen_t Rf_XLENGTH(SEXP x) { return XLENGTH(x); } const char *(R_CHAR)(SEXP x) { if(TYPEOF(x) != CHARSXP) // Han-Tak proposes to prepend 'x && ' error("%s() can only be applied to a '%s', not a '%s'", - "CHAR", "CHARSXP", type2char(TYPEOF(x))); + "CHAR", "CHARSXP", R_typeToChar(x)); return (const char *) CHAR(CHK(x)); } SEXP (STRING_ELT)(SEXP x, R_xlen_t i) { if(TYPEOF(x) != STRSXP) error("%s() can only be applied to a '%s', not a '%s'", - "STRING_ELT", "character vector", type2char(TYPEOF(x))); + "STRING_ELT", "character vector", R_typeToChar(x)); if (ALTREP(x)) return CHK(ALTSTRING_ELT(CHK(x), i)); else { @@ -3930,7 +3930,7 @@ SEXP (VECTOR_ELT)(SEXP x, R_xlen_t i) { TYPEOF(x) != EXPRSXP && TYPEOF(x) != WEAKREFSXP) error("%s() can only be applied to a '%s', not a '%s'", - "VECTOR_ELT", "list", type2char(TYPEOF(x))); + "VECTOR_ELT", "list", R_typeToChar(x)); if (ALTREP(x)) { SEXP ans = CHK(ALTLIST_ELT(CHK(x), i)); /* the element is marked as not mutable since complex @@ -3965,7 +3965,7 @@ void *(STDVEC_DATAPTR)(SEXP x) error("cannot get STDVEC_DATAPTR from ALTREP object"); if (! isVector(x) && TYPEOF(x) != WEAKREFSXP) error("STDVEC_DATAPTR can only be applied to a vector, not a '%s'", - type2char(TYPEOF(x))); + R_typeToChar(x)); CHKZLN(x); return STDVEC_DATAPTR(x); } @@ -3973,7 +3973,7 @@ void *(STDVEC_DATAPTR)(SEXP x) int *(LOGICAL)(SEXP x) { if(TYPEOF(x) != LGLSXP) error("%s() can only be applied to a '%s', not a '%s'", - "LOGICAL", "logical", type2char(TYPEOF(x))); + "LOGICAL", "logical", R_typeToChar(x)); CHKZLN(x); return LOGICAL(x); } @@ -3981,7 +3981,7 @@ int *(LOGICAL)(SEXP x) { const int *(LOGICAL_RO)(SEXP x) { if(TYPEOF(x) != LGLSXP) error("%s() can only be applied to a '%s', not a '%s'", - "LOGICAL", "logical", type2char(TYPEOF(x))); + "LOGICAL", "logical", R_typeToChar(x)); CHKZLN(x); return LOGICAL_RO(x); } @@ -3990,7 +3990,7 @@ const int *(LOGICAL_RO)(SEXP x) { int *(INTEGER)(SEXP x) { if(TYPEOF(x) != INTSXP && TYPEOF(x) != LGLSXP) error("%s() can only be applied to a '%s', not a '%s'", - "INTEGER", "integer", type2char(TYPEOF(x))); + "INTEGER", "integer", R_typeToChar(x)); CHKZLN(x); return INTEGER(x); } @@ -3998,7 +3998,7 @@ int *(INTEGER)(SEXP x) { const int *(INTEGER_RO)(SEXP x) { if(TYPEOF(x) != INTSXP && TYPEOF(x) != LGLSXP) error("%s() can only be applied to a '%s', not a '%s'", - "INTEGER", "integer", type2char(TYPEOF(x))); + "INTEGER", "integer", R_typeToChar(x)); CHKZLN(x); return INTEGER_RO(x); } @@ -4006,7 +4006,7 @@ const int *(INTEGER_RO)(SEXP x) { Rbyte *(RAW)(SEXP x) { if(TYPEOF(x) != RAWSXP) error("%s() can only be applied to a '%s', not a '%s'", - "RAW", "raw", type2char(TYPEOF(x))); + "RAW", "raw", R_typeToChar(x)); CHKZLN(x); return RAW(x); } @@ -4014,7 +4014,7 @@ Rbyte *(RAW)(SEXP x) { const Rbyte *(RAW_RO)(SEXP x) { if(TYPEOF(x) != RAWSXP) error("%s() can only be applied to a '%s', not a '%s'", - "RAW", "raw", type2char(TYPEOF(x))); + "RAW", "raw", R_typeToChar(x)); CHKZLN(x); return RAW(x); } @@ -4022,7 +4022,7 @@ const Rbyte *(RAW_RO)(SEXP x) { double *(REAL)(SEXP x) { if(TYPEOF(x) != REALSXP) error("%s() can only be applied to a '%s', not a '%s'", - "REAL", "numeric", type2char(TYPEOF(x))); + "REAL", "numeric", R_typeToChar(x)); CHKZLN(x); return REAL(x); } @@ -4030,7 +4030,7 @@ double *(REAL)(SEXP x) { const double *(REAL_RO)(SEXP x) { if(TYPEOF(x) != REALSXP) error("%s() can only be applied to a '%s', not a '%s'", - "REAL", "numeric", type2char(TYPEOF(x))); + "REAL", "numeric", R_typeToChar(x)); CHKZLN(x); return REAL_RO(x); } @@ -4038,7 +4038,7 @@ const double *(REAL_RO)(SEXP x) { Rcomplex *(COMPLEX)(SEXP x) { if(TYPEOF(x) != CPLXSXP) error("%s() can only be applied to a '%s', not a '%s'", - "COMPLEX", "complex", type2char(TYPEOF(x))); + "COMPLEX", "complex", R_typeToChar(x)); CHKZLN(x); return COMPLEX(x); } @@ -4046,7 +4046,7 @@ Rcomplex *(COMPLEX)(SEXP x) { const Rcomplex *(COMPLEX_RO)(SEXP x) { if(TYPEOF(x) != CPLXSXP) error("%s() can only be applied to a '%s', not a '%s'", - "COMPLEX", "complex", type2char(TYPEOF(x))); + "COMPLEX", "complex", R_typeToChar(x)); CHKZLN(x); return COMPLEX_RO(x); } @@ -4054,7 +4054,7 @@ const Rcomplex *(COMPLEX_RO)(SEXP x) { SEXP *(STRING_PTR)(SEXP x) { if(TYPEOF(x) != STRSXP) error("%s() can only be applied to a '%s', not a '%s'", - "STRING_PTR", "character", type2char(TYPEOF(x))); + "STRING_PTR", "character", R_typeToChar(x)); CHKZLN(x); return STRING_PTR(x); } @@ -4062,7 +4062,7 @@ SEXP *(STRING_PTR)(SEXP x) { const SEXP *(STRING_PTR_RO)(SEXP x) { if(TYPEOF(x) != STRSXP) error("%s() can only be applied to a '%s', not a '%s'", - "STRING_PTR_RO", "character", type2char(TYPEOF(x))); + "STRING_PTR_RO", "character", R_typeToChar(x)); CHKZLN(x); return STRING_PTR_RO(x); } @@ -4075,10 +4075,10 @@ NORET SEXP * (VECTOR_PTR)(SEXP x) void (SET_STRING_ELT)(SEXP x, R_xlen_t i, SEXP v) { if(TYPEOF(CHK(x)) != STRSXP) error("%s() can only be applied to a '%s', not a '%s'", - "SET_STRING_ELT", "character vector", type2char(TYPEOF(x))); + "SET_STRING_ELT", "character vector", R_typeToChar(x)); if(TYPEOF(CHK(v)) != CHARSXP) error("Value of SET_STRING_ELT() must be a 'CHARSXP' not a '%s'", - type2char(TYPEOF(v))); + R_typeToChar(v)); if (i < 0 || i >= XLENGTH(x)) error(_("attempt to set index %lld/%lld in SET_STRING_ELT"), (long long)i, (long long)XLENGTH(x)); @@ -4098,7 +4098,7 @@ SEXP (SET_VECTOR_ELT)(SEXP x, R_xlen_t i, SEXP v) { TYPEOF(x) != EXPRSXP && TYPEOF(x) != WEAKREFSXP) { error("%s() can only be applied to a '%s', not a '%s'", - "SET_VECTOR_ELT", "list", type2char(TYPEOF(x))); + "SET_VECTOR_ELT", "list", R_typeToChar(x)); } if (i < 0 || i >= XLENGTH(x)) error(_("attempt to set index %lld/%lld in SET_VECTOR_ELT"), @@ -4132,7 +4132,7 @@ static R_INLINE SEXP CHKCONS(SEXP e) return CHK(e); default: error("CAR/CDR/TAG or similar applied to %s object", - type2char(TYPEOF(e))); + R_typeToChar(e)); } } #else @@ -4438,7 +4438,7 @@ void (SET_PRSEEN)(SEXP x, int v) { SET_PRSEEN(CHK(x), v); } void (SET_PRVALUE)(SEXP x, SEXP v) { if (TYPEOF(x) != PROMSXP) - error("expecting a 'PROMSXP', not a '%s'", type2char(TYPEOF(x))); + error("expecting a 'PROMSXP', not a '%s'", R_typeToChar(x)); FIX_REFCNT(x, PRVALUE(x), v); CHECK_OLD_TO_NEW(x, v); PRVALUE(x) = v; @@ -4471,7 +4471,7 @@ SEXP (SET_CXTAIL)(SEXP x, SEXP v) { #ifdef USE_TYPE_CHECKING if(TYPEOF(v) != CHARSXP && TYPEOF(v) != NILSXP) error("value of 'SET_CXTAIL' must be a char or NULL, not a '%s'", - type2char(TYPEOF(v))); + R_typeToChar(v)); #endif /*CHECK_OLD_TO_NEW(x, v); *//* not needed since not properly traced */ ATTRIB(x) = v; diff --git a/src/main/names.c b/src/main/names.c index 3dfbb1ae9bf..6a10649ed34 100644 --- a/src/main/names.c +++ b/src/main/names.c @@ -159,7 +159,6 @@ FUNTAB R_FunTab[] = {"getNamespaceValue", do_getNSValue, 0, 211, 3, {PP_FUNCALL, PREC_FN, 0}}, - /* Binary Operators, all primitives */ /* these are group generic and so need to eval args */ {"+", do_arith, PLUSOP, 1, -1, {PP_BINARY, PREC_SUM, 0}}, @@ -1007,8 +1006,6 @@ FUNTAB R_FunTab[] = {"curlDownload",do_curlDownload, 0, 11, 6, {PP_FUNCALL, PREC_FN, 0}}, {"compilerVersion",do_compilerVersion, 0, 11, 0, {PP_FUNCALL, PREC_FN, 0}}, -/* {"object", do_object, 0, 11, 1, {PP_FUNCALL, PREC_FN, 0}}, */ - {NULL, NULL, 0, 0, 0, {PP_INVALID, PREC_FN, 0}}, }; diff --git a/src/main/objects.c b/src/main/objects.c index dc3c92f2c75..4ddc5067dc5 100644 --- a/src/main/objects.c +++ b/src/main/objects.c @@ -272,13 +272,13 @@ SEXP R_LookupMethod(SEXP method, SEXP rho, SEXP callrho, SEXP defrho) PROTECT(table); REPROTECT(val = findVarInFrame3(table, method, TRUE), validx); UNPROTECT(1); /* table */ - if (TYPEOF(val) == PROMSXP) + if (TYPEOF(val) == PROMSXP) REPROTECT(val = eval(val, rho), validx); if(val != R_UnboundValue) { UNPROTECT(2); /* top, val */ return val; } - } + } if (top == R_GlobalEnv) top = R_BaseEnv; @@ -1021,22 +1021,6 @@ attribute_hidden SEXP do_inherits(SEXP call, SEXP op, SEXP args, SEXP env) return inherits3(x, what, which); } -/* attribute_hidden SEXP do_object(SEXP call, SEXP op, SEXP args, SEXP env) -{ - // returns an S4SXP/OBJSXP. If the first arg is a character vector, - // it is set as the (S3) class attr of the object. The S4 bit is not set. - checkArity(op, args); - SEXP class = CAR(args); - - SEXP obj = PROTECT(Rf_allocSExp(OBJSXP)); - - if (TYPEOF(class) == STRSXP && LENGTH(class) >= 1) - Rf_classgets(obj, class); - UNPROTECT(1); - - return obj; -} -*/ /* ============================================================== @@ -1067,7 +1051,7 @@ int R_check_class_and_super(SEXP x, const char **valid, SEXP rho) UNPROTECT(1); /* cl */ return ans; } - /* if not found directly, then look for a match among the nonvirtual + /* if not found directly, then look for a match among the nonvirtual superclasses, possibly after finding the environment 'rho' in which class(x) is defined */ if(IS_S4_OBJECT(x)) { @@ -1096,8 +1080,8 @@ int R_check_class_and_super(SEXP x, const char **valid, SEXP rho) } SEXP classDef = PROTECT(R_getClassDef(class)); PROTECT(classExts = R_do_slot(classDef, s_contains)); - /* .selectSuperClasses(getClassDef(class)@contains, - * dropVirtual = TRUE, namesOnly = TRUE, + /* .selectSuperClasses(getClassDef(class)@contains, + * dropVirtual = TRUE, namesOnly = TRUE, * directOnly = FALSE, simpleOnly = TRUE): */ PROTECT(_call = lang6(s_selectSuperCl, classExts, @@ -1437,7 +1421,7 @@ SEXP do_set_prim_method(SEXP op, const char *code_string, SEXP fundef, else if(fundef && !isNull(fundef) && !prim_generics[offset]) { if(TYPEOF(fundef) != CLOSXP) error(_("the formal definition of a primitive generic must be a function object (got type '%s')"), - type2char(TYPEOF(fundef))); + R_typeToChar(fundef)); R_PreserveObject(fundef); prim_generics[offset] = fundef; } diff --git a/src/main/print.c b/src/main/print.c index 6c00832775e..e20596a6bd0 100644 --- a/src/main/print.c +++ b/src/main/print.c @@ -387,7 +387,7 @@ static void save_tagbuf(char *save, size_t n) else error("tagbuf overflow"); } - + static void PrintObject(SEXP s, R_PrintData *data) { /* Save the tagbuffer to restore indexing tags after evaluation @@ -482,7 +482,7 @@ static void PrintGenericVector(SEXP s, R_PrintData *data) } else snprintf(pbuf, 115, "numeric,%d", LENGTH(s_i)); break; - case CPLXSXP: + case CPLXSXP: if (LENGTH(s_i) == 1) { const Rcomplex *x = COMPLEX_RO(s_i); if (ISNA(x[0].r) || ISNA(x[0].i)) @@ -852,7 +852,7 @@ attribute_hidden void PrintValueRec(SEXP s, R_PrintData *data) Rprintf("\n"); else Rprintf("\n", - type2char(TYPEOF(s))); + R_typeToChar(s)); } else { SEXP pkg = getAttrib(s, R_PackageSymbol); if(isNull(pkg)) { diff --git a/src/main/radixsort.c b/src/main/radixsort.c index 0d3d1636408..c56e737766d 100644 --- a/src/main/radixsort.c +++ b/src/main/radixsort.c @@ -1648,7 +1648,7 @@ attribute_hidden SEXP do_radixsort(SEXP call, SEXP op, SEXP args, SEXP rho) break; default : Error("First arg is type '%s', not yet supported", - type2char(TYPEOF(x))); + R_typeToChar(x)); } if (tmp) { // -1 or 1. NEW: or -2 in case of nalast == 0 and all NAs @@ -1755,7 +1755,7 @@ attribute_hidden SEXP do_radixsort(SEXP call, SEXP op, SEXP args, SEXP rho) break; default: Error("Arg %d is type '%s', not yet supported", - col, type2char(TYPEOF(x))); + col, R_typeToChar(x)); } int i = 0; for (int grp = 0; grp < ngrp; grp++) { diff --git a/src/main/seq.c b/src/main/seq.c index 37d1d06f65f..a98db408c69 100644 --- a/src/main/seq.c +++ b/src/main/seq.c @@ -352,11 +352,11 @@ attribute_hidden SEXP do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho) if (!isVector(ncopy)) error(_("invalid type (%s) for '%s' (must be a vector)"), - type2char(TYPEOF(ncopy)), "times"); + R_typeToChar(ncopy), "times"); if (!isVector(s) && s != R_NilValue) error(_("attempt to replicate an object of type '%s'"), - type2char(TYPEOF(s))); + R_typeToChar(s)); nc = xlength(ncopy); // might be 0 if (nc == xlength(s)) @@ -706,7 +706,7 @@ attribute_hidden SEXP do_rep(SEXP call, SEXP op, SEXP args, SEXP rho) } if (!isVector(x)) errorcall(call, "attempt to replicate an object of type '%s'", - type2char(TYPEOF(x))); + R_typeToChar(x)); /* So now we know x is a vector of positive length. We need to replicate it, and its names if it has them. */ diff --git a/src/main/subscript.c b/src/main/subscript.c index 751cf0632a4..a1701018174 100644 --- a/src/main/subscript.c +++ b/src/main/subscript.c @@ -198,7 +198,7 @@ OneIndex(SEXP x, SEXP s, R_xlen_t nx, int partial, SEXP *newname, vmaxset(vmax); break; default: - ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s))); + ECALL3(call, _("invalid subscript type '%s'"), R_typeToChar(s)); } return indx; } @@ -332,7 +332,7 @@ get1index(SEXP s, SEXP names, R_xlen_t len, int pok, int pos, SEXP call) } break; default: - ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s))); + ECALL3(call, _("invalid subscript type '%s'"), R_typeToChar(s)); } return indx; } @@ -1021,7 +1021,7 @@ int_arraySubscript(int dim, SEXP s, SEXP dims, SEXP x, SEXP call) if (s == R_MissingArg) return nullSubscript(nd); default: - ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s))); + ECALL3(call, _("invalid subscript type '%s'"), R_typeToChar(s)); } return R_NilValue; } @@ -1105,7 +1105,7 @@ makeSubscript(SEXP x, SEXP s, R_xlen_t *stretch, SEXP call) break; } default: - ECALL3(call, _("invalid subscript type '%s'"), type2char(TYPEOF(s))); + ECALL3(call, _("invalid subscript type '%s'"), R_typeToChar(s)); } return ans; } diff --git a/src/main/subset.c b/src/main/subset.c index 37862e02b18..51729e000c5 100644 --- a/src/main/subset.c +++ b/src/main/subset.c @@ -95,7 +95,7 @@ static R_INLINE SEXP VECTOR_ELT_FIX_NAMED(SEXP y, R_xlen_t i) { NORET static void errorcallNotSubsettable(SEXP x, SEXP call) { - SEXP cond = R_makeNotSubsettableError(x, call); + SEXP cond = R_makeNotSubsettableError(x, call); // object of type '..' is not subsettable PROTECT(cond); R_signalErrorCondition(cond, call); UNPROTECT(1); /* cond; not reached */ @@ -734,7 +734,6 @@ attribute_hidden SEXP do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) if (cdrArgs != R_NilValue && cddrArgs == R_NilValue && TAG(cdrArgs) == R_NilValue) { /* one index, not named */ - SEXP x = CAR(args); if (ATTRIB(x) == R_NilValue) { SEXP s = CAR(cdrArgs); R_xlen_t i = scalarIndex(s); @@ -767,7 +766,6 @@ attribute_hidden SEXP do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue && TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) { /* two indices, not named */ - SEXP x = CAR(args); SEXP attr = ATTRIB(x); if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) { /* only attribute of x is 'dim' */ @@ -967,11 +965,8 @@ attribute_hidden SEXP do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) /* Is partial matching ok? When the exact arg is NA, a warning is issued if partial matching occurs. */ - int exact = ExtractExactArg(args), pok; - if (exact == -1) - pok = exact; - else - pok = !exact; + int exact = ExtractExactArg(args), + pok = (exact == -1) ? exact : !exact; x = CAR(args); @@ -998,10 +993,12 @@ attribute_hidden SEXP do_subset2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) errorcall(call, _("incorrect number of subscripts")); /* code to allow classes to extend environment */ - if(TYPEOF(x) == S4SXP) { + if(TYPEOF(x) == OBJSXP) { + SEXP xs = x; x = R_getS4DataSlot(x, ANYSXP); if(x == R_NilValue) - errorcall(call, _("this S4 class is not subsettable")); + errorcall(call, _("this %s class is not subsettable"), + IS_S4_OBJECT(xs) ? "S4" : "object"); } PROTECT(x); @@ -1231,7 +1228,7 @@ fixSubset3Args(SEXP call, SEXP args, SEXP env, SEXP* syminp) } else { errorcall(call,_("invalid subscript type '%s'"), - type2char(TYPEOF(nlist))); + R_typeToChar(nlist)); return R_NilValue; /*-Wall*/ } diff --git a/src/main/summary.c b/src/main/summary.c index 168efba3764..a615eb7eab1 100644 --- a/src/main/summary.c +++ b/src/main/summary.c @@ -552,7 +552,7 @@ attribute_hidden SEXP do_summary(SEXP call, SEXP op, SEXP args, SEXP env) case REALSXP: return real_mean(x); case CPLXSXP: return complex_mean(x); default: - error(R_MSG_type, type2char(TYPEOF(x))); + error(R_MSG_type, R_typeToChar(x)); return R_NilValue; // -Wall on clang 4.2 } } @@ -990,7 +990,7 @@ attribute_hidden SEXP do_summary(SEXP call, SEXP op, SEXP args, SEXP env) return ans; invalid_type: - errorcall(call, R_MSG_type, type2char(TYPEOF(a))); + errorcall(call, R_MSG_type, R_typeToChar(a)); return R_NilValue; }/* do_summary */ diff --git a/src/main/sysutils.c b/src/main/sysutils.c index 23df85fba4d..1300564c930 100644 --- a/src/main/sysutils.c +++ b/src/main/sysutils.c @@ -883,7 +883,7 @@ attribute_hidden SEXP do_iconv(SEXP call, SEXP op, SEXP args, SEXP env) SEXP __x__ = (x); \ if(TYPEOF(__x__) != CHARSXP) \ error(_("'%s' must be called on a CHARSXP, but got '%s'"), \ - __func__, type2char(TYPEOF(__x__))); \ + __func__, R_typeToChar(__x__)); \ } while(0); cetype_t getCharCE(SEXP x) diff --git a/src/main/util.c b/src/main/util.c index 2896fdf54b1..718f5f7f758 100644 --- a/src/main/util.c +++ b/src/main/util.c @@ -332,6 +332,21 @@ const char *type2char(SEXPTYPE t) /* returns a char* */ return buf; } +#ifdef USE_TYPE2CHAR_2 +const char *R_typeToChar2(SEXP x, SEXPTYPE t) { + return (t != OBJSXP) + ? type2char(t) + : (IS_S4_OBJECT(x) ? "S4" : "object"); +} +#endif + +const char *R_typeToChar(SEXP x) { // = type2char() but distinguishing {S4, object} + if(TYPEOF(x) == OBJSXP) + return IS_S4_OBJECT(x) ? "S4" : "object"; + // else + return type2char(TYPEOF(x)); +} + #ifdef UNUSED NORET SEXP type2symbol(SEXPTYPE t) { diff --git a/src/scripts/BATCH b/src/scripts/BATCH index ece68924c3a..2e27da336f9 100644 --- a/src/scripts/BATCH +++ b/src/scripts/BATCH @@ -1,7 +1,7 @@ # # ${R_HOME}/bin/BATCH -revision='$Rev$' +revision='$Rev: 83927 $' version=`set - ${revision}; echo ${2}` version="R batch front end: ${R_VERSION} (r${version}) diff --git a/src/scripts/COMPILE b/src/scripts/COMPILE index eb121f6e8ae..ab8296778cc 100644 --- a/src/scripts/COMPILE +++ b/src/scripts/COMPILE @@ -3,7 +3,7 @@ # @configure_input@ -revision='$Rev$' +revision='$Rev: 75653 $' version=`set - ${revision}; echo ${2}` version="R compilation front end: ${R_VERSION} (r${version}) diff --git a/src/scripts/LINK b/src/scripts/LINK index c3ceda2acb7..ad84733403c 100644 --- a/src/scripts/LINK +++ b/src/scripts/LINK @@ -1,7 +1,7 @@ ## ## ${R_HOME}/bin/LINK -revision='$Rev$' +revision='$Rev: 75653 $' version=`set - ${revision}; echo ${2}` version="R linker front end: ${R_VERSION} (r${version}) diff --git a/src/scripts/config b/src/scripts/config index 6d2c4e36d4d..b8d8f55ed46 100644 --- a/src/scripts/config +++ b/src/scripts/config @@ -20,7 +20,7 @@ ## A copy of the GNU General Public License is available at ## https://www.R-project.org/Licenses/ -revision='$Revision$' +revision='$Revision: 83600 $' version=`set - ${revision}; echo ${2}` version="R configuration information retrieval script: ${R_VERSION} (r${version}) diff --git a/src/scripts/javareconf.in b/src/scripts/javareconf.in index ffd199e7cd6..6ffb704604c 100644 --- a/src/scripts/javareconf.in +++ b/src/scripts/javareconf.in @@ -9,7 +9,7 @@ fi DYLIB_EXT=`${R_HOME}/bin/R CMD config DYLIB_EXT` tools_classpath=${R_SHARE_DIR}/java -revision='$Rev$' +revision='$Rev: 84173 $' version=`set - ${revision}; echo ${2}` version="R Java configurator: ${R_VERSION} (r${version}) diff --git a/src/scripts/rtags.in b/src/scripts/rtags.in index 8f30b44faec..2c3a0c42299 100644 --- a/src/scripts/rtags.in +++ b/src/scripts/rtags.in @@ -3,7 +3,7 @@ ## Examples: ## R CMD rtags -o TAGS /path/to/Rsrc/ -revision='$Rev$' +revision='$Rev: 83932 $' version=`set - ${revision}; echo ${2}` version="rtags/etags front-end: ${R_VERSION} (r${version}) From 33a105f78744c2f2b00b11842a9cf6d7e0d1ba9d Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 31 Jul 2023 13:05:13 -0400 Subject: [PATCH 20/22] update `type2char()` --- src/main/apply.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/apply.c b/src/main/apply.c index 43dbe6e3b51..432523ac3bb 100644 --- a/src/main/apply.c +++ b/src/main/apply.c @@ -126,7 +126,7 @@ attribute_hidden SEXP do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho) commonType != INTSXP && commonType != LGLSXP && commonType != RAWSXP && commonType != STRSXP && commonType != VECSXP) - error(_("type '%s' is not supported"), type2char(commonType)); + error(_("type '%s' is not supported"), R_typeToChar(value)); dim_v = getAttrib(value, R_DimSymbol); array_value = (TYPEOF(dim_v) == INTSXP && LENGTH(dim_v) >= 1); PROTECT(ans = allocVector(commonType, n*commonLen)); @@ -187,7 +187,7 @@ attribute_hidden SEXP do_vapply(SEXP call, SEXP op, SEXP args, SEXP rho) } if (!okay) error(_("values must be type '%s',\n but FUN(X[[%d]]) result is type '%s'"), - type2char(commonType), i+1, type2char(valType)); + R_typeToChar(value), i+1, R_typeToChar(val)); REPROTECT(val = coerceVector(val, commonType), indx); } /* Take row names from the first result only */ From 4883a6b4c1b8e2774c0219f6e5220c9f85f7961b Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 31 Jul 2023 13:06:02 -0400 Subject: [PATCH 21/22] type2char() usage comments --- src/main/bind.c | 6 ++++-- src/main/summary.c | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/bind.c b/src/main/bind.c index b89343f59c9..cd275689a19 100644 --- a/src/main/bind.c +++ b/src/main/bind.c @@ -1162,8 +1162,8 @@ attribute_hidden SEXP do_bind(SEXP call, SEXP op, SEXP args, SEXP env) to an expression is not ideal. FIXME? had cbind(y ~ x, 1) work using lists, before */ default: - error(_("cannot create a matrix from type '%s'"), - type2char(mode)); + error(_("cannot create a matrix from type '%s'"), + type2char(mode)); /* mode can only be EXPRSXP here */ } if (PRIMVAL(op) == 1) @@ -1396,6 +1396,8 @@ static SEXP cbind(SEXP call, SEXP args, SEXPTYPE mode, SEXP rho, }); } else /* not sure this can be reached, but to be safe: */ + /* `mode` is created in do_bind(), it can only be one of the following: + NILSXP, LGLSXP, INTSXP, REALSXP, CPLXSXP, STRSXP, VECSXP, RAWSXP */ error(_("cannot create a matrix of type '%s'"), type2char(mode)); } diff --git a/src/main/summary.c b/src/main/summary.c index a615eb7eab1..25e8503e7b9 100644 --- a/src/main/summary.c +++ b/src/main/summary.c @@ -625,7 +625,7 @@ attribute_hidden SEXP do_summary(SEXP call, SEXP op, SEXP args, SEXP env) int itmp = 0, icum = 0, warn = 0 /* dummy */; Rboolean use_isum = TRUE; // indicating if isum() should used; otherwise irsum() isum_INT iLtmp = (isum_INT)0, iLcum = iLtmp; // for isum() only - SEXPTYPE ans_type;/* only INTEGER, REAL, COMPLEX or STRSXP here */ + SEXPTYPE ans_type; /* only INTEGER, REAL, COMPLEX or STRSXP here */ int iop = PRIMVAL(op); switch(iop) { From 145626bd76cbbcdef727964f297511fe75c7ee8d Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 31 Jul 2023 15:53:36 -0400 Subject: [PATCH 22/22] update type2str() usage --- src/main/dotcode.c | 10 +++++----- src/main/eval.c | 2 +- src/main/subassign.c | 8 ++++---- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/main/dotcode.c b/src/main/dotcode.c index 3b8a400ee1f..d867f1e4a30 100644 --- a/src/main/dotcode.c +++ b/src/main/dotcode.c @@ -2024,7 +2024,7 @@ attribute_hidden SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env) break; case VECSXP: if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"), - type2char(t), na + 1); + R_typeToChar(s), na + 1); /* Used read-only, so this is safe */ #ifdef USE_RINTERNALS if (!ALTREP(s)) @@ -2045,20 +2045,20 @@ attribute_hidden SEXP do_dotCode(SEXP call, SEXP op, SEXP args, SEXP env) case SPECIALSXP: case ENVSXP: if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"), - type2char(t), na + 1); + R_typeToChar(s), na + 1); cargs[na] = (void*) s; break; case NILSXP: error(_("invalid mode (%s) to pass to C or Fortran (arg %d)"), - type2char(t), na + 1); + R_typeToChar(s), na + 1); cargs[na] = (void*) s; break; default: /* Includes pairlists from R 2.15.0 */ if (Fort) error(_("invalid mode (%s) to pass to Fortran (arg %d)"), - type2char(t), na + 1); + R_typeToChar(s), na + 1); warning("passing an object of type '%s' to .C (arg %d) is deprecated", - type2char(t), na + 1); + R_typeToChar(s), na + 1); if (t == LISTSXP) warning(_("pairlists are passed as SEXP as from R 2.15.0")); cargs[na] = (void*) s; diff --git a/src/main/eval.c b/src/main/eval.c index 4bac8d9ea9b..a9c4399b956 100644 --- a/src/main/eval.c +++ b/src/main/eval.c @@ -3581,7 +3581,7 @@ attribute_hidden SEXP do_eval(SEXP call, SEXP op, SEXP args, SEXP rho) } else if ( !isEnvironment(encl) && !isEnvironment((encl = simple_as_environment(encl))) ) { error(_("invalid '%s' argument of type '%s'"), - "enclos", type2char(tEncl)); + "enclos", R_typeToChar(encl)); } if(IS_S4_OBJECT(env) && (TYPEOF(env) == S4SXP)) env = R_getS4DataSlot(env, ANYSXP); /* usually an ENVSXP */ diff --git a/src/main/subassign.c b/src/main/subassign.c index 449d8d88012..13b7dbef669 100644 --- a/src/main/subassign.c +++ b/src/main/subassign.c @@ -475,7 +475,7 @@ static int SubassignTypeFix(SEXP *x, SEXP *y, R_xlen_t stretch, int level, default: error(_("incompatible types (from %s to %s) in subassignment type fix"), - type2char(which%100), type2char(which/100)); + R_typeToChar(*x), R_typeToChar(*y)); } if (stretch) { @@ -1122,7 +1122,7 @@ static SEXP MatrixAssign(SEXP call, SEXP rho, SEXP x, SEXP s, SEXP y) default: error(_("incompatible types (from %s to %s) in matrix subset assignment"), - type2char(which%100), type2char(which/100)); + R_typeToChar(x), R_typeToChar(y)); } UNPROTECT(2); return x; @@ -1356,7 +1356,7 @@ static SEXP ArrayAssign(SEXP call, SEXP rho, SEXP x, SEXP s, SEXP y) default: error(_("incompatible types (from %s to %s) in array subset assignment"), - type2char(which%100), type2char(which/100)); + R_typeToChar(x), R_typeToChar(y)); } UNPROTECT(3); @@ -2019,7 +2019,7 @@ do_subassign2_dflt(SEXP call, SEXP op, SEXP args, SEXP rho) default: error(_("incompatible types (from %s to %s) in [[ assignment"), - type2char(which%100), type2char(which/100)); + R_typeToChar(x), R_typeToChar(y)); } /* If we stretched, we may have a new name. */ /* In this case we must create a names attribute */