static void
move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
SCM key, SCM value, scm_t_weak_table_kind kind)
{
if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
&& SCM_HEAP_OBJECT_P (key))
{
#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
#else
GC_unregister_disappearing_link (&from->key);
SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (key));
#endif
}
if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
&& SCM_HEAP_OBJECT_P (value))
{
#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
#else
GC_unregister_disappearing_link (&from->value);
SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value));
#endif
}
}
static SCM
sys_add_finalizer_x (SCM obj, SCM finalizer)
#define FUNC_NAME "%add-finalizer!"
{
SCM_VALIDATE_PROC (SCM_ARG2, finalizer);
scm_i_add_finalizer (SCM2PTR (obj), invoke_finalizer, SCM2PTR (finalizer));
return SCM_UNSPECIFIED;
}
LONGEST
scm_get_field (LONGEST svalue, int index)
{
char buffer[20];
read_memory (SCM2PTR (svalue) + index * TYPE_LENGTH (builtin_type_scm),
buffer, TYPE_LENGTH (builtin_type_scm));
return extract_signed_integer (buffer, TYPE_LENGTH (builtin_type_scm));
}
static void
register_disappearing_links (scm_t_weak_entry *entry,
SCM k, SCM v,
scm_t_weak_table_kind kind)
{
if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
&& (kind == SCM_WEAK_TABLE_KIND_KEY
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
(GC_PTR) SCM2PTR (k));
if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
&& (kind == SCM_WEAK_TABLE_KIND_VALUE
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value,
(GC_PTR) SCM2PTR (v));
}
/* Create a new plotter whose output and error are Guile ports */
SCM
gupl_newpl (SCM type, SCM outp, SCM errp, SCM param)
{
char *c_type;
FILE *c_outp, *c_errp;
plPlotter *ret;
plPlotterParams *c_param;
SCM_ASSERT (scm_is_string (type), type, SCM_ARG1, "newpl");
SCM_ASSERT (scm_is_true (scm_output_port_p (outp)), outp, SCM_ARG2,
"newpl");
SCM_ASSERT (scm_is_true (scm_output_port_p (errp)), errp, SCM_ARG3, "newpl");
SCM_ASSERT (_scm_is_plparams (param), param, SCM_ARG4, "newpl");
/* Convert the output port to a special stream */
c_outp = fopencookie (SCM2PTR (outp), "wb", port_funcs);
/* Don't buffer port here, since the underlying Guile port also has
port buffering. Double buffering causes problems. */
setvbuf (c_outp, NULL, _IONBF, 0);
if (c_outp == NULL)
scm_syserror ("newpl");
/* Convert the err port to a special stream */
c_errp = fopencookie (SCM2PTR (errp), "wb", port_funcs);
if (c_errp == NULL)
scm_out_of_range ("newpl", errp);
setvbuf (c_errp, NULL, _IONBF, 0);
c_type = scm_to_locale_string (type);
c_param = _scm_to_plparams (param);
ret = pl_newpl_r (c_type, NULL, c_outp, c_errp, c_param);
free (c_type);
if (ret == NULL)
return SCM_BOOL_F;
return _scm_from_plotter (ret);
}
static struct GC_ms_entry *
mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit, GC_word env)
{
scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
for (k = 0; k < size; k++)
if (entries[k].hash && entries[k].value)
{
SCM key = SCM_PACK (entries[k].key);
mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key),
mark_stack_ptr, mark_stack_limit,
NULL);
}
return mark_stack_ptr;
}
SCM DLL_PUBLIC
cl_easy_setopt (SCM handle, SCM option, SCM param, SCM big)
{
handle_post_t *c_handle;
CURLoption c_option;
CURLcode code = CURLE_UNSUPPORTED_PROTOCOL;
SCM_ASSERT (_scm_is_handle (handle), handle, SCM_ARG1, "curl-easy-setopt");
SCM_ASSERT (scm_is_integer (option), option, SCM_ARG2, "curl-easy-setopt");
c_handle = _scm_to_handle (handle);
c_option = (CURLoption) scm_to_int (option);
if (c_option == CURLOPT_POSTFIELDS)
{
if (_scm_can_convert_to_byte_data (param))
{
size_t len;
uint8_t *m = _scm_convert_to_byte_data (param, &len);
free (c_handle->postfields);
c_handle->postfields = m;
curl_easy_setopt (c_handle->handle, CURLOPT_POSTFIELDSIZE, len);
c_handle->postfieldsize = len;
code = curl_easy_setopt (c_handle->handle, CURLOPT_POSTFIELDS, (char *) m);
}
else
scm_error (SCM_BOOL_F, "cl-easy-setopt", "CURLOPT_POSTFIELDS requires 8-bit string or bytevector data",
SCM_BOOL_F, SCM_BOOL_F);
}
else if (c_option == CURLOPT_HTTPHEADER)
{
if (_scm_can_convert_to_slist (param))
{
/* slists require special handling to free them properly, so
they are stored with the Curl handle. */
struct curl_slist *sl = _scm_convert_to_slist (param);
if (c_handle->httpheader)
curl_slist_free_all (c_handle->httpheader);
c_handle->httpheader = sl;
code = curl_easy_setopt (c_handle->handle, CURLOPT_HTTPHEADER, sl);
}
else
scm_error (SCM_BOOL_F, "cl-easy-setopt", "CURLOPT_HTTPHEADER requires a list of strings",
SCM_BOOL_F, SCM_BOOL_F);
}
else if (scm_is_integer (param))
{
if (scm_is_true (big))
code = curl_easy_setopt (c_handle->handle, c_option, scm_to_int64 (param));
else
code = curl_easy_setopt (c_handle->handle, c_option, scm_to_long (param));
}
else if (scm_is_string (param))
{
/* Strings are copied by curl, so they can be freed here. */
char *str;
str = scm_to_locale_string (param);
code = curl_easy_setopt (c_handle->handle, c_option, str);
free (str);
}
else if (_scm_can_convert_to_slist (param))
{
/* slists require special handling to free them properly, so
they are stored with the Curl handle. */
struct curl_slist *sl = _scm_convert_to_slist (param);
int ok = 1;
if (c_option == CURLOPT_HTTP200ALIASES)
{
if (c_handle->http200aliases)
curl_slist_free_all (c_handle->http200aliases);
c_handle->http200aliases = sl;
}
else if (c_option == CURLOPT_MAIL_RCPT)
{
if (c_handle->mail_rcpt)
curl_slist_free_all (c_handle->mail_rcpt);
c_handle->mail_rcpt = sl;
}
else if (c_option == CURLOPT_QUOTE)
{
if (c_handle->quote)
curl_slist_free_all (c_handle->quote);
c_handle->quote = sl;
}
else if (c_option == CURLOPT_POSTQUOTE)
{
if (c_handle->postquote)
curl_slist_free_all (c_handle->postquote);
c_handle->postquote = sl;
}
else if (c_option == CURLOPT_PREQUOTE)
{
if (c_handle->prequote)
curl_slist_free_all (c_handle->prequote);
c_handle->prequote = sl;
}
else if (c_option == CURLOPT_RESOLVE)
{
if (c_handle->resolve)
curl_slist_free_all (c_handle->resolve);
c_handle->resolve = sl;
}
else if (c_option == CURLOPT_TELNETOPTIONS)
{
if (c_handle->telnetoptions)
curl_slist_free_all (c_handle->telnetoptions);
c_handle->telnetoptions = sl;
}
else
{
// Bad slist option
ok = 0;
}
if (ok)
code = curl_easy_setopt (c_handle->handle, c_option, sl);
}
else if (_scm_can_convert_to_httppost (param))
{
if (c_option == CURLOPT_HTTPPOST)
{
struct curl_httppost *p;
p = _scm_convert_to_httppost (param);
free (c_handle->httppost);
c_handle->httppost = p;
code = curl_easy_setopt (c_handle, CURLOPT_HTTPPOST, p);
}
}
else if (scm_is_true (scm_input_port_p (param)))
{
if (c_option == CURLOPT_READDATA)
{
curl_easy_setopt (c_handle->handle, CURLOPT_READFUNCTION, read_callback);
code = curl_easy_setopt (c_handle->handle, CURLOPT_READDATA, SCM2PTR (param));
}
}
else
scm_error (SCM_BOOL_F,
"curl-easy-setopt",
"unimplemented option type",
SCM_BOOL_F,
SCM_BOOL_F);
if (code != CURLE_OK)
scm_error (SCM_BOOL_F,
"curl-easy-setopt",
"bad handle",
SCM_BOOL_F,
SCM_BOOL_F);
return SCM_UNSPECIFIED;
}
