The R Project SVN R

Rev

Rev 90261 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
73472 luke 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
90309 luke 3 
 *  Copyright (C) 2016--2026   The R Core Team
73472 luke 4 
 *
5 
 *  This program is free software; you can redistribute it and/or modify
6 
 *  it under the terms of the GNU General Public License as published by
7 
 *  the Free Software Foundation; either version 2 of the License, or
8 
 *  (at your option) any later version.
9 
 *
10 
 *  This program is distributed in the hope that it will be useful,
11 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
12 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 
 *  GNU General Public License for more details.
14 
 *
15 
 *  You should have received a copy of the GNU General Public License
16 
 *  along with this program; if not, a copy is available at
17 
 *  https://www.R-project.org/Licenses/
18 
 */
19 
 
20 
#ifdef HAVE_CONFIG_H
21 
#include <config.h>
22 
#endif
23 
 
24 
#include <Defn.h>
25 
#include <R_ext/Altrep.h>
26 
#include <float.h> /* for DBL_DIG */
27 
#include <Print.h> /* for R_print */
28 
#include <R_ext/Itermacros.h>
29 
 
79188 luke 30 
#ifdef Win32
31 
#include <trioremap.h> /* for %lld */
32 
#endif
73472 luke 33 
 
79188 luke 34 
 
74934 luke 35 
/***
36 
 *** ALTREP Concrete Class Implementations
37 
 ***/
73472 luke 38 
 
39 
/**
40 
 ** Compact Integer Sequences
41 
 **/
42 
 
43 
/*
44 
 * Methods
45 
 */
46 
 
47 
#define COMPACT_SEQ_INFO(x) R_altrep_data1(x)
48 
#define COMPACT_SEQ_EXPANDED(x) R_altrep_data2(x)
49 
#define SET_COMPACT_SEQ_EXPANDED(x, v) R_set_altrep_data2(x, v)
50 
 
74332 luke 51 
/* needed for now for objects serialized with INTSXP state */
52 
#define COMPACT_INTSEQ_SERIALIZED_STATE_LENGTH(info) \
53 
    (TYPEOF(info) == INTSXP ? INTEGER0(info)[0] : (R_xlen_t) REAL0(info)[0])
54 
#define COMPACT_INTSEQ_SERIALIZED_STATE_FIRST(info) \
55 
    (TYPEOF(info) == INTSXP ? INTEGER0(info)[1] : (int) REAL0(info)[1])
56 
#define COMPACT_INTSEQ_SERIALIZED_STATE_INCR(info) \
57 
    (TYPEOF(info) == INTSXP ? INTEGER0(info)[2] : (int) REAL0(info)[2])
58 
 
59 
/* info is stored as REALSXP to allow for long vector length */
60 
#define COMPACT_INTSEQ_INFO_LENGTH(info) ((R_xlen_t) REAL0(info)[0])
61 
#define COMPACT_INTSEQ_INFO_FIRST(info) ((int) REAL0(info)[1])
62 
#define COMPACT_INTSEQ_INFO_INCR(info) ((int) REAL0(info)[2])
63 
 
73472 luke 64 
/* By default, compact integer sequences are marked as not mutable at
65 
   creation time. Thus even when expanded the expanded data will
66 
   correspond to the original integer sequence (unless it runs into
67 
   mis-behaving C code). If COMPACT_INTSEQ_MUTABLE is defined, then
68 
   the sequence is not marked as not mutable. Once the DATAPTR has
69 
   been requested and releases, the expanded data might be modified by
70 
   an assignment and no longer correspond to the original sequence. */
71 
//#define COMPACT_INTSEQ_MUTABLE
72 
 
73 
static SEXP compact_intseq_Serialized_state(SEXP x)
74 
{
75 
#ifdef COMPACT_INTSEQ_MUTABLE
76 
    /* This drops through to standard serialization for expanded
77 
       compact vectors */
78 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
79 
	return NULL;
80 
#endif
81 
    return COMPACT_SEQ_INFO(x);
82 
}
83 
 
84 
static SEXP new_compact_intseq(R_xlen_t, int, int);
85 
static SEXP new_compact_realseq(R_xlen_t, double, double);
86 
 
87 
static SEXP compact_intseq_Unserialize(SEXP class, SEXP state)
88 
{
74332 luke 89 
    R_xlen_t n = COMPACT_INTSEQ_SERIALIZED_STATE_LENGTH(state);
90 
    int n1 = COMPACT_INTSEQ_SERIALIZED_STATE_FIRST(state);
91 
    int inc = COMPACT_INTSEQ_SERIALIZED_STATE_INCR(state);
73472 luke 92 
 
93 
    if (inc == 1)
74332 luke 94 
	return new_compact_intseq(n, n1,  1);
73472 luke 95 
    else if (inc == -1)
74332 luke 96 
	return new_compact_intseq(n, n1,  -1);
73472 luke 97 
    else
98 
	error("compact sequences with increment %d not supported yet", inc);
99 
}
100 
 
101 
static SEXP compact_intseq_Coerce(SEXP x, int type)
102 
{
103 
#ifdef COMPACT_INTSEQ_MUTABLE
104 
    /* This drops through to standard coercion for expanded compact
105 
       vectors */
106 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
107 
	return NULL;
108 
#endif
109 
    if (type == REALSXP) {
110 
	SEXP info = COMPACT_SEQ_INFO(x);
111 
	R_xlen_t n = COMPACT_INTSEQ_INFO_LENGTH(info);
112 
	int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
113 
	int inc = COMPACT_INTSEQ_INFO_INCR(info);
114 
	return new_compact_realseq(n, n1, inc);
115 
    }
116 
    else return NULL;
117 
}
118 
 
119 
static SEXP compact_intseq_Duplicate(SEXP x, Rboolean deep)
120 
{
121 
    R_xlen_t n = XLENGTH(x);
122 
    SEXP val = allocVector(INTSXP, n);
123 
    INTEGER_GET_REGION(x, 0, n, INTEGER0(val));
124 
    return val;
125 
}
126 
 
127 
static
128 
Rboolean compact_intseq_Inspect(SEXP x, int pre, int deep, int pvec,
129 
				void (*inspect_subtree)(SEXP, int, int, int))
130 
{
131 
    int inc = COMPACT_INTSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
132 
    if (inc != 1 && inc != -1)
133 
	error("compact sequences with increment %d not supported yet", inc);
134 
 
135 
#ifdef COMPACT_INTSEQ_MUTABLE
136 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue) {
137 
	Rprintf("  <expanded compact integer sequence>\n");
138 
	inspect_subtree(COMPACT_SEQ_EXPANDED(x), pre, deep, pvec);
139 
	return TRUE;
140 
    }
141 
#endif
142 
 
79156 maechler 143 
    R_xlen_t n = XLENGTH(x); // int .. LENGTH(.) not ok, e.g. for -1e9:2e9
73472 luke 144 
    int n1 = INTEGER_ELT(x, 0);
79156 maechler 145 
    int n2 = (int) ((inc == 1) ? n1 + n - 1 : n1 - n + 1);
73472 luke 146 
    Rprintf(" %d : %d (%s)", n1, n2,
147 
	    COMPACT_SEQ_EXPANDED(x) == R_NilValue ? "compact" : "expanded");
148 
    Rprintf("\n");
149 
    return TRUE;
150 
}
151 
 
152 
static R_INLINE R_xlen_t compact_intseq_Length(SEXP x)
153 
{
154 
    SEXP info = COMPACT_SEQ_INFO(x);
155 
    return COMPACT_INTSEQ_INFO_LENGTH(info);
156 
}
157 
 
158 
static void *compact_intseq_Dataptr(SEXP x, Rboolean writeable)
159 
{
160 
    if (COMPACT_SEQ_EXPANDED(x) == R_NilValue) {
74224 luke 161 
	/* no need to re-run if expanded data exists */
73472 luke 162 
	PROTECT(x);
163 
	SEXP info = COMPACT_SEQ_INFO(x);
74332 luke 164 
	R_xlen_t n = COMPACT_INTSEQ_INFO_LENGTH(info);
73472 luke 165 
	int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
166 
	int inc = COMPACT_INTSEQ_INFO_INCR(info);
167 
	SEXP val = allocVector(INTSXP, n);
168 
	int *data = INTEGER(val);
169 
 
170 
	if (inc == 1) {
171 
	    /* compact sequences n1 : n2 with n1 <= n2 */
79169 kalibera 172 
	    for (R_xlen_t i = 0; i < n; i++)
79173 luke 173 
		data[i] = (int) (n1 + i);
73472 luke 174 
	}
175 
	else if (inc == -1) {
176 
	    /* compact sequences n1 : n2 with n1 > n2 */
79169 kalibera 177 
	    for (R_xlen_t i = 0; i < n; i++)
79173 luke 178 
		data[i] = (int) (n1 - i);
73472 luke 179 
	}
180 
	else
181 
	    error("compact sequences with increment %d not supported yet", inc);
182 
 
183 
	SET_COMPACT_SEQ_EXPANDED(x, val);
184 
	UNPROTECT(1);
185 
    }
89022 luke 186 
    return DATAPTR_RW(COMPACT_SEQ_EXPANDED(x));
73472 luke 187 
}
188 
 
73718 luke 189 
static const void *compact_intseq_Dataptr_or_null(SEXP x)
73472 luke 190 
{
191 
    SEXP val = COMPACT_SEQ_EXPANDED(x);
89022 luke 192 
    return val == R_NilValue ? NULL : DATAPTR_RO(val);
73472 luke 193 
}
194 
 
195 
static int compact_intseq_Elt(SEXP x, R_xlen_t i)
196 
{
74230 luke 197 
    SEXP ex = COMPACT_SEQ_EXPANDED(x);
198 
    if (ex != R_NilValue)
199 
	return INTEGER0(ex)[i];
200 
    else {
201 
	SEXP info = COMPACT_SEQ_INFO(x);
202 
	int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
203 
	int inc = COMPACT_INTSEQ_INFO_INCR(info);
74319 luke 204 
	return (int) (n1 + inc * i);
74230 luke 205 
    }
73472 luke 206 
}
207 
 
74934 luke 208 
#define CHECK_NOT_EXPANDED(x)					\
209 
    if (DATAPTR_OR_NULL(x) != NULL)				\
210 
	error("method should only handle unexpanded vectors")
211 
 
73472 luke 212 
static R_xlen_t
213 
compact_intseq_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
214 
{
215 
    /* should not get here if x is already expanded */
216 
    CHECK_NOT_EXPANDED(sx);
217 
 
218 
    SEXP info = COMPACT_SEQ_INFO(sx);
219 
    R_xlen_t size = COMPACT_INTSEQ_INFO_LENGTH(info);
220 
    R_xlen_t n1 = COMPACT_INTSEQ_INFO_FIRST(info);
221 
    int inc = COMPACT_INTSEQ_INFO_INCR(info);
222 
 
223 
    R_xlen_t ncopy = size - i > n ? n : size - i;
224 
    if (inc == 1) {
225 
	for (R_xlen_t k = 0; k < ncopy; k++)
226 
	    buf[k] = (int) (n1 + k + i);
227 
	return ncopy;
228 
    }
229 
    else if (inc == -1) {
230 
	for (R_xlen_t k = 0; k < ncopy; k++)
231 
	    buf[k] = (int) (n1 - k - i);
232 
	return ncopy;
233 
    }
234 
    else
235 
	error("compact sequences with increment %d not supported yet", inc);
236 
}
237 
 
238 
static int compact_intseq_Is_sorted(SEXP x)
239 
{
240 
#ifdef COMPACT_INTSEQ_MUTABLE
241 
    /* If the vector has been expanded it may have been modified. */
242 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
74230 luke 243 
	return UNKNOWN_SORTEDNESS;
73472 luke 244 
#endif
245 
    int inc = COMPACT_INTSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
74405 luke 246 
    return inc < 0 ? SORTED_DECR : SORTED_INCR;
73472 luke 247 
}
248 
 
249 
static int compact_intseq_No_NA(SEXP x)
250 
{
251 
#ifdef COMPACT_INTSEQ_MUTABLE
252 
    /* If the vector has been expanded it may have been modified. */
253 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
254 
	return FALSE;
255 
#endif
256 
    return TRUE;
257 
}
258 
 
