brodieG / vetr
1
/*
2
Copyright (C) 2020 Brodie Gaslam
3

4
This file is part of "vetr - Trust, but Verify"
5

6
This program is free software: you can redistribute it and/or modify
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
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
14
GNU General Public License for more details.
15

16
Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
17
*/
18

19
#include "alike.h"
20

21
/*
22
Initialize return object
23
*/
24
/*
25
Moves pointer on language object to skip any `(` calls since those are
26
already accounted for in parsing and as such don't add anything.
27

28
Returns a list/vector with a pointer to the updated lanaguage object position
29
and an integer indicating how many parentheses were skipped
30
*/
31

32 3
SEXP ALIKEC_skip_paren(SEXP lang) {
33 3
  int i = 0;
34 3
  SEXP res = PROTECT(allocVector(VECSXP, 2));
35 3
  if(TYPEOF(lang) == LANGSXP) {
36 3
    while(
37 3
      CAR(lang) == ALIKEC_SYM_paren_open && CDR(CDR(lang)) == R_NilValue
38
    ) {
39 3
      lang = CADR(lang);
40 3
      i++;
41 3
      if(i < 0) {
42
        // nocov start
43 0
        error(
44
          "Internal Error: %s; contact maintainer.",
45
          "exceeded language recursion depth when skipping parens"
46
        );
47
        // nocov end
48
      }
49
  } }
50 3
  SET_VECTOR_ELT(res, 0, lang);
51 3
  SET_VECTOR_ELT(res, 1, ScalarInteger(i));
52 3
  UNPROTECT(1);
53 3
  return(res);
54
}
55

56
// - Anonymize Formula ---------------------------------------------------------
57

58
/* Look up symbol in hash table, if already present, return the anonymized
59
version of the symbol.  If not, add to the hash table.
60

61
symb the symbol to lookup
62
hash the hash table
63
varnum used to generate the anonymized variable name
64
*/
65

