/* 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