/* ---------------- 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 */
/* ------------------ 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 */
/* ------------------ 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 */
/* ------------------ 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 */
/* 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 */
/* ----------------- 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 */
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);
}
/* ---------------- 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 */
/* ------------------ 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 */
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);
}
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);
}
/* ---------------- Lrcpy ------------------ */
void __CDECL
Lrcpy( const PLstr to, const double from )
{
LLEN(*to) = sizeof(double);
LTYPE(*to) = LREAL_TY;
LREAL(*to) = from;
} /* Lrcpy */
/* ---------------- Licpy ------------------ */
void __CDECL
Licpy( const PLstr to, const long from )
{
LLEN(*to) = sizeof(long);
LTYPE(*to) = LINTEGER_TY;
LINT(*to) = from;
} /* Licpy */
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;
}
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);
}
/* ----------------- 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 */
/* --------------------------------------------------------------- */
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 */
/* ----------------- 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 */
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;
}
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;
}
/* ------------------ 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 */
/* -- 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 */
/* ---------------- 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 */
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;
}
/* ---------------- 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 */
/* ---------------- 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 */
/* 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 */
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);
}
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;
}
/* --------------- 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 */
