The R Project SVN R

Rev

Rev 87184 | Rev 87901 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 87184 Rev 87891
Line 1... Line 1...
1 
/*
 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
 2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  Copyright (C) 1997--2024  The R Core Team
 3 
 *  Copyright (C) 1997--2025  The R Core Team
4 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 4 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
5 
 *
 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
 6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
 7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
 8 
 *  the Free Software Foundation; either version 2 of the License, or
Line 747... Line 747...
747 
static SEXP
 747 
static SEXP
748 
integerSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch,
 748 
integerSubscript(SEXP s, R_xlen_t ns, R_xlen_t nx, R_xlen_t *stretch,
749 
		 SEXP call, SEXP x)
 749 
		 SEXP call, SEXP x)
750 
{
 750 
{
751 
    R_xlen_t i;
 751 
    R_xlen_t i;
752 
    int ii, neg, max, canstretch;
 752 
    int ii, max, canstretch;
753 
    Rboolean isna = FALSE;
 753 
    bool isna = false, neg = false;
754 
    canstretch = *stretch > 0;
 754 
    canstretch = *stretch > 0;
755 
    *stretch = 0;
 755 
    *stretch = 0;
756 
    neg = FALSE;
 - 
 
757 
    max = 0;
 756 
    max = 0;
758 
    const int *ps = INTEGER_RO(s);
 757 
    const int *ps = INTEGER_RO(s);
759 
    for (i = 0; i < ns; i++) {
 758 
    for (i = 0; i < ns; i++) {
760 
	ii = ps[i];
 759 
	ii = ps[i];
761 
	if (ii < 0) {
 760 
	if (ii < 0) {
762 
	    if (ii == NA_INTEGER)
 761 
	    if (ii == NA_INTEGER)
763 
		isna = TRUE;
 762 
		isna = true;
764 
	    else
 763 
	    else
765 
		neg = TRUE;
 764 
		neg = true;
766 
	}
 765 
	}
767 
	else if (ii > max)
 766 
	else if (ii > max)
768 
	    max = ii;
 767 
	    max = ii;
769 
    }
 768 
    }
770 
    if (max > nx) {
 769 
    if (max > nx) {
Line 789... Line 788...
789 
{
 788 
{
790 
    int canstretch = *stretch > 0;
 789 
    int canstretch = *stretch > 0;
791 
    *stretch = 0;
 790 
    *stretch = 0;
792 
    double min = 0, max = 0;
 791 
    double min = 0, max = 0;
793 
    const double *ps = REAL_RO(s);
 792 
    const double *ps = REAL_RO(s);
794 
    Rboolean isna = FALSE;
 793 
    bool isna = false;
795 
    for (R_xlen_t i = 0; i < ns; i++) {
 794 
    for (R_xlen_t i = 0; i < ns; i++) {
796 
	double ii = ps[i];
 795 
	double ii = ps[i];
797 
	if (R_FINITE(ii)) {
 796 
	if (R_FINITE(ii)) {
798 
	    if (ii < min) min = ii;
 797 
	    if (ii < min) min = ii;
799 
	    if (ii > max) max = ii;
 798 
	    if (ii > max) max = ii;
800 
	} else isna = TRUE;
 799 
	} else isna = true;
801 
    }
 800 
    }
802 
    if (max >= (double)nx+1.) {
 801 
    if (max >= (double)nx+1.) {
803 
#ifndef LONG_VECTOR_SUPPORT
 802 
#ifndef LONG_VECTOR_SUPPORT
804 
	if (max > INT_MAX) {
 803 
	if (max > INT_MAX) {
805 
	    ECALL(call, _("subscript too large for 32-bit R"));
 804 
	    ECALL(call, _("subscript too large for 32-bit R"));
Line 831... Line 830...
831 
	}
 830 
	}
832 
    } else {
 831 
    } else {
833 
	/* Only return a REALSXP index if we need to */
 832 
	/* Only return a REALSXP index if we need to */
834 
	SEXP indx;
 833 
	SEXP indx;
835 
	R_xlen_t i, cnt = 0;
 834 
	R_xlen_t i, cnt = 0;
836 
	Rboolean int_ok = TRUE;
 835 
	bool int_ok = true;
837 
	/* NB, indices will be truncated eventually,
 836 
	/* NB, indices will be truncated eventually,
838 
	   so need to do that to take '0' into account */
 837 
	   so need to do that to take '0' into account */
839 
	for (i = 0; i < ns; i++) {
 838 
	for (i = 0; i < ns; i++) {
840 
	    double ds = ps[i];
 839 
	    double ds = ps[i];
841 
#ifdef OLDCODE_LONG_VECTOR
 840 
#ifdef OLDCODE_LONG_VECTOR
842 
	    if (!R_FINITE(ds)) {
 841 
	    if (!R_FINITE(ds)) {
843 
		if (ds > INT_MAX) int_ok = FALSE;
 842 
		if (ds > INT_MAX) int_ok = false;
844 
		cnt++;
 843 
		cnt++;
845 
	    } else if ((R_xlen_t) ds != 0) cnt++;
 844 
	    } else if ((R_xlen_t) ds != 0) cnt++;
846 
#else
 845 
#else
847 
	    if (R_FINITE(ds) && ds > INT_MAX) int_ok = FALSE;
 846 
	    if (R_FINITE(ds) && ds > INT_MAX) int_ok = false;
848 
	    if (!R_FINITE(ds) || (R_xlen_t) ds != 0) cnt++;
 847 
	    if (!R_FINITE(ds) || (R_xlen_t) ds != 0) cnt++;
849 
#endif
 848 
#endif
850 
	}
 849 
	}
851 
	if (int_ok) {
 850 
	if (int_ok) {
852 
	    indx = allocVector(INTSXP, cnt);
 851 
	    indx = allocVector(INTSXP, cnt);
Line 892... Line 891...
892 
{
 891 
{
893 
    SEXP indx, indexnames = R_NilValue;
 892 
    SEXP indx, indexnames = R_NilValue;
894 
    R_xlen_t i, j, nnames, extra, sub;
 893 
    R_xlen_t i, j, nnames, extra, sub;
895 
    int canstretch = *stretch > 0;
 894 
    int canstretch = *stretch > 0;
896 
    /* product may overflow, so check factors as well. */
 895 
    /* product may overflow, so check factors as well. */
897 
    Rboolean usehashing = ( ((ns > 1000 && nx) || (nx > 1000 && ns)) || (ns * nx > 15*nx + ns) );
 896 
    bool usehashing = ( ((ns > 1000 && nx) || (nx > 1000 && ns)) || (ns * nx > 15*nx + ns) );
898 
    int nprotect = 0;
 897 
    int nprotect = 0;
899 
 
 898 
 
900 
    PROTECT(s);
 899 
    PROTECT(s);
901 
    PROTECT(names);
 900 
    PROTECT(names);
902 
    nprotect += 2;
 901 
    nprotect += 2;