コード例 #1
0
ファイル: copy.c プロジェクト: margnus1/otp
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:
		erl_exit(ERTS_ABORT_EXIT,
			 "%s, line %d: Internal error in copy_struct: 0x%08x\n",
			 __FILE__, __LINE__,obj);
	    }
	    
	case TAG_PRIMARY_BOXED:
	#if !HALFWORD_HEAP || defined(DEBUG)
	    if (in_area(boxed_val_rel(obj,src_base),hstart,hsize)) {
		ASSERT(!HALFWORD_HEAP);
		hp++;
		break;
	    }
	#endif
	    argp = hp++;

	L_copy_boxed:
	    objp = boxed_val_rel(obj, src_base);
	    hdr = *objp;
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG:
		{
		    int const_flag = 1; /* assume constant tuple */
		    i = arityval(hdr);
		    *argp = make_tuple_rel(htop, dst_base);
		    tp = htop;	/* tp is pointer to new arity value */
		    *htop++ = *objp++; /* copy arity value */
		    while (i--) {
			elem = *objp++;
			if (!IS_CONST(elem)) {
			    const_flag = 0;
			}
			*htop++ = elem;
		    }
		    if (const_flag) {
			const_tuple = tp; /* this is the latest const_tuple */
		    }
		}
		break;
	    case MAP_SUBTAG:
		{
		    i = map_get_size(objp) + 3;
		    *argp = make_map_rel(htop, dst_base);
		    while (i--) {
			*htop++ = *objp++;
		    }
		}
		break;
	    case REFC_BINARY_SUBTAG:
		{
                    EPIPHANY_STUB(copy_struct);
		}
		break;
	    case SUB_BINARY_SUBTAG:
		{
                    EPIPHANY_STUB(copy_struct);
		}
		break;
	    case FUN_SUBTAG:
		{
		    ErlFunThing* funp = (ErlFunThing *) objp;

		    i =  thing_arityval(hdr) + 2 + funp->num_free;
		    tp = htop;
		    while (i--)  {
			*htop++ = *objp++;
		    }
		    funp = (ErlFunThing *) tp;
		    funp->next = off_heap->first;
		    off_heap->first = (struct erl_off_heap_header*) funp;
		    erts_refc_inc(&funp->fe->refc, 2);
		    *argp = make_fun_rel(tp, dst_base);
		}
		break;
	    case EXTERNAL_PID_SUBTAG:
	    case EXTERNAL_PORT_SUBTAG:
	    case EXTERNAL_REF_SUBTAG:
		{
		  ExternalThing *etp = (ExternalThing *) htop;

		  i =  thing_arityval(hdr) + 1;
		  tp = htop;

		  while (i--)  {
		    *htop++ = *objp++;
		  }

		  etp->next = off_heap->first;
		  off_heap->first = (struct erl_off_heap_header*)etp;
		  erts_refc_inc(&etp->node->refc, 2);

		  *argp = make_external_rel(tp, dst_base);
		}
		break;
	    case BIN_MATCHSTATE_SUBTAG:
		erl_exit(ERTS_ABORT_EXIT,
			 "copy_struct: matchstate term not allowed");
	    default:
		i = thing_arityval(hdr)+1;
		hbot -= i;
		tp = hbot;
		*argp = make_boxed_rel(hbot, dst_base);
		while (i--) {
		    *tp++ = *objp++;
		}
	    }
	    break;
	case TAG_PRIMARY_HEADER:
	    if (header_is_thing(obj) || hp == const_tuple) {
		hp += header_arity(obj) + 1;
	    } else {
		hp++;
	    }
	    break;
	}
    }

#ifdef DEBUG
    if (htop != hbot)
	erl_exit(ERTS_ABORT_EXIT,
		 "Internal error in copy_struct() when copying %T:"
		 " htop=%p != hbot=%p (sz=%beu)\n",
		 org_obj, htop, hbot, org_sz); 
#else
    if (htop > hbot) {
	erl_exit(ERTS_ABORT_EXIT,
		 "Internal error in copy_struct(): htop, hbot overrun\n");
    }
#endif
    *hpp = (Eterm *) (hstart+hsize);
    return res;
}
コード例 #2
0
ファイル: test.c プロジェクト: kbob/schetoo
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));
}
コード例 #3
0
ファイル: subset.c プロジェクト: Maxsl/r-source
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;
	INTEGER(attr)[1] = ncs;
	setAttrib(result, R_DimSymbol, attr);
	UNPROTECT(1);
    }

    /* The matrix elements have been transferred.  Now we need to */
    /* transfer the attributes.	 Most importantly, we need to subset */
    /* the dimnames of the returned value. */

    if (nrs >= 0 && ncs >= 0) {
	SEXP dimnames, dimnamesnames, newdimnames;
	dimnames = getAttrib(x, R_DimNamesSymbol);
	PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
	if (!isNull(dimnames)) {
	    PROTECT(newdimnames = allocVector(VECSXP, 2));
	    if (TYPEOF(dimnames) == VECSXP) {
	      SET_VECTOR_ELT(newdimnames, 0,
		    ExtractSubset(VECTOR_ELT(dimnames, 0),
				  allocVector(STRSXP, nrs), sr, call));
	      SET_VECTOR_ELT(newdimnames, 1,
		    ExtractSubset(VECTOR_ELT(dimnames, 1),
				  allocVector(STRSXP, ncs), sc, call));
	    }
	    else {
	      SET_VECTOR_ELT(newdimnames, 0,
		    ExtractSubset(CAR(dimnames),
				  allocVector(STRSXP, nrs), sr, call));
	      SET_VECTOR_ELT(newdimnames, 1,
		    ExtractSubset(CADR(dimnames),
				  allocVector(STRSXP, ncs), sc, call));
	    }
	    setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
	    setAttrib(result, R_DimNamesSymbol, newdimnames);
	    UNPROTECT(1); /* newdimnames */
	}
	UNPROTECT(1); /* dimnamesnames */
    }
    /*  Probably should not do this:
    copyMostAttrib(x, result); */
    if (drop)
	DropDims(result);
    UNPROTECT(3);
    return result;
}
コード例 #4
0
ファイル: api.cpp プロジェクト: elenius/dplyr
 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) ) ;
     }
 }
