static sexp sexp_vector_nreverse (sexp ctx, sexp vec) {
int i, j;
sexp tmp, *data=sexp_vector_data(vec);
for (i=0, j=sexp_vector_length(vec)-1; i<j; i++, j--)
swap(tmp, data[i], data[j]);
return vec;
}
static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) {
sexp_sint_t i;
sexp ls, *data=sexp_vector_data(vec);
for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls))
sexp_car(ls) = data[i];
return seq;
}
static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq,
sexp less, sexp key) {
sexp_sint_t len;
sexp res, *data;
sexp_gc_var1(vec);
if (sexp_nullp(seq)) return seq;
sexp_gc_preserve1(ctx, vec);
vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
if (! sexp_vectorp(vec)) {
res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
} else {
data = sexp_vector_data(vec);
len = sexp_vector_length(vec);
if (sexp_not(key) && sexp_basic_comparator(less)) {
sexp_qsort(ctx, data, 0, len-1);
if (sexp_opcodep(less) && sexp_opcode_inverse(less))
sexp_vector_nreverse(ctx, vec);
res = vec;
} else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less);
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
} else {
res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
}
}
if (sexp_pairp(seq) && ! sexp_exceptionp(res))
res = sexp_vector_copy_to_list(ctx, vec, seq);
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_load_image (const char* file, sexp_uint_t heap_size, sexp_uint_t heap_max_size) {
sexp ctx, flags, *globals, *types;
int fd;
sexp_sint_t offset;
sexp_heap heap;
sexp_free_list q;
struct sexp_image_header_t header;
fd = open(file, O_RDONLY);
if (fd < 0) {
fprintf(stderr, "can't open image file: %s\n", file);
return NULL;
}
if (read(fd, &header, sizeof(header)) != sizeof(header))
return NULL;
if (memcmp(header.magic, SEXP_IMAGE_MAGIC, sizeof(header.magic)) != 0) {
fprintf(stderr, "invalid image file magic for %s: %s\n", file, header.magic);
return NULL;
} else if (header.major != SEXP_IMAGE_MAJOR_VERSION
|| header.major < SEXP_IMAGE_MINOR_VERSION) {
fprintf(stderr, "unsupported image version: %d.%d\n",
header.major, header.minor);
return NULL;
} else if (!sexp_abi_compatible(NULL, header.abi, SEXP_ABI_IDENTIFIER)) {
fprintf(stderr, "unsupported ABI: %s (expected %s)\n",
header.abi, SEXP_ABI_IDENTIFIER);
return NULL;
}
if (heap_size < header.size) heap_size = header.size;
heap = (sexp_heap)malloc(sexp_heap_pad_size(heap_size));
if (!heap) {
fprintf(stderr, "couldn't malloc heap\n");
return NULL;
}
if (read(fd, heap, header.size) != header.size) {
fprintf(stderr, "error reading image\n");
return NULL;
}
offset = (sexp_sint_t)((char*)heap - (sexp_sint_t)header.base);
/* expand the last free chunk if necessary */
if (heap->size < heap_size) {
for (q=(sexp_free_list)(((char*)heap->free_list) + offset); q->next;
q=(sexp_free_list)(((char*)q->next) + offset))
;
if ((char*)q + q->size >= (char*)heap->data + heap->size) {
/* last free chunk at end of heap */
q->size += heap_size - heap->size;
} else {
/* last free chunk in the middle of the heap */
q->next = (sexp_free_list)((char*)heap->data + heap->size);
q = (sexp_free_list)(((char*)q->next) + offset);
q->size = heap_size - heap->size;
q->next = NULL;
}
heap->size += (heap_size - heap->size);
}
ctx = (sexp)(((char*)header.context) + offset);
globals = sexp_vector_data((sexp)((char*)sexp_context_globals(ctx) + offset));
types = sexp_vector_data((sexp)((char*)(globals[SEXP_G_TYPES]) + offset));
flags = sexp_fx_add(SEXP_COPY_LOADP, SEXP_COPY_FREEP);
sexp_offset_heap_pointers(heap, header.base, types, flags);
close(fd);
return ctx;
}
