Permalink
Cannot retrieve contributors at this time
360 lines (298 sloc)
7.79 KB
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #include <rlang.h> | |
| // attrs.c | |
| sexp* rlang_poke_attributes(sexp* x, sexp* attrs) { | |
| SET_ATTRIB(x, attrs); | |
| return x; | |
| } | |
| // cnd.c | |
| sexp* rlang_cnd_signal(sexp* cnd) { | |
| r_cnd_signal(cnd); | |
| return r_null; | |
| } | |
| sexp* rlang_cnd_type(sexp* cnd) { | |
| enum r_condition_type type = r_cnd_type(cnd); | |
| switch (type) { | |
| case r_cnd_type_condition: return r_scalar_chr("condition"); | |
| case r_cnd_type_message: return r_scalar_chr("message"); | |
| case r_cnd_type_warning: return r_scalar_chr("warning"); | |
| case r_cnd_type_error: return r_scalar_chr("error"); | |
| case r_cnd_type_interrupt: return r_scalar_chr("interrupt"); | |
| } | |
| } | |
| sexp* rlang_interrupt() { | |
| r_interrupt(); | |
| return r_null; | |
| } | |
| // env.c | |
| sexp* rlang_env_poke_parent(sexp* env, sexp* new_parent) { | |
| SET_ENCLOS(env, new_parent); | |
| return env; | |
| } | |
| sexp* rlang_env_frame(sexp* env) { | |
| return FRAME(env); | |
| } | |
| sexp* rlang_env_hash_table(sexp* env) { | |
| return HASHTAB(env); | |
| } | |
| // eval.c | |
| sexp* rlang_eval(sexp* expr, sexp* env) { | |
| return Rf_eval(expr, env); | |
| } | |
| // formula.c | |
| sexp* rlang_is_formulaish(sexp* x, sexp* scoped, sexp* lhs) { | |
| int scoped_int = r_as_optional_bool(scoped); | |
| int lhs_int = r_as_optional_bool(lhs); | |
| bool out = r_is_formulaish(x, scoped_int, lhs_int); | |
| return Rf_ScalarLogical(out); | |
| } | |
| // parse.c | |
| sexp* rlang_call_has_precedence(sexp* x, sexp* y, sexp* side) { | |
| bool has_predence; | |
| if (side == r_null) { | |
| has_predence = r_call_has_precedence(x, y); | |
| } else if (r_is_string(side, "lhs")) { | |
| has_predence = r_lhs_call_has_precedence(x, y); | |
| } else if (r_is_string(side, "rhs")) { | |
| has_predence = r_rhs_call_has_precedence(x, y); | |
| } else { | |
| r_abort("`side` must be NULL, \"lhs\" or \"rhs\""); | |
| } | |
| return r_bool_as_logical(has_predence); | |
| } | |
| sexp* rlang_which_operator(sexp* call) { | |
| const char* op = r_op_as_c_string(r_which_operator(call)); | |
| return r_scalar_chr(op); | |
| } | |
| // node.c | |
| sexp* rlang_node_car(sexp* x) { | |
| return CAR(x); | |
| } | |
| sexp* rlang_node_cdr(sexp* x) { | |
| return CDR(x); | |
| } | |
| sexp* rlang_node_caar(sexp* x) { | |
| return CAAR(x); | |
| } | |
| sexp* rlang_node_cadr(sexp* x) { | |
| return CADR(x); | |
| } | |
| sexp* rlang_node_cdar(sexp* x) { | |
| return CDAR(x); | |
| } | |
| sexp* rlang_node_cddr(sexp* x) { | |
| return CDDR(x); | |
| } | |
| sexp* rlang_node_tail(sexp* x) { | |
| while (CDR(x) != r_null) | |
| x = CDR(x); | |
| return x; | |
| } | |
| sexp* rlang_node_poke_car(sexp* x, sexp* newcar) { | |
| SETCAR(x, newcar); | |
| return x; | |
| } | |
| sexp* rlang_node_poke_cdr(sexp* x, sexp* newcdr) { | |
| SETCDR(x, newcdr); | |
| return x; | |
| } | |
| sexp* rlang_node_poke_caar(sexp* x, sexp* newcaar) { | |
| SETCAR(CAR(x), newcaar); | |
| return x; | |
| } | |
| sexp* rlang_node_poke_cadr(sexp* x, sexp* newcar) { | |
| SETCADR(x, newcar); | |
| return x; | |
| } | |
| sexp* rlang_node_poke_cdar(sexp* x, sexp* newcdar) { | |
| SETCDR(CAR(x), newcdar); | |
| return x; | |
| } | |
| sexp* rlang_node_poke_cddr(sexp* x, sexp* newcdr) { | |
| SETCDR(CDR(x), newcdr); | |
| return x; | |
| } | |
| sexp* rlang_new_node_(sexp* car, sexp* cdr) { | |
| return Rf_cons(car, cdr); | |
| } | |
| sexp* rlang_node_tag(sexp* x) { | |
| return TAG(x); | |
| } | |
| sexp* rlang_node_poke_tag(sexp* x, sexp* tag) { | |
| SET_TAG(x, tag); | |
| return x; | |
| } | |
| sexp* rlang_on_exit(sexp* expr, sexp* frame) { | |
| r_on_exit(expr, frame); | |
| return r_null; | |
| } | |
| // lang.h | |
| sexp* rlang_new_call_node(sexp* car, sexp* cdr) { | |
| return Rf_lcons(car, cdr); | |
| } | |
| // quo.h | |
| #include "../internal/quo.h" | |
| sexp* rlang_quo_is_missing(sexp* quo) { | |
| check_quosure(quo); | |
| return r_bool_as_logical(quo_is_missing(quo)); | |
| } | |
| sexp* rlang_quo_is_symbol(sexp* quo) { | |
| check_quosure(quo); | |
| return r_bool_as_logical(quo_is_symbol(quo)); | |
| } | |
| sexp* rlang_quo_is_call(sexp* quo) { | |
| check_quosure(quo); | |
| return r_bool_as_logical(quo_is_call(quo)); | |
| } | |
| sexp* rlang_quo_is_symbolic(sexp* quo) { | |
| check_quosure(quo); | |
| return r_bool_as_logical(quo_is_symbolic(quo)); | |
| } | |
| sexp* rlang_quo_is_null(sexp* quo) { | |
| check_quosure(quo); | |
| return r_bool_as_logical(quo_is_null(quo)); | |
| } | |
| // sexp.h | |
| sexp* rlang_length(sexp* x) { | |
| return Rf_ScalarInteger(r_length(x)); | |
| } | |
| sexp* rlang_true_length(sexp* x) { | |
| return Rf_ScalarInteger(TRUELENGTH(x)); | |
| } | |
| sexp* rlang_is_reference(sexp* x, sexp* y) { | |
| return r_bool_as_logical(x == y); | |
| } | |
| sexp* rlang_missing_arg() { | |
| return R_MissingArg; | |
| } | |
| sexp* rlang_duplicate(sexp* x, sexp* shallow) { | |
| return r_duplicate(x, r_as_bool(shallow)); | |
| } | |
| sexp* rlang_is_null(sexp* x) { | |
| return r_bool_as_logical(r_is_null(x)); | |
| } | |
| sexp* rlang_sexp_address(sexp* x) { | |
| static char str[1000]; | |
| snprintf(str, 1000, "%p", (void*) x); | |
| return Rf_mkString(str); | |
| } | |
| sexp* rlang_poke_type(sexp* x, sexp* type) { | |
| SET_TYPEOF(x, Rf_str2type(r_c_string(type))); | |
| return x; | |
| } | |
| sexp* rlang_mark_object(sexp* x) { | |
| SET_OBJECT(x, 1); | |
| return x; | |
| } | |
| sexp* rlang_unmark_object(sexp* x) { | |
| SET_OBJECT(x, 0); | |
| return x; | |
| } | |
| // vec.h | |
| sexp* rlang_vec_coerce(sexp* x, sexp* type) { | |
| return Rf_coerceVector(x, Rf_str2type(r_c_string(type))); | |
| } | |
| // TODO: C-level check for scalar integerish | |
| int r_as_int(sexp* x) { | |
| switch(r_typeof(x)) { | |
| case r_type_integer: return *INTEGER(x); | |
| case r_type_double: return (int) *REAL(x); | |
| default: r_abort("Internal error: Expected integerish input"); | |
| } | |
| } | |
| sexp* rlang_vec_poke_n(sexp* x, sexp* offset, | |
| sexp* y, sexp* from, sexp* n) { | |
| r_ssize_t offset_size = r_as_int(offset) - 1; | |
| r_ssize_t from_size = r_as_int(from) - 1; | |
| r_ssize_t n_size = r_as_int(n); | |
| r_vec_poke_n(x, offset_size, y, from_size, n_size); | |
| return x; | |
| } | |
| sexp* rlang_vec_poke_range(sexp* x, sexp* offset, | |
| sexp* y, sexp* from, sexp* to) { | |
| r_ssize_t offset_size = r_as_int(offset) - 1; | |
| r_ssize_t from_size = r_as_int(from) - 1; | |
| r_ssize_t to_size = r_as_int(to) - 1; | |
| r_vec_poke_range(x, offset_size, y, from_size, to_size); | |
| return x; | |
| } | |
| // vec-list.h | |
| static r_ssize_t validate_n(sexp* n) { | |
| switch (r_typeof(n)) { | |
| case r_type_null: | |
| return -1; | |
| // Just coerce doubles to int for efficiency | |
| case r_type_double: | |
| if (r_length(n) == 1) { | |
| return r_dbl_get(n, 0); | |
| } else { | |
| goto error; | |
| } | |
| case r_type_integer: | |
| if (r_length(n) == 1) { | |
| return r_int_get(n, 0); | |
| } else { | |
| goto error; | |
| } | |
| error: | |
| default: | |
| r_abort("`n` must be NULL or a scalar integer"); | |
| } | |
| } | |
| static int validate_finite(sexp* finite) { | |
| switch (r_typeof(finite)) { | |
| case r_type_null: | |
| return -1; | |
| case r_type_integer: | |
| case r_type_double: | |
| finite = r_vec_coerce(finite, r_type_logical); | |
| case r_type_logical: { | |
| int value = r_lgl_get(finite, 0); | |
| if (value != NA_LOGICAL) { | |
| return r_lgl_get(finite, 0); | |
| } // else fallthrough | |
| } | |
| default: | |
| r_abort("`finite` must be NULL or a scalar logical"); | |
| } | |
| } | |
| sexp* rlang_is_finite(sexp* x) { | |
| return r_bool_as_shared_logical(r_is_finite(x)); | |
| } | |
| sexp* rlang_is_list(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_list(x, n)); | |
| } | |
| sexp* rlang_is_atomic(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_atomic(x, n)); | |
| } | |
| sexp* rlang_is_vector(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_vector(x, n)); | |
| } | |
| sexp* rlang_is_logical(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_logical(x, n)); | |
| } | |
| sexp* rlang_is_integer(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_integer(x, n, -1)); | |
| } | |
| sexp* rlang_is_double(sexp* x, sexp* n_, sexp* finite_) { | |
| r_ssize_t n = validate_n(n_); | |
| int finite = validate_finite(finite_); | |
| return r_bool_as_shared_logical(r_is_double(x, n, finite)); | |
| } | |
| sexp* rlang_is_integerish(sexp* x, sexp* n_, sexp* finite_) { | |
| r_ssize_t n = validate_n(n_); | |
| int finite = validate_finite(finite_); | |
| return r_bool_as_shared_logical(r_is_integerish(x, n, finite)); | |
| } | |
| sexp* rlang_is_character(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_character(x, n)); | |
| } | |
| sexp* rlang_is_raw(sexp* x, sexp* n_) { | |
| r_ssize_t n = validate_n(n_); | |
| return r_bool_as_shared_logical(r_is_raw(x, n)); | |
| } |