The R Project SVN – R – Blame – /trunk/src/include/Rinlinedfuns.h

Rev	Author	Line No.	Line
37087	ripley	1	`/*`
		2	`* R : A Computer Language for Statistical Data Analysis`
87813	ripley	3	`* Copyright (C) 1999-2025 The R Core Team.`
37087	ripley	4	`* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka`
		5	`*`
		6	`* This program is free software; you can redistribute it and/or modify`
38988	ripley	7	`* it under the terms of the GNU General Public License as published by`
		8	`* the Free Software Foundation; either version 2 of the License, or`
37087	ripley	9	`* (at your option) any later version.`
		10	`*`
		11	`* This program is distributed in the hope that it will be useful,`
		12	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
		13	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
71657	plummer	14	`* GNU General Public License for more details.`
37087	ripley	15	`*`
38988	ripley	16	`* You should have received a copy of the GNU General Public License`
42308	ripley	17	`* along with this program; if not, a copy is available at`
68949	ripley	18	`* https://www.R-project.org/Licenses/`
37087	ripley	19	`*/`
		20
70046	ripley	21	`/* Internal header, not installed */`
		22
37087	ripley	23	`/* this header is always to be included from others.`
		24	`It is only called if COMPILING_R is defined (in util.c) or`
		25	`from GNU C systems.`
		26
40855	ripley	27	`There are different conventions for inlining across compilation units.`
41631	ripley	28	`See http://www.greenend.org.uk/rjk/2003/03/inline.html`
37087	ripley	29	`*/`
		30	`#ifndef R_INLINES_H_`
		31	`#define R_INLINES_H_`
		32
87176	kalibera	33	`#if defined(__GNUC_STDC_INLINE__) && !defined(C99_INLINE_SEMANTICS)`
59035	ripley	34	`/* Probably not able to use C99 semantics in gcc < 4.3.0 */`
87176	kalibera	35	`# if defined(__clang__) \|\| __GNUC__ > 4 \|\| __GNUC__ == 4 && __GNUC_MINOR__ >= 3`
		36	`# define C99_INLINE_SEMANTICS 1`
		37	`# endif`
41631	ripley	38	`#endif`
		39
79711	ripley	40	`/* Apple's gcc build >5400 (since Xcode 3.0) doesn't support GNU inline in C99 mode`
87367	ripley	41	`Apple's 'gcc' is nowadays a clang wrapper.`
43219	urbaneks	42	`#if __APPLE_CC__ > 5400 && !defined(C99_INLINE_SEMANTICS) && __STDC_VERSION__ >= 199901L`
41648	urbaneks	43	`#define C99_INLINE_SEMANTICS 1`
		44	`#endif`
87367	ripley	45	`*/`
41648	urbaneks	46
41631	ripley	47	`#ifdef COMPILING_R`
41637	ripley	48	`/* defined only in inlined.c: this emits standalone code there */`
41631	ripley	49	`# define INLINE_FUN`
86628	luke	50	`# define HIDDEN attribute_hidden`
41631	ripley	51	`#else`
41838	ripley	52	`/* This section is normally only used for versions of gcc which do not`
		53	`support C99 semantics. __GNUC_STDC_INLINE__ is defined if`
40870	ripley	54	`GCC is following C99 inline semantics by default: we`
41838	ripley	55	`switch R's usage to the older GNU semantics via attributes.`
		56	`Do this even for __GNUC_GNUC_INLINE__ to shut up warnings in 4.2.x.`
		57	`__GNUC_STDC_INLINE__ and __GNUC_GNU_INLINE__ were added in gcc 4.2.0.`
		58	`*/`
87168	kalibera	59	`/* object files will not contain definitions of functions declared`
		60	`"extern inline" in gnu90 inline mode */`
41623	ripley	61	`# if defined(__GNUC_STDC_INLINE__) \|\| defined(__GNUC_GNU_INLINE__)`
40870	ripley	62	`# define INLINE_FUN extern __attribute__((gnu_inline)) inline`
		63	`# else`
		64	`# define INLINE_FUN extern R_INLINE`
		65	`# endif`
86628	luke	66	`# define HIDDEN`
41631	ripley	67	`#endif /* ifdef COMPILING_R */`
37087	ripley	68
41636	ripley	69	`#if C99_INLINE_SEMANTICS`
41631	ripley	70	`# undef INLINE_FUN`
		71	`# ifdef COMPILING_R`
87168	kalibera	72	`/* force exported copy (in inlined.c) */`
41631	ripley	73	`# define INLINE_FUN extern inline`
		74	`# else`
		75	`/* either inline or link to extern version at compiler's choice */`
		76	`# define INLINE_FUN inline`
		77	`# endif /* ifdef COMPILING_R */`
		78	`#endif /* C99_INLINE_SEMANTICS */`
		79
		80
42397	ripley	81	`#include <string.h> /* for strlen, strcmp */`
41631	ripley	82
37087	ripley	83	`/* define inline-able functions */`
87443	kalibera	84	`#if defined(TESTING_WRITE_BARRIER) \|\| defined(COMPILING_R) \|\| defined(COMPILING_MEMORY_C)`
73243	luke	85	`# define STRICT_TYPECHECK`
74380	luke	86	`# define CATCH_ZERO_LENGTH_ACCESS`
73243	luke	87	`#endif`
37087	ripley	88
77327	luke	89
		90	`#if defined(USE_RINTERNALS) \|\| defined(COMPILING_R)`
		91	`/* inline version of CAR to support immediate bindings */`
		92	`INLINE_FUN SEXP CAR(SEXP e)`
		93	`{`
		94	`if (BNDCELL_TAG(e))`
		95	`error("bad binding access");`
		96	`return CAR0(e);`
		97	`}`
		98	`#else`
		99	`SEXP CAR(SEXP e);`
		100	`#endif`
		101
73243	luke	102	`#ifdef STRICT_TYPECHECK`
87321	kalibera	103	`/* Functions called from other inline functions cannot be hidden, because`
		104	`the compiler may choose to inline the caller, but not the callee, causing`
		105	`a linking failure in the caller if the callee is hidden. The callees`
		106	`that were exposed due to this problem have comment "HIDDEN (inlining)",`
		107	`below.`
		108	`*/`
		109	`/HIDDEN (inlining)/ INLINE_FUN void CHKVEC(SEXP x) {`
73243	luke	110	`switch (TYPEOF(x)) {`
		111	`case CHARSXP:`
		112	`case LGLSXP:`
		113	`case INTSXP:`
		114	`case REALSXP:`
		115	`case CPLXSXP:`
		116	`case STRSXP:`
		117	`case VECSXP:`
		118	`case EXPRSXP:`
		119	`case RAWSXP:`
		120	`case WEAKREFSXP:`
		121	`break;`
		122	`default:`
85146	luke	123	`error("cannot get data pointer of '%s' objects", R_typeToChar(x));`
73243	luke	124	`}`
		125	`}`
		126	`#else`
		127	`# define CHKVEC(x) do {} while(0)`
		128	`#endif`
		129
		130	`INLINE_FUN void *DATAPTR(SEXP x) {`
		131	`CHKVEC(x);`
