1
#include "utils.h"
2
#include "divmod.h"
3

4
// -----------------------------------------------------------------------------
5

6
SEXP warp_ns_env = NULL;
7

8
SEXP syms_x = NULL;
9
SEXP syms_tzone = NULL;
10
SEXP syms_class = NULL;
11

12
SEXP syms_as_posixct_from_posixlt = NULL;
13
SEXP syms_as_posixlt_from_posixct = NULL;
14
SEXP syms_as_date = NULL;
15

16
SEXP fns_as_posixct_from_posixlt = NULL;
17
SEXP fns_as_posixlt_from_posixct = NULL;
18
SEXP fns_as_date = NULL;
19

20
SEXP classes_data_frame = NULL;
21
SEXP classes_posixct = NULL;
22

23
SEXP strings_start_stop = NULL;
24

25
SEXP chars = NULL;
26
SEXP char_posixlt = NULL;
27
SEXP char_posixct = NULL;
28
SEXP char_posixt = NULL;
29
SEXP char_date = NULL;
30

31
// -----------------------------------------------------------------------------
32

33
enum warp_class_type time_class_type(SEXP x);
34
static enum warp_class_type time_class_type_impl(SEXP klass);
35
static const char* class_type_as_str(enum warp_class_type type);
36

37
// [[ register() ]]
38 1
SEXP warp_class_type(SEXP x) {
39 1
  return Rf_mkString(class_type_as_str(time_class_type(x)));
40
}
41

42 1
enum warp_class_type time_class_type(SEXP x) {
43 1
  if (!OBJECT(x)) {
44 1
    return warp_class_unknown;
45
  }
46

47 1
  SEXP klass = PROTECT(Rf_getAttrib(x, R_ClassSymbol));
48 1
  enum warp_class_type type = time_class_type_impl(klass);
49

50 1
  UNPROTECT(1);
51 1
  return type;
52
}
53

54 1
static enum warp_class_type time_class_type_impl(SEXP klass) {
55 1
  int n = Rf_length(klass);
56 1
  SEXP const* p_klass = STRING_PTR(klass);
57

58 1
  p_klass += n - 2;
59 1
  SEXP butlast = *p_klass++;
60 1
  SEXP last = *p_klass++;
61

62 1
  if (last == char_date) {
63 1
    return warp_class_date;
64
  }
65

66 1
  if (last == char_posixt) {
67 1
    if (butlast == char_posixlt) {
68 1
      return warp_class_posixlt;
69 1
    } else if (butlast == char_posixct) {
70 1
      return warp_class_posixct;
71
    }
72
  }
73

74 0
  return warp_class_unknown;
75
}
76

77 1
static const char* class_type_as_str(enum warp_class_type type) {
78 1
  switch (type) {
79 1
  case warp_class_date: return "date";
80 1
  case warp_class_posixct: return "posixct";
81 0
  case warp_class_posixlt: return "posixlt";
82 0
  case warp_class_unknown: return "unknown";
83
  }
84 0
  never_reached("class_type_as_str");
85
}
86

87
// -----------------------------------------------------------------------------
88

89
// TODO - Could be lossy...really should use vctrs? Callable from C?
90 1
int pull_every(SEXP every) {
91 1
  if (Rf_length(every) != 1) {
92 1
    r_error("pull_every", "`every` must have size 1, not %i", Rf_length(every));
93
  }
94

95 1
  if (OBJECT(every) != 0) {
96 1
    r_error("pull_every", "`every` must be a bare integer-ish value.");
97
  }
98

99 1
  switch (TYPEOF(every)) {
100 1
  case INTSXP: return INTEGER(every)[0];
101 1
  case REALSXP: return Rf_asInteger(every);
102 1
  default: r_error("pull_every", "`every` must be integer-ish, not %s", Rf_type2char(TYPEOF(every)));
103
  }
104
}
105

106
// -----------------------------------------------------------------------------
107

108
// [[ include("utils.h") ]]
109 1
bool pull_endpoint(SEXP endpoint) {
110 1
  if (Rf_length(endpoint) != 1) {
111 0
    r_error("pull_endpoint", "`endpoint` must have size 1, not %i", Rf_length(endpoint));
112
  }
113

114 1
  if (OBJECT(endpoint) != 0) {
115 0
    r_error("pull_endpoint", "`endpoint` must be a bare logical value.");
116
  }
117

118 1
  switch (TYPEOF(endpoint)) {
119 1
  case LGLSXP: return LOGICAL(endpoint)[0];
120 0
  default: r_error("pull_endpoint", "`endpoint` must be logical, not %s", Rf_type2char(TYPEOF(endpoint)));
121
  }
122
}
123

124
// -----------------------------------------------------------------------------
125

