static Lisp_Object
hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
{
struct Lisp_Hash_Table *h;
ptrdiff_t i;
EMACS_UINT hash;
if (NILP (XCHAR_TABLE (table)->extras[1]))
set_char_table_extras
(table, 1,
make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
Qnil));
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash);
if (i >= 0)
return HASH_KEY (h, i);
hash_put (h, category_set, Qnil, hash);
return category_set;
}
static Lisp_Object
hash_get_category_set (Lisp_Object table, Lisp_Object category_set)
{
Lisp_Object val;
struct Lisp_Hash_Table *h;
int i;
unsigned hash;
if (NILP (XCHAR_TABLE (table)->extras[1]))
XCHAR_TABLE (table)->extras[1]
= make_hash_table (Qequal, make_number (DEFAULT_HASH_SIZE),
make_float (DEFAULT_REHASH_SIZE),
make_float (DEFAULT_REHASH_THRESHOLD),
Qnil, Qnil, Qnil);
h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]);
i = hash_lookup (h, category_set, &hash);
if (i >= 0)
return HASH_KEY (h, i);
hash_put (h, category_set, Qnil, hash);
return category_set;
}
/* Match the buffer text against names of symbols in obarray. Returns
the matching symbol, or 0 if not found. */
static Lisp_Symbol *abbrev_match(struct buffer *buf, Lisp_Object obarray)
{
struct abbrev_match_mapper_closure closure;
/* Precalculate some stuff, so mapper function needn't to it in each
iteration. */
closure.buf = buf;
closure.point = BUF_PT(buf);
closure.maxlen = closure.point - BUF_BEGV(buf);
closure.chartab = XCHAR_TABLE(buf->mirror_syntax_table);
closure.found = 0;
map_obarray(obarray, abbrev_match_mapper, &closure);
return closure.found;
}
static void
set_char_table_parent (Lisp_Object table, Lisp_Object val)
{
XCHAR_TABLE (table)->parent = val;
}
static void
set_char_table_ascii (Lisp_Object table, Lisp_Object val)
{
XCHAR_TABLE (table)->ascii = val;
}
static void
find_context (struct buffer *buf, Bufpos pt)
{
/* This function can GC */
#ifndef emacs
#ifdef UTF2000
Lisp_Char_Table *mirrortab = XCHAR_TABLE (buf->syntax_table);
#else
Lisp_Char_Table *mirrortab = XCHAR_TABLE (buf->mirror_syntax_table);
#endif
Lisp_Object syntaxtab = buf->syntax_table;
#endif
Emchar prev_c, c;
int prev_syncode, syncode;
Bufpos target = pt;
setup_context_cache (buf, pt);
pt = context_cache.cur_point;
SCS_STATISTICS_SET_FUNCTION (scs_find_context);
SETUP_SYNTAX_CACHE (pt - 1, 1);
if (pt > BUF_BEGV (buf))
{
c = BUF_FETCH_CHAR (buf, pt - 1);
syncode = SYNTAX_CODE_FROM_CACHE (mirrortab, c);
}
else
{
c = '\n'; /* to get bol_context_cache at point-min */
syncode = Swhitespace;
}
for (; pt < target; pt++, context_cache.cur_point = pt)
{
if (context_cache.needs_its_head_reexamined)
{
if (context_cache.depth == 0
&& context_cache.context == context_none)
{
/* We've found an anchor spot.
Try to put the start of defun within 6000 chars of
the target, and the end of defun as close as possible.
6000 is also arbitrary but tries to strike a balance
between two conflicting pulls when dealing with a
file that has lots of stuff sitting outside of a top-
level form:
a) If you move past the start of defun, you will
have to recompute defun, which in this case
means that start of defun goes all the way back
to the beginning of the file; so you want
to set start of defun a ways back from the
current point.
b) If you move a line backwards but within start of
defun, you have to move back to start of defun;
so you don't want start of defun too far from
the current point.
*/
if (target - context_cache.start_point > 6000)
context_cache.start_point = pt;
context_cache.end_point = pt;
bol_context_cache = context_cache;
}
}
UPDATE_SYNTAX_CACHE_FORWARD (pt);
prev_c = c;
prev_syncode = syncode;
c = BUF_FETCH_CHAR (buf, pt);
syncode = SYNTAX_CODE_FROM_CACHE (mirrortab, c);
if (prev_c == '\n')
bol_context_cache = context_cache;
if (context_cache.backslash_p)
{
context_cache.backslash_p = 0;
continue;
}
switch (SYNTAX_FROM_CACHE (mirrortab, c))
{
case Sescape:
context_cache.backslash_p = 1;
break;
case Sopen:
if (context_cache.context == context_none)
context_cache.depth++;
break;
case Sclose:
if (context_cache.context == context_none)
context_cache.depth--;
break;
case Scomment:
if (context_cache.context == context_none)
{
context_cache.context = context_comment;
context_cache.ccontext = ccontext_none;
context_cache.style = SINGLE_SYNTAX_STYLE (syncode);
if (context_cache.style == comment_style_none) ABORT ();
}
break;
case Sendcomment:
if (context_cache.style != SINGLE_SYNTAX_STYLE (syncode))
;
else if (context_cache.context == context_comment)
{
context_cache.context = context_none;
context_cache.style = comment_style_none;
}
else if (context_cache.context == context_block_comment &&
(context_cache.ccontext == ccontext_start2 ||
context_cache.ccontext == ccontext_end1))
{
context_cache.context = context_none;
context_cache.ccontext = ccontext_none;
context_cache.style = comment_style_none;
}
break;
case Sstring:
{
if (context_cache.context == context_string &&
context_cache.scontext == c)
{
context_cache.context = context_none;
context_cache.scontext = '\000';
}
else if (context_cache.context == context_none)
{
Lisp_Object stringtermobj =
syntax_match (syntax_cache.current_syntax_table, c);
Emchar stringterm;
if (CHARP (stringtermobj))
stringterm = XCHAR (stringtermobj);
else
stringterm = c;
context_cache.context = context_string;
context_cache.scontext = stringterm;
context_cache.ccontext = ccontext_none;
}
break;
}
case Scomment_fence:
{
if (context_cache.context == context_generic_comment)
{
context_cache.context = context_none;
}
else if (context_cache.context == context_none)
{
context_cache.context = context_generic_comment;
context_cache.ccontext = ccontext_none;
}
break;
}
case Sstring_fence:
{
if (context_cache.context == context_generic_string)
{
context_cache.context = context_none;
}
else if (context_cache.context == context_none)
{
context_cache.context = context_generic_string;
context_cache.ccontext = ccontext_none;
}
break;
}
default:
;
}
/* That takes care of the characters with manifest syntax.
Now we've got to hack multi-char sequences that start
and end block comments.
*/
if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_SECOND_CHAR_START) &&
context_cache.context == context_none &&
context_cache.ccontext == ccontext_start1 &&
SYNTAX_CODES_START_P (prev_syncode, syncode) /* the two chars match */
)
{
context_cache.ccontext = ccontext_start2;
context_cache.style = SYNTAX_START_STYLE (prev_syncode, syncode);
if (context_cache.style == comment_style_none) ABORT ();
}
else if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_FIRST_CHAR_START) &&
context_cache.context == context_none &&
(context_cache.ccontext == ccontext_none ||
context_cache.ccontext == ccontext_start1))
{
context_cache.ccontext = ccontext_start1;
context_cache.style = comment_style_none; /* should be this already*/
}
else if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_SECOND_CHAR_END) &&
context_cache.context == context_block_comment &&
context_cache.ccontext == ccontext_end1 &&
SYNTAX_CODES_END_P (prev_syncode, syncode) &&
/* the two chars match */
context_cache.style ==
SYNTAX_END_STYLE (prev_syncode, syncode)
)
{
context_cache.context = context_none;
context_cache.ccontext = ccontext_none;
context_cache.style = comment_style_none;
}
else if ((SYNTAX_CODE_COMMENT_BITS (syncode) &
SYNTAX_FIRST_CHAR_END) &&
context_cache.context == context_block_comment &&
#if 0
/* #### pre-Matt code had: */
(context_cache.style ==
SYNTAX_END_STYLE (c, BUF_FETCH_CHAR (buf, pt+1))) &&
/* why do these differ here?! */
#endif
context_cache.style == SINGLE_SYNTAX_STYLE (syncode) &&
(context_cache.ccontext == ccontext_start2 ||
context_cache.ccontext == ccontext_end1))
/* check end1, to detect a repetition of the first char of a
comment-end sequence. ie, '/xxx foo xxx/' or '/xxx foo x/',
where 'x' = '*' -- mct */
{
if (context_cache.style == comment_style_none) ABORT ();
context_cache.ccontext = ccontext_end1;
}
else if (context_cache.ccontext == ccontext_start1)
{
if (context_cache.context != context_none) ABORT ();
context_cache.ccontext = ccontext_none;
}
else if (context_cache.ccontext == ccontext_end1)
{
if (context_cache.context != context_block_comment) ABORT ();
context_cache.context = context_none;
context_cache.ccontext = ccontext_start2;
}
if (context_cache.ccontext == ccontext_start2 &&
context_cache.context == context_none)
{
context_cache.context = context_block_comment;
if (context_cache.style == comment_style_none) ABORT ();
}
else if (context_cache.ccontext == ccontext_none &&
context_cache.context == context_block_comment)
{
context_cache.context = context_none;
}
}
context_cache.needs_its_head_reexamined = 0;
}
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;
}