73395	luke	132	`if (ALTREP(x))`
73721	luke	133	`return ALTVEC_DATAPTR(x);`
74380	luke	134	`#ifdef CATCH_ZERO_LENGTH_ACCESS`
		135	`/* Attempts to read or write elements of a zero length vector will`
		136	`result in a segfault, rather than read and write random memory.`
		137	`Returning NULL would be more natural, but Matrix seems to assume`
		138	`that even zero-length vectors have non-NULL data pointers, so`
		139	`return (void *) 1 instead. Zero-length CHARSXP objects still`
		140	`have a trailing zero byte so they are not handled. */`
		141	`else if (STDVEC_LENGTH(x) == 0 && TYPEOF(x) != CHARSXP)`
		142	`return (void *) 1;`
		143	`#endif`
73395	luke	144	`else`
		145	`return STDVEC_DATAPTR(x);`
73243	luke	146	`}`
		147
73721	luke	148	`INLINE_FUN const void *DATAPTR_RO(SEXP x) {`
73395	luke	149	`CHKVEC(x);`
		150	`if (ALTREP(x))`
73721	luke	151	`return ALTVEC_DATAPTR_RO(x);`
73395	luke	152	`else`
		153	`return STDVEC_DATAPTR(x);`
		154	`}`
		155
73718	luke	156	`INLINE_FUN const void *DATAPTR_OR_NULL(SEXP x) {`
73395	luke	157	`CHKVEC(x);`
		158	`if (ALTREP(x))`
73718	luke	159	`return ALTVEC_DATAPTR_OR_NULL(x);`
73395	luke	160	`else`
		161	`return STDVEC_DATAPTR(x);`
		162	`}`
		163
		164	`#ifdef STRICT_TYPECHECK`
		165	`# define CHECK_VECTOR_LGL(x) do { \`
		166	`if (TYPEOF(x) != LGLSXP) error("bad LGLSXP vector"); \`
		167	`} while (0)`
		168	`# define CHECK_VECTOR_INT(x) do { \`
		169	`if (! (TYPEOF(x) == INTSXP \|\| TYPEOF(x) == LGLSXP)) \`
		170	`error("bad INTSXP vector"); \`
		171	`} while (0)`
		172	`# define CHECK_VECTOR_REAL(x) do { \`
		173	`if (TYPEOF(x) != REALSXP) error("bad REALSXP vector"); \`
		174	`} while (0)`
		175	`# define CHECK_VECTOR_CPLX(x) do { \`
		176	`if (TYPEOF(x) != CPLXSXP) error("bad CPLXSXP vector"); \`
		177	`} while (0)`
		178	`# define CHECK_VECTOR_RAW(x) do { \`
		179	`if (TYPEOF(x) != RAWSXP) error("bad RAWSXP vector"); \`
		180	`} while (0)`
		181	`#else`
		182	`# define CHECK_VECTOR_LGL(x) do { } while(0)`
		183	`# define CHECK_VECTOR_INT(x) do { } while(0)`
		184	`# define CHECK_VECTOR_REAL(x) do { } while(0)`
		185	`# define CHECK_VECTOR_CPLX(x) do { } while(0)`
		186	`# define CHECK_VECTOR_RAW(x) do { } while(0)`
		187	`#endif`
		188
73718	luke	189	`INLINE_FUN const int *LOGICAL_OR_NULL(SEXP x) {`
73395	luke	190	`CHECK_VECTOR_LGL(x);`
73718	luke	191	`return ALTREP(x) ? ALTVEC_DATAPTR_OR_NULL(x) : STDVEC_DATAPTR(x);`
73395	luke	192	`}`
		193
73718	luke	194	`INLINE_FUN const int *INTEGER_OR_NULL(SEXP x) {`
73395	luke	195	`CHECK_VECTOR_INT(x);`
73718	luke	196	`return ALTREP(x) ? ALTVEC_DATAPTR_OR_NULL(x) : STDVEC_DATAPTR(x);`
73395	luke	197	`}`
		198
73718	luke	199	`INLINE_FUN const double *REAL_OR_NULL(SEXP x) {`
73395	luke	200	`CHECK_VECTOR_REAL(x);`
73718	luke	201	`return ALTREP(x) ? ALTVEC_DATAPTR_OR_NULL(x) : STDVEC_DATAPTR(x);`
73395	luke	202	`}`
		203
84209	luke	204	`INLINE_FUN const Rcomplex *COMPLEX_OR_NULL(SEXP x) {`
73395	luke	205	`CHECK_VECTOR_CPLX(x);`
73718	luke	206	`return ALTREP(x) ? ALTVEC_DATAPTR_OR_NULL(x) : STDVEC_DATAPTR(x);`
73395	luke	207	`}`
		208
84209	luke	209	`INLINE_FUN const Rbyte *RAW_OR_NULL(SEXP x) {`
73395	luke	210	`CHECK_VECTOR_RAW(x);`
73718	luke	211	`return ALTREP(x) ? ALTVEC_DATAPTR_OR_NULL(x) : STDVEC_DATAPTR(x);`
73395	luke	212	`}`
		213
73243	luke	214	`INLINE_FUN R_xlen_t XLENGTH_EX(SEXP x)`
		215	`{`
		216	`return ALTREP(x) ? ALTREP_LENGTH(x) : STDVEC_LENGTH(x);`
		217	`}`
		218
89518	luke	219	`HIDDEN INLINE_FUN R_xlen_t XTRUELENGTH(SEXP x)`
73243	luke	220	`{`
		221	`return ALTREP(x) ? ALTREP_TRUELENGTH(x) : STDVEC_TRUELENGTH(x);`
		222	`}`
		223
86640	luke	224	`/HIDDEN/ INLINE_FUN int LENGTH_EX(SEXP x, const char *file, int line)`
73243	luke	225	`{`
		226	`if (x == R_NilValue) return 0;`
		227	`R_xlen_t len = XLENGTH(x);`
		228	`#ifdef LONG_VECTOR_SUPPORT`
		229	`if (len > R_SHORT_LEN_MAX)`
		230	`R_BadLongVector(x, file, line);`
		231	`#endif`
73248	ripley	232	`return (int) len;`
73243	luke	233	`}`
		234
73395	luke	235	`#ifdef STRICT_TYPECHECK`
		236	`# define CHECK_STDVEC_LGL(x) do { \`
		237	`CHECK_VECTOR_LGL(x); \`
		238	`if (ALTREP(x)) error("bad standard LGLSXP vector"); \`
		239	`} while (0)`
		240	`# define CHECK_STDVEC_INT(x) do { \`
		241	`CHECK_VECTOR_INT(x); \`
		242	`if (ALTREP(x)) error("bad standard INTSXP vector"); \`
		243	`} while (0)`
		244	`# define CHECK_STDVEC_REAL(x) do { \`
		245	`CHECK_VECTOR_REAL(x); \`
		246	`if (ALTREP(x)) error("bad standard REALSXP vector"); \`
		247	`} while (0)`
		248	`# define CHECK_STDVEC_CPLX(x) do { \`
		249	`CHECK_VECTOR_CPLX(x); \`
		250	`if (ALTREP(x)) error("bad standard CPLXSXP vector"); \`
		251	`} while (0)`
		252	`# define CHECK_STDVEC_RAW(x) do { \`
		253	`CHECK_VECTOR_RAW(x); \`
		254	`if (ALTREP(x)) error("bad standard RAWSXP vector"); \`
		255	`} while (0)`
		256
		257	`# define CHECK_SCALAR_LGL(x) do { \`
