Example #1
0
/* ---------------- Lstrcpy ----------------- */
void __CDECL
Lstrcpy( const PLstr to, const PLstr from )
{
	if (LLEN(*from)==0) {
		LLEN(*to) = 0;
		LTYPE(*to) = LSTRING_TY;
	} else {
		if (LMAXLEN(*to)<=LLEN(*from)) Lfx(to,LLEN(*from));
		switch ( LTYPE(*from) ) {
			case LSTRING_TY:
				MEMCPY( LSTR(*to), LSTR(*from), LLEN(*from) );
				break;

			case LINTEGER_TY:
				LINT(*to) = LINT(*from);
				break;

			case LREAL_TY:
				LREAL(*to) = LREAL(*from);
				break;
		}
		LTYPE(*to) = LTYPE(*from);
		LLEN(*to) = LLEN(*from);
	} 
} /* Lstrcpy */
Example #2
0
/* ------------------ L2int ------------------- */
void __CDECL
L2int( const PLstr s )
{
	if (LTYPE(*s)==LREAL_TY) {
		if ((double)((long)LREAL(*s)) == LREAL(*s))
			LINT(*s) = (long)LREAL(*s);
		else
			Lerror(ERR_INVALID_INTEGER,0);
	} else { /* LSTRING_TY */
		LASCIIZ(*s);
		switch (_Lisnum(s)) {
			case LINTEGER_TY:
				LINT(*s) = (long)lLastScannedNumber;
				break;

			case LREAL_TY:
				LREAL(*s) = lLastScannedNumber;
				if ((double)((long)LREAL(*s)) == LREAL(*s))
					LINT(*s) = (long)LREAL(*s);
				else
					Lerror(ERR_INVALID_INTEGER,0);
				break;

			default:
				Lerror(ERR_INVALID_INTEGER,0);
		}
	}
	LTYPE(*s) = LINTEGER_TY;
	LLEN(*s) = sizeof(long);
} /* L2int */
Example #3
0
/* ------------------ L2str ------------------- */
void __CDECL
L2str( const PLstr s )
{
	if (LTYPE(*s)==LINTEGER_TY) {
#if defined(WCE) || defined(__BORLANDC__)
		LTOA(LINT(*s),LSTR(*s),10);
#else
		sprintf(LSTR(*s), "%ld", LINT(*s));
#endif
		LLEN(*s) = STRLEN(LSTR(*s));
	} else {	/* LREAL_TY */
		/* There is a problem with the Windows CE */
		char	str[50];
		size_t	len;

		snprintf(str, sizeof(str), "%.*g", lNumericDigits, LREAL(*s));
		/* --- remove the last dot from the number --- */
		len = STRLEN(str);
#ifdef WCE
		if (str[len-1] == '.') len--;
#endif
		if (len>=LMAXLEN(*s)) Lfx(s,len);
		MEMCPY(LSTR(*s),str,len);
		LLEN(*s) = len;
	}
	LTYPE(*s) = LSTRING_TY;
} /* L2str */
Example #4
0
/* ------------------ L2num ------------------- */
void __CDECL
L2num( const PLstr s )
{
	switch (_Lisnum(s)) {
		case LINTEGER_TY:
			/*//LINT(*s) = atol( LSTR(*s) ); */
			LINT(*s) = (long)lLastScannedNumber;
			LTYPE(*s) = LINTEGER_TY;
			LLEN(*s) = sizeof(long);
			break;

		case LREAL_TY:
			/*///LREAL(*s) = strtod( LSTR(*s), NULL ); */
			LREAL(*s) = lLastScannedNumber;
/*
//// Numbers like 2.0 should be treated as real and not as integer
//// because in cases like factorial while give an error result
////			if ((double)((long)LREAL(*s)) == LREAL(*s)) {
////				LINT(*s) = (long)LREAL(*s);
////				LTYPE(*s) = LINTEGER_TY;
////				LLEN(*s) = sizeof(long);
////			} else {
*/
				LTYPE(*s) = LREAL_TY;
				LLEN(*s) = sizeof(double);
/*
////			}
*/
			break;

		default:
			Lerror(ERR_BAD_ARITHMETIC,0);
	}
} /* L2num */
Example #5
0
/* we should change the string                     */
void __CDECL
_L2num( const PLstr s, const int type )
{
	LASCIIZ(*s);
	switch (type) {
		case LINTEGER_TY:
			/*////LINT(*s) = atol( LSTR(*s) ); */
			LINT(*s) = (long)lLastScannedNumber;
			LTYPE(*s) = LINTEGER_TY;
			LLEN(*s) = sizeof(long);
			break;

		case LREAL_TY:
			/*////LREAL(*s) = strtod( LSTR(*s), NULL ); */
			LREAL(*s) = lLastScannedNumber;
			if ((double)((long)LREAL(*s)) == LREAL(*s)) {
				LINT(*s) = (long)LREAL(*s);
				LTYPE(*s) = LINTEGER_TY;
				LLEN(*s) = sizeof(long);
			} else {
				LTYPE(*s) = LREAL_TY;
				LLEN(*s) = sizeof(double);
			}
			break;
		default:
			Lerror(ERR_BAD_ARITHMETIC,0);
	}
} /* _L2num */
Example #6
0
/* ----------------- Lrdint ------------------ */
long __CDECL
Lrdint( const PLstr s )
{
	if (LTYPE(*s)==LINTEGER_TY) return LINT(*s);

	if (LTYPE(*s)==LREAL_TY) {
		if ((double)((long)LREAL(*s)) == LREAL(*s))
			return (long)LREAL(*s);
		else
			Lerror(ERR_INVALID_INTEGER,0);
	} else { /* LSTRING_TY */
		LASCIIZ(*s);
		switch (_Lisnum(s)) {
			case LINTEGER_TY:
				/*///return atol( LSTR(*s) ); */
				return (long)lLastScannedNumber;

			case LREAL_TY:
				/*///d = strtod( LSTR(*s), NULL );
				//////if ((double)((long)d) == d)
				//////	return (long)d; */
				if ((double)((long)lLastScannedNumber) == lLastScannedNumber)
					return (long)lLastScannedNumber;
				else
					Lerror(ERR_INVALID_INTEGER,0);
				break;

			default:
				Lerror(ERR_INVALID_INTEGER,0);
		}
	}
	return 0;	/* never gets here but keeps compiler happy */
} /* Lrdint */
Example #7
0
struct lval* lval_builtin_if(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 3, "if");
    LTYPE(v, LVAL_BOOL, 0, "if");
    LTYPE(v, LVAL_QEXP, 1, "if");
    LTYPE(v, LVAL_QEXP, 2, "if");

    int result = v->cell[0]->flag;

    struct lval* x = lval_sexp();
    lval_add(x, lval_take(v, result ? 1 : 2));

    return lval_builtin_eval(e, x);
}
Example #8
0
/* ---------------- Lfx -------------------- */
void __CDECL
Lfx( const PLstr s, const size_t len )
{
	size_t	max;

	if (LISNULL(*s)) {
		LSTR(*s) = (unsigned char *) MALLOC( (max = LNORMALISE(len))+LEXTRA, "Lstr" );
		LLEN(*s) = 0;
		LMAXLEN(*s) = max;
		LTYPE(*s) = LSTRING_TY;
#ifdef USEOPTION
		LOPT(*s) = 0;
#endif
	} else
#ifdef USEOPTION
	if (!LOPTION(*s,LOPTFIX) && LMAXLEN(*s)<len) {
		LSTR(*s) = (unsigned char *) REALLOC( LSTR(*s), (max=LNORMALISE(len))+LEXTRA);
		LMAXLEN(*s) = max;
	}
#else
	if (LMAXLEN(*s)<len) {
		LSTR(*s) = (unsigned char *) REALLOC( LSTR(*s), (max=LNORMALISE(len))+LEXTRA);
		LMAXLEN(*s) = max;
	}
#endif
} /* Lfx */
Example #9
0
/* ------------------ L2real ------------------- */
void __CDECL
L2real( const PLstr s )
{
	if (LTYPE(*s)==LINTEGER_TY)
		LREAL(*s) = (double)LINT(*s);
	else { /* LSTRING_TY */
		LASCIIZ(*s);
		if (_Lisnum(s)!=LSTRING_TY)
			/*/////LREAL(*s) = strtod( LSTR(*s), NULL ); */
			LREAL(*s) = lLastScannedNumber;
		else
			Lerror(ERR_BAD_ARITHMETIC,0);
	}
	LTYPE(*s) = LREAL_TY;
	LLEN(*s) = sizeof(double);
} /* L2real */
Example #10
0
struct lval* lval_builtin_def(struct lenv* e, struct lval* v) {
    LTYPE(v, LVAL_QEXP, 0, "def");