コード例 #5
0
ファイル: walk.c プロジェクト: 8l/bigloo-llvm
/* 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;

								{	/* Inline/walk.scm 47 */
									bool_t BgL_testz00_1367;

									{	/* Inline/walk.scm 47 */
										obj_t BgL_auxz00_1368;

										{	/* Inline/walk.scm 47 */
											BgL_sfunz00_bglt BgL_obj1887z00_1262;

											{	/* Inline/walk.scm 47 */
												BgL_variablez00_bglt BgL_obj1611z00_1261;

												BgL_obj1611z00_1261 =
													(BgL_variablez00_bglt) (BgL_gz00_811);
												BgL_obj1887z00_1262 =
													(BgL_sfunz00_bglt) (
													(((BgL_variablez00_bglt) CREF(BgL_obj1611z00_1261))->
														BgL_valuez00));
											}
											BgL_auxz00_1368 =
												(((BgL_sfunz00_bglt) CREF(BgL_obj1887z00_1262))->
												BgL_classz00);
										}
										BgL_testz00_1367 =
											(BgL_auxz00_1368 == CNST_TABLE_REF(((long) 3)));
									}
									if (BgL_testz00_1367)
										{	/* Inline/walk.scm 47 */
											BgL_kfactorz00_812 = BINT(((long) 1));
										}
									else
										{	/* Inline/walk.scm 47 */
											BgL_kfactorz00_812 = BGl_za2kfactorza2z00zzinline_walkz00;
										}
								}
								{	/* Inline/walk.scm 53 */
									obj_t BgL_arg3295z00_813;

									{
										BgL_variablez00_bglt BgL_auxz00_1376;

										BgL_auxz00_1376 = (BgL_variablez00_bglt) (BgL_gz00_811);
										BgL_arg3295z00_813 =
											(((BgL_variablez00_bglt) CREF(BgL_auxz00_1376))->
											BgL_idz00);
									}
									BGl_enterzd2functionzd2zztools_errorz00(BgL_arg3295z00_813);
								}
								BGl_inlinezd2sfunz12zc0zzinline_inlinez00(
									(BgL_variablez00_bglt) (BgL_gz00_811),
									(long) CINT(BgL_kfactorz00_812), BNIL);
								BGl_leavezd2functionzd2zztools_errorz00();
						}}
						{
							obj_t BgL_l3275z00_1384;

							BgL_l3275z00_1384 = CDR(BgL_l3275z00_808);
							BgL_l3275z00_808 = BgL_l3275z00_1384;
							goto BgL_zc3anonymousza33293ze3z83_809;
						}
					}
				else
					{	/* Inline/walk.scm 46 */
						((bool_t) 1);
					}
			}
			{
				obj_t BgL_globalsz00_822;

				obj_t BgL_newzd2globalszd2_823;

				BgL_globalsz00_822 = BgL_globalsz00_1;
				BgL_newzd2globalszd2_823 = BNIL;
			BgL_zc3anonymousza33301ze3z83_824:
				if (NULLP(BgL_globalsz00_822))
					{	/* Inline/walk.scm 62 */
						obj_t BgL_valuez00_826;

						{	/* Inline/walk.scm 62 */
							obj_t BgL_arg3319z00_848;

							obj_t BgL_arg3320z00_849;

							BgL_arg3319z00_848 = CNST_TABLE_REF(((long) 4));
							BgL_arg3320z00_849 = bgl_reverse_bang(BgL_newzd2globalszd2_823);
							BgL_valuez00_826 =
								BGl_removezd2varzd2zzast_removez00(BgL_arg3319z00_848,
								BgL_arg3320z00_849);
						}
						if (
							((long) CINT(BGl_za2nbzd2errorzd2onzd2passza2zd2zztools_errorz00)
								> ((long) 0)))
							{	/* Inline/walk.scm 62 */
								{	/* Inline/walk.scm 62 */
									obj_t BgL_port3277z00_828;

									{	/* Inline/walk.scm 62 */
										obj_t BgL_res3391z00_1269;

										{	/* Inline/walk.scm 62 */
											obj_t BgL_auxz00_1394;

											BgL_auxz00_1394 = BGL_CURRENT_DYNAMIC_ENV();
											BgL_res3391z00_1269 =
												BGL_ENV_CURRENT_ERROR_PORT(BgL_auxz00_1394);
										}
										BgL_port3277z00_828 = BgL_res3391z00_1269;
									}
									bgl_display_obj
										(BGl_za2nbzd2errorzd2onzd2passza2zd2zztools_errorz00,
										BgL_port3277z00_828);
									bgl_display_string(BGl_string3396z00zzinline_walkz00,
										BgL_port3277z00_828);
									{	/* Inline/walk.scm 62 */
										obj_t BgL_arg3304z00_829;

										{	/* Inline/walk.scm 62 */
											bool_t BgL_testz00_1399;

											if (BGl_integerzf3zf3zz__r4_numbers_6_5_fixnumz00
												(BGl_za2nbzd2errorzd2onzd2passza2zd2zztools_errorz00))
												{	/* Inline/walk.scm 62 */
													BgL_testz00_1399 =
														BGl_2ze3ze3zz__r4_numbers_6_5z00
														(BGl_za2nbzd2errorzd2onzd2passza2zd2zztools_errorz00,
														BINT(((long) 1)));
												}
											else
												{	/* Inline/walk.scm 62 */
													BgL_testz00_1399 = ((bool_t) 0);
												}
											if (BgL_testz00_1399)
												{	/* Inline/walk.scm 62 */
													BgL_arg3304z00_829 =
														BGl_string3397z00zzinline_walkz00;
												}
											else
												{	/* Inline/walk.scm 62 */
													BgL_arg3304z00_829 =
														BGl_string3398z00zzinline_walkz00;
												}
										}
										bgl_display_obj(BgL_arg3304z00_829, BgL_port3277z00_828);
									}
									bgl_display_string(BGl_string3399z00zzinline_walkz00,
										BgL_port3277z00_828);
									bgl_display_char(((unsigned char) '\n'), BgL_port3277z00_828);
								}
								{	/* Inline/walk.scm 62 */
									obj_t BgL_list3307z00_832;

									BgL_list3307z00_832 = MAKE_PAIR(BINT(((long) -1)), BNIL);
									return BGl_exitz00zz__errorz00(BgL_list3307z00_832);
								}
							}
						else
							{	/* Inline/walk.scm 62 */
								obj_t BgL_g3273z00_833;

								obj_t BgL_g3274z00_834;

								{	/* Inline/walk.scm 62 */
									obj_t BgL_list3318z00_847;

									BgL_list3318z00_847 =
										MAKE_PAIR(BGl_showzd2statz12zd2envz12zzinline_walkz00,
										BNIL);
									BgL_g3273z00_833 = BgL_list3318z00_847;
								}
								BgL_g3274z00_834 = CNST_TABLE_REF(((long) 5));
								{
									obj_t BgL_hooksz00_836;

									obj_t BgL_hnamesz00_837;

									BgL_hooksz00_836 = BgL_g3273z00_833;
									BgL_hnamesz00_837 = BgL_g3274z00_834;
								BgL_zc3anonymousza33308ze3z83_838:
									if (NULLP(BgL_hooksz00_836))
										{	/* Inline/walk.scm 62 */
											return BgL_valuez00_826;
										}
									else
										{	/* Inline/walk.scm 62 */
											bool_t BgL_testz00_1414;

											{	/* Inline/walk.scm 62 */
												obj_t BgL_fun3317z00_845;

												BgL_fun3317z00_845 = CAR(BgL_hooksz00_836);
												BgL_testz00_1414 =
													CBOOL(PROCEDURE_ENTRY(BgL_fun3317z00_845)
													(BgL_fun3317z00_845, BEOA));
											}
											if (BgL_testz00_1414)
												{
													obj_t BgL_hnamesz00_1421;

													obj_t BgL_hooksz00_1419;

													BgL_hooksz00_1419 = CDR(BgL_hooksz00_836);
													BgL_hnamesz00_1421 = CDR(BgL_hnamesz00_837);
													BgL_hnamesz00_837 = BgL_hnamesz00_1421;
													BgL_hooksz00_836 = BgL_hooksz00_1419;
													goto BgL_zc3anonymousza33308ze3z83_838;
												}
											else
												{	/* Inline/walk.scm 62 */
													obj_t BgL_arg3314z00_844;

													BgL_arg3314z00_844 = CAR(BgL_hnamesz00_837);
													return
														BGl_internalzd2errorzd2zztools_errorz00
														(BGl_za2currentzd2passza2zd2zzengine_passz00,
														BGl_string3400z00zzinline_walkz00,
														BgL_arg3314z00_844);
												}
										}
								}
							}
					}
				else
					{	/* Inline/walk.scm 64 */
						bool_t BgL_testz00_1425;

						{	/* Inline/walk.scm 64 */
							obj_t BgL_arg3328z00_855;

							{	/* Inline/walk.scm 64 */
								BgL_globalz00_bglt BgL_obj1676z00_1283;

								{	/* Inline/walk.scm 64 */
									obj_t BgL_pairz00_1282;

									BgL_pairz00_1282 = BgL_globalsz00_822;
									BgL_obj1676z00_1283 =
										(BgL_globalz00_bglt) (CAR(BgL_pairz00_1282));
								}
								BgL_arg3328z00_855 =
									(((BgL_globalz00_bglt) CREF(BgL_obj1676z00_1283))->
									BgL_modulez00);
							}
							BgL_testz00_1425 =
								(BgL_arg3328z00_855 == BGl_za2moduleza2z00zzmodule_modulez00);
						}
						if (BgL_testz00_1425)
							{	/* Inline/walk.scm 65 */
								obj_t BgL_arg3324z00_851;

								obj_t BgL_arg3325z00_852;

								BgL_arg3324z00_851 = CDR(BgL_globalsz00_822);
								BgL_arg3325z00_852 =
									MAKE_PAIR(CAR(BgL_globalsz00_822), BgL_newzd2globalszd2_823);
								{
									obj_t BgL_newzd2globalszd2_1434;

									obj_t BgL_globalsz00_1433;

									BgL_globalsz00_1433 = BgL_arg3324z00_851;
									BgL_newzd2globalszd2_1434 = BgL_arg3325z00_852;
									BgL_newzd2globalszd2_823 = BgL_newzd2globalszd2_1434;
									BgL_globalsz00_822 = BgL_globalsz00_1433;
									goto BgL_zc3anonymousza33301ze3z83_824;
								}
							}
						else
							{
								obj_t BgL_globalsz00_1435;

								BgL_globalsz00_1435 = CDR(BgL_globalsz00_822);
								BgL_globalsz00_822 = BgL_globalsz00_1435;
								goto BgL_zc3anonymousza33301ze3z83_824;
							}
					}
			}
		}
	}