87326	kalibera	258	`CHECK_VECTOR_LGL(x); \`
73395	luke	259	`if (XLENGTH(x) != 1) error("bad LGLSXP scalar"); \`
		260	`} while (0)`
		261	`# define CHECK_SCALAR_INT(x) do { \`
87326	kalibera	262	`CHECK_VECTOR_INT(x); \`
73395	luke	263	`if (XLENGTH(x) != 1) error("bad INTSXP scalar"); \`
		264	`} while (0)`
		265	`# define CHECK_SCALAR_REAL(x) do { \`
87326	kalibera	266	`CHECK_VECTOR_REAL(x); \`
73395	luke	267	`if (XLENGTH(x) != 1) error("bad REALSXP scalar"); \`
		268	`} while (0)`
		269	`# define CHECK_SCALAR_CPLX(x) do { \`
87326	kalibera	270	`CHECK_VECTOR_CPLX(x); \`
73395	luke	271	`if (XLENGTH(x) != 1) error("bad CPLXSXP scalar"); \`
		272	`} while (0)`
		273	`# define CHECK_SCALAR_RAW(x) do { \`
87326	kalibera	274	`CHECK_VECTOR_RAW(x); \`
73395	luke	275	`if (XLENGTH(x) != 1) error("bad RAWSXP scalar"); \`
		276	`} while (0)`
		277
		278	`# define CHECK_BOUNDS_ELT(x, i) do { \`
		279	`if (i < 0 \|\| i > XLENGTH(x)) \`
		280	`error("subscript out of bounds"); \`
		281	`} while (0)`
		282
		283	`# define CHECK_VECTOR_LGL_ELT(x, i) do { \`
		284	`SEXP ce__x__ = (x); \`
		285	`R_xlen_t ce__i__ = (i); \`
		286	`CHECK_VECTOR_LGL(ce__x__); \`
		287	`CHECK_BOUNDS_ELT(ce__x__, ce__i__); \`
		288	`} while (0)`
		289	`# define CHECK_VECTOR_INT_ELT(x, i) do { \`
		290	`SEXP ce__x__ = (x); \`
		291	`R_xlen_t ce__i__ = (i); \`
		292	`CHECK_VECTOR_INT(ce__x__); \`
		293	`CHECK_BOUNDS_ELT(ce__x__, ce__i__); \`
		294	`} while (0)`
		295	`# define CHECK_VECTOR_REAL_ELT(x, i) do { \`
		296	`SEXP ce__x__ = (x); \`
		297	`R_xlen_t ce__i__ = (i); \`
		298	`CHECK_VECTOR_REAL(ce__x__); \`
		299	`CHECK_BOUNDS_ELT(ce__x__, ce__i__); \`
		300	`} while (0)`
		301	`# define CHECK_VECTOR_CPLX_ELT(x, i) do { \`
		302	`SEXP ce__x__ = (x); \`
		303	`R_xlen_t ce__i__ = (i); \`
		304	`CHECK_VECTOR_CPLX(ce__x__); \`
		305	`CHECK_BOUNDS_ELT(ce__x__, ce__i__); \`
		306	`} while (0)`
73598	luke	307	`# define CHECK_VECTOR_RAW_ELT(x, i) do { \`
		308	`SEXP ce__x__ = (x); \`
		309	`R_xlen_t ce__i__ = (i); \`
		310	`CHECK_VECTOR_RAW(ce__x__); \`
		311	`CHECK_BOUNDS_ELT(ce__x__, ce__i__); \`
		312	`} while (0)`
73395	luke	313	`#else`
		314	`# define CHECK_STDVEC_LGL(x) do { } while(0)`
		315	`# define CHECK_STDVEC_INT(x) do { } while(0)`
		316	`# define CHECK_STDVEC_REAL(x) do { } while(0)`
		317	`# define CHECK_STDVEC_CPLX(x) do { } while(0)`
		318	`# define CHECK_STDVEC_RAW(x) do { } while(0)`
		319
		320	`# define CHECK_SCALAR_LGL(x) do { } while(0)`
		321	`# define CHECK_SCALAR_INT(x) do { } while(0)`
		322	`# define CHECK_SCALAR_REAL(x) do { } while(0)`
		323	`# define CHECK_SCALAR_CPLX(x) do { } while(0)`
		324	`# define CHECK_SCALAR_RAW(x) do { } while(0)`
		325
		326	`# define CHECK_VECTOR_LGL_ELT(x, i) do { } while(0)`
		327	`# define CHECK_VECTOR_INT_ELT(x, i) do { } while(0)`
		328	`# define CHECK_VECTOR_REAL_ELT(x, i) do { } while(0)`
		329	`# define CHECK_VECTOR_CPLX_ELT(x, i) do { } while(0)`
73598	luke	330	`# define CHECK_VECTOR_RAW_ELT(x, i) do { } while(0)`
73395	luke	331	`#endif`
		332
87321	kalibera	333	`/HIDDEN (inlining)/ INLINE_FUN int *LOGICAL0(SEXP x) {`
73395	luke	334	`CHECK_STDVEC_LGL(x);`
73726	luke	335	`return (int *) STDVEC_DATAPTR(x);`
73395	luke	336	`}`
87813	ripley	337	`/* This should not be Rboolean as could be NA_LOGICAL */`
		338	`HIDDEN INLINE_FUN int SCALAR_LVAL(SEXP x) {`
73395	luke	339	`CHECK_SCALAR_LGL(x);`
87326	kalibera	340	`return LOGICAL(x)[0];`
73395	luke	341	`}`
87813	ripley	342	`/* ditto */`
		343	`HIDDEN INLINE_FUN void SET_SCALAR_LVAL(SEXP x, int v) {`
73395	luke	344	`CHECK_SCALAR_LGL(x);`
87326	kalibera	345	`LOGICAL(x)[0] = v;`
73395	luke	346	`}`
		347
87321	kalibera	348	`/HIDDEN (inlining)/ INLINE_FUN int *INTEGER0(SEXP x) {`
73395	luke	349	`CHECK_STDVEC_INT(x);`
		350	`return (int *) STDVEC_DATAPTR(x);`
		351	`}`
86628	luke	352	`HIDDEN INLINE_FUN int SCALAR_IVAL(SEXP x) {`
73395	luke	353	`CHECK_SCALAR_INT(x);`
87326	kalibera	354	`return INTEGER(x)[0];`
73395	luke	355	`}`
87321	kalibera	356	`/HIDDEN (inlining)/ INLINE_FUN void SET_SCALAR_IVAL(SEXP x, int v) {`
73395	luke	357	`CHECK_SCALAR_INT(x);`
87326	kalibera	358	`INTEGER(x)[0] = v;`
73395	luke	359	`}`
		360
86683	ripley	361	`/HIDDEN/ INLINE_FUN double *REAL0(SEXP x) {`
73395	luke	362	`CHECK_STDVEC_REAL(x);`
		363	`return (double *) STDVEC_DATAPTR(x);`
		364	`}`