    struct lval* syms = v->cell[0];

    for (int i = 0; i < syms->count; i++) {
        LASSERT(v, syms->cell[i]->type == LVAL_SYM,
                "'def' expects variable %i to be symbol", i);
    }

    LASSERT(v, syms->count == (v->count - 1),
            "'def' expects same variable & value count. "
            "Got %i variables and %i values.",
            syms->count, v->count -1);

    for (int i = 0; i < syms->count; i++) {
        char* sym = syms->cell[i]->sym;
        struct lval* x = lenv_get(e, sym);
        if (x->type == LVAL_FUN && x->fun_type == LVAL_FUN_BUILTIN) {
            struct lval* err = lval_err(
                                   "Cannot redefine builtin function '%s'", sym);
            lval_del(v);
            return err;
        }

        lenv_def(e, sym, v->cell[i + 1]);
    }

    return lval_take(v, 0);
}
Example #11
0
struct lval* lval_eval_comp(struct lenv* e, char* sym, struct lval* v) {
    if (strcmp(sym, "=") != 0 || strcmp(sym, "!=") != 0) {
        for (int i = 0; i < v->count; i++) {
            LTYPE(v, LVAL_NUM, i, sym);
        }
    }

    if (v->count <= 1) {
        lval_del(v);
        return lval_bool(1);
    }