126
// [[ include("utils.h") ]]
127 1
bool pull_last(SEXP last) {
128 1
  if (Rf_length(last) != 1) {
129 0
    r_error("pull_last", "`last` must have size 1, not %i", Rf_length(last));
130
  }
131

132 1
  if (OBJECT(last) != 0) {
133 0
    r_error("pull_last", "`last` must be a bare logical value.");
134
  }
135

136 1
  switch (TYPEOF(last)) {
137 1
  case LGLSXP: return LOGICAL(last)[0];
138 0
  default: r_error("pull_last", "`last` must be logical, not %s", Rf_type2char(TYPEOF(last)));
139
  }
140
}
141

142
// -----------------------------------------------------------------------------
143

144
#define YEARS_FROM_0001_01_01_TO_EPOCH 1969
145
#define LEAP_YEARS_FROM_0001_01_01_TO_EPOCH 477
146

147 1
int leap_years_before_and_including_year(int year_offset) {
148 1
  int year = year_offset + YEARS_FROM_0001_01_01_TO_EPOCH;
149

150 1
  int n_leap_years =
151 1
    int_div(year, 4) -
152 1
    int_div(year, 100) +
153 1
    int_div(year, 400);
154

155 1
  n_leap_years -= LEAP_YEARS_FROM_0001_01_01_TO_EPOCH;
156

157 1
  return n_leap_years;
158
}
159

160
#undef YEARS_FROM_0001_01_01_TO_EPOCH
161
#undef LEAP_YEARS_FROM_0001_01_01_TO_EPOCH
162

163
// -----------------------------------------------------------------------------
164

165
// [[ include("utils.h") ]]
166 1
bool str_equal(const char* x, const char* y) {
167 1
  return strcmp(x, y) == 0;
168
}
169

170
// -----------------------------------------------------------------------------
171

172
// [[ include("utils.h") ]]
173 1
enum warp_period_type as_period_type(SEXP period) {
174 1
  if (TYPEOF(period) != STRSXP || Rf_length(period) != 1) {
175 1
    Rf_errorcall(R_NilValue, "`period` must be a single string.");
176
  }
177

178 1
  const char* type = CHAR(STRING_ELT(period, 0));
179

180 1
  if (str_equal(type, "year")) {
181 1
    return warp_period_year;
182
  }
183

184 1
  if (str_equal(type, "quarter")) {
185 1
    return warp_period_quarter;
186
  }
187

188 1
  if (str_equal(type, "month")) {
189 1
    return warp_period_month;
190
  }
191

192 1
  if (str_equal(type, "week")) {
193 1
    return warp_period_week;
194
  }
195

196 1
  if (str_equal(type, "yweek")) {
197 1
    return warp_period_yweek;
198
  }
199

200 1
  if (str_equal(type, "mweek")) {
201 1
    return warp_period_mweek;
202
  }
203

204 1
  if (str_equal(type, "day")) {
205 1
    return warp_period_day;
206
  }
207

208 1
  if (str_equal(type, "yday")) {
209 1
    return warp_period_yday;
210
  }
211

212 1
  if (str_equal(type, "mday")) {
213 1
    return warp_period_mday;
214
  }
215

216 1
  if (str_equal(type, "hour")) {
217 1
    return warp_period_hour;
218
  }
219

220 1
  if (str_equal(type, "minute")) {
221 1
    return warp_period_minute;
222
  }
223

224 1
  if (str_equal(type, "second")) {
225 1
    return warp_period_second;
226
  }
227

228 1
  if (str_equal(type, "millisecond")) {
229 1
    return warp_period_millisecond;
230
  }
231

232 1
  Rf_errorcall(R_NilValue, "Unknown `period` value '%s'.", type);
233
}
234

235
// -----------------------------------------------------------------------------
236

237
#define BUFSIZE 8192
238

239
// [[ include("utils.h") ]]
240 1
void __attribute__((noreturn)) r_error(const char* where, const char* why, ...) {
241
  char buf[BUFSIZE];
242

243
  va_list dots;
244 1
  va_start(dots, why);
245 1
  vsnprintf(buf, BUFSIZE, why, dots);
246 1
  va_end(dots);
247

248 1
  buf[BUFSIZE - 1] = '\0';
249

250 1
  Rf_errorcall(R_NilValue, "In C function `%s()`: %s", where, buf);
251
}
252

253
#undef BUFSIZE
254

255
// [[ include("utils.h") ]]
256 0
void __attribute__((noreturn)) never_reached(const char* fn) {
257 0
  r_error("never_reached", "Internal error in `%s()`: Reached the unreachable.", fn);
258
}
259

260
// -----------------------------------------------------------------------------
261