74224 luke 259 
/* XXX this also appears in summary.c. move to header file?*/
260 
#define R_INT_MIN (1 + INT_MIN)
73472 luke 261 
 
74224 luke 262 
static SEXP compact_intseq_Sum(SEXP x, Rboolean narm)
263 
{
264 
#ifdef COMPACT_INTSEQ_MUTABLE
265 
    /* If the vector has been expanded it may have been modified. */
266 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
267 
	return NULL;
268 
#endif
269 
    double tmp;
270 
    SEXP info = COMPACT_SEQ_INFO(x);
271 
    R_xlen_t size = COMPACT_INTSEQ_INFO_LENGTH(info);
272 
    R_xlen_t n1 = COMPACT_INTSEQ_INFO_FIRST(info);
273 
    int inc = COMPACT_INTSEQ_INFO_INCR(info);
274 
    tmp = (size / 2.0) * (n1 + n1 + inc * (size - 1));
275 
    if(tmp > INT_MAX || tmp < R_INT_MIN)
276 
	/**** check for overflow of exact integer range? */
277 
	return ScalarReal(tmp);
278 
    else
279 
	return ScalarInteger((int) tmp);
280 
}
281 
 
282 
 
73472 luke 283 
/*
284 
 * Class Objects and Method Tables
285 
 */
286 
 
287 
R_altrep_class_t R_compact_intseq_class;
288 
 
82931 ripley 289 
static void InitCompactIntegerClass(void)
73472 luke 290 
{
291 
    R_altrep_class_t cls = R_make_altinteger_class("compact_intseq", "base",
292 
						   NULL);
293 
    R_compact_intseq_class = cls;
294 
 
295 
    /* override ALTREP methods */
296 
    R_set_altrep_Unserialize_method(cls, compact_intseq_Unserialize);
297 
    R_set_altrep_Serialized_state_method(cls, compact_intseq_Serialized_state);
298 
    R_set_altrep_Duplicate_method(cls, compact_intseq_Duplicate);
299 
    R_set_altrep_Coerce_method(cls, compact_intseq_Coerce);
300 
    R_set_altrep_Inspect_method(cls, compact_intseq_Inspect);
301 
    R_set_altrep_Length_method(cls, compact_intseq_Length);
302 
 
303 
    /* override ALTVEC methods */
304 
    R_set_altvec_Dataptr_method(cls, compact_intseq_Dataptr);
305 
    R_set_altvec_Dataptr_or_null_method(cls, compact_intseq_Dataptr_or_null);
306 
 
307 
    /* override ALTINTEGER methods */
308 
    R_set_altinteger_Elt_method(cls, compact_intseq_Elt);
309 
    R_set_altinteger_Get_region_method(cls, compact_intseq_Get_region);
310 
    R_set_altinteger_Is_sorted_method(cls, compact_intseq_Is_sorted);
311 
    R_set_altinteger_No_NA_method(cls, compact_intseq_No_NA);
74224 luke 312 
    R_set_altinteger_Sum_method(cls, compact_intseq_Sum);
73472 luke 313 
}
314 
 
315 
 
316 
/*
317 
 * Constructor
318 
 */
319 
 
320 
static SEXP new_compact_intseq(R_xlen_t n, int n1, int inc)
321 
{
322 
    if (n == 1) return ScalarInteger(n1);
323 
 
324 
    if (inc != 1 && inc != -1)
325 
	error("compact sequences with increment %d not supported yet", inc);
326 
 
74332 luke 327 
    /* info used REALSXP to allow for long vectors */
328 
    SEXP info = allocVector(REALSXP, 3);
329 
    REAL0(info)[0] = (double) n;
330 
    REAL0(info)[1] = (double) n1;
331 
    REAL0(info)[2] = (double) inc;
73472 luke 332 
 
333 
    SEXP ans = R_new_altrep(R_compact_intseq_class, info, R_NilValue);
334 
#ifndef COMPACT_INTSEQ_MUTABLE
335 
    MARK_NOT_MUTABLE(ans); /* force duplicate on modify */
336 
#endif
337 
 
338 
    return ans;
339 
}
340 
 
89199 luke 341 
attribute_hidden Rboolean R_is_compact_intseq(SEXP x)
342 
{
343 
    return R_altrep_inherits(x, R_compact_intseq_class);
344 
}
73472 luke 345 
 
89199 luke 346 
 
73472 luke 347 
/**
348 
 ** Compact Real Sequences
349 
 **/
350 
 
351 
/*
352 
 * Methods
353 
 */
354 
 
74333 luke 355 
#define COMPACT_REALSEQ_INFO_LENGTH(info) ((R_xlen_t) REAL0(info)[0])
73472 luke 356 
#define COMPACT_REALSEQ_INFO_FIRST(info) REAL0(info)[1]
357 
#define COMPACT_REALSEQ_INFO_INCR(info) REAL0(info)[2]
358 
 
359 
static SEXP compact_realseq_Serialized_state(SEXP x)
360 
{
361 
    return COMPACT_SEQ_INFO(x);
362 
}
363 
 
364 
static SEXP compact_realseq_Unserialize(SEXP class, SEXP state)
365 
{
366 
    double inc = COMPACT_REALSEQ_INFO_INCR(state);
74333 luke 367 
    R_xlen_t len = COMPACT_REALSEQ_INFO_LENGTH(state);
368 
    double n1 = COMPACT_REALSEQ_INFO_FIRST(state);
73472 luke 369 
 
370 
    if (inc == 1)
371 
	return new_compact_realseq(len, n1,  1);
372 
    else if (inc == -1)
373 
	return new_compact_realseq(len, n1, -1);
374 
    else
375 
	error("compact sequences with increment %f not supported yet", inc);
376 
}
377 
 
378 
static SEXP compact_realseq_Duplicate(SEXP x, Rboolean deep)
379 
{
380 
    R_xlen_t n = XLENGTH(x);
381 
    SEXP val = allocVector(REALSXP, n);
382 
    REAL_GET_REGION(x, 0, n, REAL0(val));
383 
    return val;
384 
}
385 
 
386 
static
387 
Rboolean compact_realseq_Inspect(SEXP x, int pre, int deep, int pvec,
388 
				 void (*inspect_subtree)(SEXP, int, int, int))
389 
{
390 
    double inc = COMPACT_REALSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
391 
    if (inc != 1 && inc != -1)
392 
	error("compact sequences with increment %f not supported yet", inc);
393 
 
394 
    R_xlen_t n = XLENGTH(x);
395 
    R_xlen_t n1 = (R_xlen_t) REAL_ELT(x, 0);
396 
    R_xlen_t n2 = inc == 1 ? n1 + n - 1 : n1 - n + 1;
85576 kalibera 397 
    Rprintf(" %lld : %lld (%s)", (long long)n1, (long long)n2,
73472 luke 398 
	    COMPACT_SEQ_EXPANDED(x) == R_NilValue ? "compact" : "expanded");
399 
    Rprintf("\n");
400 
    return TRUE;
401 
}
402 
 
403 
static R_INLINE R_xlen_t compact_realseq_Length(SEXP x)
404 
{
405 
    return (R_xlen_t) REAL0(COMPACT_SEQ_INFO(x))[0];
406 
}
407 
 
408 
static void *compact_realseq_Dataptr(SEXP x, Rboolean writeable)
409 
{
410 
    if (COMPACT_SEQ_EXPANDED(x) == R_NilValue) {
411 
	PROTECT(x);
412 
	SEXP info = COMPACT_SEQ_INFO(x);
74333 luke 413 
	R_xlen_t n = COMPACT_REALSEQ_INFO_LENGTH(info);
73472 luke 414 
	double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
415 
	double inc = COMPACT_REALSEQ_INFO_INCR(info);
416 
 
417 
	SEXP val = allocVector(REALSXP, (R_xlen_t) n);
418 
	double *data = REAL(val);
419 
 
420 
	if (inc == 1) {
421 
	    /* compact sequences n1 : n2 with n1 <= n2 */
422 
	    for (R_xlen_t i = 0; i < n; i++)
423 
		data[i] = n1 + i;
424 
	}
425 
	else if (inc == -1) {
426 
	    /* compact sequences n1 : n2 with n1 > n2 */
427 
	    for (R_xlen_t i = 0; i < n; i++)
428 
		data[i] = n1 - i;
429 
	}
430 
	else
431 
	    error("compact sequences with increment %f not supported yet", inc);
432 
 
433 
	SET_COMPACT_SEQ_EXPANDED(x, val);
434 
	UNPROTECT(1);
435 
    }
89022 luke 436 
    return DATAPTR_RW(COMPACT_SEQ_EXPANDED(x));
73472 luke 437 
}
438 
 
73718 luke 439 
static const void *compact_realseq_Dataptr_or_null(SEXP x)
73472 luke 440 
{
441 
    SEXP val = COMPACT_SEQ_EXPANDED(x);
89022 luke 442 
    return val == R_NilValue ? NULL : DATAPTR_RO(val);
73472 luke 443 
}
444 
 
445 
static double compact_realseq_Elt(SEXP x, R_xlen_t i)
446 
{
74230 luke 447 
    SEXP ex = COMPACT_SEQ_EXPANDED(x);
448 
    if (ex != R_NilValue)
449 
	return REAL0(ex)[i];
450 
    else {
451 
	SEXP info = COMPACT_SEQ_INFO(x);
452 
	double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
453 
	double inc = COMPACT_REALSEQ_INFO_INCR(info);
454 
	return n1 + inc * i;
455 
    }
73472 luke 456 
}
457 
 
458 
static R_xlen_t
459 
compact_realseq_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
460 
{
461 
    /* should not get here if x is already expanded */
462 
    CHECK_NOT_EXPANDED(sx);
463 
 
464 
    SEXP info = COMPACT_SEQ_INFO(sx);
74333 luke 465 
    R_xlen_t size = COMPACT_REALSEQ_INFO_LENGTH(info);
73472 luke 466 
    double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
467 
    double inc = COMPACT_REALSEQ_INFO_INCR(info);
468 
 
469 
    R_xlen_t ncopy = size - i > n ? n : size - i;
470 
    if (inc == 1) {
471 
	for (R_xlen_t k = 0; k < ncopy; k++)
472 
	    buf[k] = n1 + k + i;
473 
	return ncopy;
474 
    }
475 
    else if (inc == -1) {
476 
	for (R_xlen_t k = 0; k < ncopy; k++)
477 
	    buf[k] = n1 - k - i;
478 
	return ncopy;
479 
    }
480 
    else
481 
	error("compact sequences with increment %f not supported yet", inc);
482 
}
483 
 
484 
static int compact_realseq_Is_sorted(SEXP x)
485 
{
486 
#ifdef COMPACT_REALSEQ_MUTABLE
487 
    /* If the vector has been expanded it may have been modified. */
488 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
74230 luke 489 
	return UNKNOWN_SORTEDNESS;
73472 luke 490 
#endif
491 
    double inc = COMPACT_REALSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
74405 luke 492 
    return inc < 0 ? SORTED_DECR : SORTED_INCR;
73472 luke 493 
}
494 
 
495 
static int compact_realseq_No_NA(SEXP x)
496 
{
497 
#ifdef COMPACT_REALSEQ_MUTABLE
498 
    /* If the vector has been expanded it may have been modified. */
499 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
500 
	return FALSE;
501 
#endif
502 
    return TRUE;
503 
}
504 
 
74224 luke 505 
static SEXP compact_realseq_Sum(SEXP x, Rboolean narm)
506 
{
507 
#ifdef COMPACT_INTSEQ_MUTABLE
508 
    /* If the vector has been expanded it may have been modified. */
509 
    if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
510 
	return NULL;
511 
#endif
512 
    SEXP info = COMPACT_SEQ_INFO(x);
74333 luke 513 
    double size = (double) COMPACT_REALSEQ_INFO_LENGTH(info);
74224 luke 514 
    double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
515 
    double inc = COMPACT_REALSEQ_INFO_INCR(info);
516 
    return ScalarReal((size / 2.0) *(n1 + n1 + inc * (size - 1)));
517 
}
73472 luke 518 
 
74224 luke 519 
 
73472 luke 520 
/*
521 
 * Class Objects and Method Tables
522 
 */
523 
 
524 
 
525 
R_altrep_class_t R_compact_realseq_class;
526 
 