66 3
const char * ALIKEC_symb_abstract(
67
  SEXP symb, pfHashTable * hash, size_t * varnum, struct VALC_settings set
68
) {
69 3
  const char * symb_chr = CHAR(PRINTNAME(symb));
70
  // really shouldn't have to do this, but can't be bothered re-defining the
71
  // hash library
72 3
  const char * symb_abs = pfHashFind(hash, (char *) symb_chr);
73 3
  if(symb_abs == NULL) {
74 3
    symb_abs = CSR_smprintf4(
75 3
      set.nchar_max, "a%s", CSR_len_as_chr(*varnum), "", "", ""
76
    );
77 3
    pfHashSet(hash, (char *) symb_chr, symb_abs);
78 3
    (*varnum)++;
79
  }
80 3
  return symb_abs;
81
}
82
/*
83
Try to find function in env and return function if it exists, R_NilValue
84
otherwise
85

86
@param call the function we will ultimately match
87
@param env an environment to start the lookup
88
*/
89 3
SEXP ALIKEC_get_fun(SEXP call, SEXP env) {
90 3
  SEXP fun = CAR(call);
91 3
  switch(TYPEOF(fun)) {
92
    case CLOSXP:
93 3
      return fun;
94
      break;
95
    case SYMSXP:
96
      {
97
        // Assuming no GC happens in next couple of steps
98 3
        SEXP fun_def = ALIKEC_findFun(fun, env);
99 3
        if(TYPEOF(fun_def) == CLOSXP) return fun_def;
100
      }
101 3
      break;
102
  }
103 3
  return R_NilValue;
104
}
105
/*
106
@param match_call a preconstructed call to retrieve the function; needed because
107
  can't figure out a way to create preconstructed call in init without
108
  sub-components getting GCed
109
*/
110 3
SEXP ALIKEC_match_call(
111
  SEXP call, SEXP match_call, SEXP env
112
) {
113 3
  SEXP fun = PROTECT(ALIKEC_get_fun(call, env));
114 3
  if(fun == R_NilValue) {
115 3
    UNPROTECT(1);
116 3
    return call;
117
  }
118
  // remember, match_call is pre-defined as: match.call(def, quote(call)), also,
119
  // in theory should never be SHARED since it is a SEXP created in C code only
120
  // for internal use.
121

122 3
  if (MAYBE_SHARED(match_call)) PROTECT(match_call = duplicate(match_call));
123 3
  else PROTECT(R_NilValue);
124

125 3
  SETCADR(match_call, fun);
126 3
  SETCADR(CADDR(match_call), call);
127 3
  int tmp = 0;
128 3
  int * err =& tmp;
129 3
  SEXP res = PROTECT(R_tryEvalSilent(match_call, env, err));
130 3
  UNPROTECT(3);
131 3
  if(* err) return call; else return res;
132
}
133
/*
134
Handle language object comparison
135

136
Note that we always pass cur_par instead of current so that we can modify the
137
original call (mostly by using `match.call` on it)
138
*/
139 3
struct ALIKEC_res ALIKEC_lang_obj_compare(
140
  SEXP target, SEXP cur_par, pfHashTable * tar_hash,
141
  pfHashTable * cur_hash, pfHashTable * rev_hash, size_t * tar_varnum,
142
  size_t * cur_varnum, int formula, SEXP match_call, SEXP match_env,
143
  struct VALC_settings set, struct ALIKEC_rec_track rec
144
) {
145 3
  SEXP current = CAR(cur_par);
146 3
  struct ALIKEC_res res = ALIKEC_res_init();
147 3
  res.dat.rec = rec;
148

149
  // Skip parens and increment recursion; not we don't track recursion level
150
  // for target
151

152 3
  SEXP cur_skip_paren = PROTECT(ALIKEC_skip_paren(current));
153 3
  SEXP tar_skip_paren = PROTECT(ALIKEC_skip_paren(target));
154

155
  // Need to reset all variables so we work on the paren less version
156

157 3
  current = VECTOR_ELT(cur_skip_paren, 0);
158 3
  SEXP cur_par_dup = PROTECT(duplicate(cur_par));
159 3
  SETCAR(cur_par_dup, current);
160

161 3
  int i, i_max = asInteger(VECTOR_ELT(cur_skip_paren, 1));
162

163 3
  PROTECT(res.wrap);   // Dummy PROTECT
164

165 3
  for(i = 0; i < i_max; i++) {
166 3
    res.dat.rec = ALIKEC_rec_inc(res.dat.rec);
167
  }
168 3
  target = VECTOR_ELT(tar_skip_paren, 0);
169

170 3
  SEXPTYPE tsc_type = TYPEOF(target), csc_type = TYPEOF(current);
171 3
  res.success = 0;  // assume fail until shown otherwise
172

173 3
  if(target == R_NilValue) {// NULL matches anything
174 3
    res.success = 1;
175 3
  } else if(tsc_type == SYMSXP && csc_type == SYMSXP) {
176 3
    const char * tar_abs = ALIKEC_symb_abstract(
177
      target, tar_hash, tar_varnum, set
178
    );
179 3
    const char * cur_abs = ALIKEC_symb_abstract(
180
      current, cur_hash, cur_varnum, set
181
    );
182
    // reverse hash to get what symbol should be in case of error
183 3
    const char * rev_symb = pfHashFind(rev_hash, tar_abs);
184 3
    const char * csc_text = CHAR(PRINTNAME(current));
185 3
    if(rev_symb == NULL) {
186 3
      rev_symb = (char *) csc_text;
187 3
      pfHashSet(rev_hash, cur_abs, rev_symb);
188
    }
189 3
    if(strcmp(tar_abs, cur_abs)) {
190 3
      res.success = 0;
191 3
      if(*tar_varnum > *cur_varnum) {
192 3
        res.dat.strings.tar_pre = "not be";
193 3
        res.dat.strings.target[0] = "`%s`";
194 3
        res.dat.strings.target[1] = csc_text;
195 3
        res.dat.strings.current[1] = ""; // gcc-10
196
      } else {
197 3
        res.dat.strings.target[0] = "`%s`";
198 3
        res.dat.strings.target[1] = rev_symb;
199 3
        res.dat.strings.current[0] = "`%s`";
200 3
        res.dat.strings.current[1] = csc_text;
201
      }
202 3
    } else res.success = 1;
203 3
  } else if (tsc_type == LANGSXP && csc_type != LANGSXP) {
204 3
    res.success = 0;
205 3
    res.dat.strings.target[0] = "a call to `%s`";
206 3
    res.dat.strings.target[1] = ALIKEC_deparse_chr(CAR(target), -1, set);
207 3
    res.dat.strings.current[0] =  "\"%s\"";
208 3
    res.dat.strings.current[1] = type2char(csc_type);
209 3
  } else if (tsc_type != LANGSXP && csc_type == LANGSXP) {
210 3
    res.success = 0;
211 3
    res.dat.strings.target[0] =  "\"%s\"";
212 3
    res.dat.strings.target[1] = type2char(tsc_type);
213 3
    res.dat.strings.current[0] =  "\"%s\"";
214 3
    res.dat.strings.current[1] = type2char(csc_type);
215 3
  } else if (tsc_type == LANGSXP) {
216
    // Note how we pass cur_par and not current so we can modify cur_par
217
    // this should be changed since we don't use that feature any more
218 3
    UNPROTECT(1);
219 3
    res = ALIKEC_lang_alike_rec(
220
      target, cur_par_dup, tar_hash, cur_hash, rev_hash, tar_varnum,
221
      cur_varnum, formula, match_call, match_env, set, res.dat.rec
222
    );
223 3
    PROTECT(res.wrap);
224 3
  } else if(tsc_type == SYMSXP || csc_type == SYMSXP) {
225 3
    res.success = 0;
226 3
    res.dat.strings.target[0] =  "\"%s\"";
227 3
    res.dat.strings.target[1] = type2char(tsc_type);
228 3
    res.dat.strings.current[0] =  "\"%s\"";
229 3
    res.dat.strings.current[1] = type2char(csc_type);
230 3
  } else if (formula && !R_compute_identical(target, current, 16)) {
231
    // Maybe this shouldn't be "identical", but too much of a pain in the butt
232
    // to do an all.equals type comparison
233

234
    // could have constant vs. language here, right?
235

236 3
    res.success = 0;
237 3
    res.dat.strings.tar_pre = "have";
238 3
    res.dat.strings.target[1] =  "identical constant values";
239 3
    res.dat.strings.current[1] = ""; // gcc-10
240 3
  } else res.success = 1;
241

242
  // Deal with index implications of skiping parens, note + 2 because we need
243
  // +1 for zero index, and then another +1 to reference contents of parens
244

245 3
  if(!res.success) {
246 3
    for(i = 0; i < i_max; i++) {
247 3
      res.dat.rec = ALIKEC_rec_ind_num(res.dat.rec, i + 2);
248 3
      res.dat.rec = ALIKEC_rec_dec(res.dat.rec);
249
    }
250 3
    if(res.wrap == R_NilValue) res.wrap = allocVector(VECSXP, 2);
251
  }
252 3
  UNPROTECT(4);
253 3
  return res;
254
}
255