262 1
static SEXP r_env_get(SEXP env, SEXP sym) {
263 1
  SEXP obj = PROTECT(Rf_findVarInFrame3(env, sym, FALSE));
264

265
  // Force lazy loaded bindings
266 1
  if (TYPEOF(obj) == PROMSXP) {
267 1
    obj = Rf_eval(obj, R_BaseEnv);
268
  }
269

270 1
  UNPROTECT(1);
271 1
  return obj;
272
}
273

274
// [[ include("utils.h") ]]
275 1
SEXP r_maybe_duplicate(SEXP x) {
276 1
  if (MAYBE_REFERENCED(x)) {
277 1
    return Rf_shallow_duplicate(x);
278
  } else {
279 1
    return x;
280
  }
281
}
282

283
// -----------------------------------------------------------------------------
284

285
#include <R_ext/Parse.h>
286

287 0
static void abort_parse(SEXP code, const char* why) {
288 0
  if (Rf_GetOption1(Rf_install("rlang__verbose_errors")) != R_NilValue) {
289 0
    Rf_PrintValue(code);
290
  }
291 0
  Rf_error("Internal error: %s", why);
292
}
293

294 1
static SEXP r_parse(const char* str) {
295 1
  SEXP str_ = PROTECT(Rf_mkString(str));
296

297
  ParseStatus status;
298 1
  SEXP out = PROTECT(R_ParseVector(str_, -1, &status, R_NilValue));
299 1
  if (status != PARSE_OK) {
300 0
    abort_parse(str_, "Parsing failed");
301
  }
302 1
  if (Rf_length(out) != 1) {
303 0
    abort_parse(str_, "Expected a single expression");
304
  }
305

306 1
  out = VECTOR_ELT(out, 0);
307

308 1
  UNPROTECT(2);
309 1
  return out;
310
}
311

312 1
static SEXP r_parse_eval(const char* str, SEXP env) {
313 1
  SEXP out = Rf_eval(PROTECT(r_parse(str)), env);
314 1
  UNPROTECT(1);
315 1
  return out;
316
}
317

318
static SEXP new_env_call = NULL;
319
static SEXP new_env__parent_node = NULL;
320
static SEXP new_env__size_node = NULL;
321

322 1
static SEXP r_new_environment(SEXP parent, R_len_t size) {
323 1
  parent = parent ? parent : R_EmptyEnv;
324 1
  SETCAR(new_env__parent_node, parent);
325

326 1
  size = size ? size : 29;
327 1
  SETCAR(new_env__size_node, Rf_ScalarInteger(size));
328

329 1
  SEXP env = Rf_eval(new_env_call, R_BaseEnv);
330

331
  // Free for gc
332 1
  SETCAR(new_env__parent_node, R_NilValue);
333

334 1
  return env;
335
}
336

337
// -----------------------------------------------------------------------------
338

339
/**
340
 * Create a call or pairlist
341
 *
342
 * @param tags Optional. If not `NULL`, a null-terminated array of symbols.
343
 * @param cars Mandatory. A null-terminated array of CAR values.
344
 * @param fn The first CAR value of the language list.
345
 *
346
 */
347 1
static SEXP r_pairlist(SEXP* tags, SEXP* cars) {
348 1
  if (!cars) {
349 0
    Rf_error("Internal error: Null `cars` in `r_pairlist()`");
350
  }
351

352 1
  SEXP list = PROTECT(Rf_cons(R_NilValue, R_NilValue));
353 1
  SEXP node = list;
354

355 1
  while (*cars) {
356 1
    SEXP next_node = Rf_cons(*cars, R_NilValue);
357 1
    SETCDR(node, next_node);
358 1
    node = next_node;
359

360 1
    if (tags) {
361 1
      SET_TAG(next_node, *tags);
362 1
      ++tags;
363
    }
364

365 1
    ++cars;
366
  }
367

368 1
  UNPROTECT(1);
369 1
  return CDR(list);
370
}
371

372 1
static SEXP r_call(SEXP fn, SEXP* tags, SEXP* cars) {
373 1
  return Rf_lcons(fn, r_pairlist(tags, cars));
374
}
375

376 1
static SEXP warp_eval_mask_n_impl(SEXP fn, SEXP* syms, SEXP* args, SEXP mask) {
377 1
  SEXP call = PROTECT(r_call(fn, syms, syms));
378

379 1
  while (*syms) {
380 1
    Rf_defineVar(*syms, *args, mask);
381 1
    ++syms; ++args;
382
  }
383

384 1
  SEXP out = Rf_eval(call, mask);
385

386 1
  UNPROTECT(1);
387 1
  return out;
388
}
389