82931 ripley 527 
static void InitCompactRealClass(void)
73472 luke 528 
{
529 
    R_altrep_class_t cls = R_make_altreal_class("compact_realseq", "base",
530 
						NULL);
531 
    R_compact_realseq_class = cls;
532 
 
533 
    /* override ALTREP methods */
534 
    R_set_altrep_Unserialize_method(cls, compact_realseq_Unserialize);
535 
    R_set_altrep_Serialized_state_method(cls, compact_realseq_Serialized_state);
536 
    R_set_altrep_Duplicate_method(cls, compact_realseq_Duplicate);
537 
    R_set_altrep_Inspect_method(cls, compact_realseq_Inspect);
538 
    R_set_altrep_Length_method(cls, compact_realseq_Length);
539 
 
540 
    /* override ALTVEC methods */
541 
    R_set_altvec_Dataptr_method(cls, compact_realseq_Dataptr);
542 
    R_set_altvec_Dataptr_or_null_method(cls, compact_realseq_Dataptr_or_null);
543 
 
544 
    /* override ALTREAL methods */
545 
    R_set_altreal_Elt_method(cls, compact_realseq_Elt);
546 
    R_set_altreal_Get_region_method(cls, compact_realseq_Get_region);
547 
    R_set_altreal_Is_sorted_method(cls, compact_realseq_Is_sorted);
548 
    R_set_altreal_No_NA_method(cls, compact_realseq_No_NA);
74224 luke 549 
    R_set_altreal_Sum_method(cls, compact_realseq_Sum);
73472 luke 550 
}
551 
 
552 
 
553 
/*
554 
 * Constructor
555 
 */
556 
 
557 
static SEXP new_compact_realseq(R_xlen_t n, double n1, double inc)
558 
{
559 
    if (n == 1) return ScalarReal(n1);
560 
 
561 
    if (inc != 1 && inc != -1)
562 
	error("compact sequences with increment %f not supported yet", inc);
563 
 
564 
    SEXP info = allocVector(REALSXP, 3);
565 
    REAL(info)[0] = n;
566 
    REAL(info)[1] = n1;
567 
    REAL(info)[2] = inc;
568 
 
569 
    SEXP ans = R_new_altrep(R_compact_realseq_class, info, R_NilValue);
570 
    MARK_NOT_MUTABLE(ans); /* force duplicate on modify */
571 
 
572 
    return ans;
573 
}
574 
 
575 
 
576 
/**
577 
 ** Compact Integer/Real Sequences
578 
 **/
579 
 
83446 ripley 580 
attribute_hidden SEXP R_compact_intrange(R_xlen_t n1, R_xlen_t n2)
73472 luke 581 
{
582 
    R_xlen_t n = n1 <= n2 ? n2 - n1 + 1 : n1 - n2 + 1;
583 
 
74888 luke 584 
    if (n >= R_XLEN_T_MAX)
585 
	error("result would be too long a vector");
586 
 
73472 luke 587 
    if (n1 <= INT_MIN || n1 > INT_MAX || n2 <= INT_MIN || n2 > INT_MAX)
588 
	return new_compact_realseq(n, n1, n1 <= n2 ? 1 : -1);
589 
    else
590 
	return new_compact_intseq(n, (int) n1, n1 <= n2 ? 1 : -1);
591 
}
592 
 
593 
 
594 
/**
595 
 ** Deferred String Coercions
596 
 **/
597 
 
598 
/*
599 
 * Methods
600 
 */
601 
 
602 
#define DEFERRED_STRING_STATE(x) R_altrep_data1(x)
603 
#define	CLEAR_DEFERRED_STRING_STATE(x) R_set_altrep_data1(x, R_NilValue)
604 
#define DEFERRED_STRING_EXPANDED(x) R_altrep_data2(x)
605 
#define SET_DEFERRED_STRING_EXPANDED(x, v) R_set_altrep_data2(x, v)
606 
 
607 
#define MAKE_DEFERRED_STRING_STATE(v, sp) CONS(v, sp)
608 
#define DEFERRED_STRING_STATE_ARG(s) CAR(s)
75424 luke 609 
#define DEFERRED_STRING_STATE_INFO(s) CDR(s)
73472 luke 610 
 
611 
#define DEFERRED_STRING_ARG(x) \
612 
    DEFERRED_STRING_STATE_ARG(DEFERRED_STRING_STATE(x))
75424 luke 613 
#define DEFERRED_STRING_INFO(x) \
614 
    DEFERRED_STRING_STATE_INFO(DEFERRED_STRING_STATE(x))
73472 luke 615 
#define DEFERRED_STRING_SCIPEN(x) \
75424 luke 616 
    INTEGER0(DEFERRED_STRING_STATE_INFO(DEFERRED_STRING_STATE(x)))[0]
73472 luke 617 
 
76852 luke 618 
/* work-around for package code that mutates things it shouldn't and
619 
   makes serialize and inspect infinite-loop */
620 
#define DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state) do {			\
621 
	if (state != R_NilValue && ATTRIB(CAR(state)) != R_NilValue) {	\
622 
	    SETCAR(state, shallow_duplicate(CAR(state)));		\
623 
	    SET_ATTRIB(CAR(state), R_NilValue);				\
624 
	}								\
625 
    } while (0)
626 
 
75424 luke 627 
static SEXP R_OutDecSym = NULL;
628 
 
629 
static R_INLINE const char *DEFERRED_STRING_OUTDEC(SEXP x)
630 
{
631 
    /* The default value of OutDec at startup is ".". If it is
632 
       something different at the time the deferred string conversion
633 
       is created then the current value is stored as an attribute. */
634 
    if (R_OutDecSym == NULL)
635 
	R_OutDecSym = install("OutDec");
636 
    SEXP info = DEFERRED_STRING_INFO(x);
637 
    if (ATTRIB(info) != R_NilValue) {
638 
	SEXP outdecattr = getAttrib(info, R_OutDecSym);
639 
	if (TYPEOF(outdecattr) == STRSXP && XLENGTH(outdecattr) == 1)
640 
	    return CHAR(STRING_ELT(outdecattr, 0));
641 
    }
642 
    return ".";
643 
}
644 
 
73472 luke 645 
static SEXP deferred_string_Serialized_state(SEXP x)
646 
{
647 
    /* This drops through to standard serialization for fully expanded
648 
       deferred string conversions. Partial expansions are OK since
649 
       they still correspond to the original data. An assignment to
650 
       the object will access the DATAPTR and force a full expansion
651 
       and dropping the original data. */
652 
    SEXP state = DEFERRED_STRING_STATE(x);
76852 luke 653 
    DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state);
73472 luke 654 
    return state != R_NilValue ? state : NULL;
655 
}
656 
 
657 
static SEXP deferred_string_Unserialize(SEXP class, SEXP state)
658 
{
659 
    SEXP arg = DEFERRED_STRING_STATE_ARG(state);
75424 luke 660 
    SEXP info = DEFERRED_STRING_STATE_INFO(state);
661 
    return R_deferred_coerceToString(arg, info);
73472 luke 662 
}
663 
 
664 
static
665 
Rboolean deferred_string_Inspect(SEXP x, int pre, int deep, int pvec,
666 
				 void (*inspect_subtree)(SEXP, int, int, int))
667 
{
668 
    SEXP state = DEFERRED_STRING_STATE(x);
669 
    if (state != R_NilValue) {
76852 luke 670 
	DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state);
73472 luke 671 
	SEXP arg = DEFERRED_STRING_STATE_ARG(state);
672 
	Rprintf("  <deferred string conversion>\n");
673 
	inspect_subtree(arg, pre, deep, pvec);
674 
    }
675 
    else {
676 
	Rprintf("  <expanded string conversion>\n");
677 
	inspect_subtree(DEFERRED_STRING_EXPANDED(x), pre, deep, pvec);
678 
    }
679 
    return TRUE;
680 
}
681 
 
682 
static R_INLINE R_xlen_t deferred_string_Length(SEXP x)
683 
{
684 
    SEXP state = DEFERRED_STRING_STATE(x);
685 
    return state == R_NilValue ?
686 
	XLENGTH(DEFERRED_STRING_EXPANDED(x)) :
687 
	XLENGTH(DEFERRED_STRING_STATE_ARG(state));
688 
}
689 
 
690 
static R_INLINE SEXP ExpandDeferredStringElt(SEXP x, R_xlen_t i)
691 
{
692 
    /* make sure the STRSXP for the expanded string is allocated */
693 
    /* not yet expanded strings are NULL in the STRSXP */
694 
    SEXP val = DEFERRED_STRING_EXPANDED(x);
695 
    if (val == R_NilValue) {
696 
	R_xlen_t n = XLENGTH(x);
697 
	val = allocVector(STRSXP, n);
87180 kalibera 698 
	if (n)
699 
	    memset(STDVEC_DATAPTR(val), 0, n * sizeof(SEXP));
73472 luke 700 
	SET_DEFERRED_STRING_EXPANDED(x, val);
701 
    }
702 
 
703 
    SEXP elt = STRING_ELT(val, i);
704 
    if (elt == NULL) {
705 
	int warn; /* not used by the coercion functions */
706 
	int savedigits, savescipen;
707 
	SEXP data = DEFERRED_STRING_ARG(x);
708 
	switch(TYPEOF(data)) {
709 
	case INTSXP:
710 
	    elt = StringFromInteger(INTEGER_ELT(data, i), &warn);
711 
	    break;
712 
	case REALSXP:
713 
	    savedigits = R_print.digits;
714 
	    savescipen = R_print.scipen;
715 
	    R_print.digits = DBL_DIG;/* MAX precision */
75424 luke 716 
	    R_print.scipen = DEFERRED_STRING_SCIPEN(x);
717 
	    const char *myoutdec = DEFERRED_STRING_OUTDEC(x);
718 
	    if (strcmp(OutDec, myoutdec)) {
719 
		/* The current and saved OutDec values differ. The
720 
		   value to use is put in a static buffer and OutDec
721 
		   temporarily points to this buffer while
722 
		   StringFromReal is called and then reset. The buffer
723 
		   originally pointed to by OutDec cannot be used as
724 
		   it wil not be writable if the default "." has not
725 
		   been changed. */
726 
		static char buf[10];
727 
		strncpy(buf, myoutdec, sizeof buf);
75582 hornik 728 
		buf[sizeof(buf) - 1] = '\0';
75424 luke 729 
		char *savedOutDec = OutDec;
730 
		OutDec = buf;
731 
		elt = StringFromReal(REAL_ELT(data, i), &warn);
732 
		OutDec = savedOutDec;
733 
	    }
734 
	    else
735 
		elt = StringFromReal(REAL_ELT(data, i), &warn);
73472 luke 736 
	    R_print.digits = savedigits;
737 
	    R_print.scipen = savescipen;
738 
	    break;
739 
	default:
740 
	    error("unsupported type for deferred string coercion");
741 
	}
742 
	SET_STRING_ELT(val, i, elt);
743 
    }
744 
    return elt;
745 
}
746 
 
747 
static R_INLINE void expand_deferred_string(SEXP x)
748 
{
749 
    SEXP state = DEFERRED_STRING_STATE(x);
750 
    if (state != R_NilValue) {
751 
	/* expanded data may be incomplete until original data is removed */
752 
	PROTECT(x);
753 
	R_xlen_t n = XLENGTH(x), i;
754 
	if (n == 0)
755 
	    SET_DEFERRED_STRING_EXPANDED(x, allocVector(STRSXP, 0));
756 
	else
757 
	    for (i = 0; i < n; i++)
758 
		ExpandDeferredStringElt(x, i);
759 
	CLEAR_DEFERRED_STRING_STATE(x); /* allow arg to be reclaimed */
760 
	UNPROTECT(1);
761 
    }
762 
}
763 
 
764 
static void *deferred_string_Dataptr(SEXP x, Rboolean writeable)
765 
{
766 
    expand_deferred_string(x);
89022 luke 767 
    return DATAPTR_RW(DEFERRED_STRING_EXPANDED(x));
73472 luke 768 
}
769 
 
73718 luke 770 
static const void *deferred_string_Dataptr_or_null(SEXP x)
73472 luke 771 
{
772 
    SEXP state = DEFERRED_STRING_STATE(x);
89022 luke 773 
    return state != R_NilValue ? NULL : DATAPTR_RO(DEFERRED_STRING_EXPANDED(x));
73472 luke 774 
}
775 
 
