/
altclasses.c
2042 lines (1710 loc) · 57 KB
/
altclasses.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/*
* R : A Computer Language for Statistical Data Analysis
* Copyright (C) 2016--2021 The R Core Team
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, a copy is available at
* https://www.R-project.org/Licenses/
*/
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <Defn.h>
#include <R_ext/Altrep.h>
#include <float.h> /* for DBL_DIG */
#include <Print.h> /* for R_print */
#include <R_ext/Itermacros.h>
#ifdef Win32
#include <trioremap.h> /* for %lld */
#endif
/***
*** ALTREP Concrete Class Implementations
***/
/**
** Compact Integer Sequences
**/
/*
* Methods
*/
#define COMPACT_SEQ_INFO(x) R_altrep_data1(x)
#define COMPACT_SEQ_EXPANDED(x) R_altrep_data2(x)
#define SET_COMPACT_SEQ_EXPANDED(x, v) R_set_altrep_data2(x, v)
/* needed for now for objects serialized with INTSXP state */
#define COMPACT_INTSEQ_SERIALIZED_STATE_LENGTH(info) \
(TYPEOF(info) == INTSXP ? INTEGER0(info)[0] : (R_xlen_t) REAL0(info)[0])
#define COMPACT_INTSEQ_SERIALIZED_STATE_FIRST(info) \
(TYPEOF(info) == INTSXP ? INTEGER0(info)[1] : (int) REAL0(info)[1])
#define COMPACT_INTSEQ_SERIALIZED_STATE_INCR(info) \
(TYPEOF(info) == INTSXP ? INTEGER0(info)[2] : (int) REAL0(info)[2])
/* info is stored as REALSXP to allow for long vector length */
#define COMPACT_INTSEQ_INFO_LENGTH(info) ((R_xlen_t) REAL0(info)[0])
#define COMPACT_INTSEQ_INFO_FIRST(info) ((int) REAL0(info)[1])
#define COMPACT_INTSEQ_INFO_INCR(info) ((int) REAL0(info)[2])
/* By default, compact integer sequences are marked as not mutable at
creation time. Thus even when expanded the expanded data will
correspond to the original integer sequence (unless it runs into
mis-behaving C code). If COMPACT_INTSEQ_MUTABLE is defined, then
the sequence is not marked as not mutable. Once the DATAPTR has
been requested and releases, the expanded data might be modified by
an assignment and no longer correspond to the original sequence. */
//#define COMPACT_INTSEQ_MUTABLE
static SEXP compact_intseq_Serialized_state(SEXP x)
{
#ifdef COMPACT_INTSEQ_MUTABLE
/* This drops through to standard serialization for expanded
compact vectors */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return NULL;
#endif
return COMPACT_SEQ_INFO(x);
}
static SEXP new_compact_intseq(R_xlen_t, int, int);
static SEXP new_compact_realseq(R_xlen_t, double, double);
static SEXP compact_intseq_Unserialize(SEXP class, SEXP state)
{
R_xlen_t n = COMPACT_INTSEQ_SERIALIZED_STATE_LENGTH(state);
int n1 = COMPACT_INTSEQ_SERIALIZED_STATE_FIRST(state);
int inc = COMPACT_INTSEQ_SERIALIZED_STATE_INCR(state);
if (inc == 1)
return new_compact_intseq(n, n1, 1);
else if (inc == -1)
return new_compact_intseq(n, n1, -1);
else
error("compact sequences with increment %d not supported yet", inc);
}
static SEXP compact_intseq_Coerce(SEXP x, int type)
{
#ifdef COMPACT_INTSEQ_MUTABLE
/* This drops through to standard coercion for expanded compact
vectors */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return NULL;
#endif
if (type == REALSXP) {
SEXP info = COMPACT_SEQ_INFO(x);
R_xlen_t n = COMPACT_INTSEQ_INFO_LENGTH(info);
int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
int inc = COMPACT_INTSEQ_INFO_INCR(info);
return new_compact_realseq(n, n1, inc);
}
else return NULL;
}
static SEXP compact_intseq_Duplicate(SEXP x, Rboolean deep)
{
R_xlen_t n = XLENGTH(x);
SEXP val = allocVector(INTSXP, n);
INTEGER_GET_REGION(x, 0, n, INTEGER0(val));
return val;
}
static
Rboolean compact_intseq_Inspect(SEXP x, int pre, int deep, int pvec,
void (*inspect_subtree)(SEXP, int, int, int))
{
int inc = COMPACT_INTSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
if (inc != 1 && inc != -1)
error("compact sequences with increment %d not supported yet", inc);
#ifdef COMPACT_INTSEQ_MUTABLE
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue) {
Rprintf(" <expanded compact integer sequence>\n");
inspect_subtree(COMPACT_SEQ_EXPANDED(x), pre, deep, pvec);
return TRUE;
}
#endif
R_xlen_t n = XLENGTH(x); // int .. LENGTH(.) not ok, e.g. for -1e9:2e9
int n1 = INTEGER_ELT(x, 0);
int n2 = (int) ((inc == 1) ? n1 + n - 1 : n1 - n + 1);
Rprintf(" %d : %d (%s)", n1, n2,
COMPACT_SEQ_EXPANDED(x) == R_NilValue ? "compact" : "expanded");
Rprintf("\n");
return TRUE;
}
static R_INLINE R_xlen_t compact_intseq_Length(SEXP x)
{
SEXP info = COMPACT_SEQ_INFO(x);
return COMPACT_INTSEQ_INFO_LENGTH(info);
}
static void *compact_intseq_Dataptr(SEXP x, Rboolean writeable)
{
if (COMPACT_SEQ_EXPANDED(x) == R_NilValue) {
/* no need to re-run if expanded data exists */
PROTECT(x);
SEXP info = COMPACT_SEQ_INFO(x);
R_xlen_t n = COMPACT_INTSEQ_INFO_LENGTH(info);
int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
int inc = COMPACT_INTSEQ_INFO_INCR(info);
SEXP val = allocVector(INTSXP, n);
int *data = INTEGER(val);
if (inc == 1) {
/* compact sequences n1 : n2 with n1 <= n2 */
for (R_xlen_t i = 0; i < n; i++)
data[i] = (int) (n1 + i);
}
else if (inc == -1) {
/* compact sequences n1 : n2 with n1 > n2 */
for (R_xlen_t i = 0; i < n; i++)
data[i] = (int) (n1 - i);
}
else
error("compact sequences with increment %d not supported yet", inc);
SET_COMPACT_SEQ_EXPANDED(x, val);
UNPROTECT(1);
}
return DATAPTR(COMPACT_SEQ_EXPANDED(x));
}
static const void *compact_intseq_Dataptr_or_null(SEXP x)
{
SEXP val = COMPACT_SEQ_EXPANDED(x);
return val == R_NilValue ? NULL : DATAPTR(val);
}
static int compact_intseq_Elt(SEXP x, R_xlen_t i)
{
SEXP ex = COMPACT_SEQ_EXPANDED(x);
if (ex != R_NilValue)
return INTEGER0(ex)[i];
else {
SEXP info = COMPACT_SEQ_INFO(x);
int n1 = COMPACT_INTSEQ_INFO_FIRST(info);
int inc = COMPACT_INTSEQ_INFO_INCR(info);
return (int) (n1 + inc * i);
}
}
#define CHECK_NOT_EXPANDED(x) \
if (DATAPTR_OR_NULL(x) != NULL) \
error("method should only handle unexpanded vectors")
static R_xlen_t
compact_intseq_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, int *buf)
{
/* should not get here if x is already expanded */
CHECK_NOT_EXPANDED(sx);
SEXP info = COMPACT_SEQ_INFO(sx);
R_xlen_t size = COMPACT_INTSEQ_INFO_LENGTH(info);
R_xlen_t n1 = COMPACT_INTSEQ_INFO_FIRST(info);
int inc = COMPACT_INTSEQ_INFO_INCR(info);
R_xlen_t ncopy = size - i > n ? n : size - i;
if (inc == 1) {
for (R_xlen_t k = 0; k < ncopy; k++)
buf[k] = (int) (n1 + k + i);
return ncopy;
}
else if (inc == -1) {
for (R_xlen_t k = 0; k < ncopy; k++)
buf[k] = (int) (n1 - k - i);
return ncopy;
}
else
error("compact sequences with increment %d not supported yet", inc);
}
static int compact_intseq_Is_sorted(SEXP x)
{
#ifdef COMPACT_INTSEQ_MUTABLE
/* If the vector has been expanded it may have been modified. */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return UNKNOWN_SORTEDNESS;
#endif
int inc = COMPACT_INTSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
return inc < 0 ? SORTED_DECR : SORTED_INCR;
}
static int compact_intseq_No_NA(SEXP x)
{
#ifdef COMPACT_INTSEQ_MUTABLE
/* If the vector has been expanded it may have been modified. */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return FALSE;
#endif
return TRUE;
}
/* XXX this also appears in summary.c. move to header file?*/
#define R_INT_MIN (1 + INT_MIN)
static SEXP compact_intseq_Sum(SEXP x, Rboolean narm)
{
#ifdef COMPACT_INTSEQ_MUTABLE
/* If the vector has been expanded it may have been modified. */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return NULL;
#endif
double tmp;
SEXP info = COMPACT_SEQ_INFO(x);
R_xlen_t size = COMPACT_INTSEQ_INFO_LENGTH(info);
R_xlen_t n1 = COMPACT_INTSEQ_INFO_FIRST(info);
int inc = COMPACT_INTSEQ_INFO_INCR(info);
tmp = (size / 2.0) * (n1 + n1 + inc * (size - 1));
if(tmp > INT_MAX || tmp < R_INT_MIN)
/**** check for overflow of exact integer range? */
return ScalarReal(tmp);
else
return ScalarInteger((int) tmp);
}
/*
* Class Objects and Method Tables
*/
R_altrep_class_t R_compact_intseq_class;
static void InitCompactIntegerClass(void)
{
R_altrep_class_t cls = R_make_altinteger_class("compact_intseq", "base",
NULL);
R_compact_intseq_class = cls;
/* override ALTREP methods */
R_set_altrep_Unserialize_method(cls, compact_intseq_Unserialize);
R_set_altrep_Serialized_state_method(cls, compact_intseq_Serialized_state);
R_set_altrep_Duplicate_method(cls, compact_intseq_Duplicate);
R_set_altrep_Coerce_method(cls, compact_intseq_Coerce);
R_set_altrep_Inspect_method(cls, compact_intseq_Inspect);
R_set_altrep_Length_method(cls, compact_intseq_Length);
/* override ALTVEC methods */
R_set_altvec_Dataptr_method(cls, compact_intseq_Dataptr);
R_set_altvec_Dataptr_or_null_method(cls, compact_intseq_Dataptr_or_null);
/* override ALTINTEGER methods */
R_set_altinteger_Elt_method(cls, compact_intseq_Elt);
R_set_altinteger_Get_region_method(cls, compact_intseq_Get_region);
R_set_altinteger_Is_sorted_method(cls, compact_intseq_Is_sorted);
R_set_altinteger_No_NA_method(cls, compact_intseq_No_NA);
R_set_altinteger_Sum_method(cls, compact_intseq_Sum);
}
/*
* Constructor
*/
static SEXP new_compact_intseq(R_xlen_t n, int n1, int inc)
{
if (n == 1) return ScalarInteger(n1);
if (inc != 1 && inc != -1)
error("compact sequences with increment %d not supported yet", inc);
/* info used REALSXP to allow for long vectors */
SEXP info = allocVector(REALSXP, 3);
REAL0(info)[0] = (double) n;
REAL0(info)[1] = (double) n1;
REAL0(info)[2] = (double) inc;
SEXP ans = R_new_altrep(R_compact_intseq_class, info, R_NilValue);
#ifndef COMPACT_INTSEQ_MUTABLE
MARK_NOT_MUTABLE(ans); /* force duplicate on modify */
#endif
return ans;
}
/**
** Compact Real Sequences
**/
/*
* Methods
*/
#define COMPACT_REALSEQ_INFO_LENGTH(info) ((R_xlen_t) REAL0(info)[0])
#define COMPACT_REALSEQ_INFO_FIRST(info) REAL0(info)[1]
#define COMPACT_REALSEQ_INFO_INCR(info) REAL0(info)[2]
static SEXP compact_realseq_Serialized_state(SEXP x)
{
return COMPACT_SEQ_INFO(x);
}
static SEXP compact_realseq_Unserialize(SEXP class, SEXP state)
{
double inc = COMPACT_REALSEQ_INFO_INCR(state);
R_xlen_t len = COMPACT_REALSEQ_INFO_LENGTH(state);
double n1 = COMPACT_REALSEQ_INFO_FIRST(state);
if (inc == 1)
return new_compact_realseq(len, n1, 1);
else if (inc == -1)
return new_compact_realseq(len, n1, -1);
else
error("compact sequences with increment %f not supported yet", inc);
}
static SEXP compact_realseq_Duplicate(SEXP x, Rboolean deep)
{
R_xlen_t n = XLENGTH(x);
SEXP val = allocVector(REALSXP, n);
REAL_GET_REGION(x, 0, n, REAL0(val));
return val;
}
static
Rboolean compact_realseq_Inspect(SEXP x, int pre, int deep, int pvec,
void (*inspect_subtree)(SEXP, int, int, int))
{
double inc = COMPACT_REALSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
if (inc != 1 && inc != -1)
error("compact sequences with increment %f not supported yet", inc);
R_xlen_t n = XLENGTH(x);
R_xlen_t n1 = (R_xlen_t) REAL_ELT(x, 0);
R_xlen_t n2 = inc == 1 ? n1 + n - 1 : n1 - n + 1;
Rprintf(" %lld : %lld (%s)", n1, n2,
COMPACT_SEQ_EXPANDED(x) == R_NilValue ? "compact" : "expanded");
Rprintf("\n");
return TRUE;
}
static R_INLINE R_xlen_t compact_realseq_Length(SEXP x)
{
return (R_xlen_t) REAL0(COMPACT_SEQ_INFO(x))[0];
}
static void *compact_realseq_Dataptr(SEXP x, Rboolean writeable)
{
if (COMPACT_SEQ_EXPANDED(x) == R_NilValue) {
PROTECT(x);
SEXP info = COMPACT_SEQ_INFO(x);
R_xlen_t n = COMPACT_REALSEQ_INFO_LENGTH(info);
double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
double inc = COMPACT_REALSEQ_INFO_INCR(info);
SEXP val = allocVector(REALSXP, (R_xlen_t) n);
double *data = REAL(val);
if (inc == 1) {
/* compact sequences n1 : n2 with n1 <= n2 */
for (R_xlen_t i = 0; i < n; i++)
data[i] = n1 + i;
}
else if (inc == -1) {
/* compact sequences n1 : n2 with n1 > n2 */
for (R_xlen_t i = 0; i < n; i++)
data[i] = n1 - i;
}
else
error("compact sequences with increment %f not supported yet", inc);
SET_COMPACT_SEQ_EXPANDED(x, val);
UNPROTECT(1);
}
return DATAPTR(COMPACT_SEQ_EXPANDED(x));
}
static const void *compact_realseq_Dataptr_or_null(SEXP x)
{
SEXP val = COMPACT_SEQ_EXPANDED(x);
return val == R_NilValue ? NULL : DATAPTR(val);
}
static double compact_realseq_Elt(SEXP x, R_xlen_t i)
{
SEXP ex = COMPACT_SEQ_EXPANDED(x);
if (ex != R_NilValue)
return REAL0(ex)[i];
else {
SEXP info = COMPACT_SEQ_INFO(x);
double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
double inc = COMPACT_REALSEQ_INFO_INCR(info);
return n1 + inc * i;
}
}
static R_xlen_t
compact_realseq_Get_region(SEXP sx, R_xlen_t i, R_xlen_t n, double *buf)
{
/* should not get here if x is already expanded */
CHECK_NOT_EXPANDED(sx);
SEXP info = COMPACT_SEQ_INFO(sx);
R_xlen_t size = COMPACT_REALSEQ_INFO_LENGTH(info);
double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
double inc = COMPACT_REALSEQ_INFO_INCR(info);
R_xlen_t ncopy = size - i > n ? n : size - i;
if (inc == 1) {
for (R_xlen_t k = 0; k < ncopy; k++)
buf[k] = n1 + k + i;
return ncopy;
}
else if (inc == -1) {
for (R_xlen_t k = 0; k < ncopy; k++)
buf[k] = n1 - k - i;
return ncopy;
}
else
error("compact sequences with increment %f not supported yet", inc);
}
static int compact_realseq_Is_sorted(SEXP x)
{
#ifdef COMPACT_REALSEQ_MUTABLE
/* If the vector has been expanded it may have been modified. */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return UNKNOWN_SORTEDNESS;
#endif
double inc = COMPACT_REALSEQ_INFO_INCR(COMPACT_SEQ_INFO(x));
return inc < 0 ? SORTED_DECR : SORTED_INCR;
}
static int compact_realseq_No_NA(SEXP x)
{
#ifdef COMPACT_REALSEQ_MUTABLE
/* If the vector has been expanded it may have been modified. */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return FALSE;
#endif
return TRUE;
}
static SEXP compact_realseq_Sum(SEXP x, Rboolean narm)
{
#ifdef COMPACT_INTSEQ_MUTABLE
/* If the vector has been expanded it may have been modified. */
if (COMPACT_SEQ_EXPANDED(x) != R_NilValue)
return NULL;
#endif
SEXP info = COMPACT_SEQ_INFO(x);
double size = (double) COMPACT_REALSEQ_INFO_LENGTH(info);
double n1 = COMPACT_REALSEQ_INFO_FIRST(info);
double inc = COMPACT_REALSEQ_INFO_INCR(info);
return ScalarReal((size / 2.0) *(n1 + n1 + inc * (size - 1)));
}
/*
* Class Objects and Method Tables
*/
R_altrep_class_t R_compact_realseq_class;
static void InitCompactRealClass(void)
{
R_altrep_class_t cls = R_make_altreal_class("compact_realseq", "base",
NULL);
R_compact_realseq_class = cls;
/* override ALTREP methods */
R_set_altrep_Unserialize_method(cls, compact_realseq_Unserialize);
R_set_altrep_Serialized_state_method(cls, compact_realseq_Serialized_state);
R_set_altrep_Duplicate_method(cls, compact_realseq_Duplicate);
R_set_altrep_Inspect_method(cls, compact_realseq_Inspect);
R_set_altrep_Length_method(cls, compact_realseq_Length);
/* override ALTVEC methods */
R_set_altvec_Dataptr_method(cls, compact_realseq_Dataptr);
R_set_altvec_Dataptr_or_null_method(cls, compact_realseq_Dataptr_or_null);
/* override ALTREAL methods */
R_set_altreal_Elt_method(cls, compact_realseq_Elt);
R_set_altreal_Get_region_method(cls, compact_realseq_Get_region);
R_set_altreal_Is_sorted_method(cls, compact_realseq_Is_sorted);
R_set_altreal_No_NA_method(cls, compact_realseq_No_NA);
R_set_altreal_Sum_method(cls, compact_realseq_Sum);
}
/*
* Constructor
*/
static SEXP new_compact_realseq(R_xlen_t n, double n1, double inc)
{
if (n == 1) return ScalarReal(n1);
if (inc != 1 && inc != -1)
error("compact sequences with increment %f not supported yet", inc);
SEXP info = allocVector(REALSXP, 3);
REAL(info)[0] = n;
REAL(info)[1] = n1;
REAL(info)[2] = inc;
SEXP ans = R_new_altrep(R_compact_realseq_class, info, R_NilValue);
MARK_NOT_MUTABLE(ans); /* force duplicate on modify */
return ans;
}
/**
** Compact Integer/Real Sequences
**/
attribute_hidden SEXP R_compact_intrange(R_xlen_t n1, R_xlen_t n2)
{
R_xlen_t n = n1 <= n2 ? n2 - n1 + 1 : n1 - n2 + 1;
if (n >= R_XLEN_T_MAX)
error("result would be too long a vector");
if (n1 <= INT_MIN || n1 > INT_MAX || n2 <= INT_MIN || n2 > INT_MAX)
return new_compact_realseq(n, n1, n1 <= n2 ? 1 : -1);
else
return new_compact_intseq(n, (int) n1, n1 <= n2 ? 1 : -1);
}
/**
** Deferred String Coercions
**/
/*
* Methods
*/
#define DEFERRED_STRING_STATE(x) R_altrep_data1(x)
#define CLEAR_DEFERRED_STRING_STATE(x) R_set_altrep_data1(x, R_NilValue)
#define DEFERRED_STRING_EXPANDED(x) R_altrep_data2(x)
#define SET_DEFERRED_STRING_EXPANDED(x, v) R_set_altrep_data2(x, v)
#define MAKE_DEFERRED_STRING_STATE(v, sp) CONS(v, sp)
#define DEFERRED_STRING_STATE_ARG(s) CAR(s)
#define DEFERRED_STRING_STATE_INFO(s) CDR(s)
#define DEFERRED_STRING_ARG(x) \
DEFERRED_STRING_STATE_ARG(DEFERRED_STRING_STATE(x))
#define DEFERRED_STRING_INFO(x) \
DEFERRED_STRING_STATE_INFO(DEFERRED_STRING_STATE(x))
#define DEFERRED_STRING_SCIPEN(x) \
INTEGER0(DEFERRED_STRING_STATE_INFO(DEFERRED_STRING_STATE(x)))[0]
/* work-around for package code that mutates things it shouldn't and
makes serialize and inspect infinite-loop */
#define DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state) do { \
if (state != R_NilValue && ATTRIB(CAR(state)) != R_NilValue) { \
SETCAR(state, shallow_duplicate(CAR(state))); \
SET_ATTRIB(CAR(state), R_NilValue); \
} \
} while (0)
static SEXP R_OutDecSym = NULL;
static R_INLINE const char *DEFERRED_STRING_OUTDEC(SEXP x)
{
/* The default value of OutDec at startup is ".". If it is
something different at the time the deferred string conversion
is created then the current value is stored as an attribute. */
if (R_OutDecSym == NULL)
R_OutDecSym = install("OutDec");
SEXP info = DEFERRED_STRING_INFO(x);
if (ATTRIB(info) != R_NilValue) {
SEXP outdecattr = getAttrib(info, R_OutDecSym);
if (TYPEOF(outdecattr) == STRSXP && XLENGTH(outdecattr) == 1)
return CHAR(STRING_ELT(outdecattr, 0));
}
return ".";
}
static SEXP deferred_string_Serialized_state(SEXP x)
{
/* This drops through to standard serialization for fully expanded
deferred string conversions. Partial expansions are OK since
they still correspond to the original data. An assignment to
the object will access the DATAPTR and force a full expansion
and dropping the original data. */
SEXP state = DEFERRED_STRING_STATE(x);
DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state);
return state != R_NilValue ? state : NULL;
}
static SEXP deferred_string_Unserialize(SEXP class, SEXP state)
{
SEXP arg = DEFERRED_STRING_STATE_ARG(state);
SEXP info = DEFERRED_STRING_STATE_INFO(state);
return R_deferred_coerceToString(arg, info);
}
static
Rboolean deferred_string_Inspect(SEXP x, int pre, int deep, int pvec,
void (*inspect_subtree)(SEXP, int, int, int))
{
SEXP state = DEFERRED_STRING_STATE(x);
if (state != R_NilValue) {
DEFERRED_STRING_FIXUP_ARG_ATTRIBS(state);
SEXP arg = DEFERRED_STRING_STATE_ARG(state);
Rprintf(" <deferred string conversion>\n");
inspect_subtree(arg, pre, deep, pvec);
}
else {
Rprintf(" <expanded string conversion>\n");
inspect_subtree(DEFERRED_STRING_EXPANDED(x), pre, deep, pvec);
}
return TRUE;
}
static R_INLINE R_xlen_t deferred_string_Length(SEXP x)
{
SEXP state = DEFERRED_STRING_STATE(x);
return state == R_NilValue ?
XLENGTH(DEFERRED_STRING_EXPANDED(x)) :
XLENGTH(DEFERRED_STRING_STATE_ARG(state));
}
static R_INLINE SEXP ExpandDeferredStringElt(SEXP x, R_xlen_t i)
{
/* make sure the STRSXP for the expanded string is allocated */
/* not yet expanded strings are NULL in the STRSXP */
SEXP val = DEFERRED_STRING_EXPANDED(x);
if (val == R_NilValue) {
R_xlen_t n = XLENGTH(x);
val = allocVector(STRSXP, n);
memset(STDVEC_DATAPTR(val), 0, n * sizeof(SEXP));
SET_DEFERRED_STRING_EXPANDED(x, val);
}
SEXP elt = STRING_ELT(val, i);
if (elt == NULL) {
int warn; /* not used by the coercion functions */
int savedigits, savescipen;
SEXP data = DEFERRED_STRING_ARG(x);
switch(TYPEOF(data)) {
case INTSXP:
elt = StringFromInteger(INTEGER_ELT(data, i), &warn);
break;
case REALSXP:
savedigits = R_print.digits;
savescipen = R_print.scipen;
R_print.digits = DBL_DIG;/* MAX precision */
R_print.scipen = DEFERRED_STRING_SCIPEN(x);
const char *myoutdec = DEFERRED_STRING_OUTDEC(x);
if (strcmp(OutDec, myoutdec)) {
/* The current and saved OutDec values differ. The
value to use is put in a static buffer and OutDec
temporarily points to this buffer while
StringFromReal is called and then reset. The buffer
originally pointed to by OutDec cannot be used as
it wil not be writable if the default "." has not
been changed. */
static char buf[10];
strncpy(buf, myoutdec, sizeof buf);
buf[sizeof(buf) - 1] = '\0';
char *savedOutDec = OutDec;
OutDec = buf;
elt = StringFromReal(REAL_ELT(data, i), &warn);
OutDec = savedOutDec;
}
else
elt = StringFromReal(REAL_ELT(data, i), &warn);
R_print.digits = savedigits;
R_print.scipen = savescipen;
break;
default:
error("unsupported type for deferred string coercion");
}
SET_STRING_ELT(val, i, elt);
}
return elt;
}
static R_INLINE void expand_deferred_string(SEXP x)
{
SEXP state = DEFERRED_STRING_STATE(x);
if (state != R_NilValue) {
/* expanded data may be incomplete until original data is removed */
PROTECT(x);
R_xlen_t n = XLENGTH(x), i;
if (n == 0)
SET_DEFERRED_STRING_EXPANDED(x, allocVector(STRSXP, 0));
else
for (i = 0; i < n; i++)
ExpandDeferredStringElt(x, i);
CLEAR_DEFERRED_STRING_STATE(x); /* allow arg to be reclaimed */
UNPROTECT(1);
}
}
static void *deferred_string_Dataptr(SEXP x, Rboolean writeable)
{
expand_deferred_string(x);
return DATAPTR(DEFERRED_STRING_EXPANDED(x));
}
static const void *deferred_string_Dataptr_or_null(SEXP x)
{
SEXP state = DEFERRED_STRING_STATE(x);
return state != R_NilValue ? NULL : DATAPTR(DEFERRED_STRING_EXPANDED(x));
}
static SEXP deferred_string_Elt(SEXP x, R_xlen_t i)
{
SEXP state = DEFERRED_STRING_STATE(x);
if (state == R_NilValue)
/* string is fully expanded */
return STRING_ELT(DEFERRED_STRING_EXPANDED(x), i);
else {
/* expand only the requested element */
PROTECT(x);
SEXP elt = ExpandDeferredStringElt(x, i);
UNPROTECT(1);
return elt;
}
}
static void deferred_string_Set_elt(SEXP x, R_xlen_t i, SEXP v)
{
expand_deferred_string(x);
SET_STRING_ELT(DEFERRED_STRING_EXPANDED(x), i, v);
}
static int deferred_string_Is_sorted(SEXP x)
{
/* same as the default method; sortedness of the numeric is not relevant */
return UNKNOWN_SORTEDNESS;
}
static int deferred_string_No_NA(SEXP x)
{
SEXP state = DEFERRED_STRING_STATE(x);
if (state == R_NilValue)
/* string is fully expanded and may have been modified. */
return FALSE;
else {
/* defer to the argument */
SEXP arg = DEFERRED_STRING_STATE_ARG(state);
switch(TYPEOF(arg)) {
case INTSXP: return INTEGER_NO_NA(arg);
case REALSXP: return REAL_NO_NA(arg);
default: return FALSE;
}
}
}
static SEXP deferred_string_Extract_subset(SEXP x, SEXP indx, SEXP call)
{
SEXP result = NULL;
if (! OBJECT(x) && ATTRIB(x) == R_NilValue &&
DEFERRED_STRING_STATE(x) != R_NilValue) {
/* For deferred string coercions, create a new conversion
using the subset of the argument. Could try to
preserve/share coercions already done, if there are any. */
SEXP data = DEFERRED_STRING_ARG(x);
SEXP info = DEFERRED_STRING_INFO(x);
PROTECT(result = ExtractSubset(data, indx, call));
result = R_deferred_coerceToString(result, info);
UNPROTECT(1);
return result;
}
return result;
}
/*
* Class Object and Method Table
*/
static R_altrep_class_t R_deferred_string_class;
static void InitDefferredStringClass(void)
{
R_altrep_class_t cls = R_make_altstring_class("deferred_string", "base",
NULL);
R_deferred_string_class = cls;
/* override ALTREP methods */
R_set_altrep_Unserialize_method(cls, deferred_string_Unserialize);
R_set_altrep_Serialized_state_method(cls, deferred_string_Serialized_state);
R_set_altrep_Inspect_method(cls, deferred_string_Inspect);
R_set_altrep_Length_method(cls, deferred_string_Length);
/* override ALTVEC methods */
R_set_altvec_Dataptr_method(cls, deferred_string_Dataptr);
R_set_altvec_Dataptr_or_null_method(cls, deferred_string_Dataptr_or_null);
R_set_altvec_Extract_subset_method(cls, deferred_string_Extract_subset);
/* override ALTSTRING methods */
R_set_altstring_Elt_method(cls, deferred_string_Elt);
R_set_altstring_Set_elt_method(cls, deferred_string_Set_elt);
R_set_altstring_Is_sorted_method(cls, deferred_string_Is_sorted);
R_set_altstring_No_NA_method(cls, deferred_string_No_NA);
}
/*
* Constructor
*/
attribute_hidden SEXP R_deferred_coerceToString(SEXP v, SEXP info)
{
SEXP ans = R_NilValue;
switch (TYPEOF(v)) {
case INTSXP:
case REALSXP:
PROTECT(v); /* may not be needed, but to be safe ... */
if (info == NULL) {
PrintDefaults(); /* to set R_print from options */
info = ScalarInteger(R_print.scipen);
if (strcmp(OutDec, ".")) {
/* non-default OutDec setting -- attach as an attribute */
PROTECT(info);
if (R_OutDecSym == NULL)
R_OutDecSym = install("OutDec");
setAttrib(info, R_OutDecSym, GetOption1(R_OutDecSym));
UNPROTECT(1); /* info */
}
}
MARK_NOT_MUTABLE(v); /* make sure it can't change once captured */
ans = PROTECT(MAKE_DEFERRED_STRING_STATE(v, info));
ans = R_new_altrep(R_deferred_string_class, ans, R_NilValue);
UNPROTECT(2); /* ans, v */
break;
default:
error("unsupported type for deferred string coercion");
}
return ans;
}
/**
** Memory Mapped Vectors
**/
/* For now, this code is designed to work both in base R and in a
package. Some simplifications would be possible if it was only to
be used in base. in particular, the issue of finalizing objects
before unloading the library would not need to be addressed, and
ordinary finalizers in the external pointers could be used instead
of maintaining a weak reference list of the live mmap objects. */
/*
* MMAP Object State
*/
/* State is held in a LISTSXP of length 3, and includes
file
size and length in a REALSXP
type, ptrOK, wrtOK, serOK in an INTSXP
These are used by the methods, and also represent the serialized
state object.
*/
#ifndef Win32
static SEXP make_mmap_state(SEXP file, size_t size, int type,
Rboolean ptrOK, Rboolean wrtOK, Rboolean serOK)
{
SEXP sizes = PROTECT(allocVector(REALSXP, 2));
double *dsizes = REAL(sizes);
dsizes[0] = size;
switch(type) {
case INTSXP: dsizes[1] = size / sizeof(int); break;
case REALSXP: dsizes[1] = size / sizeof(double); break;
default: error("mmap for %s not supported yet", type2char(type));
}
SEXP info = PROTECT(allocVector(INTSXP, 4));
INTEGER(info)[0] = type;
INTEGER(info)[1] = ptrOK;
INTEGER(info)[2] = wrtOK;
INTEGER(info)[3] = serOK;
SEXP state = list3(file, sizes, info);
UNPROTECT(2);
return state;
}
#endif
#define MMAP_STATE_FILE(x) CAR(x)
#define MMAP_STATE_SIZE(x) ((size_t) REAL_ELT(CADR(x), 0))
#define MMAP_STATE_LENGTH(x) ((size_t) REAL_ELT(CADR(x), 1))
#define MMAP_STATE_TYPE(x) INTEGER(CADDR(x))[0]
#define MMAP_STATE_PTROK(x) INTEGER(CADDR(x))[1]
#define MMAP_STATE_WRTOK(x) INTEGER(CADDR(x))[2]
#define MMAP_STATE_SEROK(x) INTEGER(CADDR(x))[3]
/*
* MMAP Classes and Objects
*/
static R_altrep_class_t mmap_integer_class;
static R_altrep_class_t mmap_real_class;
/* MMAP objects are ALTREP objects with data fields
data1: an external pointer to the mmaped address
data2: the MMAP object's state
The state is also stored in the Protected field of the external
pointer for use by the finalizer.
*/
#ifndef Win32
static void register_mmap_eptr(SEXP eptr);
static SEXP make_mmap(void *p, SEXP file, size_t size, int type,
Rboolean ptrOK, Rboolean wrtOK, Rboolean serOK)
{
SEXP state = PROTECT(make_mmap_state(file, size,
type, ptrOK, wrtOK, serOK));
SEXP eptr = PROTECT(R_MakeExternalPtr(p, R_NilValue, state));
register_mmap_eptr(eptr);
R_altrep_class_t class;
switch(type) {
case INTSXP:
class = mmap_integer_class;
break;
case REALSXP:
class = mmap_real_class;
break;
default: error("mmap for %s not supported yet", type2char(type));
}
SEXP ans = R_new_altrep(class, eptr, state);
if (ptrOK && ! wrtOK)
MARK_NOT_MUTABLE(ans);