86628	luke	365	`HIDDEN INLINE_FUN double SCALAR_DVAL(SEXP x) {`
73395	luke	366	`CHECK_SCALAR_REAL(x);`
87326	kalibera	367	`return REAL(x)[0];`
73395	luke	368	`}`
87321	kalibera	369	`/HIDDEN (inlining)/ INLINE_FUN void SET_SCALAR_DVAL(SEXP x, double v) {`
73395	luke	370	`CHECK_SCALAR_REAL(x);`
87326	kalibera	371	`REAL(x)[0] = v;`
73395	luke	372	`}`
		373
86683	ripley	374	`/HIDDEN/ INLINE_FUN Rcomplex *COMPLEX0(SEXP x) {`
73395	luke	375	`CHECK_STDVEC_CPLX(x);`
		376	`return (Rcomplex *) STDVEC_DATAPTR(x);`
		377	`}`
86628	luke	378	`HIDDEN INLINE_FUN Rcomplex SCALAR_CVAL(SEXP x) {`
73395	luke	379	`CHECK_SCALAR_CPLX(x);`
87326	kalibera	380	`return COMPLEX(x)[0];`
73395	luke	381	`}`
87321	kalibera	382	`/HIDDEN (inlining)/ INLINE_FUN void SET_SCALAR_CVAL(SEXP x, Rcomplex v) {`
73395	luke	383	`CHECK_SCALAR_CPLX(x);`
87326	kalibera	384	`COMPLEX(x)[0] = v;`
73395	luke	385	`}`
		386
87321	kalibera	387	`/HIDDEN (inlining)/ INLINE_FUN Rbyte *RAW0(SEXP x) {`
73395	luke	388	`CHECK_STDVEC_RAW(x);`
		389	`return (Rbyte *) STDVEC_DATAPTR(x);`
		390	`}`
86628	luke	391	`HIDDEN INLINE_FUN Rbyte SCALAR_BVAL(SEXP x) {`
73395	luke	392	`CHECK_SCALAR_RAW(x);`
87326	kalibera	393	`return RAW(x)[0];`
73395	luke	394	`}`
87321	kalibera	395	`/HIDDEN (inlining)/ INLINE_FUN void SET_SCALAR_BVAL(SEXP x, Rbyte v) {`
73395	luke	396	`CHECK_SCALAR_RAW(x);`
87326	kalibera	397	`RAW(x)[0] = v;`
73395	luke	398	`}`
		399
73472	luke	400	`INLINE_FUN SEXP ALTREP_CLASS(SEXP x) { return TAG(x); }`
		401
		402	`INLINE_FUN SEXP R_altrep_data1(SEXP x) { return CAR(x); }`
		403	`INLINE_FUN SEXP R_altrep_data2(SEXP x) { return CDR(x); }`
		404	`INLINE_FUN void R_set_altrep_data1(SEXP x, SEXP v) { SETCAR(x, v); }`
		405	`INLINE_FUN void R_set_altrep_data2(SEXP x, SEXP v) { SETCDR(x, v); }`
		406
73395	luke	407	`INLINE_FUN int INTEGER_ELT(SEXP x, R_xlen_t i)`
		408	`{`
		409	`CHECK_VECTOR_INT_ELT(x, i);`
73593	luke	410	`return ALTREP(x) ? ALTINTEGER_ELT(x, i) : INTEGER0(x)[i];`
73395	luke	411	`}`
		412
73762	luke	413	`INLINE_FUN void SET_INTEGER_ELT(SEXP x, R_xlen_t i, int v)`
		414	`{`
		415	`CHECK_VECTOR_INT_ELT(x, i);`
		416	`if (ALTREP(x)) ALTINTEGER_SET_ELT(x, i, v);`
		417	`else INTEGER0(x)[i] = v;`
		418	`}`
		419
73395	luke	420	`INLINE_FUN int LOGICAL_ELT(SEXP x, R_xlen_t i)`
		421	`{`
		422	`CHECK_VECTOR_LGL_ELT(x, i);`
		423	`return ALTREP(x) ? ALTLOGICAL_ELT(x, i) : LOGICAL0(x)[i];`
		424	`}`
		425
73762	luke	426	`INLINE_FUN void SET_LOGICAL_ELT(SEXP x, R_xlen_t i, int v)`
		427	`{`
		428	`CHECK_VECTOR_LGL_ELT(x, i);`
		429	`if (ALTREP(x)) ALTLOGICAL_SET_ELT(x, i, v);`
		430	`else LOGICAL0(x)[i] = v;`
		431	`}`
		432
73395	luke	433	`INLINE_FUN double REAL_ELT(SEXP x, R_xlen_t i)`
		434	`{`
		435	`CHECK_VECTOR_REAL_ELT(x, i);`
73593	luke	436	`return ALTREP(x) ? ALTREAL_ELT(x, i) : REAL0(x)[i];`
73395	luke	437	`}`
		438
73762	luke	439	`INLINE_FUN void SET_REAL_ELT(SEXP x, R_xlen_t i, double v)`
		440	`{`
		441	`CHECK_VECTOR_REAL_ELT(x, i);`
		442	`if (ALTREP(x)) ALTREAL_SET_ELT(x, i, v);`
		443	`else REAL0(x)[i] = v;`
		444	`}`
		445
73395	luke	446	`INLINE_FUN Rcomplex COMPLEX_ELT(SEXP x, R_xlen_t i)`
		447	`{`
		448	`CHECK_VECTOR_CPLX_ELT(x, i);`
		449	`return ALTREP(x) ? ALTCOMPLEX_ELT(x, i) : COMPLEX0(x)[i];`
		450	`}`
		451
73762	luke	452	`INLINE_FUN void SET_COMPLEX_ELT(SEXP x, R_xlen_t i, Rcomplex v)`
		453	`{`
		454	`CHECK_VECTOR_CPLX_ELT(x, i);`
		455	`if (ALTREP(x)) ALTCOMPLEX_SET_ELT(x, i, v);`
		456	`else COMPLEX0(x)[i] = v;`
		457	`}`
		458
73598	luke	459	`INLINE_FUN Rbyte RAW_ELT(SEXP x, R_xlen_t i)`
		460	`{`
		461	`CHECK_VECTOR_RAW_ELT(x, i);`
		462	`return ALTREP(x) ? ALTRAW_ELT(x, i) : RAW0(x)[i];`
		463	`}`
		464
75481	luke	465	`INLINE_FUN void SET_RAW_ELT(SEXP x, R_xlen_t i, Rbyte v)`
73762	luke	466	`{`
75481	luke	467	`CHECK_VECTOR_RAW_ELT(x, i);`
		468	`if (ALTREP(x)) ALTRAW_SET_ELT(x, i, v);`
		469	`else RAW0(x)[i] = v;`
73762	luke	470	`}`
		471