776 
static SEXP deferred_string_Elt(SEXP x, R_xlen_t i)
777 
{
778 
    SEXP state = DEFERRED_STRING_STATE(x);
779 
    if (state == R_NilValue)
780 
	/* string is fully expanded */
781 
	return STRING_ELT(DEFERRED_STRING_EXPANDED(x), i);
782 
    else {
783 
	/* expand only the requested element */
784 
	PROTECT(x);
785 
	SEXP elt = ExpandDeferredStringElt(x, i);
786 
	UNPROTECT(1);
787 
	return elt;
788 
    }
789 
}
790 
 
791 
static void deferred_string_Set_elt(SEXP x, R_xlen_t i, SEXP v)
792 
{
793 
    expand_deferred_string(x);
794 
    SET_STRING_ELT(DEFERRED_STRING_EXPANDED(x), i, v);
795 
}
796 
 
797 
static int deferred_string_Is_sorted(SEXP x)
798 
{
75616 luke 799 
    /* same as the default method; sortedness of the numeric is not relevant  */
800 
    return UNKNOWN_SORTEDNESS;
73472 luke 801 
}
802 
 
803 
static int deferred_string_No_NA(SEXP x)
804 
{
805 
    SEXP state = DEFERRED_STRING_STATE(x);
806 
    if (state == R_NilValue)
807 
	/* string is fully expanded and may have been modified. */
808 
	return FALSE;
809 
    else {
810 
	/* defer to the argument */
811 
	SEXP arg = DEFERRED_STRING_STATE_ARG(state);
812 
	switch(TYPEOF(arg)) {
813 
	case INTSXP: return INTEGER_NO_NA(arg);
814 
	case REALSXP: return REAL_NO_NA(arg);
815 
	default: return FALSE;
816 
	}
817 
    }
818 
}
819 
 
820 
static SEXP deferred_string_Extract_subset(SEXP x, SEXP indx, SEXP call)
821 
{
822 
    SEXP result = NULL;
823 
 
824 
    if (! OBJECT(x) && ATTRIB(x) == R_NilValue &&
825 
	DEFERRED_STRING_STATE(x) != R_NilValue) {
826 
	/* For deferred string coercions, create a new conversion
827 
	   using the subset of the argument.  Could try to
828 
	   preserve/share coercions already done, if there are any. */
829 
	SEXP data = DEFERRED_STRING_ARG(x);
75424 luke 830 
	SEXP info = DEFERRED_STRING_INFO(x);
73472 luke 831 
	PROTECT(result = ExtractSubset(data, indx, call));
75424 luke 832 
	result = R_deferred_coerceToString(result, info);
73472 luke 833 
	UNPROTECT(1);
834 
	return result;
835 
    }
836 
 
837 
    return result;
838 
}
839 
 
840 
 
841 
/*
842 
 * Class Object and Method Table
843 
 */
844 
 
845 
static R_altrep_class_t R_deferred_string_class;
846 
 
82931 ripley 847 
static void InitDefferredStringClass(void)
73472 luke 848 
{
849 
    R_altrep_class_t cls = R_make_altstring_class("deferred_string", "base",
850 
						  NULL);
851 
    R_deferred_string_class = cls;
852 
 
853 
    /* override ALTREP methods */
854 
    R_set_altrep_Unserialize_method(cls, deferred_string_Unserialize);
855 
    R_set_altrep_Serialized_state_method(cls, deferred_string_Serialized_state);
856 
    R_set_altrep_Inspect_method(cls, deferred_string_Inspect);
857 
    R_set_altrep_Length_method(cls, deferred_string_Length);
858 
 
859 
    /* override ALTVEC methods */
860 
    R_set_altvec_Dataptr_method(cls, deferred_string_Dataptr);
861 
    R_set_altvec_Dataptr_or_null_method(cls, deferred_string_Dataptr_or_null);
862 
    R_set_altvec_Extract_subset_method(cls, deferred_string_Extract_subset);
863 
 
864 
    /* override ALTSTRING methods */
865 
    R_set_altstring_Elt_method(cls, deferred_string_Elt);
866 
    R_set_altstring_Set_elt_method(cls, deferred_string_Set_elt);
867 
    R_set_altstring_Is_sorted_method(cls, deferred_string_Is_sorted);
868 
    R_set_altstring_No_NA_method(cls, deferred_string_No_NA);
869 
}
870 
 
871 
 
872 
/*
873 
 * Constructor
874 
 */
875 
 
83446 ripley 876 
attribute_hidden SEXP R_deferred_coerceToString(SEXP v, SEXP info)
73472 luke 877 
{
878 
    SEXP ans = R_NilValue;
879 
    switch (TYPEOF(v)) {
880 
    case INTSXP:
881 
    case REALSXP:
74748 luke 882 
	PROTECT(v); /* may not be needed, but to be safe ... */
75424 luke 883 
	if (info == NULL) {
74748 luke 884 
	    PrintDefaults(); /* to set R_print from options */
75424 luke 885 
	    info = ScalarInteger(R_print.scipen);
886 
	    if (strcmp(OutDec, ".")) {
887 
		/* non-default OutDec setting -- attach as an attribute */
888 
		PROTECT(info);
889 
		if (R_OutDecSym == NULL)
890 
		    R_OutDecSym = install("OutDec");
891 
		setAttrib(info, R_OutDecSym, GetOption1(R_OutDecSym));
892 
		UNPROTECT(1); /* info */
893 
	    }
74748 luke 894 
	}
73472 luke 895 
	MARK_NOT_MUTABLE(v); /* make sure it can't change once captured */
75424 luke 896 
	ans = PROTECT(MAKE_DEFERRED_STRING_STATE(v, info));
73472 luke 897 
	ans = R_new_altrep(R_deferred_string_class, ans, R_NilValue);
74748 luke 898 
	UNPROTECT(2); /* ans, v */
73472 luke 899 
	break;
900 
    default:
901 
	error("unsupported type for deferred string coercion");
902 
    }
903 
    return ans;
904 
}
905 
 
906 
 
907 
/**
908 
 ** Memory Mapped Vectors
909 
 **/
910 
 
911 
/* For now, this code is designed to work both in base R and in a
912 
   package. Some simplifications would be possible if it was only to
913 
   be used in base. in particular, the issue of finalizing objects
914 
   before unloading the library would not need to be addressed, and
915 
   ordinary finalizers in the external pointers could be used instead
916 
   of maintaining a weak reference list of the live mmap objects. */
917 
 
918 
/*
919 
 * MMAP Object State
920 
 */
921 
 
922 
/* State is held in a LISTSXP of length 3, and includes
923 
 
924 
       file
925 
       size and length in a REALSXP
926 
       type, ptrOK, wrtOK, serOK in an INTSXP
927 
 
928 
   These are used by the methods, and also represent the serialized
929 
   state object.
930 
 */
931 
 
78870 ripley 932 
#ifndef Win32
73472 luke 933 
static SEXP make_mmap_state(SEXP file, size_t size, int type,
934 
			    Rboolean ptrOK, Rboolean wrtOK, Rboolean serOK)
935 
{
936 
    SEXP sizes = PROTECT(allocVector(REALSXP, 2));
937 
    double *dsizes = REAL(sizes);
938 
    dsizes[0] = size;
939 
    switch(type) {
940 
    case INTSXP: dsizes[1] = size / sizeof(int); break;
941 
    case REALSXP: dsizes[1] = size / sizeof(double); break;
942 
    default: error("mmap for %s not supported yet", type2char(type));
943 
    }
944 
 
945 
    SEXP info = PROTECT(allocVector(INTSXP, 4));
946 
    INTEGER(info)[0] = type;
947 
    INTEGER(info)[1] = ptrOK;
948 
    INTEGER(info)[2] = wrtOK;
949 
    INTEGER(info)[3] = serOK;
950 
 
951 
    SEXP state = list3(file, sizes, info);
952 
 
953 
    UNPROTECT(2);
954 
    return state;
955 
}
78870 ripley 956 
#endif
957 
 
73472 luke 958 
#define MMAP_STATE_FILE(x) CAR(x)
959 
#define MMAP_STATE_SIZE(x) ((size_t) REAL_ELT(CADR(x), 0))
960 
#define MMAP_STATE_LENGTH(x) ((size_t) REAL_ELT(CADR(x), 1))
961 
#define MMAP_STATE_TYPE(x) INTEGER(CADDR(x))[0]
962 
#define MMAP_STATE_PTROK(x) INTEGER(CADDR(x))[1]
963 
#define MMAP_STATE_WRTOK(x) INTEGER(CADDR(x))[2]
964 
#define MMAP_STATE_SEROK(x) INTEGER(CADDR(x))[3]
965 
 
966 
 
967 
/*
968 
 * MMAP Classes and Objects
969 
 */
970 
 
971 
static R_altrep_class_t mmap_integer_class;
972 
static R_altrep_class_t mmap_real_class;
973 
 
974 
/* MMAP objects are ALTREP objects with data fields
975 
 
976 
       data1: an external pointer to the mmaped address
977 
       data2: the MMAP object's state
978 
 
979 
   The state is also stored in the Protected field of the external
980 
   pointer for use by the finalizer.
981 
*/
982 
 
78870 ripley 983 
#ifndef Win32
73472 luke 984 
static void register_mmap_eptr(SEXP eptr);
985 
static SEXP make_mmap(void *p, SEXP file, size_t size, int type,
986 
		      Rboolean ptrOK, Rboolean wrtOK, Rboolean serOK)
987 
{
988 
    SEXP state = PROTECT(make_mmap_state(file, size,
989 
					 type, ptrOK, wrtOK, serOK));
990 
    SEXP eptr = PROTECT(R_MakeExternalPtr(p, R_NilValue, state));
991 
    register_mmap_eptr(eptr);
992 
 
993 
    R_altrep_class_t class;
994 
    switch(type) {
995 
    case INTSXP:
996 
	class = mmap_integer_class;
997 
	break;
998 
    case REALSXP:
999 
	class = mmap_real_class;
1000 
	break;
1001 
    default: error("mmap for %s not supported yet", type2char(type));
1002 
    }
1003 
 
1004 
    SEXP ans = R_new_altrep(class, eptr, state);
1005 
    if (ptrOK && ! wrtOK)
1006 
	MARK_NOT_MUTABLE(ans);
1007 
 
1008 
    UNPROTECT(2); /* state, eptr */
1009 
    return ans;
1010 
}
78870 ripley 1011 
#endif
73472 luke 1012 
 
1013 
#define MMAP_EPTR(x) R_altrep_data1(x)
1014 
#define MMAP_STATE(x) R_altrep_data2(x)
1015 
#define MMAP_LENGTH(x) MMAP_STATE_LENGTH(MMAP_STATE(x))
1016 
#define MMAP_PTROK(x) MMAP_STATE_PTROK(MMAP_STATE(x))
1017 
#define MMAP_WRTOK(x) MMAP_STATE_WRTOK(MMAP_STATE(x))
1018 
#define MMAP_SEROK(x) MMAP_STATE_SEROK(MMAP_STATE(x))
1019 
 
1020 
#define MMAP_EPTR_STATE(x) R_ExternalPtrProtected(x)
1021 
 
1022 
static R_INLINE void *MMAP_ADDR(SEXP x)
1023 
{
1024 
    SEXP eptr = MMAP_EPTR(x);
1025 
    void *addr = R_ExternalPtrAddr(eptr);
1026 
 
1027 
    if (addr == NULL)
1028 
	error("object has been unmapped");
1029 
    return addr;
1030 
}
1031 
 
1032 
/* We need to maintain a list of weak references to the external
1033 
   pointers of memory-mapped objects so a request to unload the shared
1034 
   library can finalize them before unloading; otherwise, attempting
1035 
   to run a finalizer after unloading would result in an illegal
1036 
   instruction. */
1037 
 
78870 ripley 1038 
 
1039 
#ifndef Win32
73472 luke 1040 
static SEXP mmap_list = NULL;
1041 
 
1042 
#define MAXCOUNT 10
1043 
 
