/*
* valid_ptr - returns true if p points to allocated memory and
* has at least size available
*/
int valid_ptr(const void* p, size_t size)
{
BlkHdr* bh;
assert(0 != p);
assert(0 < size);
bh = find_blk(p);
/*
* check that there are at least size bytes available from p
*/
assert((BYTE_PTR(p) + size) <= (BYTE_PTR(bh->buf) + bh->size));
return 1;
}
/*
* find_blk_exhaustive - find a block by scanning the
* entire hash table. This function finds blocks that do not
* start at the pointer returned from Malloc.
*/
static BlkHdr* find_blk_exhaustive(const void* p)
{
int i;
BlkHdr* bh;
for (i = 0; i < HTABLE_SIZE; ++i) {
for (bh = bhTab[i]; bh; bh = bh->next) {
if (bh->buf <= p && BYTE_PTR(p) < (BYTE_PTR(bh->buf) + bh->size))
return bh;
}
}
return 0;
}
/*
* fda_free - check chunk of memory for overruns and free it
*/
void fda_free(void* p)
{
if (p) {
size_t size;
BlkHdr* bh = find_blk(p);
void* bp;
/* p already freed or not allocated? */
assert(0 != bh);
assert(p == bh->buf);
bp = BASE_PTR(p);
/* buffer underflow? */
assert(DEADBEEF == *((size_t*) bp));
/*
* buffer overflow?
* Note: it's possible to have up to 3 bytes of unchecked space
* between size and DEADBEEF
*/
size = BASE_SIZE(bh->size);
assert(DEADBEEF == *((size_t*)(BYTE_PTR(bp) + size - S_SIZE)));
SHRED_MEM(bp, size);
free_blk(p);
free(bp);
}
}
/*
* fda_realloc - resize a buffer, force reallocation if new size is
* larger than old size
*/
void* fda_realloc(void* p, size_t size, const char* file, int line)
{
void* np;
size_t old_size;
size_t blk_size;
/*
* don't allow malloc or free through realloc
*/
assert(0 != p);
assert(0 < size);
old_size = fda_sizeof(p);
if (size < old_size)
SHRED_MEM(BYTE_PTR(p) + size, old_size - size);
else if (size > old_size) {
void* t = fda_malloc(size, __FILE__, __LINE__);
memmove(t, p, old_size);
fda_free(p);
p = t;
}
blk_size = BASE_SIZE(size);
if ((np = realloc(BASE_PTR(p), blk_size)) == 0) {
lowMemFn();
if ((np = realloc(BASE_PTR(p), blk_size)) == 0)
noMemFn();
}
/*
* don't allow noMemFn to return
*/
assert(0 != np);
*((size_t*)(BYTE_PTR(np) + blk_size - S_SIZE)) = DEADBEEF;
np = BYTE_PTR(np) + S_SIZE;
update_blk(p, np, size, file, line);
/*
* shred tail
*/
if (size > old_size)
SHRED_MEM(BYTE_PTR(np) + old_size, size - old_size);
return np;
}
uptr_t exec_special(uptr_t *env, uptr_t form) {
uptr_t fn = CAR(form);
uptr_t args = CDR(form);
switch(SVAL(fn)) {
case S_LET:
return let(env, args);
case S_FN:
return form;
case S_LOOP:
return loop(env, args);
case S_DO: {
uptr_t *body_p = refer(args), rval = NIL;
while (*body_p) {
rval = eval(env, CAR(*body_p));
*body_p = CDR(*body_p);
}
release(1); // body_p
return rval;
}
case S_RECUR: {
uptr_t rval, *fn_p = refer(fn);
rval = build_cons(*fn_p, eval_list(env, args));
release(1); // fn_p
return rval;
}
case S_QUOTE:
return CAR(args);
case S_CAR:
return CAR(eval(env, CAR(args)));
case S_CDR:
return CDR(eval(env, CAR(args)));
case S_AND: {
if (IS_NIL(args)) return PS_TRUE;
uptr_t *rem_args = refer(args),
rval = NIL;
while ((rval = eval(env, CAR(*rem_args))) && (*rem_args = CDR(*rem_args)));
release(1);
return rval;
}
case S_OR: {
if (IS_NIL(args)) return NIL;
uptr_t *rem_args = refer(args),
rval = NIL;
while (!(rval = eval(env, CAR(*rem_args))) && (*rem_args = CDR(*rem_args)));
release(1);
return rval;
}
case S_NOT: {
if (IS_NIL(args)) return NIL;
uptr_t rval = eval(env, CAR(args));
return rval ? NIL : PS_TRUE;
}
case S_IF: {
uptr_t rval = NIL, *clauses = refer(args);
if (eval(env, CAR(*clauses)) && CDR(*clauses))
rval = eval(env, CADR(*clauses));
else if (CDDR(*clauses))
rval = eval(env, CADDR(*clauses));
release(1); // clauses
return rval;
}
case S_WHEN: {
uptr_t rval = NIL, *cond_p = refer(CAR(args)), *body_p = refer(CDR(args));
if (eval(env, *cond_p))
while(*body_p) {
rval = eval(env, CAR(*body_p));
*body_p = CDR(*body_p);
}
release(2); // cond_p, body_p
return rval;
}
case S_CONS: {
uptr_t rval = NIL, *args_p = refer(args);
rval = build_cons(eval(env, CAR(*args_p)), eval(env, CADR(*args_p)));
release(1); // args_p
return rval;
}
case S_PRINT:
print_form(eval(env, CAR(args)));
printf_P(PSTR("\n"));
return NIL;
case S_DEF: {
uptr_t *args_p = refer(args),
*binding = refer(eval(env, CADR(args)));
assoc(env, CAR(*args_p), *binding);
release(2); // args_p, binding
return *binding; // Yeah, it's been "released", but the pointer is still valid.
}
case S_EVAL:
return eval(env, eval(env, CAR(args)));
#define _COMPR(rval) { \
if (IS_NIL(args)) return NIL; \
\
uptr_t *args_p = refer(args); \
while(CDR(*args_p) && (eval(env, CAR(*args_p)) _COMP_OPR eval(env, CADR(*args_p)))) \
*args_p = CDR(*args_p); \
\
if (IS_NIL(CDR(*args_p))) \
rval = eval(env, CAR(*args_p)); \
release(1); \
}
#define _COMP_OPR ==
case S_EQL: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
case S_NEQL: {
uptr_t rval = NIL;
_COMPR(rval);
return rval ? NIL : PS_TRUE;
}
#undef _COMP_OPR
#define _COMP_OPR <
case S_LT: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _COMP_OPR <=
case S_LTE: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _COMP_OPR >
case S_GT: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _COMP_OPR >=
case S_GTE: {
uptr_t rval = NIL;
_COMPR(rval);
return rval;
}
#undef _COMP_OPR
#define _ARITH(coll) { \
uptr_t *rem_args = refer(args); \
coll = TO_INT(eval(env, CAR(*rem_args))); \
*rem_args = CDR(*rem_args); \
while (*rem_args) { \
coll _ARITH_OPR TO_INT(eval(env, CAR(*rem_args))); \
*rem_args = CDR(*rem_args); \
} \
release(1); \
}
#define _ARITH_OPR +=
case S_PLUS: {
if (! args) return INTERN_INT(0);
if (! CDR(args)) return eval(env, CAR(args));
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR -=
case S_MINUS: {
if (! args) return NIL;
if (! CDR(args)) return INTERN_INT(0 - TO_INT(eval(env, CAR(args))));
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR *=
case S_MULT: {
if (! args) return INTERN_INT(1);
if (! CDR(args)) return eval(env, CAR(args));
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR /=
case S_DIV: {
if (! args) return NIL;
if (! CDR(args)) return INTERN_INT(eval(env, CAR(args)) == INTERN_INT(1) ? 1 : 0);
int rval;
_ARITH(rval);
return INTERN_INT(rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR &=
case S_BAND: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR |=
case S_BOR: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR ^=
case S_BXOR: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR <<=
case S_BSL: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
#define _ARITH_OPR >>=
case S_BSR: {
if (! args) return NIL;
if (! CDR(args)) return eval(env, CAR(args));
uint8_t rval;
_ARITH(rval);
return INTERN_INT((int)rval);
}
#undef _ARITH_OPR
case S_SREG: {
uptr_t *args_p = refer(args),
reg = eval(env, CAR(*args_p));
if (IS_REG(reg))
*BYTE_PTR(reg) = eval(env, CADR(*args_p));
else {
printf_P(PSTR("Invalid register: "));
print_form(reg);
printf_P(PSTR("\n"));
}
release(1); // args_p
return NIL;
}
case S_SLP:
_delay_ms(TO_INT(eval(env, CAR(args))));
return NIL;
default:
printf_P(PSTR("ERROR: "));
print_form(fn);
printf_P(PSTR(" is not a function.\n"));
return NIL;
}
}
/*
* fda_malloc - allocate size chunk of memory and create debug
* records for it.
*/
void* fda_malloc(size_t size, const char* file, int line)
{
void* p;
size_t blk_size;
Location* location;
assert(0 < size);
assert(0 != file);
assert(sizeof(void*) == sizeof(size_t));
/*
* memory limiter do not allocate more than byteLimit
*/
if ((size + byteCount) > byteLimit)
return 0;
/*
* Make sure that there is enough room for prefix/postfix
* and we get an aligned buffer
*/
blk_size = BASE_SIZE(size);
if ((p = malloc(blk_size)) == 0) {
lowMemFn();
if ((p = malloc(blk_size)) == 0)
noMemFn();
}
/*
* don't allow malloc to fail
*/
assert(0 != p);
/*
* shred the memory and set bounds markers
*/
SHRED_MEM(p, blk_size);
*((size_t*) p) = DEADBEEF;
*((size_t*) (BYTE_PTR(p) + blk_size - S_SIZE)) = DEADBEEF;
/*
* find the location or create a new one
*/
if (0 == (location = findLocation(file, line))) {
if (0 == (location = addLocation(file, line))) {
free(p);
noMemFn();
}
}
/*
* don't allow noMemFn to return
*/
assert(0 != location);
if (!make_blk(BYTE_PTR(p) + S_SIZE, size, location)) {
if (0 == location->count)
freeLocation(location);
free(p);
p = 0;
noMemFn();
}
/*
* don't allow noMemFn to return
*/
assert(0 != p);
return (BYTE_PTR(p) + S_SIZE);
}