/* an error throwing seq impl */
static size_t
seq_unsupp_length(const seq_t s)
{
Lisp_Object sequence = (Lisp_Object)(long int)s;
check_losing_bytecode("length", sequence);
sequence = wrong_type_argument(Qsequencep, sequence);
return 0UL;
}
static ad_device_data *
sound_ao_create(Lisp_Object ao_options)
{
int driver;
ao_device *device;
ao_option *options;
ao_sample_format *fmt;
/* result */
sound_ao_data_t *aod;
/* option keywords */
Lisp_Object opt_driver;
char *optext_driver = NULL;
/* parse options */
opt_driver = Fplist_get(ao_options, intern(":driver"), Qnil);
if (!NILP(opt_driver) && !STRINGP(opt_driver)) {
wrong_type_argument(Qstringp, opt_driver);
return NULL;
} else if (STRINGP(opt_driver))
optext_driver = (char*)XSTRING_DATA(opt_driver);
/* -- initialise -- */
ao_initialize();
fmt = xmalloc(sizeof(ao_sample_format));
/* -- Setup for driver -- */
if (optext_driver != NULL)
driver = ao_driver_id(optext_driver);
else
driver = ao_default_driver_id();
/* just some generics */
fmt->channels = 2;
fmt->rate = 44100;
fmt->bits = 16;
fmt->byte_format = AO_FMT_LITTLE;
options = NULL;
/* -- Open driver -- */
device = ao_open_live(driver, fmt, options);
if (device == NULL) {
message(GETTEXT("audio-ao: Unsupported driver."));
xfree(fmt);
aod = NULL;
} else {
aod = xnew_and_zero(sound_ao_data_t);
aod->ad = device;
aod->options = NULL;
aod->fmt = fmt;
aod->driver_id = driver;
}
return aod;
}
static ad_device_data *
sound_nas_create(Lisp_Object nas_options)
{
sound_nas_data_t *snd;
char *server[6] = {NULL, NULL, NULL, NULL, NULL, NULL};
int i, server_cnt = 0;
AuServer *aud = NULL;
Lisp_Object opt_server = Qnil;
/* parse options */
opt_server = Fplist_get(nas_options, intern(":server"), Qnil);
if (!NILP(opt_server) && !STRINGP(opt_server) && !DEVICEP(opt_server)) {
wrong_type_argument(Qstringp, opt_server);
return NULL;
}
if (NILP(opt_server))
nas_setup_defaults(server, &server_cnt);
else if (STRINGP(opt_server))
server[server_cnt++] = (char*)XSTRING_DATA(opt_server);
#ifdef HAVE_X_WINDOWS
else if (DEVICEP(opt_server) && DEVICE_X_P(XDEVICE(opt_server)))
server[server_cnt++] =
(char*)XSTRING_DATA(
DEVICE_CONNECTION(XDEVICE(opt_server)));
#endif
NAS_DEBUG("trying %d connections\n", server_cnt);
for (i = 0; i<server_cnt; i++)
if ((aud = nas_try_connection(server[i])))
break;
if (!aud) {
NAS_DEBUG_C("cannot contact any NAS server\n");
warn_when_safe(Qnas, Qwarning,
GETTEXT("No NAS servers in sight.\n"));
return NULL; /* Could not contact NAS server */
}
/* -- initialise -- */
snd = xnew_and_zero(sound_nas_data_t);
snd->aud = aud;
/* round up SOUND_MAX_AUDIO_FRAME_SIZE to multiple of NAS_FRAG_SIZE
* divide by 3 first because of 2:1 split */
snd->proposed_buffer_size =
(SOUND_MAX_AUDIO_FRAME_SIZE/3 + NAS_FRAG_SIZE-1)
& ~(NAS_FRAG_SIZE-1);
NAS_DEBUG_C("proposed buffer size: %u\n", snd->proposed_buffer_size);
NAS_DEBUG_C("created: 0x%x\n", (unsigned int)snd);
return snd;
}
static ad_device_data *
sound_oss_create(Lisp_Object oss_options)
{
/* result */
sound_oss_data_t *sod = NULL;
int keep_open = 0;
/* option keywords */
Lisp_Object opt_device;
Lisp_Object opt_keepopen;
/* parse options */
opt_device = Fplist_get(oss_options, Q_device, Qnil);
if (!NILP(opt_device) && !STRINGP(opt_device)) {
wrong_type_argument(Qstringp, opt_device);
return NULL;
}
opt_keepopen = Fplist_get(oss_options, Q_keep_open, Qnil);
if (!NILP(opt_keepopen))
keep_open = 1;
/* initialise and fill */
sod = xnew_and_zero(sound_oss_data_t);
sod->device = opt_device;
sod->keep_open = keep_open;
sod->device_fd = -1;
SXE_MUTEX_INIT(&sod->mtx);
/* Open the device */
if (!keep_open) {
sod->device_fd = -1;
}
return (ad_device_data*)sod;
}
static Lisp_Object
casify_object (enum case_action flag, Lisp_Object string_or_char,
Lisp_Object buffer)
{
struct buffer *buf = decode_buffer (buffer, 0);
retry:
if (CHAR_OR_CHAR_INTP (string_or_char))
{
Ichar c;
CHECK_CHAR_COERCE_INT (string_or_char);
c = XCHAR (string_or_char);
if (flag == CASE_DOWN)
{
c = DOWNCASE (buf, c);
}
else if (flag == CASE_UP)
{
c = UPCASE (buf, c);
}
else
{
c = CANONCASE (buf, c);
}
return make_char (c);
}
if (STRINGP (string_or_char))
{
Lisp_Object syntax_table = buf->mirror_syntax_table;
Ibyte *storage =
alloca_ibytes (XSTRING_LENGTH (string_or_char) * MAX_ICHAR_LEN);
Ibyte *newp = storage;
Ibyte *oldp = XSTRING_DATA (string_or_char);
Ibyte *endp = oldp + XSTRING_LENGTH (string_or_char);
int wordp = 0, wordp_prev;
while (oldp < endp)
{
Ichar c = itext_ichar (oldp);
switch (flag)
{
case CASE_UP:
c = UPCASE (buf, c);
break;
case CASE_DOWN:
c = DOWNCASE (buf, c);
break;
case CASE_CANONICALIZE:
c = CANONCASE (buf, c);
break;
case CASE_CAPITALIZE:
case CASE_CAPITALIZE_UP:
wordp_prev = wordp;
wordp = WORD_SYNTAX_P (syntax_table, c);
if (!wordp) break;
if (wordp_prev)
{
if (flag == CASE_CAPITALIZE)
c = DOWNCASE (buf, c);
}
else
c = UPCASE (buf, c);
break;
}
newp += set_itext_ichar (newp, c);
INC_IBYTEPTR (oldp);
}
return make_string (storage, newp - storage);
}
string_or_char = wrong_type_argument (Qchar_or_string_p, string_or_char);
goto retry;
}
static Lisp_Object
casify_object (enum case_action flag, Lisp_Object obj)
{
register int c, c1;
register int inword = flag == CASE_DOWN;
/* If the case table is flagged as modified, rescan it. */
if (NILP (XCHAR_TABLE (BVAR (current_buffer, downcase_table))->extras[1]))
Fset_case_table (BVAR (current_buffer, downcase_table));
if (INTEGERP (obj))
{
int flagbits = (CHAR_ALT | CHAR_SUPER | CHAR_HYPER
| CHAR_SHIFT | CHAR_CTL | CHAR_META);
int flags = XINT (obj) & flagbits;
int multibyte = ! NILP (BVAR (current_buffer, enable_multibyte_characters));
/* If the character has higher bits set
above the flags, return it unchanged.
It is not a real character. */
if ((unsigned) XFASTINT (obj) > (unsigned) flagbits)
return obj;
c1 = XFASTINT (obj) & ~flagbits;
/* FIXME: Even if enable-multibyte-characters is nil, we may
manipulate multibyte chars. This means we have a bug for latin-1
chars since when we receive an int 128-255 we can't tell whether
it's an eight-bit byte or a latin-1 char. */
if (c1 >= 256)
multibyte = 1;
if (! multibyte)
MAKE_CHAR_MULTIBYTE (c1);
c = downcase (c1);
if (inword)
XSETFASTINT (obj, c | flags);
else if (c == (XFASTINT (obj) & ~flagbits))
{
if (! inword)
c = upcase1 (c1);
if (! multibyte)
MAKE_CHAR_UNIBYTE (c);
XSETFASTINT (obj, c | flags);
}
return obj;
}
if (!STRINGP (obj))
wrong_type_argument (Qchar_or_string_p, obj);
else if (!STRING_MULTIBYTE (obj))
{
EMACS_INT i;
EMACS_INT size = SCHARS (obj);
obj = Fcopy_sequence (obj);
for (i = 0; i < size; i++)
{
c = SREF (obj, i);
MAKE_CHAR_MULTIBYTE (c);
c1 = c;
if (inword && flag != CASE_CAPITALIZE_UP)
c = downcase (c);
else if (!uppercasep (c)
&& (!inword || flag != CASE_CAPITALIZE_UP))
c = upcase1 (c1);
if ((int) flag >= (int) CASE_CAPITALIZE)
inword = (SYNTAX (c) == Sword);
if (c != c1)
{
MAKE_CHAR_UNIBYTE (c);
/* If the char can't be converted to a valid byte, just don't
change it. */
if (c >= 0 && c < 256)
SSET (obj, i, c);
}
}
return obj;
}
else
{
EMACS_INT i, i_byte, size = SCHARS (obj);
int len;
USE_SAFE_ALLOCA;
unsigned char *dst, *o;
/* Over-allocate by 12%: this is a minor overhead, but should be
sufficient in 99.999% of the cases to avoid a reallocation. */
EMACS_INT o_size = SBYTES (obj) + SBYTES (obj) / 8 + MAX_MULTIBYTE_LENGTH;
SAFE_ALLOCA (dst, void *, o_size);
o = dst;
for (i = i_byte = 0; i < size; i++, i_byte += len)
{
if ((o - dst) + MAX_MULTIBYTE_LENGTH > o_size)
{ /* Not enough space for the next char: grow the destination. */
unsigned char *old_dst = dst;
o_size += o_size; /* Probably overkill, but extremely rare. */
SAFE_ALLOCA (dst, void *, o_size);
memcpy (dst, old_dst, o - old_dst);
o = dst + (o - old_dst);
}
c = STRING_CHAR_AND_LENGTH (SDATA (obj) + i_byte, len);
if (inword && flag != CASE_CAPITALIZE_UP)
c = downcase (c);
else if (!uppercasep (c)
&& (!inword || flag != CASE_CAPITALIZE_UP))
c = upcase1 (c);
if ((int) flag >= (int) CASE_CAPITALIZE)
inword = (SYNTAX (c) == Sword);
o += CHAR_STRING (c, o);
}
eassert (o - dst <= o_size);
obj = make_multibyte_string ((char *) dst, size, o - dst);
SAFE_FREE ();
return obj;
}
}
static Lisp_Object
casify_object(enum case_action flag, Lisp_Object string_or_char,
Lisp_Object buffer)
{
struct buffer *buf = decode_buffer(buffer, 0);
retry:
if (CHAR_OR_CHAR_INTP(string_or_char)) {
Emchar c;
CHECK_CHAR_COERCE_INT(string_or_char);
c = XCHAR(string_or_char);
c = (flag == CASE_DOWN) ? DOWNCASE(buf, c) : UPCASE(buf, c);
return make_char(c);
}
if (STRINGP(string_or_char)) {
Lisp_Char_Table *syntax_table =
XCHAR_TABLE(buf->mirror_syntax_table);
Bufbyte *storage =
alloca_array(Bufbyte,
XSTRING_LENGTH(string_or_char) *
MAX_EMCHAR_LEN);
Bufbyte *newp = storage;
Bufbyte *oldp = XSTRING_DATA(string_or_char);
int wordp = 0, wordp_prev;
while (*oldp) {
Emchar c = charptr_emchar(oldp);
switch (flag) {
case CASE_UP:
c = UPCASE(buf, c);
break;
case CASE_DOWN:
c = DOWNCASE(buf, c);
break;
case CASE_CAPITALIZE:
case CASE_CAPITALIZE_UP:
wordp_prev = wordp;
wordp = WORD_SYNTAX_P(syntax_table, c);
if (!wordp)
break;
if (wordp_prev) {
if (flag == CASE_CAPITALIZE)
c = DOWNCASE(buf, c);
} else
c = UPCASE(buf, c);
break;
/* can't happen */
default:
/* abort()? */
break;
}
newp += set_charptr_emchar(newp, c);
INC_CHARPTR(oldp);
}
return make_string(storage, newp - storage);
}
string_or_char = wrong_type_argument(Qchar_or_string_p, string_or_char);
goto retry;
}
static json_t *
lisp_to_json_toplevel_1 (Lisp_Object lisp)
{
json_t *json;
ptrdiff_t count;
if (VECTORP (lisp))
{
ptrdiff_t size = ASIZE (lisp);
json = json_check (json_array ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
for (ptrdiff_t i = 0; i < size; ++i)
{
int status
= json_array_append_new (json, lisp_to_json (AREF (lisp, i)));
if (status == -1)
json_out_of_memory ();
}
eassert (json_array_size (json) == size);
}
else if (HASH_TABLE_P (lisp))
{
struct Lisp_Hash_Table *h = XHASH_TABLE (lisp);
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
if (!NILP (HASH_HASH (h, i)))
{
Lisp_Object key = json_encode (HASH_KEY (h, i));
/* We can't specify the length, so the string must be
null-terminated. */
check_string_without_embedded_nulls (key);
const char *key_str = SSDATA (key);
/* Reject duplicate keys. These are possible if the hash
table test is not `equal'. */
if (json_object_get (json, key_str) != NULL)
wrong_type_argument (Qjson_value_p, lisp);
int status = json_object_set_new (json, key_str,
lisp_to_json (HASH_VALUE (h, i)));
if (status == -1)
{
/* A failure can be caused either by an invalid key or
by low memory. */
json_check_utf8 (key);
json_out_of_memory ();
}
}
}
else if (NILP (lisp))
return json_check (json_object ());
else if (CONSP (lisp))
{
Lisp_Object tail = lisp;
json = json_check (json_object ());
count = SPECPDL_INDEX ();
record_unwind_protect_ptr (json_release_object, json);
bool is_plist = !CONSP (XCAR (tail));
FOR_EACH_TAIL (tail)
{
const char *key_str;
Lisp_Object value;
Lisp_Object key_symbol;
if (is_plist)
{
key_symbol = XCAR (tail);
tail = XCDR (tail);
CHECK_CONS (tail);
value = XCAR (tail);
if (EQ (tail, li.tortoise)) circular_list (lisp);
}
else
{
Lisp_Object pair = XCAR (tail);
CHECK_CONS (pair);
key_symbol = XCAR (pair);
value = XCDR (pair);
}
CHECK_SYMBOL (key_symbol);
Lisp_Object key = SYMBOL_NAME (key_symbol);
/* We can't specify the length, so the string must be
null-terminated. */
check_string_without_embedded_nulls (key);
key_str = SSDATA (key);
/* In plists, ensure leading ":" in keys is stripped. It
will be reconstructed later in `json_to_lisp'.*/
if (is_plist && ':' == key_str[0] && key_str[1])
{
key_str = &key_str[1];
}
/* Only add element if key is not already present. */
if (json_object_get (json, key_str) == NULL)
{
int status
= json_object_set_new (json, key_str, lisp_to_json (value));
if (status == -1)
json_out_of_memory ();
}
}
CHECK_LIST_END (tail, lisp);
}
else