1044 
static void mmap_finalize(SEXP eptr);
1045 
static void register_mmap_eptr(SEXP eptr)
1046 
{
1047 
    if (mmap_list == NULL) {
1048 
	mmap_list = CONS(R_NilValue, R_NilValue);
1049 
	R_PreserveObject(mmap_list);
1050 
    }
1051 
 
1052 
    /* clean out the weak list every MAXCOUNT calls*/
1053 
    static int cleancount = MAXCOUNT;
1054 
    if (--cleancount <= 0) {
1055 
	cleancount = MAXCOUNT;
1056 
	for (SEXP last = mmap_list, next = CDR(mmap_list);
1057 
	     next != R_NilValue;
1058 
	     next = CDR(next))
1059 
	    if (R_WeakRefKey(CAR(next)) == R_NilValue)
1060 
		SETCDR(last, CDR(next));
1061 
	    else
1062 
		last = next;
1063 
    }
1064 
 
1065 
    /* add a weak reference with a finalizer to the list */
1066 
    SETCDR(mmap_list,
1067 
	   CONS(R_MakeWeakRefC(eptr, R_NilValue, mmap_finalize, TRUE),
1068 
		CDR(mmap_list)));
1069 
 
1070 
    /* store the weak reference in the external pointer for do_munmap_file */
1071 
    R_SetExternalPtrTag(eptr, CAR(CDR(mmap_list)));
1072 
}
78870 ripley 1073 
#endif
73472 luke 1074 
 
1075 
#ifdef SIMPLEMMAP
1076 
static void finalize_mmap_objects()
1077 
{
1078 
    if (mmap_list == NULL)
1079 
	return;
1080 
 
1081 
    /* finalize any remaining mmap objects before unloading */
1082 
    for (SEXP next = CDR(mmap_list); next != R_NilValue; next = CDR(next))
1083 
	R_RunWeakRefFinalizer(CAR(next));
1084 
    R_ReleaseObject(mmap_list);
1085 
}
1086 
#endif
1087 
 
1088 
 
1089 
/*
1090 
 * ALTREP Methods
1091 
 */
1092 
 
1093 
static SEXP mmap_Serialized_state(SEXP x)
1094 
{
74230 luke 1095 
    /* If serOK is FALSE then serialize as a regular typed vector. If
73472 luke 1096 
       serOK is true, then serialize information to allow the mmap to
1097 
       be reconstructed. The original file name is serialized; it will
1098 
       be expanded again when unserializing, in a context where the
1099 
       result may be different. */
1100 
    if (MMAP_SEROK(x))
1101 
	return MMAP_STATE(x);
1102 
    else
1103 
	return NULL;
1104 
}
1105 
 
1106 
static SEXP mmap_file(SEXP, int, Rboolean, Rboolean, Rboolean, Rboolean);
1107 
 
1108 
static SEXP mmap_Unserialize(SEXP class, SEXP state)
1109 
{
1110 
    SEXP file = MMAP_STATE_FILE(state);
1111 
    int type = MMAP_STATE_TYPE(state);
87816 ripley 1112 
    Rboolean ptrOK = (Rboolean) MMAP_STATE_PTROK(state);
1113 
    Rboolean wrtOK = (Rboolean) MMAP_STATE_WRTOK(state);
1114 
    Rboolean serOK = (Rboolean) MMAP_STATE_SEROK(state);
73472 luke 1115 
 
1116 
    SEXP val = mmap_file(file, type, ptrOK, wrtOK, serOK, TRUE);
1117 
    if (val == NULL) {
1118 
	/**** The attempt to memory map failed. Eventually it would be
1119 
	      good to have a mechanism to allow the user to try to
1120 
	      resolve this.  For now, return a length zero vector with
1121 
	      another warning. */
1122 
	warning("memory mapping failed; returning vector of length zero");
1123 
	return allocVector(type, 0);
1124 
    }
1125 
    return val;
1126 
}
1127 
 
80594 luke 1128 
static Rboolean mmap_Inspect(SEXP x, int pre, int deep, int pvec,
1129 
			     void (*inspect_subtree)(SEXP, int, int, int))
73472 luke 1130 
{
87816 ripley 1131 
    Rboolean ptrOK = (Rboolean) MMAP_PTROK(x);
1132 
    Rboolean wrtOK = (Rboolean) MMAP_WRTOK(x);
1133 
    Rboolean serOK = (Rboolean) MMAP_SEROK(x);
85146 luke 1134 
    Rprintf(" mmaped %s", R_typeToChar(x));
73472 luke 1135 
    Rprintf(" [ptr=%d,wrt=%d,ser=%d]\n", ptrOK, wrtOK, serOK);
1136 
    return TRUE;
1137 
}
1138 
 
1139 
 
1140 
/*
1141 
 * ALTVEC Methods
1142 
 */
1143 
 
1144 
static R_xlen_t mmap_Length(SEXP x)
1145 
{
1146 
    return MMAP_LENGTH(x);
1147 
}
1148 
 
1149 
static void *mmap_Dataptr(SEXP x, Rboolean writeable)
1150 
{
1151 
    /* get addr first to get error if the object has been unmapped */
1152 
    void *addr = MMAP_ADDR(x);
1153 
 
1154 
    if (MMAP_PTROK(x))
1155 
	return addr;
1156 
    else
1157 
	error("cannot access data pointer for this mmaped vector");
1158 
}
1159 
 
73718 luke 1160 
static const void *mmap_Dataptr_or_null(SEXP x)
73472 luke 1161 
{
1162 
    return MMAP_PTROK(x) ? MMAP_ADDR(x) : NULL;
1163 
}
1164 
 
1165 
 
1166 
/*
1167 
 * ALTINTEGER Methods
1168 
 */
1169 
 
1170 
static int mmap_integer_Elt(SEXP x, R_xlen_t i)
1171 
{
1172 
    int *p = MMAP_ADDR(x);
1173 
    return p[i];
1174 
}
1175 
 
1176 
static
1177 
R_xlen_t mmap_integer_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
1178 
{
1179 
    int *x = MMAP_ADDR(sx);
1180 
    R_xlen_t size = XLENGTH(sx);
1181 
    R_xlen_t ncopy = size - i > n ? n : size - i;
1182 
    for (R_xlen_t k = 0; k < ncopy; k++)
1183 
	buf[k] = x[k + i];
1184 
    //memcpy(buf, x + i, ncopy * sizeof(int));
1185 
    return ncopy;
1186 
}
1187 
 
1188 
 
1189 
/*
1190 
 * ALTREAL Methods
1191 
 */
1192 
 
1193 
static double mmap_real_Elt(SEXP x, R_xlen_t i)
1194 
{
1195 
    double *p = MMAP_ADDR(x);
1196 
    return p[i];
1197 
}
1198 
 
1199 
static
1200 
R_xlen_t mmap_real_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
1201 
{
1202 
    double *x = MMAP_ADDR(sx);
1203 
    R_xlen_t size = XLENGTH(sx);
1204 
    R_xlen_t ncopy = size - i > n ? n : size - i;
1205 
    for (R_xlen_t k = 0; k < ncopy; k++)
1206 
	buf[k] = x[k + i];
1207 
    //memcpy(buf, x + i, ncopy * sizeof(double));
1208 
    return ncopy;
1209 
}
1210 
 
1211 
 
1212 
/*
1213 
 * Class Objects and Method Tables
1214 
 */
1215 
 
1216 
#ifdef SIMPLEMMAP
1217 
# define MMAPPKG "simplemmap"
1218 
#else
1219 
# define MMAPPKG "base"
1220 
#endif
1221 
 
1222 
static void InitMmapIntegerClass(DllInfo *dll)
1223 
{
1224 
    R_altrep_class_t cls =
1225 
	R_make_altinteger_class("mmap_integer", MMAPPKG, dll);
1226 
    mmap_integer_class = cls;
1227 
 
1228 
    /* override ALTREP methods */
1229 
    R_set_altrep_Unserialize_method(cls, mmap_Unserialize);
1230 
    R_set_altrep_Serialized_state_method(cls, mmap_Serialized_state);
1231 
    R_set_altrep_Inspect_method(cls, mmap_Inspect);
1232 
    R_set_altrep_Length_method(cls, mmap_Length);
1233 
 
1234 
    /* override ALTVEC methods */
1235 
    R_set_altvec_Dataptr_method(cls, mmap_Dataptr);
1236 
    R_set_altvec_Dataptr_or_null_method(cls, mmap_Dataptr_or_null);
1237 
 
1238 
    /* override ALTINTEGER methods */
1239 
    R_set_altinteger_Elt_method(cls, mmap_integer_Elt);
1240 
    R_set_altinteger_Get_region_method(cls, mmap_integer_Get_region);
1241 
}
1242 
 
1243 
static void InitMmapRealClass(DllInfo *dll)
1244 
{
1245 
    R_altrep_class_t cls =
1246 
	R_make_altreal_class("mmap_real", MMAPPKG, dll);
1247 
    mmap_real_class = cls;
1248 
 
1249 
    /* override ALTREP methods */
1250 
    R_set_altrep_Unserialize_method(cls, mmap_Unserialize);
1251 
    R_set_altrep_Serialized_state_method(cls, mmap_Serialized_state);
1252 
    R_set_altrep_Inspect_method(cls, mmap_Inspect);
1253 
    R_set_altrep_Length_method(cls, mmap_Length);
1254 
 
1255 
    /* override ALTVEC methods */
1256 
    R_set_altvec_Dataptr_method(cls, mmap_Dataptr);
1257 
    R_set_altvec_Dataptr_or_null_method(cls, mmap_Dataptr_or_null);
1258 
 
1259 
    /* override ALTREAL methods */
1260 
    R_set_altreal_Elt_method(cls, mmap_real_Elt);
1261 
    R_set_altreal_Get_region_method(cls, mmap_real_Get_region);
1262 
}
1263 
 
1264 
 
1265 
/*
1266 
 * Constructor
1267 
 */
1268 
 
1269 
#ifdef Win32
78870 ripley 1270 
/* unused
73472 luke 1271 
static void mmap_finalize(SEXP eptr)
1272 
{
78113 kalibera 1273 
    error("mmap objects not supported on Windows yet");
73472 luke 1274 
}
78870 ripley 1275 
*/
73472 luke 1276 
 
1277 
static SEXP mmap_file(SEXP file, int type, Rboolean ptrOK, Rboolean wrtOK,
1278 
		      Rboolean serOK, Rboolean warn)
1279 
{
78113 kalibera 1280 
    error("mmap objects not supported on Windows yet");
73472 luke 1281 
}
1282 
#else
1283 
/* derived from the example in
1284 
  https://www.safaribooksonline.com/library/view/linux-system-programming/0596009585/ch04s03.html */
1285 
 
1286 
#include <sys/stat.h>
1287 
#include <fcntl.h>
1288 
#include <errno.h>
1289 
#include <unistd.h>
1290 
#include <sys/mman.h>
1291 
 
1292 
//#define DEBUG_PRINT(x) REprintf(x);
1293 
#define DEBUG_PRINT(x) do { } while (0)
1294 
 
1295 
static void mmap_finalize(SEXP eptr)
1296 
{
1297 
    DEBUG_PRINT("finalizing ... ");
1298 
    void *p = R_ExternalPtrAddr(eptr);
1299 
    size_t size = MMAP_STATE_SIZE(MMAP_EPTR_STATE(eptr));
1300 
 
1301 
    if (p != NULL) {
1302 
	munmap(p, size); /* don't check for errors */
1303 
	R_SetExternalPtrAddr(eptr, NULL);
1304 
    }
1305 
    DEBUG_PRINT("done\n");
1306 
}
1307 
 
1308 
#define MMAP_FILE_WARNING_OR_ERROR(str, ...) do {	\
1309 
	if (warn) {					\
1310 
	    warning(str, __VA_ARGS__);			\
1311 
	    return NULL;				\
1312 
	}						\
1313 
	else error(str, __VA_ARGS__);			\
1314 
    } while (0)
1315 
 
1316 
static SEXP mmap_file(SEXP file, int type, Rboolean ptrOK, Rboolean wrtOK,
1317 
		      Rboolean serOK, Rboolean warn)
