自学教程：C++ CAR函数代码示例

Eterm copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)#endif{    char* hstart;    Uint hsize;    Eterm* htop;    Eterm* hbot;    Eterm* hp;    Eterm* objp;    Eterm* tp;    Eterm  res;    Eterm  elem;    Eterm* tailp;    Eterm* argp;    Eterm* const_tuple;    Eterm hdr;    int i;#ifdef DEBUG    Eterm org_obj = obj;    Uint org_sz = sz;#endif    if (IS_CONST(obj))	return obj;    DTRACE1(copy_struct, (int32_t)sz);    hp = htop = *hpp;    hbot   = htop + sz;    hstart = (char *)htop;    hsize = (char*) hbot - hstart;    const_tuple = 0;    /* Copy the object onto the heap */    switch (primary_tag(obj)) {    case TAG_PRIMARY_LIST:	argp = &res;	objp = list_val_rel(obj,src_base);	goto L_copy_list;    case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed;    default:	erl_exit(ERTS_ABORT_EXIT,		 "%s, line %d: Internal error in copy_struct: 0x%08x/n",		 __FILE__, __LINE__,obj);    } L_copy:    while (hp != htop) {	obj = *hp;	switch (primary_tag(obj)) {	case TAG_PRIMARY_IMMED1:	    hp++;	    break;	case TAG_PRIMARY_LIST:	    objp = list_val_rel(obj,src_base);	#if !HALFWORD_HEAP || defined(DEBUG)	    if (in_area(objp,hstart,hsize)) {		ASSERT(!HALFWORD_HEAP);		hp++;		break;	    }	#endif	    argp = hp++;	    /* Fall through */	L_copy_list:	    tailp = argp;	    for (;;) {		tp = tailp;		elem = CAR(objp);		if (IS_CONST(elem)) {		    hbot -= 2;		    CAR(hbot) = elem;		    tailp = &CDR(hbot);		}		else {		    CAR(htop) = elem;		#if HALFWORD_HEAP		    CDR(htop) = CDR(objp);		    *tailp = make_list_rel(htop,dst_base);		    htop += 2;		    goto L_copy;		#else		    tailp = &CDR(htop);		    htop += 2;		#endif		}		ASSERT(!HALFWORD_HEAP || tp < hp || tp >= hbot);		*tp = make_list_rel(tailp - 1, dst_base);		obj = CDR(objp);		if (!is_list(obj)) {		    break;		}		objp = list_val_rel(obj,src_base);	    }	    switch (primary_tag(obj)) {	    case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy;	    case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed;	    default://.........这里部分代码省略.........

static cv_t c_test_handler(obj_t cont, obj_t values){    obj_t ex = vector_ref(record_get_field(CAR(values), 0), 0);    return cv(EMPTY_LIST, MAKE_LIST(ex));}