    struct lval* x = lval_pop(v, 0);

    int result = 1;
    while (v->count > 0) {
        struct lval* y = lval_pop(v, 0);
        if (lval_eval_compare(sym, x, y)) {
            lval_del(x);
            x = y;
        } else {
            lval_del(y);
            result = 0;
            break;
        }
    }

    lval_del(x);
    lval_del(v);

    return lval_bool(result);
}
Example #12
0
/* ---------------- Lrcpy ------------------ */
void __CDECL
Lrcpy( const PLstr to, const double from )
{
	LLEN(*to)  = sizeof(double);
	LTYPE(*to) = LREAL_TY;
	LREAL(*to) = from;
} /* Lrcpy */
Example #13
0
/* ---------------- Licpy ------------------ */
void __CDECL
Licpy( const PLstr to, const long from )
{
	LLEN(*to)  = sizeof(long);
	LTYPE(*to) = LINTEGER_TY;
	LINT(*to)  = from;
} /* Licpy */
Example #14
0
struct lval* lval_builtin_not(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 1, "not");
    LTYPE(v, LVAL_BOOL, 0, "not");

    struct lval* x = lval_take(v, 0);
    x->flag = !x->flag;
    return x;
}
Example #15
0
struct lval* lval_builtin_eval(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 1, "eval");
    LTYPE(v, LVAL_QEXP, 0, "eval");

    struct lval* x = lval_take(v, 0);
    x->type = LVAL_SEXP;
    return lval_eval(e, x);
}
Example #16
0
/* ----------------- Lrdreal ------------------ */
double __CDECL
Lrdreal( const PLstr s )
{
	if (LTYPE(*s)==LREAL_TY) return LREAL(*s);

	if (LTYPE(*s)==LINTEGER_TY)
		return (double)LINT(*s);
	else { /* LSTRING_TY */
		LASCIIZ(*s);
		if (_Lisnum(s)!=LSTRING_TY)
			/*///// return strtod( LSTR(*s), NULL ); */
			return lLastScannedNumber;
		else
			Lerror(ERR_BAD_ARITHMETIC,0);
	}
	return 0.0;
} /* Lrdreal */
Example #17
0
/* --------------------------------------------------------------- */
void R_sqlget( const int func )
{
	int col, bytes;

	if (ARGN==0) {
		Licpy(ARGR, sqlite3_column_count(sqlstmt));
		return;
	}
	if (ARGN>1) Lerror(ERR_INCORRECT_CALL,0);
	get_i0(1,col);
	col--;

	switch (sqlite3_column_type(sqlstmt, col)) {
		case SQLITE_INTEGER:
			Licpy(ARGR, sqlite3_column_int(sqlstmt, col));
			break;

		case SQLITE_FLOAT:
			Lrcpy(ARGR, sqlite3_column_double(sqlstmt, col));
			break;

		case SQLITE_TEXT:
			Lscpy(ARGR, (char*)sqlite3_column_text(sqlstmt, col));
			break;

		case SQLITE_BLOB:
			bytes = sqlite3_column_bytes(sqlstmt, col);
			Lfx(ARGR, bytes);
			LLEN(*ARGR) = bytes;
			LTYPE(*ARGR) = LSTRING_TY;
			MEMCPY(LSTR(*ARGR), sqlite3_column_blob(sqlstmt, col), bytes);
			break;

		case SQLITE_NULL:
			Lfx(ARGR,1);
			LTYPE(*ARGR)   = LSTRING_TY;
			LLEN(*ARGR)    = 1;
			LSTR(*ARGR)[0] = 0;
			break;

		default:
			Lfx(ARGR,0);
			LTYPE(*ARGR) = LSTRING_TY;
			LLEN(*ARGR)  = 0;
	}
} /* R_sqlget */
Example #18
0
/* ----------------- Lstrset ------------------ */
void __CDECL
Lstrset( const PLstr to, const size_t length, const char value)
{
	Lfx(to,length);
	LTYPE(*to) = LSTRING_TY;
	LLEN(*to) = length;
	MEMSET(LSTR(*to),value,length);
}  /* Lstrset */
Example #19
0
struct lval* lval_builtin_len(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 1, "len");
    LTYPE(v, LVAL_QEXP, 0, "len");

    struct lval* x = lval_num(v->cell[0]->count);
    lval_del(v);

    return x;
}
Example #20
0
struct lval* lval_builtin_lambda(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 2, "\\");
    LTYPE(v, LVAL_QEXP, 0, "\\");
    LTYPE(v, LVAL_QEXP, 1, "\\");

    for (int i = 0; i < v->cell[0]->count; i++) {
        struct lval* s = v->cell[0]->cell[i];
        LASSERT(v, s->type == LVAL_SYM,
                "'\\' expects variable %i to be symbol", i);

        if (strcmp(s->sym, "&") == 0) {
            LASSERT(v, v->cell[0]->count == i + 2,
                    "'\\' requires exactly one symbol after &");
        }
    }

    struct lval* x = lval_lambda(lval_pop(v, 0), lval_pop(v, 0));
    lval_del(v);

    return x;
}
Example #21
0
/* ------------------ Lmod ----------------- */
void __CDECL
Lmod( const PLstr to, const PLstr A, const PLstr B )
{
	L2REAL(A);
	L2REAL(B);

	if (LREAL(*B) == 0) Lerror(ERR_ARITH_OVERFLOW,0);

	LREAL(*to) = (double) (LREAL(*A) - (long)(LREAL(*A) / LREAL(*B)) * LREAL(*B));
	LTYPE(*to) = LREAL_TY;
	LLEN(*to)  = sizeof(double);
} /* Lmod */
Example #22
0
/* -- are of the same type                      */
int __CDECL
_Lstrcmp( const PLstr a, const PLstr b )
{
	int	r;

	if ( (r=MEMCMP( LSTR(*a), LSTR(*b), MIN(LLEN(*a),LLEN(*b))))!=0 )
		return r;
	else {
		if (LLEN(*a) > LLEN(*b))
			return 1;
		else
		if (LLEN(*a) == LLEN(*b)) {
			if (LTYPE(*a) > LTYPE(*b))
				return 1;
			else
			if (LTYPE(*a) < LTYPE(*b))
				return -1;
			return 0;
		} else
			return -1;
	}
} /* _Lstrcmp */
Example #23
0
/* ---------------- Lintdiv ---------------- */
void __CDECL
Lintdiv( const PLstr to, const PLstr A, const PLstr B )
{
	double	b;

	b = Lrdreal(B);

	if (b == 0) Lerror(ERR_ARITH_OVERFLOW,0);

	LINT(*to)  = (long) (Lrdreal(A) / b);
	LTYPE(*to) = LINTEGER_TY;
	LLEN(*to)  = sizeof(long);
} /* Lintdiv */
Example #24
0
struct lval* lval_builtin_join(struct lenv* e, struct lval* v) {
    for (int i = 0; i < v->count; i++) {
        LTYPE(v, LVAL_QEXP, i, "join");
    }