1318 
{
76974 ripley 1319 
    const char *efn = R_ExpandFileName(translateCharFP(STRING_ELT(file, 0)));
73472 luke 1320 
    struct stat sb;
1321 
 
1322 
    /* Target not link */
1323 
    if (stat(efn, &sb) != 0)
1324 
	MMAP_FILE_WARNING_OR_ERROR("stat: %s", strerror(errno));
1325 
 
1326 
    if (! S_ISREG(sb.st_mode))
1327 
	MMAP_FILE_WARNING_OR_ERROR("%s is not a regular file", efn);
1328 
 
1329 
    int oflags = wrtOK ? O_RDWR : O_RDONLY;
1330 
    int fd = open(efn, oflags);
1331 
    if (fd == -1)
1332 
	MMAP_FILE_WARNING_OR_ERROR("open: %s", strerror(errno));
1333 
 
1334 
    int pflags = wrtOK ? PROT_READ | PROT_WRITE : PROT_READ;
1335 
    void *p = mmap(0, sb.st_size, pflags, MAP_SHARED, fd, 0);
1336 
    close(fd); /* don't care if this fails */
1337 
    if (p == MAP_FAILED)
1338 
	MMAP_FILE_WARNING_OR_ERROR("mmap: %s", strerror(errno));
1339 
 
1340 
    return make_mmap(p, file, sb.st_size, type, ptrOK, wrtOK, serOK);
1341 
}
1342 
#endif
1343 
 
1344 
static Rboolean asLogicalNA(SEXP x, Rboolean dflt)
1345 
{
87816 ripley 1346 
    int val = asLogical(x);
1347 
    return val == NA_LOGICAL ? dflt : (Rboolean) val;
73472 luke 1348 
}
1349 
 
1350 
#ifdef SIMPLEMMAP
1351 
SEXP do_mmap_file(SEXP args)
1352 
{
1353 
    args = CDR(args);
1354 
#else
83446 ripley 1355 
attribute_hidden SEXP do_mmap_file(SEXP call, SEXP op, SEXP args, SEXP env)
73472 luke 1356 
{
1357 
#endif
1358 
    SEXP file = CAR(args);
1359 
    SEXP stype = CADR(args);
1360 
    SEXP sptrOK = CADDR(args);
1361 
    SEXP swrtOK = CADDDR(args);
87184 maechler 1362 
    SEXP sserOK = CAD4R(args);
73472 luke 1363 
 
1364 
    int type = REALSXP;
1365 
    if (stype != R_NilValue) {
1366 
	const char *typestr = CHAR(asChar(stype));
1367 
	if (strcmp(typestr, "double") == 0)
1368 
	    type = REALSXP;
1369 
	else if (strcmp(typestr, "integer") == 0 ||
1370 
		 strcmp(typestr, "int") == 0)
1371 
	    type = INTSXP;
1372 
	else
1373 
	    error("type '%s' is not supported", typestr);
1374 
    }
1375 
 
1376 
    Rboolean ptrOK = sptrOK == R_NilValue ? TRUE : asLogicalNA(sptrOK, FALSE);
1377 
    Rboolean wrtOK = swrtOK == R_NilValue ? FALSE : asLogicalNA(swrtOK, FALSE);
1378 
    Rboolean serOK = sserOK == R_NilValue ? FALSE : asLogicalNA(sserOK, FALSE);
1379 
 
1380 
    if (TYPEOF(file) != STRSXP || LENGTH(file) != 1 || file == NA_STRING)
1381 
	error("invalud 'file' argument");
1382 
 
1383 
    return mmap_file(file, type, ptrOK, wrtOK, serOK, FALSE);
1384 
}
1385 
 
1386 
#ifdef SIMPLEMMAP
1387 
static SEXP do_munmap_file(SEXP args)
1388 
{
1389 
    args = CDR(args);
1390 
#else
83446 ripley 1391 
attribute_hidden SEXP do_munmap_file(SEXP call, SEXP op, SEXP args, SEXP env)
73472 luke 1392 
{
1393 
#endif
1394 
    SEXP x = CAR(args);
1395 
 
1396 
    /**** would be useful to have R_mmap_class virtual class as parent here */
1397 
    if (! (R_altrep_inherits(x, mmap_integer_class) ||
1398 
	   R_altrep_inherits(x, mmap_real_class)))
1399 
	error("not a memory-mapped object");
1400 
 
1401 
    /* using the finalizer is a cheat to avoid yet another #ifdef Windows */
1402 
    SEXP eptr = MMAP_EPTR(x);
1403 
    errno = 0;
1404 
    R_RunWeakRefFinalizer(R_ExternalPtrTag(eptr));
1405 
    if (errno)
1406 
	error("munmap: %s", strerror(errno));
1407 
    return R_NilValue;
1408 
}
1409 
 
1410 
 
1411 
/**
1412 
 ** Attribute and Meta Data Wrappers
1413 
 **/
1414 
 
1415 
/*
1416 
 * Wrapper Classes and Objects
1417 
 */
1418 
 
1419 
#define NMETA 2
1420 
 
1421 
static R_altrep_class_t wrap_integer_class;
75491 luke 1422 
static R_altrep_class_t wrap_logical_class;
73472 luke 1423 
static R_altrep_class_t wrap_real_class;
75492 luke 1424 
static R_altrep_class_t wrap_complex_class;
75493 luke 1425 
static R_altrep_class_t wrap_raw_class;
73472 luke 1426 
static R_altrep_class_t wrap_string_class;
83914 luke 1427 
static R_altrep_class_t wrap_list_class;
73472 luke 1428 
 
1429 
/* Wrapper objects are ALTREP objects designed to hold the attributes
74230 luke 1430 
   of a potentially large object and/or meta data for the object. */
73472 luke 1431 
 
1432 
#define WRAPPER_WRAPPED(x) R_altrep_data1(x)
1433 
#define WRAPPER_SET_WRAPPED(x, v) R_set_altrep_data1(x, v)
1434 
#define WRAPPER_METADATA(x) R_altrep_data2(x)
1435 
 
1436 
#define WRAPPER_SORTED(x) INTEGER(WRAPPER_METADATA(x))[0]
1437 
#define WRAPPER_NO_NA(x) INTEGER(WRAPPER_METADATA(x))[1]
1438 
 
90309 luke 1439 
/* When a wrapper is created, e.g. using structure(), the data may
1440 
   initially be shared. Once it is modified to be modified or a
1441 
   DATAPTR is requested the data has to be remain unchanged and the
1442 
   wrapper should be the only reference. The metadata is marked to
1443 
   reflecth this. The data then has to be duplicated by the duplicate
1444 
   method to ensure that no new references are created. This ensures
1445 
   that a DATAPTR, once obtained, remains valid while the wrapper
1446 
   object is reachable.
1447 
 
1448 
   For now the sxpinfo.gp field is used via PRSEEN for the lock.
1449 
 */
1450 
#define WRAPPER_DATA_IS_LOCKED(x) PRSEEN(WRAPPER_METADATA(x))
1451 
#define WRAPPER_LOCK_DATA(x) SET_PRSEEN(WRAPPER_METADATA(x), 1)
1452 
#define WRAPPER_UNLOCK_DATA(x) SET_PRSEEN(WRAPPER_METADATA(x), 0)
1453 
 
75502 luke 1454 
static R_INLINE SEXP WRAPPER_WRAPPED_RW(SEXP x)
1455 
{
1456 
    SEXP data = WRAPPER_WRAPPED(x);
90309 luke 1457 
    if (WRAPPER_DATA_IS_LOCKED(x)) {
1458 
	/* Once data is locked it's reference cout should remain at one. */
1459 
	if (MAYBE_SHARED(data))
1460 
	    error("REFCNT on locked WRAPPER data increased to %d",
1461 
		  REFCNT(data));
75502 luke 1462 
    }
90309 luke 1463 
    else {
1464 
	/* If the data might be shared and is accessed for possible
1465 
	   modification, then it needs to be duplicated now. */
1466 
	if (MAYBE_SHARED(data)) {
1467 
	    PROTECT(x);
1468 
	    WRAPPER_SET_WRAPPED(x, shallow_duplicate(data));
1469 
	    UNPROTECT(1);
1470 
	}
1471 
	WRAPPER_LOCK_DATA(x);
1472 
    }
73472 luke 1473 
 
75502 luke 1474 
    /* The meta data also needs to be cleared as it may no longer be
1475 
       valid after a write. */
1476 
    SEXP meta = WRAPPER_METADATA(x);
1477 
    INTEGER(meta)[0] = UNKNOWN_SORTEDNESS;
1478 
    for (int i = 1; i < NMETA; i++)
1479 
	INTEGER(meta)[i] = 0;
1480 
 
1481 
    return WRAPPER_WRAPPED(x);
1482 
}
1483 
 
1484 
 
73472 luke 1485 
/*
1486 
 * ALTREP Methods
1487 
 */
1488 
 
1489 
static SEXP wrapper_Serialized_state(SEXP x)
1490 
{
80595 luke 1491 
    /* If the wrapped value is not an ALTREP and there is no useful
1492 
       metadata then return NULL to allow this to be serialized as a
1493 
       standard object. This avoids serializing potentially large
1494 
       attributes on the wrapped value (PR18142). */
1495 
    if (! ALTREP(WRAPPER_WRAPPED(x)) &&
1496 
	WRAPPER_SORTED(x) == UNKNOWN_SORTEDNESS &&
1497 
	! WRAPPER_NO_NA(x))
1498 
	return NULL;
1499 
 
73472 luke 1500 
    return CONS(WRAPPER_WRAPPED(x), WRAPPER_METADATA(x));
1501 
}
1502 
 
1503 
static SEXP make_wrapper(SEXP, SEXP);
1504 
 
1505 
static SEXP wrapper_Unserialize(SEXP class, SEXP state)
1506 
{
1507 
    return make_wrapper(CAR(state), CDR(state));
1508 
}
1509 
 
1510 
static SEXP wrapper_Duplicate(SEXP x, Rboolean deep)
1511 
{
1512 
    SEXP data = WRAPPER_WRAPPED(x);
1513 
 
74230 luke 1514 
    /* For a deep copy, duplicate the data. */
1515 
    /* For a shallow copy, mark as immutable in the NAMED world; with
73472 luke 1516 
       reference counting the reference count will be incremented when
1517 
       the data is installed in the new wrapper object. */
90309 luke 1518 
    if (deep || WRAPPER_DATA_IS_LOCKED(x)) // **** shallow duplicate if only locked?
73472 luke 1519 
	data = duplicate(data);
1520 
#ifndef SWITCH_TO_REFCNT
1521 
    else
1522 
	/* not needed with reference counting */
1523 
	MARK_NOT_MUTABLE(data);
1524 
#endif
1525 
    PROTECT(data);
1526 
 
1527 
    /* always duplicate the meta data */
1528 
    SEXP meta = PROTECT(duplicate(WRAPPER_METADATA(x)));
1529 
 
1530 
    SEXP ans = make_wrapper(data, meta);
1531 
 
1532 
    UNPROTECT(2); /* data, meta */
1533 
    return ans;
1534 
}
1535 
 
80594 luke 1536 
static Rboolean wrapper_Inspect(SEXP x, int pre, int deep, int pvec,
1537 
				void (*inspect_subtree)(SEXP, int, int, int))
73472 luke 1538 
{
87816 ripley 1539 
    Rboolean srt = (Rboolean) WRAPPER_SORTED(x);
1540 
    Rboolean no_na = (Rboolean) WRAPPER_NO_NA(x);
90309 luke 1541 
    Rboolean lck = (Rboolean) WRAPPER_DATA_IS_LOCKED(x);
1542 
    Rprintf(" wrapper [srt=%d,no_na=%d,lck=%d]\n", srt, no_na, lck);
73472 luke 1543 
    inspect_subtree(WRAPPER_WRAPPED(x), pre, deep, pvec);
1544 
    return TRUE;
1545 
}
1546 
 
1547 
static R_xlen_t wrapper_Length(SEXP x)
1548 
{
1549 
    return XLENGTH(WRAPPER_WRAPPED(x));
1550 
}
1551 
 
1552 
 
1553 
/*
1554 
 * ALTVEC Methods
1555 
 */
1556 
 
1557 
static void *wrapper_Dataptr(SEXP x, Rboolean writeable)
1558 
{
75502 luke 1559 
    if (writeable)
89022 luke 1560 
	return DATAPTR_RW(WRAPPER_WRAPPED_RW(x));
73472 luke 1561 
    else
90261 luke 1562 
	/* This has to use WRAPPER_WRAPPED_RW even for a read-only
1563 
	   pointer to make sure a later request for a writable pointer
1564 
	   will return the same address. */
75502 luke 1565 
	/**** could avoid the cast by having separate methods */
90261 luke 1566 
	return (void *) DATAPTR_RO(WRAPPER_WRAPPED_RW(x));
73472 luke 1567 
}
1568 
 
73718 luke 1569 
static const void *wrapper_Dataptr_or_null(SEXP x)
73472 luke 1570 
{
90261 luke 1571 
    /* This has to use WRAPPER_WRAPPED_RW as above. */
1572 
    return DATAPTR_OR_NULL(WRAPPER_WRAPPED_RW(x));
73472 luke 1573 
}
1574 
 
78088 luke 1575 
static SEXP wrapper_Extract_subset(SEXP x, SEXP indx, SEXP call)
1576 
{
1577 
  return ExtractSubset(WRAPPER_WRAPPED(x), indx, call);
1578 
}
73472 luke 1579 
 
78088 luke 1580 
 
73472 luke 1581 
/*
1582 
 * ALTINTEGER Methods
1583 
 */
1584 
 
1585 
static int wrapper_integer_Elt(SEXP x, R_xlen_t i)
1586 
{
1587 
    return INTEGER_ELT(WRAPPER_WRAPPED(x), i);
1588 
}
1589 
 
1590 
static
1591 
R_xlen_t wrapper_integer_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, int *buf)
1592 
{
1593 
    return INTEGER_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
1594 
}
1595 
 
1596 
static int wrapper_integer_Is_sorted(SEXP x)
1597 
{
74230 luke 1598 
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
1599 
	return WRAPPER_SORTED(x);
73472 luke 1600 
    else
1601 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1602 
	return INTEGER_IS_SORTED(WRAPPER_WRAPPED(x));
1603 
}
1604 
 
1605 
static int wrapper_integer_no_NA(SEXP x)
1606 
{
1607 
    if (WRAPPER_NO_NA(x))
1608 
	return TRUE;
1609 
    else
1610 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1611 
	return INTEGER_NO_NA(WRAPPER_WRAPPED(x));
1612 
}
1613 
 
1614 
 
1615 
/*
75491 luke 1616 
 * ALTLOGICAL Methods
1617 
 */
1618 
 
1619 
static int wrapper_logical_Elt(SEXP x, R_xlen_t i)
1620 
{
1621 
    return LOGICAL_ELT(WRAPPER_WRAPPED(x), i);
1622 
}
1623 
 
1624 
static
1625 
R_xlen_t wrapper_logical_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, int *buf)
1626 
{
1627 
    return LOGICAL_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
1628 
}
1629 
 
