Beispiel #1
0
void Flength(CL_FORM *base)
{
	if(CL_TRUEP(ARG(0)))
	{
		if(CL_CONSP(ARG(0)))
		{
			LOAD_FIXNUM(ARG(1), 0, ARG(1));
			COPY(ARG(0), ARG(2));
			M1_1:;
			if(CL_ATOMP(ARG(2)))
			{
				goto RETURN1;
			}
			F1plus(ARG(1));
			COPY(ARG(2), ARG(3));
			COPY(GET_CDR(ARG(3)), ARG(2));
			goto M1_1;
			RETURN1:;
			COPY(ARG(1), ARG(0));
		}
		else
		{
			if(CL_SMVECP(ARG(0)))
			{
				LOAD_FIXNUM(ARG(2), AR_SIZE(GET_FORM(ARG(0))), ARG(0));
			}
			else
			{
				COPY(ARG(0), ARG(1));
				LOAD_SYMBOL(SYMBOL(Slisp, 150), ARG(2));	/* COMPLEX-VECTOR */
				rt_struct_typep(ARG(1));
				if(CL_TRUEP(ARG(1)))
				{
					COPY(ARG(0), ARG(1));
					complex_vector_fillptr(ARG(1));
					Fminusp(ARG(1));
					if(CL_TRUEP(ARG(1)))
					{
						complex_vector_length(ARG(0));
					}
					else
					{
						complex_vector_fillptr(ARG(0));
					}
				}
				else
				{
					COPY(SYMVAL(Slisp, 58), ARG(1));	/* WRONG_TYPE */
					COPY(ARG(0), ARG(2));
					LOAD_SYMBOL(SYMBOL(Slisp, 36), ARG(3));	/* SEQUENCE */
					Ferror(ARG(1), 3);
				}
			}
		}
	}
	else
	{
		LOAD_FIXNUM(ARG(1), 0, ARG(0));
	}
}
Beispiel #2
0
void string_to_simple_string(CL_FORM *base)
{
	if(CL_SMSTRP(ARG(0)))
	{
	}
	else
	{
		COPY(ARG(0), ARG(1));
		Fstringp(ARG(1));
		if(CL_TRUEP(ARG(1)))
		{
			COPY(ARG(0), ARG(1));
			complex_vector_displaced(ARG(1));
			Fminusp(ARG(1));
			if(CL_TRUEP(ARG(1)))
			{
				COPY(ARG(0), ARG(1));
				complex_vector_fillptr(ARG(1));
				Fminusp(ARG(1));
			}
			else
			{
				goto ELSE1;
			}
			if(CL_TRUEP(ARG(1)))
			{
				complex_vector_data(ARG(0));
			}
			else
			{
				ELSE1:;
				LOAD_FIXNUM(ARG(1), 0, ARG(1));
				LOAD_NIL(ARG(2));
				subseq1(ARG(0));
			}
		}
		else
		{
			COPY(SYMVAL(Slisp, 58), ARG(1));	/* WRONG_TYPE */
			COPY(ARG(0), ARG(2));
			LOAD_SYMBOL(SYMBOL(Slisp, 44), ARG(3));	/* STRING */
			Ferror(ARG(1), 3);
		}
	}
}
Beispiel #3
0
void Fabs(CL_FORM *base)
{
	COPY(ARG(0), ARG(1));
	Fminusp(ARG(1));
	if(CL_TRUEP(ARG(1)))
	{
		Fminus(ARG(0), 1);
	}
	else
	{
	}
}
Beispiel #4
0
void rt_setup_symbol(CL_FORM *base)
{
	if(CL_SYMBOLP(ARG(0)))
	{
		COPY(SYM_PACKAGE(ARG(0)), ARG(2));
	}
	else
	{
		if(CL_TRUEP(ARG(0)))
		{
			LOAD_NIL(ARG(2));
		}
		else
		{
			COPY(SYMVAL(Slisp, 679), ARG(2));	/* *NIL-PACKAGE* */
		}
	}
	if(CL_TRUEP(ARG(2)))
	{
		COPY(ARG(1), ARG(3));
		COPY(ARG(2), ARG(4));
		Fminusp(ARG(4));
		if(CL_TRUEP(ARG(4)))
		{
			COPY(ARG(2), ARG(4));
			Fminus(ARG(4), 1);
		}
		else
		{
			COPY(ARG(2), ARG(4));
		}
		Fsvref(ARG(3));
		if(CL_SYMBOLP(ARG(0)))
		{
			LOAD_SMSTR(SYM_NAME(ARG(0)), ARG(4));
		}
		else
		{
			if(CL_TRUEP(ARG(0)))
			{
				COPY(SYMVAL(Slisp, 676), ARG(4));	/* SYM_EXPECTED */
				COPY(ARG(0), ARG(5));
				Ferror(ARG(4), 2);
			}
			else
			{
				LOAD_SMSTR((CL_FORM *)&KClisp[266], ARG(4));	/* NIL */
			}
		}
		LOAD_FIXNUM(ARG(5), 101, ARG(5));
		COPY(ARG(4), ARG(6));
		string_to_simple_string(ARG(6));
		rt_sxhash_string(ARG(6));
		COPY(ARG(6), ARG(7));
		LOAD_FIXNUM(ARG(8), 101, ARG(8));
		rt_floor(ARG(7));
		COPY(&mv_buf[0], ARG(8));
		mv_count = 1;
		{
			COPY(ARG(8), ARG(4));
		}
		COPY(ARG(0), ARG(5));
		COPY(ARG(3), ARG(6));
		set_symbol_package(ARG(5));
		COPY(ARG(2), ARG(5));
		Fplusp(ARG(5));
		if(CL_TRUEP(ARG(5)))
		{
			COPY(ARG(3), ARG(5));
			Ppackage_internal(ARG(5));
			COPY(ARG(5), ARG(7));
			COPY(ARG(4), ARG(8));
			Fsvref(ARG(7));
			ALLOC_CONS(ARG(8), ARG(0), ARG(7), ARG(6));
			COPY(ARG(5), ARG(7));
			COPY(ARG(4), ARG(8));
			Fset_svref(ARG(6));
			COPY(ARG(6), ARG(0));
		}
		else
		{
			COPY(ARG(3), ARG(5));
			Ppackage_external(ARG(5));
			COPY(ARG(5), ARG(7));
			COPY(ARG(4), ARG(8));
			Fsvref(ARG(7));
			ALLOC_CONS(ARG(8), ARG(0), ARG(7), ARG(6));
			COPY(ARG(5), ARG(7));
			COPY(ARG(4), ARG(8));
			Fset_svref(ARG(6));
			COPY(ARG(6), ARG(0));
		}
	}
	else
	{
		LOAD_NIL(ARG(0));
	}
}
Beispiel #5
0
void quick_integer_to_string(CL_FORM *base)
{
	COPY(ARG(0), ARG(1));
	Fzerop(ARG(1));
	if(CL_TRUEP(ARG(1)))
	{
		LOAD_SMSTR((CL_FORM *)&Kquick_integer_to_string[0], ARG(0));	/* 0 */
	}
	else
	{
		if(CL_FIXNUMP(ARG(0)) && GET_FIXNUM(ARG(0)) == 1)
		{
			LOAD_SMSTR((CL_FORM *)&Kquick_integer_to_string[2], ARG(0));	/* 1 */
		}
		else
		{
			COPY(ARG(0), ARG(1));
			Fminusp(ARG(1));
			if(CL_TRUEP(ARG(1)))
			{
				LOAD_SYMBOL(SYMBOL(Slisp, 40), ARG(1));	/* SIMPLE-STRING */
				LOAD_SMSTR((CL_FORM *)&Kquick_integer_to_string[4], ARG(2));	/* - */
				COPY(ARG(0), ARG(3));
				Fminus(ARG(3), 1);
				quick_integer_to_string(ARG(3));
				if(CL_SMSTRP(ARG(3)))
				{
				}
				else
				{
					LOAD_SMSTR((CL_FORM *)&KClisp[244], ARG(4));	/* type error: ~S is not of type ~S */
					COPY(ARG(3), ARG(5));
					LOAD_SYMBOL(SYMBOL(Slisp, 40), ARG(6));	/* SIMPLE-STRING */
					Ferror(ARG(4), 3);
				}
				Fconcatenate(ARG(1), 3);
				COPY(ARG(1), ARG(0));
			}
			else
			{
				COPY(ARG(0), ARG(1));
				Finteger_length(ARG(1));
				LOAD_FIXNUM(ARG(2), 3, ARG(2));
				LOAD_FIXNUM(ARG(2), 3, ARG(2));
				rt_truncate(ARG(1));
				mv_count = 1;
				F1plus(ARG(1));
				COPY(ARG(1), ARG(2));
				LOAD_CHAR(ARG(3), ' ', ARG(3));
				make_string1(ARG(2));
				COPY(ARG(1), ARG(3));
				F1minus(ARG(3));
				COPY(ARG(0), ARG(4));
				LOAD_FIXNUM(ARG(5), 0, ARG(5));
				M1_1:;
				COPY(ARG(4), ARG(6));
				Fzerop(ARG(6));
				if(CL_TRUEP(ARG(6)))
				{
					F1plus(ARG(3));
					COPY(ARG(2), ARG(6));
					COPY(ARG(2), ARG(7));
					LOAD_FIXNUM(ARG(8), 0, ARG(8));
					LOAD_NIL(ARG(9));
					COPY(ARG(3), ARG(10));
					COPY(ARG(1), ARG(11));
					replace1(ARG(6));
					COPY(ARG(2), ARG(0));
					COPY(ARG(3), ARG(2));
					Fminus(ARG(1), 2);
					shrink_simple_string(ARG(0));
					goto RETURN1;
				}
				LOAD_FIXNUM(ARG(6), 10, ARG(6));
				COPY(ARG(4), ARG(6));
				LOAD_FIXNUM(ARG(7), 10, ARG(7));
				rt_truncate(ARG(6));
				COPY(&mv_buf[0], ARG(7));
				{
					int nargs;
					nargs = 2;
					mv_count = 1;
					{
						switch(nargs)
						{
							case 0:
							LOAD_NIL(ARG(6));
							case 1:
							LOAD_NIL(ARG(7));
							nargs = 2;
						}
						COPY(ARG(6), ARG(4));
						COPY(ARG(7), ARG(5));
					}
				}
				LOAD_SMSTR((CL_FORM *)&Kquick_integer_to_string[6], ARG(6));	/* 0123456789 */
				COPY(ARG(5), ARG(7));
				pvref(ARG(6));
				COPY(ARG(6), ARG(7));
				COPY(ARG(2), ARG(8));
				COPY(ARG(3), ARG(9));
				Fset_schar(ARG(7));
				F1minus(ARG(3));
				goto M1_1;
				RETURN1:;
			}
		}
	}
}
Beispiel #6
0
void print_float(CL_FORM *base)
{
	COPY(ARG(0), ARG(2));
	Fminusp(ARG(2));
	if(CL_TRUEP(ARG(2)))
	{
		LOAD_CHAR(ARG(2), '-', ARG(2));
		COPY(ARG(1), ARG(3));
		write_char1(ARG(2));
		mv_count = 1;
		COPY(ARG(0), ARG(2));
		Fminus(ARG(2), 1);
		COPY(ARG(2), ARG(0));
	}
	COPY(ARG(0), ARG(2));
	Fzerop(ARG(2));
	if(CL_TRUEP(ARG(2)))
	{
		LOAD_SMSTR((CL_FORM *)&Kprint_float[0], ARG(2));	/* 0.0 */
		COPY(ARG(2), ARG(3));
		COPY(ARG(1), ARG(4));
		LOAD_FIXNUM(ARG(5), 0, ARG(5));
		COPY(ARG(2), ARG(6));
		Flength(ARG(6));
		write_string1(ARG(3));
		COPY(ARG(3), ARG(0));
	}
	else
	{
		LOAD_FIXNUM(ARG(2), 10, ARG(2));
		COPY(ARG(0), ARG(2));
		LOAD_FIXNUM(ARG(3), 10, ARG(3));
		rt_log(ARG(2));
		LOAD_FIXNUM(ARG(3), 1, ARG(3));
		LOAD_FIXNUM(ARG(3), 1, ARG(3));
		rt_floor(ARG(2));
		mv_count = 1;
		COPY(ARG(0), ARG(3));
		GEN_FLOAT(ARG(4), 10.0, ARG(4));
		LOAD_FIXNUM(ARG(5), -1, ARG(5));
		COPY(ARG(2), ARG(6));
		Fminus(ARG(5), 2);
		COPY(ARG(5), ARG(6));
		Fminusp(ARG(6));
		if(CL_TRUEP(ARG(6)))
		{
			LOAD_FIXNUM(ARG(6), 1, ARG(6));
			COPY(ARG(4), ARG(7));
			COPY(ARG(5), ARG(8));
			Fminus(ARG(8), 1);
			Fexpt(ARG(7));
			Fdiv(ARG(6), 2);
			COPY(ARG(6), ARG(4));
		}
		else
		{
			rt_expt(ARG(4));
		}
		Fmult(ARG(3), 2);
		LOAD_NIL(ARG(4));
		COPY(SYMVAL(Slisp, 2), ARG(5));	/* SHORT-FLOAT-EPSILON */
		LOAD_NIL(ARG(6));
		COPY(ARG(3), ARG(7));
		LOAD_FIXNUM(ARG(8), 1, ARG(8));
		COPY(ARG(5), ARG(9));
		Fminus(ARG(8), 2);
		Fge(ARG(7), 2);
		if(CL_TRUEP(ARG(7)))
		{
			GEN_FLOAT(ARG(7), 0.1, ARG(3));
			F1plus(ARG(2));
		}
		COPY(ARG(2), ARG(7));
		LOAD_FIXNUM(ARG(8), 7, ARG(8));
		Fgt(ARG(7), 2);
		if(CL_TRUEP(ARG(7)))
		{
			goto THEN1;
		}
		else
		{
			COPY(ARG(2), ARG(8));
			LOAD_FIXNUM(ARG(9), -3, ARG(9));
			Flt(ARG(8), 2);
		}
		if(CL_TRUEP(ARG(8)))
		{
			THEN1:;
			LOAD_FIXNUM(ARG(7), 0, ARG(4));
		}
		else
		{
			COPY(ARG(2), ARG(4));
			LOAD_FIXNUM(ARG(7), 0, ARG(2));
		}
		COPY(ARG(4), ARG(7));
		Fminusp(ARG(7));
		if(CL_TRUEP(ARG(7)))
		{
			LOAD_CHAR(ARG(7), '0', ARG(7));
			COPY(ARG(1), ARG(8));
			write_char1(ARG(7));
			mv_count = 1;
			LOAD_CHAR(ARG(7), '.', ARG(7));
			COPY(ARG(1), ARG(8));
			write_char1(ARG(7));
			mv_count = 1;
			LOAD_FIXNUM(ARG(7), 0, ARG(7));
			M1_1:;
			COPY(ARG(7), ARG(8));
			COPY(ARG(4), ARG(9));
			Fminus(ARG(9), 1);
			F1minus(ARG(9));
			Fge(ARG(8), 2);
			if(CL_TRUEP(ARG(8)))
			{
				goto RETURN1;
			}
			LOAD_CHAR(ARG(8), '0', ARG(8));
			COPY(ARG(1), ARG(9));
			write_char1(ARG(8));
			mv_count = 1;
			F1plus(ARG(7));
			goto M1_1;
			RETURN1:;
			LOAD_FIXNUM(ARG(7), -1, ARG(4));
		}
		M2_1:;
		COPY(ARG(5), ARG(7));
		LOAD_FIXNUM(ARG(8), 10, ARG(8));
		Fmult(ARG(7), 2);
		COPY(ARG(7), ARG(5));
		LOAD_FIXNUM(ARG(7), 10, ARG(7));
		COPY(ARG(3), ARG(8));
		Fmult(ARG(7), 2);
		LOAD_FIXNUM(ARG(8), 1, ARG(8));
		LOAD_FIXNUM(ARG(8), 1, ARG(8));
		rt_truncate(ARG(7));
		COPY(&mv_buf[0], ARG(8));
		{
			int nargs;
			nargs = 2;
			mv_count = 1;
			{
				switch(nargs)
				{
					case 0:
					LOAD_NIL(ARG(7));
					case 1:
					LOAD_NIL(ARG(8));
					nargs = 2;
				}
				COPY(ARG(7), ARG(6));
				COPY(ARG(8), ARG(3));
			}
		}
		COPY(ARG(3), ARG(7));
		LOAD_FIXNUM(ARG(8), 1, ARG(8));
		COPY(ARG(5), ARG(9));
		Fminus(ARG(8), 2);
		Fge(ARG(7), 2);
		if(CL_TRUEP(ARG(7)))
		{
			goto THEN2;
		}
		else
		{
			COPY(ARG(3), ARG(8));
			COPY(ARG(5), ARG(9));
			Fle(ARG(8), 2);
		}
		if(CL_TRUEP(ARG(8)))
		{
			THEN2:;
			goto RETURN2;
		}
		COPY(ARG(6), ARG(7));
		LOAD_FIXNUM(ARG(8), 10, ARG(8));
		digit_char1(ARG(7));
		COPY(ARG(1), ARG(8));
		write_char1(ARG(7));
		mv_count = 1;
		COPY(ARG(4), ARG(7));
		Fzerop(ARG(7));
		if(CL_TRUEP(ARG(7)))
		{
			LOAD_CHAR(ARG(7), '.', ARG(7));
			COPY(ARG(1), ARG(8));
			write_char1(ARG(7));
			mv_count = 1;
		}
		F1minus(ARG(4));
		goto M2_1;
		RETURN2:;
		COPY(ARG(3), ARG(7));
		GEN_FLOAT(ARG(8), 0.5, ARG(8));
		Fge(ARG(7), 2);
		if(CL_TRUEP(ARG(7)))
		{
			F1plus(ARG(6));
		}
		COPY(ARG(6), ARG(7));
		LOAD_FIXNUM(ARG(8), 10, ARG(8));
		digit_char1(ARG(7));
		COPY(ARG(1), ARG(8));
		write_char1(ARG(7));
		mv_count = 1;
		COPY(ARG(4), ARG(7));
		LOAD_FIXNUM(ARG(8), 0, ARG(8));
		Fge(ARG(7), 2);
		if(CL_TRUEP(ARG(7)))
		{
			LOAD_FIXNUM(ARG(7), 0, ARG(7));
			M3_1:;
			COPY(ARG(7), ARG(8));
			COPY(ARG(4), ARG(9));
			Fge(ARG(8), 2);
			if(CL_TRUEP(ARG(8)))
			{
				goto RETURN3;
			}
			LOAD_CHAR(ARG(8), '0', ARG(8));
			COPY(ARG(1), ARG(9));
			write_char1(ARG(8));
			mv_count = 1;
			F1plus(ARG(7));
			goto M3_1;
			RETURN3:;
			LOAD_CHAR(ARG(7), '.', ARG(7));
			COPY(ARG(1), ARG(8));
			write_char1(ARG(7));
			mv_count = 1;
			LOAD_CHAR(ARG(7), '0', ARG(7));
			COPY(ARG(1), ARG(8));
			write_char1(ARG(7));
			mv_count = 1;
		}
		COPY(ARG(2), ARG(7));
		Fzerop(ARG(7));
		if(CL_TRUEP(ARG(7)))
		{
		}
		else
		{
			LOAD_CHAR(ARG(7), 'E', ARG(7));
			COPY(ARG(1), ARG(8));
			write_char1(ARG(7));
			mv_count = 1;
			COPY(ARG(2), ARG(7));
			COPY(ARG(1), ARG(8));
			print_integer(ARG(7));
			mv_count = 1;
		}
		LOAD_NIL(ARG(0));
	}
}
Beispiel #7
0
void setup_symbol(CL_FORM *base)
{
	LOAD_NIL(STACK(base, 2));
	COPY(STACK(base, 0), STACK(base, 2));
	symbol_package_index(STACK(base, 2));
	if(CL_TRUEP(STACK(base, 2)))
	{
		COPY(STACK(base, 1), STACK(base, 3));
		COPY(STACK(base, 2), STACK(base, 4));
		Fminusp(STACK(base, 4));
		if(CL_TRUEP(STACK(base, 4)))
		{
			COPY(STACK(base, 2), STACK(base, 4));
			Fminus(STACK(base, 4), 1);
		}
		else
		{
			COPY(STACK(base, 2), STACK(base, 4));
		}
		vref(STACK(base, 3));
		COPY(STACK(base, 0), STACK(base, 4));
		Fsymbol_name(STACK(base, 4));
		LOAD_FIXNUM(101, STACK(base, 5));
		string_hash(STACK(base, 4));
		COPY(STACK(base, 3), STACK(base, 5));
		COPY(STACK(base, 0), STACK(base, 6));
		set_symbol_package(STACK(base, 5));
		COPY(STACK(base, 2), STACK(base, 5));
		LOAD_FIXNUM(0, STACK(base, 6));
		Fle(STACK(base, 5), 2);
		if(CL_TRUEP(STACK(base, 5)))
		{
			COPY(STACK(base, 3), STACK(base, 5));
			LOAD_FIXNUM(3, STACK(base, 6));
			LOAD_SYMBOL(SYMBOL(Slisp, 273), STACK(base, 7));	/* PACKAGE */
			struct_ref(STACK(base, 5));
			COPY(STACK(base, 5), STACK(base, 6));
			COPY(STACK(base, 4), STACK(base, 7));
			Fsvref(STACK(base, 6));
			{
				CL_FORM *lptr;
				lptr = form_alloc(STACK(base, 7), 2);
				COPY(STACK(base, 0), CAR(lptr));
				COPY(STACK(base, 6), CDR(lptr));
				LOAD_CONS(lptr, STACK(base, 6));
			}
			COPY(STACK(base, 6), STACK(base, 0));
			COPY(STACK(base, 5), STACK(base, 1));
			COPY(STACK(base, 4), STACK(base, 2));
			Fset_svref(STACK(base, 0));
		}
		else
		{
			COPY(STACK(base, 3), STACK(base, 5));
			LOAD_FIXNUM(2, STACK(base, 6));
			LOAD_SYMBOL(SYMBOL(Slisp, 273), STACK(base, 7));	/* PACKAGE */
			struct_ref(STACK(base, 5));
			COPY(STACK(base, 5), STACK(base, 6));
			COPY(STACK(base, 4), STACK(base, 7));
			Fsvref(STACK(base, 6));
			{
				CL_FORM *lptr;
				lptr = form_alloc(STACK(base, 7), 2);
				COPY(STACK(base, 0), CAR(lptr));
				COPY(STACK(base, 6), CDR(lptr));
				LOAD_CONS(lptr, STACK(base, 6));
			}
			COPY(STACK(base, 6), STACK(base, 0));
			COPY(STACK(base, 5), STACK(base, 1));
			COPY(STACK(base, 4), STACK(base, 2));
			Fset_svref(STACK(base, 0));
		}
	}
	else
	{
		LOAD_NIL(STACK(base, 0));
	}
}