コード例 #6
0
ファイル: c-obj.c プロジェクト: poschengband/emrys
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;
}
コード例 #7
0
ファイル: eval.c プロジェクト: Card1nal/guile
static SCM
eval (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
        return scm_call_with_vm (scm_the_vm (), proc, args);

    case SCM_M_CALL:
      /* Evaluate the procedure to be applied.  */
      proc = EVAL1 (CAR (mx), env);
      argc = SCM_I_INUM (CADR (mx));
      mx = CDDR (mx);

      if (BOOT_CLOSURE_P (proc))
        {
          prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env);
          goto loop;
        }
      else
        {
	  SCM *argv;
	  unsigned int i;

	  argv = alloca (argc * sizeof (SCM));
	  for (i = 0; i < argc; i++, mx = CDR (mx))
	    argv[i] = EVAL1 (CAR (mx), env);

	  return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
        }

    case SCM_M_CONT:
      return scm_i_call_with_current_continuation (EVAL1 (mx, env));

    case SCM_M_CALL_WITH_VALUES:
      {
        SCM producer;
        SCM v;

        producer = EVAL1 (CAR (mx), env);
        /* `proc' is the consumer.  */
        proc = EVAL1 (CDR (mx), env);
        v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
        if (SCM_VALUESP (v))
          args = scm_struct_ref (v, SCM_INUM0);
        else
          args = scm_list_1 (v);
        goto apply_proc;
      }

    case SCM_M_LEXICAL_REF:
      {
        int n;
        SCM ret;
        for (n = SCM_I_INUM (mx); n; n--)
          env = CDR (env);
        ret = CAR (env);
        if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
          /* we don't know what variable, though, because we don't have its
             name */
          error_used_before_defined ();
        return ret;
      }

    case SCM_M_LEXICAL_SET:
      {
        int n;
        SCM val = EVAL1 (CDR (mx), env);
        for (n = SCM_I_INUM (CAR (mx)); n; n--)
          env = CDR (env);
        SCM_SETCAR (env, val);
        return SCM_UNSPECIFIED;
      }

    case SCM_M_TOPLEVEL_REF:
      if (SCM_VARIABLEP (mx))
        return SCM_VARIABLE_REF (mx);
      else
        {
          while (scm_is_pair (env))
            env = CDR (env);
          return SCM_VARIABLE_REF
            (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
        }

    case SCM_M_TOPLEVEL_SET:
      {
        SCM var = CAR (mx);
        SCM val = EVAL1 (CDR (mx), env);
        if (SCM_VARIABLEP (var))
          {
            SCM_VARIABLE_SET (var, val);
            return SCM_UNSPECIFIED;
          }
        else
          {
            while (scm_is_pair (env))
              env = CDR (env);
            SCM_VARIABLE_SET
              (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
               val);
            return SCM_UNSPECIFIED;
          }
      }

    case SCM_M_MODULE_REF:
      if (SCM_VARIABLEP (mx))
        return SCM_VARIABLE_REF (mx);
      else
        return SCM_VARIABLE_REF
          (scm_memoize_variable_access_x (x, SCM_BOOL_F));

    case SCM_M_MODULE_SET:
      if (SCM_VARIABLEP (CDR (mx)))
        {
          SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
          return SCM_UNSPECIFIED;
        }
      else
        {
          SCM_VARIABLE_SET
            (scm_memoize_variable_access_x (x, SCM_BOOL_F),
             EVAL1 (CAR (mx), env));
          return SCM_UNSPECIFIED;
        }

    case SCM_M_PROMPT:
      {
        SCM vm, k, res;
        scm_i_jmp_buf registers;
        /* We need the handler after nonlocal return to the setjmp, so
           make sure it is volatile.  */
        volatile SCM handler;

        k = EVAL1 (CAR (mx), env);
        handler = EVAL1 (CDDR (mx), env);
        vm = scm_the_vm ();

        /* Push the prompt onto the dynamic stack. */
        scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
                                  SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY,
                                  k,
                                  SCM_VM_DATA (vm)->fp,
                                  SCM_VM_DATA (vm)->sp,
                                  SCM_VM_DATA (vm)->ip,
                                  &registers);

        if (SCM_I_SETJMP (registers))
          {
            /* The prompt exited nonlocally. */
            proc = handler;
            args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
            goto apply_proc;
          }
        
        res = eval (CADR (mx), env);
        scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
        return res;
      }

    default:
      abort ();
    }
}
コード例 #8
0
ファイル: erl_io_queue.c プロジェクト: crownedgrouse/otp
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;
    }

    BIF_ERROR(state->process, BADARG);
}
コード例 #9
0
ファイル: erl_io_queue.c プロジェクト: crownedgrouse/otp
int
erts_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) {
			erts_emasculate_writable_binary(pb);
		    }
                    if (driver)
                        qbin = (ErtsIOQBinary*)Binary2ErlDrvBinary(pb->val);
                    else
                        qbin = (ErtsIOQBinary*)pb->val;

                    io_list_to_vec_set_vec(
                        &iov, &binv, qbin,
                        pb->bytes+offset, size, &vlen);
		}
	    } else {
		ErlHeapBin* hb = (ErlHeapBin *) bptr;
		if (len < size) {
		    goto L_overflow;
		}
		copy_binary_to_buffer(buf, 0,
				      ((byte *) hb->data)+offset, bitoffs,
				      8*size);
		csize += size;
		buf += size;
		len -= size;
	    }
	} else if (!is_nil(obj)) {
	    goto L_type_error;
	}
    }

    if (csize != 0) {
        io_list_to_vec_set_vec(&iov, &binv, cbin, cptr, csize, &vlen);
    }

    DESTROY_ESTACK(s);
    return vlen;

 L_type_error:
    DESTROY_ESTACK(s);
    return -2;

 L_overflow:
    DESTROY_ESTACK(s);
    return -1;
}
コード例 #10
0
ファイル: mexpand.c プロジェクト: mbrock/bigloo-llvm
/* 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;
				}
		}
	}
コード例 #11
0
ファイル: mexpand.c プロジェクト: mbrock/bigloo-llvm
/* 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;
				}
			}
		}
	}
コード例 #12
0
ファイル: mexpand.c プロジェクト: mbrock/bigloo-llvm
/* <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 =
																						BgL_prototypez00_828;
																					BgL_arg1916z00_833 =
																						CAR(CDR(BgL_pairz00_1402));
																				}
																				BgL_arg1915z00_832 =
																					MAKE_PAIR(BgL_arg1916z00_833,
																					BgL_bodyz00_829);
																			}
																			BgL_arg1910z00_826 =
																				MAKE_PAIR(BgL_arg1914z00_831,
																				BgL_arg1915z00_832);
																		}
																}
															}
															BgL_newtail1852z00_824 =
																MAKE_PAIR(BgL_arg1910z00_826, BNIL);
														}
														SET_CDR(BgL_tail1851z00_821,
															BgL_newtail1852z00_824);
														{
															obj_t BgL_tail1851z00_1805;

															obj_t BgL_l1848z00_1803;

															BgL_l1848z00_1803 = CDR(BgL_l1848z00_820);
															BgL_tail1851z00_1805 = BgL_newtail1852z00_824;
															BgL_tail1851z00_821 = BgL_tail1851z00_1805;
															BgL_l1848z00_820 = BgL_l1848z00_1803;
															goto BgL_zc3anonymousza31907ze3z83_822;
														}
													}
											}
										}
									BgL_arg1900z00_810 =
										BGl_eappendzd22zd2zz__r4_pairs_and_lists_6_3z00
										(BgL_arg1904z00_814, BNIL);
								}
								{	/* Match/mexpand.scm 101 */
									obj_t BgL_list1902z00_812;

									{	/* Match/mexpand.scm 101 */
										obj_t BgL_arg1903z00_813;

										BgL_arg1903z00_813 = MAKE_PAIR(BNIL, BNIL);
										BgL_list1902z00_812 =
											MAKE_PAIR(BgL_compiledzd2patzd2_806, BgL_arg1903z00_813);
									}
									BgL_arg1899z00_809 =
										BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
										(BgL_arg1900z00_810, BgL_list1902z00_812);
								}
							}
							return MAKE_PAIR(BgL_arg1898z00_808, BgL_arg1899z00_809);
						}
					}
				}
			}
		}
	}
