updated patch from Martin

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*)

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}
  }
  }
 }

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);
 

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

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);

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)

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.

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"));
 

src/library/parallel/src/fork.c

@@ -49,6 +49,12 @@
 #include <Rinterface.h> /* for R_Interactive */
 #include <R_ext/eventloop.h> /* 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);

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));
  }
  }
  }

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"));

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;
  }
  }

src/library/tools/R/Rd2HTML.R

@@ -1299,16 +1299,15 @@ function(dir)
  x <- fsub("<", "&lt;", x)
  x <- fsub(">", "&gt;", x)
  if(a) {
- ## CRAN also transforms
- ## "&lt;(URL: *)?((https?|ftp)://[^[:space:]]+)[[:space:]]*&gt;"
- ## <FIXME>
- ## Sync regexp with what we use in .DESCRIPTION_to_latex()?
- x <- trfm("([^>\"])((https?|ftp)://[[:alnum:]/.:@+\\_~%#?=&;,-]+[[:alnum:]/])",
- "\\1<a href=\"%s\">\\2</a>",
+ ## URL regexp as in .DESCRIPTION_to_latex(). CRAN uses
+ ## &lt;(URL: *)?((https?|ftp)://[^[:space:]]+)[[:space:]]*&gt;
+ ##  ([^>\"])((https?|ftp)://[[:alnum:]/.:@+\\_~%#?=&;,-]+[[:alnum:]/])
+ ## (also used in toRd.citation().
+ x <- trfm("&lt;(http://|ftp://|https://)([^[:space:],>]+)&gt;",
+ "<a href=\"\\1%s\">\\1\\2</a>",
  x,
  urlify,
  2L)
- ## </FIXME>
  }
  if(d) {
  x <- trfm("&lt;(DOI|doi):[[:space:]]*([^<[:space:]]+[[:alnum:]])&gt;",

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))

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);

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;
 }

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);

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*/
  }
 

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");
  }
 }
 

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);