X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Ffns.c;h=9de6fea678db62550b2a888be5951b5646448157;hb=dc745854625e6c7b8fb441c6fb4a521857a5cce0;hp=95ce1459c622b2fa11bf79f44cb934397cc06e4e;hpb=3198ed8319f99e19a14447745f4f93e4b4522961;p=chise%2Fxemacs-chise.git.1 diff --git a/src/fns.c b/src/fns.c index 95ce145..9de6fea 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1,6 +1,7 @@ /* 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. @@ -49,6 +50,42 @@ Boston, MA 02111-1307, USA. */ #include "lstream.h" #include "opaque.h" + + +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) + + + + /* NOTE: This symbol is also used in lread.c */ #define FEATUREP_SYNTAX @@ -73,7 +110,7 @@ print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) size_t last = len; if (INTP (Vprint_length)) - last = min (len, XINT (Vprint_length)); + last = min ((EMACS_INT) len, XINT (Vprint_length)); write_c_string ("#*", printcharfun); for (i = 0; i < last; i++) { @@ -143,7 +180,7 @@ extern void seed_random (long arg); DEFUN ("random", Frandom, 0, 1, 0, /* Return a pseudo-random number. All integers representable in Lisp are equally likely. - On most systems, this is 28 bits' worth. + On most systems, this is 31 bits' worth. With positive integer argument N, return random number in interval [0,N). With argument t, set the random number seed from the current time and pid. */ @@ -163,7 +200,7 @@ With argument t, set the random number seed from the current time and pid. it's possible to get a quotient larger than limit; discarding these values eliminates the bias that would otherwise appear when using a large limit. */ - denominator = ((unsigned long)1 << VALBITS) / XINT (limit); + denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit); do val = get_random () / denominator; while (val >= XINT (limit)); @@ -604,6 +641,8 @@ concat (int nargs, Lisp_Object *args, 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 @@ -621,7 +660,7 @@ concat (int nargs, Lisp_Object *args, 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) @@ -670,7 +709,7 @@ concat (int nargs, Lisp_Object *args, /* 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++) { @@ -686,8 +725,11 @@ concat (int nargs, Lisp_Object *args, { 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: @@ -707,12 +749,14 @@ concat (int nargs, Lisp_Object *args, 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: val = Qnil; - abort (); + ABORT (); } } @@ -820,6 +864,8 @@ concat (int nargs, Lisp_Object *args, 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)) @@ -1001,7 +1047,7 @@ are copied to the new string. } else { - abort (); /* unreachable, since Flength (sequence) did not get + ABORT (); /* unreachable, since Flength (sequence) did not get an error */ return Qnil; } @@ -1840,6 +1886,7 @@ plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, Lisp_Object *keys, *vals; char *flags; Lisp_Object rest; + int speccount = specpdl_depth(); if (NILP (a) && NILP (b)) return 0; @@ -1851,9 +1898,9 @@ plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, 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))) @@ -1898,10 +1945,17 @@ plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, 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; } @@ -2995,8 +3049,12 @@ mapcar1 (size_t leni, Lisp_Object *vals, { /* 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); @@ -3007,6 +3065,7 @@ mapcar1 (size_t leni, Lisp_Object *vals, result = Ffuncall (2, args); if (vals) vals[gcpro1.nvars++] = result; } + XMALLOC_UNBIND(p, slen, speccount); } else if (BIT_VECTORP (sequence)) { @@ -3020,28 +3079,32 @@ mapcar1 (size_t leni, Lisp_Object *vals, } } else - abort (); /* unreachable, since Flength (sequence) did not get an error */ + ABORT (); /* unreachable, since Flength (sequence) did not get an error */ if (vals) UNGCPRO; } DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* -Apply FUNCTION to each element of SEQUENCE, and concat the results as strings. -In between each pair of results, insert SEPARATOR. Thus, using " " as -SEPARATOR results in spaces between the values returned by FUNCTION. -SEQUENCE may be a list, a vector, a bit vector, or a string. +Apply FUNCTION to each element of SEQUENCE, and concat the results to a string. +Between each pair of results, insert SEPARATOR. + +Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR +results in spaces between the values returned by FUNCTION. SEQUENCE itself +may be a list, a vector, a bit vector, or a string. */ (function, sequence, separator)) { 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); @@ -3051,7 +3114,9 @@ SEQUENCE may be a list, a vector, a bit vector, or a string. 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, /* @@ -3062,11 +3127,17 @@ SEQUENCE may be a list, a vector, a bit vector, or a string. (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, /* @@ -3569,38 +3640,6 @@ base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr) #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. @@ -3635,7 +3674,7 @@ into shorter lines. encoded_length = base64_encode_1 (XLSTREAM (input), encoded, NILP (no_line_break)); if (encoded_length > allength) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); /* Now we have encoded the region, so we insert the new contents @@ -3677,7 +3716,7 @@ into shorter lines. encoded_length = base64_encode_1 (XLSTREAM (input), encoded, NILP (no_line_break)); if (encoded_length > allength) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); result = make_string (encoded, encoded_length); XMALLOC_UNBIND (encoded, allength, speccount); @@ -3710,7 +3749,7 @@ Characters out of the base64 alphabet are ignored. XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte); decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); if (decoded_length > length * MAX_EMCHAR_LEN) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); /* Now we have decoded the region, so we insert the new contents @@ -3751,7 +3790,7 @@ Characters out of the base64 alphabet are ignored. decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); if (decoded_length > length * MAX_EMCHAR_LEN) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); result = make_string (decoded, decoded_length); @@ -3759,6 +3798,154 @@ Characters out of the base64 alphabet are ignored. return result; } +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; +} + Lisp_Object Qyes_or_no_p; void @@ -3768,6 +3955,8 @@ syms_of_fns (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); @@ -3854,6 +4043,8 @@ syms_of_fns (void) DEFSUBR (Fbase64_encode_string); DEFSUBR (Fbase64_decode_region); DEFSUBR (Fbase64_decode_string); + DEFSUBR (Fideographic_structure_to_ids); + DEFSUBR (Fchar_refs_simplify_char_specs); } void