X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Ffns.c;h=55d5e2fe53efe82bec6b038fd0d6ebe83301e991;hb=4082f470d7c6075a5c04c1bdf6e9e3f27c9700d5;hp=c1fa079bc974c6b13bc9de20edf4c809fdd2f3ba;hpb=33c8db8e2477d62fd8734f65475f2ed516167532;p=chise%2Fxemacs-chise.git- diff --git a/src/fns.c b/src/fns.c index c1fa079..55d5e2f 100644 --- a/src/fns.c +++ b/src/fns.c @@ -113,7 +113,7 @@ bit_vector_hash (Lisp_Object obj, int depth) DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector, mark_bit_vector, print_bit_vector, 0, - bit_vector_equal, bit_vector_hash, + bit_vector_equal, bit_vector_hash, 0, struct Lisp_Bit_Vector); DEFUN ("identity", Fidentity, 1, 1, 0, /* @@ -339,32 +339,41 @@ may be solved. properly, it would still not work because strcoll() does not handle multiple locales. This is the fundamental flaw in the locale model. */ - Bytecount bcend = charcount_to_bytecount (string_data (p1), end); - /* Compare strings using collation order of locale. */ - /* Need to be tricky to handle embedded nulls. */ + { + Bytecount bcend = charcount_to_bytecount (string_data (p1), end); + /* Compare strings using collation order of locale. */ + /* Need to be tricky to handle embedded nulls. */ - for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) - { - int val = strcoll ((char *) string_data (p1) + i, - (char *) string_data (p2) + i); - if (val < 0) - return Qt; - if (val > 0) - return Qnil; - } + for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) + { + int val = strcoll ((char *) string_data (p1) + i, + (char *) string_data (p2) + i); + if (val < 0) + return Qt; + if (val > 0) + return Qnil; + } + } #else /* not I18N2, or MULE */ - /* #### It is not really necessary to do this: We could compare - byte-by-byte and still get a reasonable comparison, since this - would compare characters with a charset in the same way. - With a little rearrangement of the leading bytes, we could - make most inter-charset comparisons work out the same, too; - even if some don't, this is not a big deal because inter-charset - comparisons aren't really well-defined anyway. */ - for (i = 0; i < end; i++) - { - if (string_char (p1, i) != string_char (p2, i)) - return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil; - } + { + Bufbyte *ptr1 = string_data (p1); + Bufbyte *ptr2 = string_data (p2); + + /* #### It is not really necessary to do this: We could compare + byte-by-byte and still get a reasonable comparison, since this + would compare characters with a charset in the same way. With + a little rearrangement of the leading bytes, we could make most + inter-charset comparisons work out the same, too; even if some + don't, this is not a big deal because inter-charset comparisons + aren't really well-defined anyway. */ + for (i = 0; i < end; i++) + { + if (charptr_emchar (ptr1) != charptr_emchar (ptr2)) + return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil; + INC_CHARPTR (ptr1); + INC_CHARPTR (ptr2); + } + } #endif /* not I18N2, or MULE */ /* Can't do i < len2 because then comparison between "foo" and "foo^@" won't work right in I18N2 case */ @@ -881,7 +890,7 @@ Relevant parts of the string-extent-data are copied in the new string. (string, from, to)) { Charcount ccfr, ccto; - Bytecount bfr, bto; + Bytecount bfr, blen; Lisp_Object val; CHECK_STRING (string); @@ -889,10 +898,10 @@ Relevant parts of the string-extent-data are copied in the new string. get_string_range_char (string, from, to, &ccfr, &ccto, GB_HISTORICAL_STRING_BEHAVIOR); bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr); - bto = charcount_to_bytecount (XSTRING_DATA (string), ccto); - val = make_string (XSTRING_DATA (string) + bfr, bto - bfr); + blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr); + val = make_string (XSTRING_DATA (string) + bfr, blen); /* Copy any applicable extent information into the new string: */ - copy_string_extents (val, string, 0, bfr, bto - bfr); + copy_string_extents (val, string, 0, bfr, blen); return val; } @@ -2678,7 +2687,7 @@ See also `get', `remprop', and `object-plist'. (object, propname, value)) { CHECK_SYMBOL (propname); - CHECK_IMPURE (object); + CHECK_LISP_WRITEABLE (object); if (SYMBOLP (object)) symbol_putprop (object, propname, value); @@ -2723,7 +2732,7 @@ was present in the property list). See also `get', `put', and int retval = 0; CHECK_SYMBOL (propname); - CHECK_IMPURE (object); + CHECK_LISP_WRITEABLE (object); if (SYMBOLP (object)) retval = symbol_remprop (object, propname); @@ -2786,47 +2795,12 @@ internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); -#ifndef LRECORD_CONS - do_cdr: -#endif QUIT; if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ if (XTYPE (obj1) != XTYPE (obj2)) return 0; -#ifndef LRECORD_CONS - if (CONSP (obj1)) - { - if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1)) - return 0; - obj1 = XCDR (obj1); - obj2 = XCDR (obj2); - goto do_cdr; - } -#endif -#ifndef LRECORD_VECTOR - if (VECTORP (obj1)) - { - Lisp_Object *v1 = XVECTOR_DATA (obj1); - Lisp_Object *v2 = XVECTOR_DATA (obj2); - int len = XVECTOR_LENGTH (obj1); - if (len != XVECTOR_LENGTH (obj2)) - return 0; - while (len--) - if (!internal_equal (*v1++, *v2++, depth + 1)) - return 0; - return 1; - } -#endif -#ifndef LRECORD_STRING - if (STRINGP (obj1)) - { - Bytecount len; - return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && - !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); - } -#endif if (LRECORDP (obj1)) { CONST struct lrecord_implementation @@ -2851,39 +2825,12 @@ internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); -#ifndef LRECORD_CONS - do_cdr: -#endif QUIT; if (HACKEQ_UNSAFE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ if (XTYPE (obj1) != XTYPE (obj2)) return 0; -#ifndef LRECORD_CONS - if (CONSP (obj1)) - { - if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1)) - return 0; - obj1 = XCDR (obj1); - obj2 = XCDR (obj2); - goto do_cdr; - } -#endif -#ifndef LRECORD_VECTOR - if (VECTORP (obj1)) - { - Lisp_Object *v1 = XVECTOR_DATA (obj1); - Lisp_Object *v2 = XVECTOR_DATA (obj2); - int len = XVECTOR_LENGTH (obj1); - if (len != XVECTOR_LENGTH (obj2)) - return 0; - while (len--) - if (!internal_old_equal (*v1++, *v2++, depth + 1)) - return 0; - return 1; - } -#endif return internal_equal (obj1, obj2, depth); } @@ -2929,7 +2876,7 @@ ARRAY is a vector, bit vector, or string. Charcount len = string_char_length (s); Charcount i; CHECK_CHAR_COERCE_INT (item); - CHECK_IMPURE (array); + CHECK_LISP_WRITEABLE (array); charval = XCHAR (item); for (i = 0; i < len; i++) set_string_char (s, i, charval); @@ -2939,7 +2886,7 @@ ARRAY is a vector, bit vector, or string. { Lisp_Object *p = XVECTOR_DATA (array); int len = XVECTOR_LENGTH (array); - CHECK_IMPURE (array); + CHECK_LISP_WRITEABLE (array); while (len--) *p++ = item; } @@ -2949,7 +2896,7 @@ ARRAY is a vector, bit vector, or string. int len = bit_vector_length (v); int bit; CHECK_BIT (item); - CHECK_IMPURE (array); + CHECK_LISP_WRITEABLE (array); bit = XINT (item); while (len--) set_bit_vector_bit (v, len, bit); @@ -3444,9 +3391,12 @@ If FILENAME is omitted, the printname of FEATURE is used as the file name. } /* base64 encode/decode functions. - Based on code from GNU recode. */ -#define MIME_LINE_LENGTH 76 + Originally based on code from GNU recode. Ported to FSF Emacs by + Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and + subsequently heavily hacked by Hrvoje Niksic. */ + +#define MIME_LINE_LENGTH 72 #define IS_ASCII(Character) \ ((Character) < 128) @@ -3502,11 +3452,11 @@ static short base64_char_to_value[128] = base64 characters. */ #define ADVANCE_INPUT(c, stream) \ - (ec = Lstream_get_emchar (stream), \ - ec == -1 ? 0 : \ + ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \ ((ec > 255) ? \ - (error ("Non-ascii character detected in base64 input"), 0) \ - : (c = (Bufbyte)ec, 1))) + (signal_simple_error ("Non-ascii character in base64 input", \ + make_char (ec)), 0) \ + : (c = (Bufbyte)ec), 1)) static Bytind base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) @@ -3566,105 +3516,90 @@ base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) } #undef ADVANCE_INPUT -#define ADVANCE_INPUT(c, stream) \ - (ec = Lstream_get_emchar (stream), \ - ec == -1 ? 0 : (c = (Bufbyte)ec, 1)) - -#define INPUT_EOF_P(stream) \ - (ADVANCE_INPUT (c2, stream) \ - ? (Lstream_unget_emchar (stream, (Emchar)c2), 0) \ - : 1) - -#define STORE_BYTE(pos, val) do { \ +/* Get next character from the stream, except that non-base64 + characters are ignored. This is in accordance with rfc2045. EC + should be an Emchar, so that it can hold -1 as the value for EOF. */ +#define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ + ec = Lstream_get_emchar (stream); \ + ++streampos; \ + /* IS_BASE64 may not be called with negative arguments so check for \ + EOF first. */ \ + if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ + break; \ +} while (1) + +#define STORE_BYTE(pos, val, ccnt) do { \ pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \ - ++*ccptr; \ + ++ccnt; \ } while (0) static Bytind base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr) { - EMACS_INT counter = 0; - Emchar ec; + Charcount ccnt = 0; Bufbyte *e = to; - unsigned long value; + EMACS_INT streampos = 0; - *ccptr = 0; while (1) { - Bufbyte c, c2; - - if (!ADVANCE_INPUT (c, istream)) - break; - - /* Accept wrapping lines, reversibly if at each 76 characters. */ - if (c == '\n') - { - if (!ADVANCE_INPUT (c, istream)) - break; - if (INPUT_EOF_P (istream)) - break; - /* FSF Emacs has this check, apparently inherited from - recode. However, I see no reason to be this picky about - line length -- why reject base64 with say 72-byte lines? - (yes, there are programs that generate them.) */ - /*if (counter != MIME_LINE_LENGTH / 4) return -1;*/ - counter = 1; - } - else - counter++; + Emchar ec; + unsigned long value; /* Process first byte of a quadruplet. */ - if (!IS_BASE64 (c)) - return -1; - value = base64_char_to_value[c] << 18; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + break; + if (ec == '=') + signal_simple_error ("Illegal `=' character while decoding base64", + make_int (streampos)); + value = base64_char_to_value[ec] << 18; /* Process second byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; - - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c] << 12; - - STORE_BYTE (e, value >> 16); + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec == '=') + signal_simple_error ("Illegal `=' character while decoding base64", + make_int (streampos)); + value |= base64_char_to_value[ec] << 12; + STORE_BYTE (e, value >> 16, ccnt); /* Process third byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); - if (c == '=') + if (ec == '=') { - if (!ADVANCE_INPUT (c, istream)) - return -1; - if (c != '=') - return -1; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec != '=') + signal_simple_error ("Padding `=' expected but not found while decoding base64", + make_int (streampos)); continue; } - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c] << 6; - - STORE_BYTE (e, 0xff & value >> 8); + value |= base64_char_to_value[ec] << 6; + STORE_BYTE (e, 0xff & value >> 8, ccnt); /* Process fourth byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; - - if (c == '=') + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec == '=') continue; - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c]; - - STORE_BYTE (e, 0xff & value); + value |= base64_char_to_value[ec]; + STORE_BYTE (e, 0xff & value, ccnt); } + *ccptr = ccnt; return e - to; } #undef ADVANCE_INPUT -#undef INPUT_EOF_P +#undef ADVANCE_INPUT_IGNORE_NONBASE64 +#undef STORE_BYTE static Lisp_Object free_malloced_ptr (Lisp_Object unwind_obj) @@ -3741,8 +3676,8 @@ into shorter lines. XMALLOC_UNBIND (encoded, allength, speccount); buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); - /* Simulate FSF Emacs: if point was in the region, place it at the - beginning. */ + /* Simulate FSF Emacs implementation of this function: if point was + in the region, place it at the beginning. */ if (old_pt >= begv && old_pt < zv) BUF_SET_PT (buf, begv); @@ -3783,6 +3718,7 @@ DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* Base64-decode the region between BEG and END. Return the length of the decoded text. If the region can't be decoded, return nil and don't modify the buffer. +Characters out of the base64 alphabet are ignored. */ (beg, end)) { @@ -3807,13 +3743,6 @@ If the region can't be decoded, return nil and don't modify the buffer. abort (); Lstream_delete (XLSTREAM (input)); - if (decoded_length < 0) - { - /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); - return Qnil; - } - /* Now we have decoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ BUF_SET_PT (buf, begv); @@ -3822,8 +3751,8 @@ If the region can't be decoded, return nil and don't modify the buffer. buffer_delete_range (buf, begv + cc_decoded_length, zv + cc_decoded_length, 0); - /* Simulate FSF Emacs: if point was in the region, place it at the - beginning. */ + /* Simulate FSF Emacs implementation of this function: if point was + in the region, place it at the beginning. */ if (old_pt >= begv && old_pt < zv) BUF_SET_PT (buf, begv); @@ -3832,6 +3761,7 @@ If the region can't be decoded, return nil and don't modify the buffer. DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* Base64-decode STRING and return the result. +Characters out of the base64 alphabet are ignored. */ (string)) { @@ -3854,13 +3784,6 @@ Base64-decode STRING and return the result. abort (); Lstream_delete (XLSTREAM (input)); - if (decoded_length < 0) - { - /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); - return Qnil; - } - result = make_string (decoded, decoded_length); XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return result; @@ -3968,4 +3891,6 @@ A list of symbols which are the features of the executing emacs. Used by `featurep' and `require', and altered by `provide'. */ ); Vfeatures = Qnil; + + Fprovide (intern ("base64")); }