    struct lval* x = lval_pop(v, 0);

    while (v->count) {
        x = lval_join(x, lval_pop(v, 0));
    }

    lval_del(v);
    return x;
}
Example #25
0
/* ---------------- Lwscpy ------------------ */
void __CDECL
Lwscpy(const PLstr to, const wchar_t *from )
{
	size_t	len;

	if (!from)
		Lfx(to,len=0);
	else {
		Lfx(to,len = wcslen(from));
		wcstombs(LSTR(*to), from ,len );
	}
	LLEN(*to) = len;
	LTYPE(*to) = LSTRING_TY;
} /* Lwscpy */
Example #26
0
/* ---------------- Lscpy ------------------ */
void __CDECL
Lscpy( const PLstr to, const char *from )
{
	size_t	len;

	if (!from)
		Lfx(to,len=0);
	else {
		Lfx(to,len = STRLEN(from));
		MEMCPY( LSTR(*to), from, len );
	}
	LLEN(*to) = len;
	LTYPE(*to) = LSTRING_TY;
} /* Lscpy */
Example #27
0
/* WARNING!!! length is size_t type DO NOT PASS A NEGATIVE value */
void __CDECL
_Lsubstr( const PLstr to, const PLstr from, size_t start, size_t length )
{
	L2STR(from);

	start--;
	if ((length==0) || (length+start>LLEN(*from)))
		length = LLEN(*from) - start;

	if (start<LLEN(*from)) {
		if (LMAXLEN(*to)<length) Lfx(to,length);
		MEMCPY( LSTR(*to), LSTR(*from)+start, length );
		LLEN(*to) = length;
	} else
		LZEROSTR(*to);
	LTYPE(*to) = LSTRING_TY;
}  /* Lstrsub */
Example #28
0
struct lval* lval_builtin_cons(struct lenv* e, struct lval* v) {
    LNUMARGS(v, 2, "cons");
    LTYPE(v, LVAL_QEXP, 1, "cons");

