/* Random utility Lisp functions.
Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
Copyright (C) 1995, 1996 Ben Wing.
+ Copyright (C) 2002, 2003, 2004, 2008 MORIOKA Tomohiko
This file is part of XEmacs.
#include "lstream.h"
#include "opaque.h"
+
+\f
+static Lisp_Object free_malloced_ptr(Lisp_Object unwind_obj)
+{
+ void *ptr = (void *)get_opaque_ptr(unwind_obj);
+ xfree(ptr);
+ free_opaque_ptr(unwind_obj);
+ return Qnil;
+}
+
+/* Don't use alloca for regions larger than this, lest we overflow
+ the stack. */
+#define MAX_ALLOCA 65536
+
+/* We need to setup proper unwinding, because there is a number of
+ ways these functions can blow up, and we don't want to have memory
+ leaks in those cases. */
+#define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
+ size_t XOA_len = (len); \
+ if (XOA_len > MAX_ALLOCA ) { \
+ ptr = xnew_array (type, XOA_len); \
+ record_unwind_protect (free_malloced_ptr, \
+ make_opaque_ptr ((void *)ptr)); \
+ } \
+ else \
+ ptr = alloca_array (type, XOA_len); \
+} while (0)
+
+#define XMALLOC_UNBIND(ptr, len, speccount) do { \
+ if ((len) > MAX_ALLOCA) \
+ unbind_to (speccount, Qnil); \
+} while (0)
+
+\f
+
+
/* NOTE: This symbol is also used in lread.c */
#define FEATUREP_SYNTAX
Bufbyte *string_result = 0;
Bufbyte *string_result_ptr = 0;
struct gcpro gcpro1;
+ int speccount = specpdl_depth();
+ Charcount total_length;
/* The modus operandi in Emacs is "caller gc-protects args".
However, concat is called many times in Emacs on freshly
the result in the returned string's `string-translatable' property. */
#endif
if (target_type == c_string)
- args_mse = alloca_array (struct merge_string_extents_struct, nargs);
+ XMALLOC_OR_ALLOCA(args_mse, nargs, struct merge_string_extents_struct);
/* In append, the last arg isn't treated like the others */
if (last_special && nargs > 0)
/* Charcount is a misnomer here as we might be dealing with the
length of a vector or list, but emphasizes that we're not dealing
with Bytecounts in strings */
- Charcount total_length;
+ /* Charcount total_length; */
for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
{
{
case c_cons:
if (total_length == 0)
+ {
/* In append, if all but last arg are nil, return last arg */
+ XMALLOC_UNBIND(args_mse, nargs, speccount);
RETURN_UNGCPRO (last_tail);
+ }
val = Fmake_list (make_int (total_length), Qnil);
break;
case c_vector:
realloc()ing in order to make the char fit properly.
O(N^2) yuckage. */
val = Qnil;
- string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
+ XMALLOC_OR_ALLOCA( string_result,
+ total_length * MAX_EMCHAR_LEN,
+ Bufbyte );
string_result_ptr = string_result;
break;
default:
args_mse[argnum].entry_offset, 0,
args_mse[argnum].entry_length);
}
+ XMALLOC_UNBIND(string_result, total_length * MAX_EMCHAR_LEN, speccount);
+ XMALLOC_UNBIND(args_mse, nargs, speccount);
}
if (!NILP (prev))
Lisp_Object *keys, *vals;
char *flags;
Lisp_Object rest;
+ int speccount = specpdl_depth();
if (NILP (a) && NILP (b))
return 0;
lb = XINT (Flength (b));
m = (la > lb ? la : lb);
fill = 0;
- keys = alloca_array (Lisp_Object, m);
- vals = alloca_array (Lisp_Object, m);
- flags = alloca_array (char, m);
+ XMALLOC_OR_ALLOCA(keys, m, Lisp_Object);
+ XMALLOC_OR_ALLOCA(vals, m, Lisp_Object);
+ XMALLOC_OR_ALLOCA(flags, m, char);
/* First extract the pairs from A. */
for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
if (flags [i] == 0)
goto MISMATCH;
+
+ XMALLOC_UNBIND(flags, m, speccount);
+ XMALLOC_UNBIND(vals, m, speccount);
+ XMALLOC_UNBIND(keys, m, speccount);
/* Ok. */
return 0;
MISMATCH:
+ XMALLOC_UNBIND(flags, m, speccount);
+ XMALLOC_UNBIND(vals, m, speccount);
+ XMALLOC_UNBIND(keys, m, speccount);
return 1;
}
{
/* The string data of `sequence' might be relocated during GC. */
Bytecount slen = XSTRING_LENGTH (sequence);
- Bufbyte *p = alloca_array (Bufbyte, slen);
- Bufbyte *end = p + slen;
+ Bufbyte *p = NULL;
+ Bufbyte *end = NULL;
+ int speccount = specpdl_depth();
+
+ XMALLOC_OR_ALLOCA(p, slen, Bufbyte);
+ end = p + slen;
memcpy (p, XSTRING_DATA (sequence), slen);
result = Ffuncall (2, args);
if (vals) vals[gcpro1.nvars++] = result;
}
+ XMALLOC_UNBIND(p, slen, speccount);
}
else if (BIT_VECTORP (sequence))
{
{
EMACS_INT len = XINT (Flength (sequence));
Lisp_Object *args;
+ Lisp_Object result;
EMACS_INT i;
EMACS_INT nargs = len + len - 1;
+ int speccount = specpdl_depth();
if (len == 0) return build_string ("");
- args = alloca_array (Lisp_Object, nargs);
+ XMALLOC_OR_ALLOCA(args, nargs, Lisp_Object);
mapcar1 (len, args, function, sequence);
for (i = 1; i < nargs; i += 2)
args[i] = separator;
- return Fconcat (nargs, args);
+ result = Fconcat(nargs, args);
+ XMALLOC_UNBIND(args, nargs, speccount);
+ return result;
}
DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
(function, sequence))
{
size_t len = XINT (Flength (sequence));
- Lisp_Object *args = alloca_array (Lisp_Object, len);
+ Lisp_Object *args = NULL;
+ Lisp_Object result;
+ int speccount = specpdl_depth();
+
+ XMALLOC_OR_ALLOCA(args, len, Lisp_Object);
mapcar1 (len, args, function, sequence);
- return Flist (len, args);
+ result = Flist(len, args);
+ XMALLOC_UNBIND(args, len, speccount);
+ return result;
}
DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
#undef ADVANCE_INPUT_IGNORE_NONBASE64
#undef STORE_BYTE
-static Lisp_Object
-free_malloced_ptr (Lisp_Object unwind_obj)
-{
- void *ptr = (void *)get_opaque_ptr (unwind_obj);
- xfree (ptr);
- free_opaque_ptr (unwind_obj);
- return Qnil;
-}
-
-/* Don't use alloca for regions larger than this, lest we overflow
- the stack. */
-#define MAX_ALLOCA 65536
-
-/* We need to setup proper unwinding, because there is a number of
- ways these functions can blow up, and we don't want to have memory
- leaks in those cases. */
-#define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
- size_t XOA_len = (len); \
- if (XOA_len > MAX_ALLOCA) \
- { \
- ptr = xnew_array (type, XOA_len); \
- record_unwind_protect (free_malloced_ptr, \
- make_opaque_ptr ((void *)ptr)); \
- } \
- else \
- ptr = alloca_array (type, XOA_len); \
-} while (0)
-
-#define XMALLOC_UNBIND(ptr, len, speccount) do { \
- if ((len) > MAX_ALLOCA) \
- unbind_to (speccount, Qnil); \
-} while (0)
DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
Base64-encode the region between START and END.
return result;
}
\f
+Lisp_Object Qideographic_structure;
+Lisp_Object Qkeyword_char;
+
+EXFUN (Fideographic_structure_to_ids, 1);
+
+Lisp_Object ids_format_unit (Lisp_Object ids_char);
+Lisp_Object
+ids_format_unit (Lisp_Object ids_char)
+{
+ if (CHARP (ids_char))
+ return Fchar_to_string (ids_char);
+ else if (INTP (ids_char))
+ return Fchar_to_string (Fdecode_char (Qrep_ucs, ids_char, Qnil, Qnil));
+ else
+ {
+ Lisp_Object ret = Ffind_char (ids_char);
+
+ if (CHARP (ret))
+ return Fchar_to_string (ret);
+ else
+ {
+ ret = Fassq (Qideographic_structure, ids_char);
+
+ if (CONSP (ret))
+ return Fideographic_structure_to_ids (XCDR (ret));
+ }
+ }
+ return Qnil;
+}
+
+DEFUN ("ideographic-structure-to-ids",
+ Fideographic_structure_to_ids, 1, 1, 0, /*
+Format ideographic-structure IDS-LIST as an IDS-string.
+*/
+ (ids_list))
+{
+ Lisp_Object dest = Qnil;
+
+ while (CONSP (ids_list))
+ {
+ Lisp_Object cell = XCAR (ids_list);
+
+ if (!NILP (Fchar_ref_p (cell)))
+ cell = Fplist_get (cell, Qkeyword_char, Qnil);
+ dest = concat2 (dest, ids_format_unit (cell));
+ ids_list = XCDR (ids_list);
+ }
+ return dest;
+}
+
+Lisp_Object simplify_char_spec (Lisp_Object char_spec);
+Lisp_Object
+simplify_char_spec (Lisp_Object char_spec)
+{
+ if (CHARP (char_spec))
+ {
+ Lisp_Object ccs;
+ int code_point = ENCODE_CHAR (XCHAR (char_spec), ccs);
+
+ if (code_point >= 0)
+ {
+ int cid = decode_defined_char (ccs, code_point, Qnil);
+
+ if (cid >= 0)
+ return make_char (cid);
+ }
+ return char_spec;
+ }
+ else if (INTP (char_spec))
+ return Fdecode_char (Qrep_ucs, char_spec, Qnil, Qnil);
+ else
+ {
+#if 0
+ Lisp_Object ret = Ffind_char (char_spec);
+#else
+ Lisp_Object ret;
+ Lisp_Object rest = char_spec;
+ int have_ccs = 0;
+
+ while (CONSP (rest))
+ {
+ Lisp_Object cell = Fcar (rest);
+ Lisp_Object ccs;
+
+#if 0
+ if (!LISTP (cell))
+ signal_simple_error ("Invalid argument", char_spec);
+#endif
+ if (!NILP (ccs = Ffind_charset (Fcar (cell))))
+ {
+ cell = Fcdr (cell);
+ if (CONSP (cell))
+ ret = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell)));
+ else
+ ret = Fdecode_char (ccs, cell, Qt, Qt);
+ have_ccs = 1;
+ if (CHARP (ret))
+ return ret;
+ }
+ rest = Fcdr (rest);
+ }
+ if (have_ccs)
+ ret = Fdefine_char (char_spec);
+ else
+ ret = Qnil;
+#endif
+
+ if (CHARP (ret))
+ return ret;
+ else
+ return char_spec;
+ }
+}
+
+Lisp_Object char_ref_simplify_spec (Lisp_Object char_ref);
+Lisp_Object
+char_ref_simplify_spec (Lisp_Object char_ref)
+{
+ if (!NILP (Fchar_ref_p (char_ref)))
+ {
+ Lisp_Object ret = Fplist_get (char_ref, Qkeyword_char, Qnil);
+
+ if (NILP (ret))
+ return char_ref;
+ else
+ return Fplist_put (Fcopy_sequence (char_ref), Qkeyword_char,
+ simplify_char_spec (ret));
+ }
+ else
+ return simplify_char_spec (char_ref);
+}
+
+DEFUN ("char-refs-simplify-char-specs",
+ Fchar_refs_simplify_char_specs, 1, 1, 0, /*
+Simplify char-specs in CHAR-REFS.
+*/
+ (char_refs))
+{
+ Lisp_Object rest = char_refs;
+
+ while (CONSP (rest))
+ {
+ Fsetcar (rest, char_ref_simplify_spec (XCAR (rest)));
+ rest = XCDR (rest);
+ }
+ return char_refs;
+}
+\f
Lisp_Object Qyes_or_no_p;
void
defsymbol (&Qstring_lessp, "string-lessp");
defsymbol (&Qidentity, "identity");
+ defsymbol (&Qideographic_structure, "ideographic-structure");
+ defsymbol (&Qkeyword_char, ":char");
defsymbol (&Qyes_or_no_p, "yes-or-no-p");
DEFSUBR (Fidentity);
DEFSUBR (Fbase64_encode_string);
DEFSUBR (Fbase64_decode_region);
DEFSUBR (Fbase64_decode_string);
+ DEFSUBR (Fideographic_structure_to_ids);
+ DEFSUBR (Fchar_refs_simplify_char_specs);
}
void
projects / chise / xemacs-chise.git.1 / blobdiff