mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-21 03:52:16 -08:00
1d00afac81
Publish minor changes to readme and configure files in main directory. Main directory and code directory licence texts are now fully updated. Copied from Perforce Change: 196994
488 lines
14 KiB
C
488 lines
14 KiB
C
/* fmtscheme.c: SCHEME OBJECT FORMAT IMPLEMENTATION
|
|
*
|
|
* $Id$
|
|
* 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 <http://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.
|
|
*/
|