1630 
static int wrapper_logical_Is_sorted(SEXP x)
1631 
{
1632 
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
1633 
	return WRAPPER_SORTED(x);
1634 
    else
1635 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1636 
	return LOGICAL_IS_SORTED(WRAPPER_WRAPPED(x));
1637 
}
1638 
 
1639 
static int wrapper_logical_no_NA(SEXP x)
1640 
{
1641 
    if (WRAPPER_NO_NA(x))
1642 
	return TRUE;
1643 
    else
1644 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1645 
	return LOGICAL_NO_NA(WRAPPER_WRAPPED(x));
1646 
}
1647 
 
1648 
 
1649 
/*
73472 luke 1650 
 * ALTREAL Methods
1651 
 */
1652 
 
1653 
static double wrapper_real_Elt(SEXP x, R_xlen_t i)
1654 
{
1655 
    return REAL_ELT(WRAPPER_WRAPPED(x), i);
1656 
}
1657 
 
1658 
static
1659 
R_xlen_t wrapper_real_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, double *buf)
1660 
{
1661 
    return REAL_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
1662 
}
1663 
 
1664 
static int wrapper_real_Is_sorted(SEXP x)
1665 
{
74230 luke 1666 
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
1667 
	return WRAPPER_SORTED(x);
73472 luke 1668 
    else
1669 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1670 
	return REAL_IS_SORTED(WRAPPER_WRAPPED(x));
1671 
}
1672 
 
1673 
static int wrapper_real_no_NA(SEXP x)
1674 
{
1675 
    if (WRAPPER_NO_NA(x))
1676 
	return TRUE;
1677 
    else
1678 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1679 
	return REAL_NO_NA(WRAPPER_WRAPPED(x));
1680 
}
1681 
 
1682 
 
1683 
/*
75492 luke 1684 
 * ALTCOMPLEX Methods
1685 
 */
1686 
 
1687 
static Rcomplex wrapper_complex_Elt(SEXP x, R_xlen_t i)
1688 
{
1689 
    return COMPLEX_ELT(WRAPPER_WRAPPED(x), i);
1690 
}
1691 
 
1692 
static
1693 
R_xlen_t wrapper_complex_Get_region(SEXP x, R_xlen_t i, R_xlen_t n,
1694 
				    Rcomplex *buf)
1695 
{
1696 
    return COMPLEX_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
1697 
}
1698 
 
1699 
 
1700 
/*
75493 luke 1701 
 * ALTRAW Methods
1702 
 */
1703 
 
1704 
static Rbyte wrapper_raw_Elt(SEXP x, R_xlen_t i)
1705 
{
1706 
    return RAW_ELT(WRAPPER_WRAPPED(x), i);
1707 
}
1708 
 
1709 
static
1710 
R_xlen_t wrapper_raw_Get_region(SEXP x, R_xlen_t i, R_xlen_t n, Rbyte *buf)
1711 
{
1712 
    return RAW_GET_REGION(WRAPPER_WRAPPED(x), i, n, buf);
1713 
}
1714 
 
1715 
 
1716 
/*
73472 luke 1717 
 * ALTSTRING Methods
1718 
 */
1719 
 
1720 
static SEXP wrapper_string_Elt(SEXP x, R_xlen_t i)
1721 
{
1722 
    return STRING_ELT(WRAPPER_WRAPPED(x), i);
1723 
}
1724 
 
75498 luke 1725 
static void wrapper_string_Set_elt(SEXP x, R_xlen_t i, SEXP v)
1726 
{
75502 luke 1727 
    SET_STRING_ELT(WRAPPER_WRAPPED_RW(x), i, v);
75498 luke 1728 
}
1729 
 
73472 luke 1730 
static int wrapper_string_Is_sorted(SEXP x)
1731 
{
74230 luke 1732 
    if (WRAPPER_SORTED(x) != UNKNOWN_SORTEDNESS)
1733 
	return WRAPPER_SORTED(x);
73472 luke 1734 
    else
1735 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1736 
	return STRING_IS_SORTED(WRAPPER_WRAPPED(x));
1737 
}
1738 
 
1739 
static int wrapper_string_no_NA(SEXP x)
1740 
{
1741 
    if (WRAPPER_NO_NA(x))
1742 
	return TRUE;
1743 
    else
1744 
	/* If the  meta data bit is not set, defer to the wrapped object. */
1745 
	return STRING_NO_NA(WRAPPER_WRAPPED(x));
1746 
}
1747 
 
1748 
 
1749 
/*
83914 luke 1750 
 * ALTLIST Methods
1751 
 */
1752 
 
1753 
static SEXP wrapper_list_Elt(SEXP x, R_xlen_t i)
1754 
{
1755 
    return VECTOR_ELT(WRAPPER_WRAPPED(x), i);
1756 
}
1757 
 
1758 
static void wrapper_list_Set_elt(SEXP x, R_xlen_t i, SEXP v)
1759 
{
1760 
    SET_VECTOR_ELT(WRAPPER_WRAPPED_RW(x), i, v);
1761 
}
1762 
 
1763 
/*
73472 luke 1764 
 * Class Objects and Method Tables
1765 
 */
1766 
 
1767 
#define WRAPPKG "base"
1768 
 
1769 
static void InitWrapIntegerClass(DllInfo *dll)
1770 
{
1771 
    R_altrep_class_t cls =
1772 
	R_make_altinteger_class("wrap_integer", WRAPPKG, dll);
1773 
    wrap_integer_class = cls;
1774 
 
1775 
    /* override ALTREP methods */
1776 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1777 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1778 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1779 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1780 
    R_set_altrep_Length_method(cls, wrapper_Length);
1781 
 
1782 
    /* override ALTVEC methods */
1783 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1784 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
78088 luke 1785 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
73472 luke 1786 
 
1787 
    /* override ALTINTEGER methods */
1788 
    R_set_altinteger_Elt_method(cls, wrapper_integer_Elt);
1789 
    R_set_altinteger_Get_region_method(cls, wrapper_integer_Get_region);
1790 
    R_set_altinteger_Is_sorted_method(cls, wrapper_integer_Is_sorted);
1791 
    R_set_altinteger_No_NA_method(cls, wrapper_integer_no_NA);
1792 
}
1793 
 
75491 luke 1794 
static void InitWrapLogicalClass(DllInfo *dll)
1795 
{
1796 
    R_altrep_class_t cls =
1797 
	R_make_altlogical_class("wrap_logical", WRAPPKG, dll);
1798 
    wrap_logical_class = cls;
1799 
 
1800 
    /* override ALTREP methods */
1801 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1802 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1803 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1804 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1805 
    R_set_altrep_Length_method(cls, wrapper_Length);
1806 
 
1807 
    /* override ALTVEC methods */
1808 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1809 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
78088 luke 1810 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
75491 luke 1811 
 
1812 
    /* override ALTLOGICAL methods */
1813 
    R_set_altlogical_Elt_method(cls, wrapper_logical_Elt);
1814 
    R_set_altlogical_Get_region_method(cls, wrapper_logical_Get_region);
1815 
    R_set_altlogical_Is_sorted_method(cls, wrapper_logical_Is_sorted);
1816 
    R_set_altlogical_No_NA_method(cls, wrapper_logical_no_NA);
1817 
}
1818 
 
73472 luke 1819 
static void InitWrapRealClass(DllInfo *dll)
1820 
{
1821 
    R_altrep_class_t cls =
1822 
	R_make_altreal_class("wrap_real", WRAPPKG, dll);
1823 
    wrap_real_class = cls;
1824 
 
1825 
    /* override ALTREP methods */
1826 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1827 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1828 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1829 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1830 
    R_set_altrep_Length_method(cls, wrapper_Length);
1831 
 
1832 
    /* override ALTVEC methods */
1833 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1834 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
78088 luke 1835 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
73472 luke 1836 
 
1837 
    /* override ALTREAL methods */
1838 
    R_set_altreal_Elt_method(cls, wrapper_real_Elt);
1839 
    R_set_altreal_Get_region_method(cls, wrapper_real_Get_region);
1840 
    R_set_altreal_Is_sorted_method(cls, wrapper_real_Is_sorted);
1841 
    R_set_altreal_No_NA_method(cls, wrapper_real_no_NA);
1842 
}
1843 
 
75492 luke 1844 
static void InitWrapComplexClass(DllInfo *dll)
1845 
{
1846 
    R_altrep_class_t cls =
1847 
	R_make_altcomplex_class("wrap_complex", WRAPPKG, dll);
1848 
    wrap_complex_class = cls;
1849 
 
1850 
    /* override ALTREP methods */
1851 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1852 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1853 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1854 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1855 
    R_set_altrep_Length_method(cls, wrapper_Length);
1856 
 
1857 
    /* override ALTVEC methods */
1858 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1859 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
78088 luke 1860 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
75492 luke 1861 
 
1862 
    /* override ALTCOMPLEX methods */
1863 
    R_set_altcomplex_Elt_method(cls, wrapper_complex_Elt);
1864 
    R_set_altcomplex_Get_region_method(cls, wrapper_complex_Get_region);
1865 
}
1866 
 
75493 luke 1867 
static void InitWrapRawClass(DllInfo *dll)
1868 
{
1869 
    R_altrep_class_t cls =
1870 
	R_make_altraw_class("wrap_raw", WRAPPKG, dll);
1871 
    wrap_raw_class = cls;
1872 
 
1873 
    /* override ALTREP methods */
1874 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1875 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1876 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1877 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1878 
    R_set_altrep_Length_method(cls, wrapper_Length);
1879 
 
1880 
    /* override ALTVEC methods */
1881 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1882 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
78088 luke 1883 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
75493 luke 1884 
 
1885 
    /* override ALTRAW methods */
1886 
    R_set_altraw_Elt_method(cls, wrapper_raw_Elt);
1887 
    R_set_altraw_Get_region_method(cls, wrapper_raw_Get_region);
1888 
}
1889 
 
