示例#1
0
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:init_fas_CODE@";
 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      */
}
示例#2
0
文件: stacks.o.c 项目: hoobaa/mecl
void
ecl_cs_overflow(void)
{
        static const char *stack_overflow_msg =
                "\n;;;\n;;; Stack overflow.\n"
                ";;; Jumping to the outermost toplevel prompt\n"
                ";;;\n\n";
	cl_env_ptr env = ecl_process_env();
	cl_index safety_area = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
	cl_index size = env->cs_size;
#ifdef ECL_DOWN_STACK
	if (env->cs_limit > env->cs_org - size)
		env->cs_limit -= safety_area;
#else
	if (env->cs_limit < env->cs_org + size)
		env->cs_limit += safety_area;
#endif
	else
                ecl_unrecoverable_error(env, stack_overflow_msg);
	cl_cerror(6, make_constant_base_string("Extend stack size"),
		  ECL_SYM("EXT::STACK-OVERFLOW",1665), ECL_SYM(":SIZE",1308), ecl_make_fixnum(size),
		  ECL_SYM(":TYPE",1318), ECL_SYM("EXT::C-STACK",1671));
	size += size / 2;
	cs_set_size(env, size);
}
示例#3
0
文件: rwlock.o.c 项目: hoobaa/mecl
static void
FEunknown_rwlock_error(cl_object lock, int rc)
{
#ifdef ECL_WINDOWS_THREADS
        FEwin32_error("When acting on rwlock ~A, got an unexpected error.", 1, lock);
#else
        const char *msg = NULL;
        switch (rc) {
        case EINVAL:
                msg = "The value specified by rwlock is invalid";
                break;
        case EPERM:
                msg = "Read/write lock not owned by us";
                break;
        case EDEADLK:
                msg = "Thread already owns this lock";
                break;
        case ENOMEM:
                msg = "Out of memory";
                break;
        default:
                FElibc_error("When acting on rwlock ~A, got an unexpected error.",
                             1, lock);
        }
        FEerror("When acting on rwlock ~A, got the following C library error:~%"
                "~A", 2, lock, make_constant_base_string(msg));
#endif
}
示例#4
0
文件: typespec.o.c 项目: hoobaa/mecl
cl_object
ecl_type_error(cl_object function, const char *place, cl_object o,
	       cl_object type)
{
	si_wrong_type_argument(4, o, type,
			       (*place? make_constant_base_string(place) : ECL_NIL),
			       function);
}
示例#5
0
文件: typespec.o.c 项目: hoobaa/mecl
void
FEtype_error_proper_list(cl_object x) {
	cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
		    make_constant_base_string("Not a proper list ~D"),
		    ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
		    ECL_SYM(":EXPECTED-TYPE",1232), ecl_read_from_cstring("si::proper-list"),
		    ECL_SYM(":DATUM",1214), x);
}
示例#6
0
文件: symbol.o.c 项目: hoobaa/mecl
static void
FEtype_error_plist(cl_object x)
{
	cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
		 make_constant_base_string("Not a valid property list ~D"),
		 ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
		 ECL_SYM(":EXPECTED-TYPE",1232), ECL_SYM("SI::PROPERTY-LIST",1658),
		 ECL_SYM(":DATUM",1214), x);
}
示例#7
0
文件: typespec.o.c 项目: hoobaa/mecl
void
FEtype_error_index(cl_object seq, cl_fixnum ndx)
{
        cl_object n = ecl_make_fixnum(ndx);
	cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq);
	cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
		    make_constant_base_string("~S is not a valid index into the object ~S"),
		    ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(2, n, seq),
		    ECL_SYM(":EXPECTED-TYPE",1232), cl_list(3, ECL_SYM("INTEGER",437), ecl_make_fixnum(0), ecl_make_fixnum(l-1)),
		    ECL_SYM(":DATUM",1214), n);
}
示例#8
0
文件: typespec.o.c 项目: hoobaa/mecl
void
FEcircular_list(cl_object x)
{
	/* FIXME: Is this the right way to rebind it? */
	ecl_bds_bind(ecl_process_env(), ECL_SYM("*PRINT-CIRCLE*",47), ECL_T);
	cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
		    make_constant_base_string("Circular list ~D"),
		    ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
		    ECL_SYM(":EXPECTED-TYPE",1232), ECL_SYM("LIST",481),
		    ECL_SYM(":DATUM",1214), x);
}
示例#9
0
文件: stacks.o.c 项目: hoobaa/mecl
static void
frs_overflow(void)		/* used as condition in list.d */
{
        static const char *stack_overflow_msg =
                "\n;;;\n;;; Frame stack overflow.\n"
                ";;; Jumping to the outermost toplevel prompt\n"
                ";;;\n\n";
	cl_env_ptr env = ecl_process_env();
	cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
	cl_index size = env->frs_size;
	ecl_frame_ptr org = env->frs_org;
	ecl_frame_ptr last = org + size;
	if (env->frs_limit >= last) {
                ecl_unrecoverable_error(env, stack_overflow_msg);
	}
	env->frs_limit += margin;
	cl_cerror(6, make_constant_base_string("Extend stack size"),
		  ECL_SYM("EXT::STACK-OVERFLOW",1665), ECL_SYM(":SIZE",1308), ecl_make_fixnum(size),
		  ECL_SYM(":TYPE",1318), ECL_SYM("EXT::FRAME-STACK",1669));
	frs_set_size(env, size + size / 2);
}
示例#10
0
文件: stacks.o.c 项目: hoobaa/mecl
ecl_bds_ptr 
ecl_bds_overflow(void)
{
        static const char *stack_overflow_msg =
                "\n;;;\n;;; Binding stack overflow.\n"
                ";;; Jumping to the outermost toplevel prompt\n"
                ";;;\n\n";
	cl_env_ptr env = ecl_process_env();
	cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
	cl_index size = env->bds_size;
	ecl_bds_ptr org = env->bds_org;
	ecl_bds_ptr last = org + size;
	if (env->bds_limit >= last) {
                ecl_unrecoverable_error(env, stack_overflow_msg);
	}
	env->bds_limit += margin;
	cl_cerror(6, make_constant_base_string("Extend stack size"),
		  ECL_SYM("EXT::STACK-OVERFLOW",1665), ECL_SYM(":SIZE",1308), ecl_make_fixnum(size),
		  ECL_SYM(":TYPE",1318), ECL_SYM("EXT::BINDING-STACK",1668));
	ecl_bds_set_size(env, size + (size / 2));
        return env->bds_top;
}
示例#11
0
文件: all_symbols.c 项目: hoobaa/mecl
cl_object si_mangle_name(cl_narg narg, ...)
{
#line 81
// ------------------------------2
#line 81
	const cl_env_ptr the_env = ecl_process_env();
#line 81
	cl_object as_function;
#line 81
	va_list ARGS;
	va_start(ARGS, narg);
	cl_object symbol = va_arg(ARGS,cl_object);  
#line 81
// ------------------------------3

	cl_index l;
	unsigned char c, *source, *dest;
	cl_object output;
	cl_object package;
	cl_object found = ECL_NIL;
	cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT);
	cl_object minarg = ecl_make_fixnum(0);
	bool is_symbol;
	cl_object name;