256
/*
257
Creates a copy of the call mapping objects to a deterministic set of names
258
based on the order in which they appear in the call
259

260
Here we use a hash table to identify whether a symbol already showed up or not.
261
This is probably faster if langauge object has 25 or more elements, so may
262
eventually want to add logic that choses path based on how many elements.
263

264
If return value is zero length string then comparison succeeded, otherwise
265
return value is error message.  Note that we also return information by modifying
266
the `cur_par` argument by reference.  We either mark the token the error message
267
refers to by wrapping it in ``{}``, or blow it away to indicate we don't want
268
the final error message to try to point out where the error occurred (this is
269
typically the case when the error is not specific to a particular part of the
270
call).
271
*/
272

273 3
struct ALIKEC_res ALIKEC_lang_alike_rec(
274
  SEXP target, SEXP cur_par, pfHashTable * tar_hash, pfHashTable * cur_hash,
275
  pfHashTable * rev_hash, size_t * tar_varnum, size_t * cur_varnum, int formula,
276
  SEXP match_call, SEXP match_env, struct VALC_settings set,
277
  struct ALIKEC_rec_track rec
278
) {
279 3
  SEXP current = CAR(cur_par);
280

281
  // If not language object, run comparison
282

283 3
  struct ALIKEC_res res = ALIKEC_res_init();
284 3
  res.dat.rec = rec;
285

286 3
  if(TYPEOF(target) != LANGSXP || TYPEOF(current) != LANGSXP) {
287 3
    res =  ALIKEC_lang_obj_compare(
288
      target, cur_par, tar_hash, cur_hash, rev_hash, tar_varnum,
289
      cur_varnum, formula, match_call, match_env, set, res.dat.rec
290
    );
291
  } else {
292
    // If language object, then recurse
293

294 3
    res.dat.rec = ALIKEC_rec_inc(res.dat.rec);
295

296 3
    SEXP tar_fun = CAR(target), cur_fun = CAR(current);
297

298
    // Actual fun call must match exactly, unless NULL
299

300 3
    if(tar_fun != R_NilValue && !R_compute_identical(tar_fun, cur_fun, 16)) {
301 3
      res.success = 0;
302 3
      res.dat.rec = ALIKEC_rec_ind_num(res.dat.rec, 1);
303

304 3
      res.dat.strings.target[0] = "a call to `%s`";
305 3
      res.dat.strings.target[1] = ALIKEC_deparse_chr(CAR(target), -1, set);
306

307 3
      res.dat.strings.current[0] = "a call to `%s`";
308 3
      res.dat.strings.current[1] = ALIKEC_deparse_chr(CAR(current), -1, set);
309

310 3
    } else if (CDR(target) != R_NilValue) {
311
      // Zero length calls match anything, so only come here if target is not
312
      // Nil
313

314
      // Match the calls before comparison; small inefficiency below since we
315
      // know that target and current must be the same fun; we shouldn't need
316
      // to retrieve it twice as we do now
317

318 3
      int use_names = 1;
319 3
      if(match_env != R_NilValue && set.lang_mode != 1) {
320 3
        target = PROTECT(ALIKEC_match_call(target, match_call, match_env));
321 3
        current = PROTECT(ALIKEC_match_call(current, match_call, match_env));
322 3
        SETCAR(cur_par, current);  // ensures original call is matched
323
        // Can't be sure that names will match up with call as originally
324
        // submitted
325 3
        use_names = 0;
326
      } else {
327 3
        PROTECT(PROTECT(R_NilValue)); // stack balance
328
      }
329
      SEXP tar_sub, cur_sub, cur_sub_tag, tar_sub_tag,
330 3
        prev_tag = R_UnboundValue;
331
      R_xlen_t arg_num;
332

333 3
      for(
334 3
        tar_sub = CDR(target), cur_sub = CDR(current), arg_num = 0;
335 3
        tar_sub != R_NilValue && cur_sub != R_NilValue;
336 3
        tar_sub = CDR(tar_sub), cur_sub = CDR(cur_sub), prev_tag = cur_sub_tag,
337 3
        arg_num++
338
      ) {
339 3
        if(arg_num > R_XLEN_T_MAX - 1) {
340
          // nocov start
341 0
          error(
342
            "Internal Error: %s; contact maintainer.",
343
            "exceeded allowable call length"
344
          );
345
          // nocov end
346
        }
347
        // Check tags are compatible; NULL tag in target allows any tag in
348
        // current
349

350 3
        cur_sub_tag = TAG(cur_sub);
351 3
        tar_sub_tag = TAG(tar_sub);
352

353 3
        int update_rec_ind = 0;
354

355 3
        if(tar_sub_tag != R_NilValue && tar_sub_tag != cur_sub_tag) {
356 3
          char * prev_tag_msg = "as first argument";
357 3
          if(prev_tag != R_UnboundValue) {
358 3
            if(prev_tag == R_NilValue) {
359 3
              prev_tag_msg = CSR_smprintf4(
360 3
                set.nchar_max, "after argument %s", CSR_len_as_chr(arg_num),
361
                "", "", ""
362
              );
363
            } else {
364 3
              prev_tag_msg = CSR_smprintf4(
365
                set.nchar_max, "after argument `%s`", CHAR(PRINTNAME(prev_tag)),
366
                "", "", ""
367
          );} }
368 3
          res.success = 0;
369

370 3
          res.dat.strings.tar_pre = "have";
371 3
          res.dat.strings.target[0] =  "argument `%s` %s";
372 3
          res.dat.strings.target[1] = CHAR(PRINTNAME(TAG(tar_sub)));
373 3
          res.dat.strings.target[2] = prev_tag_msg;
374 3
          res.dat.strings.cur_pre = "has";
375

376 3
          if(TAG(cur_sub) == R_NilValue) {
377 3
            res.dat.strings.current[1] = "unnamed argument";
378
          } else {
379 3
            res.dat.strings.current[0] =  "`%s`";
380 3
            res.dat.strings.current[1] =  CHAR(PRINTNAME(TAG(cur_sub)));
381
          }
382
        } else {
383
          // Note that `lang_obj_compare` kicks off recursion as well, and
384
          // skips parens
385

386 3
          SEXP tar_sub_car = CAR(tar_sub);
387 3
          res = ALIKEC_lang_obj_compare(
388
            tar_sub_car, cur_sub, tar_hash, cur_hash, rev_hash,
389
            tar_varnum, cur_varnum, formula, match_call, match_env, set,
390
            res.dat.rec
391
          );
392 3
          update_rec_ind = 1;
393
        }
394
        // Update recursion indices and exit loop; keep in mind that this is a
395
        // call so first element is fun, hence `arg_num + 2`
396

397 3
        if(!res.success) {
398 3
          if(update_rec_ind) {
399 3
            if(cur_sub_tag != R_NilValue && use_names)
400 3
              res.dat.rec =
401 3
                ALIKEC_rec_ind_chr(res.dat.rec, CHAR(PRINTNAME(cur_sub_tag)));
402
            else
403 3
              res.dat.rec =
404 3
                ALIKEC_rec_ind_num(res.dat.rec, arg_num + 2);
405
          }
406 3
          break;
407
        }
408
      }
409 3
      if(res.success) {
410
        // Make sure that we compared all items; missing R_NilValue here means
411
        // one of the calls has more items
412

413
        R_xlen_t tar_len, cur_len;
414 3
        tar_len = cur_len = arg_num;
415 3
        if(tar_sub != R_NilValue || cur_sub != R_NilValue) {
416 3
          while(tar_sub != R_NilValue) {
417 3
            tar_len++;
418 3
            tar_sub = CDR(tar_sub);
419
          }
420 3
          while(cur_sub != R_NilValue) {
421 3
            cur_len++;
422 3
            cur_sub = CDR(cur_sub);
423
          }
424 3
          res.success = 0;
425 3
          res.dat.strings.tar_pre = "have";
426 3
          res.dat.strings.target[0] = "%s arguments";
427 3
          res.dat.strings.target[1] = CSR_len_as_chr(tar_len);
428 3
          res.dat.strings.cur_pre = "has";
429 3
          res.dat.strings.current[1] = CSR_len_as_chr(cur_len);
430
        }
431
      }
432 3
      target = current = R_NilValue;
433

434 3
      UNPROTECT(2);
435
    }
436 3
    res.dat.rec = ALIKEC_rec_dec(res.dat.rec);
437
  }
438 3
  return res;
439
}
440
/*
441
Compare language objects.
442

443
This is a semi internal function used by the internal language comparison
444
mechanism as well as the external testing functions.
445

446
Determine whether objects should be compared as calls or as formulas; the main
447
difference in treatment is that calls are match-called if possible, and also
448
that for calls constants need not be the same
449

450
Return a list (vector) with the status, error message, the matched language
451
object, the original language object, and index within the langauge object of
452
the problem if there is one (relative to the matched object)
453
*/
454

