/* ---------------- 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 */