#line 92
// ------------------------------4
#line 92
#line 92
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(1107));
#line 92
	if (narg > 1) {
#line 92
		as_function = va_arg(ARGS,cl_object);  
#line 92
	} else {
#line 92
		as_function = ECL_NIL;
#line 92
	}
#line 92
// ------------------------------5
	name = ecl_symbol_name(symbol);
	is_symbol = Null(as_function);
	if (is_symbol) {
		cl_fixnum p;
		if (symbol == ECL_NIL)
			{
#line 97
				#line 97
				cl_object __value0 = ECL_T;
#line 97
				cl_object __value1 = make_constant_base_string("ECL_NIL");
#line 97
				the_env->nvalues = 2;
#line 97
				the_env->values[1] = __value1;
#line 97
				return __value0;
#line 97
			}

		else if (symbol == ECL_T)
			{
#line 99
				#line 99
				cl_object __value0 = ECL_T;
#line 99
				cl_object __value1 = make_constant_base_string("ECL_T");
#line 99
				the_env->nvalues = 2;
#line 99
				the_env->values[1] = __value1;
#line 99
				return __value0;
#line 99
			}

		p  = (cl_symbol_initializer*)symbol - cl_symbols;
		if (p >= 0 && p <= cl_num_symbols_in_core) {
			found = ECL_T;
			output = cl_format(4, ECL_NIL,
					   make_constant_base_string("ECL_SYM(~S,~D)"),
					   name, ecl_make_fixnum(p));
			{
#line 106
				#line 106
				cl_object __value0 = found;
#line 106
				cl_object __value1 = output;
#line 106
				cl_object __value2 = maxarg;
#line 106
				the_env->nvalues = 3;
#line 106
				the_env->values[2] = __value2;
#line 106
				the_env->values[1] = __value1;
#line 106
				return __value0;
#line 106
			}

		}
	} else if (!Null(symbol)) {
		cl_object fun = symbol->symbol.gfdef;
		cl_type t = (fun == OBJNULL)? t_other : type_of(fun);
		if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) {
			for (l = 0; l <= cl_num_symbols_in_core; l++) {
				cl_object s = (cl_object)(cl_symbols + l);
				if (fun == ECL_SYM_FUN(s)) {
					symbol = s;
					found = ECL_T;
					if (fun->cfun.narg >= 0) {
					    minarg =
					    maxarg = ecl_make_fixnum(fun->cfun.narg);
					}
					break;
				}
			}
		}
	}
	package = ecl_symbol_package(symbol);
	if (Null(package))
		;
	else if (package == cl_core.lisp_package)
		package = make_constant_base_string("cl");
	else if (package == cl_core.system_package)
		package = make_constant_base_string("si");
	else if (package == cl_core.ext_package)
		package = make_constant_base_string("si");
	else if (package == cl_core.keyword_package)
		package = ECL_NIL;
	else
		package = package->pack.name;
	symbol = ecl_symbol_name(symbol);
	l      = symbol->base_string.fillp;
	source = symbol->base_string.self;
	output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1);
	if (is_symbol && source[0] == '*') {
		if (l > 2 && source[l-1] == '*') l--;
		c = 'V';
		l--;
		source++;
	} else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') {
		c = 'C';
		l-= 2;
		source++;
	} else if (!is_symbol) {
		c = '_';
	} else if (package == cl_core.keyword_package) {
		c = 'K';
	} else {
		c = 'S';
	}
	output->base_string.fillp = 0;
	if (!Null(package))
		if (!mangle_name(output, package->base_string.self, package->base_string.fillp))
			{
#line 162
				#line 162
				cl_object __value0 = ECL_NIL;
#line 162
				cl_object __value1 = ECL_NIL;
#line 162
				cl_object __value2 = maxarg;
#line 162
				the_env->nvalues = 3;
#line 162
				the_env->values[2] = __value2;
#line 162
				the_env->values[1] = __value1;
#line 162
				return __value0;
#line 162
			}

	output->base_string.self[output->base_string.fillp++] = c;
	if (!(dest = mangle_name(output, source, l)))
		{
#line 165
			#line 165
			cl_object __value0 = ECL_NIL;
#line 165
			cl_object __value1 = ECL_NIL;
#line 165
			cl_object __value2 = maxarg;
#line 165
			the_env->nvalues = 3;
#line 165
			the_env->values[2] = __value2;
#line 165
			the_env->values[1] = __value1;
#line 165
			return __value0;
#line 165
		}

	if (dest[-1] == '_')
		dest[-1] = 'M';
	*(dest++) = '\0';
	{
#line 169
		#line 169
		cl_object __value0 = found;
#line 169
		cl_object __value1 = output;
#line 169
		cl_object __value2 = minarg;
#line 169
		cl_object __value3 = maxarg;
#line 169
		the_env->nvalues = 4;
#line 169
		the_env->values[3] = __value3;
#line 169
		the_env->values[2] = __value2;
#line 169
		the_env->values[1] = __value1;
#line 169
		return __value0;
#line 169
	}

}
示例#12
0
文件: all_symbols.c 项目: hoobaa/mecl
static void
make_this_symbol(int i, cl_object s, int code, const char *name,
		 cl_objectfn fun, int narg, cl_object value)
{
	enum ecl_stype stp;
	cl_object package;
	bool form = 0;

	switch (code & 3) {
	case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break;
	case SPECIAL_SYMBOL: stp = ecl_stp_special; break;
	case CONSTANT_SYMBOL: stp = ecl_stp_constant; break;
	case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary;
	}
	switch (code & 0xfc) {
	case CL_PACKAGE: package = cl_core.lisp_package; break;
	case SI_PACKAGE: package = cl_core.system_package; break;
	case EXT_PACKAGE: package = cl_core.ext_package; break;
	case KEYWORD_PACKAGE: package = cl_core.keyword_package; break;
	case MP_PACKAGE: package = cl_core.mp_package; break;
#ifdef CLOS
	case CLOS_PACKAGE: package = cl_core.clos_package; break;
#endif
#ifdef ECL_CLOS_STREAMS
	case GRAY_PACKAGE: package = cl_core.gray_package; break;
#endif
	case FFI_PACKAGE: package = cl_core.ffi_package; break;
	default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()");
	}
	s->symbol.t = t_symbol;
	s->symbol.dynamic = 0;
#ifdef ECL_THREADS
	s->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
#endif
	ECL_SET(s, OBJNULL);
	ECL_SYM_FUN(s) = ECL_NIL;
	s->symbol.plist = ECL_NIL;
	s->symbol.hpack = ECL_NIL;
	s->symbol.stype = stp;
	s->symbol.hpack = package;
	s->symbol.name = make_constant_base_string(name);
	if (package == cl_core.keyword_package) {
		package->pack.external =
                        _ecl_sethash(s->symbol.name, package->pack.external, s);
		ECL_SET(s, s);
	} else {
		int intern_flag;
		ECL_SET(s, value);
		if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL
		    && intern_flag == ECL_INHERITED) {
			ecl_shadowing_import(s, package);
		} else {
			cl_import2(s, package);
		}
		if (!(code & PRIVATE)) {
			cl_export2(s, package);
			if (package == cl_core.ext_package)
				cl_export2(s, cl_core.system_package);
		}
	}
	if (form) {
		s->symbol.stype |= ecl_stp_special_form;
	} else if (fun) {
		cl_object f;
		if (narg >= 0) {
			f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg);
		} else {
			f = ecl_make_cfun_va(fun, s, NULL);
		}
		ECL_SYM_FUN(s) = f;
	}
	cl_num_symbols_in_core = i + 1;
}