C++ ecl_process_env函数代码示例

cl_object
si_get_limit(cl_object type)
{
	cl_env_ptr env = ecl_process_env();
	cl_index output;
	if (type == ECL_SYM("EXT::FRAME-STACK",1669)) {
		output = env->frs_size;
	} else if (type == ECL_SYM("EXT::BINDING-STACK",1668)) {
		output = env->bds_size;
	} else if (type == ECL_SYM("EXT::C-STACK",1671)) {
		output = env->cs_size;
	} else if (type == ECL_SYM("EXT::LISP-STACK",1670)) {
		output = env->stack_size;
	} else {
		output = cl_core.max_heap_size;
	}
	{
#line 633
		const cl_env_ptr the_env = ecl_process_env();
#line 633
		#line 633
		cl_object __value0 = ecl_make_unsigned_integer(output);
#line 633
		the_env->nvalues = 1;
#line 633
		return __value0;
#line 633
	}

}

cl_object
mp_get_rwlock_write_wait(cl_object lock)
{
        cl_env_ptr env = ecl_process_env();
        if (ecl_t_of(lock) != t_rwlock)
		FEerror_not_a_rwlock(lock);
#ifdef ECL_RWLOCK
        {
                int rc = pthread_rwlock_wrlock(&lock->rwlock.mutex);
                if (rc != 0) {
                        FEunknown_rwlock_error(lock, rc);
                }
                {
#line 213
	const cl_env_ptr the_env = ecl_process_env();
#line 213
	#line 213
	cl_object __value0 = ECL_T;
#line 213
	the_env->nvalues = 1;
#line 213
	return __value0;
#line 213
}

        }
#else
        return mp_get_lock_wait(lock->rwlock.mutex);
#endif
}

/*
	(SI:PUT-F plist value indicator)
	returns the new property list with value for property indicator.
	It will be used in SETF for GETF.
*/
cl_object
si_put_f(cl_object place, cl_object value, cl_object indicator)
{
	cl_object l;

#ifdef ECL_SAFE
	assert_type_proper_list(place);
#endif
	/* This loop guarantees finishing for circular lists */
	for (l = place; CONSP(l); ) {
		cl_object cdr_l = ECL_CONS_CDR(l);
		if (!CONSP(cdr_l))
			break;
		if (ECL_CONS_CAR(l) == indicator) {
			ECL_RPLACA(cdr_l, value);
			{
#line 214
				const cl_env_ptr the_env = ecl_process_env();
#line 214
				#line 214
				cl_object __value0 = place;
#line 214
				the_env->nvalues = 1;
#line 214
				return __value0;
#line 214
			}
;
		}
		l = ECL_CONS_CDR(cdr_l);
	}
	if (l != ECL_NIL)
		FEtype_error_plist(place);
	place = CONS(value, place);
	{
#line 221
		const cl_env_ptr the_env = ecl_process_env();
#line 221
		#line 221
		cl_object __value0 = CONS(indicator, place);
#line 221
		the_env->nvalues = 1;
#line 221
		return __value0;
#line 221
	}
;
}

cl_object
si_float_to_digits(cl_object digits, cl_object number, cl_object position,
                   cl_object relativep)
{
        cl_fixnum k;
        float_approx approx[1];
        setup(number, approx);
        change_precision(approx, position, relativep);
        k = scale(approx);
        if (Null(digits))
                digits = si_make_vector(ECL_SYM("BASE-CHAR",120), ecl_make_fixnum(10),
                                        ECL_T /* adjustable */,
                                        ecl_make_fixnum(0) /* fill pointer */,
                                        ECL_NIL /* displacement */,
                                        ECL_NIL /* displ. offset */);
        generate(digits, approx);
        {
#line 218
	const cl_env_ptr the_env = ecl_process_env();
#line 218
	#line 218
	cl_object __value0 = ecl_make_fixnum(k);
#line 218
	cl_object __value1 = digits;
#line 218
	the_env->nvalues = 2;
#line 218
	the_env->values[1] = __value1;
#line 218
	return __value0;
#line 218
}

}

/*
	(SI:REM-F plist indicator) returns two values:

		* the new property list
		  in which property indcator is removed

		* T     if really removed
		  NIL   otherwise.

	It will be used for macro REMF.
*/
cl_object
si_rem_f(cl_object plist, cl_object indicator)
{
	cl_env_ptr the_env = ecl_process_env();
	bool found = remf(&plist, indicator);
	ecl_return2(the_env, plist, (found? ECL_T : ECL_NIL));
}

