1 #include <R.h>
2 #include "000.types.h"
3
4 #define R_TYPE_LGL 1 /* 0b0001 */
5 #define R_TYPE_INT 2 /* 0b0010 */
6 #define R_TYPE_REAL 4 /* 0b0100 */
7
8
assertArgVector(SEXP x,int type,char * xlabel)9 static R_INLINE void assertArgVector(SEXP x, int type, char *xlabel) {
10 /* Argument 'x': */
11 if (!isVectorAtomic(x)) {
12 error("Argument '%s' must be a matrix or a vector.", xlabel);
13 }
14 switch (TYPEOF(x)) {
15 case LGLSXP:
16 if (!(type & R_TYPE_LGL))
17 error("Argument '%s' cannot be logical.", xlabel);
18 break;
19
20 case INTSXP:
21 if (!(type & R_TYPE_INT))
22 error("Argument '%s' cannot be integer.", xlabel);
23 break;
24
25 case REALSXP:
26 if (!(type & R_TYPE_REAL))
27 error("Argument '%s' cannot be numeric.", xlabel);
28 break;
29
30 default:
31 error("Argument '%s' must be of type logical, integer or numeric, not '%s'.", xlabel, type2char(TYPEOF(x)));
32 } /* switch */
33 } /* assertArgVector() */
34
35
assertArgDim(SEXP dim,double max,char * maxlabel)36 static R_INLINE void assertArgDim(SEXP dim, double max, char *maxlabel) {
37 double nrow, ncol;
38 const char *dimlabel = "dim.";
39
40 /* Argument 'dim': */
41 if (!isVectorAtomic(dim) || xlength(dim) != 2 || !isInteger(dim)) {
42 error("Argument '%s' must be an integer vector of length two.", dimlabel);
43 }
44 nrow = (double)INTEGER(dim)[0];
45 ncol = (double)INTEGER(dim)[1];
46 if (nrow < 0) {
47 error("Argument '%s' specifies a negative number of rows (%s[1]): %g", dimlabel, dimlabel, nrow);
48 } else if (ncol < 0) {
49 error("Argument '%s' specifies a negative number of columns (%s[2]): %g", dimlabel, dimlabel, ncol);
50 } else if (nrow * ncol != max) {
51 error("Argument '%s' does not match length of argument '%s': %g * %g != %g", dimlabel, maxlabel, nrow, ncol, max);
52 }
53 } /* assertArgDim() */
54
55
assertArgMatrix(SEXP x,SEXP dim,int type,char * xlabel)56 static R_INLINE void assertArgMatrix(SEXP x, SEXP dim, int type, char *xlabel) {
57 /* Argument 'x': */
58 if (isMatrix(x)) {
59 } else if (isVectorAtomic(x)) {
60 } else {
61 error("Argument '%s' must be a matrix or a vector.", xlabel);
62 }
63 switch (TYPEOF(x)) {
64 case LGLSXP:
65 if (!(type & R_TYPE_LGL))
66 error("Argument '%s' cannot be logical.", xlabel);
67 break;
68
69 case INTSXP:
70 if (!(type & R_TYPE_INT))
71 error("Argument '%s' cannot be integer.", xlabel);
72 break;
73
74 case REALSXP:
75 if (!(type & R_TYPE_REAL))
76 error("Argument '%s' cannot be numeric.", xlabel);
77 break;
78
79 default:
80 error("Argument '%s' must be of type logical, integer or numeric, not '%s'.", xlabel, type2char(TYPEOF(x)));
81 } /* switch */
82
83 /* Argument 'dim': */
84 assertArgDim(dim, xlength(x), "x");
85 } /* assertArgMatrix() */
86
87
asLogicalNoNA(SEXP x,char * xlabel)88 static R_INLINE int asLogicalNoNA(SEXP x, char *xlabel) {
89 int value = 0;
90
91 if (length(x) != 1)
92 error("Argument '%s' must be a single value.", xlabel);
93 if (isLogical(x)) {
94 value = asLogical(x);
95 } else if (isInteger(x)) {
96 value = asInteger(x);
97 } else {
98 error("Argument '%s' must be a logical.", xlabel);
99 }
100 if (value != TRUE && value != FALSE)
101 error("Argument '%s' must be either TRUE or FALSE.", xlabel);
102
103 return value;
104 } /* asLogicalNoNA() */
105
106
107 /* Retrieve the 'i'th element of 'x' as R_xlen_t */
asR_xlen_t(SEXP x,R_xlen_t i)108 static R_INLINE R_xlen_t asR_xlen_t(SEXP x, R_xlen_t i) {
109 int mode = TYPEOF(x);
110 switch (mode) {
111 case INTSXP: return INTEGER(x)[i];
112 case REALSXP: return REAL(x)[i];
113 default: error("only integer and numeric are supported, not '%s'.", type2char(TYPEOF(x)));
114 }
115 return 0;
116 } /* asR_xlen_t() */
117
118
119 /* Specified in validateIndices.c */
120 R_xlen_t *validateIndicesCheckNA(SEXP idxs, R_xlen_t maxIdx, int allowOutOfBound, R_xlen_t *ansNidxs, int *hasna);
121
122
123 R_xlen_t *validateIndices(SEXP idxs, R_xlen_t maxIdx, int allowOutOfBound, R_xlen_t *ansNidxs);
124
125
int_from_dbl(double x)126 static R_INLINE int int_from_dbl(double x) {
127 if (ISNAN(x)) return NA_INTEGER;
128 if (x > INT_MAX || x <= INT_MIN) return NA_INTEGER;
129 return x;
130 } /* int_from_dbl() */
131
132
dbl_from_int(int x)133 static R_INLINE double dbl_from_int(int x) {
134 if (x == NA_INTEGER) return NA_REAL;
135 return x;
136 } /* dbl_from_int() */
137
138
139 #define SWAP(type, x, y) { \
140 type tmp = x; \
141 x = y; \
142 y = tmp; \
143 }
144