X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=src%2Ffns.c;h=55d5e2fe53efe82bec6b038fd0d6ebe83301e991;hb=5973c2021bef3a9ad59dafb10aef042a349102d4;hp=269ae5e09d659c1dacc434ceb7c1d3015a75f7cd;hpb=77dcef404dc78635f6ffa8f71a803d2bc7cc8921;p=chise%2Fxemacs-chise.git diff --git a/src/fns.c b/src/fns.c index 269ae5e..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); @@ -3037,7 +2984,9 @@ changing the value of `foo'. while (argnum < nargs) { - Lisp_Object val = args[argnum]; + Lisp_Object val; + retry: + val = args[argnum]; if (CONSP (val)) { /* `val' is the first cons, which will be our return value. */ @@ -3048,7 +2997,7 @@ changing the value of `foo'. for (argnum++; argnum < nargs; argnum++) { Lisp_Object next = args[argnum]; - retry: + retry_next: if (CONSP (next) || argnum == nargs -1) { /* (setcdr (last val) next) */ @@ -3073,8 +3022,8 @@ changing the value of `foo'. } else { - next = wrong_type_argument (next, Qlistp); - goto retry; + next = wrong_type_argument (Qlistp, next); + goto retry_next; } } RETURN_UNGCPRO (val); @@ -3084,86 +3033,84 @@ changing the value of `foo'. else if (argnum == nargs - 1) /* last arg? */ RETURN_UNGCPRO (val); else - args[argnum] = wrong_type_argument (val, Qlistp); + { + args[argnum] = wrong_type_argument (Qlistp, val); + goto retry; + } } RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ } /* This is the guts of all mapping functions. - Apply fn to each element of seq, one by one, - storing the results into elements of vals, a C vector of Lisp_Objects. - leni is the length of vals, which should also be the length of seq. + Apply fn to each element of seq, one by one, + storing the results into elements of vals, a C vector of Lisp_Objects. + leni is the length of vals, which should also be the length of seq. - If VALS is a null pointer, do not accumulate the results. */ + If VALS is a null pointer, do not accumulate the results. */ static void -mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) +mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { - Lisp_Object tail; - Lisp_Object dummy = Qnil; - int i; - struct gcpro gcpro1, gcpro2, gcpro3; Lisp_Object result; - - GCPRO3 (dummy, fn, seq); + Lisp_Object args[2]; + int i; + struct gcpro gcpro1; if (vals) { - /* Don't let vals contain any garbage when GC happens. */ - for (i = 0; i < leni; i++) - vals[i] = Qnil; - gcpro1.var = vals; - gcpro1.nvars = leni; + GCPRO1 (vals[0]); + gcpro1.nvars = 0; } - /* We need not explicitly protect `tail' because it is used only on - lists, and 1) lists are not relocated and 2) the list is marked - via `seq' so will not be freed */ + args[0] = fn; - if (VECTORP (seq)) + if (LISTP (seq)) { for (i = 0; i < leni; i++) { - dummy = XVECTOR_DATA (seq)[i]; - result = call1 (fn, dummy); - if (vals) - vals[i] = result; + args[1] = XCAR (seq); + seq = XCDR (seq); + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } - else if (BIT_VECTORP (seq)) + else if (VECTORP (seq)) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); + Lisp_Object *objs = XVECTOR_DATA (seq); for (i = 0; i < leni; i++) { - XSETINT (dummy, bit_vector_bit (v, i)); - result = call1 (fn, dummy); - if (vals) - vals[i] = result; + args[1] = *objs++; + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } else if (STRINGP (seq)) { + Bufbyte *p = XSTRING_DATA (seq); for (i = 0; i < leni; i++) { - result = call1 (fn, make_char (string_char (XSTRING (seq), i))); - if (vals) - vals[i] = result; + args[1] = make_char (charptr_emchar (p)); + INC_CHARPTR (p); + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } - else /* Must be a list, since Flength did not get an error */ + else if (BIT_VECTORP (seq)) { - tail = seq; + struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); for (i = 0; i < leni; i++) { - result = call1 (fn, Fcar (tail)); - if (vals) - vals[i] = result; - tail = Fcdr (tail); + args[1] = make_int (bit_vector_bit (v, i)); + result = Ffuncall (2, args); + if (vals) vals[gcpro1.nvars++] = result; } } + else + abort(); /* cannot get here since Flength(seq) did not get an error */ - UNGCPRO; + if (vals) + UNGCPRO; } DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* @@ -3173,7 +3120,7 @@ Thus, " " as SEP results in spaces between the values returned by FN. */ (fn, seq, sep)) { - int len = XINT (Flength (seq)); + size_t len = XINT (Flength (seq)); Lisp_Object *args; int i; struct gcpro gcpro1; @@ -3203,7 +3150,7 @@ SEQUENCE may be a list, a vector, a bit vector, or a string. */ (fn, seq)) { - int len = XINT (Flength (seq)); + size_t len = XINT (Flength (seq)); Lisp_Object *args = alloca_array (Lisp_Object, len); mapcar1 (len, args, fn, seq); @@ -3218,9 +3165,7 @@ SEQUENCE may be a list, a vector or a string. */ (fn, seq)) { - int len = XINT (Flength (seq)); - /* Ideally, this should call make_vector_internal, because we don't - need initialization. */ + size_t len = XINT (Flength (seq)); Lisp_Object result = make_vector (len, Qnil); struct gcpro gcpro1; @@ -3446,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) @@ -3504,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) @@ -3564,114 +3512,94 @@ base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) *e++ = base64_value_to_char[0x3f & c]; } - /* Complete last partial line. */ - if (line_break) - if (counter > 0) - *e++ = '\n'; - return e - to; } #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) @@ -3748,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); @@ -3757,10 +3685,10 @@ into shorter lines. return make_int (encoded_length); } -DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 1, 0, /* +DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* Base64 encode STRING and return the result. */ - (string)) + (string, no_line_break)) { Charcount allength, length; Bytind encoded_length; @@ -3771,11 +3699,13 @@ Base64 encode STRING and return the result. CHECK_STRING (string); length = XSTRING_CHAR_LENGTH (string); - allength = length + length/3 + 1 + 6; + allength = length + length/3 + 1; + allength += allength / MIME_LINE_LENGTH + 1 + 6; input = make_lisp_string_input_stream (string, 0, -1); XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte); - encoded_length = base64_encode_1 (XLSTREAM (input), encoded, 0); + encoded_length = base64_encode_1 (XLSTREAM (input), encoded, + NILP (no_line_break)); if (encoded_length > allength) abort (); Lstream_delete (XLSTREAM (input)); @@ -3788,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)) { @@ -3812,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); @@ -3827,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); @@ -3837,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)) { @@ -3859,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; @@ -3973,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")); }