ECL_DLLEXPORT void init_fas_CODE(cl_object flag)
{
 const cl_env_ptr cl_env_copy = ecl_process_env();
 cl_object value0;
 cl_object *VVtemp;
 if (flag != OBJNULL){
 Cblock = flag;
 #ifndef ECL_DYNAMIC_VV
 flag->cblock.data = VV;
 #endif
 flag->cblock.data_size = VM;
 flag->cblock.temp_data_size = VMtemp;
 flag->cblock.data_text = compiler_data_text;
 flag->cblock.data_text_size = compiler_data_text_size;
 flag->cblock.cfuns_size = compiler_cfuns_size;
 flag->cblock.cfuns = compiler_cfuns;
 flag->cblock.source = make_constant_base_string("/home/tucker/Repo/my-code/lisp/misc.lisp");
 return;}
 #ifdef ECL_DYNAMIC_VV
 VV = Cblock->cblock.data;
 #endif
 Cblock->cblock.data_text = "@EcLtAg:[email protected]";
 VVtemp = Cblock->cblock.temp_data;
 ECL_DEFINE_SETF_FUNCTIONS
 ecl_function_dispatch(cl_env_copy,VV[2])(10, VVtemp[0], ECL_NIL, ECL_NIL, VVtemp[1], ECL_NIL, ECL_NIL, VVtemp[2], ECL_NIL, ECL_NIL, ECL_NIL) /*  DODEFPACKAGE */;
 ecl_cmp_defun(VV[3]);                            /*  SEQ             */
 ecl_function_dispatch(cl_env_copy,VV[4])(3, VV[0], ECL_SYM("FUNCTION",396), VVtemp[3]) /*  SET-DOCUMENTATION */;
 ecl_cmp_defun(VV[8]);                            /*  INTERLEAVE      */
}

cl_object
cl_denominator(cl_object x)
{
	switch (ecl_t_of(x)) {
	case t_ratio:
		x = x->ratio.den;
		break;
	case t_fixnum:
	case t_bignum:
		x = ecl_make_fixnum(1);
		break;
	default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*NUMERATOR*/608),1,x,ecl_make_fixnum(/*RATIONAL*/687));
	}
	{
#line 116
		const cl_env_ptr the_env = ecl_process_env();
#line 116
		#line 116
		cl_object __value0 = x;
#line 116
		the_env->nvalues = 1;
#line 116
		return __value0;
#line 116
	}

}

cl_object
cl_copy_alist(cl_object x)
{
	cl_object copy;
	if (ecl_unlikely(!LISTP(x))) {
                FEwrong_type_only_arg(ecl_make_fixnum(/*COPY-ALIST*/256), x, ecl_make_fixnum(/*LIST*/481));
	}
	copy = ECL_NIL;
	if (!Null(x)) {
		cl_object tail = copy = duplicate_pairs(x);
		while (x = ECL_CONS_CDR(x), !Null(x)) {
			if (!LISTP(x)) {
				FEtype_error_list(x);
			} else {
				cl_object cons = duplicate_pairs(x);
				tail = ECL_RPLACD(tail, cons);
				tail = cons;
			}
		}
	}
	{
#line 473
		const cl_env_ptr the_env = ecl_process_env();
#line 473
		#line 473
		cl_object __value0 = copy;
#line 473
		the_env->nvalues = 1;
#line 473
		return __value0;
#line 473
	}
;
}

cl_object
si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value)
{
	cl_index ndx = ecl_to_size(andx);
	cl_index limit = f->foreign.size;
	enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
	if (ecl_unlikely(ndx >= limit ||
                         ndx + ecl_foreign_type_table[tag].size > limit)) {
		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
	}
	if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-SET-ELT*/1354), 1, f,
                                     ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value);
	{
#line 655
		const cl_env_ptr the_env = ecl_process_env();
#line 655
		#line 655
		cl_object __value0 = value;
#line 655
		the_env->nvalues = 1;
#line 655
		return __value0;
#line 655
	}

}

