/* fmtscheme.c: SCHEME OBJECT FORMAT IMPLEMENTATION
*
* $Id: //info.ravenbrook.com/project/mps/master/code/fmtscheme.c#10 $
* Copyright (c) 2001-2020 Ravenbrook Limited. See end of file for license.
*/
#include <string.h>
#include "fmtscheme.h"
#include "testlib.h"
/* special objects */
static obj_t obj_true; /* #t, boolean true */
static obj_t obj_false; /* #f, boolean false */
/* MPS globals */
mps_arena_t scheme_arena; /* the arena */
mps_pool_t obj_pool; /* pool for ordinary Scheme objects */
mps_ap_t obj_ap; /* allocation point used to allocate objects */
/* make_* -- object constructors */
#define ALIGNMENT sizeof(mps_word_t)
/* Align size upwards to the next multiple of the word size. */
#define ALIGN_WORD(size) \
(((size) + ALIGNMENT - 1) & ~(ALIGNMENT - 1))
/* Align size upwards to the next multiple of the word size, and
* additionally ensure that it's big enough to store a forwarding
* pointer. Evaluates its argument twice. */
#define ALIGN_OBJ(size) \
(ALIGN_WORD(size) >= ALIGN_WORD(sizeof(fwd_s)) \
? ALIGN_WORD(size) \
: ALIGN_WORD(sizeof(fwd_s)))
obj_t scheme_make_bool(int condition)
{
return condition ? obj_true : obj_false;
}
obj_t scheme_make_pair(mps_ap_t ap, obj_t car, obj_t cdr)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(pair_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_pair");
obj = addr;
obj->pair.type = TYPE_PAIR;
CAR(obj) = car;
CDR(obj) = cdr;
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_integer(mps_ap_t ap, long integer)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(integer_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_integer");
obj = addr;
obj->integer.type = TYPE_INTEGER;
obj->integer.integer = integer;
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_symbol(mps_ap_t ap, size_t length, char string[])
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(symbol_s, string) + length+1);
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_symbol");
obj = addr;
obj->symbol.type = TYPE_SYMBOL;
obj->symbol.length = length;
memcpy(obj->symbol.string, string, length+1);
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_string(mps_ap_t ap, size_t length, char string[])
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(string_s, string) + length+1);
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_string");
obj = addr;
obj->string.type = TYPE_STRING;
obj->string.length = length;
if (string) memcpy(obj->string.string, string, length+1);
else memset(obj->string.string, 0, length+1);
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_special(mps_ap_t ap, char *string)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(special_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_special");
obj = addr;
obj->special.type = TYPE_SPECIAL;
obj->special.name = string;
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_operator(mps_ap_t ap, char *name,
entry_t entry, obj_t arguments,
obj_t body, obj_t env, obj_t op_env)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(operator_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_operator");
obj = addr;
obj->operator.type = TYPE_OPERATOR;
obj->operator.name = name;
obj->operator.entry = entry;
obj->operator.arguments = arguments;
obj->operator.body = body;
obj->operator.env = env;
obj->operator.op_env = op_env;
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_port(mps_ap_t ap, obj_t name, FILE *stream)
{
mps_addr_t port_ref;
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(port_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_port");
obj = addr;
obj->port.type = TYPE_PORT;
obj->port.name = name;
obj->port.stream = stream;
} while(!mps_commit(ap, addr, size));
port_ref = obj;
mps_finalize(scheme_arena, &port_ref);
return obj;
}
obj_t scheme_make_character(mps_ap_t ap, char c)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(sizeof(character_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_character");
obj = addr;
obj->character.type = TYPE_CHARACTER;
obj->character.c = c;
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_vector(mps_ap_t ap, size_t length, obj_t fill)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(vector_s, vector) + length * sizeof(obj_t));
do {
size_t i;
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_vector");
obj = addr;
obj->vector.type = TYPE_VECTOR;
obj->vector.length = length;
for(i = 0; i < length; ++i)
obj->vector.vector[i] = fill;
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_buckets(mps_ap_t ap, size_t length)
{
obj_t obj;
mps_addr_t addr;
size_t size = ALIGN_OBJ(offsetof(buckets_s, bucket) + length * sizeof(obj->buckets.bucket[0]));
do {
size_t i;
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_buckets");
obj = addr;
obj->buckets.type = TYPE_BUCKETS;
obj->buckets.length = length;
obj->buckets.used = 0;
obj->buckets.deleted = 0;
for(i = 0; i < length; ++i) {
obj->buckets.bucket[i].key = NULL;
obj->buckets.bucket[i].value = NULL;
}
} while(!mps_commit(ap, addr, size));
return obj;
}
obj_t scheme_make_table(mps_ap_t ap, size_t length, hash_t hashf, cmp_t cmpf)
{
obj_t obj;
mps_addr_t addr;
size_t l, size = ALIGN_OBJ(sizeof(table_s));
do {
mps_res_t res = mps_reserve(&addr, ap, size);
if (res != MPS_RES_OK) error("out of memory in make_table");
obj = addr;
obj->table.type = TYPE_TABLE;
obj->table.buckets = NULL;
} while(!mps_commit(ap, addr, size));
obj->table.hash = hashf;
obj->table.cmp = cmpf;
/* round up to next power of 2 */
for(l = 1; l < length; l *= 2);
obj->table.buckets = scheme_make_buckets(ap, l);
mps_ld_reset(&obj->table.ld, scheme_arena);
return obj;
}
/* MPS Format */
static mps_res_t obj_scan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit)
{
#define FIX(ref) \
do { \
mps_addr_t _addr = (ref); /* copy to local to avoid type pun */ \
mps_res_t res = MPS_FIX12(ss, &_addr); \
if (res != MPS_RES_OK) return res; \
(ref) = _addr; \
} while(0)
MPS_SCAN_BEGIN(ss) {
while (base < limit) {
obj_t obj = base;
switch (TYPE(obj)) {
case TYPE_PAIR:
case TYPE_PROMISE:
FIX(CAR(obj));
FIX(CDR(obj));
base = (char *)base + ALIGN_OBJ(sizeof(pair_s));
break;
case TYPE_INTEGER:
base = (char *)base + ALIGN_OBJ(sizeof(integer_s));
break;
case TYPE_SYMBOL:
base = (char *)base +
ALIGN_OBJ(offsetof(symbol_s, string) + obj->symbol.length + 1);
break;
case TYPE_SPECIAL:
base = (char *)base + ALIGN_OBJ(sizeof(special_s));
break;
case TYPE_OPERATOR:
FIX(obj->operator.arguments);
FIX(obj->operator.body);
FIX(obj->operator.env);
FIX(obj->operator.op_env);
base = (char *)base + ALIGN_OBJ(sizeof(operator_s));
break;
case TYPE_STRING:
base = (char *)base +
ALIGN_OBJ(offsetof(string_s, string) + obj->string.length + 1);
break;
case TYPE_PORT:
FIX(obj->port.name);
base = (char *)base + ALIGN_OBJ(sizeof(port_s));
break;
case TYPE_CHARACTER:
base = (char *)base + ALIGN_OBJ(sizeof(character_s));
break;
case TYPE_VECTOR:
{
size_t i;
for (i = 0; i < obj->vector.length; ++i)
FIX(obj->vector.vector[i]);
}
base = (char *)base +
ALIGN_OBJ(offsetof(vector_s, vector) +
obj->vector.length * sizeof(obj->vector.vector[0]));
break;
case TYPE_BUCKETS:
{
size_t i;
for (i = 0; i < obj->buckets.length; ++i) {
FIX(obj->buckets.bucket[i].key);
FIX(obj->buckets.bucket[i].value);
}
}
base = (char *)base +
ALIGN_OBJ(offsetof(buckets_s, bucket) +
obj->buckets.length * sizeof(obj->buckets.bucket[0]));
break;
case TYPE_TABLE:
FIX(obj->table.buckets);
base = (char *)base + ALIGN_OBJ(sizeof(table_s));
break;
case TYPE_FWD2:
base = (char *)base + ALIGN_WORD(sizeof(fwd2_s));
break;
case TYPE_FWD:
base = (char *)base + ALIGN_WORD(obj->fwd.size);
break;
case TYPE_PAD1:
base = (char *)base + ALIGN_WORD(sizeof(pad1_s));
break;
case TYPE_PAD:
base = (char *)base + ALIGN_WORD(obj->pad.size);
break;
default:
error("Unexpected object on the heap\n");
return MPS_RES_FAIL;
}
}
} MPS_SCAN_END(ss);
return MPS_RES_OK;
}
static mps_addr_t obj_skip(mps_addr_t base)
{
obj_t obj = base;
switch (TYPE(obj)) {
case TYPE_PAIR:
case TYPE_PROMISE:
base = (char *)base + ALIGN_OBJ(sizeof(pair_s));
break;
case TYPE_INTEGER:
base = (char *)base + ALIGN_OBJ(sizeof(integer_s));
break;
case TYPE_SYMBOL:
base = (char *)base +
ALIGN_OBJ(offsetof(symbol_s, string) + obj->symbol.length + 1);
break;
case TYPE_SPECIAL:
base = (char *)base + ALIGN_OBJ(sizeof(special_s));
break;
case TYPE_OPERATOR:
base = (char *)base + ALIGN_OBJ(sizeof(operator_s));
break;
case TYPE_STRING:
base = (char *)base +
ALIGN_OBJ(offsetof(string_s, string) + obj->string.length + 1);
break;
case TYPE_PORT:
base = (char *)base + ALIGN_OBJ(sizeof(port_s));
break;
case TYPE_CHARACTER:
base = (char *)base + ALIGN_OBJ(sizeof(character_s));
break;
case TYPE_VECTOR:
base = (char *)base +
ALIGN_OBJ(offsetof(vector_s, vector) +
obj->vector.length * sizeof(obj->vector.vector[0]));
break;
case TYPE_BUCKETS:
base = (char *)base +
ALIGN_OBJ(offsetof(buckets_s, bucket) +
obj->buckets.length * sizeof(obj->buckets.bucket[0]));
break;
case TYPE_TABLE:
base = (char *)base + ALIGN_OBJ(sizeof(table_s));
break;
case TYPE_FWD2:
base = (char *)base + ALIGN_WORD(sizeof(fwd2_s));
break;
case TYPE_FWD:
base = (char *)base + ALIGN_WORD(obj->fwd.size);
break;
case TYPE_PAD:
base = (char *)base + ALIGN_WORD(obj->pad.size);
break;
case TYPE_PAD1:
base = (char *)base + ALIGN_WORD(sizeof(pad1_s));
break;
default:
error("Unexpected object on the heap\n");
return NULL;
}
return base;
}
static mps_addr_t obj_isfwd(mps_addr_t addr)
{
obj_t obj = addr;
switch (TYPE(obj)) {
case TYPE_FWD2:
return obj->fwd2.fwd;
case TYPE_FWD:
return obj->fwd.fwd;
default:
return NULL;
}
}
static void obj_fwd(mps_addr_t old, mps_addr_t new)
{
obj_t obj = old;
mps_addr_t limit = obj_skip(old);
size_t size = (size_t)((char *)limit - (char *)old);
cdie(size >= ALIGN_WORD(sizeof(fwd2_s)), "bad size in obj_fwd");
if (size == ALIGN_WORD(sizeof(fwd2_s))) {
TYPE(obj) = TYPE_FWD2;
obj->fwd2.fwd = new;
} else {
TYPE(obj) = TYPE_FWD;
obj->fwd.fwd = new;
obj->fwd.size = size;
}
}
static void obj_pad(mps_addr_t addr, size_t size)
{
obj_t obj = addr;
cdie(size >= ALIGN_WORD(sizeof(pad1_s)), "bad size in obj_pad");
if (size == ALIGN_WORD(sizeof(pad1_s))) {
TYPE(obj) = TYPE_PAD1;
} else {
TYPE(obj) = TYPE_PAD;
obj->pad.size = size;
}
}
void scheme_fmt(mps_fmt_t *fmt)
{
mps_res_t res;
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_FMT_ALIGN, ALIGNMENT);
MPS_ARGS_ADD(args, MPS_KEY_FMT_SCAN, obj_scan);
MPS_ARGS_ADD(args, MPS_KEY_FMT_SKIP, obj_skip);
MPS_ARGS_ADD(args, MPS_KEY_FMT_FWD, obj_fwd);
MPS_ARGS_ADD(args, MPS_KEY_FMT_ISFWD, obj_isfwd);
MPS_ARGS_ADD(args, MPS_KEY_FMT_PAD, obj_pad);
res = mps_fmt_create_k(fmt, scheme_arena, args);
} MPS_ARGS_END(args);
if (res != MPS_RES_OK) error("Couldn't create obj format");
}
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2020 Ravenbrook Limited <https://www.ravenbrook.com/>.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the
* distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
* IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
* HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/