static PyObject *
pyscm_PySCM_call(pyscm_PySCMObject *self, PyObject *args, PyObject *kwargs)
{
/* Return the result of calling self with argument args */
SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(self->ob_scm_index));
if (SCM_BOOLP(shandle) && SCM_EQ_P(SCM_BOOL_F,shandle)) {
Py_FatalError("PySCM object lost its associated SCM object"); // NOT COVERED BY TESTS
}
// Now:
// SCM_CADR(shandle) is the SCM object itself
// SCM_CDDR(shandle) is the stemplate.
if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_call: calling ~S with args=~S and keywords=~S; stemplate=~S\n"),scm_list_4(SCM_CADR(shandle),verbosity_repr(args),verbosity_repr(kwargs),SCM_CDDR(shandle)));
}
SCM sapply_func = GET_APPLY_FUNC(SCM_CDDR(shandle));
if (SCM_EQ_P(SCM_EOL,sapply_func)) {
if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_call: raising exceptions.TypeError due to \"PySCM wraps a non-callable SCM\"\n"),SCM_EOL);
}
PyErr_SetString(PyExc_TypeError, "PySCM wraps a non-callable SCM");
return(NULL);
}
// Process arguments.
SCM sargs_template = GET_P2G_POSITIONAL_ARGS_TEMPLATE(SCM_CDDR(shandle));
SCM skwargs_template = GET_P2G_KEYWORD_ARGS_TEMPLATE(SCM_CDDR(shandle));
/*if (logical_xor(SCM_EQ_P(SCM_EOL,sargs_template),(NULL==args))
|| logical_xor(SCM_EQ_P(SCM_EOL,skwargs_template),(NULL==kwargs)))*/
// The following allows template to exist without actual arguments.
if ((SCM_EQ_P(SCM_EOL,sargs_template) && (NULL != args))
|| (SCM_EQ_P(SCM_EOL,skwargs_template) && (NULL != kwargs))) {
if (pyguile_verbosity_test(PYGUILE_VERBOSE_PYSCM)) {
scm_simple_format(scm_current_output_port(),scm_makfrom0str("# pyscm_PySCM_call: raising exceptions.TypeError due to \"wrapped SCM does not take some of the provided arguments\"\n"),SCM_EOL);
}
PyErr_SetString(PyExc_TypeError, "wrapped SCM does not take some of the provided arguments");
return(NULL);
}
SCM sargs = SCM_EQ_P(SCM_EOL,sargs_template) || (NULL == args)
? SCM_EOL : p2g_apply(args,sargs_template);
SCM skwargs = SCM_EQ_P(SCM_EOL,skwargs_template) || (NULL == kwargs)
? SCM_EOL : p2g_apply(kwargs,skwargs_template);
SCM sresult = scm_apply(sapply_func,scm_list_2(SCM_CADR(shandle),scm_list_2(sargs,skwargs)),SCM_EOL);
SCM sresult_template = GET_G2P_RESULT_TEMPLATE(SCM_CDDR(shandle));
if (SCM_EQ_P(SCM_EOL,sresult_template)) {
Py_RETURN_NONE;
}
else {
return(g2p_apply(sresult,sresult_template));
}
}
static ScmObj message_args_get(ScmMessageCondition *obj)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
return SCM_CDDR(msglist);
} else {
return SCM_NIL;
}
}
// Common code for pyscm_PySCM_getattr() and pyscm_PySCM_setattr():
// Retrieve and return the 4-element vector corresponding to desired
// attribute of the pyscm_PySCMObject.
// Perform also validity checking and raise Python exception if
// invalid.
// Since it is needed later, also the SCM object, corresponding to the
// pyscm_PySCMObject, is returned to the caller, put into 2-element
// list together with the #:-keyword corresponding to name.
static SCM
retrieve_sattr_vector(pyscm_PySCMObject *self, char *name, SCM *sobj_keyword)
{
SCM shandle = scm_hashv_get_handle(pyscm_registration_hash,scm_long2num(self->ob_scm_index));
if (SCM_BOOLP(shandle) && SCM_EQ_P(SCM_BOOL_F,shandle)) {
Py_FatalError("PySCM object lost its associated SCM object");
}
// Now:
// SCM_CADR(shandle) is the SCM object itself
// SCM_CDDR(shandle) is the stemplate.
SCM sattrshash = GET_ATTRS_HASH(SCM_CDDR(shandle));
if (SCM_EQ_P(SCM_BOOL_F,sattrshash)) {
PyErr_SetString(PyExc_AttributeError, name);
return(SCM_UNDEFINED); // Error return
}
// The object has attributes. Build the hash key (a keyword).
size_t nlength = strlen(name);
char *dashstr = malloc(nlength+2);
dashstr[0] = '-';
dashstr[1] = '\0';
strncat(dashstr,name,nlength);
SCM skeyword = scm_make_keyword_from_dash_symbol(scm_str2symbol(dashstr));
// !!! Do we have to free dashstr?
// !!! Similar code is used also in pytoguile.c - review it.
SCM sattr_vector_handle = scm_hashv_get_handle(sattrshash,skeyword);
if (SCM_EQ_P(SCM_BOOL_F,sattr_vector_handle)) {
// Missing attribute. How to deal with it?
sattr_vector_handle = scm_hashv_get_handle(sattrshash,SCM_BOOL_F);
if (SCM_EQ_P(SCM_BOOL_F,sattr_vector_handle)) {
// Hash value corresponding to key #f is itself another #f, which
// means that the object does not wish to exhibit to Python
// unknown attributes.
PyErr_SetString(PyExc_AttributeError, name);
return(SCM_UNDEFINED); // Error return
}
// Otherwise, we'll use the hash value corresponding to #f as
// a catch-all for all attributes not otherwise defined.
}
*sobj_keyword = scm_list_2(SCM_CADR(shandle),skeyword);
return(SCM_CDR(sattr_vector_handle));
}
inline tmscm tmscm_cddr (tmscm obj) { return SCM_CDDR (obj); }
/* 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
}