390 1
SEXP warp_dispatch_n(SEXP fn_sym, SEXP fn, SEXP* syms, SEXP* args) {
391
  // Mask `fn` with `fn_sym`. We dispatch in the global environment.
392 1
  SEXP mask = PROTECT(r_new_environment(R_GlobalEnv, 4));
393 1
  Rf_defineVar(fn_sym, fn, mask);
394

395 1
  SEXP out = warp_eval_mask_n_impl(fn_sym, syms, args, mask);
396

397 1
  UNPROTECT(1);
398 1
  return out;
399
}
400

401 1
SEXP warp_dispatch1(SEXP fn_sym, SEXP fn,
402
                         SEXP x_sym, SEXP x) {
403 1
  SEXP syms[2] = { x_sym, NULL };
404 1
  SEXP args[2] = { x, NULL };
405 1
  return warp_dispatch_n(fn_sym, fn, syms, args);
406
}
407

408
// -----------------------------------------------------------------------------
409

410
// [[ include("utils.h") ]]
411 1
SEXP as_posixct_from_posixlt(SEXP x) {
412 1
  return warp_dispatch1(
413 1
    syms_as_posixct_from_posixlt, fns_as_posixct_from_posixlt,
414 1
    syms_x, x
415
  );
416
}
417

418
// [[ include("utils.h") ]]
419 1
SEXP as_posixlt_from_posixct(SEXP x) {
420 1
  return warp_dispatch1(
421 1
    syms_as_posixlt_from_posixct, fns_as_posixlt_from_posixct,
422 1
    syms_x, x
423
  );
424
}
425

426
// [[ include("utils.h") ]]
427 1
SEXP as_date(SEXP x) {
428 1
  return warp_dispatch1(
429 1
    syms_as_date, fns_as_date,
430 1
    syms_x, x
431
  );
432
}
433

434
// -----------------------------------------------------------------------------
435

436 1
void warp_init_utils(SEXP ns) {
437 1
  warp_ns_env = ns;
438

439 1
  syms_x = Rf_install("x");
440 1
  syms_tzone = Rf_install("tzone");
441 1
  syms_class = Rf_install("class");
442

443 1
  new_env_call = r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", R_BaseEnv);
444 1
  R_PreserveObject(new_env_call);
445

446 1
  new_env__parent_node = CDDR(new_env_call);
447 1
  new_env__size_node = CDR(new_env__parent_node);
448

449 1
  syms_as_posixct_from_posixlt = Rf_install("as_posixct_from_posixlt");
450 1
  syms_as_posixlt_from_posixct = Rf_install("as_posixlt_from_posixct");
451 1
  syms_as_date = Rf_install("as_date");
452

453 1
  fns_as_posixct_from_posixlt = r_env_get(warp_ns_env, syms_as_posixct_from_posixlt);
454 1
  fns_as_posixlt_from_posixct = r_env_get(warp_ns_env, syms_as_posixlt_from_posixct);
455 1
  fns_as_date = r_env_get(warp_ns_env, syms_as_date);
456

457 1
  classes_data_frame = Rf_allocVector(STRSXP, 1);
458 1
  R_PreserveObject(classes_data_frame);
459 1
  SET_STRING_ELT(classes_data_frame, 0, Rf_mkChar("data.frame"));
460

461 1
  classes_posixct = Rf_allocVector(STRSXP, 2);
462 1
  R_PreserveObject(classes_posixct);
463 1
  SET_STRING_ELT(classes_posixct, 0, Rf_mkChar("POSIXct"));
464 1
  SET_STRING_ELT(classes_posixct, 1, Rf_mkChar("POSIXt"));
465

466 1
  strings_start_stop = Rf_allocVector(STRSXP, 2);
467 1
  R_PreserveObject(strings_start_stop);
468 1
  SET_STRING_ELT(strings_start_stop, 0, Rf_mkChar("start"));
469 1
  SET_STRING_ELT(strings_start_stop, 1, Rf_mkChar("stop"));
470

471
  // Holds the CHARSXP objects because they can be garbage collected
472 1
  chars = Rf_allocVector(STRSXP, 4);
473 1
  R_PreserveObject(chars);
474

475 1
  char_posixlt = Rf_mkChar("POSIXlt");
476 1
  SET_STRING_ELT(chars, 0, char_posixlt);
477

478 1
  char_posixct = Rf_mkChar("POSIXct");
479 1
  SET_STRING_ELT(chars, 1, char_posixct);
480

481 1
  char_posixt = Rf_mkChar("POSIXt");
482 1
  SET_STRING_ELT(chars, 2, char_posixt);
483

484 1
  char_date = Rf_mkChar("Date");
485 1
  SET_STRING_ELT(chars, 3, char_date);
486
}

Read our documentation on viewing source code .

Loading