73586	luke	472	`#if !defined(COMPILING_R) && !defined(COMPILING_MEMORY_C) && \`
73579	luke	473	`!defined(TESTING_WRITE_BARRIER)`
		474	`/* if not inlining use version in memory.c with more error checking */`
		475	`INLINE_FUN SEXP STRING_ELT(SEXP x, R_xlen_t i) {`
		476	`if (ALTREP(x))`
		477	`return ALTSTRING_ELT(x, i);`
		478	`else {`
		479	`SEXP *ps = STDVEC_DATAPTR(x);`
		480	`return ps[i];`
		481	`}`
		482	`}`
73586	luke	483	`#else`
		484	`SEXP STRING_ELT(SEXP x, R_xlen_t i);`
73579	luke	485	`#endif`
73395	luke	486
63436	luke	487	`#ifdef INLINE_PROTECT`
84904	kalibera	488	`LibExtern int R_PPStackSize;`
		489	`LibExtern int R_PPStackTop;`
		490	`LibExtern SEXP* R_PPStack;`
37088	ripley	491
63436	luke	492	`INLINE_FUN SEXP protect(SEXP s)`
		493	`{`
75618	luke	494	`R_CHECK_THREAD;`
63436	luke	495	`if (R_PPStackTop < R_PPStackSize)`
		496	`R_PPStack[R_PPStackTop++] = s;`
		497	`else R_signal_protect_error();`
		498	`return s;`
		499	`}`
		500
		501	`INLINE_FUN void unprotect(int l)`
		502	`{`
75618	luke	503	`R_CHECK_THREAD;`
63436	luke	504	`#ifdef PROTECT_PARANOID`
		505	`if (R_PPStackTop >= l)`
		506	`R_PPStackTop -= l;`
		507	`else R_signal_unprotect_error();`
		508	`#else`
		509	`R_PPStackTop -= l;`
		510	`#endif`
		511	`}`
		512
		513	`INLINE_FUN void R_ProtectWithIndex(SEXP s, PROTECT_INDEX *pi)`
		514	`{`
		515	`protect(s);`
		516	`*pi = R_PPStackTop - 1;`
		517	`}`
		518
		519	`INLINE_FUN void R_Reprotect(SEXP s, PROTECT_INDEX i)`
		520	`{`
75618	luke	521	`R_CHECK_THREAD;`
63436	luke	522	`if (i >= R_PPStackTop \|\| i < 0)`
		523	`R_signal_reprotect_error(i);`
		524	`R_PPStack[i] = s;`
		525	`}`
		526	`#endif /* INLINE_PROTECT */`
		527
37088	ripley	528	`/* from dstruct.c */`
		529
		530	`/* length - length of objects */`
		531
38662	ripley	532	`int Rf_envlength(SEXP rho);`
37088	ripley	533
48980	maechler	534	`/* TODO: a Length(.) {say} which is length() + dispatch (S3 + S4) if needed`
		535	`for one approach, see do_seq_along() in ../main/seq.c`
		536	`*/`
37088	ripley	537	`INLINE_FUN R_len_t length(SEXP s)`
		538	`{`
		539	`switch (TYPEOF(s)) {`
		540	`case NILSXP:`
		541	`return 0;`
		542	`case LGLSXP:`
		543	`case INTSXP:`
		544	`case REALSXP:`
		545	`case CPLXSXP:`
		546	`case STRSXP:`
		547	`case CHARSXP:`
		548	`case VECSXP:`
		549	`case EXPRSXP:`
		550	`case RAWSXP:`
		551	`return LENGTH(s);`
		552	`case LISTSXP:`
		553	`case LANGSXP:`
		554	`case DOTSXP:`
68527	ripley	555	`{`
		556	`int i = 0;`
37088	ripley	557	`while (s != NULL && s != R_NilValue) {`
		558	`i++;`
		559	`s = CDR(s);`
		560	`}`
		561	`return i;`
68527	ripley	562	`}`
37088	ripley	563	`case ENVSXP:`
38662	ripley	564	`return Rf_envlength(s);`
37088	ripley	565	`default:`
		566	`return 1;`
		567	`}`
		568	`}`
		569
68527	ripley	570	`R_xlen_t Rf_envxlength(SEXP rho);`
		571
59009	ripley	572	`INLINE_FUN R_xlen_t xlength(SEXP s)`
		573	`{`
		574	`switch (TYPEOF(s)) {`
		575	`case NILSXP:`
		576	`return 0;`
		577	`case LGLSXP:`
		578	`case INTSXP:`
		579	`case REALSXP:`
		580	`case CPLXSXP:`
		581	`case STRSXP:`
		582	`case CHARSXP:`
		583	`case VECSXP:`
		584	`case EXPRSXP:`
		585	`case RAWSXP:`
		586	`return XLENGTH(s);`
		587	`case LISTSXP:`
		588	`case LANGSXP:`
		589	`case DOTSXP:`
68527	ripley	590	`{`
		591	`// it is implausible this would be >= 2^31 elements, but allow it`
		592	`R_xlen_t i = 0;`
59009	ripley	593	`while (s != NULL && s != R_NilValue) {`
		594	`i++;`
		595	`s = CDR(s);`
		596	`}`
		597	`return i;`
68527	ripley	598	`}`
59009	ripley	599	`case ENVSXP:`
68527	ripley	600	`return Rf_envxlength(s);`
59009	ripley	601	`default:`
		602	`return 1;`
		603	`}`
		604	`}`
37088	ripley	605
65160	urbaneks	606	`/* regular allocVector() as a special case of allocVector3() with no custom allocator */`
		607	`INLINE_FUN SEXP allocVector(SEXPTYPE type, R_xlen_t length)`
		608	`{`
		609	`return allocVector3(type, length, NULL);`
		610	`}`
59009	ripley	611
37088	ripley	612	`/* from list.c */`
		613	`/* Return a dotted pair with the given CAR and CDR. */`
		614	`/* The (R) TAG slot on the cell is set to NULL. */`
		615
		616
		617	`/* Get the i-th element of a list */`
		618	`INLINE_FUN SEXP elt(SEXP list, int i)`
		619	`{`
		620	`int j;`
		621	`SEXP result = list;`
		622
		623	`if ((i < 0) \|\| (i > length(list)))`
		624	`return R_NilValue;`
		625	`else`
		626	`for (j = 0; j < i; j++)`
		627	`result = CDR(result);`
		628
		629	`return CAR(result);`
		630	`}`
		631
		632
		633	`/* Return the last element of a list */`
		634	`INLINE_FUN SEXP lastElt(SEXP list)`
		635	`{`
		636	`SEXP result = R_NilValue;`
		637	`while (list != R_NilValue) {`
		638	`result = list;`
		639	`list = CDR(list);`
		640	`}`
		641	`return result;`
		642	`}`
		643
		644
		645	`/* Shorthands for creating small lists */`
		646
		647	`INLINE_FUN SEXP list1(SEXP s)`
		648	`{`
		649	`return CONS(s, R_NilValue);`
		650	`}`
		651
		652
		653	`INLINE_FUN SEXP list2(SEXP s, SEXP t)`
		654	`{`
		655	`PROTECT(s);`
		656	`s = CONS(s, list1(t));`
		657	`UNPROTECT(1);`
		658	`return s;`
		659	`}`
		660
		661
		662	`INLINE_FUN SEXP list3(SEXP s, SEXP t, SEXP u)`
		663	`{`
		664	`PROTECT(s);`
		665	`s = CONS(s, list2(t, u));`
		666	`UNPROTECT(1);`
		667	`return s;`
		668	`}`
		669
		670
		671	`INLINE_FUN SEXP list4(SEXP s, SEXP t, SEXP u, SEXP v)`
		672	`{`
		673	`PROTECT(s);`
		674	`s = CONS(s, list3(t, u, v));`
		675	`UNPROTECT(1);`
		676	`return s;`
		677	`}`
		678
