static int internal_old_equal (Lisp_Object, Lisp_Object, int);
static Lisp_Object
-mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object))
+mark_bit_vector (Lisp_Object obj)
{
return Qnil;
}
static void
print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
- int i;
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
- int len = bit_vector_length (v);
- int last = len;
+ size_t i;
+ Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ size_t len = bit_vector_length (v);
+ size_t last = len;
if (INTP (Vprint_length))
last = min (len, XINT (Vprint_length));
static int
bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
{
- struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
- struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
+ Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
+ Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
!memcmp (v1->bits, v2->bits,
static unsigned long
bit_vector_hash (Lisp_Object obj, int depth)
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
return HASH2 (bit_vector_length (v),
memory_hash (v->bits,
BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
sizeof (long)));
}
+static const struct lrecord_description bit_vector_description[] = {
+ { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
+ { XD_END }
+};
+
+
DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
mark_bit_vector, print_bit_vector, 0,
bit_vector_equal, bit_vector_hash,
- struct Lisp_Bit_Vector);
+ bit_vector_description,
+ Lisp_Bit_Vector);
\f
DEFUN ("identity", Fidentity, 1, 1, 0, /*
Return the argument unchanged.
return XINT (Flength (seq));
else
{
- struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
+ Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
return (f->flags.interactivep ? COMPILED_INTERACTIVE :
f->flags.domainp ? COMPILED_DOMAIN :
return make_int (XSTRING_CHAR_LENGTH (sequence));
else if (CONSP (sequence))
{
- int len;
+ size_t len;
GET_EXTERNAL_LIST_LENGTH (sequence, len);
return make_int (len);
}
(list))
{
Lisp_Object hare, tortoise;
- int len;
+ size_t len;
for (hare = tortoise = list, len = 0;
CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
(s1, s2))
{
Bytecount len;
- struct Lisp_String *p1, *p2;
+ Lisp_String *p1, *p2;
if (SYMBOLP (s1))
p1 = XSYMBOL (s1)->name;
*/
(s1, s2))
{
- struct Lisp_String *p1, *p2;
+ Lisp_String *p1, *p2;
Charcount end, len2;
int i;
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 */
*/
(string))
{
- struct Lisp_String *s;
+ Lisp_String *s;
CHECK_STRING (string);
s = XSTRING (string);
void
bump_string_modiff (Lisp_Object str)
{
- struct Lisp_String *s = XSTRING (str);
+ Lisp_String *s = XSTRING (str);
Lisp_Object *ptr = &s->plist;
#ifdef I18N3
Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
Lisp_Object last = list_copy;
Lisp_Object hare, tortoise;
- int len;
+ size_t len;
for (tortoise = hare = XCDR (list), len = 1;
CONSP (hare);
(string, from, to))
{
Charcount ccfr, ccto;
- Bytecount bfr, bto;
+ Bytecount bfr, blen;
Lisp_Object val;
CHECK_STRING (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;
}
*/
(seq, from, to))
{
- int len, f, t;
+ EMACS_INT len, f, t;
if (STRINGP (seq))
return Fsubstring (seq, from, to);
if (VECTORP (seq))
{
Lisp_Object result = make_vector (t - f, Qnil);
- int i;
+ EMACS_INT i;
Lisp_Object *in_elts = XVECTOR_DATA (seq);
Lisp_Object *out_elts = XVECTOR_DATA (result);
if (LISTP (seq))
{
Lisp_Object result = Qnil;
- int i;
+ EMACS_INT i;
seq = Fnthcdr (make_int (f), seq);
/* bit vector */
{
Lisp_Object result = make_bit_vector (t - f, Qzero);
- int i;
+ EMACS_INT i;
for (i = f; i < t; i++)
set_bit_vector_bit (XBIT_VECTOR (result), i - f,
*/
(n, list))
{
- REGISTER int i;
+ REGISTER size_t i;
REGISTER Lisp_Object tail = list;
CHECK_NATNUM (n);
for (i = XINT (n); i; i--)
#ifdef LOSING_BYTECODE
else if (COMPILED_FUNCTIONP (sequence))
{
- int idx = XINT (n);
+ EMACS_INT idx = XINT (n);
if (idx < 0)
{
lose:
*/
(list, n))
{
- int int_n, count;
+ EMACS_INT int_n, count;
Lisp_Object retval, tortoise, hare;
CHECK_LIST (list);
*/
(list, n))
{
- int int_n;
+ EMACS_INT int_n;
CHECK_LIST (list);
plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
int laxp, int depth)
{
- int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
+ int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
int la, lb, m, i, fill;
Lisp_Object *keys, *vals;
char *flags;
{
if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
{
- if ((eqp
- /* We narrowly escaped being Ebolified here. */
- ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
- : !internal_equal (v, vals [i], depth)))
+ if (eqp
+ /* We narrowly escaped being Ebolified here. */
+ ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
+ : !internal_equal (v, vals [i], depth))
/* a property in B has a different value than in A */
goto MISMATCH;
flags [i] = 1;
static Lisp_Object *
-string_plist_ptr (struct Lisp_String *s)
+string_plist_ptr (Lisp_String *s)
{
Lisp_Object *ptr = &s->plist;
}
static Lisp_Object
-string_getprop (struct Lisp_String *s, Lisp_Object property,
+string_getprop (Lisp_String *s, Lisp_Object property,
Lisp_Object default_)
{
Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
}
static void
-string_putprop (struct Lisp_String *s, Lisp_Object property,
+string_putprop (Lisp_String *s, Lisp_Object property,
Lisp_Object value)
{
external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
}
static int
-string_remprop (struct Lisp_String *s, Lisp_Object property)
+string_remprop (Lisp_String *s, Lisp_Object property)
{
return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
}
static Lisp_Object
-string_plist (struct Lisp_String *s)
+string_plist (Lisp_String *s)
{
return *string_plist_ptr (s);
}
(object, propname, value))
{
CHECK_SYMBOL (propname);
- CHECK_IMPURE (object);
+ CHECK_LISP_WRITEABLE (object);
if (SYMBOLP (object))
symbol_putprop (object, propname, value);
return value;
}
-void
-pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
-{
- Fput (sym, prop, Fpurecopy (val));
-}
-
DEFUN ("remprop", Fremprop, 2, 2, 0, /*
Remove from OBJECT's property list the property PROPNAME and its
value. OBJECT can be a symbol, face, extent, or string. Returns
int retval = 0;
CHECK_SYMBOL (propname);
- CHECK_IMPURE (object);
+ CHECK_LISP_WRITEABLE (object);
if (SYMBOLP (object))
retval = symbol_remprop (object, propname);
{
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
{
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);
}
\f
DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
-Store each element of ARRAY with ITEM.
+Destructively modify ARRAY by replacing each element with ITEM.
ARRAY is a vector, bit vector, or string.
*/
(array, item))
retry:
if (STRINGP (array))
{
- Emchar charval;
- struct Lisp_String *s = XSTRING (array);
- Charcount len = string_char_length (s);
- Charcount i;
+ Lisp_String *s = XSTRING (array);
+ Bytecount old_bytecount = string_length (s);
+ Bytecount new_bytecount;
+ Bytecount item_bytecount;
+ Bufbyte item_buf[MAX_EMCHAR_LEN];
+ Bufbyte *p;
+ Bufbyte *end;
+
CHECK_CHAR_COERCE_INT (item);
- CHECK_IMPURE (array);
- charval = XCHAR (item);
- for (i = 0; i < len; i++)
- set_string_char (s, i, charval);
+ CHECK_LISP_WRITEABLE (array);
+
+ item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
+ new_bytecount = item_bytecount * string_char_length (s);
+
+ resize_string (s, -1, new_bytecount - old_bytecount);
+
+ for (p = string_data (s), end = p + new_bytecount;
+ p < end;
+ p += item_bytecount)
+ memcpy (p, item_buf, item_bytecount);
+ *p = '\0';
+
bump_string_modiff (array);
}
else if (VECTORP (array))
{
Lisp_Object *p = XVECTOR_DATA (array);
int len = XVECTOR_LENGTH (array);
- CHECK_IMPURE (array);
+ CHECK_LISP_WRITEABLE (array);
while (len--)
*p++ = item;
}
else if (BIT_VECTORP (array))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (array);
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);
}
\f
-/* 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.
+/* This is the guts of several mapping functions.
+ Apply FUNCTION to each element of SEQUENCE, 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 SEQUENCE.
If VALS is a null pointer, do not accumulate the results. */
static void
-mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
+mapcar1 (size_t leni, Lisp_Object *vals,
+ Lisp_Object function, Lisp_Object sequence)
{
Lisp_Object result;
Lisp_Object args[2];
gcpro1.nvars = 0;
}
- args[0] = fn;
+ args[0] = function;
- if (LISTP (seq))
+ if (LISTP (sequence))
{
- for (i = 0; i < leni; i++)
+ /* A devious `function' could either:
+ - insert garbage into the list in front of us, causing XCDR to crash
+ - amputate the list behind us using (setcdr), causing the remaining
+ elts to lose their GCPRO status.
+
+ if (vals != 0) we avoid this by copying the elts into the
+ `vals' array. By a stroke of luck, `vals' is exactly large
+ enough to hold the elts left to be traversed as well as the
+ results computed so far.
+
+ if (vals == 0) we don't have any free space available and
+ don't want to eat up any more stack with alloca().
+ So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
+
+ if (vals)
{
- args[1] = XCAR (seq);
- seq = XCDR (seq);
- result = Ffuncall (2, args);
- if (vals) vals[gcpro1.nvars++] = result;
+ Lisp_Object *val = vals;
+ Lisp_Object elt;
+
+ LIST_LOOP_2 (elt, sequence)
+ *val++ = elt;
+
+ gcpro1.nvars = leni;
+
+ for (i = 0; i < leni; i++)
+ {
+ args[1] = vals[i];
+ vals[i] = Ffuncall (2, args);
+ }
+ }
+ else
+ {
+ Lisp_Object elt, tail;
+ struct gcpro ngcpro1;
+
+ NGCPRO1 (tail);
+
+ {
+ EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
+ {
+ args[1] = elt;
+ Ffuncall (2, args);
+ }
+ }
+
+ NUNGCPRO;
}
}
- else if (VECTORP (seq))
+ else if (VECTORP (sequence))
{
- Lisp_Object *objs = XVECTOR_DATA (seq);
+ Lisp_Object *objs = XVECTOR_DATA (sequence);
for (i = 0; i < leni; i++)
{
args[1] = *objs++;
if (vals) vals[gcpro1.nvars++] = result;
}
}
- else if (STRINGP (seq))
+ else if (STRINGP (sequence))
{
- Bufbyte *p = XSTRING_DATA (seq);
- for (i = 0; i < leni; i++)
+ /* 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;
+
+ memcpy (p, XSTRING_DATA (sequence), slen);
+
+ while (p < end)
{
args[1] = make_char (charptr_emchar (p));
INC_CHARPTR (p);
if (vals) vals[gcpro1.nvars++] = result;
}
}
- else if (BIT_VECTORP (seq))
+ else if (BIT_VECTORP (sequence))
{
- struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
+ Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
for (i = 0; i < leni; i++)
{
args[1] = make_int (bit_vector_bit (v, i));
}
}
else
- abort(); /* cannot get here since Flength(seq) did not get an error */
+ abort(); /* cannot get here since Flength(sequence) did not get an error */
if (vals)
UNGCPRO;
}
DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
-Apply FN to each element of SEQ, and concat the results as strings.
-In between each pair of results, stick in SEP.
-Thus, " " as SEP results in spaces between the values returned by FN.
+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.
*/
- (fn, seq, sep))
+ (function, sequence, separator))
{
- size_t len = XINT (Flength (seq));
+ size_t len = XINT (Flength (sequence));
Lisp_Object *args;
int i;
struct gcpro gcpro1;
args = alloca_array (Lisp_Object, nargs);
- GCPRO1 (sep);
- mapcar1 (len, args, fn, seq);
+ GCPRO1 (separator);
+ mapcar1 (len, args, function, sequence);
UNGCPRO;
for (i = len - 1; i >= 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
- args[i] = sep;
+ args[i] = separator;
return Fconcat (nargs, args);
}
DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
-Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
-The result is a list just as long as SEQUENCE.
+Apply FUNCTION to each element of SEQUENCE; return a list of the results.
+The result is a list of the same length as SEQUENCE.
SEQUENCE may be a list, a vector, a bit vector, or a string.
*/
- (fn, seq))
+ (function, sequence))
{
- size_t len = XINT (Flength (seq));
+ size_t len = XINT (Flength (sequence));
Lisp_Object *args = alloca_array (Lisp_Object, len);
- mapcar1 (len, args, fn, seq);
+ mapcar1 (len, args, function, sequence);
return Flist (len, args);
}
DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
-Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
+Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
The result is a vector of the same length as SEQUENCE.
-SEQUENCE may be a list, a vector or a string.
+SEQUENCE may be a list, a vector, a bit vector, or a string.
*/
- (fn, seq))
+ (function, sequence))
{
- size_t len = XINT (Flength (seq));
+ size_t len = XINT (Flength (sequence));
Lisp_Object result = make_vector (len, Qnil);
struct gcpro gcpro1;
GCPRO1 (result);
- mapcar1 (len, XVECTOR_DATA (result), fn, seq);
+ mapcar1 (len, XVECTOR_DATA (result), function, sequence);
UNGCPRO;
return result;
}
-DEFUN ("mapc", Fmapc, 2, 2, 0, /*
+DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
Apply FUNCTION to each element of SEQUENCE.
SEQUENCE may be a list, a vector, a bit vector, or a string.
This function is like `mapcar' but does not accumulate the results,
which is more efficient if you do not use the results.
+
+The difference between this and `mapc' is that `mapc' supports all
+the spiffy Common Lisp arguments. You should normally use `mapc'.
*/
- (fn, seq))
+ (function, sequence))
{
- mapcar1 (XINT (Flength (seq)), 0, fn, seq);
+ mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
- return seq;
+ return sequence;
}
\f
}
\f
/* 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)
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)
}
#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)
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);
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))
{
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);
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);
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))
{
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;
DEFSUBR (Fnconc);
DEFSUBR (Fmapcar);
DEFSUBR (Fmapvector);
- DEFSUBR (Fmapc);
+ DEFSUBR (Fmapc_internal);
DEFSUBR (Fmapconcat);
DEFSUBR (Fload_average);
DEFSUBR (Ffeaturep);
Used by `featurep' and `require', and altered by `provide'.
*/ );
Vfeatures = Qnil;
+
+ Fprovide (intern ("base64"));
}
projects / chise / xemacs-chise.git.1 / blobdiff