static SCM
scm_gnumeric_funcall (SCM funcname, SCM arglist)
{
int i, num_args;
GnmValue **argvals;
GnmValue *retval;
SCM retsmob;
GnmCellRef cell_ref = { 0, 0, 0, 0 };
SCM_ASSERT (SCM_NIMP (funcname) && SCM_STRINGP (funcname), funcname, SCM_ARG1, "gnumeric-funcall");
SCM_ASSERT (SCM_NFALSEP (scm_list_p (arglist)), arglist, SCM_ARG2, "gnumeric-funcall");
num_args = scm_ilength (arglist);
argvals = g_new (GnmValue *, num_args);
for (i = 0; i < num_args; ++i) {
argvals[i] = scm_to_value (SCM_CAR (arglist));
arglist = SCM_CDR (arglist);
}
retval = function_call_with_values (eval_pos, SCM_CHARS (funcname),
num_args,argvals);
retsmob = value_to_scm (retval, cell_ref);
value_release (retval);
return retsmob;
}
/*
* Scm_Write - Standard Write.
*/
void Scm_Write(ScmObj obj, ScmObj p, int mode)
{
if (!SCM_OPORTP(p)) Scm_Error("output port required, but got %S", p);
ScmPort *port = SCM_PORT(p);
ScmWriteContext ctx;
write_context_init(&ctx, mode, 0, 0);
ScmVM *vm = Scm_VM();
if (PORT_LOCK_OWNER_P(port, vm) && PORT_RECURSIVE_P(port)) {
/* Special treatment - if we're "display"-ing a string, we'll bypass
walk path even if we're in the middle of write/ss. Using srfi-38
notation to show displayed strings doesn't make sense at all.
*/
if (PORT_WALKER_P(port) &&
!((mode == SCM_WRITE_DISPLAY) && SCM_STRINGP(obj))) {
write_walk(obj, port);
} else {
write_rec(obj, port, &ctx);
}
return;
}
PORT_LOCK(port, vm);
if (WRITER_NEED_2PASS(&ctx)) {
PORT_SAFE_CALL(port, write_ss(obj, port, &ctx),
cleanup_port_write_state(port));
} else {
PORT_SAFE_CALL(port, write_rec(obj, port, &ctx), /*no cleanup*/);
}
PORT_UNLOCK(port);
}
/*------------------------------------------------------------
* Vport Gets
*/
static int vport_getz(char *buf, int buflen, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->gets_proc)) {
u_int size;
const char *start;
ScmObj s = Scm_ApplyRec(data->gets_proc,
SCM_LIST1(SCM_MAKE_INT(buflen)));
if (!SCM_STRINGP(s)) return EOF;
start = Scm_GetStringContent(SCM_STRING(s), &size, NULL, NULL);
if ((int)size > buflen) {
/* NB: should raise an exception? */
memcpy(buf, start, buflen);
return buflen;
} else {
memcpy(buf, start, size);
return size;
}
} else {
int byte, i;
for (i=0; i<buflen; i++) {
byte = vport_getb(p);
if (byte == EOF) break;
buf[i] = byte;
}
if (i==0) return EOF;
else return i;
}
}
int Scm_Compare(ScmObj x, ScmObj y)
{
/* Shortcut for typical case */
if (SCM_NUMBERP(x) && SCM_NUMBERP(y))
return Scm_NumCmp(x, y);
if (SCM_STRINGP(x) && SCM_STRINGP(y))
return Scm_StringCmp(SCM_STRING(x), SCM_STRING(y));
if (SCM_CHARP(x) && SCM_CHARP(y))
return SCM_CHAR_VALUE(x) == SCM_CHAR_VALUE(y)? 0 :
SCM_CHAR_VALUE(x) < SCM_CHAR_VALUE(y)? -1 : 1;
ScmClass *cx = Scm_ClassOf(x);
ScmClass *cy = Scm_ClassOf(y);
if (Scm_SubtypeP(cx, cy)) {
if (cy->compare) return cy->compare(x, y, FALSE);
} else {
if (cx->compare) return cx->compare(x, y, FALSE);
}
Scm_Error("can't compare %S and %S", x, y);
return 0; /* dummy */
}
static const char *get_message_body(ScmObj msg, u_int *size)
{
if (SCM_UVECTORP(msg)) {
*size = Scm_UVectorSizeInBytes(SCM_UVECTOR(msg));
return (const char*)SCM_UVECTOR_ELEMENTS(msg);
} else if (SCM_STRINGP(msg)) {
return Scm_GetStringContent(SCM_STRING(msg), size, NULL, NULL);
} else {
Scm_TypeError("socket message", "uniform vector or string", msg);
*size = 0; /* dummy */
return NULL;
}
}
static const uint8_t* get_message_body(ScmObj msg, u_int *size)
{
if (SCM_UVECTORP(msg)) {
*size = Scm_UVectorSizeInBytes(SCM_UVECTOR(msg));
return (const uint8_t*) SCM_UVECTOR_ELEMENTS(msg);
} else if (SCM_STRINGP(msg)) {
return (const uint8_t*)Scm_GetStringContent(SCM_STRING(msg), size, 0, 0);
} else {
Scm_TypeError("TLS message", "uniform vector or string", msg);
*size = 0;
return 0;
}
}
/*
* FIXME: If we clean up at exit, removing the registered functions, we get
* rid of the 'Leaking string [Guile] with ref_count=1' warnings. The way we
* do this for other plugins, including Python, we deactivate the
* plugin. However, it is not possible to finalize Guile.
*/
static SCM
scm_register_function (SCM scm_name, SCM scm_args, SCM scm_help, SCM scm_category, SCM scm_function)
{
GnmFunc *fndef;
GnmFuncGroup *cat;
GnmFuncDescriptor desc;
char *help;
SCM_ASSERT (SCM_NIMP (scm_name) && SCM_STRINGP (scm_name), scm_name, SCM_ARG1, "scm_register_function");
SCM_ASSERT (SCM_NIMP (scm_args) && SCM_STRINGP (scm_args), scm_args, SCM_ARG2, "scm_register_function");
SCM_ASSERT (SCM_NIMP (scm_help) && SCM_STRINGP (scm_help), scm_help, SCM_ARG3, "scm_register_function");
SCM_ASSERT (SCM_NIMP (scm_category) && SCM_STRINGP (scm_category),
scm_category, SCM_ARG4, "scm_register_function");
SCM_ASSERT (scm_procedure_p (scm_function), scm_function, SCM_ARG5, "scm_register_function");
scm_permanent_object (scm_function);
desc.name = g_strdup (SCM_CHARS (scm_name));
desc.arg_spec = g_strdup (SCM_CHARS (scm_args));
desc.arg_names = NULL;
help = g_strdup (SCM_CHARS (scm_help));
desc.help = &help;
desc.fn_args = func_marshal_func;
desc.fn_nodes = NULL;
desc.linker = NULL;
desc.unlinker = NULL;
desc.flags = 0;
desc.ref_notify = NULL;
desc.impl_status = GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC;
desc.test_status = GNM_FUNC_TEST_STATUS_UNKNOWN;
cat = gnm_func_group_fetch (SCM_CHARS (scm_category), NULL);
fndef = gnm_func_add (cat, &desc, NULL);
gnm_func_set_user_data (fndef, GINT_TO_POINTER (scm_function));
return SCM_UNSPECIFIED;
}
SCM
scm_oldfmt (SCM s)
{
#ifdef HAVE_SCM_SIMPLE_FORMAT
return s;
#else
int n;
SCM_ASSERT (SCM_NIMP (s) && SCM_STRINGP (s), s, 1, s_oldfmt);
n = SCM_LENGTH (s);
return scm_return_first (scm_mem2string (scm_c_oldfmt (SCM_ROCHARS (s), n),
n),
s);
#endif
}
/* Auxiliary function */
const char* Scm_GetCESName(ScmObj code, const char *argname)
{
const char *c = NULL;
if (SCM_UNBOUNDP(code) || SCM_FALSEP(code)) {
c = Scm_SupportedCharacterEncodings()[0];
} else if (SCM_STRINGP(code)) {
c = Scm_GetStringConst(SCM_STRING(code));
} else if (SCM_SYMBOLP(code)) {
c = Scm_GetStringConst(SCM_SYMBOL_NAME(code));
} else {
Scm_Error("string, symbol or #f is required for %s, but got %S",
argname, code);
}
return c;
}
SCM
python_import(SCM smodulename)
{
if (!SCM_STRINGP(smodulename)) {
scm_wrong_type_arg("python-import",SCM_ARG1,smodulename);
}
else {
char *mname = scm_to_locale_string(smodulename);
PyObject *pmodule = PyImport_ImportModule(mname);
PyObject *pexception = PyErr_Occurred();
if (pexception) {
PyObject *prepr = PyObject_Repr(pexception);
Py_XDECREF(pmodule);
PyErr_Clear();
SCM smname = scm_list_1(scm_mem2string(mname,strlen(mname)));
free(mname);
if (NULL == prepr) {
scm_misc_error("python-import", // NOT COVERED BY TESTS
"Python exception during module ~A import - could not be identified",
smname);
}
else {
int strlength = PyString_Size(prepr);
char *pstr = PyString_AsString(prepr);
SCM slist = scm_list_2(SCM_CAR(smname),scm_mem2string(pstr,strlength));
Py_DECREF(prepr);
scm_misc_error("python-import",
"Python exception during module ~A import: ~A",
slist);
}
}
// OK, exception did not occur. Do we have a module?
if (NULL == pmodule) {
SCM slist = scm_list_1(scm_mem2string(mname,strlen(mname)));
free(mname);
scm_misc_error("python-eval","could not import module ~S",
slist);
}
free(mname);
SCM smodule = wrap_pyobject(pmodule);
Py_DECREF(pmodule); // wrap_pyobject did Py_INCREF
return(smodule);
}
}
/*
* Scm_WriteWithControls - the general entry
*/
void Scm_WriteWithControls(ScmObj obj, ScmObj p, int mode,
const ScmWriteControls *ctrl)
{
if (!SCM_OPORTP(p)) Scm_Error("output port required, but got %S", p);
ScmPort *port = SCM_PORT(p);
ScmVM *vm = Scm_VM();
if (ctrl == NULL) ctrl = Scm_DefaultWriteControls();
if (PORT_LOCK_OWNER_P(port, vm) && PORT_RECURSIVE_P(port)) {
/* We're in the recursive call, so we just recurse into write_walk
or write_rec, according to the phase. NB: The controls passed
into the argument CTRL is ignored; the "root" control, passed
to the toplevel write API, will be used. */
if (PORT_WALKER_P(port)) {
/* Special treatment - if we're "display"-ing a string, we'll
bypass walk path even if we're in the middle of write/ss.
Using srfi-38 notation to show displayed strings doesn't
make sense at all. */
if (!((mode == SCM_WRITE_DISPLAY) && SCM_STRINGP(obj))) {
write_walk(obj, port);
}
} else {
ScmWriteContext ctx;
write_context_init(&ctx, mode, 0, 0);
write_rec(obj, port, &ctx);
}
} else {
/* We're in the toplevel call.*/
ScmWriteContext ctx;
write_context_init(&ctx, mode, 0, 0);
PORT_LOCK(port, vm);
if (WRITER_NEED_2PASS(&ctx)) {
ctx.controls = ctrl;
PORT_SAFE_CALL(port, write_ss(obj, port, &ctx),
cleanup_port_write_state(port));
} else {
/* write-simple case. CTRL is ignored. */
PORT_SAFE_CALL(port, write_rec(obj, port, &ctx), /*no cleanup*/);
}
PORT_UNLOCK(port);
}
}
/* General hash function */
u_long Scm_Hash(ScmObj obj)
{
u_long hashval;
if (!SCM_PTRP(obj)) {
SMALL_INT_HASH(hashval, (u_long)SCM_WORD(obj));
return hashval;
} else if (SCM_NUMBERP(obj)) {
return Scm_EqvHash(obj);
} else if (SCM_STRINGP(obj)) {
goto string_hash;
} else if (SCM_PAIRP(obj)) {
u_long h = 0, h2;
ScmObj cp;
SCM_FOR_EACH(cp, obj) {
h2 = Scm_Hash(SCM_CAR(cp));
h = COMBINE(h, h2);
}
h2 = Scm_Hash(cp);
h = COMBINE(h, h2);
return h;
} else if (SCM_VECTORP(obj)) {
int Scm_EqualP(ScmObj x, ScmObj y)
{
ScmClass *cx, *cy;
if (SCM_EQ(x, y)) return TRUE;
if (SCM_PAIRP(x)) {
if (!SCM_PAIRP(y)) return FALSE;
do {
if (!Scm_EqualP(SCM_CAR(x), SCM_CAR(y))) return FALSE;
x = SCM_CDR(x);
y = SCM_CDR(y);
} while (SCM_PAIRP(x)&&SCM_PAIRP(y));
return Scm_EqualP(x, y);
}
if (SCM_STRINGP(x)) {
if (SCM_STRINGP(y)) {
return Scm_StringEqual(SCM_STRING(x), SCM_STRING(y));
}
return FALSE;
}
if (SCM_NUMBERP(x)) {
if (SCM_NUMBERP(y)) {
if ((SCM_EXACTP(x) && SCM_EXACTP(y))
|| (SCM_INEXACTP(x) && SCM_INEXACTP(y))) {
return Scm_NumEq(x, y);
}
}
return FALSE;
}
if (SCM_VECTORP(x)) {
if (SCM_VECTORP(y)) {
int sizx = SCM_VECTOR_SIZE(x);
int sizy = SCM_VECTOR_SIZE(y);
if (sizx == sizy) {
while (sizx--) {
if (!Scm_EqualP(SCM_VECTOR_ELEMENT(x, sizx),
SCM_VECTOR_ELEMENT(y, sizx)))
break;
}
if (sizx < 0) return TRUE;
}
}
return FALSE;
}
/* EXPERIMENTAL: when identifier is compared by equal?,
we use its symbolic name to compare. This allows
comparing macro output with equal?, and also less confusing
when R5RS macro and legacy macro are mixed.
For "proper" comparison of identifiers keeping their semantics,
we need such procedures as free-identifier=? and bound-identifier=?
anyway, so this change of equal? won't have a negative impact, I hope.
NB: this operation come here instead of the beginning of this
procedure, since comparing identifiers are relatively rare so
we don't want to check idnetifier-ness every time.
*/
if (SCM_IDENTIFIERP(x) || SCM_IDENTIFIERP(y)) {
if (SCM_IDENTIFIERP(x)) x = SCM_OBJ(SCM_IDENTIFIER(x)->name);
if (SCM_IDENTIFIERP(y)) y = SCM_OBJ(SCM_IDENTIFIER(y)->name);
return SCM_EQ(x, y);
}
/* End of EXPERIMENTAL code */
if (!SCM_HPTRP(x)) return (x == y);
cx = Scm_ClassOf(x);
cy = Scm_ClassOf(y);
if (cx == cy && cx->compare) {
return (cx->compare(x, y, TRUE) == 0);
}
return FALSE;
}
int Scm_Compare(ScmObj x, ScmObj y)
{
/* Shortcut for typical case */
if (SCM_NUMBERP(x) && SCM_NUMBERP(y)) {
if (SCM_COMPNUMP(x) || SCM_COMPNUMP(y)) {
/* Scm_NumCmp can't compare complex numbers---it doesn't make
mathematical sense. But Scm_Compare is used just to order
items, it doesn't need to carry meaning. So here it goes.
We follow srfi-114 spec. */
/* TODO: If we ever introduce exact compnums, we should use
exact number first to compare, for Scm_GetDouble may lose
precision. */
/* TODO: Handle NaN. */
double xr = Scm_RealPart(x);
double yr = Scm_RealPart(y);
if (xr < yr) return -1;
if (xr > yr) return 1;
double xi = Scm_ImagPart(x);
double yi = Scm_ImagPart(y);
if (xi < yi) return -1;
if (xi > yi) return 1;
return 0;
} else {
return Scm_NumCmp(x, y);
}
}
if (SCM_STRINGP(x) && SCM_STRINGP(y))
return Scm_StringCmp(SCM_STRING(x), SCM_STRING(y));
if (SCM_CHARP(x) && SCM_CHARP(y))
return SCM_CHAR_VALUE(x) == SCM_CHAR_VALUE(y)? 0 :
SCM_CHAR_VALUE(x) < SCM_CHAR_VALUE(y)? -1 : 1;
/* Set cx, cy here, for we may jump to distinct_types later. */
ScmClass *cx = Scm_ClassOf(x);
ScmClass *cy = Scm_ClassOf(y);
/* srfi-114 default comparator behaviors*/
/* () is the smallest of all */
if (SCM_NULLP(x)) return (SCM_NULLP(y)? 0 : -1);
if (SCM_NULLP(y)) return (SCM_NULLP(x)? 0 : 1);
if (SCM_PAIRP(x)) {
if (SCM_PAIRP(y)) {
ScmObj px = x;
ScmObj py = y;
while (SCM_PAIRP(px) && SCM_PAIRP(py)) {
int r = Scm_Compare(SCM_CAR(px), SCM_CAR(py));
if (r != 0) return r;
px = SCM_CDR(px);
py = SCM_CDR(py);
}
return Scm_Compare(px, py);
}
goto distinct_types;
}
if (SCM_FALSEP(x)) {
if (SCM_FALSEP(y)) return 0;
if (SCM_TRUEP(y)) return -1;
goto distinct_types;
}
if (SCM_TRUEP(x)) {
if (SCM_FALSEP(y)) return 1;
if (SCM_TRUEP(y)) return 0;
goto distinct_types;
}
if (Scm_SubtypeP(cx, cy)) {
if (cy->compare) return cy->compare(x, y, FALSE);
} else if (Scm_SubtypeP(cy, cx)) {
if (cx->compare) return cx->compare(x, y, FALSE);
}
if (cx == cy) {
/* x and y are of the same type, and they can't be ordered. */
Scm_Error("can't compare %S and %S", x, y);
}
distinct_types:
/* x and y are of distinct types. Follow the srfi-114 rule:
() < pairs < booleans < chars < strings < symbols < numbers
< vectors < bytevectors < others
Note that we already eliminated NULL.
*/
#define ELIMINATE(pred) \
do { \
if pred(x) return -1; \
if pred(y) return 1; \
} while (0)
ELIMINATE(SCM_PAIRP);
ELIMINATE(SCM_BOOLP);
ELIMINATE(SCM_CHARP);
ELIMINATE(SCM_STRINGP);
ELIMINATE(SCM_SYMBOLP);
ELIMINATE(SCM_NUMBERP);
ELIMINATE(SCM_VECTORP);
/* To conform srfi-114, we must order u8vector first. For the
consistency, we use this order:
u8 < s8 < u16 < s16 < u32 < s32 < u64 < s64 < f16 < f32 < f64
Unfortunately this doesn't match the order of ScmUVectorType,
so we need some tweak.
*/
if (SCM_UVECTORP(x)) {
if (SCM_UVECTORP(y)) {
int tx = Scm_UVectorType(Scm_ClassOf(x));
int ty = Scm_UVectorType(Scm_ClassOf(y));
if (tx/2 < ty/2) return -1;
if (tx/2 > ty/2) return 1;
if (tx < SCM_UVECTOR_F16) {
/* x and y are either sNvector and uNvector with the same N.
The odd one is uNvector.
*/
return (tx%2)? -1:1;
} else {
return (tx<ty)? -1:1;
}
}
return -1; /* y is other, so x comes first. */
} else if (SCM_UVECTORP(y)) {
return 1; /* x is other, so y comes first. */
}
/* Now we have two objects of different types, both are not the
types defined the order in srfi-114.
To achieve better stability, we first compare the name of the
classes and the names of their defining modules; if they are still
the same, we fall back to compare addresses.
Note: Addresses and defining modules may be changed when
the class is redefined.
*/
ScmObj nx = cx->name;
ScmObj ny = cy->name;
int nr = Scm_Compare(nx, ny);
if (nr != 0) return nr;
ScmObj mx = cx->modules;
ScmObj my = cy->modules;
while (SCM_PAIRP(mx) && SCM_PAIRP(my)) {
SCM_ASSERT(SCM_MODULEP(SCM_CAR(mx)) && SCM_MODULEP(SCM_CAR(my)));
int r = Scm_Compare(SCM_MODULE(SCM_CAR(mx))->name,
SCM_MODULE(SCM_CAR(my))->name);
if (r != 0) return r;
mx = SCM_CDR(mx);
my = SCM_CDR(my);
}
if (SCM_PAIRP(mx)) return -1;
if (SCM_PAIRP(my)) return 1;
if (cx < cy) return -1;
else return 1;
}
SCM
python_eval(SCM sobj,SCM smode)
{
if (!SCM_STRINGP(sobj)) {
scm_wrong_type_arg("python-eval",SCM_ARG1,sobj);
}
int start = (SCM_UNBNDP(smode)) || (SCM_EQ_P(SCM_BOOL_F,smode))
? Py_file_input
: Py_eval_input;
char *pstr = scm_to_locale_string(sobj);
if (NULL == pstr) {
scm_memory_error("python-eval"); // NOT COVERED BY TESTS
//return(SCM_UNSPECIFIED);
}
PyObject *pmaindict =
PyModule_GetDict(PyImport_AddModule("__main__"));
if (NULL == pmaindict) {
scm_misc_error("python-eval","could not get __main__ for (~S), mode ~A", // NOT COVERED BY TESTS
scm_list_2(sobj,smode));
}
Py_INCREF(pmaindict);
PyObject *pres = PyRun_String(pstr, start, pmaindict, pmaindict);
Py_DECREF(pmaindict);
free(pstr);
PyObject *pexception = PyErr_Occurred();
if (pexception) {
PyObject *prepr = PyObject_Repr(pexception);
Py_XDECREF(pres);
PyErr_Clear();
if (NULL == prepr) {
scm_misc_error("python-eval", // NOT COVERED BY TESTS
"python exception - could not be identified",
SCM_UNSPECIFIED);
}
else {
int strlength = PyString_Size(prepr);
char *pstr = PyString_AsString(prepr);
SCM slist = scm_list_1(scm_mem2string(pstr,strlength));
Py_DECREF(prepr);
scm_misc_error("python-eval","Python exception: ~A",
slist);
}
}
switch(start) {
case Py_eval_input:
{
if (NULL != pres) {
SCM sres = p2g_apply(pres,
SCM_EQ_P(SCM_BOOL_T,smode)
? srestemplate_default : smode);
Py_DECREF(pres);
return(sres);
}
else {
scm_misc_error("python-eval","could not return result of evaluation",
SCM_UNSPECIFIED);
return(SCM_UNSPECIFIED);
}
}
case Py_file_input:
default:
{
Py_XDECREF(pres);
return(SCM_UNSPECIFIED);
}
}
}
/* Trick: The hashtable contains positive integer after the walk pass.
If we emit a reference tag N, we replace the entry's value to -N,
so that we can distinguish whether we've already emitted the object
or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
char numbuf[50]; /* enough to contain long number */
ScmObj stack = SCM_NIL;
ScmWriteState *st = port->writeState;
ScmHashTable *ht = (st? st->sharedTable : NULL);
int stack_depth = 0;
#define PUSH(elt) \
do { \
stack = Scm_Cons(elt, stack); \
if (!ht && ++stack_depth > STACK_LIMIT) { \
Scm_Error("write recursed too deeply; " \
"maybe a circular structure?"); \
} \
} while (0)
#define POP() \
do { \
stack = SCM_CDR(stack); \
if (ht) stack_depth--; \
} while (0)
for (;;) {
write1:
if (ctx->flags & WRITE_LIMITED) {
if (port->src.ostr.length >= ctx->limit) return;
}
/* number may be heap allocated, but we don't use srfi-38 notation. */
if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
}
goto next;
}
if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
|| (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
/* we don't put a reference tag for these */
write_general(obj, port, ctx);
goto next;
}
if (ht) {
ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
long k = SCM_INT_VALUE(e);
if (k <= 0) {
/* This object is already printed. */
snprintf(numbuf, 50, "#%ld#", -k);
Scm_PutzUnsafe(numbuf, -1, port);
goto next;
} else if (k > 1) {
/* This object will be seen again. Put a reference tag. */
ScmWriteState *s = port->writeState;
snprintf(numbuf, 50, "#%d=", s->sharedCounter);
Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
s->sharedCounter++;
Scm_PutzUnsafe(numbuf, -1, port);
}
}
/* Writes aggregates */
if (SCM_PAIRP(obj)) {
/* special case for quote etc.
NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
get infinite recursion for the case like (cdr '#1='#1#). */
if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
&& (!ht
|| SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
const char *prefix = NULL;
if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
prefix = "'";
} else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
prefix = "`";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
prefix = ",";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
prefix = ",@";
}
if (prefix) {
Scm_PutzUnsafe(prefix, -1, port);
obj = SCM_CADR(obj);
goto write1;
}
}
/* normal case */
Scm_PutcUnsafe('(', port);
PUSH(Scm_Cons(SCM_TRUE, SCM_CDR(obj)));
obj = SCM_CAR(obj);
goto write1;
} else if (SCM_VECTORP(obj)) {
Scm_PutzUnsafe("#(", -1, port);
PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
obj = SCM_VECTOR_ELEMENT(obj, 0);
goto write1;
} else {
/* string or user-defined object */
write_general(obj, port, ctx);
goto next;
}
next:
while (SCM_PAIRP(stack)) {
ScmObj top = SCM_CAR(stack);
SCM_ASSERT(SCM_PAIRP(top));
if (SCM_INTP(SCM_CAR(top))) {
/* we're processing a vector */
ScmObj v = SCM_CDR(top);
int i = SCM_INT_VALUE(SCM_CAR(top));
int len = SCM_VECTOR_SIZE(v);
if (i == len) { /* we've done this vector */
Scm_PutcUnsafe(')', port);
POP();
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_VECTOR_ELEMENT(v, i);
SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
goto write1;
}
} else {
/* we're processing a list */
ScmObj v = SCM_CDR(top);
if (SCM_NULLP(v)) { /* we've done with this list */
Scm_PutcUnsafe(')', port);
POP();
} else if (!SCM_PAIRP(v)) {
Scm_PutzUnsafe(" . ", -1, port);
obj = v;
SCM_SET_CDR(top, SCM_NIL);
goto write1;
} else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) {
/* cdr part is shared */
Scm_PutzUnsafe(" . ", -1, port);
obj = v;
SCM_SET_CDR(top, SCM_NIL);
goto write1;
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_CAR(v);
SCM_SET_CDR(top, SCM_CDR(v));
goto write1;
}
}
}
break;
}
#undef PUSH
#undef POP
}
/* Trick: The hashtable contains positive integer after the walk pass.
If we emit a reference tag N, we replace the entry's value to -N,
so that we can distinguish whether we've already emitted the object
or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
char numbuf[50]; /* enough to contain long number */
ScmObj stack = SCM_NIL;
ScmWriteState *st = port->writeState;
ScmHashTable *ht = (st? st->sharedTable : NULL);
const ScmWriteControls *wp = Scm_GetWriteControls(ctx, st);
int stack_depth = 0; /* only used when !ht */
#define PUSH(elt) \
do { \
stack = Scm_Cons(elt, stack); \
if (!ht && ++stack_depth > STACK_LIMIT) { \
Scm_Error("write recursed too deeply; " \
"maybe a circular structure?"); \
} \
} while (0)
#define POP() \
do { \
stack = SCM_CDR(stack); \
if (!ht) stack_depth--; \
} while (0)
#define CHECK_LEVEL() \
do { \
if (st) { \
if (wp->printLevel >= 0 && st->currentLevel >= wp->printLevel) { \
Scm_PutcUnsafe('#', port); \
goto next; \
} else { \
if (st) st->currentLevel++; \
} \
} \
} while (0)
for (;;) {
write1:
if (ctx->flags & WRITE_LIMITED) {
if (port->src.ostr.length >= ctx->limit) return;
}
/* number may be heap allocated, but we don't use srfi-38 notation. */
if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
}
goto next;
}
if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
|| (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
/* we don't put a reference tag for these */
write_general(obj, port, ctx);
goto next;
}
/* obj is heap allocated and we may use label notation. */
if (ht) {
ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
long k = SCM_INT_VALUE(e);
if (k <= 0) {
/* This object is already printed. */
snprintf(numbuf, 50, "#%ld#", -k);
Scm_PutzUnsafe(numbuf, -1, port);
goto next;
} else if (k > 1) {
/* This object will be seen again. Put a reference tag. */
ScmWriteState *s = port->writeState;
snprintf(numbuf, 50, "#%d=", s->sharedCounter);
Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
s->sharedCounter++;
Scm_PutzUnsafe(numbuf, -1, port);
}
}
/* Writes aggregates */
if (SCM_PAIRP(obj)) {
CHECK_LEVEL();
/* special case for quote etc.
NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
get infinite recursion for the case like (cdr '#1='#1#). */
if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
&& (!ht
|| SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
const char *prefix = NULL;
if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
prefix = "'";
} else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
prefix = "`";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
prefix = ",";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
prefix = ",@";
}
if (prefix) {
Scm_PutzUnsafe(prefix, -1, port);
obj = SCM_CADR(obj);
goto write1;
}
}
if (wp->printLength == 0) {
/* in this case we don't print the elements at all, so we need
to treat this specially. */
Scm_PutzUnsafe("(...)", -1, port);
if (st) st->currentLevel--;
goto next;
}
/* normal case */
Scm_PutcUnsafe('(', port);
PUSH(Scm_Cons(SCM_TRUE, Scm_Cons(SCM_MAKE_INT(1), SCM_CDR(obj))));
obj = SCM_CAR(obj);
goto write1;
} else if (SCM_VECTORP(obj)) {
CHECK_LEVEL();
if (wp->printLength == 0) {
/* in this case we don't print the elements at all, so we need
to treat this specially. */
Scm_PutzUnsafe("#(...)", -1, port);
if (st) st->currentLevel--;
goto next;
}
Scm_PutzUnsafe("#(", -1, port);
PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
obj = SCM_VECTOR_ELEMENT(obj, 0);
goto write1;
} else if (Scm_ClassOf(obj)->flags & SCM_CLASS_AGGREGATE) {
CHECK_LEVEL();
write_general(obj, port, ctx);
if (st) st->currentLevel--;
goto next;
} else {
write_general(obj, port, ctx);
goto next;
}
next:
while (SCM_PAIRP(stack)) {
ScmObj top = SCM_CAR(stack);
SCM_ASSERT(SCM_PAIRP(top));
if (SCM_INTP(SCM_CAR(top))) {
/* we're processing a vector */
ScmObj v = SCM_CDR(top);
int i = SCM_INT_VALUE(SCM_CAR(top));
int len = SCM_VECTOR_SIZE(v);
if (i == len) { /* we've done this vector */
Scm_PutcUnsafe(')', port);
POP();
} else if (wp->printLength >= 0 && wp->printLength <= i) {
Scm_PutzUnsafe(" ...)", -1, port);
POP();
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_VECTOR_ELEMENT(v, i);
SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
goto write1;
}
} else {
/* we're processing a list */
SCM_ASSERT(SCM_PAIRP(SCM_CDR(top)));
long count = SCM_INT_VALUE(SCM_CADR(top));
ScmObj v = SCM_CDDR(top);
if (SCM_NULLP(v)) { /* we've done with this list */
Scm_PutcUnsafe(')', port);
POP();
} else if (!SCM_PAIRP(v)) {
/* Improper list. We treat aggregate types specially,
since such object at this position shouldn't increment
"level" - its content is regarded as the same level of
the current list.
*/
Scm_PutzUnsafe(" . ", -1, port);
if (Scm_ClassOf(v)->flags & SCM_CLASS_AGGREGATE) {
if (st) st->currentLevel--;
write_rec(v, port, ctx);
if (st) st->currentLevel++;
Scm_PutcUnsafe(')', port);
POP();
} else {
obj = v;
SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
goto write1;
}
} else if (wp->printLength >= 0 && wp->printLength <= count) {
/* print-length limit reached */
Scm_PutzUnsafe(" ...)", -1, port);
POP();
} else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) {
/* cdr part is shared */
Scm_PutzUnsafe(" . ", -1, port);
obj = v;
SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
goto write1;
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_CAR(v);
SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
SCM_SET_CDR(SCM_CDR(top), SCM_CDR(v));
goto write1;
}
}
if (st) st->currentLevel--;
}
break;
}
#undef PUSH
#undef POP
#undef CHECK_DEPTH
}