51659	maechler	679	`INLINE_FUN SEXP list5(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w)`
		680	`{`
		681	`PROTECT(s);`
		682	`s = CONS(s, list4(t, u, v, w));`
		683	`UNPROTECT(1);`
		684	`return s;`
		685	`}`
37088	ripley	686
70560	morgan	687	`INLINE_FUN SEXP list6(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x)`
		688	`{`
		689	`PROTECT(s);`
		690	`s = CONS(s, list5(t, u, v, w, x));`
		691	`UNPROTECT(1);`
		692	`return s;`
		693	`}`
51659	maechler	694
37088	ripley	695	/* Destructive list append : See also ``append'' */
		696
		697	`INLINE_FUN SEXP listAppend(SEXP s, SEXP t)`
		698	`{`
		699	`SEXP r;`
		700	`if (s == R_NilValue)`
		701	`return t;`
		702	`r = s;`
		703	`while (CDR(r) != R_NilValue)`
		704	`r = CDR(r);`
		705	`SETCDR(r, t);`
		706	`return s;`
		707	`}`
		708
		709
		710	`/* Language based list constructs. These are identical to the list */`
		711	`/* constructs, but the results can be evaluated. */`
		712
		713	`/* Return a (language) dotted pair with the given car and cdr */`
		714
		715	`INLINE_FUN SEXP lcons(SEXP car, SEXP cdr)`
		716	`{`
		717	`SEXP e = cons(car, cdr);`
		718	`SET_TYPEOF(e, LANGSXP);`
		719	`return e;`
		720	`}`
		721
		722	`INLINE_FUN SEXP lang1(SEXP s)`
		723	`{`
		724	`return LCONS(s, R_NilValue);`
		725	`}`
		726
		727	`INLINE_FUN SEXP lang2(SEXP s, SEXP t)`
		728	`{`
		729	`PROTECT(s);`
		730	`s = LCONS(s, list1(t));`
		731	`UNPROTECT(1);`
		732	`return s;`
		733	`}`
		734
		735	`INLINE_FUN SEXP lang3(SEXP s, SEXP t, SEXP u)`
		736	`{`
		737	`PROTECT(s);`
		738	`s = LCONS(s, list2(t, u));`
		739	`UNPROTECT(1);`
		740	`return s;`
		741	`}`
		742
		743	`INLINE_FUN SEXP lang4(SEXP s, SEXP t, SEXP u, SEXP v)`
		744	`{`
		745	`PROTECT(s);`
		746	`s = LCONS(s, list3(t, u, v));`
		747	`UNPROTECT(1);`
		748	`return s;`
		749	`}`
		750
51659	maechler	751	`INLINE_FUN SEXP lang5(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w)`
		752	`{`
		753	`PROTECT(s);`
		754	`s = LCONS(s, list4(t, u, v, w));`
		755	`UNPROTECT(1);`
		756	`return s;`
		757	`}`
		758
		759	`INLINE_FUN SEXP lang6(SEXP s, SEXP t, SEXP u, SEXP v, SEXP w, SEXP x)`
		760	`{`
		761	`PROTECT(s);`
		762	`s = LCONS(s, list5(t, u, v, w, x));`
		763	`UNPROTECT(1);`
		764	`return s;`
		765	`}`
		766
37088	ripley	767	`/* from util.c */`
		768
37087	ripley	769	`/* Check to see if the arrays "x" and "y" have the identical extents */`
		770
86628	luke	771	`HIDDEN INLINE_FUN Rboolean conformable(SEXP x, SEXP y)`
37087	ripley	772	`{`
		773	`int i, n;`
		774	`PROTECT(x = getAttrib(x, R_DimSymbol));`
		775	`y = getAttrib(y, R_DimSymbol);`
		776	`UNPROTECT(1);`
		777	`if ((n = length(x)) != length(y))`
		778	`return FALSE;`
		779	`for (i = 0; i < n; i++)`
		780	`if (INTEGER(x)[i] != INTEGER(y)[i])`
		781	`return FALSE;`
		782	`return TRUE;`
		783	`}`
		784
52431	maechler	785	`/* NOTE: R's inherits() is based on inherits3() in ../main/objects.c`
		786	`* Here, use char / CHAR() instead of the slower more general translateChar()`
		787	`*/`
41781	ripley	788	`INLINE_FUN Rboolean inherits(SEXP s, const char *name)`
37087	ripley	789	`{`
39863	duncan	790	`SEXP klass;`
37087	ripley	791	`int i, nclass;`
41636	ripley	792	`if (OBJECT(s)) {`
39863	duncan	793	`klass = getAttrib(s, R_ClassSymbol);`
		794	`nclass = length(klass);`
37087	ripley	795	`for (i = 0; i < nclass; i++) {`
39863	duncan	796	`if (!strcmp(CHAR(STRING_ELT(klass, i)), name))`
37087	ripley	797	`return TRUE;`
		798	`}`
		799	`}`
		800	`return FALSE;`
		801	`}`
		802
89191	luke	803	`INLINE_FUN Rboolean isScalarString(SEXP x)`
		804	`{`
		805	`return TYPEOF(x) == STRSXP && XLENGTH(x) == 1;`
		806	`}`
		807
89552	luke	808	`//HIDDEN`
		809	`INLINE_FUN Rboolean isValidString(SEXP x)`
37087	ripley	810	`{`
41636	ripley	811	`return TYPEOF(x) == STRSXP && LENGTH(x) > 0 && TYPEOF(STRING_ELT(x, 0)) != NILSXP;`
37087	ripley	812	`}`
		813
		814	`/* non-empty ("") valid string :*/`
89523	luke	815	`HIDDEN INLINE_FUN Rboolean isValidStringF(SEXP x)`
37087	ripley	816	`{`
		817	`return isValidString(x) && CHAR(STRING_ELT(x, 0))[0];`
		818	`}`
		819
86628	luke	820	`HIDDEN INLINE_FUN Rboolean isUserBinop(SEXP s)`
37087	ripley	821	`{`
41636	ripley	822	`if (TYPEOF(s) == SYMSXP) {`
41777	ripley	823	`const char *str = CHAR(PRINTNAME(s));`
37087	ripley	824	`if (strlen(str) >= 2 && str[0] == '%' && str[strlen(str)-1] == '%')`
		825	`return TRUE;`
		826	`}`
		827	`return FALSE;`
		828	`}`
		829
		830	`INLINE_FUN Rboolean isFunction(SEXP s)`
		831	`{`
		832	`return (TYPEOF(s) == CLOSXP \|\|`
		833	`TYPEOF(s) == BUILTINSXP \|\|`
		834	`TYPEOF(s) == SPECIALSXP);`
		835	`}`
		836
		837	`INLINE_FUN Rboolean isPrimitive(SEXP s)`
		838	`{`
		839	`return (TYPEOF(s) == BUILTINSXP \|\|`
		840	`TYPEOF(s) == SPECIALSXP);`
		841	`}`
		842
		843	`INLINE_FUN Rboolean isList(SEXP s)`
		844	`{`
		845	`return (s == R_NilValue \|\| TYPEOF(s) == LISTSXP);`
		846	`}`
		847
		848
		849	`INLINE_FUN Rboolean isNewList(SEXP s)`
		850	`{`
		851	`return (s == R_NilValue \|\| TYPEOF(s) == VECSXP);`
		852	`}`
		853
		854	`INLINE_FUN Rboolean isPairList(SEXP s)`
		855	`{`
		856	`switch (TYPEOF(s)) {`
		857	`case NILSXP:`
		858	`case LISTSXP:`
		859	`case LANGSXP:`
