The R Project SVN R

Rev

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