コード例 #13
0
ファイル: mexpand.c プロジェクト: mbrock/bigloo-llvm
/* 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 =
																	BGl_symbol2306z00zz__match_expandz00;
																{	/* Match/mexpand.scm 85 */
																	obj_t BgL_arg1940z00_857;

																	BgL_arg1940z00_857 =
																		MAKE_PAIR
																		(BGl_symbol2309z00zz__match_expandz00,
																		BNIL);
																	{	/* Match/mexpand.scm 85 */
																		obj_t BgL_list1942z00_859;

																		BgL_list1942z00_859 = MAKE_PAIR(BNIL, BNIL);
																		BgL_arg1938z00_856 =
																			BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
																			(BgL_arg1940z00_857, BgL_list1942z00_859);
																	}
																}
																BgL_arg1929z00_850 =
																	MAKE_PAIR(BgL_arg1937z00_855,
																	BgL_arg1938z00_856);
															}
															{	/* Match/mexpand.scm 85 */
																obj_t BgL_list1931z00_852;

																{	/* Match/mexpand.scm 85 */
																	obj_t BgL_arg1932z00_853;

																	{	/* Match/mexpand.scm 85 */
																		obj_t BgL_arg1935z00_854;

																		BgL_arg1935z00_854 = MAKE_PAIR(BNIL, BNIL);
																		BgL_arg1932z00_853 =
																			MAKE_PAIR(BgL_arg1929z00_850,
																			BgL_arg1935z00_854);
																	}
																	BgL_list1931z00_852 =
																		MAKE_PAIR(BgL_tagz00_843,
																		BgL_arg1932z00_853);
																}
																BgL_arg1926z00_848 =
																	BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
																	(BgL_arg1927z00_849, BgL_list1931z00_852);
															}
														}
														BgL_arg1923z00_845 =
															MAKE_PAIR(BgL_arg1925z00_847, BgL_arg1926z00_848);
													}
													{	/* Match/mexpand.scm 86 */
														obj_t BgL_envz00_1423;

														BgL_envz00_1423 =
															BGl_za2thezd2emptyzd2envza2z00zz__match_expandz00;
														{	/* Match/mexpand.scm 86 */
															obj_t BgL_arg1982z00_1426;

															BgL_arg1982z00_1426 =
																MAKE_PAIR(BgL_tagz00_843, BgL_actionsz00_841);
															BgL_arg1924z00_846 =
																MAKE_PAIR(BgL_arg1982z00_1426, BgL_envz00_1423);
														}
													}
													return
														PROCEDURE_ENTRY(BgL_kz00_799) (BgL_kz00_799,
														BgL_arg1923z00_845, BgL_arg1924z00_846, BEOA);
												}
											else
												{	/* Match/mexpand.scm 90 */
													obj_t BgL_zc3anonymousza31944ze3z83_1690;

													BgL_zc3anonymousza31944ze3z83_1690 =
														make_fx_procedure
														(BGl_zc3anonymousza31944ze3z83zz__match_expandz00,
														(int) (((long) 2)), (int) (((long) 4)));
													PROCEDURE_SET(BgL_zc3anonymousza31944ze3z83_1690,
														(int) (((long) 0)), BgL_patternz00_840);
													PROCEDURE_SET(BgL_zc3anonymousza31944ze3z83_1690,
														(int) (((long) 1)), BgL_tagz00_843);
													PROCEDURE_SET(BgL_zc3anonymousza31944ze3z83_1690,
														(int) (((long) 2)), BgL_actionsz00_841);
													PROCEDURE_SET(BgL_zc3anonymousza31944ze3z83_1690,
														(int) (((long) 3)), BgL_kz00_799);
													{
														obj_t BgL_kz00_1776;

														obj_t BgL_clausesz00_1775;

														BgL_clausesz00_1775 = BgL_restz00_842;
														BgL_kz00_1776 = BgL_zc3anonymousza31944ze3z83_1690;
														BgL_kz00_799 = BgL_kz00_1776;
														BgL_clausesz00_798 = BgL_clausesz00_1775;
														goto BgL_clauseszd2ze3patternz31_800;
													}
												}
										}
									}
								else
									{	/* Match/mexpand.scm 77 */
										return
											BGl_errorz00zz__errorz00
											(BGl_symbol2316z00zz__match_expandz00,
											BGl_string2318z00zz__match_expandz00, BgL_expz00_1);
									}
							}
					}
				}
			}
		}
	}