67162	lawrence	860	`case DOTSXP:`
37087	ripley	861	`return TRUE;`
		862	`default:`
		863	`return FALSE;`
		864	`}`
		865	`}`
		866
		867	`INLINE_FUN Rboolean isVectorList(SEXP s)`
		868	`{`
		869	`switch (TYPEOF(s)) {`
		870	`case VECSXP:`
		871	`case EXPRSXP:`
		872	`return TRUE;`
		873	`default:`
		874	`return FALSE;`
		875	`}`
		876	`}`
		877
		878	`INLINE_FUN Rboolean isVectorAtomic(SEXP s)`
		879	`{`
		880	`switch (TYPEOF(s)) {`
		881	`case LGLSXP:`
		882	`case INTSXP:`
		883	`case REALSXP:`
		884	`case CPLXSXP:`
		885	`case STRSXP:`
		886	`case RAWSXP:`
		887	`return TRUE;`
		888	`default: /* including NULL */`
		889	`return FALSE;`
		890	`}`
		891	`}`
		892
		893	`INLINE_FUN Rboolean isVector(SEXP s)/* === isVectorList() or isVectorAtomic() */`
		894	`{`
		895	`switch(TYPEOF(s)) {`
		896	`case LGLSXP:`
		897	`case INTSXP:`
		898	`case REALSXP:`
		899	`case CPLXSXP:`
		900	`case STRSXP:`
		901	`case RAWSXP:`
		902
		903	`case VECSXP:`
		904	`case EXPRSXP:`
		905	`return TRUE;`
		906	`default:`
		907	`return FALSE;`
		908	`}`
		909	`}`
		910
86702	luke	911	`INLINE_FUN Rboolean isDataFrame(SEXP s)`
37087	ripley	912	`{`
39863	duncan	913	`SEXP klass;`
37087	ripley	914	`int i;`
41636	ripley	915	`if (OBJECT(s)) {`
39863	duncan	916	`klass = getAttrib(s, R_ClassSymbol);`
		917	`for (i = 0; i < length(klass); i++)`
		918	`if (!strcmp(CHAR(STRING_ELT(klass, i)), "data.frame")) return TRUE;`
37087	ripley	919	`}`
		920	`return FALSE;`
		921	`}`
89685	luke	922	`/* keep available under old name for now for old RStudio in particular */`
		923	`INLINE_FUN Rboolean Rf_isFrame(SEXP s) { return isDataFrame(s); }`
37087	ripley	924
72690	maechler	925	`/* DIFFERENT than R's is.language(.) in ../main/coerce.c [do_is(), case 301:]`
		926	`* which is <=> SYMSXP \|\| LANGSXP \|\| EXPRSXP */`
37087	ripley	927	`INLINE_FUN Rboolean isLanguage(SEXP s)`
		928	`{`
		929	`return (s == R_NilValue \|\| TYPEOF(s) == LANGSXP);`
		930	`}`
		931
		932	`INLINE_FUN Rboolean isMatrix(SEXP s)`
		933	`{`
		934	`SEXP t;`
		935	`if (isVector(s)) {`
		936	`t = getAttrib(s, R_DimSymbol);`
40675	ripley	937	`/* You are not supposed to be able to assign a non-integer dim,`
		938	`although this might be possible by misuse of ATTRIB. */`
37087	ripley	939	`if (TYPEOF(t) == INTSXP && LENGTH(t) == 2)`
		940	`return TRUE;`
		941	`}`
		942	`return FALSE;`
		943	`}`
		944
		945	`INLINE_FUN Rboolean isArray(SEXP s)`
		946	`{`
		947	`SEXP t;`
		948	`if (isVector(s)) {`
		949	`t = getAttrib(s, R_DimSymbol);`
40675	ripley	950	`/* You are not supposed to be able to assign a 0-length dim,`
		951	`nor a non-integer dim */`
37087	ripley	952	`if (TYPEOF(t) == INTSXP && LENGTH(t) > 0)`
		953	`return TRUE;`
		954	`}`
		955	`return FALSE;`
		956	`}`
		957
		958	`INLINE_FUN Rboolean isTs(SEXP s)`
		959	`{`
		960	`return (isVector(s) && getAttrib(s, R_TspSymbol) != R_NilValue);`
		961	`}`
		962
		963
		964	`INLINE_FUN Rboolean isInteger(SEXP s)`
		965	`{`
		966	`return (TYPEOF(s) == INTSXP && !inherits(s, "factor"));`
		967	`}`
		968
		969	`INLINE_FUN Rboolean isFactor(SEXP s)`
		970	`{`
		971	`return (TYPEOF(s) == INTSXP && inherits(s, "factor"));`
		972	`}`
		973
		974	`INLINE_FUN int nlevels(SEXP f)`
		975	`{`
		976	`if (!isFactor(f))`
		977	`return 0;`
		978	`return LENGTH(getAttrib(f, R_LevelsSymbol));`
		979	`}`
		980
		981	`/* Is an object of numeric type. */`
		982	`/* FIXME: the LGLSXP case should be excluded here`
		983	`* (really? in many places we affirm they are treated like INTs)*/`
		984
		985	`INLINE_FUN Rboolean isNumeric(SEXP s)`
		986	`{`
		987	`switch(TYPEOF(s)) {`
		988	`case INTSXP:`
		989	`if (inherits(s,"factor")) return FALSE;`
		990	`case LGLSXP:`
		991	`case REALSXP:`
		992	`return TRUE;`
		993	`default:`
		994	`return FALSE;`
		995	`}`
		996	`}`
		997
49903	maechler	998	`/** Is an object "Numeric" or complex */`
		999	`INLINE_FUN Rboolean isNumber(SEXP s)`
		1000	`{`
		1001	`switch(TYPEOF(s)) {`
		1002	`case INTSXP:`
		1003	`if (inherits(s,"factor")) return FALSE;`
		1004	`case LGLSXP:`
		1005	`case REALSXP:`
		1006	`case CPLXSXP:`
		1007	`return TRUE;`
		1008	`default:`
		1009	`return FALSE;`
		1010	`}`
		1011	`}`
		1012
85382	maechler	1013
38064	ripley	1014	`/* As from R 2.4.0 we check that the value is allowed. */`
37087	ripley	1015	`INLINE_FUN SEXP ScalarLogical(int x)`
		1016	`{`
