(object, propname, value))
{
CHECK_SYMBOL (propname);
- CHECK_IMPURE (object);
+ CHECK_LISP_WRITEABLE (object);
if (SYMBOLP (object))
symbol_putprop (object, propname, value);
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);
}
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);
{
Lisp_Object *p = XVECTOR_DATA (array);
int len = XVECTOR_LENGTH (array);
- CHECK_IMPURE (array);
+ CHECK_LISP_WRITEABLE (array);
while (len--)
*p++ = item;
}
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);
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. */
for (argnum++; argnum < nargs; argnum++)
{
Lisp_Object next = args[argnum];
- retry:
+ retry_next:
if (CONSP (next) || argnum == nargs -1)
{
/* (setcdr (last val) next) */
}
else
{
- next = wrong_type_argument (next, Qlistp);
- goto retry;
+ next = wrong_type_argument (Qlistp, next);
+ goto retry_next;
}
}
RETURN_UNGCPRO (val);
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. */
}
\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.
+ 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, /*
*/
(fn, seq, sep))
{
- int len = XINT (Flength (seq));
+ size_t len = XINT (Flength (seq));
Lisp_Object *args;
int i;
struct gcpro gcpro1;
*/
(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);
*/
(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;
*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
(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 { \
pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
++*ccptr; \
static Bytind
base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
{
- EMACS_INT counter = 0;
Emchar ec;
Bufbyte *e = to;
unsigned long value;
*ccptr = 0;
while (1)
{
- Bufbyte c, c2;
+ Bufbyte c;
if (!ADVANCE_INPUT (c, istream))
break;
- /* Accept wrapping lines, reversibly if at each 76 characters. */
+ /* Accept wrapping lines. */
+ if (c == '\r')
+ {
+ if (!ADVANCE_INPUT (c, istream)
+ || c != '\n')
+ return -1;
+ }
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;
+ /* FSF checks for end of text here, but that's wrong. */
+ /* FSF checks for correct line length here; that's also
+ wrong; some MIME encoders use different line lengths. */
}
- else
- counter++;
/* Process first byte of a quadruplet. */
if (!IS_BASE64 (c))
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;
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));
Used by `featurep' and `require', and altered by `provide'.
*/ );
Vfeatures = Qnil;
+
+ Fprovide (intern ("base64"));
}
projects / chise / xemacs-chise.git / blobdiff