コード例 #14
0
ファイル: reader.c プロジェクト: qyqx/wisp
/* Read a single sexp from the reader. */
object_t *read_sexp (reader_t * r)
{
  /* Check for a shebang line. */
  if (r->shebang == -1)
    {
      char str[2];
      str[0] = reader_getc (r);
      str[1] = reader_getc (r);
      if (str[0] == '#' && str[1] == '!')
	{
	  /* Looks like a she-bang line. */
	  r->shebang = 1;
	  consume_line (r);
	}
      else
	{
	  r->shebang = 0;
	  reader_putc (r, str[1]);
	  reader_putc (r, str[0]);
	}
    }

  r->done = 0;
  r->error = 0;
  push (r);
  print_prompt (r);
  while (!r->eof && !r->error && (list_empty (r) || stack_height (r) > 1))
    {
      int nc, c = reader_getc (r);
      switch (c)
	{
	case EOF:
	  r->eof = 1;
	  break;

	  /* Comments */
	case ';':
	  consume_line (r);
	  break;

	  /* Dotted pair */
	case '.':
	  nc = reader_getc (r);
	  if (strchr (" \t\r\n()", nc) != NULL)
	    {
	      if (r->state->dotpair_mode > 0)
		read_error (r, "invalid dotted pair syntax");
	      else if (r->state->vector_mode > 0)
		read_error (r, "dotted pair not allowed in vector");
	      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;
}
コード例 #15
0
// TODO: split out some of the large blocks into helper functions, to make this easier to read
void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, bool misplaced, RData *storage) {
	RK_TRACE (RBACKEND);

	bool is_function = false;
	bool is_container = false;
	bool is_environment = false;
	unsigned int type = 0;
	unsigned int count;

	RK_DO (qDebug ("fetching '%s': %p, s-type %d", name.toLatin1().data(), val, TYPEOF (val)), RBACKEND, DL_DEBUG);

	PROTECT (val);
	// manually resolve any promises
	SEXP value = resolvePromise (val);
	UNPROTECT (1);		/* val */
	PROTECT (value);

	// first field: get name
	RData *namedata = new RData;
	namedata->datatype = RData::StringVector;
	namedata->length = 1;
	QString *name_dummy = new QString[1];
	name_dummy[0] = name;
	namedata->data = name_dummy;

	// get classes
	SEXP classes_s;

	if (TYPEOF (value) == LANGSXP) {	// if it's a call, we should NEVER send it through eval
		extern SEXP R_data_class (SEXP, Rboolean);
		classes_s = R_data_class (value, (Rboolean) 0);

		value = coerceVector (value, EXPRSXP);	// make sure the object is safe for everything to come
		UNPROTECT (1); /* old value */

		PROTECT (classes_s);
		PROTECT (value);
	} else {
		classes_s = callSimpleFun (class_fun, value, R_BaseEnv);
		PROTECT (classes_s);
	}

	QString *classes = SEXPToStringList (classes_s, &count);
	unsigned int num_classes = count;
	UNPROTECT (1);	/* classes_s */

	// store classes
	RData *classdata = new RData;
	classdata->datatype = RData::StringVector;
	classdata->data = classes;
	classdata->length = num_classes;

	// basic classification
	for (unsigned int i = 0; i < num_classes; ++i) {
#warning: Using is.data.frame() may be more reliable (would need to be called only on List-objects, thus no major performance hit)
		if (classes[i] == "data.frame") type |= RObject::DataFrame;
	}

	if (callSimpleBool (is_matrix_fun, value, R_BaseEnv)) type |= RObject::Matrix;
	if (callSimpleBool (is_array_fun, value, R_BaseEnv)) type |= RObject::Array;
	if (callSimpleBool (is_list_fun, value, R_BaseEnv)) type |= RObject::List;

	if (type != 0) {
		is_container = true;
		type |= RObject::Container;
	} else {
		if (callSimpleBool (is_function_fun, value, R_BaseEnv)) {
			is_function = true;
			type |= RObject::Function;
		} else if (callSimpleBool (is_environment_fun, value, R_BaseEnv)) {
			is_container = true;
			is_environment = true;
			type |= RObject::Environment;
		} else {
			type |= RObject::Variable;
			if (callSimpleBool (is_factor_fun, value, R_BaseEnv)) type |= RObject::Factor;
			else if (callSimpleBool (is_numeric_fun, value, R_BaseEnv)) type |= RObject::Numeric;
			else if (callSimpleBool (is_character_fun, value, R_BaseEnv)) type |= RObject::Character;
			else if (callSimpleBool (is_logical_fun, value, R_BaseEnv)) type |= RObject::Logical;
		}
	}
	if (misplaced) type |= RObject::Misplaced;

	// get meta data, if any
	RData *metadata = new RData;
	metadata->datatype = RData::StringVector;
	if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
		type |= RObject::HasMetaObject;

		SEXP meta_s = callSimpleFun (get_meta_fun, value, R_GlobalEnv);
		PROTECT (meta_s);
		metadata->data = SEXPToStringList (meta_s, &count);
		metadata->length = count;
		UNPROTECT (1);	/* meta_s */
	} else {
		metadata->length = 1;
		QString *meta_dummy = new QString[1];
		meta_dummy[0] = "";
		metadata->data = meta_dummy;
	}

	// store type
	RData *typedata = new RData;
	typedata->datatype = RData::IntVector;
	typedata->length = 1;
	int *type_dummy = new int[1];
	type_dummy[0] = type;
	typedata->data = type_dummy;

	// get dims
	int *dims;
	unsigned int num_dims;
	SEXP dims_s = callSimpleFun (dims_fun, value, R_BaseEnv);
	if (!Rf_isNull (dims_s)) {
		dims = SEXPToIntArray (dims_s, &num_dims);
	} else {
		num_dims = 1;

		unsigned int len = Rf_length (value);
		if ((len < 2) && (!is_function)) {		// suspicious. Maybe some kind of list
			SEXP len_s = callSimpleFun (length_fun, value, R_BaseEnv);
			PROTECT (len_s);
			if (Rf_isNull (len_s)) {
				dims = new int[1];
				dims[0] = len;
			} else {
				dims = SEXPToIntArray (len_s, &num_dims);
			}
			UNPROTECT (1); /* len_s */
		} else {
			dims = new int[1];
			dims[0] = len;
		}
	}

	// store dims
	RData *dimdata = new RData;
	dimdata->datatype = RData::IntVector;
	dimdata->length = num_dims;
	dimdata->data = dims;

	// store everything we have so far
	if (is_container) {
		storage->length = 6;
	} else if (is_function) {
		storage->length = 7;
	} else {
		storage->length = 5;
	}
	storage->datatype = RData::StructureVector;
	RData **res = new RData*[storage->length];
	storage->data = res;
	res[0] = namedata;
	res[1] = typedata;
	res[2] = classdata;
	res[3] = metadata;
	res[4] = dimdata;

	// now add the extra info for containers and functions
	if (is_container) {
		bool do_env = (is_environment && (++envir_depth < 2));
		bool do_cont = is_container && (!is_environment);

		RData *childdata = new RData;
		childdata->datatype = RData::StructureVector;
		childdata->length = 0;
		childdata->data = 0;
		res[5] = childdata;

		// fetch list of child names
		unsigned int childcount;
		SEXP childnames_s;
		if (do_env) {
			childnames_s = R_lsInternal (value, (Rboolean) 1);
		} else if (do_cont) {
			childnames_s = callSimpleFun (names_fun, value, R_BaseEnv);
		} else {
			childnames_s = R_NilValue; // dummy
		}
		PROTECT (childnames_s);
		QString *childnames = SEXPToStringList (childnames_s, &childcount);

		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 */
}
コード例 #16
0
ファイル: erl_io_queue.c プロジェクト: crownedgrouse/otp
/* 
 * 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
 */
int
erts_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;
}
コード例 #17
0
ファイル: expddo.c プロジェクト: mbrock/bigloo-llvm
/* 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
																									(BgL_varzd2initzd2stepz00_797)
																									>= ((long) 2)))
																								{	/* Eval/expddo.scm 74 */
																									BgL_testz00_1556 =
																										(bgl_list_length
																										(BgL_varzd2initzd2stepz00_797)
																										<= ((long) 3));
																								}
																							else
																								{	/* Eval/expddo.scm 74 */
																									BgL_testz00_1556 =
																										((bool_t) 0);
																								}
																							if (BgL_testz00_1556)
																								{	/* Eval/expddo.scm 76 */
																									obj_t BgL_varz00_799;

																									BgL_varz00_799 =
																										CAR
																										(BgL_varzd2initzd2stepz00_797);
																									{	/* Eval/expddo.scm 76 */
																										obj_t BgL_initz00_800;

																										{	/* Eval/expddo.scm 77 */
																											obj_t BgL_pairz00_1319;

																											BgL_pairz00_1319 =
																												BgL_varzd2initzd2stepz00_797;
																											BgL_initz00_800 =
																												CAR(CDR
																												(BgL_pairz00_1319));
																										}
																										{	/* Eval/expddo.scm 77 */
																											obj_t BgL_stepz00_801;

																											{	/* Eval/expddo.scm 78 */
																												bool_t BgL_testz00_1565;

																												{	/* Eval/expddo.scm 78 */
																													obj_t BgL_auxz00_1566;

																													{	/* Eval/expddo.scm 78 */
																														obj_t
																															BgL_pairz00_1323;
																														BgL_pairz00_1323 =
																															BgL_varzd2initzd2stepz00_797;
																														BgL_auxz00_1566 =
																															CDR(CDR
																															(BgL_pairz00_1323));
																													}
																													BgL_testz00_1565 =
																														NULLP
																														(BgL_auxz00_1566);
																												}
																												if (BgL_testz00_1565)
																													{	/* Eval/expddo.scm 78 */
																														BgL_stepz00_801 =
																															BgL_varz00_799;
																													}
																												else
																													{	/* Eval/expddo.scm 79 */
																														obj_t
																															BgL_pairz00_1332;
																														{	/* Eval/expddo.scm 79 */
																															obj_t
																																BgL_pairz00_1328;
																															BgL_pairz00_1328 =
																																BgL_varzd2initzd2stepz00_797;
																															BgL_pairz00_1332 =
																																CDR(CDR
																																(BgL_pairz00_1328));
																														}
																														BgL_stepz00_801 =
																															CAR
																															(BgL_pairz00_1332);
																													}
																											}
																											{	/* Eval/expddo.scm 78 */

																												BgL_varsz00_785 =
																													MAKE_PAIR
																													(BgL_varz00_799,
																													BgL_varsz00_785);
																												BgL_stepsz00_787 =
																													MAKE_PAIR
																													(BgL_stepz00_801,
																													BgL_stepsz00_787);
																												BgL_initsz00_786 =
																													MAKE_PAIR
																													(BgL_initz00_800,
																													BgL_initsz00_786);
																											}
																										}
																									}
																								}
																							else
																								{	/* Eval/expddo.scm 74 */
																									BGl_errorz00zz__errorz00
																										(BGl_symbol2224z00zz__expander_doz00,
																										BGl_string2225z00zz__expander_doz00,
																										BgL_varzd2initzd2stepz00_797);
																								}
																						}
																					}
																					{
																						obj_t BgL_l1848z00_1577;

																						BgL_l1848z00_1577 =
																							CDR(BgL_l1848z00_794);
																						BgL_l1848z00_794 =
																							BgL_l1848z00_1577;
																						goto
																							BgL_zc3anonymousza31899ze3z83_795;
																					}
																				}
																			else
																				{	/* Eval/expddo.scm 85 */
																					((bool_t) 1);
																				}
																		}
																	}
																	{	/* Eval/expddo.scm 86 */
																		obj_t BgL_arg1911z00_812;

																		{	/* Eval/expddo.scm 86 */
																			obj_t BgL_arg1912z00_813;

																			obj_t BgL_arg1914z00_814;

																			BgL_arg1912z00_813 =
																				BGl_symbol2226z00zz__expander_doz00;
																			{	/* Eval/expddo.scm 86 */
																				obj_t BgL_arg1915z00_815;

																				obj_t BgL_arg1916z00_816;

																				{	/* Eval/expddo.scm 86 */
																					obj_t BgL_arg1921z00_820;

																					{	/* Eval/expddo.scm 86 */
																						obj_t BgL_arg1923z00_822;

																						{	/* Eval/expddo.scm 86 */
																							obj_t BgL_arg1924z00_823;

																							{	/* Eval/expddo.scm 86 */
																								obj_t BgL_arg1927z00_826;

																								obj_t BgL_arg1929z00_827;

																								BgL_arg1927z00_826 =
																									BGl_symbol2228z00zz__expander_doz00;
																								{	/* Eval/expddo.scm 87 */
																									obj_t BgL_arg1930z00_828;

																									{	/* Eval/expddo.scm 87 */
																										obj_t BgL_arg1937z00_832;

																										obj_t BgL_arg1938z00_833;

																										BgL_arg1937z00_832 =
																											BGl_symbol2230z00zz__expander_doz00;
																										{	/* Eval/expddo.scm 88 */
																											obj_t BgL_arg1940z00_834;

																											obj_t BgL_arg1941z00_835;

																											BgL_arg1940z00_834 =
																												MAKE_PAIR
																												(BGl_symbol2232z00zz__expander_doz00,
																												BGl_eappendzd22zd2zz__r4_pairs_and_lists_6_3z00
																												(BgL_endingz00_790,
																													BNIL));
																											{	/* Eval/expddo.scm 89 */
																												obj_t
																													BgL_arg1949z00_842;
																												obj_t
																													BgL_arg1950z00_843;
																												BgL_arg1949z00_842 =
																													BGl_symbol2232z00zz__expander_doz00;
																												{	/* Eval/expddo.scm 90 */
																													obj_t
																														BgL_arg1951z00_844;
																													{	/* Eval/expddo.scm 90 */
																														obj_t
																															BgL_arg1952z00_845;
																														BgL_arg1952z00_845 =
																															MAKE_PAIR
																															(BgL_loopz00_788,
																															BGl_eappendzd22zd2zz__r4_pairs_and_lists_6_3z00
																															(BgL_stepsz00_787,
																																BNIL));
																														BgL_arg1951z00_844 =
																															MAKE_PAIR
																															(BgL_arg1952z00_845,
																															BNIL);
																													}
																													BgL_arg1950z00_843 =
																														BGl_eappendzd22zd2zz__r4_pairs_and_lists_6_3z00
																														(BgL_commandz00_772,
																														BgL_arg1951z00_844);
																												}
																												BgL_arg1941z00_835 =
																													MAKE_PAIR
																													(BgL_arg1949z00_842,
																													BgL_arg1950z00_843);
																											}
																											{	/* Eval/expddo.scm 87 */
																												obj_t
																													BgL_list1943z00_837;
																												{	/* Eval/expddo.scm 87 */
																													obj_t
																														BgL_arg1944z00_838;
																													{	/* Eval/expddo.scm 87 */
																														obj_t
																															BgL_arg1945z00_839;
																														BgL_arg1945z00_839 =
																															MAKE_PAIR(BNIL,
																															BNIL);
																														BgL_arg1944z00_838 =
																															MAKE_PAIR
																															(BgL_arg1941z00_835,
																															BgL_arg1945z00_839);
																													}
																													BgL_list1943z00_837 =
																														MAKE_PAIR
																														(BgL_arg1940z00_834,
																														BgL_arg1944z00_838);
																												}
																												BgL_arg1938z00_833 =
																													BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
																													(BgL_testz00_789,
																													BgL_list1943z00_837);
																											}
																										}
																										BgL_arg1930z00_828 =
																											MAKE_PAIR
																											(BgL_arg1937z00_832,
																											BgL_arg1938z00_833);
																									}
																									{	/* Eval/expddo.scm 86 */
																										obj_t BgL_list1932z00_830;

																										{	/* Eval/expddo.scm 86 */
																											obj_t BgL_arg1935z00_831;

																											BgL_arg1935z00_831 =
																												MAKE_PAIR(BNIL, BNIL);
																											BgL_list1932z00_830 =
																												MAKE_PAIR
																												(BgL_arg1930z00_828,
																												BgL_arg1935z00_831);
																										}
																										BgL_arg1929z00_827 =
																											BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
																											(BgL_varsz00_785,
																											BgL_list1932z00_830);
																									}
																								}
																								BgL_arg1924z00_823 =
																									MAKE_PAIR(BgL_arg1927z00_826,
																									BgL_arg1929z00_827);
																							}
																							{	/* Eval/expddo.scm 86 */
																								obj_t BgL_list1926z00_825;

																								BgL_list1926z00_825 =
																									MAKE_PAIR(BNIL, BNIL);
																								BgL_arg1923z00_822 =
																									BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
																									(BgL_arg1924z00_823,
																									BgL_list1926z00_825);
																							}
																						}
																						BgL_arg1921z00_820 =
																							MAKE_PAIR(BgL_loopz00_788,
																							BgL_arg1923z00_822);
																					}
																					BgL_arg1915z00_815 =
																						MAKE_PAIR(BgL_arg1921z00_820, BNIL);
																				}
																				BgL_arg1916z00_816 =
																					MAKE_PAIR(BgL_loopz00_788,
																					BGl_eappendzd22zd2zz__r4_pairs_and_lists_6_3z00
																					(BgL_initsz00_786, BNIL));
																				{	/* Eval/expddo.scm 86 */
																					obj_t BgL_list1919z00_818;

																					{	/* Eval/expddo.scm 86 */
																						obj_t BgL_arg1920z00_819;

																						BgL_arg1920z00_819 =
																							MAKE_PAIR(BNIL, BNIL);
																						BgL_list1919z00_818 =
																							MAKE_PAIR(BgL_arg1916z00_816,
																							BgL_arg1920z00_819);
																					}
																					BgL_arg1914z00_814 =
																						BGl_consza2za2zz__r4_pairs_and_lists_6_3z00
																						(BgL_arg1915z00_815,
																						BgL_list1919z00_818);
																				}
																			}
																			BgL_arg1911z00_812 =
																				MAKE_PAIR(BgL_arg1912z00_813,
																				BgL_arg1914z00_814);
																		}
																		return
																			PROCEDURE_ENTRY(BgL_ez00_2) (BgL_ez00_2,
																			BgL_arg1911z00_812, BgL_ez00_2, BEOA);
																	}
																}
															}
														}
													}
												}
											}
										}
									}
								else
									{	/* Eval/expddo.scm 58 */
										return
											BGl_errorz00zz__errorz00
											(BGl_symbol2224z00zz__expander_doz00,
											BGl_string2223z00zz__expander_doz00,
											BGl_symbol2234z00zz__expander_doz00);
									}
							}
						else
							{	/* Eval/expddo.scm 58 */
								return
									BGl_errorz00zz__errorz00(BGl_symbol2224z00zz__expander_doz00,
									BGl_string2223z00zz__expander_doz00,
									BGl_symbol2234z00zz__expander_doz00);
							}
					}
				else
					{	/* Eval/expddo.scm 58 */
						return
							BGl_errorz00zz__errorz00(BGl_symbol2224z00zz__expander_doz00,
							BGl_string2223z00zz__expander_doz00,
							BGl_symbol2234z00zz__expander_doz00);
					}
			}
		}
	}
