1 #include "vctrs.h"
2
3 // SEXP x and y must be CHARSXP
4 // x_utf* is pointer to const char* which is lazily initialised:
5 // This makes this function also suitable for use when repeated
6 // comparing varying y to constant x
equal_string(SEXP x,const char ** x_utf8,SEXP y)7 bool equal_string(SEXP x, const char** x_utf8, SEXP y) {
8 // Try fast pointer comparison
9 if (x == y)
10 return true;
11
12 if (*x_utf8 == NULL)
13 *x_utf8 = Rf_translateCharUTF8(x);
14
15 // Try slower conversion to common encoding
16 const char* y_utf = Rf_translateCharUTF8(y);
17 return (strcmp(y_utf, *x_utf8) == 0);
18 }
19
find_offset(SEXP x,SEXP index)20 int find_offset(SEXP x, SEXP index) {
21 if (Rf_length(index) != 1) {
22 Rf_errorcall(R_NilValue, "Invalid index: must have length 1");
23 }
24
25 int n = Rf_length(x);
26
27 if (TYPEOF(index) == INTSXP) {
28 int val = INTEGER(index)[0];
29
30 if (val == NA_INTEGER)
31 Rf_errorcall(R_NilValue, "Invalid index: NA_integer_");
32
33 val--;
34 if (val < 0 || val >= n)
35 Rf_errorcall(R_NilValue, "Invalid index: out of bounds");
36
37 return val;
38 } else if (TYPEOF(index) == REALSXP) {
39 double val = REAL(index)[0];
40
41 if (R_IsNA(val))
42 Rf_errorcall(R_NilValue, "Invalid index: NA_real_");
43
44 val--;
45 if (val < 0 || val >= n)
46 Rf_errorcall(R_NilValue, "Invalid index: out of bounds");
47
48 if (val > R_LEN_T_MAX) {
49 Rf_errorcall(R_NilValue, "Invalid index: too large");
50 }
51
52 return (int) val;
53 } else if (TYPEOF(index) == STRSXP) {
54 SEXP names = PROTECT(Rf_getAttrib(x, R_NamesSymbol));
55 if (names == R_NilValue)
56 Rf_errorcall(R_NilValue, "Corrupt x: no names");
57
58 SEXP val_0 = STRING_ELT(index, 0);
59 if (val_0 == NA_STRING)
60 Rf_errorcall(R_NilValue, "Invalid index: NA_character_");
61
62 const char* val_0_chr = Rf_translateCharUTF8(val_0);
63 if (val_0_chr[0] == '\0')
64 Rf_errorcall(R_NilValue, "Invalid index: empty string");
65
66 for (int j = 0; j < Rf_length(names); ++j) {
67 SEXP name_j = STRING_ELT(names, j);
68 if (name_j == NA_STRING)
69 Rf_errorcall(R_NilValue, "Corrupt x: element %i is unnamed", j + 1);
70
71 if (equal_string(val_0, &val_0_chr, name_j)) {
72 UNPROTECT(1);
73 return j;
74 }
75 }
76 Rf_errorcall(R_NilValue, "Invalid index: field name '%s' not found", val_0_chr);
77 } else {
78 Rf_errorcall(R_NilValue, "Invalid index: must be a character or numeric vector");
79 }
80 }
81
82 // Lists -------------------------------------------------------------------
83
vctrs_list_get(SEXP x,SEXP index)84 SEXP vctrs_list_get(SEXP x, SEXP index) {
85 int idx = find_offset(x, index);
86
87 return VECTOR_ELT(x, idx);
88 }
89
vctrs_list_set(SEXP x,SEXP index,SEXP value)90 SEXP vctrs_list_set(SEXP x, SEXP index, SEXP value) {
91 int idx = find_offset(x, index);
92
93 SEXP out = PROTECT(Rf_shallow_duplicate(x));
94 SET_VECTOR_ELT(out, idx, value);
95 UNPROTECT(1);
96
97 return out;
98 }
99
100 // Records ------------------------------------------------------------------
101
check_rcrd(SEXP x)102 void check_rcrd(SEXP x) {
103 if (!Rf_isVectorList(x))
104 Rf_errorcall(R_NilValue, "Corrupt rcrd: not a list");
105 if (Rf_length(x) == 0)
106 Rf_errorcall(R_NilValue, "Corrupt rcrd: length 0");
107 }
108
vctrs_fields(SEXP x)109 SEXP vctrs_fields(SEXP x) {
110 check_rcrd(x);
111
112 return Rf_getAttrib(x, R_NamesSymbol);
113 }
114
vctrs_n_fields(SEXP x)115 SEXP vctrs_n_fields(SEXP x) {
116 check_rcrd(x);
117
118 return Rf_ScalarInteger(Rf_length(x));
119 }
120
vctrs_field_get(SEXP x,SEXP index)121 SEXP vctrs_field_get(SEXP x, SEXP index) {
122 check_rcrd(x);
123 return vctrs_list_get(x, index);
124 }
125
vctrs_field_set(SEXP x,SEXP index,SEXP value)126 SEXP vctrs_field_set(SEXP x, SEXP index, SEXP value) {
127 check_rcrd(x);
128
129 if (!vec_is_vector(value)) {
130 Rf_errorcall(R_NilValue, "Invalid value: not a vector.");
131 }
132
133 if (vec_size(value) != vec_size(x)) {
134 Rf_errorcall(R_NilValue, "Invalid value: incorrect length.");
135 }
136
137 return vctrs_list_set(x, index, value);
138 }
139