Index: src/library/base/R/iterators.R =================================================================== --- src/library/base/R/iterators.R (revision 0) +++ src/library/base/R/iterators.R (revision 0) @@ -0,0 +1,36 @@ +# File src/library/base/R/iterators.R +# Part of the R package, http://www.R-project.org +# +# 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. +# +# A copy of the GNU General Public License is available at +# http://www.r-project.org/Licenses/ + +is.iterable <- function( x ){ + UseMethod("is.iterable") +} +is.iterable.default <- function(x) FALSE + +iterator <- function( x ){ + UseMethod( "iterator" ) +} +iterator.default <- function( x ) NULL + +hasNext <- function( x ){ + UseMethod("hasNext") +} +hasNext.default <- function(x) FALSE + +getNext <- function( x ){ + UseMethod( "getNext" ) +} +getNext.default <- function( x ) NULL + Index: src/main/eval.c =================================================================== --- src/main/eval.c (revision 50053) +++ src/main/eval.c (working copy) @@ -1025,15 +1025,67 @@ do_browser(call, op, R_NilValue, rho); \ } } while (0) +Rboolean isIterable( SEXP object, SEXP rho){ + SEXP expr ; + SEXP ans ; + Rboolean res ; + /* this probably should use DispatchOrEval */ + PROTECT( expr = lang2(install("is.iterable"), object )); + PROTECT( ans = eval( expr, rho ) ) ; + res = asLogicalNoNA(ans, expr) ; + UNPROTECT(2) ; + return res ; +} +Rboolean hasNext( SEXP object, SEXP rho){ + SEXP expr ; + SEXP ans ; + Rboolean res ; + /* this probably should use DispatchOrEval */ + PROTECT( expr = lang2(install("hasNext"), object )); + PROTECT( ans = eval( expr, rho ) ) ; + res = asLogicalNoNA(ans, expr) ; + UNPROTECT(2) ; + return res ; +} + +SEXP getNext( SEXP object, SEXP rho){ + SEXP expr, ans ; + /* this probably should use DispatchOrEval */ + PROTECT( expr = lang2(install("getNext"), object )); + PROTECT( ans =eval( expr, rho ) ) ; + UNPROTECT( 2) ; + return ans ; +} + +SEXP iterator(SEXP object, SEXP rho){ + SEXP expr ; + SEXP ans ; + /* this probably should use DispatchOrEval */ + PROTECT( expr = lang2(install("iterator"), object )); + PROTECT( ans = eval( expr, rho ) ) ; + UNPROTECT(2) ; + return ans ; +} + +SEXP asList( SEXP object, SEXP rho ){ + SEXP expr, ans ; + /* this probably should use DispatchOrEval */ + PROTECT( expr = lang2(install("as.list"), object )); + PROTECT( ans =eval( expr, rho ) ) ; + UNPROTECT( 2) ; + return ans ; +} + + SEXP attribute_hidden do_for(SEXP call, SEXP op, SEXP args, SEXP rho) { int dbg, nm; volatile int i, n, bgn; SEXP sym, body; - volatile SEXP ans, v, val; + volatile SEXP ans, v, val ; RCNTXT cntxt; - PROTECT_INDEX vpi, api; + PROTECT_INDEX vpi, api ; sym = CAR(args); val = CADR(args); @@ -1046,24 +1098,52 @@ PROTECT(val = eval(val, rho)); defineVar(sym, R_NilValue, rho); - /* deal with the case where we are iterating over a factor - we need to coerce to character - then iterate */ - - if( inherits(val, "factor") ) { - PROTECT(ans = asCharacterFactor(val)); - val = ans; - UNPROTECT(2); /* ans and val from above */ - PROTECT(val); + Rboolean iterate = FALSE ; + + /* deal with the S4 case, try to dispatch to as.list */ + if( TYPEOF(val) == S4SXP ){ + SEXP expr ; + + if( isIterable(val, rho) ){ + /* iterating using the iterator scheme */ + iterate = TRUE ; + + /* replace val by its iterator */ + PROTECT(ans = iterator( val, rho ) ) ; + val = ans; + UNPROTECT(2) ; /* ans and val */ + PROTECT(val ); + + PROTECT_WITH_INDEX(v = R_NilValue, &vpi); + } else{ + /* trying as.list. Maybe this should just throw an error */ + PROTECT(ans = asList( val, rho ) ) ; + val = ans ; + UNPROTECT(2); /* ans and val from above*/ + PROTECT(val); + } } - - if (isList(val) || isNull(val)) { - n = length(val); - PROTECT_WITH_INDEX(v = R_NilValue, &vpi); - } - else { - n = LENGTH(val); - PROTECT_WITH_INDEX(v = allocVector(TYPEOF(val), 1), &vpi); - } + + if( !iterate ){ + /* deal with the case where we are iterating over a factor + we need to coerce to character - then iterate */ + + if( inherits(val, "factor") ) { + PROTECT(ans = asCharacterFactor(val)); + val = ans; + UNPROTECT(2); /* ans and val from above */ + PROTECT(val); + } + + if (isList(val) || isNull(val)) { + n = length(val); + PROTECT_WITH_INDEX(v = R_NilValue, &vpi); + } + else { + n = LENGTH(val); + PROTECT_WITH_INDEX(v = allocVector(TYPEOF(val), 1), &vpi); + } + } ans = R_NilValue; dbg = RDEBUG(rho); @@ -1079,62 +1159,84 @@ PROTECT_WITH_INDEX(ans, &api); /**** ans should no longer be needed. LT */ begincontext(&cntxt, CTXT_LOOP, R_NilValue, rho, R_BaseEnv, R_NilValue, R_NilValue); - switch (SETJMP(cntxt.cjmpbuf)) { - case CTXT_BREAK: goto for_break; - case CTXT_NEXT: goto for_next; - } - for (i = 0; i < n; i++) { - DO_LOOP_RDEBUG(call, op, args, rho, bgn); - switch (TYPEOF(val)) { - case LGLSXP: - REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); - LOGICAL(v)[0] = LOGICAL(val)[i]; - setVar(sym, v, rho); - break; - case INTSXP: - REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); - INTEGER(v)[0] = INTEGER(val)[i]; - setVar(sym, v, rho); - break; - case REALSXP: - REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); - REAL(v)[0] = REAL(val)[i]; - setVar(sym, v, rho); - break; - case CPLXSXP: - REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); - COMPLEX(v)[0] = COMPLEX(val)[i]; - setVar(sym, v, rho); - break; - case STRSXP: - REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); - SET_STRING_ELT(v, 0, STRING_ELT(val, i)); - setVar(sym, v, rho); - break; - case RAWSXP: - REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); - RAW(v)[0] = RAW(val)[i]; - setVar(sym, v, rho); - break; - case EXPRSXP: - case VECSXP: - /* make sure loop variable is a copy if needed */ - if(nm > 0) SET_NAMED(VECTOR_ELT(val, i), 2); - setVar(sym, VECTOR_ELT(val, i), rho); - break; - case LISTSXP: - /* make sure loop variable is a copy if needed */ - if(nm > 0) SET_NAMED(CAR(val), 2); - setVar(sym, CAR(val), rho); - val = CDR(val); - break; - default: - errorcall(call, _("invalid for() loop sequence")); - } - REPROTECT(ans = eval(body, rho), api); - for_next: - ; /* needed for strict ISO C compliance, according to gcc 2.95.2 */ - } + if( iterate ){ + switch (SETJMP(cntxt.cjmpbuf)) { + case CTXT_BREAK: goto for_break; + case CTXT_NEXT: goto iterate_next; + } + + while( hasNext( val , rho ) == TRUE ){ + DO_LOOP_RDEBUG(call, op, args, rho, bgn); + + /* get the next item and set it to the loop symbol */ + REPROTECT(v = getNext(val, rho) , vpi); + setVar(sym, v, rho); + + /* eval the loop body */ + REPROTECT(ans = eval(body, rho), api); + + iterate_next: + ; /* needed for strict ISO C compliance, according to gcc 2.95.2 */ + } + } else{ + + switch (SETJMP(cntxt.cjmpbuf)) { + case CTXT_BREAK: goto for_break; + case CTXT_NEXT: goto for_next; + } + for (i = 0; i < n; i++) { + DO_LOOP_RDEBUG(call, op, args, rho, bgn); + switch (TYPEOF(val)) { + case LGLSXP: + REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); + LOGICAL(v)[0] = LOGICAL(val)[i]; + setVar(sym, v, rho); + break; + case INTSXP: + REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); + INTEGER(v)[0] = INTEGER(val)[i]; + setVar(sym, v, rho); + break; + case REALSXP: + REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); + REAL(v)[0] = REAL(val)[i]; + setVar(sym, v, rho); + break; + case CPLXSXP: + REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); + COMPLEX(v)[0] = COMPLEX(val)[i]; + setVar(sym, v, rho); + break; + case STRSXP: + REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); + SET_STRING_ELT(v, 0, STRING_ELT(val, i)); + setVar(sym, v, rho); + break; + case RAWSXP: + REPROTECT(v = allocVector(TYPEOF(val), 1), vpi); + RAW(v)[0] = RAW(val)[i]; + setVar(sym, v, rho); + break; + case EXPRSXP: + case VECSXP: + /* make sure loop variable is a copy if needed */ + if(nm > 0) SET_NAMED(VECTOR_ELT(val, i), 2); + setVar(sym, VECTOR_ELT(val, i), rho); + break; + case LISTSXP: + /* make sure loop variable is a copy if needed */ + if(nm > 0) SET_NAMED(CAR(val), 2); + setVar(sym, CAR(val), rho); + val = CDR(val); + break; + default: + errorcall(call, _("invalid for() loop sequence")); + } + REPROTECT(ans = eval(body, rho), api); + for_next: + ; /* needed for strict ISO C compliance, according to gcc 2.95.2 */ + } + } for_break: endcontext(&cntxt); UNPROTECT(5);