cl_object
si_foreign_data_set(cl_object f, cl_object andx, cl_object value)
{
	cl_index ndx = ecl_to_size(andx);
	cl_index size, limit;

	if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-SET*/1353), 1, f,
                                     ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	if (ecl_unlikely(ecl_t_of(value) != t_foreign)) {
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-SET*/1353), 3, value,
                                     ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	size = value->foreign.size;
	limit = f->foreign.size;
	if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) {
		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
	}
	memcpy(f->foreign.data + ndx, value->foreign.data, size);
	{
#line 397
		const cl_env_ptr the_env = ecl_process_env();
#line 397
		#line 397
		cl_object __value0 = value;
#line 397
		the_env->nvalues = 1;
#line 397
		return __value0;
#line 397
	}

}

cl_object
si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag)
{
	cl_index ndx = ecl_to_size(andx);
	cl_index size = ecl_to_size(asize);
	cl_object output;

	if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-REF*/1351), 1, f,
                                     ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) {
		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
	}
	output = ecl_allocate_foreign_data(tag, size);
	memcpy(output->foreign.data, f->foreign.data + ndx, size);
	{
#line 374
		const cl_env_ptr the_env = ecl_process_env();
#line 374
		#line 374
		cl_object __value0 = output;
#line 374
		the_env->nvalues = 1;
#line 374
		return __value0;
#line 374
	}

}

cl_object
si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize,
			cl_object tag)
{
	cl_index ndx = ecl_to_size(andx);
	cl_index size = ecl_to_size(asize);
	cl_object output;

	if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
                FEwrong_type_only_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-POINTER*/1349), f,
                                      ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) {
		FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
	}
	output = ecl_alloc_object(t_foreign);
	output->foreign.tag = tag;
	output->foreign.size = size;
	output->foreign.data = f->foreign.data + ndx;
	{
#line 355
		const cl_env_ptr the_env = ecl_process_env();
#line 355
		#line 355
		cl_object __value0 = output;
#line 355
		the_env->nvalues = 1;
#line 355
		return __value0;
#line 355
	}

}

cl_object
si_foreign_data_equal(cl_object f1, cl_object f2)
{
	if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) {
                FEwrong_type_only_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-ADDRESS*/1346), f1,
                                      ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) {
                FEwrong_type_only_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-ADDRESS*/1346), f2,
                                      ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
	}
	{
#line 333
		const cl_env_ptr the_env = ecl_process_env();
#line 333
		#line 333
		cl_object __value0 = ((f1->foreign.data == f2->foreign.data)? ECL_T : ECL_NIL);
#line 333
		the_env->nvalues = 1;
#line 333
		return __value0;
#line 333
	}

}

cl_object
si_make_foreign_data_from_array(cl_object array)
{
	cl_object tag;
	if (ecl_unlikely(ecl_t_of(array) != t_array && ecl_t_of(array) != t_vector)) {
                FEwrong_type_only_arg(ecl_make_fixnum(/*SI::MAKE-FOREIGN-DATA-FROM-ARRAY*/1358), array,
                                      ecl_make_fixnum(/*ARRAY*/96));
	}
        tag = ecl_aet_to_ffi_table[array->array.elttype];
        if (ecl_unlikely(Null(tag))) {
		FEerror("Cannot make foreign object from array "
                        "with element type ~S.", 1,
                        ecl_elttype_to_symbol(array->array.elttype));
	}
	{
#line 293
		const cl_env_ptr the_env = ecl_process_env();
#line 293
		#line 293
		cl_object __value0 = ecl_make_foreign_data(tag, 0, array->array.self.bc);
#line 293
		the_env->nvalues = 1;
#line 293
		return __value0;
#line 293
	}
;
}

cl_object
si_allocate_foreign_data(cl_object tag, cl_object size)
{
	cl_object output = ecl_alloc_object(t_foreign);
	cl_index bytes = ecl_to_size(size);
	output->foreign.tag = tag;
	output->foreign.size = bytes;
	/* FIXME! Should be atomic uncollectable or malloc, but we do not export
	 * that garbage collector interface and malloc may be overwritten
	 * by the GC library */
	output->foreign.data = bytes? ecl_alloc_uncollectable(bytes) : NULL;
	{
#line 260
		const cl_env_ptr the_env = ecl_process_env();
#line 260
		#line 260
		cl_object __value0 = output;
#line 260
		the_env->nvalues = 1;
#line 260
		return __value0;
#line 260
	}

}