コード例 #18
0
ファイル: erl_io_queue.c プロジェクト: crownedgrouse/otp
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;
}
コード例 #19
0
ファイル: sprintf.c プロジェクト: SvenDowideit/clearlinux
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;
		    /* now look for %n$ or %nn$ form */
		    if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') {
			v = fmt[1] - '0';
			if(fmt[2] == '$') {
			    if(v > nargs)
				error(_("reference to non-existent argument %d"), v);
			    nthis = v-1;
			    memmove(fmt+1, fmt+3, strlen(fmt)-2);
			} else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') {
			    v = 10*v + fmt[2] - '0';
			    if(v > nargs)
				error(_("reference to non-existent argument %d"), v);
			    nthis = v-1;
			    memmove(fmt+1, fmt+4, strlen(fmt)-3);
			}
		    }

		    starc = Rf_strchr(fmt, '*');
		    if (starc) { /* handle  *  format if present */
			nstar = -1;
			if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') {
			    v = starc[1] - '0';
			    if(starc[2] == '$') {
				if(v > nargs)
				    error(_("reference to non-existent argument %d"), v);
				nstar = v-1;
				memmove(starc+1, starc+3, strlen(starc)-2);
			    } else if(starc[2] >= '0' && starc[2] <= '9'
				      && starc[3] == '$') {
				v = 10*v + starc[2] - '0';
				if(v > nargs)
				    error(_("reference to non-existent argument %d"), v);
				nstar = v-1;
				memmove(starc+1, starc+4, strlen(starc)-3);
			    }
			}

			if(nstar < 0) {
			    if (cnt >= nargs) error(_("too few arguments"));
			    nstar = cnt++;
			}

			if (Rf_strchr(starc+1, '*'))
			    error(_("at most one asterisk '*' is supported in each conversion specification"));

			_this = a[nstar];
			if(ns == 0 && TYPEOF(_this) == REALSXP) {
			    _this = coerceVector(_this, INTSXP);
			    PROTECT(a[nstar] = _this);
			    nprotect++;
			}
			if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 ||
			   INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER)
			    error(_("argument for '*' conversion specification must be a number"));
			star_arg = INTEGER(_this)[ns % LENGTH(_this)];
			has_star = TRUE;
		    }
		    else
			has_star = FALSE;

		    if (fmt[strlen(fmt) - 1] == '%') {
			/* handle % with formatting options */
			if (has_star)
			    snprintf(bit, MAXLINE+1, fmt, star_arg);
			else
			    strcpy(bit, fmt);
			/* was sprintf(..)  for which some compiler warn */
		    } else {
			Rboolean did_this = FALSE;
			if(nthis < 0) {
			    if (cnt >= nargs) error(_("too few arguments"));
			    nthis = cnt++;
			}
			_this = a[nthis];
			if (has_star) {
			    size_t nf; char *p, *q = fmt2;
			    for (p = fmt; *p; p++)
				if (*p == '*') q += sprintf(q, "%d", star_arg);
				else *q++ = *p;
			    *q = '\0';
			    nf = strlen(fmt2);
			    if (nf > MAXLINE)
				error(_("'fmt' length exceeds maximal format length %d"),
				      MAXLINE);
			    fmtp = fmt2;
			} else fmtp = fmt;

#define CHECK_this_length						\
			PROTECT(_this);					\
			thislen = length(_this);			\
			if(thislen == 0)				\
			    error(_("coercion has changed vector length to 0"))

			/* Now let us see if some minimal coercion
			   would be sensible, but only do so once, for ns = 0: */
			if(ns == 0) {
			    SEXP tmp; Rboolean do_check;
			    switch(*findspec(fmtp)) {
			    case 'd':
			    case 'i':
			    case 'o':
			    case 'x':
			    case 'X':
				if(TYPEOF(_this) == REALSXP) {
				    double r = REAL(_this)[0];
				    if((double)((int) r) == r)
					_this = coerceVector(_this, INTSXP);
				    PROTECT(a[nthis] = _this);
				    nprotect++;
				}
				break;
			    case 'a':
			    case 'A':
			    case 'e':
			    case 'f':
			    case 'g':
			    case 'E':
			    case 'G':
				if(TYPEOF(_this) != REALSXP &&
				   /* no automatic as.double(<string>) : */
				   TYPEOF(_this) != STRSXP) {
				    PROTECT(tmp = lang2(install("as.double"), _this));
#define COERCE_THIS_TO_A						\
				    _this = eval(tmp, env);		\
				    UNPROTECT(1);			\
				    PROTECT(a[nthis] = _this);		\
				    nprotect++;				\
				    did_this = TRUE;			\
				    CHECK_this_length;			\
				    do_check = (lens[nthis] == maxlen);	\
				    lens[nthis] = thislen; /* may have changed! */ \
				    if(do_check && thislen < maxlen) {	\
					CHECK_maxlen;			\
				    }

				    COERCE_THIS_TO_A
				}
				break;
			    case 's':
				if(TYPEOF(_this) != STRSXP) {
				    /* as.character method might call sprintf() */
				    size_t nc = strlen(outputString);
				    char *z = Calloc(nc+1, char);
				    strcpy(z, outputString);
				    PROTECT(tmp = lang2(install("as.character"), _this));

				    COERCE_THIS_TO_A
				    strcpy(outputString, z);
				    Free(z);
				}
				break;
			    default:
				break;
			    }
			} /* ns == 0 (first-time only) */

			if(!did_this)
			    CHECK_this_length;

			switch(TYPEOF(_this)) {
			case LGLSXP:
			    {
				int x = LOGICAL(_this)[ns % thislen];
				if (checkfmt(fmtp, "di"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d or %i for logical objects"));
				if (x == NA_LOGICAL) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
			case INTSXP:
			    {
				int x = INTEGER(_this)[ns % thislen];
				if (checkfmt(fmtp, "dioxX"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d, %i, %o, %x or %X for integer objects"));
				if (x == NA_INTEGER) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
コード例 #20
0
ファイル: gevents.cpp プロジェクト: csilles/cxxr
SEXP
do_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);
}
コード例 #21
0
ファイル: read_internal_stub.c プロジェクト: agarwal/OCaml-R
/**  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))));
}
コード例 #22
0
ファイル: KLWDEBUG.C プロジェクト: thearttrooper/KappaPC
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;
}
コード例 #23
0
ファイル: copy.c プロジェクト: Airon2014/otp
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:
		erl_exit(ERTS_ABORT_EXIT,
			 "%s, line %d: Internal error in copy_struct: 0x%08x\n",
			 __FILE__, __LINE__,obj);
	    }
	    
	case TAG_PRIMARY_BOXED:
	#if !HALFWORD_HEAP || defined(DEBUG)
	    if (in_area(boxed_val_rel(obj,src_base),hstart,hsize)) {
		ASSERT(!HALFWORD_HEAP);
		hp++;
		break;
	    }
	#endif
	    argp = hp++;

	L_copy_boxed:
	    objp = boxed_val_rel(obj, src_base);
	    hdr = *objp;
	    switch (hdr & _TAG_HEADER_MASK) {
	    case ARITYVAL_SUBTAG:
		{
		    int const_flag = 1; /* assume constant tuple */
		    i = arityval(hdr);
		    *argp = make_tuple_rel(htop, dst_base);
		    tp = htop;	/* tp is pointer to new arity value */
		    *htop++ = *objp++; /* copy arity value */
		    while (i--) {
			elem = *objp++;
			if (!IS_CONST(elem)) {
			    const_flag = 0;
			}
			*htop++ = elem;
		    }
		    if (const_flag) {
			const_tuple = tp; /* this is the latest const_tuple */
		    }
		}
		break;
	    case MAP_SUBTAG:
		{
		    i = map_get_size(objp) + 3;
		    *argp = make_map_rel(htop, dst_base);
		    while (i--) {
			*htop++ = *objp++;
		    }
		}
		break;
	    case REFC_BINARY_SUBTAG:
		{
		    ProcBin* pb;

		    pb = (ProcBin *) objp;
		    if (pb->flags) {
			erts_emasculate_writable_binary(pb);
		    }
		    i = thing_arityval(*objp) + 1;
		    hbot -= i;
		    tp = hbot;
		    while (i--)  {
			*tp++ = *objp++;
		    }
		    *argp = make_binary_rel(hbot, dst_base);
		    pb = (ProcBin*) hbot;
		    erts_refc_inc(&pb->val->refc, 2);
		    pb->next = off_heap->first;
		    pb->flags = 0;
		    off_heap->first = (struct erl_off_heap_header*) pb;
		    OH_OVERHEAD(off_heap, pb->size / sizeof(Eterm));
		}
		break;
	    case SUB_BINARY_SUBTAG:
		{
		    ErlSubBin* sb = (ErlSubBin *) objp;
		    Eterm real_bin = sb->orig;
		    Uint bit_offset = sb->bitoffs;
		    Uint bit_size = sb -> bitsize;
		    Uint offset = sb->offs;
		    size_t size = sb->size;
		    Uint extra_bytes;
		    Uint real_size;
		    if ((bit_size + bit_offset) > 8) {
			extra_bytes = 2;
		    } else if ((bit_size + bit_offset) > 0) {
			extra_bytes = 1;
		    } else {
			extra_bytes = 0;
		    } 
		    real_size = size+extra_bytes;
		    objp = binary_val_rel(real_bin,src_base);
		    if (thing_subtag(*objp) == HEAP_BINARY_SUBTAG) {
			ErlHeapBin* from = (ErlHeapBin *) objp;
			ErlHeapBin* to;
			i = heap_bin_size(real_size);
			hbot -= i;
			to = (ErlHeapBin *) hbot;
			to->thing_word = header_heap_bin(real_size);
			to->size = real_size;
			sys_memcpy(to->data, ((byte *)from->data)+offset, real_size);
		    } else {
			ProcBin* from = (ProcBin *) objp;
			ProcBin* to;
			
			ASSERT(thing_subtag(*objp) == REFC_BINARY_SUBTAG);
			if (from->flags) {
			    erts_emasculate_writable_binary(from);
			}
			hbot -= PROC_BIN_SIZE;
			to = (ProcBin *) hbot;
			to->thing_word = HEADER_PROC_BIN;
			to->size = real_size;
			to->val = from->val;
			erts_refc_inc(&to->val->refc, 2);
			to->bytes = from->bytes + offset;
			to->next = off_heap->first;
			to->flags = 0;
			off_heap->first = (struct erl_off_heap_header*) to;
			OH_OVERHEAD(off_heap, to->size / sizeof(Eterm));
		    }
		    *argp = make_binary_rel(hbot, dst_base);
		    if (extra_bytes != 0) {
			ErlSubBin* res;
			hbot -= ERL_SUB_BIN_SIZE;
			res = (ErlSubBin *) hbot;
			res->thing_word = HEADER_SUB_BIN;
			res->size = size;
			res->bitsize = bit_size;
			res->bitoffs = bit_offset;
			res->offs = 0;
			res->is_writable = 0;
			res->orig = *argp;
			*argp = make_binary_rel(hbot, dst_base);
		    }
		    break;
		}
		break;
	    case FUN_SUBTAG:
		{
		    ErlFunThing* funp = (ErlFunThing *) objp;

		    i =  thing_arityval(hdr) + 2 + funp->num_free;
		    tp = htop;
		    while (i--)  {
			*htop++ = *objp++;
		    }
		    funp = (ErlFunThing *) tp;
		    funp->next = off_heap->first;
		    off_heap->first = (struct erl_off_heap_header*) funp;
		    erts_refc_inc(&funp->fe->refc, 2);
		    *argp = make_fun_rel(tp, dst_base);
		}
		break;
	    case EXTERNAL_PID_SUBTAG:
	    case EXTERNAL_PORT_SUBTAG:
	    case EXTERNAL_REF_SUBTAG:
		{
		  ExternalThing *etp = (ExternalThing *) htop;

		  i =  thing_arityval(hdr) + 1;
		  tp = htop;

		  while (i--)  {
		    *htop++ = *objp++;
		  }

		  etp->next = off_heap->first;
		  off_heap->first = (struct erl_off_heap_header*)etp;
		  erts_refc_inc(&etp->node->refc, 2);

		  *argp = make_external_rel(tp, dst_base);
		}
		break;
	    case BIN_MATCHSTATE_SUBTAG:
		erl_exit(ERTS_ABORT_EXIT,
			 "copy_struct: matchstate term not allowed");
	    default:
		i = thing_arityval(hdr)+1;
		hbot -= i;
		tp = hbot;
		*argp = make_boxed_rel(hbot, dst_base);
		while (i--) {
		    *tp++ = *objp++;
		}
	    }
	    break;
	case TAG_PRIMARY_HEADER:
	    if (header_is_thing(obj) || hp == const_tuple) {
		hp += header_arity(obj) + 1;
	    } else {
		hp++;
	    }
	    break;
	}
    }

#ifdef DEBUG
    if (htop != hbot)
	erl_exit(ERTS_ABORT_EXIT,
		 "Internal error in copy_struct() when copying %T:"
		 " htop=%p != hbot=%p (sz=%beu)\n",
		 org_obj, htop, hbot, org_sz); 
#else
    if (htop > hbot) {
	erl_exit(ERTS_ABORT_EXIT,
		 "Internal error in copy_struct(): htop, hbot overrun\n");
    }
#endif
    *hpp = (Eterm *) (hstart+hsize);
    return res;
}
コード例 #24
0
ファイル: ERRORLIB.C プロジェクト: thearttrooper/KappaPC
/**********************************************************
 *	 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;
}
コード例 #25
0
ファイル: machine.cpp プロジェクト: DeveloperHacker/SECD
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");
}
コード例 #26
0
ファイル: edit.c プロジェクト: SensePlatform/R
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);
    
    /* <FIXME> setup a context to close the file, and parse and eval
       line by line */
    if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
	errorcall(call, _("unable to open file to read"));

    x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
    fclose(fp);

    if (status != PARSE_OK)
	errorcall(call,
		  _("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
    R_ResetConsole();
    {   /* can't just eval(x) here */
	int j, n;
	SEXP tmp = R_NilValue;

	n = LENGTH(x);
	for (j = 0 ; j < n ; j++)
	    tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
	x = tmp;
    }
    if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
	SET_CLOENV(x, envir);
    UNPROTECT(3);
    vmaxset(vmaxsave);
    return (x);
}
コード例 #27
0
ファイル: subset.c プロジェクト: Maxsl/r-source
/* 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;
		case CHARSXP:
		    st = translateChar(target);
		    break;
		}
		warningcall(call, _("partial match of '%s' to '%s'"),
			    translateChar(input), st);
	    }
	    y = VECTOR_ELT(x, imatch);
	    if (NAMED(x) > NAMED(y)) SET_NAMED(y, NAMED(x));
	    return y;
	}
	return R_NilValue;
    }
    else if( isEnvironment(x) ){
	y = findVarInFrame(x, installTrChar(input));
	if( TYPEOF(y) == PROMSXP ) {
	    PROTECT(y);
	    y = eval(y, R_GlobalEnv);
	    UNPROTECT(1); /* y */
	}
	UNPROTECT(2); /* input, x */
	if( y != R_UnboundValue ) {
	    if (NAMED(y))
		SET_NAMED(y, 2);
	    else if (NAMED(x) > NAMED(y))
		SET_NAMED(y, NAMED(x));
	    return(y);
	}
	return R_NilValue;
    }
    else if( isVectorAtomic(x) ){
	errorcall(call, "$ operator is invalid for atomic vectors");
    }
    else /* e.g. a function */
	errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
    UNPROTECT(2); /* input, x */
    return R_NilValue;
}
コード例 #28
0
ファイル: access.c プロジェクト: 8l/bigloo-llvm
/* 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);
					}
				}
		}
	}
コード例 #29
0
ファイル: subset.c プロジェクト: Maxsl/r-source
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;
	default:
	    errorcall(call, _("array subscripting not handled for this type"));
	    break;
	}
	if (n > 1) {
	    int j = 0;
	    while (++indx[j] >= bound[j]) {
		indx[j] = 0;
		j = (j + 1) % k;
	    }
	}
    }

    PROTECT(xdims = allocVector(INTSXP, k));
    for(int i = 0 ; i < k ; i++)
	INTEGER(xdims)[i] = bound[i];
    setAttrib(result, R_DimSymbol, xdims);
    UNPROTECT(1); /* xdims */

    /* The array elements have been transferred. */
    /* Now we need to transfer the attributes. */
    /* Most importantly, we need to subset the */
    /* dimnames of the returned value. */

    dimnames = getAttrib(x, R_DimNamesSymbol);
    PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
    if (dimnames != R_NilValue) {
	int j = 0;
	PROTECT(xdims = allocVector(VECSXP, k));
	if (TYPEOF(dimnames) == VECSXP) {
	    r = s;
	    for (int i = 0; i < k ; i++) {
		if (bound[i] > 0) {
		  SET_VECTOR_ELT(xdims, j++,
			ExtractSubset(VECTOR_ELT(dimnames, i),
				      allocVector(STRSXP, bound[i]),
				      CAR(r), call));
		} else { /* 0-length dims have NULL dimnames */
		    SET_VECTOR_ELT(xdims, j++, R_NilValue);
		}
		r = CDR(r);
	    }
	}
	else {
	    p = dimnames;
	    q = xdims;
	    r = s;
	    for(int i = 0 ; i < k; i++) {
		SETCAR(q, allocVector(STRSXP, bound[i]));
		SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call));
		p = CDR(p);
		q = CDR(q);
		r = CDR(r);
	    }
	}
	setAttrib(xdims, R_NamesSymbol, dimnamesnames);
	setAttrib(result, R_DimNamesSymbol, xdims);
	UNPROTECT(1); /* xdims */
    }
    /* This was removed for matrices in 1998
       copyMostAttrib(x, result); */
    /* Free temporary memory */
    vmaxset(vmaxsave);
    if (drop)
	DropDims(result);
    UNPROTECT(2); /* dimnamesnames, result */
    return result;
}
コード例 #30
0
ファイル: scc1.cpp プロジェクト: garyfurnish/M2
int main(int argc, char **argv){
     int i;
     char *p;
     GC_INIT();
     ::cgc1::cgc_root_t hash_bucket_root(hash_buckets);
     hash_buckets=reinterpret_cast<node*>(::cgc1::cgc_malloc(sizeof(node)*7313));
     progname = BaseName(argv[0]);
     yyinit();
     for (p=argv[0]; *p; p++) if (*p=='/') progname = p+1;
     for (i=1; i<argc; i++) {
     	  if (EQUAL == strcmp(argv[i],"--help")) {
	       usage();
	       exit(0);
	       }
     	  if (EQUAL == strcmp(argv[i],"-dep")) {
	       stop_after_dep = TRUE;
	       continue;
	       }
     	  if (EQUAL == strcmp(argv[i],"-cxx")) {
	       do_cxx = TRUE;
	       continue;
	       }
     	  if (EQUAL == strcmp(argv[i],"-noline")) {
	       noline = TRUE;
	       continue;
	       }
	  if (EQUAL == strcmp(argv[i],"-pthreadlocal")) {
	       pthreadThreadLocal=TRUE;
               compilerThreadLocal=FALSE;
               continue;
	       }
     	  if (EQUAL == strcmp(argv[i],"-typecodes")) {
	       printtypecodes();
	       return 0;
	       }
     	  if (EQUAL == strcmp(argv[i],"-noarraychks")) {
	       arraychks = FALSE;
	       continue;
	       }
     	  if (EQUAL == strcmp(argv[i],"-nocasechks")) {
	       casechks = FALSE;
	       continue;
	       }
	  if (EQUAL == strcmp(argv[i],"-nomacros")) {
	       nomacros = TRUE;
	       continue;
	       }
     	  if (EQUAL == strcmp(argv[i],"-O")) {
	       arraychks = FALSE;
	       casechks = FALSE;
	       continue;
	       }
	  if (EQUAL == strcmp(argv[i],"-tabwidth")) {
	       i++;
	       if (i < argc) tabwidth = atoi(argv[i]);
	       continue;
	       }
	  if (EQUAL == strcmp(argv[i],"-yydebug")) {
	       yydebug = 1;
	       continue;
	       }
	  if (EQUAL == strcmp(argv[i],"-debug")) {
	       debug = TRUE;
	       continue;
	       }
	  if (EQUAL == strcmp(argv[i],"-v")) {
	       puts(Version);
     	       puts(Copyright);
	       continue;
	       }
     	  if ('-' == argv[i][0] && 'I' == argv[i][1]) {
	       if (argv[i][2] == 0) {
		    error("-I option: missing directory");
		    usage();
		    exit(1);
		    }
	       char buf[256];
	       strcpy(buf,sigpath);
	       strcat(buf,":");
	       strcat(buf,argv[i]+2);
	       sigpath = strperm(buf);
	       continue;
	       }
	  if ('-' == argv[i][0]) {
	       error("unrecognized option %s\n",argv[i]);
	       usage();
	       exit(1);
	       }
	  if ( EQUAL == strcmp(".d",tail(argv[i])) || EQUAL == strcmp(".dd",tail(argv[i])) ) {
	       node f;
	       do_this_cxx = do_cxx || EQUAL == strcmp(".dd",tail(argv[i]));
	       global_scope = new(struct SCOPE);
	       readsetup(global_scope);
	       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);
			 }
		    put(declarations_header);
		    /* printtypecodes(); */
		    cprinttypes();
		    put(declarations_trailer);
		    put("#endif\n");
		    }
	       if (TRUE) {
		    if (NULL == freopen(outfilename,"w", stdout)) {
			 fatal("can't open file %s",outfilename);
			 }
		    printf("#include \"%s\"\n",newsuffixbase(argv[i],"-exports.h"));
		    put(code_header);
		    headerstrings = reverse(headerstrings);
		    while (headerstrings) {
			 locn(car(headerstrings));
			 printpos();
			 node s = unpos(car(headerstrings));
			 assert(isstrconst(s));
			 put_unescape(s->body.string_const.characters);
			 put("\n");
			 locn(NULL);
			 headerstrings = cdr(headerstrings);
			 }
		    cprintsemi(f);
		    }
	       }
	  else {
	       fprintf(stderr,"unknown file type %s\n",argv[i]);
	       usage();
	       exit(1);
	       }
	  }
     quit();
     return 0;
     }