static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop){    SEXP attr, result, sr, sc, dim;    int nr, nc, nrs, ncs;    R_xlen_t i, j, ii, jj, ij, iijj;    nr = nrows(x);    nc = ncols(x);    /* Note that "s" is protected on entry. */    /* The following ensures that pointers remain protected. */    dim = getAttrib(x, R_DimSymbol);    sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call));    sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));    nrs = LENGTH(sr);    ncs = LENGTH(sc);    /* Check this does not overflow: currently only possible on 32-bit */    if ((double)nrs * (double)ncs > R_XLEN_T_MAX)	error(_("dimensions would exceed maximum size of array"));    PROTECT(sr);    PROTECT(sc);    result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) ncs);    PROTECT(result);    for (i = 0; i < nrs; i++) {	ii = INTEGER(sr)[i];	if (ii != NA_INTEGER) {	    if (ii < 1 || ii > nr)		errorcall(call, R_MSG_subs_o_b);	    ii--;	}	for (j = 0; j < ncs; j++) {	    jj = INTEGER(sc)[j];	    if (jj != NA_INTEGER) {		if (jj < 1 || jj > nc)		    errorcall(call, R_MSG_subs_o_b);		jj--;	    }	    ij = i + j * nrs;	    if (ii == NA_INTEGER || jj == NA_INTEGER) {		switch (TYPEOF(x)) {		case LGLSXP:		case INTSXP:		    INTEGER(result)[ij] = NA_INTEGER;		    break;		case REALSXP:		    REAL(result)[ij] = NA_REAL;		    break;		case CPLXSXP:		    COMPLEX(result)[ij].r = NA_REAL;		    COMPLEX(result)[ij].i = NA_REAL;		    break;		case STRSXP:		    SET_STRING_ELT(result, ij, NA_STRING);		    break;		case VECSXP:		    SET_VECTOR_ELT(result, ij, R_NilValue);		    break;		case RAWSXP:		    RAW(result)[ij] = (Rbyte) 0;		    break;		default:		    errorcall(call, _("matrix subscripting not handled for this type"));		    break;		}	    }	    else {		iijj = ii + jj * nr;		switch (TYPEOF(x)) {		case LGLSXP:		    LOGICAL(result)[ij] = LOGICAL(x)[iijj];		    break;		case INTSXP:		    INTEGER(result)[ij] = INTEGER(x)[iijj];		    break;		case REALSXP:		    REAL(result)[ij] = REAL(x)[iijj];		    break;		case CPLXSXP:		    COMPLEX(result)[ij] = COMPLEX(x)[iijj];		    break;		case STRSXP:		    SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));		    break;		case VECSXP:		    SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));		    break;		case RAWSXP:		    RAW(result)[ij] = RAW(x)[iijj];		    break;		default:		    errorcall(call, _("matrix subscripting not handled for this type"));		    break;		}	    }	}    }    if(nrs >= 0 && ncs >= 0) {	PROTECT(attr = allocVector(INTSXP, 2));	INTEGER(attr)[0] = nrs;//.........这里部分代码省略.........

 void CallProxy::traverse_call( SEXP obj ){     if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("local") ) return ;     if( ! Rf_isNull(obj) ){         SEXP head = CAR(obj) ;         switch( TYPEOF( head ) ){         case LANGSXP:             if( CAR(head) == Rf_install("order_by") ) break ;             if( CAR(head) == Rf_install("function") ) break ;             if( CAR(head) == Rf_install("local") ) return ;             if( CAR(head) == Rf_install("<-") ){                 stop( "assignments are forbidden" ) ;             }             if( Rf_length(head) == 3 ){                 SEXP symb = CAR(head) ;                 if( symb == R_DollarSymbol || symb == Rf_install("@") || symb == Rf_install("::") || symb == Rf_install(":::") ){                     // for things like : foo( bar = bling )$bla                     // so that `foo( bar = bling )` gets processed                     if( TYPEOF(CADR(head)) == LANGSXP ){                         traverse_call( CDR(head) ) ;                         }                                          // deal with foo$bar( bla = boom )                     if( TYPEOF(CADDR(head)) == LANGSXP ){                         traverse_call( CDDR(head) ) ;                     }                                          break ;                 } else {                   traverse_call( CDR(head) ) ;                 }             } else {                 traverse_call( CDR(head) ) ;             }              break ;         case LISTSXP:             traverse_call( head ) ;             traverse_call( CDR(head) ) ;             break ;         case SYMSXP:             if( TYPEOF(obj) != LANGSXP ){                 if( ! subsets.count(head) ){                     if( head == R_MissingArg ) break ;                     if( head == Rf_install(".") ) break ;                      // in the Environment -> resolve                     try{                         Shield<SEXP> x( env.find( CHAR(PRINTNAME(head)) ) ) ;                         SETCAR( obj, x );                     } catch( ...){                         // what happens when not found in environment                     }                  } else {                     // in the data frame                     proxies.push_back( CallElementProxy( head, obj ) );                 }                 break ;             }         }         traverse_call( CDR(obj) ) ;     } }

/* inline-walk! */	BGL_EXPORTED_DEF obj_t BGl_inlinezd2walkz12zc0zzinline_walkz00(obj_t		BgL_globalsz00_1, obj_t BgL_whatz00_2)	{		AN_OBJECT;		{	/* Inline/walk.scm 40 */			{	/* Inline/walk.scm 42 */				obj_t BgL_list3278z00_786;				{	/* Inline/walk.scm 42 */					obj_t BgL_arg3280z00_788;					{	/* Inline/walk.scm 42 */						obj_t BgL_arg3282z00_790;						BgL_arg3282z00_790 = MAKE_PAIR(BCHAR(((unsigned char) '/n')), BNIL);						BgL_arg3280z00_788 =							MAKE_PAIR(BGl_string3393z00zzinline_walkz00, BgL_arg3282z00_790);					}					BgL_list3278z00_786 =						MAKE_PAIR(BGl_string3394z00zzinline_walkz00, BgL_arg3280z00_788);				}				BGl_verbosez00zztools_speekz00(BINT(((long) 1)), BgL_list3278z00_786);			}			BGl_za2nbzd2errorzd2onzd2passza2zd2zztools_errorz00 = BINT(((long) 0));			BGl_za2currentzd2passza2zd2zzengine_passz00 =				BGl_string3393z00zzinline_walkz00;			{	/* Inline/walk.scm 42 */				obj_t BgL_g3270z00_791;				obj_t BgL_g3271z00_792;				{	/* Inline/walk.scm 42 */					obj_t BgL_list3292z00_806;					BgL_list3292z00_806 =						MAKE_PAIR(BGl_resetzd2statz12zd2envz12zzinline_walkz00, BNIL);					BgL_g3270z00_791 = BgL_list3292z00_806;				}				BgL_g3271z00_792 = CNST_TABLE_REF(((long) 1));				{					obj_t BgL_hooksz00_794;					obj_t BgL_hnamesz00_795;					BgL_hooksz00_794 = BgL_g3270z00_791;					BgL_hnamesz00_795 = BgL_g3271z00_792;				BgL_zc3anonymousza33283ze3z83_796:					if (NULLP(BgL_hooksz00_794))						{	/* Inline/walk.scm 42 */							CNST_TABLE_REF(((long) 2));						}					else						{	/* Inline/walk.scm 42 */							bool_t BgL_testz00_1352;							{	/* Inline/walk.scm 42 */								obj_t BgL_fun3291z00_804;								BgL_fun3291z00_804 = CAR(BgL_hooksz00_794);								BgL_testz00_1352 =									CBOOL(PROCEDURE_ENTRY(BgL_fun3291z00_804) (BgL_fun3291z00_804,										BEOA));							}							if (BgL_testz00_1352)								{									obj_t BgL_hnamesz00_1359;									obj_t BgL_hooksz00_1357;									BgL_hooksz00_1357 = CDR(BgL_hooksz00_794);									BgL_hnamesz00_1359 = CDR(BgL_hnamesz00_795);									BgL_hnamesz00_795 = BgL_hnamesz00_1359;									BgL_hooksz00_794 = BgL_hooksz00_1357;									goto BgL_zc3anonymousza33283ze3z83_796;								}							else								{	/* Inline/walk.scm 42 */									BGl_internalzd2errorzd2zztools_errorz00										(BGl_string3393z00zzinline_walkz00,										BGl_string3395z00zzinline_walkz00, CAR(BgL_hnamesz00_795));								}						}				}			}			BGl_inlinezd2setupz12zc0zzinline_walkz00(BgL_whatz00_2);			{				obj_t BgL_l3275z00_808;				BgL_l3275z00_808 = BgL_globalsz00_1;			BgL_zc3anonymousza33293ze3z83_809:				if (PAIRP(BgL_l3275z00_808))					{	/* Inline/walk.scm 46 */						{	/* Inline/walk.scm 47 */							obj_t BgL_gz00_811;							BgL_gz00_811 = CAR(BgL_l3275z00_808);							{	/* Inline/walk.scm 47 */								obj_t BgL_kfactorz00_812;//.........这里部分代码省略.........

int obj_compare(obj_ptr left, obj_ptr right){    /* TODO    if (NUMP(left) && NUMP(right))        ...    */    if (TYPE(left) < TYPE(right))        return -1;        if (TYPE(left) > TYPE(right))        return 1;    switch (TYPE(left))    {    case TYPE_INT:    case TYPE_BOOL:        return _int_compare(INT(left), INT(right));    case TYPE_FLOAT:        return _float_compare(FLOAT(left), FLOAT(right), 0.00000001); /* TODO: Better epsilon? */    case TYPE_SYMBOL:        return strcmp(SYMBOL(left), SYMBOL(right));    case TYPE_STRING:        return string_compare(&STRING(left), &STRING(right));    case TYPE_CONS:    {        int res = 0;        for (;;)        {            if (NTYPEP(left, TYPE(right)))                return obj_compare(left, right);            if (NTYPEP(left, TYPE_CONS))                return obj_compare(left, right);            res = obj_compare(CAR(left), CAR(right));            if (res != 0)                return res;                        left = CDR(left);            right = CDR(right);        }        assert(0); /* unreachable */        break;    }    case TYPE_VEC:        return vec_compare(&left->data.as_vec, &right->data.as_vec);    /* TODO */    case TYPE_MAP:        assert(TYPE(left) != TYPE_MAP);        break;    case TYPE_CLOSURE:        assert(TYPE(left) != TYPE_CLOSURE);        break;    case TYPE_PRIMITIVE:        assert(TYPE(left) != TYPE_PRIMITIVE);        break;    case TYPE_ERROR:        assert(TYPE(left) != TYPE_ERROR);        break;    case TYPE_PORT:        assert(TYPE(left) != TYPE_PORT);        break;    }    return 0;}

static SCMeval (SCM x, SCM env){  SCM mx;  SCM proc = SCM_UNDEFINED, args = SCM_EOL;  unsigned int argc; loop:  SCM_TICK;  if (!SCM_MEMOIZED_P (x))    abort ();    mx = SCM_MEMOIZED_ARGS (x);  switch (SCM_MEMOIZED_TAG (x))    {    case SCM_M_SEQ:      eval (CAR (mx), env);      x = CDR (mx);      goto loop;    case SCM_M_IF:      if (scm_is_true (EVAL1 (CAR (mx), env)))        x = CADR (mx);      else        x = CDDR (mx);      goto loop;    case SCM_M_LET:      {        SCM inits = CAR (mx);        SCM new_env = CAPTURE_ENV (env);        for (; scm_is_pair (inits); inits = CDR (inits))          new_env = scm_cons (EVAL1 (CAR (inits), env),                              new_env);        env = new_env;        x = CDR (mx);        goto loop;      }              case SCM_M_LAMBDA:      RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));    case SCM_M_QUOTE:      return mx;    case SCM_M_DEFINE:      scm_define (CAR (mx), EVAL1 (CDR (mx), env));      return SCM_UNSPECIFIED;    case SCM_M_DYNWIND:      {        SCM in, out, res;        scm_i_thread *t = SCM_I_CURRENT_THREAD;        in = EVAL1 (CAR (mx), env);        out = EVAL1 (CDDR (mx), env);        scm_call_0 (in);        scm_dynstack_push_dynwind (&t->dynstack, in, out);        res = eval (CADR (mx), env);        scm_dynstack_pop (&t->dynstack);        scm_call_0 (out);        return res;      }    case SCM_M_WITH_FLUIDS:      {        long i, len;        SCM *fluidv, *valuesv, walk, res;        scm_i_thread *thread = SCM_I_CURRENT_THREAD;        len = scm_ilength (CAR (mx));        fluidv = alloca (sizeof (SCM)*len);        for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))          fluidv[i] = EVAL1 (CAR (walk), env);        valuesv = alloca (sizeof (SCM)*len);        for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))          valuesv[i] = EVAL1 (CAR (walk), env);                scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,                                  thread->dynamic_state);        res = eval (CDDR (mx), env);        scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);                return res;      }    case SCM_M_APPLY:      /* Evaluate the procedure to be applied.  */      proc = EVAL1 (CAR (mx), env);      /* Evaluate the argument holding the list of arguments */      args = EVAL1 (CADR (mx), env);              apply_proc:      /* Go here to tail-apply a procedure.  PROC is the procedure and       * ARGS is the list of arguments. */      if (BOOT_CLOSURE_P (proc))        {          prepare_boot_closure_env_for_apply (proc, args, &x, &env);          goto loop;        }      else//.........这里部分代码省略.........

static BIF_RETTYPE iol2v_continue(iol2v_state_t *state) {    Eterm iterator;    DECLARE_ESTACK(s);    ESTACK_CHANGE_ALLOCATOR(s, ERTS_ALC_T_SAVED_ESTACK);    state->bytereds_available =        ERTS_BIF_REDS_LEFT(state->process) * IOL2V_SMALL_BIN_LIMIT;    state->bytereds_spent = 0;    if (state->estack.start) {        ESTACK_RESTORE(s, &state->estack);    }    iterator = state->input_list;    for(;;) {        if (state->bytereds_spent >= state->bytereds_available) {            ESTACK_SAVE(s, &state->estack);            state->input_list = iterator;            return iol2v_yield(state);        }        while (is_list(iterator)) {            Eterm *cell;            Eterm head;            cell = list_val(iterator);            head = CAR(cell);            if (is_binary(head)) {                if (!iol2v_append_binary(state, head)) {                    goto l_badarg;                }                iterator = CDR(cell);            } else if (is_small(head)) {                Eterm seq_end;                if (!iol2v_append_byte_seq(state, iterator, &seq_end)) {                    goto l_badarg;                }                iterator = seq_end;            } else if (is_list(head) || is_nil(head)) {                Eterm tail = CDR(cell);                if (!is_nil(tail)) {                    ESTACK_PUSH(s, tail);                }                state->bytereds_spent += 1;                iterator = head;            } else {                goto l_badarg;            }            if (state->bytereds_spent >= state->bytereds_available) {                ESTACK_SAVE(s, &state->estack);                state->input_list = iterator;                return iol2v_yield(state);            }        }        if (is_binary(iterator)) {            if (!iol2v_append_binary(state, iterator)) {                goto l_badarg;            }        } else if (!is_nil(iterator)) {            goto l_badarg;        }        if(ESTACK_ISEMPTY(s)) {            break;        }        iterator = ESTACK_POP(s);    }    if (state->acc_size != 0) {        iol2v_enqueue_result(state, iol2v_promote_acc(state));    }    BUMP_REDS(state->process, state->bytereds_spent / IOL2V_SMALL_BIN_LIMIT);    CLEAR_SAVED_ESTACK(&state->estack);    DESTROY_ESTACK(s);    BIF_RET(state->result_head);l_badarg:    CLEAR_SAVED_ESTACK(&state->estack);    DESTROY_ESTACK(s);    if (state->acc != NULL) {        erts_bin_free(state->acc);        state->acc = NULL;    }//.........这里部分代码省略.........

interts_ioq_iolist_to_vec(Eterm obj,	  /* io-list */                       SysIOVec* iov,	  /* io vector */                       ErtsIOQBinary** binv,       /* binary reference vector */                       ErtsIOQBinary* cbin,        /* binary to store characters */                       Uint bin_limit,  /* small binaries limit */                       int driver){    DECLARE_ESTACK(s);    Eterm* objp;    byte *buf  = NULL;    Uint len = 0;    Uint csize  = 0;    int vlen   = 0;    byte* cptr;    if (cbin) {        if (driver) {            buf = (byte*)cbin->driver.orig_bytes;            len = cbin->driver.orig_size;        } else {            buf = (byte*)cbin->nif.orig_bytes;            len = cbin->nif.orig_size;        }    }    cptr = buf;    goto L_jump_start;  /* avoid push */    while (!ESTACK_ISEMPTY(s)) {	obj = ESTACK_POP(s);    L_jump_start:	if (is_list(obj)) {	L_iter_list:	    objp = list_val(obj);	    obj = CAR(objp);	    if (is_byte(obj)) {		if (len == 0)		    goto L_overflow;		*buf++ = unsigned_val(obj);		csize++;		len--;	    } else if (is_binary(obj)) {		ESTACK_PUSH(s, CDR(objp));		goto handle_binary;	    } else if (is_list(obj)) {		ESTACK_PUSH(s, CDR(objp));		goto L_iter_list;    /* on head */	    } else if (!is_nil(obj)) {		goto L_type_error;	    }	    obj = CDR(objp);	    if (is_list(obj))		goto L_iter_list; /* on tail */	    else if (is_binary(obj)) {		goto handle_binary;	    } else if (!is_nil(obj)) {		goto L_type_error;	    }	} else if (is_binary(obj)) {	    Eterm real_bin;	    Uint offset;	    Eterm* bptr;	    Uint size;	    int bitoffs;	    int bitsize;	handle_binary:	    size = binary_size(obj);	    ERTS_GET_REAL_BIN(obj, real_bin, offset, bitoffs, bitsize);	    ASSERT(bitsize == 0);	    bptr = binary_val(real_bin);	    if (*bptr == HEADER_PROC_BIN) {		ProcBin* pb = (ProcBin *) bptr;		if (bitoffs != 0) {		    if (len < size) {			goto L_overflow;		    }		    erts_copy_bits(pb->bytes+offset, bitoffs, 1,				   (byte *) buf, 0, 1, size*8);		    csize += size;		    buf += size;		    len -= size;		} else if (bin_limit && size < bin_limit) {		    if (len < size) {			goto L_overflow;		    }		    sys_memcpy(buf, pb->bytes+offset, size);		    csize += size;		    buf += size;		    len -= size;		} else {                    ErtsIOQBinary *qbin;		    if (csize != 0) {                        io_list_to_vec_set_vec(&iov, &binv, cbin,                                               cptr, csize, &vlen);			cptr = buf;			csize = 0;		    }		    if (pb->flags) {//.........这里部分代码省略.........

/* fetch-prototypes */	obj_t BGl_fetchzd2prototypeszd2zz__match_expandz00(obj_t BgL_patz00_2)	{		AN_OBJECT;		{	/* Match/mexpand.scm 112 */			if (CBOOL(BGl_memqz00zz__r4_pairs_and_lists_6_3z00(CAR(BgL_patz00_2),						BGl_list2321z00zz__match_expandz00)))				{	/* Match/mexpand.scm 114 */					obj_t BgL_arg1957z00_876;					obj_t BgL_arg1958z00_877;					{	/* Match/mexpand.scm 114 */						obj_t BgL_arg1959z00_878;						obj_t BgL_arg1960z00_879;						{	/* Match/mexpand.scm 114 */							obj_t BgL_pairz00_1432;							BgL_pairz00_1432 = BgL_patz00_2;							BgL_arg1959z00_878 = CAR(CDR(CDR(BgL_pairz00_1432)));						}						{	/* Match/mexpand.scm 114 */							obj_t BgL_arg1961z00_880;							{	/* Match/mexpand.scm 114 */								obj_t BgL_arg1965z00_883;								{	/* Match/mexpand.scm 114 */									obj_t BgL_pairz00_1438;									BgL_pairz00_1438 = BgL_patz00_2;									BgL_arg1965z00_883 = CAR(CDR(BgL_pairz00_1438));								}								BgL_arg1961z00_880 =									BGl_patternzd2variableszd2zz__match_descriptionsz00									(BgL_arg1965z00_883);							}							{	/* Match/mexpand.scm 114 */								obj_t BgL_list1963z00_882;								BgL_list1963z00_882 = MAKE_PAIR(BNIL, BNIL);								BgL_arg1960z00_879 =									BGl_consza2za2zz__r4_pairs_and_lists_6_3z00									(BgL_arg1961z00_880, BgL_list1963z00_882);							}						}						BgL_arg1957z00_876 =							MAKE_PAIR(BgL_arg1959z00_878, BgL_arg1960z00_879);					}					{	/* Match/mexpand.scm 115 */						obj_t BgL_arg1966z00_884;						{	/* Match/mexpand.scm 115 */							obj_t BgL_pairz00_1442;							BgL_pairz00_1442 = BgL_patz00_2;							BgL_arg1966z00_884 = CAR(CDR(CDR(CDR(BgL_pairz00_1442))));						}						BgL_arg1958z00_877 =							BGl_fetchzd2prototypeszd2zz__match_expandz00(BgL_arg1966z00_884);					}					return MAKE_PAIR(BgL_arg1957z00_876, BgL_arg1958z00_877);				}			else				{	/* Match/mexpand.scm 113 */					return BNIL;				}		}	}

/* expand-match-case */	BGL_EXPORTED_DEF obj_t BGl_expandzd2matchzd2casez00zz__match_expandz00(obj_t		BgL_expz00_5)	{		AN_OBJECT;		{	/* Match/mexpand.scm 123 */			{	/* Match/mexpand.scm 124 */				obj_t BgL_arg1973z00_891;				obj_t BgL_arg1974z00_892;				{	/* Match/mexpand.scm 124 */					obj_t BgL_arg1977z00_895;					{	/* Match/mexpand.scm 124 */						obj_t BgL_arg1979z00_896;						{	/* Match/mexpand.scm 124 */							obj_t BgL_arg1980z00_897;							obj_t BgL_arg1981z00_898;							BgL_arg1980z00_897 = BGl_symbol2324z00zz__match_expandz00;							{	/* Match/mexpand.scm 124 */								obj_t BgL_pairz00_1462;								BgL_pairz00_1462 = BgL_expz00_5;								BgL_arg1981z00_898 = CDR(CDR(BgL_pairz00_1462));							}							BgL_arg1979z00_896 =								MAKE_PAIR(BgL_arg1980z00_897, BgL_arg1981z00_898);						}						if (EXTENDED_PAIRP(BgL_expz00_5))							{	/* Match/mexpand.scm 124 */								obj_t BgL_arg1970z00_1469;								obj_t BgL_arg1971z00_1470;								obj_t BgL_arg1972z00_1471;								BgL_arg1970z00_1469 = CAR(BgL_arg1979z00_896);								BgL_arg1971z00_1470 = CDR(BgL_arg1979z00_896);								BgL_arg1972z00_1471 = CER(BgL_expz00_5);								{	/* Match/mexpand.scm 124 */									obj_t BgL_res2294z00_1479;									BgL_res2294z00_1479 =										MAKE_EXTENDED_PAIR(BgL_arg1970z00_1469, BgL_arg1971z00_1470,										BgL_arg1972z00_1471);									BgL_arg1977z00_895 = BgL_res2294z00_1479;								}							}						else							{	/* Match/mexpand.scm 124 */								BgL_arg1977z00_895 = BgL_arg1979z00_896;							}					}					BgL_arg1973z00_891 =						BGl_expandzd2matchzd2lambdaz00zz__match_expandz00						(BgL_arg1977z00_895);				}				{	/* Match/mexpand.scm 125 */					obj_t BgL_pairz00_1480;					BgL_pairz00_1480 = BgL_expz00_5;					BgL_arg1974z00_892 = CAR(CDR(BgL_pairz00_1480));				}				{	/* Match/mexpand.scm 124 */					obj_t BgL_list1975z00_893;					{	/* Match/mexpand.scm 124 */						obj_t BgL_arg1976z00_894;						BgL_arg1976z00_894 = MAKE_PAIR(BgL_arg1974z00_892, BNIL);						BgL_list1975z00_893 =							MAKE_PAIR(BgL_arg1973z00_891, BgL_arg1976z00_894);					}					return BgL_list1975z00_893;				}			}		}	}

/* <anonymous:1896> */	obj_t BGl_zc3anonymousza31896ze3z83zz__match_expandz00(obj_t BgL_envz00_1693,		obj_t BgL_patz00_1695, obj_t BgL_envz00_1696)	{		AN_OBJECT;		{	/* Match/mexpand.scm 96 */			{	/* Match/mexpand.scm 97 */				obj_t BgL_expz00_1694;				BgL_expz00_1694 = PROCEDURE_REF(BgL_envz00_1693, (int) (((long) 0)));				{					obj_t BgL_patz00_803;					obj_t BgL_envz00_804;					BgL_patz00_803 = BgL_patz00_1695;					BgL_envz00_804 = BgL_envz00_1696;					{	/* Match/mexpand.scm 97 */						obj_t BgL_compiledzd2patzd2_806;						obj_t BgL_prototypesz00_807;						BgL_compiledzd2patzd2_806 =							BGl_pcompilez00zz__match_compilerz00(BgL_patz00_803);						BgL_prototypesz00_807 =							BGl_fetchzd2prototypeszd2zz__match_expandz00(BgL_patz00_803);						{	/* Match/mexpand.scm 101 */							obj_t BgL_arg1898z00_808;							obj_t BgL_arg1899z00_809;							BgL_arg1898z00_808 = BGl_symbol2319z00zz__match_expandz00;							{	/* Match/mexpand.scm 102 */								obj_t BgL_arg1900z00_810;								{	/* Match/mexpand.scm 102 */									obj_t BgL_arg1904z00_814;									if (NULLP(BgL_prototypesz00_807))										{	/* Match/mexpand.scm 102 */											BgL_arg1904z00_814 = BNIL;										}									else										{	/* Match/mexpand.scm 102 */											obj_t BgL_head1850z00_818;											BgL_head1850z00_818 = MAKE_PAIR(BNIL, BNIL);											{												obj_t BgL_l1848z00_820;												obj_t BgL_tail1851z00_821;												BgL_l1848z00_820 = BgL_prototypesz00_807;												BgL_tail1851z00_821 = BgL_head1850z00_818;											BgL_zc3anonymousza31907ze3z83_822:												if (NULLP(BgL_l1848z00_820))													{	/* Match/mexpand.scm 102 */														BgL_arg1904z00_814 = CDR(BgL_head1850z00_818);													}												else													{	/* Match/mexpand.scm 102 */														obj_t BgL_newtail1852z00_824;														{	/* Match/mexpand.scm 102 */															obj_t BgL_arg1910z00_826;															{	/* Match/mexpand.scm 102 */																obj_t BgL_prototypez00_828;																BgL_prototypez00_828 = CAR(BgL_l1848z00_820);																{	/* Match/mexpand.scm 104 */																	obj_t BgL_bodyz00_829;																	BgL_bodyz00_829 =																		CDR(BGl_assqz00zz__r4_pairs_and_lists_6_3z00																		(CAR(BgL_prototypez00_828),																			BgL_envz00_804));																	if (NULLP(BgL_bodyz00_829))																		{	/* Match/mexpand.scm 105 */																			BgL_arg1910z00_826 =																				BGl_errorz00zz__errorz00																				(BGl_symbol2316z00zz__match_expandz00,																				BGl_string2318z00zz__match_expandz00,																				BgL_expz00_1694);																		}																	else																		{	/* Match/mexpand.scm 107 */																			obj_t BgL_arg1914z00_831;																			obj_t BgL_arg1915z00_832;																			BgL_arg1914z00_831 =																				CAR(BgL_prototypez00_828);																			{	/* Match/mexpand.scm 108 */																				obj_t BgL_arg1916z00_833;																				{	/* Match/mexpand.scm 108 */																					obj_t BgL_pairz00_1402;																					BgL_pairz00_1402 =//.........这里部分代码省略.........

/* expand-match-lambda */	BGL_EXPORTED_DEF obj_t BGl_expandzd2matchzd2lambdaz00zz__match_expandz00(obj_t		BgL_expz00_1)	{		AN_OBJECT;		{	/* Match/mexpand.scm 71 */			{				obj_t BgL_clausesz00_798;				obj_t BgL_kz00_799;				{	/* Match/mexpand.scm 95 */					obj_t BgL_arg1894z00_801;					BgL_arg1894z00_801 = CDR(BgL_expz00_1);					{	/* Match/mexpand.scm 97 */						obj_t BgL_zc3anonymousza31896ze3z83_1689;						BgL_zc3anonymousza31896ze3z83_1689 =							make_fx_procedure							(BGl_zc3anonymousza31896ze3z83zz__match_expandz00,							(int) (((long) 2)), (int) (((long) 1)));						PROCEDURE_SET(BgL_zc3anonymousza31896ze3z83_1689,							(int) (((long) 0)), BgL_expz00_1);						BgL_clausesz00_798 = BgL_arg1894z00_801;						BgL_kz00_799 = BgL_zc3anonymousza31896ze3z83_1689;					BgL_clauseszd2ze3patternz31_800:						if (NULLP(BgL_clausesz00_798))							{	/* Match/mexpand.scm 75 */								return									PROCEDURE_ENTRY(BgL_kz00_799) (BgL_kz00_799,									BGl_list2305z00zz__match_expandz00,									BGl_za2thezd2emptyzd2envza2z00zz__match_expandz00, BEOA);							}						else							{	/* Match/mexpand.scm 77 */								bool_t BgL_testz00_1737;								{	/* Match/mexpand.scm 77 */									obj_t BgL_auxz00_1738;									BgL_auxz00_1738 = CAR(BgL_clausesz00_798);									BgL_testz00_1737 = PAIRP(BgL_auxz00_1738);								}								if (BgL_testz00_1737)									{	/* Match/mexpand.scm 80 */										obj_t BgL_patternz00_840;										obj_t BgL_actionsz00_841;										obj_t BgL_restz00_842;										{	/* Match/mexpand.scm 80 */											obj_t BgL_pairz00_1414;											BgL_pairz00_1414 = BgL_clausesz00_798;											BgL_patternz00_840 = CAR(CAR(BgL_pairz00_1414));										}										{	/* Match/mexpand.scm 81 */											obj_t BgL_pairz00_1418;											BgL_pairz00_1418 = BgL_clausesz00_798;											BgL_actionsz00_841 = CDR(CAR(BgL_pairz00_1418));										}										BgL_restz00_842 = CDR(BgL_clausesz00_798);										{	/* Match/mexpand.scm 83 */											obj_t BgL_tagz00_843;											BgL_tagz00_843 =												PROCEDURE_ENTRY(BGl_jimzd2gensymzd2zz__match_s2cfunz00)												(BGl_jimzd2gensymzd2zz__match_s2cfunz00,												BGl_string2311z00zz__match_expandz00, BEOA);											if ((BgL_patternz00_840 ==													BGl_symbol2312z00zz__match_expandz00))												{	/* Match/mexpand.scm 85 */													obj_t BgL_arg1923z00_845;													obj_t BgL_arg1924z00_846;													{	/* Match/mexpand.scm 85 */														obj_t BgL_arg1925z00_847;														obj_t BgL_arg1926z00_848;														BgL_arg1925z00_847 =															BGl_symbol2314z00zz__match_expandz00;														{	/* Match/mexpand.scm 85 */															obj_t BgL_arg1927z00_849;															obj_t BgL_arg1929z00_850;															BgL_arg1927z00_849 =																MAKE_PAIR(BGl_symbol2309z00zz__match_expandz00,																BNIL);															{	/* Match/mexpand.scm 85 */																obj_t BgL_arg1937z00_855;																obj_t BgL_arg1938z00_856;																BgL_arg1937z00_855 =//.........这里部分代码省略.........

//.........这里部分代码省略.........	      else		{		  r->state->dotpair_mode = 1;		  reader_putc (r, nc);		}	    }	  else	    {	      /* Turn it into a decimal point. */	      reader_putc (r, nc);	      reader_putc (r, '.');	      reader_putc (r, '0');	    }	  break;	  /* Whitespace */	case '/n':	  r->linecnt++;	  print_prompt (r);	case ' ':	case '/t':	case '/r':	  break;	  /* Parenthesis */	case '(':	  push (r);	  break;	case ')':	  if (r->state->quote_mode)	    read_error (r, "unbalanced parenthesis");	  else if (r->state->vector_mode)	    read_error (r, "unbalanced brackets");	  else	    addpop (r);	  break;	  /* Vectors */	case '[':	  push (r);	  r->state->vector_mode = 1;	  break;	case ']':	  if (r->state->quote_mode)	    read_error (r, "unbalanced parenthesis");	  else if (!r->state->vector_mode)	    read_error (r, "unbalanced brackets");	  else	    addpop (r);	  break;	  /* Quoting */	case '/'':	  push (r);	  add (r, quote);	  if (!r->error)	    r->state->quote_mode = 1;	  break;	  /* strings */	case '"':	  buf_read (r, "/"");	  add (r, parse_str (r));	  reader_getc (r);	/* Throw away other quote. */	  break;	  /* numbers and symbols */	default:	  buf_append (r, c);	  buf_read (r, " /t/r/n()[];");	  object_t *o = parse_atom (r);	  if (!r->error)	    add (r, o);	  break;	}    }  if (!r->eof && !r->error)    consume_whitespace (r);  if (r->error)    return err_symbol;  /* Check state */  r->done = 1;  if (stack_height (r) > 1 || r->state->quote_mode      || r->state->dotpair_mode == 1)    {      read_error (r, "premature end of file");      return err_symbol;    }  if (list_empty (r))    {      obj_destroy (pop (r));      return NIL;    }  object_t *wrap = pop (r);  object_t *sexp = UPREF (CAR (wrap));  obj_destroy (wrap);  return sexp;}

//.........这里部分代码省略.........		childdata->length = childcount;		RData **children = new RData*[childcount];		childdata->data = children;		childdata->length = childcount;		for (unsigned int i = 0; i < childcount; ++i) {		// in case there is an error while fetching one of the children, let's pre-initialize everything.			children[i] = new RData;			children[i]->data = 0;			children[i]->length = 0;			children[i]->datatype = RData::NoData;		}		if (do_env) {			RK_DO (qDebug ("recurse into environment %s", name.toLatin1().data ()), RBACKEND, DL_DEBUG);			for (unsigned int i = 0; i < childcount; ++i) {				SEXP current_childname = install(CHAR(STRING_ELT(childnames_s, i)));				PROTECT (current_childname);				SEXP child = Rf_findVar (current_childname, value);				PROTECT (child);				bool child_misplaced = false;				if (with_namespace) {					/* before R 2.4.0, operator "::" would only work on true namespaces, not on package names (operator "::" work, if there is a namespace, and that namespace has the symbol in it)					TODO remove once we depend on R >= 2.4.0 */#					ifndef R_2_5					if (Rf_isNull (namespace_envir)) {						child_misplaced = true;					} else {						SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);						if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;					}					/* for R 2.4.0 or greater: operator "::" works if package has no namespace at all, or has a namespace with the symbol in it */#					else					if (!Rf_isNull (namespace_envir)) {						SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);						if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;					}#					endif				}				getStructureSafe (child, childnames[i], child_misplaced, children[i]);				UNPROTECT (2); /* childname, child */			}		} else if (do_cont) {			RK_DO (qDebug ("recurse into list %s", name.toLatin1().data ()), RBACKEND, DL_DEBUG);			// fewer elements than names() can happen, although I doubt it is supposed to happen.			// see http://sourceforge.net/tracker/?func=detail&aid=3002439&group_id=50231&atid=459007			bool may_be_special = Rf_length (value) < childcount;			if (Rf_isList (value) && (!may_be_special)) {		// old style list				for (unsigned int i = 0; i < childcount; ++i) {					SEXP child = CAR (value);					getStructureSafe (child, childnames[i], false, children[i]);					CDR (value);				}			} else if (Rf_isNewList (value) && (!may_be_special)) {				// new style list				for (unsigned int i = 0; i < childcount; ++i) {					SEXP child = VECTOR_ELT(value, i);					getStructureSafe (child, childnames[i], false, children[i]);				}			} else {		// probably an S4 object disguised as a list				SEXP index = Rf_allocVector(INTSXP, 1);				PROTECT (index);				for (unsigned int i = 0; i < childcount; ++i) {					INTEGER (index)[0] = (i + 1);					SEXP child = callSimpleFun2 (double_brackets_fun, value, index, R_BaseEnv);					getStructureSafe (child, childnames[i], false, children[i]);				}				UNPROTECT (1); /* index */			}		}		UNPROTECT (1);   /* childnames_s */		delete [] childnames;	} else if (is_function) {		RData *funargsdata = new RData;		funargsdata->datatype = RData::StringVector;		funargsdata->length = 0;		funargsdata->data = 0;		res[5] = funargsdata;		RData *funargvaluesdata = new RData;		funargvaluesdata->datatype = RData::StringVector;		funargvaluesdata->length = 0;		funargvaluesdata->data = 0;		res[6] = funargvaluesdata;// TODO: this is still the major bottleneck, but no idea, how to improve on this		SEXP formals_s = callSimpleFun (get_formals_fun, value, R_GlobalEnv);		PROTECT (formals_s);		// the default values		funargvaluesdata->data = SEXPToStringList (formals_s, &(funargvaluesdata->length));		// the argument names		SEXP names_s = getAttrib (formals_s, R_NamesSymbol);		PROTECT (names_s);		funargsdata->data = SEXPToStringList (names_s, &(funargsdata->length));		UNPROTECT (2); /* names_s, formals_s */	}	UNPROTECT (1); /* value */}

/*  * Returns 0 if successful and a non-zero value otherwise. * * Return values through pointers: *    *vsize      - SysIOVec size needed for a writev *    *csize      - Number of bytes not in binary (in the common binary) *    *pvsize     - SysIOVec size needed if packing small binaries *    *pcsize     - Number of bytes in the common binary if packing *    *total_size - Total size of iolist in bytes */interts_ioq_iolist_vec_len(Eterm obj, int* vsize, Uint* csize,                        Uint* pvsize, Uint* pcsize,                        Uint* total_size, Uint blimit){    DECLARE_ESTACK(s);    Eterm* objp;    Uint v_size = 0;    Uint c_size = 0;    Uint b_size = 0;    Uint in_clist = 0;    Uint p_v_size = 0;    Uint p_c_size = 0;    Uint p_in_clist = 0;    Uint total;    goto L_jump_start;  /* avoid a push */    while (!ESTACK_ISEMPTY(s)) {	obj = ESTACK_POP(s);    L_jump_start:	if (is_list(obj)) {	L_iter_list:	    objp = list_val(obj);	    obj = CAR(objp);	    if (is_byte(obj)) {		c_size++;		if (c_size == 0) {		    goto L_overflow_error;		}		if (!in_clist) {		    in_clist = 1;		    v_size++;		}		p_c_size++;		if (!p_in_clist) {		    p_in_clist = 1;		    p_v_size++;		}	    }	    else if (is_binary(obj)) {                IO_LIST_VEC_COUNT(obj);	    }	    else if (is_list(obj)) {		ESTACK_PUSH(s, CDR(objp));		goto L_iter_list;   /* on head */	    }	    else if (!is_nil(obj)) {		goto L_type_error;	    }	    obj = CDR(objp);	    if (is_list(obj))		goto L_iter_list;   /* on tail */	    else if (is_binary(obj)) {  /* binary tail is OK */		IO_LIST_VEC_COUNT(obj);	    }	    else if (!is_nil(obj)) {		goto L_type_error;	    }	}	else if (is_binary(obj)) {	    IO_LIST_VEC_COUNT(obj);	}	else if (!is_nil(obj)) {	    goto L_type_error;	}    }    total = c_size + b_size;    if (total < c_size) {	goto L_overflow_error;    }    *total_size = total;    DESTROY_ESTACK(s);    *vsize = v_size;    *csize = c_size;    *pvsize = p_v_size;    *pcsize = p_c_size;    return 0; L_type_error: L_overflow_error:    DESTROY_ESTACK(s);    return 1;}

/* expand-do */	BGL_EXPORTED_DEF obj_t BGl_expandzd2dozd2zz__expander_doz00(obj_t		BgL_expz00_1, obj_t BgL_ez00_2)	{		AN_OBJECT;		{	/* Eval/expddo.scm 57 */			{				obj_t BgL_bindingsz00_770;				obj_t BgL_endz00_771;				obj_t BgL_commandz00_772;				if (PAIRP(BgL_expz00_1))					{	/* Eval/expddo.scm 58 */						obj_t BgL_cdrzd21399zd2_777;						BgL_cdrzd21399zd2_777 = CDR(BgL_expz00_1);						if (PAIRP(BgL_cdrzd21399zd2_777))							{	/* Eval/expddo.scm 58 */								obj_t BgL_cdrzd21404zd2_779;								BgL_cdrzd21404zd2_779 = CDR(BgL_cdrzd21399zd2_777);								if (PAIRP(BgL_cdrzd21404zd2_779))									{	/* Eval/expddo.scm 58 */										BgL_bindingsz00_770 = CAR(BgL_cdrzd21399zd2_777);										BgL_endz00_771 = CAR(BgL_cdrzd21404zd2_779);										BgL_commandz00_772 = CDR(BgL_cdrzd21404zd2_779);										{	/* Eval/expddo.scm 60 */											obj_t BgL_varsz00_785;											BgL_varsz00_785 = BNIL;											{	/* Eval/expddo.scm 61 */												obj_t BgL_initsz00_786;												BgL_initsz00_786 = BNIL;												{	/* Eval/expddo.scm 62 */													obj_t BgL_stepsz00_787;													BgL_stepsz00_787 = BNIL;													{	/* Eval/expddo.scm 63 */														obj_t BgL_loopz00_788;														BgL_loopz00_788 =															BGl_gensymz00zz__r4_symbols_6_4z00															(BGl_string2221z00zz__expander_doz00);														{	/* Eval/expddo.scm 64 */															obj_t BgL_testz00_789;															if (PAIRP(BgL_endz00_771))																{	/* Eval/expddo.scm 65 */																	BgL_testz00_789 = CAR(BgL_endz00_771);																}															else																{	/* Eval/expddo.scm 65 */																	BgL_testz00_789 =																		BGl_errorz00zz__errorz00																		(BGl_string2222z00zz__expander_doz00,																		BGl_string2223z00zz__expander_doz00,																		BgL_expz00_1);																}															{	/* Eval/expddo.scm 65 */																obj_t BgL_endingz00_790;																if (NULLP(CDR(BgL_endz00_771)))																	{	/* Eval/expddo.scm 69 */																		obj_t BgL_list1957z00_850;																		BgL_list1957z00_850 =																			MAKE_PAIR(BFALSE, BNIL);																		BgL_endingz00_790 = BgL_list1957z00_850;																	}																else																	{	/* Eval/expddo.scm 68 */																		BgL_endingz00_790 = CDR(BgL_endz00_771);																	}																{	/* Eval/expddo.scm 71 */																	{	/* Eval/expddo.scm 72 */																		obj_t BgL_g1850z00_792;																		BgL_g1850z00_792 =																			bgl_reverse(BgL_bindingsz00_770);																		{																			obj_t BgL_l1848z00_794;																			BgL_l1848z00_794 = BgL_g1850z00_792;																		BgL_zc3anonymousza31899ze3z83_795:																			if (PAIRP(BgL_l1848z00_794))																				{	/* Eval/expddo.scm 85 */																					{	/* Eval/expddo.scm 74 */																						obj_t BgL_varzd2initzd2stepz00_797;																						BgL_varzd2initzd2stepz00_797 =																							CAR(BgL_l1848z00_794);																						{	/* Eval/expddo.scm 74 */																							bool_t BgL_testz00_1556;																							if (																								(bgl_list_length//.........这里部分代码省略.........

static int iol2v_append_byte_seq(iol2v_state_t *state, Eterm seq_start, Eterm *seq_end) {    Eterm lookahead, iterator;    Uint observed_bits;    SWord seq_length;    char *acc_data;    lookahead = seq_start;    seq_length = 0;    ASSERT(state->bytereds_available > state->bytereds_spent);    while (is_list(lookahead)) {        Eterm *cell = list_val(lookahead);        if (!is_small(CAR(cell))) {            break;        }        if (seq_length * 2 >= (state->bytereds_available - state->bytereds_spent)) {            break;        }        lookahead = CDR(cell);        seq_length += 1;    }    ASSERT(seq_length >= 1);    iol2v_expand_acc(state, seq_length);    /* Bump a few extra reductions to account for list traversal. */    state->bytereds_spent += seq_length;    acc_data = &(state->acc)->orig_bytes[state->acc_size];    state->acc_size += seq_length;    iterator = seq_start;    observed_bits = 0;    while (iterator != lookahead) {        Eterm *cell;        Uint byte;        cell = list_val(iterator);        iterator = CDR(cell);        byte = unsigned_val(CAR(cell));        observed_bits |= byte;        ASSERT(acc_data < &(state->acc)->orig_bytes[state->acc_size]);        *(acc_data++) = byte;    }    if (observed_bits > UCHAR_MAX) {        return 0;    }    ASSERT(acc_data == &(state->acc)->orig_bytes[state->acc_size]);    *seq_end = iterator;    return 1;}

SEXP attribute_hidden do_sprintf(SEXP call, SEXP op, SEXP args, SEXP env){    int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;    /* fmt2 is a copy of fmt with '*' expanded.       bit will hold numeric formats and %<w>s, so be quite small. */    char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],	*outputString;    const char *formatString;    size_t n, cur, chunk;    SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue;    int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0;    static R_StringBuffer outbuff = {NULL, 0, MAXELTSIZE};    Rboolean has_star, use_UTF8;#define _my_sprintf(_X_)						/    {									/	int nc = snprintf(bit, MAXLINE+1, fmtp, _X_);			/	if (nc > MAXLINE)						/	    error(_("required resulting string length %d is greater than maximal %d"), /		  nc, MAXLINE);						/    }    nargs = length(args);    /* grab the format string */    format = CAR(args);    if (!isString(format))	error(_("'fmt' is not a character vector"));    nfmt = length(format);    if (nfmt == 0) return allocVector(STRSXP, 0);    args = CDR(args); nargs--;    if(nargs >= MAXNARGS)	error(_("only %d arguments are allowed"), MAXNARGS);    /* record the args for possible coercion and later re-ordering */    for(i = 0; i < nargs; i++, args = CDR(args)) {	SEXPTYPE t_ai;	a[i] = CAR(args);	if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */	    error(_("invalid type of argument[%d]: '%s'"),		  i+1, CHAR(type2str(t_ai)));	lens[i] = length(a[i]);	if(lens[i] == 0) return allocVector(STRSXP, 0);    }#define CHECK_maxlen							/    maxlen = nfmt;							/    for(i = 0; i < nargs; i++)						/	if(maxlen < lens[i]) maxlen = lens[i];				/    if(maxlen % nfmt)							/	error(_("arguments cannot be recycled to the same length"));	/    for(i = 0; i < nargs; i++)						/	if(maxlen % lens[i])						/	    error(_("arguments cannot be recycled to the same length"))    CHECK_maxlen;    outputString = R_AllocStringBuffer(0, &outbuff);    /* We do the format analysis a row at a time */    for(ns = 0; ns < maxlen; ns++) {	outputString[0] = '/0';	use_UTF8 = getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8;	if (!use_UTF8) {	    for(i = 0; i < nargs; i++) {		if (!isString(a[i])) continue;		if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) {		    use_UTF8 = TRUE; break;		}	    }	}	formatString = TRANSLATE_CHAR(format, ns % nfmt);	n = strlen(formatString);	if (n > MAXLINE)	    error(_("'fmt' length exceeds maximal format length %d"), MAXLINE);	/* process the format string */	for (cur = 0, cnt = 0; cur < n; cur += chunk) {	    const char *curFormat = formatString + cur, *ss;	    char *starc;	    ss = NULL;	    if (formatString[cur] == '%') { /* handle special format command */		if (cur < n - 1 && formatString[cur + 1] == '%') {		    /* take care of %% in the format */		    chunk = 2;		    strcpy(bit, "%");		}		else {		    /* recognise selected types from Table B-1 of K&R */		    /* NB: we deal with "%%" in branch above. */		    /* This is MBCS-OK, as we are in a format spec */		    chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2;		    if (cur + chunk > n)			error(_("unrecognised format specification '%s'"), curFormat);		    strncpy(fmt, curFormat, chunk);		    fmt[chunk] = '/0';		    nthis = -1;//.........这里部分代码省略.........

SEXPdo_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env){    SEXP result = R_NilValue, prompt;    pDevDesc dd;    pGEDevDesc gd;    int i, count=0, devNum;    checkArity(op, args);        prompt = CAR(args);    if (!isString(prompt) || !length(prompt)) error(_("invalid prompt"));    /* NB:  cleanup of event handlers must be done by driver in onExit handler */        if (!NoDevices()) {        /* Initialize all devices */        i = 1;	devNum = curDevice();	while (i++ < NumDevices()) {	    gd = GEgetDevice(devNum);	    dd = gd->dev;	    if (dd->gettingEvent)	    	error(_("recursive use of 'getGraphicsEvent' not supported"));	    if (dd->eventEnv != R_NilValue) {	        if (dd->eventHelper) dd->eventHelper(dd, 1);	        dd->gettingEvent = TRUE;	        defineVar(install("result"), R_NilValue, dd->eventEnv);	        count++;	    }	    devNum = nextDevice(devNum);	}	if (!count)	    error(_("no graphics event handlers set"));	    	Rprintf("%s/n", CHAR(asChar(prompt)));	R_FlushConsole();	/* Poll them */	while (result == R_NilValue) {	    R_ProcessEvents();	    R_CheckUserInterrupt();	    i = 1;	    devNum = curDevice();	    while (i++ < NumDevices()) {		gd = GEgetDevice(devNum);		dd = gd->dev;		if (dd->eventEnv != R_NilValue) {		    if (dd->eventHelper) dd->eventHelper(dd, 2);		    result = findVar(install("result"), dd->eventEnv);		    if (result != R_NilValue && result != R_UnboundValue) {		        break;		    }		}		devNum = nextDevice(devNum);	    }	}	/* clean up */        i = 1;	devNum = curDevice();	while (i++ < NumDevices()) {	    gd = GEgetDevice(devNum);	    dd = gd->dev;	    if (dd->eventEnv != R_NilValue) {	        if (dd->eventHelper) dd->eventHelper(dd, 0);	        dd->gettingEvent = FALSE;	    }	    devNum = nextDevice(devNum);	}	    }    return(result);}

/**  Returns the head element of a pairlist.  *  *  @param sexp An R pairlist.  *  @return The head element of the R pairlist.  */CAMLprim value ocamlr_inspect_listsxp_carval (value sexp) {  return(Val_sexp(CAR(Sexp_val(sexp))));}

LPEXP KlwGetBinding(ATOMID idVarName){    varctx ctx = varstack ? (varctx) GLOBALLOCK(varstack->hCtx) : NULL;    while (ctx) {        GLOBALHANDLE hPrev = ctx->hPrev;        LPEXP lpBinding = NULL;                if (ctx->idCode && ctx->idCode != srclns.idCode ||            ctx->wType && ctx->wType != srclns.wType)        {            GLOBALUNLOCK(ctx->hCtx);            return NULL;        }                if (ctx->idVarList)        {            VARID idVar;            LIST_LOOP loop;                        kpc_init_loop(ctx->idVarList, &loop);                        while (idVar = next(&loop)) {                LPVAR lpVar = (LPVAR) KppGetItem(VAR, idVar);                                if (lpVar)                {                    LISTID idBindings = BINDINGS(lpVar);                    ITEMID idValue = VARVALUE(lpVar);                    ATOMID idName = VARNAME(lpVar);                    WORD wFlags = VARFLAGS(lpVar);                                    KppReleaseItem(VAR, idVar);                    if (idName == idVarName)                    {                        if (wFlags & EXPBOUND)                        {                            EXPFLAGS(&resexp) = wFlags;                            CAR(&resexp) = idValue;                            lpBinding = &resexp;                        }                        else if (idBindings)                        {                            WORD wIndex = KppGetElem(idBindings, 1);                                                    if (!wIndex)                                break;                            lpBinding = ctx->lpBody + wIndex - 1;                        }                        break;                    }                }            }        }                GLOBALUNLOCK(ctx->hCtx);                    if (lpBinding)            return lpBinding;                    if (hPrev)            ctx = (varctx) GLOBALLOCK(hPrev);        else            return NULL;    }        return NULL;}

Eterm copy_struct(Eterm obj, Uint sz, Eterm** hpp, ErlOffHeap* off_heap)#endif{    char* hstart;    Uint hsize;    Eterm* htop;    Eterm* hbot;    Eterm* hp;    Eterm* objp;    Eterm* tp;    Eterm  res;    Eterm  elem;    Eterm* tailp;    Eterm* argp;    Eterm* const_tuple;    Eterm hdr;    int i;#ifdef DEBUG    Eterm org_obj = obj;    Uint org_sz = sz;#endif    if (IS_CONST(obj))	return obj;    DTRACE1(copy_struct, (int32_t)sz);    hp = htop = *hpp;    hbot   = htop + sz;    hstart = (char *)htop;    hsize = (char*) hbot - hstart;    const_tuple = 0;    /* Copy the object onto the heap */    switch (primary_tag(obj)) {    case TAG_PRIMARY_LIST:	argp = &res;	objp = list_val_rel(obj,src_base);	goto L_copy_list;    case TAG_PRIMARY_BOXED: argp = &res; goto L_copy_boxed;    default:	erl_exit(ERTS_ABORT_EXIT,		 "%s, line %d: Internal error in copy_struct: 0x%08x/n",		 __FILE__, __LINE__,obj);    } L_copy:    while (hp != htop) {	obj = *hp;	switch (primary_tag(obj)) {	case TAG_PRIMARY_IMMED1:	    hp++;	    break;	case TAG_PRIMARY_LIST:	    objp = list_val_rel(obj,src_base);	#if !HALFWORD_HEAP || defined(DEBUG)	    if (in_area(objp,hstart,hsize)) {		ASSERT(!HALFWORD_HEAP);		hp++;		break;	    }	#endif	    argp = hp++;	    /* Fall through */	L_copy_list:	    tailp = argp;	    for (;;) {		tp = tailp;		elem = CAR(objp);		if (IS_CONST(elem)) {		    hbot -= 2;		    CAR(hbot) = elem;		    tailp = &CDR(hbot);		}		else {		    CAR(htop) = elem;		#if HALFWORD_HEAP		    CDR(htop) = CDR(objp);		    *tailp = make_list_rel(htop,dst_base);		    htop += 2;		    goto L_copy;		#else		    tailp = &CDR(htop);		    htop += 2;		#endif		}		ASSERT(!HALFWORD_HEAP || tp < hp || tp >= hbot);		*tp = make_list_rel(tailp - 1, dst_base);		obj = CDR(objp);		if (!is_list(obj)) {		    break;		}		objp = list_val_rel(obj,src_base);	    }	    switch (primary_tag(obj)) {	    case TAG_PRIMARY_IMMED1: *tailp = obj; goto L_copy;	    case TAG_PRIMARY_BOXED: argp = tailp; goto L_copy_boxed;	    default://.........这里部分代码省略.........

/********************************************************** *	 start of g_error_ops library function		  * **********************************************************/short W_EXPORT KppErrorLH (LPEXP lpExp){    ITEMID idfName;    short sResult;    WORD i;    LPEXP lpExp2=NULL;        idfName = CAR(lpExp);    KppGetAtomName(idfName, (LPSTR)stName, SIZE-1);    switch(stName[0])	{	case 'C':	/* CatchError */	    if (CDR(lpExp) == 0)		return RegisterKappaMessage(				IDE_MISSINGARGS, idfName,NULLID,NULLID);	    lpExp += CDR(lpExp);        if (CDR(lpExp) != 0)	/* error handling expression */        {            lpExp2 = lpExp + CDR(lpExp);            if (CDR(lpExp2) != 0)                return RegisterKappaMessage(                    IDE_TOOMANYARGS, idfName,NULLID,NULLID);        }        kal_catch_level++;        i = Kpp_EvalArgWithList(lpExp);        kal_catch_level--;        if (i) return i; 	    /* Clear the error stack only to the point where of lpExp */	    KppClearPartialTraceStack (lpExp, FALSE);		    /* AN ERROR HAS OCCURED */	    if (lpExp2 == NULL)  /* No error handling expression */            KappaReturnAtom(lpIDs->idNull);	    return Kpp_EvalArgWithList(lpExp2);	 case 'P':	/* PostError */	    *szMsgBuffer = '/0';        if (CDR(lpExp) != 0)	/* Message Is Passed */        {            lpExp += CDR (lpExp);                        sResult = KppAppendArgsAsString (szMsgBuffer,                RET_BUFFER_LEN -1, CAR(lpExp), &lpExp);                        if (sResult == ERROR) KappaReturnError;        } /* Message Is Passed */		RegisterKappaMessage(IDE_ERRORUSER,            KppAddAtom (szMsgBuffer), NULLID, NULLID);        KappaReturnError;    } /* switch */    KappaReturnError;}

Elem & Machine::execute(std::ostream &out){    Instruction *command;    std::shared_ptr<Elem> command_ptr;    Elem *ADD(new Instruction("ADD"));    Elem *MUL(new Instruction("MUL"));    Elem *SUB(new Instruction("SUB"));    Elem *DIV(new Instruction("DIV"));    Elem *REM(new Instruction("REM"));    Elem *EQ(new Instruction("EQ"));    Elem *LEQ(new Instruction("LEQ"));    Elem *SEL(new Instruction("SEL"));    Elem *LD(new Instruction("LD"));    Elem *LDC(new Instruction("LDC"));    Elem *LDF(new Instruction("LDF"));    Elem *CAR(new Instruction("CAR"));    Elem *CDR(new Instruction("CDR"));    Elem *CONS(new Instruction("CONS"));    Elem *NIL(new Instruction("NIL"));    Elem *DUM(new Instruction("DUM"));    Elem *AP(new Instruction("AP"));    Elem *RAP(new Instruction("RAP"));    Elem *RTN(new Instruction("RTN"));    Elem *JOIN(new Instruction("JOIN"));    Elem *STOP(new Instruction("STOP"));    while (!C->empty())    {        if (out != 0x0)        {            print_S(out);            print_E(out);            print_C(out);            out << std::endl;        }        command_ptr = C->pop_ret();        command = dynamic_cast<Instruction*>(&*command_ptr);        if (command == nullptr) throw Exception("Execute", "FatalError");        if (*command == *ADD)       this->ADD();        else if (*command == *MUL)  this->MUL();        else if (*command == *SUB)  this->SUB();        else if (*command == *DIV)  this->DIV();        else if (*command == *REM)  this->REM();        else if (*command == *EQ)   this->EQ();        else if (*command == *LEQ)  this->LEQ();        else if (*command == *SEL)  this->SEL();        else if (*command == *LD)   this->LD();        else if (*command == *LDC)  this->LDC();        else if (*command == *LDF)  this->LDF();        else if (*command == *CAR)  this->CAR();        else if (*command == *CDR)  this->CDR();        else if (*command == *CONS) this->CONS();        else if (*command == *NIL)  this->NIL();        else if (*command == *DUM)  this->DUM();        else if (*command == *AP)   this->AP();        else if (*command == *RAP)  this->RAP();        else if (*command == *RTN)  this->RTN();        else if (*command == *JOIN)  this->JOIN();        else if (*command == *STOP) { return (*(this->STOP()));}        else throw Exception("Execute", "Expected 'instruction' but greeted constant.");    }    throw Exception("Execute", "FatalError");}

SEXP attribute_hidden do_edit(SEXP call, SEXP op, SEXP args, SEXP rho){    int   i, rc;    ParseStatus status;    SEXP  x, fn, envir, ed, src, srcfile, Rfn;    char *filename, *editcmd;    const char *cmd;    const void *vmaxsave;    FILE *fp;#ifdef Win32    SEXP ti;    char *title;#endif	checkArity(op, args);    vmaxsave = vmaxget();    x = CAR(args); args = CDR(args);    if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);    else envir = R_NilValue;    PROTECT(envir);    fn = CAR(args); args = CDR(args);    if (!isString(fn))	error(_("invalid argument to edit()"));    if (LENGTH(STRING_ELT(fn, 0)) > 0) {	const char *ss = translateChar(STRING_ELT(fn, 0));	filename = R_alloc(strlen(ss), sizeof(char));	strcpy(filename, ss);    }    else filename = DefaultFileName;    if (x != R_NilValue) {	if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)	    errorcall(call, _("unable to open file"));	if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;	if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))	    src = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */	for (i = 0; i < LENGTH(src); i++)	    fprintf(fp, "%s/n", translateChar(STRING_ELT(src, i)));	fclose(fp);    }#ifdef Win32    ti = CAR(args);#endif    args = CDR(args);    ed = CAR(args);    if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));    cmd = translateChar(STRING_ELT(ed, 0));    if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));    editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));#ifdef Win32    if (!strcmp(cmd,"internal")) {	if (!isString(ti))	    error(_("'title' must be a string"));	if (LENGTH(STRING_ELT(ti, 0)) > 0) {	    title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));	    strcpy(title, CHAR(STRING_ELT(ti, 0)));	} else {	    title = R_alloc(strlen(filename)+1, sizeof(char));	    strcpy(title, filename);	}	Rgui_Edit(filename, CE_NATIVE, title, 1);    }    else {	/* Quote path if necessary */	if(cmd[0] != '"' && Rf_strchr(cmd, ' '))	    sprintf(editcmd, "/"%s/" /"%s/"", cmd, filename);	else	    sprintf(editcmd, "%s /"%s/"", cmd, filename);	rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);	if (rc == NOLAUNCH)	    errorcall(call, _("unable to run editor '%s'"), cmd);	if (rc != 0)	    warningcall(call, _("editor ran but returned error status"));    }#else    if (ptr_R_EditFile)	rc = ptr_R_EditFile(filename);    else {	sprintf(editcmd, "%s %s", cmd, filename);	rc = R_system(editcmd);    }    if (rc != 0)	errorcall(call, _("problem with running editor %s"), cmd);#endif    if (asLogical(GetOption1(install("keep.source")))) {	PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));	PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));	PROTECT(src = eval(src, R_BaseEnv));	PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));	PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));	srcfile = eval(srcfile, R_BaseEnv);	UNPROTECT(5);    } else    	srcfile = R_NilValue;    PROTECT(srcfile);//.........这里部分代码省略.........

/* used in eval.c */SEXP attribute_hidden R_subset3_dflt(SEXP x, SEXP input, SEXP call){    SEXP y, nlist;    size_t slen;    PROTECT(input);    PROTECT(x);    /* Optimisation to prevent repeated recalculation */    slen = strlen(translateChar(input));     /* The mechanism to allow a class extending "environment" */    if( IS_S4_OBJECT(x) && TYPEOF(x) == S4SXP ){        x = R_getS4DataSlot(x, ANYSXP);	if(x == R_NilValue)	    errorcall(call, "$ operator not defined for this S4 class");    }    UNPROTECT(1); /* x */    PROTECT(x);    /* If this is not a list object we return NULL. */    if (isPairList(x)) {	SEXP xmatch = R_NilValue;	int havematch;	UNPROTECT(2); /* input, x */	havematch = 0;	for (y = x ; y != R_NilValue ; y = CDR(y)) {	    switch(pstrmatch(TAG(y), input, slen)) {	    case EXACT_MATCH:		y = CAR(y);		if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));		return y;	    case PARTIAL_MATCH:		havematch++;		xmatch = y;		break;	    case NO_MATCH:		break;	    }	}	if (havematch == 1) { /* unique partial match */	    if(R_warn_partial_match_dollar) {		const char *st = "";		SEXP target = TAG(xmatch);		switch (TYPEOF(target)) {		case SYMSXP:		    st = CHAR(PRINTNAME(target));		    break;		case CHARSXP:		    st = translateChar(target);		    break;		}		warningcall(call, _("partial match of '%s' to '%s'"),			    translateChar(input), st);	    }	    y = CAR(xmatch);	    if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));	    return y;	}	return R_NilValue;    }    else if (isVectorList(x)) {	R_xlen_t i, n, imatch = -1;	int havematch;	nlist = getAttrib(x, R_NamesSymbol);	UNPROTECT(2); /* input, x */	n = xlength(nlist);	havematch = 0;	for (i = 0 ; i < n ; i = i + 1) {	    switch(pstrmatch(STRING_ELT(nlist, i), input, slen)) {	    case EXACT_MATCH:		y = VECTOR_ELT(x, i);		if (NAMED(x) > NAMED(y))		    SET_NAMED(y, NAMED(x));		return y;	    case PARTIAL_MATCH:		havematch++;		if (havematch == 1) {		    /* partial matches can cause aliasing in eval.c:evalseq		       This is overkill, but alternative ways to prevent		       the aliasing appear to be even worse */		    y = VECTOR_ELT(x,i);		    SET_NAMED(y,2);		    SET_VECTOR_ELT(x,i,y);		}		imatch = i;		break;	    case NO_MATCH:		break;	    }	}	if(havematch == 1) { /* unique partial match */	    if(R_warn_partial_match_dollar) {		const char *st = "";		SEXP target = STRING_ELT(nlist, imatch);		switch (TYPEOF(target)) {		case SYMSXP:		    st = CHAR(PRINTNAME(target));		    break;//.........这里部分代码省略.........

/* read-access-files */	BGL_EXPORTED_DEF obj_t BGl_readzd2accesszd2filesz00zzread_accessz00()	{		AN_OBJECT;		{	/* Read/access.scm 26 */			if (NULLP(BGl_za2accesszd2filesza2zd2zzengine_paramz00))				{	/* Read/access.scm 30 */					if (fexists(BSTRING_TO_STRING							(BGl_za2accesszd2filezd2defaultza2z00zzengine_paramz00)))						{	/* Read/access.scm 31 */							return								BGl_innerzd2readzd2accesszd2filezd2zzread_accessz00								(BGl_za2accesszd2filezd2defaultza2z00zzengine_paramz00);						}					else						{	/* Read/access.scm 31 */							return BFALSE;						}				}			else				{					obj_t BgL_l1508z00_90;					{	/* Read/access.scm 33 */						bool_t BgL_auxz00_129;						BgL_l1508z00_90 = BGl_za2accesszd2filesza2zd2zzengine_paramz00;					BgL_zc3anonymousza31512ze3z83_91:						if (PAIRP(BgL_l1508z00_90))							{	/* Read/access.scm 33 */								{	/* Read/access.scm 34 */									obj_t BgL_fz00_93;									BgL_fz00_93 = CAR(BgL_l1508z00_90);									if (fexists(BSTRING_TO_STRING(BgL_fz00_93)))										{	/* Read/access.scm 34 */											BGl_innerzd2readzd2accesszd2filezd2zzread_accessz00												(BgL_fz00_93);										}									else										{	/* Read/access.scm 34 */											BGl_userzd2errorzd2zztools_errorz00												(BGl_string1524z00zzread_accessz00,												BGl_string1525z00zzread_accessz00, BgL_fz00_93, BNIL);										}								}								{									obj_t BgL_l1508z00_138;									BgL_l1508z00_138 = CDR(BgL_l1508z00_90);									BgL_l1508z00_90 = BgL_l1508z00_138;									goto BgL_zc3anonymousza31512ze3z83_91;								}							}						else							{	/* Read/access.scm 33 */								BgL_auxz00_129 = ((bool_t) 1);							}						return BBOOL(BgL_auxz00_129);					}				}		}	}

static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop){    int k, mode;    SEXP dimnames, dimnamesnames, p, q, r, result, xdims;    const void *vmaxsave = vmaxget();    mode = TYPEOF(x);    xdims = getAttrib(x, R_DimSymbol);    k = length(xdims);    /* k is now the number of dims */    int **subs = (int**)R_alloc(k, sizeof(int*));    int *indx = (int*)R_alloc(k, sizeof(int));    int *bound = (int*)R_alloc(k, sizeof(int));    R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t));    /* Construct a vector to contain the returned values. */    /* Store its extents. */    R_xlen_t n = 1;    r = s;    for (int i = 0; i < k; i++) {	SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call));	bound[i] = LENGTH(CAR(r));	n *= bound[i];	r = CDR(r);    }    PROTECT(result = allocVector(mode, n));    r = s;    for (int i = 0; i < k; i++) {	indx[i] = 0;	subs[i] = INTEGER(CAR(r));	r = CDR(r);    }    offset[0] = 1;    for (int i = 1; i < k; i++)	offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];    /* Transfer the subset elements from "x" to "a". */    for (R_xlen_t i = 0; i < n; i++) {	R_xlen_t ii = 0;	for (int j = 0; j < k; j++) {	    int jj = subs[j][indx[j]];	    if (jj == NA_INTEGER) {		ii = NA_INTEGER;		goto assignLoop;	    }	    if (jj < 1 || jj > INTEGER(xdims)[j])		errorcall(call, R_MSG_subs_o_b);	    ii += (jj - 1) * offset[j];	}      assignLoop:	switch (mode) {	case LGLSXP:	    if (ii != NA_INTEGER)		LOGICAL(result)[i] = LOGICAL(x)[ii];	    else		LOGICAL(result)[i] = NA_LOGICAL;	    break;	case INTSXP:	    if (ii != NA_INTEGER)		INTEGER(result)[i] = INTEGER(x)[ii];	    else		INTEGER(result)[i] = NA_INTEGER;	    break;	case REALSXP:	    if (ii != NA_INTEGER)		REAL(result)[i] = REAL(x)[ii];	    else		REAL(result)[i] = NA_REAL;	    break;	case CPLXSXP:	    if (ii != NA_INTEGER) {		COMPLEX(result)[i] = COMPLEX(x)[ii];	    }	    else {		COMPLEX(result)[i].r = NA_REAL;		COMPLEX(result)[i].i = NA_REAL;	    }	    break;	case STRSXP:	    if (ii != NA_INTEGER)		SET_STRING_ELT(result, i, STRING_ELT(x, ii));	    else		SET_STRING_ELT(result, i, NA_STRING);	    break;	case VECSXP:	    if (ii != NA_INTEGER)		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));	    else		SET_VECTOR_ELT(result, i, R_NilValue);	    break;	case RAWSXP:	    if (ii != NA_INTEGER)		RAW(result)[i] = RAW(x)[ii];	    else		RAW(result)[i] = (Rbyte) 0;	    break;//.........这里部分代码省略.........

//.........这里部分代码省略.........	       targetname = newsuffixbase(argv[i],"");	       f = readfile(argv[i]);	       if (debug) {		    char *n = newsuffixbase(argv[i],".out");		    if (NULL == freopen(n,"w", stdout)) {			 fatal("can't open file %s",n);			 }		    put("After parsing:/n");		    pp(f);		    fflush(stdout);		    }	       outfilename = newsuffixbase(argv[i], do_this_cxx ? "-tmp.cc" : "-tmp.c");	       {		    char *n = newsuffixbase(argv[i],".dep.tmp");		    dependfile = fopen(n,"w");		    if (dependfile == NULL) fatal("can't open file %s",n);		    }	       f = chkprogram(f);	       if (debug) {		    char *n = newsuffixbase(argv[i],".log");		    if (NULL == freopen(n,"w", stdout)) {			 fatal("can't open file %s",n);			 }		    pprintl(f);		    }	       {		    node t = global_scope->signature;		    char *n = newsuffixbase(argv[i],".sig.tmp");		    if (NULL == freopen(n,"w", stdout)) {			 fatal("can't open file %s",n);			 }		    printf("-- generated by %s/n/n",progname);		    while (t != NULL) {			 dprint(CAR(t));			 put(";/n");			 t = CDR(t);			 }		    }	       if (stop_after_dep) quit();	       checkfordeferredsymbols();	       if (debug) {		    char *n = newsuffixbase(argv[i],".sym");		    if (NULL == freopen(n,"w", stdout)) {			 fatal("can't open file %s",n);			 }		    printsymboltable();		    printtypelist();		    printstringlist();		    }	       if (n_errors > 0) {		    quit();		    }	       if (TRUE) {		    char *n = newsuffixbase(argv[i],"-exports.h.tmp");		    if (NULL == freopen(n,"w", stdout)) {			 fatal("can't open file %s",n);			 }		    printf("#ifndef %s_included/n",targetname);		    printf("#define %s_included/n",targetname);		    declarationsstrings = reverse(declarationsstrings);		    while (declarationsstrings) {			 node s = unpos(car(declarationsstrings));			 assert(isstrconst(s));			 put_unescape(s->body.string_const.characters);			 put("/n");			 declarationsstrings = cdr(declarationsstrings);