    // New q-exp with first arg
    struct lval* x = lval_qexp();
    lval_add(x, lval_pop(v, 0));

    // Old q-exp from second arg
    struct lval* q = lval_take(v, 0);

    while (q->count) {
        lval_add(x, lval_pop(q, 0));
    }
    lval_del(q);

    return lval_eval(e, x);
}
Example #29
0
LispObj *
LispNewObj ()
{
  LispObj *s;
  if (LispObjFreeQ) {
    s = LispObjFreeQ;
    LispObjFreeQ = LispObjFreeQ->n;
    if (LTYPE(s) == S_STRING)
      freeMagic(LSTR(s));
  }
  else {
    s = (LispObj *) mallocMagic((unsigned) (sizeof(LispObj)));
  }
  s->t = S_INT;
  s->u.l = NULL;
  if (!LispObjAllocQ)
    LispObjAllocQTail = s;
  s->n = LispObjAllocQ;
  LispObjAllocQ = s;
  return s;
}
Example #30
0
/* --------------- Lhashvalue ------------------ */
dword __CDECL
Lhashvalue( const PLstr str )
{
	dword	value = 0;
	size_t	i,l=0;

	if (LISNULL(*str)) return 0;

	switch (LTYPE(*str)) {
		case LINTEGER_TY: l = sizeof(long); break;
		case LREAL_TY:    l = sizeof(double); break;
		case LSTRING_TY:  l = MIN(255,LLEN(*str)); break;
	}
	for (i=0; i<l; i++)
		value = 31*value + LSTR(*str)[i];
/*	for (i=0; i<l; i+=4) {
		for (j=0; j<4 && i+j<l; j++)
			value ^= LSTR(*str)[i+j] << (8*j);
		value = (value>>3) | (value<<29);
	}
*/
	return value;
} /* Lhashvalue */