73472 luke 1890 
static void InitWrapStringClass(DllInfo *dll)
1891 
{
1892 
    R_altrep_class_t cls =
1893 
	R_make_altstring_class("wrap_string", WRAPPKG, dll);
1894 
    wrap_string_class = cls;
1895 
 
1896 
    /* override ALTREP methods */
1897 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1898 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1899 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1900 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1901 
    R_set_altrep_Length_method(cls, wrapper_Length);
1902 
 
1903 
    /* override ALTVEC methods */
1904 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1905 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
78088 luke 1906 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
73472 luke 1907 
 
1908 
    /* override ALTSTRING methods */
1909 
    R_set_altstring_Elt_method(cls, wrapper_string_Elt);
75498 luke 1910 
    R_set_altstring_Set_elt_method(cls, wrapper_string_Set_elt);
73472 luke 1911 
    R_set_altstring_Is_sorted_method(cls, wrapper_string_Is_sorted);
1912 
    R_set_altstring_No_NA_method(cls, wrapper_string_no_NA);
1913 
}
1914 
 
83914 luke 1915 
static void InitWrapListClass(DllInfo *dll)
1916 
{
1917 
    R_altrep_class_t cls =
1918 
	R_make_altlist_class("wrap_list", WRAPPKG, dll);
1919 
    wrap_list_class = cls;
73472 luke 1920 
 
83914 luke 1921 
    /* override ALTREP methods */
1922 
    R_set_altrep_Unserialize_method(cls, wrapper_Unserialize);
1923 
    R_set_altrep_Serialized_state_method(cls, wrapper_Serialized_state);
1924 
    R_set_altrep_Duplicate_method(cls, wrapper_Duplicate);
1925 
    R_set_altrep_Inspect_method(cls, wrapper_Inspect);
1926 
    R_set_altrep_Length_method(cls, wrapper_Length);
1927 
 
83995 luke 1928 
    /* override ALTVEC methods */
1929 
    R_set_altvec_Dataptr_method(cls, wrapper_Dataptr);
1930 
    R_set_altvec_Dataptr_or_null_method(cls, wrapper_Dataptr_or_null);
1931 
    R_set_altvec_Extract_subset_method(cls, wrapper_Extract_subset);
1932 
 
83914 luke 1933 
    /* override ALTLIST methods */
1934 
    R_set_altlist_Elt_method(cls, wrapper_list_Elt);
1935 
    R_set_altlist_Set_elt_method(cls, wrapper_list_Set_elt);
1936 
}
1937 
 
1938 
 
73472 luke 1939 
/*
1940 
 * Constructor
1941 
 */
1942 
 
1943 
static SEXP make_wrapper(SEXP x, SEXP meta)
1944 
{
1945 
    /* If x is itself a wrapper it might be a good idea to fuse */
1946 
    R_altrep_class_t cls;
1947 
    switch(TYPEOF(x)) {
1948 
    case INTSXP: cls = wrap_integer_class; break;
75491 luke 1949 
    case LGLSXP: cls = wrap_logical_class; break;
73472 luke 1950 
    case REALSXP: cls = wrap_real_class; break;
75492 luke 1951 
    case CPLXSXP: cls = wrap_complex_class; break;
75493 luke 1952 
    case RAWSXP: cls = wrap_raw_class; break;
73472 luke 1953 
    case STRSXP: cls = wrap_string_class; break;
83914 luke 1954 
    case VECSXP: cls = wrap_list_class; break;
73472 luke 1955 
    default: error("unsupported type");
1956 
    }
1957 
 
1958 
    SEXP ans = R_new_altrep(cls, x, meta);
1959 
 
75366 luke 1960 
#define WRAPATTRIB
1961 
#ifdef WRAPATTRIB
1962 
    if (ATTRIB(x) != R_NilValue) {
1963 
	/* could just move attributes if there are no references to x */
1964 
	PROTECT(ans);
1965 
	SET_ATTRIB(ans, shallow_duplicate(ATTRIB(x)));
1966 
	SET_OBJECT(ans, OBJECT(x));
75486 luke 1967 
	IS_S4_OBJECT(x) ? SET_S4_OBJECT(ans) : UNSET_S4_OBJECT(ans);
75366 luke 1968 
	UNPROTECT(1); /* ans */
1969 
    }
1970 
#endif
1971 
 
73472 luke 1972 
#ifndef SWITCH_TO_REFCNT
1973 
    if (MAYBE_REFERENCED(x))
1974 
	/* make sure no mutation can happen through another reference */
1975 
	MARK_NOT_MUTABLE(x);
1976 
#endif
90309 luke 1977 
 
1978 
    WRAPPER_UNLOCK_DATA(ans);
73472 luke 1979 
    return ans;
1980 
}
1981 
 
75484 luke 1982 
static R_INLINE int is_wrapper(SEXP x)
73472 luke 1983 
{
75484 luke 1984 
    if (ALTREP(x))
1985 
	switch(TYPEOF(x)) {
1986 
	case INTSXP: return R_altrep_inherits(x, wrap_integer_class);
75491 luke 1987 
	case LGLSXP: return R_altrep_inherits(x, wrap_logical_class);
75501 luke 1988 
	case REALSXP: return R_altrep_inherits(x, wrap_real_class);
1989 
	case CPLXSXP: return R_altrep_inherits(x, wrap_complex_class);
1990 
	case RAWSXP: return R_altrep_inherits(x, wrap_raw_class);
75553 luke 1991 
	case STRSXP: return R_altrep_inherits(x, wrap_string_class);
83914 luke 1992 
	case VECSXP: return R_altrep_inherits(x, wrap_list_class);
75484 luke 1993 
	default: return FALSE;
1994 
	}
1995 
    else return FALSE;
1996 
}
1997 
 
1998 
static SEXP wrap_meta(SEXP x, int srt, int no_na)
1999 
{
73472 luke 2000 
    switch(TYPEOF(x)) {
2001 
    case INTSXP:
2002 
    case REALSXP:
75501 luke 2003 
    case LGLSXP:
2004 
    case CPLXSXP:
2005 
    case RAWSXP:
83994 luke 2006 
    case STRSXP:
2007 
    case VECSXP: break;
75368 luke 2008 
    default: return x;
73472 luke 2009 
    }
74405 luke 2010 
 
75487 luke 2011 
    /* avoid wrappers of wrappers, at least in some cases */
75501 luke 2012 
    if (is_wrapper(x) && srt == UNKNOWN_SORTEDNESS && no_na == FALSE)
75487 luke 2013 
	return shallow_duplicate(x);
2014 
 
75366 luke 2015 
#ifndef WRAPATTRIB
73472 luke 2016 
    if (ATTRIB(x) != R_NilValue)
2017 
	/* For objects without references we could move the attributes
2018 
	   to the wrapper. For objects with references the attributes
2019 
	   would have to be shallow duplicated at least. The object/S4
2020 
	   bits would need to be moved as well.	*/
74405 luke 2021 
	/* For now, just return the original object. */
2022 
	return x;
75366 luke 2023 
#endif
73472 luke 2024 
 
74405 luke 2025 
    if (!KNOWN_SORTED(srt) && srt != KNOWN_UNSORTED &&
2026 
	srt != UNKNOWN_SORTEDNESS)
2027 
	error("srt must be -2, -1, 0, or +1, +2, or NA");
73472 luke 2028 
 
2029 
    if (no_na < 0 || no_na > 1)
2030 
	error("no_na must be 0 or +1");
2031 
 
2032 
    SEXP meta = allocVector(INTSXP, NMETA);
2033 
    INTEGER(meta)[0] = srt;
2034 
    INTEGER(meta)[1] = no_na;
2035 
 
2036 
    return make_wrapper(x, meta);
2037 
}
2038 
 
83446 ripley 2039 
attribute_hidden SEXP do_wrap_meta(SEXP call, SEXP op, SEXP args, SEXP env)
75484 luke 2040 
{
75499 luke 2041 
    checkArity(op, args);
75484 luke 2042 
    SEXP x = CAR(args);
2043 
    int srt = asInteger(CADR(args));
2044 
    int no_na = asInteger(CADDR(args));
2045 
    return wrap_meta(x, srt, no_na);
2046 
}
73472 luke 2047 
 
87901 ripley 2048 
/*attribute_hidden*/ SEXP R_tryWrap(SEXP x)
75494 luke 2049 
{
75501 luke 2050 
    return wrap_meta(x, UNKNOWN_SORTEDNESS, FALSE);
75494 luke 2051 
}
75484 luke 2052 
 
83446 ripley 2053 
attribute_hidden SEXP do_tryWrap(SEXP call, SEXP op, SEXP args, SEXP env)
75499 luke 2054 
{
2055 
    checkArity(op, args);
2056 
    SEXP x = CAR(args);
2057 
    return R_tryWrap(x);
2058 
}
75494 luke 2059 
 
75540 luke 2060 
/* When a wrapper has no useful meta-data, is no longer referenced
78113 kalibera 2061 
   anywhere, and its data is only accessible from the wrapper, then
75540 luke 2062 
   the wrapper can be unwrapped to its wrapped data, and its
2063 
   attributes can be transferred to the data.
75499 luke 2064 
 
75540 luke 2065 
   It is ESSENTIAL that the wrapper no longer be accessed after
2066 
   this function is called!
2067 
 
2068 
   This function can be used at the end of a complex assignment
2069 
   operation. It could be used in other places, but extreme caution is
84246 maechler 2070 
   needed to make sure there is no possibility that the wrapper object
75540 luke 2071 
   will be referenced from C code after it is cleared. */
83446 ripley 2072 
attribute_hidden SEXP R_tryUnwrap(SEXP x)
75540 luke 2073 
{
75592 luke 2074 
    if (! MAYBE_SHARED(x) && is_wrapper(x) &&
75540 luke 2075 
	WRAPPER_SORTED(x) == UNKNOWN_SORTEDNESS && ! WRAPPER_NO_NA(x)) {
2076 
	SEXP data = WRAPPER_WRAPPED(x);
2077 
	if (! MAYBE_SHARED(data)) {
2078 
	    SET_ATTRIB(data, ATTRIB(x));
2079 
	    SET_OBJECT(data, OBJECT(x));
2080 
	    IS_S4_OBJECT(x) ? SET_S4_OBJECT(data) : UNSET_S4_OBJECT(data);
2081 
 
2082 
	    /* Clear the fields to drop reference counts and set the
2083 
	       type to LISTSXP to limit errors in case the object is
2084 
	       still live. */
86615 luke 2085 
	    void ALTREP_SET_TYPEOF(SEXP, int); /* in memory.c */
2086 
	    ALTREP_SET_TYPEOF(x, LISTSXP);
2087 
	    SETALTREP(x, 0);
75540 luke 2088 
	    SET_ATTRIB(x, R_NilValue);
2089 
	    SETCAR(x, R_NilValue);
2090 
	    SETCDR(x, R_NilValue);
2091 
	    SET_TAG(x, R_NilValue);
75592 luke 2092 
	    SET_OBJECT(x, 0);
2093 
	    UNSET_S4_OBJECT(x);
75540 luke 2094 
	    /* NAMED should be zero */
2095 
 
2096 
	    return data;
2097 
	}
2098 
    }
2099 
    return x;
2100 
}
2101 
 
2102 
 
73472 luke 2103 
/**
2104 
 ** Initialize ALTREP Classes
2105 
 **/
2106 
 
83446 ripley 2107 
attribute_hidden void R_init_altrep(void)
73472 luke 2108 
{
2109 
    InitCompactIntegerClass();
2110 
    InitCompactRealClass();
2111 
    InitDefferredStringClass();
2112 
    InitMmapIntegerClass(NULL);
2113 
    InitMmapRealClass(NULL);
2114 
    InitWrapIntegerClass(NULL);
75491 luke 2115 
    InitWrapLogicalClass(NULL);
73472 luke 2116 
    InitWrapRealClass(NULL);
75492 luke 2117 
    InitWrapComplexClass(NULL);
75493 luke 2118 
    InitWrapRawClass(NULL);
73472 luke 2119 
    InitWrapStringClass(NULL);
83914 luke 2120 
    InitWrapListClass(NULL);
73472 luke 2121 
}