455 3
SEXP ALIKEC_lang_alike_core(
456
  SEXP target, SEXP current, struct VALC_settings set
457
) {
458 3
  SEXP match_env = set.env;
459 3
  SEXPTYPE tar_type = TYPEOF(target), cur_type = TYPEOF(current);
460 3
  int tar_is_lang =
461 3
    tar_type == LANGSXP || tar_type == SYMSXP || tar_type == NILSXP;
462 3
  int cur_is_lang =
463 3
    cur_type == LANGSXP || cur_type == SYMSXP || cur_type == NILSXP;
464 3
  if(!(tar_is_lang && cur_is_lang))
465 3
    error("Arguments must be LANGSXP, SYMSXP, or R_NilValue");
466

467 3
  if(TYPEOF(match_env) != ENVSXP && match_env != R_NilValue)
468 3
    error("Argument `match.call.env` must be an environment or NULL");
469

470
  /*
471
  Create persistent objects for use throught recursion; these are the hash
472
  tables that are used to keep track of names as they show up as we recurse
473
  through the language objects
474
  */
475

476 3
  pfHashTable * tar_hash = pfHashCreate(NULL);
477 3
  pfHashTable * cur_hash = pfHashCreate(NULL);
478 3
  pfHashTable * rev_hash = pfHashCreate(NULL);
479 3
  size_t tartmp = 0, curtmp=0;
480 3
  size_t * tar_varnum = &tartmp;
481 3
  size_t * cur_varnum = &curtmp;
482

483
  // Can't figure out how to do this on init; cost ~60ns
484 3
  SEXP match_call = PROTECT(
485
    list3(
486
      ALIKEC_SYM_matchcall, R_NilValue,
487
      list2(R_QuoteSymbol, R_NilValue)
488
  ) );
489 3
  SET_TYPEOF(match_call, LANGSXP);
490 3
  SET_TYPEOF(CADDR(match_call), LANGSXP);
491

492 3
  int formula = 0;
493

494
  // Determine if it is a formular or not
495

496 3
  SEXP class = PROTECT(getAttrib(target, R_ClassSymbol));
497 3
  if(
498 3
    class != R_NilValue && TYPEOF(class) == STRSXP &&
499 3
    !strcmp("formula", CHAR(STRING_ELT(class, XLENGTH(class) - 1))) &&
500 3
    CAR(target) == ALIKEC_SYM_tilde
501
  ) {
502 3
    formula = 1;
503
  }
504 3
  UNPROTECT(1);
505
  // Check if alike; originally we would modify a copy of current, which is
506
  // why we send curr_cpy_par
507

508 3
  SEXP curr_cpy_par = PROTECT(list1(duplicate(current)));
509 3
  struct ALIKEC_rec_track rec = ALIKEC_rec_track_init();
510 3
  struct ALIKEC_res res = ALIKEC_lang_alike_rec(
511
    target, curr_cpy_par, tar_hash, cur_hash, rev_hash, tar_varnum, cur_varnum,
512
    formula, match_call, match_env, set, rec
513
  );
514
  // Save our results in a SEXP to simplify testing
515 3
  const char * names[6] = {
516
    "success", "message", "call.match", "call.ind", "call.ind.sub.par",
517
    "call.orig"
518
  };
519 3
  SEXP res_fin = PROTECT(allocVector(VECSXP, 6));
520 3
  SEXP res_names = PROTECT(allocVector(STRSXP, 6));
521

522 3
  for(int i = 0; i < 6; i++) SET_STRING_ELT(res_names, i, mkChar(names[i]));
523

524 3
  setAttrib(res_fin, R_NamesSymbol, res_names);
525 3
  SET_VECTOR_ELT(res_fin, 0, ScalarLogical(res.success));
526

527 3
  if(!res.success) {
528 3
    SEXP rec_ind = PROTECT(ALIKEC_rec_ind_as_lang(res.dat.rec));
529

530 3
    SEXP res_msg = PROTECT(allocVector(VECSXP, 2));
531 3
    SEXP res_msg_names = PROTECT(allocVector(STRSXP, 2));
532 3
    SET_VECTOR_ELT(res_msg, 0, ALIKEC_res_strings_to_SEXP(res.dat.strings));
533 3
    if(res.wrap == R_NilValue) {
534 3
      res.wrap = PROTECT(allocVector(VECSXP, 2));
535 3
    } else PROTECT(R_NilValue);
536 3
    SET_VECTOR_ELT(res_msg, 1, res.wrap);
537 3
    SET_STRING_ELT(res_msg_names, 0, mkChar("message"));
538 3
    SET_STRING_ELT(res_msg_names, 1, mkChar("wrap"));
539 3
    setAttrib(res_msg, R_NamesSymbol, res_msg_names);
540 3
    SET_VECTOR_ELT(res_fin, 1, res_msg);
541 3
    UNPROTECT(3);
542

543 3
    SET_VECTOR_ELT(res_fin, 2, CAR(curr_cpy_par));
544 3
    SET_VECTOR_ELT(res_fin, 3, VECTOR_ELT(rec_ind, 0));
545 3
    SET_VECTOR_ELT(res_fin, 4, VECTOR_ELT(rec_ind, 1));
546 3
    SET_VECTOR_ELT(res_fin, 5, current);
547 3
    UNPROTECT(1);
548
  }
549 3
  UNPROTECT(4);
550 3
  return res_fin;
551
}
552
/*
553
  Translate result into res_sub for use by alike
554

555
  Probalby some inefficiency in the C -> SEXP -> C translations going on; this
556
  is happening mostly for legacy reason so should probably clean up to stick to
557
  C at some point.  One of the changes (amongst others) is that we no longer
558
  care about recording the call / language that caused the problem since we're
559
  refering directly to the original object
560
*/
561 3
struct ALIKEC_res ALIKEC_lang_alike_internal(
562
  SEXP target, SEXP current, struct VALC_settings set
563
) {
564 3
  SEXP lang_res = PROTECT(ALIKEC_lang_alike_core(target, current, set));
565

566 3
  struct ALIKEC_res res = ALIKEC_res_init();
567 3
  if(asInteger(VECTOR_ELT(lang_res, 0))) {
568 3
    PROTECT(res.wrap);  // stack balance
569
  } else {
570 3
    res.success = 0;
571

572 3
    SEXP message = PROTECT(VECTOR_ELT(lang_res, 1));
573 3
    SEXP msg_txt = VECTOR_ELT(message, 0);
574

575 3
    res.dat.strings.tar_pre = CHAR(STRING_ELT(msg_txt, 0));
576 3
    res.dat.strings.target[1] = CHAR(STRING_ELT(msg_txt, 1));
577 3
    res.dat.strings.cur_pre = CHAR(STRING_ELT(msg_txt, 2));
578 3
    res.dat.strings.current[1] = CHAR(STRING_ELT(msg_txt, 3));
579

580
    // Deal with wrap
581

582 3
    SEXP lang_ind = VECTOR_ELT(lang_res, 3);
583 3
    SEXP lang_ind_sub = VECTOR_ELT(lang_res, 4);
584

585 3
    SEXP wrap = VECTOR_ELT(message, 1);
586 3
    SET_VECTOR_ELT(wrap, 0, lang_ind);
587 3
    SET_VECTOR_ELT(wrap, 1, lang_ind_sub);
588 3
    res.wrap = wrap;
589
  }
590 3
  UNPROTECT(2);
591 3
  return res;
592
}
593
/*
594
For testing purposes
595
*/
596 3
SEXP ALIKEC_lang_alike_ext(
597
  SEXP target, SEXP current, SEXP match_env
598
) {
599 3
  struct VALC_settings set = VALC_settings_init();
600 3
  set.env = match_env;
601 3
  return ALIKEC_lang_alike_core(target, current, set);
602
}
603

604 3
SEXP ALIKEC_lang_alike_chr_ext(
605
  SEXP target, SEXP current, SEXP match_env
606
) {
607 3
  struct VALC_settings set = VALC_settings_init();
608 3
  set.env = match_env;
609 3
  struct ALIKEC_res res = ALIKEC_lang_alike_internal(target, current, set);
610 3
  PROTECT(res.wrap);
611
  SEXP res_str;
612 3
  if(!res.success) {
613 3
    res_str = PROTECT(ALIKEC_res_strings_to_SEXP(res.dat.strings));
614
  } else {
615 3
    res_str = PROTECT(mkString(""));
616
  }
617 3
  UNPROTECT(2);
618 3
  return res_str;
619
}

Read our documentation on viewing source code .

Loading