84904	kalibera	1017	`LibExtern SEXP R_LogicalNAValue, R_TrueValue, R_FalseValue;`
63591	luke	1018	`if (x == NA_LOGICAL) return R_LogicalNAValue;`
		1019	`else if (x != 0) return R_TrueValue;`
		1020	`else return R_FalseValue;`
37087	ripley	1021	`}`
		1022
		1023	`INLINE_FUN SEXP ScalarInteger(int x)`
		1024	`{`
73395	luke	1025	`SEXP ans = allocVector(INTSXP, 1);`
		1026	`SET_SCALAR_IVAL(ans, x);`
37087	ripley	1027	`return ans;`
		1028	`}`
		1029
		1030	`INLINE_FUN SEXP ScalarReal(double x)`
		1031	`{`
73395	luke	1032	`SEXP ans = allocVector(REALSXP, 1);`
		1033	`SET_SCALAR_DVAL(ans, x);`
37087	ripley	1034	`return ans;`
		1035	`}`
		1036
		1037	`INLINE_FUN SEXP ScalarComplex(Rcomplex x)`
		1038	`{`
73395	luke	1039	`SEXP ans = allocVector(CPLXSXP, 1);`
		1040	`SET_SCALAR_CVAL(ans, x);`
37087	ripley	1041	`return ans;`
		1042	`}`
		1043
		1044	`INLINE_FUN SEXP ScalarString(SEXP x)`
		1045	`{`
		1046	`SEXP ans;`
		1047	`PROTECT(x);`
59086	ripley	1048	`ans = allocVector(STRSXP, (R_xlen_t)1);`
		1049	`SET_STRING_ELT(ans, (R_xlen_t)0, x);`
37087	ripley	1050	`UNPROTECT(1);`
		1051	`return ans;`
		1052	`}`
		1053
		1054	`INLINE_FUN SEXP ScalarRaw(Rbyte x)`
		1055	`{`
73395	luke	1056	`SEXP ans = allocVector(RAWSXP, 1);`
		1057	`SET_SCALAR_BVAL(ans, x);`
37087	ripley	1058	`return ans;`
		1059	`}`
		1060
		1061	`/* Check to see if a list can be made into a vector. */`
		1062	`/* it must have every element being a vector of length 1. */`
		1063	`/* BUT it does not exclude 0! */`
		1064
		1065	`INLINE_FUN Rboolean isVectorizable(SEXP s)`
		1066	`{`
41636	ripley	1067	`if (s == R_NilValue) return TRUE;`
37087	ripley	1068	`else if (isNewList(s)) {`
59086	ripley	1069	`R_xlen_t i, n;`
37087	ripley	1070
59086	ripley	1071	`n = XLENGTH(s);`
37087	ripley	1072	`for (i = 0 ; i < n; i++)`
59086	ripley	1073	`if (!isVector(VECTOR_ELT(s, i)) \|\| XLENGTH(VECTOR_ELT(s, i)) > 1)`
37087	ripley	1074	`return FALSE;`
		1075	`return TRUE;`
		1076	`}`
		1077	`else if (isList(s)) {`
		1078	`for ( ; s != R_NilValue; s = CDR(s))`
		1079	`if (!isVector(CAR(s)) \|\| LENGTH(CAR(s)) > 1) return FALSE;`
		1080	`return TRUE;`
		1081	`}`
		1082	`else return FALSE;`
		1083	`}`
		1084
		1085
48980	maechler	1086	`/**`
		1087	`* Create a named vector of type TYP`
		1088	`*`
48981	maechler	1089	`* @example const char *nms[] = {"xi", "yi", "zi", ""};`
49020	maechler	1090	`* mkNamed(VECSXP, nms); =~= R list(xi=, yi=, zi=)`
48981	maechler	1091	`*`
48980	maechler	1092	`* @param TYP a vector SEXP type (e.g. REALSXP)`
		1093	`* @param names names of list elements with null string appended`
		1094	`*`
		1095	`* @return (pointer to a) named vector of type TYP`
		1096	`*/`
51659	maechler	1097	`INLINE_FUN SEXP mkNamed(SEXPTYPE TYP, const char **names)`
48980	maechler	1098	`{`
		1099	`SEXP ans, nms;`
59086	ripley	1100	`R_xlen_t i, n;`
48980	maechler	1101
		1102	`for (n = 0; strlen(names[n]) > 0; n++) {}`
		1103	`ans = PROTECT(allocVector(TYP, n));`
		1104	`nms = PROTECT(allocVector(STRSXP, n));`
		1105	`for (i = 0; i < n; i++)`
		1106	`SET_STRING_ELT(nms, i, mkChar(names[i]));`
		1107	`setAttrib(ans, R_NamesSymbol, nms);`
		1108	`UNPROTECT(2);`
		1109	`return ans;`
		1110	`}`
		1111
37088	ripley	1112	`/* from gram.y */`
37087	ripley	1113
48822	maechler	1114	`/* short cut for ScalarString(mkChar(s)) : */`
37088	ripley	1115	`INLINE_FUN SEXP mkString(const char *s)`
		1116	`{`
		1117	`SEXP t;`
		1118
59086	ripley	1119	`PROTECT(t = allocVector(STRSXP, (R_xlen_t)1));`
		1120	`SET_STRING_ELT(t, (R_xlen_t)0, mkChar(s));`
37088	ripley	1121	`UNPROTECT(1);`
		1122	`return t;`
		1123	`}`
64724	luke	1124
66477	luke	1125	`/* index of a given C string in (translated) R string vector */`
86628	luke	1126	`HIDDEN INLINE_FUN int`
66477	luke	1127	`stringPositionTr(SEXP string, const char *translatedElement) {`
		1128
		1129	`int slen = LENGTH(string);`
		1130	`int i;`
		1131
		1132	`const void *vmax = vmaxget();`
		1133	`for (i = 0 ; i < slen; i++) {`
		1134	`Rboolean found = ! strcmp(translateChar(STRING_ELT(string, i)),`
		1135	`translatedElement);`
		1136	`vmaxset(vmax);`
		1137	`if (found)`
		1138	`return i;`
		1139	`}`
		1140	`return -1; /* not found */`
		1141	`}`
		1142
64724	luke	1143	`/* duplicate RHS value of complex assignment if necessary to prevent cycles */`
86628	luke	1144	`HIDDEN INLINE_FUN SEXP R_FixupRHS(SEXP x, SEXP y)`
64724	luke	1145	`{`
65021	luke	1146	`if( y != R_NilValue && MAYBE_REFERENCED(y) ) {`
64724	luke	1147	`if (R_cycle_detected(x, y)) {`
		1148	`#ifdef WARNING_ON_CYCLE_DETECT`
		1149	`warning("cycle detected");`
		1150	`R_cycle_detected(x, y);`
		1151	`#endif`
		1152	`y = duplicate(y);`
		1153	`}`
73166	luke	1154	`else ENSURE_NAMEDMAX(y);`
64724	luke	1155	`}`
		1156	`return y;`
		1157	`}`
37087	ripley	1158	`#endif /* R_INLINES_H_ */`

The R Project SVN R

(root)/trunk/src/include/Rinlinedfuns.h @ 63243 – Rev 89685