1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1997--2021 The R Core Team
4 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
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 * You should have received a copy of the GNU General Public License
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21 #ifdef HAVE_CONFIG_H
22 #include <config.h>
23 #endif
24
25 #include <Defn.h>
26 #include <Internal.h>
27 #include <Rmath.h>
28
29 static SEXP installAttrib(SEXP, SEXP, SEXP);
30 static SEXP removeAttrib(SEXP, SEXP);
31
32 SEXP comment(SEXP);
33 static SEXP commentgets(SEXP, SEXP);
34
row_names_gets(SEXP vec,SEXP val)35 static SEXP row_names_gets(SEXP vec, SEXP val)
36 {
37 SEXP ans;
38
39 if (vec == R_NilValue)
40 error(_("attempt to set an attribute on NULL"));
41
42 if(isReal(val) && LENGTH(val) == 2 && ISNAN(REAL(val)[0]) ) {
43 /* This should not happen, but if a careless user dput()s a
44 data frame and sources the result, it will */
45 PROTECT(vec);
46 PROTECT(val);
47 val = coerceVector(val, INTSXP);
48 UNPROTECT(1); /* val */
49 PROTECT(val);
50 ans = installAttrib(vec, R_RowNamesSymbol, val);
51 UNPROTECT(2); /* vec, val */
52 return ans;
53 }
54 if(isInteger(val)) {
55 Rboolean OK_compact = TRUE;
56 int i, n = LENGTH(val);
57 if(n == 2 && INTEGER(val)[0] == NA_INTEGER) {
58 n = INTEGER(val)[1];
59 } else if (n > 2) {
60 for(i = 0; i < n; i++)
61 if(INTEGER(val)[i] != i+1) {
62 OK_compact = FALSE;
63 break;
64 }
65 } else OK_compact = FALSE;
66 if(OK_compact) {
67 /* we hide the length in an impossible integer vector */
68 PROTECT(vec);
69 PROTECT(val = allocVector(INTSXP, 2));
70 INTEGER(val)[0] = NA_INTEGER;
71 INTEGER(val)[1] = n;
72 ans = installAttrib(vec, R_RowNamesSymbol, val);
73 UNPROTECT(2); /* vec, val */
74 return ans;
75 }
76 } else if(!isString(val))
77 error(_("row names must be 'character' or 'integer', not '%s'"),
78 type2char(TYPEOF(val)));
79 PROTECT(vec);
80 PROTECT(val);
81 ans = installAttrib(vec, R_RowNamesSymbol, val);
82 UNPROTECT(2); /* vec, val */
83 return ans;
84 }
85
86 /* used in removeAttrib, commentgets and classgets */
stripAttrib(SEXP tag,SEXP lst)87 static SEXP stripAttrib(SEXP tag, SEXP lst)
88 {
89 if(lst == R_NilValue) return lst;
90 if(tag == TAG(lst)) return stripAttrib(tag, CDR(lst));
91 SETCDR(lst, stripAttrib(tag, CDR(lst)));
92 return lst;
93 }
94
isOneDimensionalArray(SEXP vec)95 static Rboolean isOneDimensionalArray(SEXP vec)
96 {
97 if(isVector(vec) || isList(vec) || isLanguage(vec)) {
98 SEXP s = getAttrib(vec, R_DimSymbol);
99 if(TYPEOF(s) == INTSXP && LENGTH(s) == 1)
100 return TRUE;
101 }
102 return FALSE;
103 }
104
105 /* NOTE: For environments serialize.c calls this function to find if
106 there is a class attribute in order to reconstruct the object bit
107 if needed. This means the function cannot use OBJECT(vec) == 0 to
108 conclude that the class attribute is R_NilValue. If you want to
109 rewrite this function to use such a pre-test, be sure to adjust
110 serialize.c accordingly. LT */
getAttrib0(SEXP vec,SEXP name)111 SEXP attribute_hidden getAttrib0(SEXP vec, SEXP name)
112 {
113 SEXP s;
114 if (name == R_NamesSymbol) {
115 if(isOneDimensionalArray(vec)) {
116 s = getAttrib(vec, R_DimNamesSymbol);
117 if(!isNull(s)) {
118 MARK_NOT_MUTABLE(VECTOR_ELT(s, 0));
119 return VECTOR_ELT(s, 0);
120 }
121 }
122 if (isList(vec) || isLanguage(vec) || TYPEOF(vec) == DOTSXP) {
123 int len = length(vec);
124 PROTECT(s = allocVector(STRSXP, len));
125 int i = 0;
126 Rboolean any = FALSE;
127 for ( ; vec != R_NilValue; vec = CDR(vec), i++) {
128 if (TAG(vec) == R_NilValue)
129 {
130 SET_STRING_ELT(s, i, R_BlankString);
131 }
132 else if (isSymbol(TAG(vec))) {
133 any = TRUE;
134 SET_STRING_ELT(s, i, PRINTNAME(TAG(vec)));
135 }
136 else
137 error(_("getAttrib: invalid type (%s) for TAG"),
138 type2char(TYPEOF(TAG(vec))));
139 }
140 UNPROTECT(1);
141 if (any) {
142 if (!isNull(s)) MARK_NOT_MUTABLE(s);
143 return (s);
144 } else
145 return R_NilValue;
146 }
147 }
148 for (s = ATTRIB(vec); s != R_NilValue; s = CDR(s))
149 if (TAG(s) == name) {
150 if (name == R_DimNamesSymbol && TYPEOF(CAR(s)) == LISTSXP)
151 error("old list is no longer allowed for dimnames attribute");
152 /**** this could be dropped for REFCNT or be less
153 stringent for NAMED for attributes where the setter
154 does not have a consistency check that could fail
155 after mutation in a complex assignment LT */
156 MARK_NOT_MUTABLE(CAR(s));
157 return CAR(s);
158 }
159 return R_NilValue;
160 }
161
getAttrib(SEXP vec,SEXP name)162 SEXP getAttrib(SEXP vec, SEXP name)
163 {
164 if(TYPEOF(vec) == CHARSXP)
165 error("cannot have attributes on a CHARSXP");
166 /* pre-test to avoid expensive operations if clearly not needed -- LT */
167 if (ATTRIB(vec) == R_NilValue &&
168 ! (TYPEOF(vec) == LISTSXP || TYPEOF(vec) == LANGSXP|| TYPEOF(vec) == DOTSXP))
169 return R_NilValue;
170
171 if (isString(name)) name = installTrChar(STRING_ELT(name, 0));
172
173 /* special test for c(NA, n) rownames of data frames: */
174 if (name == R_RowNamesSymbol) {
175 SEXP s = getAttrib0(vec, R_RowNamesSymbol);
176 if(isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER) {
177 int n = abs(INTEGER(s)[1]);
178 if (n > 0)
179 s = R_compact_intrange(1, n);
180 else
181 s = allocVector(INTSXP, 0);
182 }
183 return s;
184 } else
185 return getAttrib0(vec, name);
186 }
187
188 // R's .row_names_info(x, type = 1L) := .Internal(shortRowNames(x, type)) :
189 attribute_hidden
do_shortRowNames(SEXP call,SEXP op,SEXP args,SEXP env)190 SEXP do_shortRowNames(SEXP call, SEXP op, SEXP args, SEXP env)
191 {
192 /* return n if the data frame 'vec' has c(NA, n) rownames;
193 * nrow(.) otherwise; note that data frames with nrow(.) == 0
194 * have no row.names.
195 ==> is also used in dim.data.frame() */
196
197 checkArity(op, args);
198 SEXP s = getAttrib0(CAR(args), R_RowNamesSymbol), ans = s;
199 int type = asInteger(CADR(args));
200
201 if( type < 0 || type > 2)
202 error(_("invalid '%s' argument"), "type");
203
204 if(type >= 1) {
205 int n = (isInteger(s) && LENGTH(s) == 2 && INTEGER(s)[0] == NA_INTEGER)
206 ? INTEGER(s)[1] : (isNull(s) ? 0 : LENGTH(s));
207 ans = ScalarInteger((type == 1) ? n : abs(n));
208 }
209 return ans;
210 }
211
212 // .Internal(copyDFattr(in, out)) -- is allowed to change 'out' (!!)
213 attribute_hidden
do_copyDFattr(SEXP call,SEXP op,SEXP args,SEXP env)214 SEXP do_copyDFattr(SEXP call, SEXP op, SEXP args, SEXP env)
215 {
216 checkArity(op, args);
217 SEXP in = CAR(args), out = CADR(args);
218 SET_ATTRIB(out, shallow_duplicate(ATTRIB(in)));
219 IS_S4_OBJECT(in) ? SET_S4_OBJECT(out) : UNSET_S4_OBJECT(out);
220 SET_OBJECT(out, OBJECT(in));
221 return out;
222 }
223
224
225 /* 'name' should be 1-element STRSXP or SYMSXP */
setAttrib(SEXP vec,SEXP name,SEXP val)226 SEXP setAttrib(SEXP vec, SEXP name, SEXP val)
227 {
228 PROTECT(vec);
229 PROTECT(name);
230
231 if (isString(name)) {
232 PROTECT(val);
233 name = installTrChar(STRING_ELT(name, 0));
234 UNPROTECT(1);
235 }
236 if (val == R_NilValue) {
237 /* FIXME: see do_namesgets().
238 if (name == R_NamesSymbol && isOneDimensionalArray(vec)) {
239 UNPROTECT(2);
240 return removeAttrib(vec, R_DimNamesSymbol);
241 }
242 */
243 UNPROTECT(2);
244 return removeAttrib(vec, name);
245 }
246
247 /* We allow attempting to remove names from NULL */
248 if (vec == R_NilValue)
249 error(_("attempt to set an attribute on NULL"));
250
251 UNPROTECT(2);
252
253 if (name == R_NamesSymbol)
254 return namesgets(vec, val);
255 else if (name == R_DimSymbol)
256 return dimgets(vec, val);
257 else if (name == R_DimNamesSymbol)
258 return dimnamesgets(vec, val);
259 else if (name == R_ClassSymbol)
260 return classgets(vec, val);
261 else if (name == R_TspSymbol)
262 return tspgets(vec, val);
263 else if (name == R_CommentSymbol)
264 return commentgets(vec, val);
265 else if (name == R_RowNamesSymbol) // "row.names" -> care for data frames
266 return row_names_gets(vec, val);
267 else
268 return installAttrib(vec, name, val);
269 }
270
271 /* This is called in the case of binary operations to copy */
272 /* most attributes from (one of) the input arguments to */
273 /* the output. Note that the Dim and Names attributes */
274 /* should have been assigned elsewhere. */
275
copyMostAttrib(SEXP inp,SEXP ans)276 void copyMostAttrib(SEXP inp, SEXP ans)
277 {
278 SEXP s;
279
280 if (ans == R_NilValue)
281 error(_("attempt to set an attribute on NULL"));
282
283 PROTECT(ans);
284 PROTECT(inp);
285 for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
286 if ((TAG(s) != R_NamesSymbol) &&
287 (TAG(s) != R_DimSymbol) &&
288 (TAG(s) != R_DimNamesSymbol)) { // << for matrix, array ..
289 installAttrib(ans, TAG(s), CAR(s));
290 }
291 }
292 if (OBJECT(inp)) SET_OBJECT(ans, 1);
293 IS_S4_OBJECT(inp) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
294 UNPROTECT(2);
295 }
296
297 /* version that does not preserve ts information, for subsetting */
copyMostAttribNoTs(SEXP inp,SEXP ans)298 void copyMostAttribNoTs(SEXP inp, SEXP ans)
299 {
300 SEXP s;
301 int is_object = OBJECT(inp);
302 int is_s4_object = IS_S4_OBJECT(inp);
303
304 if (ans == R_NilValue)
305 error(_("attempt to set an attribute on NULL"));
306
307 PROTECT(ans);
308 PROTECT(inp);
309 for (s = ATTRIB(inp); s != R_NilValue; s = CDR(s)) {
310 if ((TAG(s) != R_NamesSymbol) &&
311 (TAG(s) != R_ClassSymbol) &&
312 (TAG(s) != R_TspSymbol) &&
313 (TAG(s) != R_DimSymbol) &&
314 (TAG(s) != R_DimNamesSymbol)) {
315 installAttrib(ans, TAG(s), CAR(s));
316 } else if (TAG(s) == R_ClassSymbol) {
317 SEXP cl = CAR(s);
318 int i;
319 Rboolean ists = FALSE;
320 for (i = 0; i < LENGTH(cl); i++)
321 if (strcmp(CHAR(STRING_ELT(cl, i)), "ts") == 0) { /* ASCII */
322 ists = TRUE;
323 break;
324 }
325 if (!ists) installAttrib(ans, TAG(s), cl);
326 else if(LENGTH(cl) <= 1) {
327 /* dropping class attribute */
328 is_object = 0;
329 is_s4_object = 0;
330 } else {
331 SEXP new_cl;
332 int i, j, l = LENGTH(cl);
333 PROTECT(new_cl = allocVector(STRSXP, l - 1));
334 for (i = 0, j = 0; i < l; i++)
335 if (strcmp(CHAR(STRING_ELT(cl, i)), "ts")) /* ASCII */
336 SET_STRING_ELT(new_cl, j++, STRING_ELT(cl, i));
337 installAttrib(ans, TAG(s), new_cl);
338 UNPROTECT(1);
339 }
340 }
341 }
342 SET_OBJECT(ans, is_object);
343 is_s4_object ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
344 UNPROTECT(2);
345 }
346
347 /* Tweaks here based in part on PR#14934 */
installAttrib(SEXP vec,SEXP name,SEXP val)348 static SEXP installAttrib(SEXP vec, SEXP name, SEXP val)
349 {
350 SEXP t = R_NilValue; /* -Wall */
351
352 if(TYPEOF(vec) == CHARSXP)
353 error("cannot set attribute on a CHARSXP");
354 if (TYPEOF(vec) == SYMSXP)
355 error(_("cannot set attribute on a symbol"));
356 /* this does no allocation */
357 for (SEXP s = ATTRIB(vec); s != R_NilValue; s = CDR(s)) {
358 if (TAG(s) == name) {
359 if (MAYBE_REFERENCED(val) && val != CAR(s))
360 val = R_FixupRHS(vec, val);
361 SETCAR(s, val);
362 return val;
363 }
364 t = s; // record last attribute, if any
365 }
366
367 /* The usual convention is that the caller protects,
368 but a lot of existing code depends assume that
369 setAttrib/installAttrib protects its arguments */
370 PROTECT(vec); PROTECT(name); PROTECT(val);
371 if (MAYBE_REFERENCED(val)) ENSURE_NAMEDMAX(val);
372 SEXP s = CONS(val, R_NilValue);
373 SET_TAG(s, name);
374 if (ATTRIB(vec) == R_NilValue) SET_ATTRIB(vec, s); else SETCDR(t, s);
375 UNPROTECT(3);
376 return val;
377 }
378
removeAttrib(SEXP vec,SEXP name)379 static SEXP removeAttrib(SEXP vec, SEXP name)
380 {
381 SEXP t;
382 if(TYPEOF(vec) == CHARSXP)
383 error("cannot set attribute on a CHARSXP");
384 if (name == R_NamesSymbol && isPairList(vec)) {
385 for (t = vec; t != R_NilValue; t = CDR(t))
386 SET_TAG(t, R_NilValue);
387 return R_NilValue;
388 }
389 else {
390 if (name == R_DimSymbol)
391 SET_ATTRIB(vec, stripAttrib(R_DimNamesSymbol, ATTRIB(vec)));
392 SET_ATTRIB(vec, stripAttrib(name, ATTRIB(vec)));
393 if (name == R_ClassSymbol)
394 SET_OBJECT(vec, 0);
395 }
396 return R_NilValue;
397 }
398
checkNames(SEXP x,SEXP s)399 static void checkNames(SEXP x, SEXP s)
400 {
401 if (isVector(x) || isList(x) || isLanguage(x)) {
402 if (!isVector(s) && !isList(s))
403 error(_("invalid type (%s) for 'names': must be vector or NULL"),
404 type2char(TYPEOF(s)));
405 if (xlength(x) != xlength(s))
406 error(_("'names' attribute [%d] must be the same length as the vector [%d]"), length(s), length(x));
407 }
408 else if(IS_S4_OBJECT(x)) {
409 /* leave validity checks to S4 code */
410 }
411 else error(_("names() applied to a non-vector"));
412 }
413
414
415 /* Time Series Parameters */
416
badtsp(void)417 static void NORET badtsp(void)
418 {
419 error(_("invalid time series parameters specified"));
420 }
421
422 attribute_hidden
tspgets(SEXP vec,SEXP val)423 SEXP tspgets(SEXP vec, SEXP val)
424 {
425 double start, end, frequency;
426 int n;
427
428 if (vec == R_NilValue)
429 error(_("attempt to set an attribute on NULL"));
430
431 if(IS_S4_OBJECT(vec)) { /* leave validity checking to validObject */
432 if (!isNumeric(val)) /* but should have been checked */
433 error(_("'tsp' attribute must be numeric"));
434 installAttrib(vec, R_TspSymbol, val);
435 return vec;
436 }
437
438 if (!isNumeric(val) || LENGTH(val) != 3)
439 error(_("'tsp' attribute must be numeric of length three"));
440
441 if (isReal(val)) {
442 start = REAL(val)[0];
443 end = REAL(val)[1];
444 frequency = REAL(val)[2];
445 }
446 else {
447 start = (INTEGER(val)[0] == NA_INTEGER) ?
448 NA_REAL : INTEGER(val)[0];
449 end = (INTEGER(val)[1] == NA_INTEGER) ?
450 NA_REAL : INTEGER(val)[1];
451 frequency = (INTEGER(val)[2] == NA_INTEGER) ?
452 NA_REAL : INTEGER(val)[2];
453 }
454 if (frequency <= 0) badtsp();
455 n = nrows(vec);
456 if (n == 0) error(_("cannot assign 'tsp' to zero-length vector"));
457
458 /* FIXME: 1.e-5 should rather be == option('ts.eps') !! */
459 if (fabs(end - start - (n - 1)/frequency) > 1.e-5)
460 badtsp();
461
462 PROTECT(vec);
463 val = allocVector(REALSXP, 3);
464 PROTECT(val);
465 REAL(val)[0] = start;
466 REAL(val)[1] = end;
467 REAL(val)[2] = frequency;
468 installAttrib(vec, R_TspSymbol, val);
469 UNPROTECT(2);
470 return vec;
471 }
472
commentgets(SEXP vec,SEXP comment)473 static SEXP commentgets(SEXP vec, SEXP comment)
474 {
475 if (vec == R_NilValue)
476 error(_("attempt to set an attribute on NULL"));
477
478 if (isNull(comment) || isString(comment)) {
479 if (length(comment) <= 0) {
480 SET_ATTRIB(vec, stripAttrib(R_CommentSymbol, ATTRIB(vec)));
481 }
482 else {
483 installAttrib(vec, R_CommentSymbol, comment);
484 }
485 return R_NilValue;
486 }
487 error(_("attempt to set invalid 'comment' attribute"));
488 return R_NilValue;/*- just for -Wall */
489 }
490
do_commentgets(SEXP call,SEXP op,SEXP args,SEXP env)491 SEXP attribute_hidden do_commentgets(SEXP call, SEXP op, SEXP args, SEXP env)
492 {
493 checkArity(op, args);
494 if (MAYBE_SHARED(CAR(args))) SETCAR(args, duplicate(CAR(args)));
495 if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
496 setAttrib(CAR(args), R_CommentSymbol, CADR(args));
497 SETTER_CLEAR_NAMED(CAR(args));
498 return CAR(args);
499 }
500
do_comment(SEXP call,SEXP op,SEXP args,SEXP env)501 SEXP attribute_hidden do_comment(SEXP call, SEXP op, SEXP args, SEXP env)
502 {
503 checkArity(op, args);
504 return getAttrib(CAR(args), R_CommentSymbol);
505 }
506
classgets(SEXP vec,SEXP klass)507 SEXP classgets(SEXP vec, SEXP klass)
508 {
509 if (isNull(klass) || isString(klass)) {
510 int ncl = length(klass);
511 if (ncl <= 0) {
512 SET_ATTRIB(vec, stripAttrib(R_ClassSymbol, ATTRIB(vec)));
513 SET_OBJECT(vec, 0);
514 // problems when package building: UNSET_S4_OBJECT(vec);
515 }
516 else {
517 /* When data frames were a special data type */
518 /* we had more exhaustive checks here. Now that */
519 /* use JMCs interpreted code, we don't need this */
520 /* FIXME : The whole "classgets" may as well die. */
521
522 /* HOWEVER, it is the way that the object bit gets set/unset */
523
524 Rboolean isfactor = FALSE;
525
526 if (vec == R_NilValue)
527 error(_("attempt to set an attribute on NULL"));
528
529 for(int i = 0; i < ncl; i++)
530 if(streql(CHAR(STRING_ELT(klass, i)), "factor")) { /* ASCII */
531 isfactor = TRUE;
532 break;
533 }
534 if(isfactor && TYPEOF(vec) != INTSXP) {
535 /* we cannot coerce vec here, so just fail */
536 error(_("adding class \"factor\" to an invalid object"));
537 }
538
539 installAttrib(vec, R_ClassSymbol, klass);
540 SET_OBJECT(vec, 1);
541
542 #ifdef R_classgets_copy_S4
543 // not ok -- fails at installation around byte-compiling methods
544 if(ncl == 1 && R_has_methods_attached()) { // methods: do not act too early
545 SEXP cld = R_getClassDef_R(klass);
546 if(!isNull(cld)) {
547 PROTECT(cld);
548 /* More efficient? can we protect? -- rather *assign* in method-ns?
549 static SEXP oldCl = NULL;
550 if(!oldCl) oldCl = R_getClassDef("oldClass");
551 if(!oldCl) oldCl = mkString("oldClass");
552 PROTECT(oldCl);
553 */
554 if(!R_isVirtualClass(cld, R_MethodsNamespace) &&
555 !R_extends(cld, mkString("oldClass"), R_MethodsNamespace)) // set S4 bit :
556 // !R_extends(cld, oldCl, R_MethodsNamespace)) // set S4 bit :
557
558 SET_S4_OBJECT(vec);
559
560 UNPROTECT(1); // UNPROTECT(2);
561 }
562 }
563 #endif
564 }
565 return R_NilValue;
566 }
567 error(_("attempt to set invalid 'class' attribute"));
568 return R_NilValue;/*- just for -Wall */
569 }
570
571 /* oldClass<-(), primitive */
do_classgets(SEXP call,SEXP op,SEXP args,SEXP env)572 SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
573 {
574 checkArity(op, args);
575 // have 2 args: check1arg(args, call, "x");
576
577 if (MAYBE_SHARED(CAR(args)) ||
578 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))
579 SETCAR(args, shallow_duplicate(CAR(args)));
580 if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
581 if(IS_S4_OBJECT(CAR(args)))
582 UNSET_S4_OBJECT(CAR(args));
583 setAttrib(CAR(args), R_ClassSymbol, CADR(args));
584 SETTER_CLEAR_NAMED(CAR(args));
585 return CAR(args);
586 }
587
588 // oldClass, primitive -- NB: class() |=> R_do_data_class() |=> R_data_class()
do_class(SEXP call,SEXP op,SEXP args,SEXP env)589 SEXP attribute_hidden do_class(SEXP call, SEXP op, SEXP args, SEXP env)
590 {
591 checkArity(op, args);
592 check1arg(args, call, "x");
593 SEXP x = CAR(args), s3class;
594 if(IS_S4_OBJECT(x)) {
595 if((s3class = S3Class(x)) != R_NilValue) {
596 return s3class;
597 }
598 } /* else */
599 return getAttrib(x, R_ClassSymbol);
600 }
601
602 /* character elements corresponding to the syntactic types in the
603 grammar */
lang2str(SEXP obj,SEXPTYPE t)604 static SEXP lang2str(SEXP obj, SEXPTYPE t)
605 {
606 SEXP symb = CAR(obj);
607 static SEXP if_sym = 0, while_sym, for_sym, eq_sym, gets_sym,
608 lpar_sym, lbrace_sym, call_sym;
609 if(!if_sym) {
610 /* initialize: another place for a hash table */
611 if_sym = install("if");
612 while_sym = install("while");
613 for_sym = install("for");
614 eq_sym = install("=");
615 gets_sym = install("<-");
616 lpar_sym = install("(");
617 lbrace_sym = install("{");
618 call_sym = install("call");
619 }
620 if(isSymbol(symb)) {
621 if(symb == if_sym || symb == for_sym || symb == while_sym ||
622 symb == lpar_sym || symb == lbrace_sym ||
623 symb == eq_sym || symb == gets_sym)
624 return PRINTNAME(symb);
625 }
626 return PRINTNAME(call_sym);
627 }
628
629 /* the S4-style class: for dispatch required to be a single string;
630 for the new class() function;
631 if(!singleString) , keeps S3-style multiple classes.
632 Called from the methods package, so exposed.
633 */
R_data_class(SEXP obj,Rboolean singleString)634 SEXP R_data_class(SEXP obj, Rboolean singleString)
635 {
636 SEXP value, klass = getAttrib(obj, R_ClassSymbol);
637 int n = length(klass);
638 if(n == 1 || (n > 0 && !singleString))
639 return(klass);
640 if(n == 0) {
641 SEXP dim = getAttrib(obj, R_DimSymbol);
642 int nd = length(dim);
643 if(nd > 0) {
644 if(nd == 2) {
645 if(singleString)
646 klass = mkChar("matrix");
647 else { // R >= 4.0.0 : class(<matrix>) |-> c("matrix", "array")
648 PROTECT(klass = allocVector(STRSXP, 2));
649 SET_STRING_ELT(klass, 0, mkChar("matrix"));
650 SET_STRING_ELT(klass, 1, mkChar("array"));
651 UNPROTECT(1);
652 return klass;
653 }
654 }
655 else
656 klass = mkChar("array");
657 }
658 else {
659 SEXPTYPE t = TYPEOF(obj);
660 switch(t) {
661 case CLOSXP: case SPECIALSXP: case BUILTINSXP:
662 klass = mkChar("function");
663 break;
664 case REALSXP:
665 klass = mkChar("numeric");
666 break;
667 case SYMSXP:
668 klass = mkChar("name");
669 break;
670 case LANGSXP:
671 klass = lang2str(obj, t);
672 break;
673 default:
674 klass = type2str(t);
675 }
676 }
677 }
678 else
679 klass = asChar(klass);
680 PROTECT(klass);
681 value = ScalarString(klass);
682 UNPROTECT(1);
683 return value;
684 }
685
686 static SEXP s_dot_S3Class = 0;
687
688 static SEXP R_S4_extends_table = 0;
689
690
cache_class(const char * class,SEXP klass)691 static SEXP cache_class(const char *class, SEXP klass)
692 {
693 if(!R_S4_extends_table) {
694 R_S4_extends_table = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
695 R_PreserveObject(R_S4_extends_table);
696 }
697 if(isNull(klass)) {
698 R_removeVarFromFrame(install(class), R_S4_extends_table);
699 } else {
700 defineVar(install(class), klass, R_S4_extends_table);
701 }
702 return klass;
703 }
704
S4_extends(SEXP klass,Rboolean use_tab)705 static SEXP S4_extends(SEXP klass, Rboolean use_tab) {
706 static SEXP s_extends = 0, s_extendsForS3;
707 SEXP e, val; const char *class;
708 const void *vmax;
709 if(use_tab) vmax = vmaxget();
710 if(!s_extends) {
711 s_extends = install("extends");
712 s_extendsForS3 = install(".extendsForS3");
713 R_S4_extends_table = R_NewHashedEnv(R_NilValue, ScalarInteger(0));
714 R_PreserveObject(R_S4_extends_table);
715 }
716 if(!isMethodsDispatchOn()) {
717 return klass;
718 }
719 class = translateChar(STRING_ELT(klass, 0)); /* TODO: include package attr. */
720 if(use_tab) {
721 val = findVarInFrame(R_S4_extends_table, install(class));
722 vmaxset(vmax);
723 if(val != R_UnboundValue)
724 return val;
725 }
726 // else: val <- .extendsForS3(klass) -- and cache it
727 PROTECT(e = allocVector(LANGSXP, 2));
728 SETCAR(e, s_extendsForS3);
729 val = CDR(e);
730 SETCAR(val, klass);
731 PROTECT(val = eval(e, R_MethodsNamespace));
732 cache_class(class, val);
733 UNPROTECT(2); /* val, e */
734 return(val);
735 }
736
R_S4_extends(SEXP klass,SEXP useTable)737 SEXP R_S4_extends(SEXP klass, SEXP useTable)
738 {
739 return S4_extends(klass, asLogical(useTable));
740 }
741
742
743 /* pre-allocated default class attributes */
744 static struct {
745 SEXP vector;
746 SEXP matrix;
747 SEXP array;
748 } Type2DefaultClass[MAX_NUM_SEXPTYPE];
749
750
createDefaultClass(SEXP part1,SEXP part2,SEXP part3,SEXP part4)751 static SEXP createDefaultClass(SEXP part1, SEXP part2, SEXP part3, SEXP part4)
752 {
753 int size = 0;
754 if (part1 != R_NilValue) size++;
755 if (part2 != R_NilValue) size++;
756 if (part3 != R_NilValue) size++;
757 if (part4 != R_NilValue) size++;
758
759 if (size == 0 || part3 == R_NilValue) // .. ?
760 return R_NilValue;
761
762 SEXP res = allocVector(STRSXP, size);
763 R_PreserveObject(res);
764
765 int i = 0;
766 if (part1 != R_NilValue) SET_STRING_ELT(res, i++, part1);
767 if (part2 != R_NilValue) SET_STRING_ELT(res, i++, part2);
768 if (part3 != R_NilValue) SET_STRING_ELT(res, i++, part3);
769 if (part4 != R_NilValue) SET_STRING_ELT(res, i, part4);
770
771 MARK_NOT_MUTABLE(res);
772 return res;
773 }
774
775 // called when R's main loop is setup :
776 attribute_hidden
InitS3DefaultTypes()777 void InitS3DefaultTypes()
778 {
779 for(int type = 0; type < MAX_NUM_SEXPTYPE; type++) {
780 SEXP part3 = R_NilValue;
781 SEXP part4 = R_NilValue;
782 int nprotected = 0;
783
784 switch(type) {
785 case CLOSXP:
786 case SPECIALSXP:
787 case BUILTINSXP:
788 part3 = PROTECT(mkChar("function"));
789 nprotected++;
790 break;
791 case INTSXP:
792 case REALSXP:
793 part3 = PROTECT(type2str_nowarn(type));
794 part4 = PROTECT(mkChar("numeric"));
795 nprotected += 2;
796 break;
797 case LANGSXP:
798 /* part3 remains R_NilValue: default type cannot be
799 pre-allocated, as it depends on the object value */
800 break;
801 case SYMSXP:
802 part3 = PROTECT(mkChar("name"));
803 nprotected++;
804 break;
805 default:
806 part3 = PROTECT(type2str_nowarn(type));
807 nprotected++;
808 }
809
810 Type2DefaultClass[type].vector =
811 createDefaultClass(R_NilValue, R_NilValue, part3, part4);
812
813 SEXP part2 = PROTECT(mkChar("array"));
814 SEXP part1 = PROTECT(mkChar("matrix"));
815 nprotected += 2;
816 Type2DefaultClass[type].matrix =
817 createDefaultClass(part1, part2, part3, part4);
818 Type2DefaultClass[type].array =
819 createDefaultClass(R_NilValue, part2, part3, part4);
820 UNPROTECT(nprotected);
821 }
822 }
823
824 /* Version for S3-dispatch */
R_data_class2(SEXP obj)825 SEXP attribute_hidden R_data_class2 (SEXP obj)
826 {
827 SEXP klass = getAttrib(obj, R_ClassSymbol);
828 if(length(klass) > 0) {
829 if(IS_S4_OBJECT(obj))
830 return S4_extends(klass, TRUE);
831 else
832 return klass;
833 }
834 else { // length(klass) == 0 , i.e., no class *attribute*: attr(obj, "class") is NULL
835
836 SEXP dim = getAttrib(obj, R_DimSymbol);
837 int n = length(dim);
838 SEXPTYPE t = TYPEOF(obj);
839 SEXP defaultClass;
840
841 switch(n) {
842 case 0: defaultClass = Type2DefaultClass[t].vector; break;
843 case 2: defaultClass = Type2DefaultClass[t].matrix; break;
844 default: defaultClass = Type2DefaultClass[t].array; break;
845 }
846
847 if (defaultClass != R_NilValue) {
848 return defaultClass;
849 }
850
851 /* now t == LANGSXP, but check to make sure */
852 if (t != LANGSXP)
853 error("type must be LANGSXP at this point");
854 if (n == 0) {
855 return ScalarString(lang2str(obj, t));
856 }
857 /* Where on earth is this ever needed ??
858 * __FIXME / TODO__ ??
859 * warning("R_data_class2(<LANGSXP with \"dim\" attribute>) .. please report!");
860 */
861 int I_mat = (n == 2) ? 1 : 0,
862 nprot = 2; /* part1, defaultClass */
863 defaultClass = PROTECT(allocVector(STRSXP, 2 + I_mat));
864 SEXP part1 = PROTECT(mkChar("array")), part2;
865 SET_STRING_ELT(defaultClass, 0, part1);
866 if (n == 2) {
867 part2 = PROTECT(mkChar("matrix")); nprot++;
868 SET_STRING_ELT(defaultClass, 1, part2);
869 }
870 SET_STRING_ELT(defaultClass, 1+I_mat, lang2str(obj, t));
871 UNPROTECT(nprot);
872 return defaultClass;
873 }
874 }
875
876 // class(x) & .cache_class(classname, extendsForS3(.)) {called from methods} & .class2() :
R_do_data_class(SEXP call,SEXP op,SEXP args,SEXP env)877 SEXP attribute_hidden R_do_data_class(SEXP call, SEXP op, SEXP args, SEXP env)
878 {
879 checkArity(op, args);
880 if(PRIMVAL(op) == 1) { // .cache_class() - typically re-defining existing cache
881 check1arg(args, call, "class");
882 SEXP klass = CAR(args);
883 if(TYPEOF(klass) != STRSXP || LENGTH(klass) < 1)
884 error("invalid class argument to internal .class_cache");
885 const char *class = translateChar(STRING_ELT(klass, 0));
886 return cache_class(class, CADR(args));
887 }
888 check1arg(args, call, "x");
889 if(PRIMVAL(op) == 2)
890 // .class2()
891 return R_data_class2(CAR(args));
892 // class():
893 return R_data_class(CAR(args), FALSE);
894 }
895
896 /* names(object) <- name */
do_namesgets(SEXP call,SEXP op,SEXP args,SEXP env)897 SEXP attribute_hidden do_namesgets(SEXP call, SEXP op, SEXP args, SEXP env)
898 {
899 SEXP ans;
900 checkArity(op, args);
901 // 2 args ("x", "value")
902
903 /* DispatchOrEval internal generic: names<- */
904 if (DispatchOrEval(call, op, "names<-", args, env, &ans, 0, 1))
905 return(ans);
906 /* Special case: removing non-existent names, to avoid a copy */
907 if (CADR(args) == R_NilValue &&
908 getAttrib(CAR(args), R_NamesSymbol) == R_NilValue)
909 return CAR(args);
910 PROTECT(args = ans);
911 if (MAYBE_SHARED(CAR(args)) ||
912 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))
913 SETCAR(args, R_shallow_duplicate_attr(CAR(args)));
914 if (TYPEOF(CAR(args)) == S4SXP) {
915 const char *klass = CHAR(STRING_ELT(R_data_class(CAR(args), FALSE), 0));
916 error(_("invalid to use names()<- on an S4 object of class '%s'"),
917 klass);
918 }
919 SEXP names = CADR(args);
920 if (names != R_NilValue &&
921 ! (TYPEOF(names) == STRSXP && ATTRIB(names) == R_NilValue)) {
922 PROTECT(call = allocList(2));
923 SET_TYPEOF(call, LANGSXP);
924 SETCAR(call, R_AsCharacterSymbol);
925 SETCADR(call, names);
926 names = eval(call, env);
927 SETCADR(call, R_NilValue); /* decrements REFCNT on names */
928 UNPROTECT(1);
929 }
930 /* FIXME:
931 Need to special-case names(x) <- NULL for 1-d arrays to perform
932 setAttrib(x, R_DimNamesSymbol, R_NilValue)
933 (and remove the dimnames) here if we want
934 setAttrib(x, R_NamesSymbol, R_NilValue)
935 to actually remove the names, as needed in subset.c.
936 */
937 if(names == R_NilValue && isOneDimensionalArray(CAR(args)))
938 setAttrib(CAR(args), R_DimNamesSymbol, names);
939 else
940 setAttrib(CAR(args), R_NamesSymbol, names);
941 UNPROTECT(1);
942 SETTER_CLEAR_NAMED(CAR(args));
943 return CAR(args);
944 }
945
namesgets(SEXP vec,SEXP val)946 SEXP namesgets(SEXP vec, SEXP val)
947 {
948 int i;
949 SEXP s, rval, tval;
950
951 PROTECT(vec);
952 PROTECT(val);
953
954 /* Ensure that the labels are indeed */
955 /* a vector of character strings */
956
957 if (isList(val)) {
958 if (!isVectorizable(val))
959 error(_("incompatible 'names' argument"));
960 else {
961 rval = allocVector(STRSXP, length(vec));
962 PROTECT(rval);
963 /* See PR#10807 */
964 for (i = 0, tval = val;
965 i < length(vec) && tval != R_NilValue;
966 i++, tval = CDR(tval)) {
967 s = coerceVector(CAR(tval), STRSXP);
968 SET_STRING_ELT(rval, i, STRING_ELT(s, 0));
969 }
970 UNPROTECT(1);
971 val = rval;
972 }
973 } else val = coerceVector(val, STRSXP);
974 UNPROTECT(1);
975 PROTECT(val);
976
977 /* Check that the lengths and types are compatible */
978
979 if (xlength(val) < xlength(vec)) {
980 val = xlengthgets(val, xlength(vec));
981 UNPROTECT(1);
982 PROTECT(val);
983 }
984
985 checkNames(vec, val);
986
987 /* Special treatment for one dimensional arrays */
988 if(isOneDimensionalArray(vec)) {
989 PROTECT(val = CONS(val, R_NilValue));
990 setAttrib(vec, R_DimNamesSymbol, val);
991 UNPROTECT(3);
992 return vec;
993 }
994
995 if (isList(vec) || isLanguage(vec)) {
996 /* Cons-cell based objects */
997 i = 0;
998 for (s = vec; s != R_NilValue; s = CDR(s), i++)
999 if (STRING_ELT(val, i) != R_NilValue
1000 && STRING_ELT(val, i) != R_NaString
1001 && *CHAR(STRING_ELT(val, i)) != 0) /* test of length */
1002 SET_TAG(s, installTrChar(STRING_ELT(val, i)));
1003 else
1004 SET_TAG(s, R_NilValue);
1005 }
1006 else if (isVector(vec) || IS_S4_OBJECT(vec))
1007 /* Normal case */
1008 installAttrib(vec, R_NamesSymbol, val);
1009 else
1010 error(_("invalid type (%s) to set 'names' attribute"),
1011 type2char(TYPEOF(vec)));
1012 UNPROTECT(2);
1013 return vec;
1014 }
1015
1016 #define isS4Environment(x) (TYPEOF(x) == S4SXP && \
1017 isEnvironment(R_getS4DataSlot(x, ENVSXP)))
1018
do_names(SEXP call,SEXP op,SEXP args,SEXP env)1019 SEXP attribute_hidden do_names(SEXP call, SEXP op, SEXP args, SEXP env)
1020 {
1021 SEXP ans;
1022 checkArity(op, args);
1023 check1arg(args, call, "x");
1024 /* DispatchOrEval internal generic: names */
1025 if (DispatchOrEval(call, op, "names", args, env, &ans, 0, 1))
1026 return(ans);
1027 PROTECT(args = ans);
1028 ans = CAR(args);
1029 if (isEnvironment(ans) || isS4Environment(ans))
1030 ans = R_lsInternal3(ans, TRUE, FALSE);
1031 else if (isVector(ans) || isList(ans) || isLanguage(ans) || IS_S4_OBJECT(ans) || TYPEOF(ans) == DOTSXP)
1032 ans = getAttrib(ans, R_NamesSymbol);
1033 else ans = R_NilValue;
1034 UNPROTECT(1);
1035 return ans;
1036 }
1037
do_dimnamesgets(SEXP call,SEXP op,SEXP args,SEXP env)1038 SEXP attribute_hidden do_dimnamesgets(SEXP call, SEXP op, SEXP args, SEXP env)
1039 {
1040 SEXP ans;
1041
1042 checkArity(op, args);
1043 // 2 args ("x", "value")
1044 /* DispatchOrEval internal generic: dimnames<- */
1045 if (DispatchOrEval(call, op, "dimnames<-", args, env, &ans, 0, 1))
1046 return(ans);
1047 PROTECT(args = ans);
1048 if (MAYBE_SHARED(CAR(args)) ||
1049 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))
1050 SETCAR(args, R_shallow_duplicate_attr(CAR(args)));
1051 setAttrib(CAR(args), R_DimNamesSymbol, CADR(args));
1052 UNPROTECT(1);
1053 SETTER_CLEAR_NAMED(CAR(args));
1054 return CAR(args);
1055 }
1056
dimnamesgets1(SEXP val1)1057 static SEXP dimnamesgets1(SEXP val1)
1058 {
1059 SEXP this2;
1060
1061 if (LENGTH(val1) == 0) return R_NilValue;
1062 /* if (isObject(val1)) dispatch on as.character.foo, but we don't
1063 have the context at this point to do so */
1064
1065 if (inherits(val1, "factor")) /* mimic as.character.factor */
1066 return asCharacterFactor(val1);
1067
1068 if (!isString(val1)) { /* mimic as.character.default */
1069 PROTECT(this2 = coerceVector(val1, STRSXP));
1070 SET_ATTRIB(this2, R_NilValue);
1071 SET_OBJECT(this2, 0);
1072 UNPROTECT(1);
1073 return this2;
1074 }
1075 return val1;
1076 }
1077
1078
dimnamesgets(SEXP vec,SEXP val)1079 SEXP dimnamesgets(SEXP vec, SEXP val)
1080 {
1081 SEXP dims, top, newval;
1082 int i, k;
1083
1084 PROTECT(vec);
1085 PROTECT(val);
1086
1087 if (!isArray(vec) && !isList(vec))
1088 error(_("'dimnames' applied to non-array"));
1089 /* This is probably overkill, but you never know; */
1090 /* there may be old pair-lists out there */
1091 /* There are, when this gets used as names<- for 1-d arrays */
1092 if (!isList(val) && !isNewList(val))
1093 error(_("'%s' must be a list"), "dimnames");
1094 dims = getAttrib(vec, R_DimSymbol);
1095 if ((k = LENGTH(dims)) < length(val))
1096 error(_("length of 'dimnames' [%d] must match that of 'dims' [%d]"),
1097 length(val), k);
1098 if (length(val) == 0) {
1099 removeAttrib(vec, R_DimNamesSymbol);
1100 UNPROTECT(2);
1101 return vec;
1102 }
1103 /* Old list to new list */
1104 if (isList(val)) {
1105 newval = allocVector(VECSXP, k);
1106 for (i = 0; i < k; i++) {
1107 SET_VECTOR_ELT(newval, i, CAR(val));
1108 val = CDR(val);
1109 }
1110 UNPROTECT(1);
1111 PROTECT(val = newval);
1112 }
1113 if (length(val) > 0 && length(val) < k) {
1114 newval = lengthgets(val, k);
1115 UNPROTECT(1);
1116 PROTECT(val = newval);
1117 }
1118 if (MAYBE_REFERENCED(val)) {
1119 newval = shallow_duplicate(val);
1120 UNPROTECT(1);
1121 PROTECT(val = newval);
1122 }
1123 if (k != length(val))
1124 error(_("length of 'dimnames' [%d] must match that of 'dims' [%d]"),
1125 length(val), k);
1126 for (i = 0; i < k; i++) {
1127 SEXP _this = VECTOR_ELT(val, i);
1128 if (_this != R_NilValue) {
1129 if (!isVector(_this))
1130 error(_("invalid type (%s) for 'dimnames' (must be a vector)"),
1131 type2char(TYPEOF(_this)));
1132 if (INTEGER(dims)[i] != LENGTH(_this) && LENGTH(_this) != 0)
1133 error(_("length of 'dimnames' [%d] not equal to array extent"),
1134 i+1);
1135 SET_VECTOR_ELT(val, i, dimnamesgets1(_this));
1136 }
1137 }
1138 installAttrib(vec, R_DimNamesSymbol, val);
1139 if (isList(vec) && k == 1) {
1140 top = VECTOR_ELT(val, 0);
1141 i = 0;
1142 for (val = vec; !isNull(val); val = CDR(val))
1143 SET_TAG(val, installTrChar(STRING_ELT(top, i++)));
1144 }
1145 UNPROTECT(2);
1146
1147 /* Mark as immutable so nested complex assignment can't make the
1148 dimnames attribute inconsistent with the length */
1149 MARK_NOT_MUTABLE(val);
1150
1151 return vec;
1152 }
1153
do_dimnames(SEXP call,SEXP op,SEXP args,SEXP env)1154 SEXP attribute_hidden do_dimnames(SEXP call, SEXP op, SEXP args, SEXP env)
1155 {
1156 SEXP ans;
1157 checkArity(op, args);
1158 check1arg(args, call, "x");
1159 /* DispatchOrEval internal generic: dimnames */
1160 if (DispatchOrEval(call, op, "dimnames", args, env, &ans, 0, 1))
1161 return(ans);
1162 PROTECT(args = ans);
1163 ans = getAttrib(CAR(args), R_DimNamesSymbol);
1164 UNPROTECT(1);
1165 return ans;
1166 }
1167
do_dim(SEXP call,SEXP op,SEXP args,SEXP env)1168 SEXP attribute_hidden do_dim(SEXP call, SEXP op, SEXP args, SEXP env)
1169 {
1170 SEXP ans;
1171 checkArity(op, args);
1172 check1arg(args, call, "x");
1173 /* DispatchOrEval internal generic: dim */
1174 if (DispatchOrEval(call, op, "dim", args, env, &ans, 0, 1))
1175 return(ans);
1176 PROTECT(args = ans);
1177 ans = getAttrib(CAR(args), R_DimSymbol);
1178 UNPROTECT(1);
1179 return ans;
1180 }
1181
do_dimgets(SEXP call,SEXP op,SEXP args,SEXP env)1182 SEXP attribute_hidden do_dimgets(SEXP call, SEXP op, SEXP args, SEXP env)
1183 {
1184 SEXP ans, x;
1185 checkArity(op, args);
1186 /* DispatchOrEval internal generic: dim<- */
1187 if (DispatchOrEval(call, op, "dim<-", args, env, &ans, 0, 1))
1188 return(ans);
1189 x = CAR(args);
1190 /* Duplication might be expensive */
1191 if (CADR(args) == R_NilValue) {
1192 SEXP s;
1193 for (s = ATTRIB(x); s != R_NilValue; s = CDR(s))
1194 if (TAG(s) == R_DimSymbol || TAG(s) == R_NamesSymbol) break;
1195 if (s == R_NilValue) return x;
1196 }
1197 PROTECT(args = ans);
1198 if (MAYBE_SHARED(x) ||
1199 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(x)))
1200 SETCAR(args, x = shallow_duplicate(x));
1201 setAttrib(x, R_DimSymbol, CADR(args));
1202 setAttrib(x, R_NamesSymbol, R_NilValue);
1203 UNPROTECT(1);
1204 SETTER_CLEAR_NAMED(x);
1205 return x;
1206 }
1207
dimgets(SEXP vec,SEXP val)1208 SEXP dimgets(SEXP vec, SEXP val)
1209 {
1210 int i, ndim;
1211 R_xlen_t len, total;
1212 PROTECT(vec);
1213 PROTECT(val);
1214 if (!isVector(vec) && !isList(vec))
1215 error(_("invalid first argument, must be %s"), "vector (list or atomic)");
1216 if (val != R_NilValue && !isVectorAtomic(val))
1217 error(_("invalid second argument, must be %s"), "vector or NULL");
1218 val = coerceVector(val, INTSXP);
1219 UNPROTECT(1);
1220 PROTECT(val);
1221
1222 len = xlength(vec);
1223 ndim = length(val);
1224 if (ndim == 0)
1225 error(_("length-0 dimension vector is invalid"));
1226 total = 1;
1227 for (i = 0; i < ndim; i++) {
1228 /* need this test first as NA_INTEGER is < 0 */
1229 if (INTEGER(val)[i] == NA_INTEGER)
1230 error(_("the dims contain missing values"));
1231 if (INTEGER(val)[i] < 0)
1232 error(_("the dims contain negative values"));
1233 total *= INTEGER(val)[i];
1234 }
1235 if (total != len) {
1236 if (total > INT_MAX || len > INT_MAX)
1237 error(_("dims do not match the length of object"), total, len);
1238 else
1239 error(_("dims [product %d] do not match the length of object [%d]"), total, len);
1240 }
1241 removeAttrib(vec, R_DimNamesSymbol);
1242 installAttrib(vec, R_DimSymbol, val);
1243
1244 /* Mark as immutable so nested complex assignment can't make the
1245 dim attribute inconsistent with the length */
1246 MARK_NOT_MUTABLE(val);
1247
1248 UNPROTECT(2);
1249 return vec;
1250 }
1251
do_attributes(SEXP call,SEXP op,SEXP args,SEXP env)1252 SEXP attribute_hidden do_attributes(SEXP call, SEXP op, SEXP args, SEXP env)
1253 {
1254 checkArity(op, args);
1255 check1arg(args, call, "x");
1256
1257 if (TYPEOF(CAR(args)) == ENVSXP)
1258 R_CheckStack(); /* in case attributes might lead to a cycle */
1259
1260 SEXP attrs = ATTRIB(CAR(args)), namesattr;
1261 int nvalues = length(attrs);
1262 if (isList(CAR(args))) {
1263 namesattr = getAttrib(CAR(args), R_NamesSymbol);
1264 if (namesattr != R_NilValue)
1265 nvalues++;
1266 } else
1267 namesattr = R_NilValue;
1268 /* FIXME */
1269 if (nvalues <= 0)
1270 return R_NilValue;
1271 /* FIXME */
1272 SEXP value, names;
1273 PROTECT(namesattr);
1274 PROTECT(value = allocVector(VECSXP, nvalues));
1275 PROTECT(names = allocVector(STRSXP, nvalues));
1276 nvalues = 0;
1277 if (namesattr != R_NilValue) {
1278 SET_VECTOR_ELT(value, nvalues, namesattr);
1279 SET_STRING_ELT(names, nvalues, PRINTNAME(R_NamesSymbol));
1280 nvalues++;
1281 }
1282 while (attrs != R_NilValue) {
1283 SEXP tag = TAG(attrs);
1284 if (TYPEOF(tag) == SYMSXP) {
1285 SET_VECTOR_ELT(value, nvalues, getAttrib(CAR(args), tag));
1286 SET_STRING_ELT(names, nvalues, PRINTNAME(tag));
1287 }
1288 else { // empty tag, hence name = ""
1289 MARK_NOT_MUTABLE(CAR(attrs));
1290 SET_VECTOR_ELT(value, nvalues, CAR(attrs));
1291 SET_STRING_ELT(names, nvalues, R_BlankString);
1292 }
1293 attrs = CDR(attrs);
1294 nvalues++;
1295 }
1296 setAttrib(value, R_NamesSymbol, names);
1297 UNPROTECT(3);
1298 return value;
1299 }
1300
1301 // levels(.) <- newlevs :
do_levelsgets(SEXP call,SEXP op,SEXP args,SEXP env)1302 SEXP attribute_hidden do_levelsgets(SEXP call, SEXP op, SEXP args, SEXP env)
1303 {
1304 SEXP ans;
1305
1306 checkArity(op, args);
1307 // 2 args ("x", "value")
1308 /* DispatchOrEval internal generic: levels<- */
1309 if (DispatchOrEval(call, op, "levels<-", args, env, &ans, 0, 1))
1310 /* calls, e.g., levels<-.factor() */
1311 return(ans);
1312 PROTECT(ans);
1313 if(!isNull(CADR(args)) && any_duplicated(CADR(args), FALSE))
1314 errorcall(call, _("factor level [%d] is duplicated"),
1315 any_duplicated(CADR(args), FALSE));
1316 args = ans;
1317 if (MAYBE_SHARED(CAR(args)) ||
1318 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(CAR(args))))
1319 SETCAR(args, duplicate(CAR(args)));
1320 setAttrib(CAR(args), R_LevelsSymbol, CADR(args));
1321 UNPROTECT(1);
1322 return CAR(args);
1323 }
1324
1325 /* attributes(object) <- attrs */
do_attributesgets(SEXP call,SEXP op,SEXP args,SEXP env)1326 SEXP attribute_hidden do_attributesgets(SEXP call, SEXP op, SEXP args, SEXP env)
1327 {
1328 /* NOTE: The following code ensures that when an attribute list */
1329 /* is attached to an object, that the "dim" attibute is always */
1330 /* brought to the front of the list. This ensures that when both */
1331 /* "dim" and "dimnames" are set that the "dim" is attached first. */
1332
1333 /* Extract the arguments from the argument list */
1334
1335 checkArity(op, args);
1336
1337 SEXP object = CAR(args),
1338 attrs = CADR(args), names;
1339
1340 /* Do checks before duplication */
1341 if (!isNewList(attrs))
1342 error(_("attributes must be a list or NULL"));
1343 int nattrs = length(attrs), i;
1344 if (nattrs > 0) {
1345 names = getAttrib(attrs, R_NamesSymbol);
1346 if (names == R_NilValue)
1347 error(_("attributes must be named"));
1348 for (i = 1; i < nattrs; i++) {
1349 if (STRING_ELT(names, i) == R_NilValue ||
1350 CHAR(STRING_ELT(names, i))[0] == '\0') { /* all ASCII tests */
1351 error(_("all attributes must have names [%d does not]"), i+1);
1352 }
1353 }
1354 } else
1355 names = R_NilValue; // -Wall
1356
1357 PROTECT(names);
1358 if (object == R_NilValue) {
1359 if (attrs == R_NilValue) {
1360 UNPROTECT(1); /* names */
1361 return R_NilValue;
1362 } else
1363 PROTECT(object = allocVector(VECSXP, 0));
1364 } else {
1365 /* Unlikely to have NAMED == 0 here.
1366 As from R 2.7.0 we don't optimize NAMED == 1 _if_ we are
1367 setting any attributes as an error later on would leave
1368 'obj' changed */
1369 if (MAYBE_SHARED(object) || (MAYBE_REFERENCED(object) && nattrs) ||
1370 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(object)))
1371 object = R_shallow_duplicate_attr(object);
1372 PROTECT(object);
1373 }
1374
1375
1376 /* Empty the existing attribute list */
1377
1378 /* FIXME: the code below treats pair-based structures */
1379 /* in a special way. This can probably be dropped down */
1380 /* the road (users should never encounter pair-based lists). */
1381 /* Of course, if we want backward compatibility we can't */
1382 /* make the change. :-( */
1383
1384 if (isList(object))
1385 setAttrib(object, R_NamesSymbol, R_NilValue);
1386 SET_ATTRIB(object, R_NilValue);
1387 /* We have just removed the class, but might reset it later */
1388 SET_OBJECT(object, 0);
1389 /* Probably need to fix up S4 bit in other cases, but
1390 definitely in this one */
1391 if(nattrs == 0) UNSET_S4_OBJECT(object);
1392
1393 /* We do two passes through the attributes; the first */
1394 /* finding and transferring "dim" and the second */
1395 /* transferring the rest. This is to ensure that */
1396 /* "dim" occurs in the attribute list before "dimnames". */
1397
1398 if (nattrs > 0) {
1399 int i0 = -1;
1400 for (i = 0; i < nattrs; i++) {
1401 if (!strcmp(CHAR(STRING_ELT(names, i)), "dim")) {
1402 i0 = i;
1403 setAttrib(object, R_DimSymbol, VECTOR_ELT(attrs, i));
1404 break;
1405 }
1406 }
1407 for (i = 0; i < nattrs; i++) {
1408 if (i == i0) continue;
1409 setAttrib(object, installTrChar(STRING_ELT(names, i)),
1410 VECTOR_ELT(attrs, i));
1411 }
1412 }
1413 UNPROTECT(2); /* names, object */
1414 return object;
1415 }
1416
1417 /* This code replaces an R function defined as
1418
1419 attr <- function (x, which)
1420 {
1421 if (!is.character(which))
1422 stop("attribute name must be of mode character")
1423 if (length(which) != 1)
1424 stop("exactly one attribute name must be given")
1425 attributes(x)[[which]]
1426 }
1427
1428 The R function was being called very often and replacing it by
1429 something more efficient made a noticeable difference on several
1430 benchmarks. There is still some inefficiency since using getAttrib
1431 means the attributes list will be searched twice, but this seems
1432 fairly minor. LT */
1433
do_attr(SEXP call,SEXP op,SEXP args,SEXP env)1434 SEXP attribute_hidden do_attr(SEXP call, SEXP op, SEXP args, SEXP env)
1435 {
1436 SEXP argList, s, t, tag = R_NilValue, alist, ans;
1437 const char *str;
1438 int nargs = length(args), exact = 0;
1439 enum { NONE, PARTIAL, PARTIAL2, FULL } match = NONE;
1440 static SEXP do_attr_formals = NULL;
1441
1442 if (do_attr_formals == NULL)
1443 do_attr_formals = allocFormalsList3(install("x"), install("which"),
1444 R_ExactSymbol);
1445
1446 argList = matchArgs_NR(do_attr_formals, args, call);
1447
1448 if (nargs < 2 || nargs > 3)
1449 errorcall(call, "either 2 or 3 arguments are required");
1450
1451 /* argument matching */
1452 PROTECT(argList);
1453 s = CAR(argList);
1454 t = CADR(argList);
1455 if (!isString(t))
1456 errorcall(call, _("'which' must be of mode character"));
1457 if (length(t) != 1)
1458 errorcall(call, _("exactly one attribute 'which' must be given"));
1459
1460 if (TYPEOF(s) == ENVSXP)
1461 R_CheckStack(); /* in case attributes might lead to a cycle */
1462
1463 if(nargs == 3) {
1464 exact = asLogical(CADDR(argList));
1465 if(exact == NA_LOGICAL) exact = 0;
1466 }
1467
1468
1469 if(STRING_ELT(t, 0) == NA_STRING) {
1470 UNPROTECT(1);
1471 return R_NilValue;
1472 }
1473 str = translateChar(STRING_ELT(t, 0));
1474 size_t n = strlen(str);
1475
1476 /* try to find a match among the attributes list */
1477 for (alist = ATTRIB(s); alist != R_NilValue; alist = CDR(alist)) {
1478 SEXP tmp = TAG(alist);
1479 const char *s = CHAR(PRINTNAME(tmp));
1480 if (! strncmp(s, str, n)) {
1481 if (strlen(s) == n) {
1482 tag = tmp;
1483 match = FULL;
1484 break;
1485 }
1486 else if (match == PARTIAL || match == PARTIAL2) {
1487 /* this match is partial and we already have a partial match,
1488 so the query is ambiguous and we will return R_NilValue
1489 unless a full match comes up.
1490 */
1491 match = PARTIAL2;
1492 } else {
1493 tag = tmp;
1494 match = PARTIAL;
1495 }
1496 }
1497 }
1498 if (match == PARTIAL2) {
1499 UNPROTECT(1);
1500 return R_NilValue;
1501 }
1502
1503 /* Unless a full match has been found, check for a "names" attribute.
1504 This is stored via TAGs on pairlists, and via rownames on 1D arrays.
1505 */
1506 if (match != FULL && strncmp("names", str, n) == 0) {
1507 if (strlen("names") == n) {
1508 /* we have a full match on "names", if there is such an
1509 attribute */
1510 tag = R_NamesSymbol;
1511 match = FULL;
1512 }
1513 else if (match == NONE && !exact) {
1514 /* no match on other attributes and a possible
1515 partial match on "names" */
1516 tag = R_NamesSymbol;
1517 PROTECT(t = getAttrib(s, tag));
1518 if(t != R_NilValue && R_warn_partial_match_attr)
1519 warningcall(call, _("partial match of '%s' to '%s'"), str,
1520 CHAR(PRINTNAME(tag)));
1521 UNPROTECT(2);
1522 return t;
1523 }
1524 else if (match == PARTIAL && strcmp(CHAR(PRINTNAME(tag)), "names")) {
1525 /* There is a possible partial match on "names" and on another
1526 attribute. If there really is a "names" attribute, then the
1527 query is ambiguous and we return R_NilValue. If there is no
1528 "names" attribute, then the partially matched one, which is
1529 the current value of tag, can be used. */
1530 if (getAttrib(s, R_NamesSymbol) != R_NilValue) {
1531 UNPROTECT(1);
1532 return R_NilValue;
1533 }
1534 }
1535 }
1536
1537 if (match == NONE || (exact && match != FULL)) {
1538 UNPROTECT(1);
1539 return R_NilValue;
1540 }
1541 if (match == PARTIAL && R_warn_partial_match_attr)
1542 warningcall(call, _("partial match of '%s' to '%s'"), str,
1543 CHAR(PRINTNAME(tag)));
1544
1545 ans = getAttrib(s, tag);
1546 UNPROTECT(1);
1547 return ans;
1548 }
1549
check_slot_assign(SEXP obj,SEXP input,SEXP value,SEXP env)1550 static void check_slot_assign(SEXP obj, SEXP input, SEXP value, SEXP env)
1551 {
1552 SEXP
1553 valueClass = PROTECT(R_data_class(value, FALSE)),
1554 objClass = PROTECT(R_data_class(obj, FALSE));
1555 static SEXP checkAt = NULL;
1556 // 'methods' may *not* be in search() ==> do as if calling methods::checkAtAssignment(..)
1557 if(!isMethodsDispatchOn()) { // needed?
1558 SEXP e = PROTECT(lang1(install("initMethodDispatch")));
1559 eval(e, R_MethodsNamespace); // only works with methods loaded
1560 UNPROTECT(1);
1561 }
1562 if(checkAt == NULL)
1563 checkAt = findFun(install("checkAtAssignment"), R_MethodsNamespace);
1564 SEXP e = PROTECT(lang4(checkAt, objClass, input, valueClass));
1565 eval(e, env);
1566 UNPROTECT(3);
1567 }
1568
1569
1570 /* attr(obj, which = "<name>") <- value (op == 0) and
1571 obj @ <name> <- value (op == 1)
1572 */
do_attrgets(SEXP call,SEXP op,SEXP args,SEXP env)1573 SEXP attribute_hidden do_attrgets(SEXP call, SEXP op, SEXP args, SEXP env)
1574 {
1575 SEXP obj;
1576 checkArity(op, args);
1577
1578 if(PRIMVAL(op)) { /* @<- */
1579 SEXP input, nlist, ans, value;
1580 PROTECT(input = allocVector(STRSXP, 1));
1581
1582 nlist = CADR(args);
1583 if (isSymbol(nlist))
1584 SET_STRING_ELT(input, 0, PRINTNAME(nlist));
1585 else if(isString(nlist) )
1586 SET_STRING_ELT(input, 0, STRING_ELT(nlist, 0));
1587 else {
1588 error(_("invalid type '%s' for slot name"),
1589 type2char(TYPEOF(nlist)));
1590 return R_NilValue; /*-Wall*/
1591 }
1592
1593 /* replace the second argument with a string */
1594 SETCADR(args, input);
1595 UNPROTECT(1); // 'input' is now protected
1596
1597 /* DispatchOrEval internal generic: @<- */
1598 if(DispatchOrEval(call, op, "@<-", args, env, &ans, 0, 0))
1599 return(ans);
1600
1601 PROTECT(value = CADDR(ans));
1602 obj = CAR(ans);
1603 if (MAYBE_SHARED(obj) ||
1604 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(obj)))
1605 PROTECT(obj = shallow_duplicate(obj));
1606 else
1607 PROTECT(obj);
1608 check_slot_assign(obj, input, value, env);
1609 obj = R_do_slot_assign(obj, input, value);
1610 UNPROTECT(2);
1611 SETTER_CLEAR_NAMED(obj);
1612 return obj;
1613 }
1614 else { // attr(obj, "name") <- value :
1615 SEXP argList;
1616 static SEXP do_attrgets_formals = NULL;
1617
1618 obj = CAR(args);
1619 if (MAYBE_SHARED(obj) ||
1620 ((! IS_ASSIGNMENT_CALL(call)) && MAYBE_REFERENCED(obj)))
1621 PROTECT(obj = shallow_duplicate(obj));
1622 else
1623 PROTECT(obj);
1624
1625 /* argument matching */
1626 if (do_attrgets_formals == NULL)
1627 do_attrgets_formals = allocFormalsList3(install("x"), install("which"),
1628 install("value"));
1629 argList = matchArgs_NR(do_attrgets_formals, args, call);
1630 PROTECT(argList);
1631
1632 SEXP name = CADR(argList);
1633 SEXP val = CADDR(argList);
1634 if (!isValidString(name) || STRING_ELT(name, 0) == NA_STRING)
1635 error(_("'name' must be non-null character string"));
1636 /* TODO? if (isFactor(obj) && !strcmp(asChar(name), "levels"))
1637 * --- if(any_duplicated(val))
1638 * error(.....)
1639 */
1640 setAttrib(obj, name, val);
1641 UNPROTECT(2);
1642 SETTER_CLEAR_NAMED(obj);
1643 return obj;
1644 }
1645 }
1646
1647
1648 /* These provide useful shortcuts which give access to */
1649 /* the dimnames for matrices and arrays in a standard form. */
1650
1651 /* NB: this may return R_alloc-ed rn and dn */
GetMatrixDimnames(SEXP x,SEXP * rl,SEXP * cl,const char ** rn,const char ** cn)1652 void GetMatrixDimnames(SEXP x, SEXP *rl, SEXP *cl,
1653 const char **rn, const char **cn)
1654 {
1655 SEXP dimnames = getAttrib(x, R_DimNamesSymbol);
1656 SEXP nn;
1657
1658 if (isNull(dimnames)) {
1659 *rl = R_NilValue;
1660 *cl = R_NilValue;
1661 *rn = NULL;
1662 *cn = NULL;
1663 }
1664 else {
1665 *rl = VECTOR_ELT(dimnames, 0);
1666 *cl = VECTOR_ELT(dimnames, 1);
1667 nn = getAttrib(dimnames, R_NamesSymbol);
1668 if (isNull(nn)) {
1669 *rn = NULL;
1670 *cn = NULL;
1671 }
1672 else {
1673 *rn = translateChar(STRING_ELT(nn, 0));
1674 *cn = translateChar(STRING_ELT(nn, 1));
1675 }
1676 }
1677 }
1678
1679
GetArrayDimnames(SEXP x)1680 SEXP GetArrayDimnames(SEXP x)
1681 {
1682 return getAttrib(x, R_DimNamesSymbol);
1683 }
1684
1685
1686 /* the code to manage slots in formal classes. These are attributes,
1687 but without partial matching and enforcing legal slot names (it's
1688 an error to get a slot that doesn't exist. */
1689
1690
1691 static SEXP pseudo_NULL = 0;
1692
1693 static SEXP s_dot_Data;
1694 static SEXP s_getDataPart;
1695 static SEXP s_setDataPart;
1696
init_slot_handling(void)1697 static void init_slot_handling(void) {
1698 s_dot_Data = install(".Data");
1699 s_dot_S3Class = install(".S3Class");
1700 s_getDataPart = install("getDataPart");
1701 s_setDataPart = install("setDataPart");
1702 /* create and preserve an object that is NOT R_NilValue, and is used
1703 to represent slots that are NULL (which an attribute can not
1704 be). The point is not just to store NULL as a slot, but also to
1705 provide a check on invalid slot names (see get_slot below).
1706
1707 The object has to be a symbol if we're going to check identity by
1708 just looking at referential equality. */
1709 pseudo_NULL = install("\001NULL\001");
1710 }
1711
data_part(SEXP obj)1712 static SEXP data_part(SEXP obj) {
1713 SEXP e, val;
1714 if(!s_getDataPart)
1715 init_slot_handling();
1716 PROTECT(e = allocVector(LANGSXP, 3));
1717 SETCAR(e, s_getDataPart);
1718 val = CDR(e);
1719 SETCAR(val, obj);
1720 SETCADR(val, ScalarLogical(TRUE));
1721 val = eval(e, R_MethodsNamespace);
1722 UNSET_S4_OBJECT(val); /* data part must be base vector */
1723 UNPROTECT(1);
1724 return(val);
1725 }
1726
set_data_part(SEXP obj,SEXP rhs)1727 static SEXP set_data_part(SEXP obj, SEXP rhs) {
1728 SEXP e, val;
1729 if(!s_setDataPart)
1730 init_slot_handling();
1731 PROTECT(e = allocVector(LANGSXP, 3));
1732 SETCAR(e, s_setDataPart);
1733 val = CDR(e);
1734 SETCAR(val, obj);
1735 val = CDR(val);
1736 SETCAR(val, rhs);
1737 val = eval(e, R_MethodsNamespace);
1738 SET_S4_OBJECT(val);
1739 UNPROTECT(1);
1740 return(val);
1741 }
1742
S3Class(SEXP obj)1743 SEXP S3Class(SEXP obj)
1744 {
1745 if(!s_dot_S3Class) init_slot_handling();
1746 return getAttrib(obj, s_dot_S3Class);
1747 }
1748
1749 /* Slots are stored as attributes to
1750 provide some back-compatibility
1751 */
1752
1753 /**
1754 * R_has_slot() : a C-level test if a obj@<name> is available;
1755 * as R_do_slot() gives an error when there's no such slot.
1756 */
R_has_slot(SEXP obj,SEXP name)1757 int R_has_slot(SEXP obj, SEXP name) {
1758
1759 #define R_SLOT_INIT \
1760 if(!(isSymbol(name) || (isString(name) && LENGTH(name) == 1))) \
1761 error(_("invalid type or length for slot name")); \
1762 if(!s_dot_Data) \
1763 init_slot_handling(); \
1764 if(isString(name)) name = installTrChar(STRING_ELT(name, 0))
1765
1766 R_SLOT_INIT;
1767 if(name == s_dot_Data && TYPEOF(obj) != S4SXP)
1768 return(1);
1769 /* else */
1770 return(getAttrib(obj, name) != R_NilValue);
1771 }
1772
1773 /* the @ operator, and its assignment form. Processed much like $
1774 (see do_subset3) but without S3-style methods.
1775 */
1776 /* currently, R_get_slot() ["methods"] is a trivial wrapper for this: */
R_do_slot(SEXP obj,SEXP name)1777 SEXP R_do_slot(SEXP obj, SEXP name) {
1778 R_SLOT_INIT;
1779 if(name == s_dot_Data)
1780 return data_part(obj);
1781 else {
1782 SEXP value = getAttrib(obj, name);
1783 if(value == R_NilValue) {
1784 SEXP input = name, classString;
1785 if(name == s_dot_S3Class) /* defaults to class(obj) */
1786 return R_data_class(obj, FALSE);
1787 else if(name == R_NamesSymbol &&
1788 TYPEOF(obj) == VECSXP) /* needed for namedList class */
1789 return value;
1790 if(isSymbol(name) ) {
1791 input = PROTECT(ScalarString(PRINTNAME(name)));
1792 classString = getAttrib(obj, R_ClassSymbol);
1793 if(isNull(classString)) {
1794 UNPROTECT(1);
1795 error(_("cannot get a slot (\"%s\") from an object of type \"%s\""),
1796 translateChar(asChar(input)),
1797 CHAR(type2str(TYPEOF(obj))));
1798 }
1799 UNPROTECT(1);
1800 }
1801 else classString = R_NilValue; /* make sure it is initialized */
1802 /* not there. But since even NULL really does get stored, this
1803 implies that there is no slot of this name. Or somebody
1804 screwed up by using attr(..) <- NULL */
1805
1806 error(_("no slot of name \"%s\" for this object of class \"%s\""),
1807 translateChar(asChar(input)),
1808 translateChar(asChar(classString)));
1809 }
1810 else if(value == pseudo_NULL)
1811 value = R_NilValue;
1812 return value;
1813 }
1814 }
1815 #undef R_SLOT_INIT
1816
1817 /* currently, R_set_slot() ["methods"] is a trivial wrapper for this: */
R_do_slot_assign(SEXP obj,SEXP name,SEXP value)1818 SEXP R_do_slot_assign(SEXP obj, SEXP name, SEXP value) {
1819 #ifndef _R_ver_le_2_11_x_
1820 if (isNull(obj))/* cannot use !IS_S4_OBJECT(obj), because
1821 * slot(obj, name, check=FALSE) <- value must work on
1822 * "pre-objects", currently only in makePrototypeFromClassDef() */
1823 error(_("attempt to set slot on NULL object"));
1824 #endif
1825 PROTECT(obj); PROTECT(value);
1826 /* Ensure that name is a symbol */
1827 if(isString(name) && LENGTH(name) == 1)
1828 name = installTrChar(STRING_ELT(name, 0));
1829 else if(TYPEOF(name) == CHARSXP)
1830 name = installTrChar(name);
1831 if(!isSymbol(name) )
1832 error(_("invalid type or length for slot name"));
1833
1834 if(!s_dot_Data) /* initialize */
1835 init_slot_handling();
1836
1837 if(name == s_dot_Data) { /* special handling */
1838 obj = set_data_part(obj, value);
1839 } else {
1840 if(isNull(value)) /* Slots, but not attributes, can be NULL.*/
1841 value = pseudo_NULL; /* Store a special symbol instead. */
1842
1843 #ifdef _R_ver_le_2_11_x_
1844 setAttrib(obj, name, value);
1845 #else
1846 /* simplified version of setAttrib(obj, name, value);
1847 here we do *not* treat "names", "dimnames", "dim", .. specially : */
1848 installAttrib(obj, name, value);
1849 #endif
1850 }
1851 UNPROTECT(2);
1852 return obj;
1853 }
1854
do_AT(SEXP call,SEXP op,SEXP args,SEXP env)1855 SEXP attribute_hidden do_AT(SEXP call, SEXP op, SEXP args, SEXP env)
1856 {
1857 SEXP nlist, object, ans, klass;
1858
1859 checkArity(op, args);
1860 if(!isMethodsDispatchOn())
1861 error(_("formal classes cannot be used without the 'methods' package"));
1862 nlist = CADR(args);
1863 /* Do some checks here -- repeated in R_do_slot, but on repeat the
1864 * test expression should kick out on the first element. */
1865 if(!(isSymbol(nlist) || (isString(nlist) && LENGTH(nlist) == 1)))
1866 error(_("invalid type or length for slot name"));
1867 if(isString(nlist)) nlist = installTrChar(STRING_ELT(nlist, 0));
1868 PROTECT(object = eval(CAR(args), env));
1869 if(!s_dot_Data) init_slot_handling();
1870 if(nlist != s_dot_Data && !IS_S4_OBJECT(object)) {
1871 klass = getAttrib(object, R_ClassSymbol);
1872 if(length(klass) == 0)
1873 error(_("trying to get slot \"%s\" from an object of a basic class (\"%s\") with no slots"),
1874 CHAR(PRINTNAME(nlist)),
1875 CHAR(STRING_ELT(R_data_class(object, FALSE), 0)));
1876 else
1877 error(_("trying to get slot \"%s\" from an object (class \"%s\") that is not an S4 object "),
1878 CHAR(PRINTNAME(nlist)),
1879 translateChar(STRING_ELT(klass, 0)));
1880 }
1881
1882 ans = R_do_slot(object, nlist);
1883 UNPROTECT(1);
1884 return ans;
1885 }
1886
1887 /* Return a suitable S3 object (OK, the name of the routine comes from
1888 an earlier version and isn't quite accurate.) If there is a .S3Class
1889 slot convert to that S3 class.
1890 Otherwise, unless type == S4SXP, look for a .Data or .xData slot. The
1891 value of type controls what's wanted. If it is S4SXP, then ONLY
1892 .S3class is used. If it is ANYSXP, don't check except that automatic
1893 conversion from the current type only applies for classes that extend
1894 one of the basic types (i.e., not S4SXP). For all other types, the
1895 recovered data must match the type.
1896 Because S3 objects can't have type S4SXP, .S3Class slot is not searched
1897 for in that type object, unless ONLY that class is wanted.
1898 (Obviously, this is another routine that has accumulated barnacles and
1899 should at some time be broken into separate parts.)
1900 */
1901 SEXP attribute_hidden
R_getS4DataSlot(SEXP obj,SEXPTYPE type)1902 R_getS4DataSlot(SEXP obj, SEXPTYPE type)
1903 {
1904 static SEXP s_xData, s_dotData; SEXP value = R_NilValue;
1905 PROTECT_INDEX opi;
1906
1907 PROTECT_WITH_INDEX(obj, &opi);
1908 if(!s_xData) {
1909 s_xData = install(".xData");
1910 s_dotData = install(".Data");
1911 }
1912 if(TYPEOF(obj) != S4SXP || type == S4SXP) {
1913 SEXP s3class = S3Class(obj);
1914 if(s3class == R_NilValue && type == S4SXP) {
1915 UNPROTECT(1); /* obj */
1916 return R_NilValue;
1917 }
1918 PROTECT(s3class);
1919 if(MAYBE_REFERENCED(obj))
1920 REPROTECT(obj = shallow_duplicate(obj), opi);
1921 if(s3class != R_NilValue) {/* replace class with S3 class */
1922 setAttrib(obj, R_ClassSymbol, s3class);
1923 setAttrib(obj, s_dot_S3Class, R_NilValue); /* not in the S3 class */
1924 }
1925 else { /* to avoid inf. recursion, must unset class attribute */
1926 setAttrib(obj, R_ClassSymbol, R_NilValue);
1927 }
1928 UNPROTECT(1); /* s3class */
1929 UNSET_S4_OBJECT(obj);
1930 if(type == S4SXP) {
1931 UNPROTECT(1); /* obj */
1932 return obj;
1933 }
1934 value = obj;
1935 }
1936 else
1937 value = getAttrib(obj, s_dotData);
1938 if(value == R_NilValue)
1939 value = getAttrib(obj, s_xData);
1940
1941 UNPROTECT(1); /* obj */
1942 /* the mechanism for extending abnormal types. In the future, would b
1943 good to consolidate under the ".Data" slot, but this has
1944 been used to mean S4 objects with non-S4 type, so for now
1945 a secondary slot name, ".xData" is used to avoid confusion
1946 */
1947 if(value != R_NilValue &&
1948 (type == ANYSXP || type == TYPEOF(value)))
1949 return value;
1950 else
1951 return R_NilValue;
1952 }
1953