comparison src/fns.c @ 428:3ecd8885ac67 r21-2-22

Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 9d177e8d4150
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
10 later version.
11
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 /* Synched up with: Mule 2.0, FSF 19.30. */
23
24 /* This file has been Mule-ized. */
25
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
27
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
29
30 #include <config.h>
31
32 /* Note on some machines this defines `vector' as a typedef,
33 so make sure we don't use that name in this file. */
34 #undef vector
35 #define vector *****
36
37 #include "lisp.h"
38
39 #ifdef HAVE_UNISTD_H
40 #include <unistd.h>
41 #endif
42 #include <errno.h>
43
44 #include "buffer.h"
45 #include "bytecode.h"
46 #include "device.h"
47 #include "events.h"
48 #include "extents.h"
49 #include "frame.h"
50 #include "systime.h"
51 #include "insdel.h"
52 #include "lstream.h"
53 #include "opaque.h"
54
55 /* NOTE: This symbol is also used in lread.c */
56 #define FEATUREP_SYNTAX
57
58 Lisp_Object Qstring_lessp;
59 Lisp_Object Qidentity;
60
61 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
62
63 static Lisp_Object
64 mark_bit_vector (Lisp_Object obj)
65 {
66 return Qnil;
67 }
68
69 static void
70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
71 {
72 size_t i;
73 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
74 size_t len = bit_vector_length (v);
75 size_t last = len;
76
77 if (INTP (Vprint_length))
78 last = min (len, XINT (Vprint_length));
79 write_c_string ("#*", printcharfun);
80 for (i = 0; i < last; i++)
81 {
82 if (bit_vector_bit (v, i))
83 write_c_string ("1", printcharfun);
84 else
85 write_c_string ("0", printcharfun);
86 }
87
88 if (last != len)
89 write_c_string ("...", printcharfun);
90 }
91
92 static int
93 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
94 {
95 struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
96 struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
97
98 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
99 !memcmp (v1->bits, v2->bits,
100 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
101 sizeof (long)));
102 }
103
104 static unsigned long
105 bit_vector_hash (Lisp_Object obj, int depth)
106 {
107 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
108 return HASH2 (bit_vector_length (v),
109 memory_hash (v->bits,
110 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
111 sizeof (long)));
112 }
113
114 static const struct lrecord_description bit_vector_description[] = {
115 { XD_LISP_OBJECT, offsetof(Lisp_Bit_Vector, next), 1 },
116 { XD_END }
117 };
118
119
120 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector,
121 mark_bit_vector, print_bit_vector, 0,
122 bit_vector_equal, bit_vector_hash,
123 bit_vector_description,
124 struct Lisp_Bit_Vector);
125
126 DEFUN ("identity", Fidentity, 1, 1, 0, /*
127 Return the argument unchanged.
128 */
129 (arg))
130 {
131 return arg;
132 }
133
134 extern long get_random (void);
135 extern void seed_random (long arg);
136
137 DEFUN ("random", Frandom, 0, 1, 0, /*
138 Return a pseudo-random number.
139 All integers representable in Lisp are equally likely.
140 On most systems, this is 28 bits' worth.
141 With positive integer argument N, return random number in interval [0,N).
142 With argument t, set the random number seed from the current time and pid.
143 */
144 (limit))
145 {
146 EMACS_INT val;
147 unsigned long denominator;
148
149 if (EQ (limit, Qt))
150 seed_random (getpid () + time (NULL));
151 if (NATNUMP (limit) && !ZEROP (limit))
152 {
153 /* Try to take our random number from the higher bits of VAL,
154 not the lower, since (says Gentzel) the low bits of `random'
155 are less random than the higher ones. We do this by using the
156 quotient rather than the remainder. At the high end of the RNG
157 it's possible to get a quotient larger than limit; discarding
158 these values eliminates the bias that would otherwise appear
159 when using a large limit. */
160 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
161 do
162 val = get_random () / denominator;
163 while (val >= XINT (limit));
164 }
165 else
166 val = get_random ();
167
168 return make_int (val);
169 }
170
171 /* Random data-structure functions */
172
173 #ifdef LOSING_BYTECODE
174
175 /* #### Delete this shit */
176
177 /* Charcount is a misnomer here as we might be dealing with the
178 length of a vector or list, but emphasizes that we're not dealing
179 with Bytecounts in strings */
180 static Charcount
181 length_with_bytecode_hack (Lisp_Object seq)
182 {
183 if (!COMPILED_FUNCTIONP (seq))
184 return XINT (Flength (seq));
185 else
186 {
187 struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
188
189 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
190 f->flags.domainp ? COMPILED_DOMAIN :
191 COMPILED_DOC_STRING)
192 + 1;
193 }
194 }
195
196 #endif /* LOSING_BYTECODE */
197
198 void
199 check_losing_bytecode (CONST char *function, Lisp_Object seq)
200 {
201 if (COMPILED_FUNCTIONP (seq))
202 error_with_frob
203 (seq,
204 "As of 20.3, `%s' no longer works with compiled-function objects",
205 function);
206 }
207
208 DEFUN ("length", Flength, 1, 1, 0, /*
209 Return the length of vector, bit vector, list or string SEQUENCE.
210 */
211 (sequence))
212 {
213 retry:
214 if (STRINGP (sequence))
215 return make_int (XSTRING_CHAR_LENGTH (sequence));
216 else if (CONSP (sequence))
217 {
218 size_t len;
219 GET_EXTERNAL_LIST_LENGTH (sequence, len);
220 return make_int (len);
221 }
222 else if (VECTORP (sequence))
223 return make_int (XVECTOR_LENGTH (sequence));
224 else if (NILP (sequence))
225 return Qzero;
226 else if (BIT_VECTORP (sequence))
227 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
228 else
229 {
230 check_losing_bytecode ("length", sequence);
231 sequence = wrong_type_argument (Qsequencep, sequence);
232 goto retry;
233 }
234 }
235
236 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
237 Return the length of a list, but avoid error or infinite loop.
238 This function never gets an error. If LIST is not really a list,
239 it returns 0. If LIST is circular, it returns a finite value
240 which is at least the number of distinct elements.
241 */
242 (list))
243 {
244 Lisp_Object hare, tortoise;
245 size_t len;
246
247 for (hare = tortoise = list, len = 0;
248 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
249 hare = XCDR (hare), len++)
250 {
251 if (len & 1)
252 tortoise = XCDR (tortoise);
253 }
254
255 return make_int (len);
256 }
257
258 /*** string functions. ***/
259
260 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
261 Return t if two strings have identical contents.
262 Case is significant. Text properties are ignored.
263 \(Under XEmacs, `equal' also ignores text properties and extents in
264 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
265 `equal' is the same as in XEmacs, in that respect.)
266 Symbols are also allowed; their print names are used instead.
267 */
268 (s1, s2))
269 {
270 Bytecount len;
271 struct Lisp_String *p1, *p2;
272
273 if (SYMBOLP (s1))
274 p1 = XSYMBOL (s1)->name;
275 else
276 {
277 CHECK_STRING (s1);
278 p1 = XSTRING (s1);
279 }
280
281 if (SYMBOLP (s2))
282 p2 = XSYMBOL (s2)->name;
283 else
284 {
285 CHECK_STRING (s2);
286 p2 = XSTRING (s2);
287 }
288
289 return (((len = string_length (p1)) == string_length (p2)) &&
290 !memcmp (string_data (p1), string_data (p2), len)) ? Qt : Qnil;
291 }
292
293
294 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
295 Return t if first arg string is less than second in lexicographic order.
296 If I18N2 support (but not Mule support) was compiled in, ordering is
297 determined by the locale. (Case is significant for the default C locale.)
298 In all other cases, comparison is simply done on a character-by-
299 character basis using the numeric value of a character. (Note that
300 this may not produce particularly meaningful results under Mule if
301 characters from different charsets are being compared.)
302
303 Symbols are also allowed; their print names are used instead.
304
305 The reason that the I18N2 locale-specific collation is not used under
306 Mule is that the locale model of internationalization does not handle
307 multiple charsets and thus has no hope of working properly under Mule.
308 What we really should do is create a collation table over all built-in
309 charsets. This is extremely difficult to do from scratch, however.
310
311 Unicode is a good first step towards solving this problem. In fact,
312 it is quite likely that a collation table exists (or will exist) for
313 Unicode. When Unicode support is added to XEmacs/Mule, this problem
314 may be solved.
315 */
316 (s1, s2))
317 {
318 struct Lisp_String *p1, *p2;
319 Charcount end, len2;
320 int i;
321
322 if (SYMBOLP (s1))
323 p1 = XSYMBOL (s1)->name;
324 else
325 {
326 CHECK_STRING (s1);
327 p1 = XSTRING (s1);
328 }
329
330 if (SYMBOLP (s2))
331 p2 = XSYMBOL (s2)->name;
332 else
333 {
334 CHECK_STRING (s2);
335 p2 = XSTRING (s2);
336 }
337
338 end = string_char_length (p1);
339 len2 = string_char_length (p2);
340 if (end > len2)
341 end = len2;
342
343 #if defined (I18N2) && !defined (MULE)
344 /* There is no hope of this working under Mule. Even if we converted
345 the data into an external format so that strcoll() processed it
346 properly, it would still not work because strcoll() does not
347 handle multiple locales. This is the fundamental flaw in the
348 locale model. */
349 {
350 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
351 /* Compare strings using collation order of locale. */
352 /* Need to be tricky to handle embedded nulls. */
353
354 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
355 {
356 int val = strcoll ((char *) string_data (p1) + i,
357 (char *) string_data (p2) + i);
358 if (val < 0)
359 return Qt;
360 if (val > 0)
361 return Qnil;
362 }
363 }
364 #else /* not I18N2, or MULE */
365 {
366 Bufbyte *ptr1 = string_data (p1);
367 Bufbyte *ptr2 = string_data (p2);
368
369 /* #### It is not really necessary to do this: We could compare
370 byte-by-byte and still get a reasonable comparison, since this
371 would compare characters with a charset in the same way. With
372 a little rearrangement of the leading bytes, we could make most
373 inter-charset comparisons work out the same, too; even if some
374 don't, this is not a big deal because inter-charset comparisons
375 aren't really well-defined anyway. */
376 for (i = 0; i < end; i++)
377 {
378 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
379 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
380 INC_CHARPTR (ptr1);
381 INC_CHARPTR (ptr2);
382 }
383 }
384 #endif /* not I18N2, or MULE */
385 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
386 won't work right in I18N2 case */
387 return end < len2 ? Qt : Qnil;
388 }
389
390 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
391 Return STRING's tick counter, incremented for each change to the string.
392 Each string has a tick counter which is incremented each time the contents
393 of the string are changed (e.g. with `aset'). It wraps around occasionally.
394 */
395 (string))
396 {
397 struct Lisp_String *s;
398
399 CHECK_STRING (string);
400 s = XSTRING (string);
401 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
402 return XCAR (s->plist);
403 else
404 return Qzero;
405 }
406
407 void
408 bump_string_modiff (Lisp_Object str)
409 {
410 struct Lisp_String *s = XSTRING (str);
411 Lisp_Object *ptr = &s->plist;
412
413 #ifdef I18N3
414 /* #### remove the `string-translatable' property from the string,
415 if there is one. */
416 #endif
417 /* skip over extent info if it's there */
418 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
419 ptr = &XCDR (*ptr);
420 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
421 XSETINT (XCAR (*ptr), 1+XINT (XCAR (*ptr)));
422 else
423 *ptr = Fcons (make_int (1), *ptr);
424 }
425
426
427 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
428 static Lisp_Object concat (int nargs, Lisp_Object *args,
429 enum concat_target_type target_type,
430 int last_special);
431
432 Lisp_Object
433 concat2 (Lisp_Object s1, Lisp_Object s2)
434 {
435 Lisp_Object args[2];
436 args[0] = s1;
437 args[1] = s2;
438 return concat (2, args, c_string, 0);
439 }
440
441 Lisp_Object
442 concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
443 {
444 Lisp_Object args[3];
445 args[0] = s1;
446 args[1] = s2;
447 args[2] = s3;
448 return concat (3, args, c_string, 0);
449 }
450
451 Lisp_Object
452 vconcat2 (Lisp_Object s1, Lisp_Object s2)
453 {
454 Lisp_Object args[2];
455 args[0] = s1;
456 args[1] = s2;
457 return concat (2, args, c_vector, 0);
458 }
459
460 Lisp_Object
461 vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3)
462 {
463 Lisp_Object args[3];
464 args[0] = s1;
465 args[1] = s2;
466 args[2] = s3;
467 return concat (3, args, c_vector, 0);
468 }
469
470 DEFUN ("append", Fappend, 0, MANY, 0, /*
471 Concatenate all the arguments and make the result a list.
472 The result is a list whose elements are the elements of all the arguments.
473 Each argument may be a list, vector, bit vector, or string.
474 The last argument is not copied, just used as the tail of the new list.
475 Also see: `nconc'.
476 */
477 (int nargs, Lisp_Object *args))
478 {
479 return concat (nargs, args, c_cons, 1);
480 }
481
482 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
483 Concatenate all the arguments and make the result a string.
484 The result is a string whose elements are the elements of all the arguments.
485 Each argument may be a string or a list or vector of characters.
486
487 As of XEmacs 21.0, this function does NOT accept individual integers
488 as arguments. Old code that relies on, for example, (concat "foo" 50)
489 returning "foo50" will fail. To fix such code, either apply
490 `int-to-string' to the integer argument, or use `format'.
491 */
492 (int nargs, Lisp_Object *args))
493 {
494 return concat (nargs, args, c_string, 0);
495 }
496
497 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
498 Concatenate all the arguments and make the result a vector.
499 The result is a vector whose elements are the elements of all the arguments.
500 Each argument may be a list, vector, bit vector, or string.
501 */
502 (int nargs, Lisp_Object *args))
503 {
504 return concat (nargs, args, c_vector, 0);
505 }
506
507 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
508 Concatenate all the arguments and make the result a bit vector.
509 The result is a bit vector whose elements are the elements of all the
510 arguments. Each argument may be a list, vector, bit vector, or string.
511 */
512 (int nargs, Lisp_Object *args))
513 {
514 return concat (nargs, args, c_bit_vector, 0);
515 }
516
517 /* Copy a (possibly dotted) list. LIST must be a cons.
518 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
519 static Lisp_Object
520 copy_list (Lisp_Object list)
521 {
522 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
523 Lisp_Object last = list_copy;
524 Lisp_Object hare, tortoise;
525 size_t len;
526
527 for (tortoise = hare = XCDR (list), len = 1;
528 CONSP (hare);
529 hare = XCDR (hare), len++)
530 {
531 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
532 last = XCDR (last);
533
534 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
535 continue;
536 if (len & 1)
537 tortoise = XCDR (tortoise);
538 if (EQ (tortoise, hare))
539 signal_circular_list_error (list);
540 }
541
542 return list_copy;
543 }
544
545 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
546 Return a copy of list LIST, which may be a dotted list.
547 The elements of LIST are not copied; they are shared
548 with the original.
549 */
550 (list))
551 {
552 again:
553 if (NILP (list)) return list;
554 if (CONSP (list)) return copy_list (list);
555
556 list = wrong_type_argument (Qlistp, list);
557 goto again;
558 }
559
560 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
561 Return a copy of list, vector, bit vector or string SEQUENCE.
562 The elements of a list or vector are not copied; they are shared
563 with the original. SEQUENCE may be a dotted list.
564 */
565 (sequence))
566 {
567 again:
568 if (NILP (sequence)) return sequence;
569 if (CONSP (sequence)) return copy_list (sequence);
570 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
571 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
572 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
573
574 check_losing_bytecode ("copy-sequence", sequence);
575 sequence = wrong_type_argument (Qsequencep, sequence);
576 goto again;
577 }
578
579 struct merge_string_extents_struct
580 {
581 Lisp_Object string;
582 Bytecount entry_offset;
583 Bytecount entry_length;
584 };
585
586 static Lisp_Object
587 concat (int nargs, Lisp_Object *args,
588 enum concat_target_type target_type,
589 int last_special)
590 {
591 Lisp_Object val;
592 Lisp_Object tail = Qnil;
593 int toindex;
594 int argnum;
595 Lisp_Object last_tail;
596 Lisp_Object prev;
597 struct merge_string_extents_struct *args_mse = 0;
598 Bufbyte *string_result = 0;
599 Bufbyte *string_result_ptr = 0;
600 struct gcpro gcpro1;
601
602 /* The modus operandi in Emacs is "caller gc-protects args".
603 However, concat is called many times in Emacs on freshly
604 created stuff. So we help those callers out by protecting
605 the args ourselves to save them a lot of temporary-variable
606 grief. */
607
608 GCPRO1 (args[0]);
609 gcpro1.nvars = nargs;
610
611 #ifdef I18N3
612 /* #### if the result is a string and any of the strings have a string
613 for the `string-translatable' property, then concat should also
614 concat the args but use the `string-translatable' strings, and store
615 the result in the returned string's `string-translatable' property. */
616 #endif
617 if (target_type == c_string)
618 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
619
620 /* In append, the last arg isn't treated like the others */
621 if (last_special && nargs > 0)
622 {
623 nargs--;
624 last_tail = args[nargs];
625 }
626 else
627 last_tail = Qnil;
628
629 /* Check and coerce the arguments. */
630 for (argnum = 0; argnum < nargs; argnum++)
631 {
632 Lisp_Object seq = args[argnum];
633 if (LISTP (seq))
634 ;
635 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
636 ;
637 #ifdef LOSING_BYTECODE
638 else if (COMPILED_FUNCTIONP (seq))
639 /* Urk! We allow this, for "compatibility"... */
640 ;
641 #endif
642 #if 0 /* removed for XEmacs 21 */
643 else if (INTP (seq))
644 /* This is too revolting to think about but maintains
645 compatibility with FSF (and lots and lots of old code). */
646 args[argnum] = Fnumber_to_string (seq);
647 #endif
648 else
649 {
650 check_losing_bytecode ("concat", seq);
651 args[argnum] = wrong_type_argument (Qsequencep, seq);
652 }
653
654 if (args_mse)
655 {
656 if (STRINGP (seq))
657 args_mse[argnum].string = seq;
658 else
659 args_mse[argnum].string = Qnil;
660 }
661 }
662
663 {
664 /* Charcount is a misnomer here as we might be dealing with the
665 length of a vector or list, but emphasizes that we're not dealing
666 with Bytecounts in strings */
667 Charcount total_length;
668
669 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
670 {
671 #ifdef LOSING_BYTECODE
672 Charcount thislen = length_with_bytecode_hack (args[argnum]);
673 #else
674 Charcount thislen = XINT (Flength (args[argnum]));
675 #endif
676 total_length += thislen;
677 }
678
679 switch (target_type)
680 {
681 case c_cons:
682 if (total_length == 0)
683 /* In append, if all but last arg are nil, return last arg */
684 RETURN_UNGCPRO (last_tail);
685 val = Fmake_list (make_int (total_length), Qnil);
686 break;
687 case c_vector:
688 val = make_vector (total_length, Qnil);
689 break;
690 case c_bit_vector:
691 val = make_bit_vector (total_length, Qzero);
692 break;
693 case c_string:
694 /* We don't make the string yet because we don't know the
695 actual number of bytes. This loop was formerly written
696 to call Fmake_string() here and then call set_string_char()
697 for each char. This seems logical enough but is waaaaaaaay
698 slow -- set_string_char() has to scan the whole string up
699 to the place where the substitution is called for in order
700 to find the place to change, and may have to do some
701 realloc()ing in order to make the char fit properly.
702 O(N^2) yuckage. */
703 val = Qnil;
704 string_result = (Bufbyte *) alloca (total_length * MAX_EMCHAR_LEN);
705 string_result_ptr = string_result;
706 break;
707 default:
708 abort ();
709 }
710 }
711
712
713 if (CONSP (val))
714 tail = val, toindex = -1; /* -1 in toindex is flag we are
715 making a list */
716 else
717 toindex = 0;
718
719 prev = Qnil;
720
721 for (argnum = 0; argnum < nargs; argnum++)
722 {
723 Charcount thisleni = 0;
724 Charcount thisindex = 0;
725 Lisp_Object seq = args[argnum];
726 Bufbyte *string_source_ptr = 0;
727 Bufbyte *string_prev_result_ptr = string_result_ptr;
728
729 if (!CONSP (seq))
730 {
731 #ifdef LOSING_BYTECODE
732 thisleni = length_with_bytecode_hack (seq);
733 #else
734 thisleni = XINT (Flength (seq));
735 #endif
736 }
737 if (STRINGP (seq))
738 string_source_ptr = XSTRING_DATA (seq);
739
740 while (1)
741 {
742 Lisp_Object elt;
743
744 /* We've come to the end of this arg, so exit. */
745 if (NILP (seq))
746 break;
747
748 /* Fetch next element of `seq' arg into `elt' */
749 if (CONSP (seq))
750 {
751 elt = XCAR (seq);
752 seq = XCDR (seq);
753 }
754 else
755 {
756 if (thisindex >= thisleni)
757 break;
758
759 if (STRINGP (seq))
760 {
761 elt = make_char (charptr_emchar (string_source_ptr));
762 INC_CHARPTR (string_source_ptr);
763 }
764 else if (VECTORP (seq))
765 elt = XVECTOR_DATA (seq)[thisindex];
766 else if (BIT_VECTORP (seq))
767 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
768 thisindex));
769 else
770 elt = Felt (seq, make_int (thisindex));
771 thisindex++;
772 }
773
774 /* Store into result */
775 if (toindex < 0)
776 {
777 /* toindex negative means we are making a list */
778 XCAR (tail) = elt;
779 prev = tail;
780 tail = XCDR (tail);
781 }
782 else if (VECTORP (val))
783 XVECTOR_DATA (val)[toindex++] = elt;
784 else if (BIT_VECTORP (val))
785 {
786 CHECK_BIT (elt);
787 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
788 }
789 else
790 {
791 CHECK_CHAR_COERCE_INT (elt);
792 string_result_ptr += set_charptr_emchar (string_result_ptr,
793 XCHAR (elt));
794 }
795 }
796 if (args_mse)
797 {
798 args_mse[argnum].entry_offset =
799 string_prev_result_ptr - string_result;
800 args_mse[argnum].entry_length =
801 string_result_ptr - string_prev_result_ptr;
802 }
803 }
804
805 /* Now we finally make the string. */
806 if (target_type == c_string)
807 {
808 val = make_string (string_result, string_result_ptr - string_result);
809 for (argnum = 0; argnum < nargs; argnum++)
810 {
811 if (STRINGP (args_mse[argnum].string))
812 copy_string_extents (val, args_mse[argnum].string,
813 args_mse[argnum].entry_offset, 0,
814 args_mse[argnum].entry_length);
815 }
816 }
817
818 if (!NILP (prev))
819 XCDR (prev) = last_tail;
820
821 RETURN_UNGCPRO (val);
822 }
823
824 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
825 Return a copy of ALIST.
826 This is an alist which represents the same mapping from objects to objects,
827 but does not share the alist structure with ALIST.
828 The objects mapped (cars and cdrs of elements of the alist)
829 are shared, however.
830 Elements of ALIST that are not conses are also shared.
831 */
832 (alist))
833 {
834 Lisp_Object tail;
835
836 if (NILP (alist))
837 return alist;
838 CHECK_CONS (alist);
839
840 alist = concat (1, &alist, c_cons, 0);
841 for (tail = alist; CONSP (tail); tail = XCDR (tail))
842 {
843 Lisp_Object car = XCAR (tail);
844
845 if (CONSP (car))
846 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
847 }
848 return alist;
849 }
850
851 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
852 Return a copy of a list and substructures.
853 The argument is copied, and any lists contained within it are copied
854 recursively. Circularities and shared substructures are not preserved.
855 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
856 are not copied.
857 */
858 (arg, vecp))
859 {
860 if (CONSP (arg))
861 {
862 Lisp_Object rest;
863 rest = arg = Fcopy_sequence (arg);
864 while (CONSP (rest))
865 {
866 Lisp_Object elt = XCAR (rest);
867 QUIT;
868 if (CONSP (elt) || VECTORP (elt))
869 XCAR (rest) = Fcopy_tree (elt, vecp);
870 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
871 XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
872 rest = XCDR (rest);
873 }
874 }
875 else if (VECTORP (arg) && ! NILP (vecp))
876 {
877 int i = XVECTOR_LENGTH (arg);
878 int j;
879 arg = Fcopy_sequence (arg);
880 for (j = 0; j < i; j++)
881 {
882 Lisp_Object elt = XVECTOR_DATA (arg) [j];
883 QUIT;
884 if (CONSP (elt) || VECTORP (elt))
885 XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp);
886 }
887 }
888 return arg;
889 }
890
891 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
892 Return a substring of STRING, starting at index FROM and ending before TO.
893 TO may be nil or omitted; then the substring runs to the end of STRING.
894 If FROM or TO is negative, it counts from the end.
895 Relevant parts of the string-extent-data are copied in the new string.
896 */
897 (string, from, to))
898 {
899 Charcount ccfr, ccto;
900 Bytecount bfr, blen;
901 Lisp_Object val;
902
903 CHECK_STRING (string);
904 CHECK_INT (from);
905 get_string_range_char (string, from, to, &ccfr, &ccto,
906 GB_HISTORICAL_STRING_BEHAVIOR);
907 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
908 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
909 val = make_string (XSTRING_DATA (string) + bfr, blen);
910 /* Copy any applicable extent information into the new string: */
911 copy_string_extents (val, string, 0, bfr, blen);
912 return val;
913 }
914
915 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
916 Return a subsequence of SEQ, starting at index FROM and ending before TO.
917 TO may be nil or omitted; then the subsequence runs to the end of SEQ.
918 If FROM or TO is negative, it counts from the end.
919 The resulting subsequence is always the same type as the original
920 sequence.
921 If SEQ is a string, relevant parts of the string-extent-data are copied
922 to the new string.
923 */
924 (seq, from, to))
925 {
926 EMACS_INT len, f, t;
927
928 if (STRINGP (seq))
929 return Fsubstring (seq, from, to);
930
931 if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq))
932 {
933 check_losing_bytecode ("subseq", seq);
934 seq = wrong_type_argument (Qsequencep, seq);
935 }
936
937 len = XINT (Flength (seq));
938
939 CHECK_INT (from);
940 f = XINT (from);
941 if (f < 0)
942 f = len + f;
943
944 if (NILP (to))
945 t = len;
946 else
947 {
948 CHECK_INT (to);
949 t = XINT (to);
950 if (t < 0)
951 t = len + t;
952 }
953
954 if (!(0 <= f && f <= t && t <= len))
955 args_out_of_range_3 (seq, make_int (f), make_int (t));
956
957 if (VECTORP (seq))
958 {
959 Lisp_Object result = make_vector (t - f, Qnil);
960 EMACS_INT i;
961 Lisp_Object *in_elts = XVECTOR_DATA (seq);
962 Lisp_Object *out_elts = XVECTOR_DATA (result);
963
964 for (i = f; i < t; i++)
965 out_elts[i - f] = in_elts[i];
966 return result;
967 }
968
969 if (LISTP (seq))
970 {
971 Lisp_Object result = Qnil;
972 EMACS_INT i;
973
974 seq = Fnthcdr (make_int (f), seq);
975
976 for (i = f; i < t; i++)
977 {
978 result = Fcons (Fcar (seq), result);
979 seq = Fcdr (seq);
980 }
981
982 return Fnreverse (result);
983 }
984
985 /* bit vector */
986 {
987 Lisp_Object result = make_bit_vector (t - f, Qzero);
988 EMACS_INT i;
989
990 for (i = f; i < t; i++)
991 set_bit_vector_bit (XBIT_VECTOR (result), i - f,
992 bit_vector_bit (XBIT_VECTOR (seq), i));
993 return result;
994 }
995 }
996
997
998 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
999 Take cdr N times on LIST, and return the result.
1000 */
1001 (n, list))
1002 {
1003 REGISTER size_t i;
1004 REGISTER Lisp_Object tail = list;
1005 CHECK_NATNUM (n);
1006 for (i = XINT (n); i; i--)
1007 {
1008 if (CONSP (tail))
1009 tail = XCDR (tail);
1010 else if (NILP (tail))
1011 return Qnil;
1012 else
1013 {
1014 tail = wrong_type_argument (Qlistp, tail);
1015 i++;
1016 }
1017 }
1018 return tail;
1019 }
1020
1021 DEFUN ("nth", Fnth, 2, 2, 0, /*
1022 Return the Nth element of LIST.
1023 N counts from zero. If LIST is not that long, nil is returned.
1024 */
1025 (n, list))
1026 {
1027 return Fcar (Fnthcdr (n, list));
1028 }
1029
1030 DEFUN ("elt", Felt, 2, 2, 0, /*
1031 Return element of SEQUENCE at index N.
1032 */
1033 (sequence, n))
1034 {
1035 retry:
1036 CHECK_INT_COERCE_CHAR (n); /* yuck! */
1037 if (LISTP (sequence))
1038 {
1039 Lisp_Object tem = Fnthcdr (n, sequence);
1040 /* #### Utterly, completely, fucking disgusting.
1041 * #### The whole point of "elt" is that it operates on
1042 * #### sequences, and does error- (bounds-) checking.
1043 */
1044 if (CONSP (tem))
1045 return XCAR (tem);
1046 else
1047 #if 1
1048 /* This is The Way It Has Always Been. */
1049 return Qnil;
1050 #else
1051 /* This is The Way Mly and Cltl2 say It Should Be. */
1052 args_out_of_range (sequence, n);
1053 #endif
1054 }
1055 else if (STRINGP (sequence) ||
1056 VECTORP (sequence) ||
1057 BIT_VECTORP (sequence))
1058 return Faref (sequence, n);
1059 #ifdef LOSING_BYTECODE
1060 else if (COMPILED_FUNCTIONP (sequence))
1061 {
1062 EMACS_INT idx = XINT (n);
1063 if (idx < 0)
1064 {
1065 lose:
1066 args_out_of_range (sequence, n);
1067 }
1068 /* Utter perversity */
1069 {
1070 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
1071 switch (idx)
1072 {
1073 case COMPILED_ARGLIST:
1074 return compiled_function_arglist (f);
1075 case COMPILED_INSTRUCTIONS:
1076 return compiled_function_instructions (f);
1077 case COMPILED_CONSTANTS:
1078 return compiled_function_constants (f);
1079 case COMPILED_STACK_DEPTH:
1080 return compiled_function_stack_depth (f);
1081 case COMPILED_DOC_STRING:
1082 return compiled_function_documentation (f);
1083 case COMPILED_DOMAIN:
1084 return compiled_function_domain (f);
1085 case COMPILED_INTERACTIVE:
1086 if (f->flags.interactivep)
1087 return compiled_function_interactive (f);
1088 /* if we return nil, can't tell interactive with no args
1089 from noninteractive. */
1090 goto lose;
1091 default:
1092 goto lose;
1093 }
1094 }
1095 }
1096 #endif /* LOSING_BYTECODE */
1097 else
1098 {
1099 check_losing_bytecode ("elt", sequence);
1100 sequence = wrong_type_argument (Qsequencep, sequence);
1101 goto retry;
1102 }
1103 }
1104
1105 DEFUN ("last", Flast, 1, 2, 0, /*
1106 Return the tail of list LIST, of length N (default 1).
1107 LIST may be a dotted list, but not a circular list.
1108 Optional argument N must be a non-negative integer.
1109 If N is zero, then the atom that terminates the list is returned.
1110 If N is greater than the length of LIST, then LIST itself is returned.
1111 */
1112 (list, n))
1113 {
1114 EMACS_INT int_n, count;
1115 Lisp_Object retval, tortoise, hare;
1116
1117 CHECK_LIST (list);
1118
1119 if (NILP (n))
1120 int_n = 1;
1121 else
1122 {
1123 CHECK_NATNUM (n);
1124 int_n = XINT (n);
1125 }
1126
1127 for (retval = tortoise = hare = list, count = 0;
1128 CONSP (hare);
1129 hare = XCDR (hare),
1130 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
1131 count++)
1132 {
1133 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
1134
1135 if (count & 1)
1136 tortoise = XCDR (tortoise);
1137 if (EQ (hare, tortoise))
1138 signal_circular_list_error (list);
1139 }
1140
1141 return retval;
1142 }
1143
1144 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
1145 Modify LIST to remove the last N (default 1) elements.
1146 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1147 */
1148 (list, n))
1149 {
1150 EMACS_INT int_n;
1151
1152 CHECK_LIST (list);
1153
1154 if (NILP (n))
1155 int_n = 1;
1156 else
1157 {
1158 CHECK_NATNUM (n);
1159 int_n = XINT (n);
1160 }
1161
1162 {
1163 Lisp_Object last_cons = list;
1164
1165 EXTERNAL_LIST_LOOP_1 (list)
1166 {
1167 if (int_n-- < 0)
1168 last_cons = XCDR (last_cons);
1169 }
1170
1171 if (int_n >= 0)
1172 return Qnil;
1173
1174 XCDR (last_cons) = Qnil;
1175 return list;
1176 }
1177 }
1178
1179 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
1180 Return a copy of LIST with the last N (default 1) elements removed.
1181 If LIST has N or fewer elements, nil is returned.
1182 */
1183 (list, n))
1184 {
1185 int int_n;
1186
1187 CHECK_LIST (list);
1188
1189 if (NILP (n))
1190 int_n = 1;
1191 else
1192 {
1193 CHECK_NATNUM (n);
1194 int_n = XINT (n);
1195 }
1196
1197 {
1198 Lisp_Object retval = Qnil;
1199 Lisp_Object tail = list;
1200
1201 EXTERNAL_LIST_LOOP_1 (list)
1202 {
1203 if (--int_n < 0)
1204 {
1205 retval = Fcons (XCAR (tail), retval);
1206 tail = XCDR (tail);
1207 }
1208 }
1209
1210 return Fnreverse (retval);
1211 }
1212 }
1213
1214 DEFUN ("member", Fmember, 2, 2, 0, /*
1215 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
1216 The value is actually the tail of LIST whose car is ELT.
1217 */
1218 (elt, list))
1219 {
1220 Lisp_Object list_elt, tail;
1221 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1222 {
1223 if (internal_equal (elt, list_elt, 0))
1224 return tail;
1225 }
1226 return Qnil;
1227 }
1228
1229 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
1230 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
1231 The value is actually the tail of LIST whose car is ELT.
1232 This function is provided only for byte-code compatibility with v19.
1233 Do not use it.
1234 */
1235 (elt, list))
1236 {
1237 Lisp_Object list_elt, tail;
1238 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1239 {
1240 if (internal_old_equal (elt, list_elt, 0))
1241 return tail;
1242 }
1243 return Qnil;
1244 }
1245
1246 DEFUN ("memq", Fmemq, 2, 2, 0, /*
1247 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
1248 The value is actually the tail of LIST whose car is ELT.
1249 */
1250 (elt, list))
1251 {
1252 Lisp_Object list_elt, tail;
1253 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1254 {
1255 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1256 return tail;
1257 }
1258 return Qnil;
1259 }
1260
1261 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
1262 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
1263 The value is actually the tail of LIST whose car is ELT.
1264 This function is provided only for byte-code compatibility with v19.
1265 Do not use it.
1266 */
1267 (elt, list))
1268 {
1269 Lisp_Object list_elt, tail;
1270 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
1271 {
1272 if (HACKEQ_UNSAFE (elt, list_elt))
1273 return tail;
1274 }
1275 return Qnil;
1276 }
1277
1278 Lisp_Object
1279 memq_no_quit (Lisp_Object elt, Lisp_Object list)
1280 {
1281 Lisp_Object list_elt, tail;
1282 LIST_LOOP_3 (list_elt, list, tail)
1283 {
1284 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
1285 return tail;
1286 }
1287 return Qnil;
1288 }
1289
1290 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
1291 Return non-nil if KEY is `equal' to the car of an element of LIST.
1292 The value is actually the element of LIST whose car equals KEY.
1293 */
1294 (key, list))
1295 {
1296 /* This function can GC. */
1297 Lisp_Object elt, elt_car, elt_cdr;
1298 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1299 {
1300 if (internal_equal (key, elt_car, 0))
1301 return elt;
1302 }
1303 return Qnil;
1304 }
1305
1306 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
1307 Return non-nil if KEY is `old-equal' to the car of an element of LIST.
1308 The value is actually the element of LIST whose car equals KEY.
1309 */
1310 (key, list))
1311 {
1312 /* This function can GC. */
1313 Lisp_Object elt, elt_car, elt_cdr;
1314 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1315 {
1316 if (internal_old_equal (key, elt_car, 0))
1317 return elt;
1318 }
1319 return Qnil;
1320 }
1321
1322 Lisp_Object
1323 assoc_no_quit (Lisp_Object key, Lisp_Object list)
1324 {
1325 int speccount = specpdl_depth ();
1326 specbind (Qinhibit_quit, Qt);
1327 return unbind_to (speccount, Fassoc (key, list));
1328 }
1329
1330 DEFUN ("assq", Fassq, 2, 2, 0, /*
1331 Return non-nil if KEY is `eq' to the car of an element of LIST.
1332 The value is actually the element of LIST whose car is KEY.
1333 Elements of LIST that are not conses are ignored.
1334 */
1335 (key, list))
1336 {
1337 Lisp_Object elt, elt_car, elt_cdr;
1338 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1339 {
1340 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1341 return elt;
1342 }
1343 return Qnil;
1344 }
1345
1346 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
1347 Return non-nil if KEY is `old-eq' to the car of an element of LIST.
1348 The value is actually the element of LIST whose car is KEY.
1349 Elements of LIST that are not conses are ignored.
1350 This function is provided only for byte-code compatibility with v19.
1351 Do not use it.
1352 */
1353 (key, list))
1354 {
1355 Lisp_Object elt, elt_car, elt_cdr;
1356 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1357 {
1358 if (HACKEQ_UNSAFE (key, elt_car))
1359 return elt;
1360 }
1361 return Qnil;
1362 }
1363
1364 /* Like Fassq but never report an error and do not allow quits.
1365 Use only on lists known never to be circular. */
1366
1367 Lisp_Object
1368 assq_no_quit (Lisp_Object key, Lisp_Object list)
1369 {
1370 /* This cannot GC. */
1371 Lisp_Object elt;
1372 LIST_LOOP_2 (elt, list)
1373 {
1374 Lisp_Object elt_car = XCAR (elt);
1375 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
1376 return elt;
1377 }
1378 return Qnil;
1379 }
1380
1381 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
1382 Return non-nil if KEY is `equal' to the cdr of an element of LIST.
1383 The value is actually the element of LIST whose cdr equals KEY.
1384 */
1385 (key, list))
1386 {
1387 Lisp_Object elt, elt_car, elt_cdr;
1388 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1389 {
1390 if (internal_equal (key, elt_cdr, 0))
1391 return elt;
1392 }
1393 return Qnil;
1394 }
1395
1396 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
1397 Return non-nil if KEY is `old-equal' to the cdr of an element of LIST.
1398 The value is actually the element of LIST whose cdr equals KEY.
1399 */
1400 (key, list))
1401 {
1402 Lisp_Object elt, elt_car, elt_cdr;
1403 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1404 {
1405 if (internal_old_equal (key, elt_cdr, 0))
1406 return elt;
1407 }
1408 return Qnil;
1409 }
1410
1411 DEFUN ("rassq", Frassq, 2, 2, 0, /*
1412 Return non-nil if KEY is `eq' to the cdr of an element of LIST.
1413 The value is actually the element of LIST whose cdr is KEY.
1414 */
1415 (key, list))
1416 {
1417 Lisp_Object elt, elt_car, elt_cdr;
1418 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1419 {
1420 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1421 return elt;
1422 }
1423 return Qnil;
1424 }
1425
1426 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
1427 Return non-nil if KEY is `old-eq' to the cdr of an element of LIST.
1428 The value is actually the element of LIST whose cdr is KEY.
1429 */
1430 (key, list))
1431 {
1432 Lisp_Object elt, elt_car, elt_cdr;
1433 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list)
1434 {
1435 if (HACKEQ_UNSAFE (key, elt_cdr))
1436 return elt;
1437 }
1438 return Qnil;
1439 }
1440
1441 /* Like Frassq, but caller must ensure that LIST is properly
1442 nil-terminated and ebola-free. */
1443 Lisp_Object
1444 rassq_no_quit (Lisp_Object key, Lisp_Object list)
1445 {
1446 Lisp_Object elt;
1447 LIST_LOOP_2 (elt, list)
1448 {
1449 Lisp_Object elt_cdr = XCDR (elt);
1450 if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr))
1451 return elt;
1452 }
1453 return Qnil;
1454 }
1455
1456
1457 DEFUN ("delete", Fdelete, 2, 2, 0, /*
1458 Delete by side effect any occurrences of ELT as a member of LIST.
1459 The modified LIST is returned. Comparison is done with `equal'.
1460 If the first member of LIST is ELT, there is no way to remove it by side
1461 effect; therefore, write `(setq foo (delete element foo))' to be sure
1462 of changing the value of `foo'.
1463 Also see: `remove'.
1464 */
1465 (elt, list))
1466 {
1467 Lisp_Object list_elt;
1468 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1469 (internal_equal (elt, list_elt, 0)));
1470 return list;
1471 }
1472
1473 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
1474 Delete by side effect any occurrences of ELT as a member of LIST.
1475 The modified LIST is returned. Comparison is done with `old-equal'.
1476 If the first member of LIST is ELT, there is no way to remove it by side
1477 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
1478 of changing the value of `foo'.
1479 */
1480 (elt, list))
1481 {
1482 Lisp_Object list_elt;
1483 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1484 (internal_old_equal (elt, list_elt, 0)));
1485 return list;
1486 }
1487
1488 DEFUN ("delq", Fdelq, 2, 2, 0, /*
1489 Delete by side effect any occurrences of ELT as a member of LIST.
1490 The modified LIST is returned. Comparison is done with `eq'.
1491 If the first member of LIST is ELT, there is no way to remove it by side
1492 effect; therefore, write `(setq foo (delq element foo))' to be sure of
1493 changing the value of `foo'.
1494 */
1495 (elt, list))
1496 {
1497 Lisp_Object list_elt;
1498 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1499 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1500 return list;
1501 }
1502
1503 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
1504 Delete by side effect any occurrences of ELT as a member of LIST.
1505 The modified LIST is returned. Comparison is done with `old-eq'.
1506 If the first member of LIST is ELT, there is no way to remove it by side
1507 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
1508 changing the value of `foo'.
1509 */
1510 (elt, list))
1511 {
1512 Lisp_Object list_elt;
1513 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
1514 (HACKEQ_UNSAFE (elt, list_elt)));
1515 return list;
1516 }
1517
1518 /* Like Fdelq, but caller must ensure that LIST is properly
1519 nil-terminated and ebola-free. */
1520
1521 Lisp_Object
1522 delq_no_quit (Lisp_Object elt, Lisp_Object list)
1523 {
1524 Lisp_Object list_elt;
1525 LIST_LOOP_DELETE_IF (list_elt, list,
1526 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
1527 return list;
1528 }
1529
1530 /* Be VERY careful with this. This is like delq_no_quit() but
1531 also calls free_cons() on the removed conses. You must be SURE
1532 that no pointers to the freed conses remain around (e.g.
1533 someone else is pointing to part of the list). This function
1534 is useful on internal lists that are used frequently and where
1535 the actual list doesn't escape beyond known code bounds. */
1536
1537 Lisp_Object
1538 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
1539 {
1540 REGISTER Lisp_Object tail = list;
1541 REGISTER Lisp_Object prev = Qnil;
1542
1543 while (!NILP (tail))
1544 {
1545 REGISTER Lisp_Object tem = XCAR (tail);
1546 if (EQ (elt, tem))
1547 {
1548 Lisp_Object cons_to_free = tail;
1549 if (NILP (prev))
1550 list = XCDR (tail);
1551 else
1552 XCDR (prev) = XCDR (tail);
1553 tail = XCDR (tail);
1554 free_cons (XCONS (cons_to_free));
1555 }
1556 else
1557 {
1558 prev = tail;
1559 tail = XCDR (tail);
1560 }
1561 }
1562 return list;
1563 }
1564
1565 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
1566 Delete by side effect any elements of LIST whose car is `equal' to KEY.
1567 The modified LIST is returned. If the first member of LIST has a car
1568 that is `equal' to KEY, there is no way to remove it by side effect;
1569 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
1570 the value of `foo'.
1571 */
1572 (key, list))
1573 {
1574 Lisp_Object elt;
1575 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1576 (CONSP (elt) &&
1577 internal_equal (key, XCAR (elt), 0)));
1578 return list;
1579 }
1580
1581 Lisp_Object
1582 remassoc_no_quit (Lisp_Object key, Lisp_Object list)
1583 {
1584 int speccount = specpdl_depth ();
1585 specbind (Qinhibit_quit, Qt);
1586 return unbind_to (speccount, Fremassoc (key, list));
1587 }
1588
1589 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
1590 Delete by side effect any elements of LIST whose car is `eq' to KEY.
1591 The modified LIST is returned. If the first member of LIST has a car
1592 that is `eq' to KEY, there is no way to remove it by side effect;
1593 therefore, write `(setq foo (remassq key foo))' to be sure of changing
1594 the value of `foo'.
1595 */
1596 (key, list))
1597 {
1598 Lisp_Object elt;
1599 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1600 (CONSP (elt) &&
1601 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1602 return list;
1603 }
1604
1605 /* no quit, no errors; be careful */
1606
1607 Lisp_Object
1608 remassq_no_quit (Lisp_Object key, Lisp_Object list)
1609 {
1610 Lisp_Object elt;
1611 LIST_LOOP_DELETE_IF (elt, list,
1612 (CONSP (elt) &&
1613 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
1614 return list;
1615 }
1616
1617 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
1618 Delete by side effect any elements of LIST whose cdr is `equal' to VALUE.
1619 The modified LIST is returned. If the first member of LIST has a car
1620 that is `equal' to VALUE, there is no way to remove it by side effect;
1621 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
1622 the value of `foo'.
1623 */
1624 (value, list))
1625 {
1626 Lisp_Object elt;
1627 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1628 (CONSP (elt) &&
1629 internal_equal (value, XCDR (elt), 0)));
1630 return list;
1631 }
1632
1633 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
1634 Delete by side effect any elements of LIST whose cdr is `eq' to VALUE.
1635 The modified LIST is returned. If the first member of LIST has a car
1636 that is `eq' to VALUE, there is no way to remove it by side effect;
1637 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
1638 the value of `foo'.
1639 */
1640 (value, list))
1641 {
1642 Lisp_Object elt;
1643 EXTERNAL_LIST_LOOP_DELETE_IF (elt, list,
1644 (CONSP (elt) &&
1645 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1646 return list;
1647 }
1648
1649 /* Like Fremrassq, fast and unsafe; be careful */
1650 Lisp_Object
1651 remrassq_no_quit (Lisp_Object value, Lisp_Object list)
1652 {
1653 Lisp_Object elt;
1654 LIST_LOOP_DELETE_IF (elt, list,
1655 (CONSP (elt) &&
1656 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
1657 return list;
1658 }
1659
1660 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
1661 Reverse LIST by destructively modifying cdr pointers.
1662 Return the beginning of the reversed list.
1663 Also see: `reverse'.
1664 */
1665 (list))
1666 {
1667 struct gcpro gcpro1, gcpro2;
1668 REGISTER Lisp_Object prev = Qnil;
1669 REGISTER Lisp_Object tail = list;
1670
1671 /* We gcpro our args; see `nconc' */
1672 GCPRO2 (prev, tail);
1673 while (!NILP (tail))
1674 {
1675 REGISTER Lisp_Object next;
1676 CONCHECK_CONS (tail);
1677 next = XCDR (tail);
1678 XCDR (tail) = prev;
1679 prev = tail;
1680 tail = next;
1681 }
1682 UNGCPRO;
1683 return prev;
1684 }
1685
1686 DEFUN ("reverse", Freverse, 1, 1, 0, /*
1687 Reverse LIST, copying. Return the beginning of the reversed list.
1688 See also the function `nreverse', which is used more often.
1689 */
1690 (list))
1691 {
1692 Lisp_Object reversed_list = Qnil;
1693 Lisp_Object elt;
1694 EXTERNAL_LIST_LOOP_2 (elt, list)
1695 {
1696 reversed_list = Fcons (elt, reversed_list);
1697 }
1698 return reversed_list;
1699 }
1700
1701 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1702 Lisp_Object lisp_arg,
1703 int (*pred_fn) (Lisp_Object, Lisp_Object,
1704 Lisp_Object lisp_arg));
1705
1706 Lisp_Object
1707 list_sort (Lisp_Object list,
1708 Lisp_Object lisp_arg,
1709 int (*pred_fn) (Lisp_Object, Lisp_Object,
1710 Lisp_Object lisp_arg))
1711 {
1712 struct gcpro gcpro1, gcpro2, gcpro3;
1713 Lisp_Object back, tem;
1714 Lisp_Object front = list;
1715 Lisp_Object len = Flength (list);
1716 int length = XINT (len);
1717
1718 if (length < 2)
1719 return list;
1720
1721 XSETINT (len, (length / 2) - 1);
1722 tem = Fnthcdr (len, list);
1723 back = Fcdr (tem);
1724 Fsetcdr (tem, Qnil);
1725
1726 GCPRO3 (front, back, lisp_arg);
1727 front = list_sort (front, lisp_arg, pred_fn);
1728 back = list_sort (back, lisp_arg, pred_fn);
1729 UNGCPRO;
1730 return list_merge (front, back, lisp_arg, pred_fn);
1731 }
1732
1733
1734 static int
1735 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
1736 Lisp_Object pred)
1737 {
1738 Lisp_Object tmp;
1739
1740 /* prevents the GC from happening in call2 */
1741 int speccount = specpdl_depth ();
1742 /* Emacs' GC doesn't actually relocate pointers, so this probably
1743 isn't strictly necessary */
1744 record_unwind_protect (restore_gc_inhibit,
1745 make_int (gc_currently_forbidden));
1746 gc_currently_forbidden = 1;
1747 tmp = call2 (pred, obj1, obj2);
1748 unbind_to (speccount, Qnil);
1749
1750 if (NILP (tmp))
1751 return -1;
1752 else
1753 return 1;
1754 }
1755
1756 DEFUN ("sort", Fsort, 2, 2, 0, /*
1757 Sort LIST, stably, comparing elements using PREDICATE.
1758 Returns the sorted list. LIST is modified by side effects.
1759 PREDICATE is called with two elements of LIST, and should return T
1760 if the first element is "less" than the second.
1761 */
1762 (list, pred))
1763 {
1764 return list_sort (list, pred, merge_pred_function);
1765 }
1766
1767 Lisp_Object
1768 merge (Lisp_Object org_l1, Lisp_Object org_l2,
1769 Lisp_Object pred)
1770 {
1771 return list_merge (org_l1, org_l2, pred, merge_pred_function);
1772 }
1773
1774
1775 static Lisp_Object
1776 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
1777 Lisp_Object lisp_arg,
1778 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
1779 {
1780 Lisp_Object value;
1781 Lisp_Object tail;
1782 Lisp_Object tem;
1783 Lisp_Object l1, l2;
1784 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1785
1786 l1 = org_l1;
1787 l2 = org_l2;
1788 tail = Qnil;
1789 value = Qnil;
1790
1791 /* It is sufficient to protect org_l1 and org_l2.
1792 When l1 and l2 are updated, we copy the new values
1793 back into the org_ vars. */
1794
1795 GCPRO4 (org_l1, org_l2, lisp_arg, value);
1796
1797 while (1)
1798 {
1799 if (NILP (l1))
1800 {
1801 UNGCPRO;
1802 if (NILP (tail))
1803 return l2;
1804 Fsetcdr (tail, l2);
1805 return value;
1806 }
1807 if (NILP (l2))
1808 {
1809 UNGCPRO;
1810 if (NILP (tail))
1811 return l1;
1812 Fsetcdr (tail, l1);
1813 return value;
1814 }
1815
1816 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
1817 {
1818 tem = l1;
1819 l1 = Fcdr (l1);
1820 org_l1 = l1;
1821 }
1822 else
1823 {
1824 tem = l2;
1825 l2 = Fcdr (l2);
1826 org_l2 = l2;
1827 }
1828 if (NILP (tail))
1829 value = tem;
1830 else
1831 Fsetcdr (tail, tem);
1832 tail = tem;
1833 }
1834 }
1835
1836
1837 /************************************************************************/
1838 /* property-list functions */
1839 /************************************************************************/
1840
1841 /* For properties of text, we need to do order-insensitive comparison of
1842 plists. That is, we need to compare two plists such that they are the
1843 same if they have the same set of keys, and equivalent values.
1844 So (a 1 b 2) would be equal to (b 2 a 1).
1845
1846 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1847 LAXP means use `equal' for comparisons.
1848 */
1849 int
1850 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1851 int laxp, int depth)
1852 {
1853 int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
1854 int la, lb, m, i, fill;
1855 Lisp_Object *keys, *vals;
1856 char *flags;
1857 Lisp_Object rest;
1858
1859 if (NILP (a) && NILP (b))
1860 return 0;
1861
1862 Fcheck_valid_plist (a);
1863 Fcheck_valid_plist (b);
1864
1865 la = XINT (Flength (a));
1866 lb = XINT (Flength (b));
1867 m = (la > lb ? la : lb);
1868 fill = 0;
1869 keys = alloca_array (Lisp_Object, m);
1870 vals = alloca_array (Lisp_Object, m);
1871 flags = alloca_array (char, m);
1872
1873 /* First extract the pairs from A. */
1874 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
1875 {
1876 Lisp_Object k = XCAR (rest);
1877 Lisp_Object v = XCAR (XCDR (rest));
1878 /* Maybe be Ebolified. */
1879 if (nil_means_not_present && NILP (v)) continue;
1880 keys [fill] = k;
1881 vals [fill] = v;
1882 flags[fill] = 0;
1883 fill++;
1884 }
1885 /* Now iterate over B, and stop if we find something that's not in A,
1886 or that doesn't match. As we match, mark them. */
1887 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
1888 {
1889 Lisp_Object k = XCAR (rest);
1890 Lisp_Object v = XCAR (XCDR (rest));
1891 /* Maybe be Ebolified. */
1892 if (nil_means_not_present && NILP (v)) continue;
1893 for (i = 0; i < fill; i++)
1894 {
1895 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1896 {
1897 if ((eqp
1898 /* We narrowly escaped being Ebolified here. */
1899 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1900 : !internal_equal (v, vals [i], depth)))
1901 /* a property in B has a different value than in A */
1902 goto MISMATCH;
1903 flags [i] = 1;
1904 break;
1905 }
1906 }
1907 if (i == fill)
1908 /* there are some properties in B that are not in A */
1909 goto MISMATCH;
1910 }
1911 /* Now check to see that all the properties in A were also in B */
1912 for (i = 0; i < fill; i++)
1913 if (flags [i] == 0)
1914 goto MISMATCH;
1915
1916 /* Ok. */
1917 return 0;
1918
1919 MISMATCH:
1920 return 1;
1921 }
1922
1923 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
1924 Return non-nil if property lists A and B are `eq'.
1925 A property list is an alternating list of keywords and values.
1926 This function does order-insensitive comparisons of the property lists:
1927 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1928 Comparison between values is done using `eq'. See also `plists-equal'.
1929 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1930 a nil value is ignored. This feature is a virus that has infected
1931 old Lisp implementations, but should not be used except for backward
1932 compatibility.
1933 */
1934 (a, b, nil_means_not_present))
1935 {
1936 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
1937 ? Qnil : Qt);
1938 }
1939
1940 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
1941 Return non-nil if property lists A and B are `equal'.
1942 A property list is an alternating list of keywords and values. This
1943 function does order-insensitive comparisons of the property lists: For
1944 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1945 Comparison between values is done using `equal'. See also `plists-eq'.
1946 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1947 a nil value is ignored. This feature is a virus that has infected
1948 old Lisp implementations, but should not be used except for backward
1949 compatibility.
1950 */
1951 (a, b, nil_means_not_present))
1952 {
1953 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
1954 ? Qnil : Qt);
1955 }
1956
1957
1958 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
1959 Return non-nil if lax property lists A and B are `eq'.
1960 A property list is an alternating list of keywords and values.
1961 This function does order-insensitive comparisons of the property lists:
1962 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1963 Comparison between values is done using `eq'. See also `plists-equal'.
1964 A lax property list is like a regular one except that comparisons between
1965 keywords is done using `equal' instead of `eq'.
1966 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1967 a nil value is ignored. This feature is a virus that has infected
1968 old Lisp implementations, but should not be used except for backward
1969 compatibility.
1970 */
1971 (a, b, nil_means_not_present))
1972 {
1973 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
1974 ? Qnil : Qt);
1975 }
1976
1977 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
1978 Return non-nil if lax property lists A and B are `equal'.
1979 A property list is an alternating list of keywords and values. This
1980 function does order-insensitive comparisons of the property lists: For
1981 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
1982 Comparison between values is done using `equal'. See also `plists-eq'.
1983 A lax property list is like a regular one except that comparisons between
1984 keywords is done using `equal' instead of `eq'.
1985 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
1986 a nil value is ignored. This feature is a virus that has infected
1987 old Lisp implementations, but should not be used except for backward
1988 compatibility.
1989 */
1990 (a, b, nil_means_not_present))
1991 {
1992 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
1993 ? Qnil : Qt);
1994 }
1995
1996 /* Return the value associated with key PROPERTY in property list PLIST.
1997 Return nil if key not found. This function is used for internal
1998 property lists that cannot be directly manipulated by the user.
1999 */
2000
2001 Lisp_Object
2002 internal_plist_get (Lisp_Object plist, Lisp_Object property)
2003 {
2004 Lisp_Object tail;
2005
2006 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2007 {
2008 if (EQ (XCAR (tail), property))
2009 return XCAR (XCDR (tail));
2010 }
2011
2012 return Qunbound;
2013 }
2014
2015 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
2016 internal_plist_get(). */
2017
2018 void
2019 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
2020 Lisp_Object value)
2021 {
2022 Lisp_Object tail;
2023
2024 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
2025 {
2026 if (EQ (XCAR (tail), property))
2027 {
2028 XCAR (XCDR (tail)) = value;
2029 return;
2030 }
2031 }
2032
2033 *plist = Fcons (property, Fcons (value, *plist));
2034 }
2035
2036 int
2037 internal_remprop (Lisp_Object *plist, Lisp_Object property)
2038 {
2039 Lisp_Object tail, prev;
2040
2041 for (tail = *plist, prev = Qnil;
2042 !NILP (tail);
2043 tail = XCDR (XCDR (tail)))
2044 {
2045 if (EQ (XCAR (tail), property))
2046 {
2047 if (NILP (prev))
2048 *plist = XCDR (XCDR (tail));
2049 else
2050 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
2051 return 1;
2052 }
2053 else
2054 prev = tail;
2055 }
2056
2057 return 0;
2058 }
2059
2060 /* Called on a malformed property list. BADPLACE should be some
2061 place where truncating will form a good list -- i.e. we shouldn't
2062 result in a list with an odd length. */
2063
2064 static Lisp_Object
2065 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2066 {
2067 if (ERRB_EQ (errb, ERROR_ME))
2068 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
2069 else
2070 {
2071 if (ERRB_EQ (errb, ERROR_ME_WARN))
2072 {
2073 warn_when_safe_lispobj
2074 (Qlist, Qwarning,
2075 list2 (build_string
2076 ("Malformed property list -- list has been truncated"),
2077 *plist));
2078 *badplace = Qnil;
2079 }
2080 return Qunbound;
2081 }
2082 }
2083
2084 /* Called on a circular property list. BADPLACE should be some place
2085 where truncating will result in an even-length list, as above.
2086 If doesn't particularly matter where we truncate -- anywhere we
2087 truncate along the entire list will break the circularity, because
2088 it will create a terminus and the list currently doesn't have one.
2089 */
2090
2091 static Lisp_Object
2092 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb)
2093 {
2094 if (ERRB_EQ (errb, ERROR_ME))
2095 /* #### Eek, this will probably result in another error
2096 when PLIST is printed out */
2097 return Fsignal (Qcircular_property_list, list1 (*plist));
2098 else
2099 {
2100 if (ERRB_EQ (errb, ERROR_ME_WARN))
2101 {
2102 warn_when_safe_lispobj
2103 (Qlist, Qwarning,
2104 list2 (build_string
2105 ("Circular property list -- list has been truncated"),
2106 *plist));
2107 *badplace = Qnil;
2108 }
2109 return Qunbound;
2110 }
2111 }
2112
2113 /* Advance the tortoise pointer by two (one iteration of a property-list
2114 loop) and the hare pointer by four and verify that no malformations
2115 or circularities exist. If so, return zero and store a value into
2116 RETVAL that should be returned by the calling function. Otherwise,
2117 return 1. See external_plist_get().
2118 */
2119
2120 static int
2121 advance_plist_pointers (Lisp_Object *plist,
2122 Lisp_Object **tortoise, Lisp_Object **hare,
2123 Error_behavior errb, Lisp_Object *retval)
2124 {
2125 int i;
2126 Lisp_Object *tortsave = *tortoise;
2127
2128 /* Note that our "fixing" may be more brutal than necessary,
2129 but it's the user's own problem, not ours, if they went in and
2130 manually fucked up a plist. */
2131
2132 for (i = 0; i < 2; i++)
2133 {
2134 /* This is a standard iteration of a defensive-loop-checking
2135 loop. We just do it twice because we want to advance past
2136 both the property and its value.
2137
2138 If the pointer indirection is confusing you, remember that
2139 one level of indirection on the hare and tortoise pointers
2140 is only due to pass-by-reference for this function. The other
2141 level is so that the plist can be fixed in place. */
2142
2143 /* When we reach the end of a well-formed plist, **HARE is
2144 nil. In that case, we don't do anything at all except
2145 advance TORTOISE by one. Otherwise, we advance HARE
2146 by two (making sure it's OK to do so), then advance
2147 TORTOISE by one (it will always be OK to do so because
2148 the HARE is always ahead of the TORTOISE and will have
2149 already verified the path), then make sure TORTOISE and
2150 HARE don't contain the same non-nil object -- if the
2151 TORTOISE and the HARE ever meet, then obviously we're
2152 in a circularity, and if we're in a circularity, then
2153 the TORTOISE and the HARE can't cross paths without
2154 meeting, since the HARE only gains one step over the
2155 TORTOISE per iteration. */
2156
2157 if (!NILP (**hare))
2158 {
2159 Lisp_Object *haresave = *hare;
2160 if (!CONSP (**hare))
2161 {
2162 *retval = bad_bad_bunny (plist, haresave, errb);
2163 return 0;
2164 }
2165 *hare = &XCDR (**hare);
2166 /* In a non-plist, we'd check here for a nil value for
2167 **HARE, which is OK (it just means the list has an
2168 odd number of elements). In a plist, it's not OK
2169 for the list to have an odd number of elements. */
2170 if (!CONSP (**hare))
2171 {
2172 *retval = bad_bad_bunny (plist, haresave, errb);
2173 return 0;
2174 }
2175 *hare = &XCDR (**hare);
2176 }
2177
2178 *tortoise = &XCDR (**tortoise);
2179 if (!NILP (**hare) && EQ (**tortoise, **hare))
2180 {
2181 *retval = bad_bad_turtle (plist, tortsave, errb);
2182 return 0;
2183 }
2184 }
2185
2186 return 1;
2187 }
2188
2189 /* Return the value of PROPERTY from PLIST, or Qunbound if
2190 property is not on the list.
2191
2192 PLIST is a Lisp-accessible property list, meaning that it
2193 has to be checked for malformations and circularities.
2194
2195 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
2196 function will never signal an error; and if ERRB is ERROR_ME_WARN,
2197 on finding a malformation or a circularity, it issues a warning and
2198 attempts to silently fix the problem.
2199
2200 A pointer to PLIST is passed in so that PLIST can be successfully
2201 "fixed" even if the error is at the beginning of the plist. */
2202
2203 Lisp_Object
2204 external_plist_get (Lisp_Object *plist, Lisp_Object property,
2205 int laxp, Error_behavior errb)
2206 {
2207 Lisp_Object *tortoise = plist;
2208 Lisp_Object *hare = plist;
2209
2210 while (!NILP (*tortoise))
2211 {
2212 Lisp_Object *tortsave = tortoise;
2213 Lisp_Object retval;
2214
2215 /* We do the standard tortoise/hare march. We isolate the
2216 grungy stuff to do this in advance_plist_pointers(), though.
2217 To us, all this function does is advance the tortoise
2218 pointer by two and the hare pointer by four and make sure
2219 everything's OK. We first advance the pointers and then
2220 check if a property matched; this ensures that our
2221 check for a matching property is safe. */
2222
2223 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2224 return retval;
2225
2226 if (!laxp ? EQ (XCAR (*tortsave), property)
2227 : internal_equal (XCAR (*tortsave), property, 0))
2228 return XCAR (XCDR (*tortsave));
2229 }
2230
2231 return Qunbound;
2232 }
2233
2234 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
2235 malformed or circular plist. Analogous to external_plist_get(). */
2236
2237 void
2238 external_plist_put (Lisp_Object *plist, Lisp_Object property,
2239 Lisp_Object value, int laxp, Error_behavior errb)
2240 {
2241 Lisp_Object *tortoise = plist;
2242 Lisp_Object *hare = plist;
2243
2244 while (!NILP (*tortoise))
2245 {
2246 Lisp_Object *tortsave = tortoise;
2247 Lisp_Object retval;
2248
2249 /* See above */
2250 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2251 return;
2252
2253 if (!laxp ? EQ (XCAR (*tortsave), property)
2254 : internal_equal (XCAR (*tortsave), property, 0))
2255 {
2256 XCAR (XCDR (*tortsave)) = value;
2257 return;
2258 }
2259 }
2260
2261 *plist = Fcons (property, Fcons (value, *plist));
2262 }
2263
2264 int
2265 external_remprop (Lisp_Object *plist, Lisp_Object property,
2266 int laxp, Error_behavior errb)
2267 {
2268 Lisp_Object *tortoise = plist;
2269 Lisp_Object *hare = plist;
2270
2271 while (!NILP (*tortoise))
2272 {
2273 Lisp_Object *tortsave = tortoise;
2274 Lisp_Object retval;
2275
2276 /* See above */
2277 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
2278 return 0;
2279
2280 if (!laxp ? EQ (XCAR (*tortsave), property)
2281 : internal_equal (XCAR (*tortsave), property, 0))
2282 {
2283 /* Now you see why it's so convenient to have that level
2284 of indirection. */
2285 *tortsave = XCDR (XCDR (*tortsave));
2286 return 1;
2287 }
2288 }
2289
2290 return 0;
2291 }
2292
2293 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
2294 Extract a value from a property list.
2295 PLIST is a property list, which is a list of the form
2296 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
2297 corresponding to the given PROP, or DEFAULT if PROP is not
2298 one of the properties on the list.
2299 */
2300 (plist, prop, default_))
2301 {
2302 Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME);
2303 return UNBOUNDP (val) ? default_ : val;
2304 }
2305
2306 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
2307 Change value in PLIST of PROP to VAL.
2308 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2309 PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object.
2310 If PROP is already a property on the list, its value is set to VAL,
2311 otherwise the new PROP VAL pair is added. The new plist is returned;
2312 use `(setq x (plist-put x prop val))' to be sure to use the new value.
2313 The PLIST is modified by side effects.
2314 */
2315 (plist, prop, val))
2316 {
2317 external_plist_put (&plist, prop, val, 0, ERROR_ME);
2318 return plist;
2319 }
2320
2321 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
2322 Remove from PLIST the property PROP and its value.
2323 PLIST is a property list, which is a list of the form \(PROP1 VALUE1
2324 PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is
2325 returned; use `(setq x (plist-remprop x prop val))' to be sure to use
2326 the new value. The PLIST is modified by side effects.
2327 */
2328 (plist, prop))
2329 {
2330 external_remprop (&plist, prop, 0, ERROR_ME);
2331 return plist;
2332 }
2333
2334 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
2335 Return t if PROP has a value specified in PLIST.
2336 */
2337 (plist, prop))
2338 {
2339 Lisp_Object val = Fplist_get (plist, prop, Qunbound);
2340 return UNBOUNDP (val) ? Qnil : Qt;
2341 }
2342
2343 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
2344 Given a plist, signal an error if there is anything wrong with it.
2345 This means that it's a malformed or circular plist.
2346 */
2347 (plist))
2348 {
2349 Lisp_Object *tortoise;
2350 Lisp_Object *hare;
2351
2352 start_over:
2353 tortoise = &plist;
2354 hare = &plist;
2355 while (!NILP (*tortoise))
2356 {
2357 Lisp_Object retval;
2358
2359 /* See above */
2360 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
2361 &retval))
2362 goto start_over;
2363 }
2364
2365 return Qnil;
2366 }
2367
2368 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2369 Given a plist, return non-nil if its format is correct.
2370 If it returns nil, `check-valid-plist' will signal an error when given
2371 the plist; that means it's a malformed or circular plist or has non-symbols
2372 as keywords.
2373 */
2374 (plist))
2375 {
2376 Lisp_Object *tortoise;
2377 Lisp_Object *hare;
2378
2379 tortoise = &plist;
2380 hare = &plist;
2381 while (!NILP (*tortoise))
2382 {
2383 Lisp_Object retval;
2384
2385 /* See above */
2386 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
2387 &retval))
2388 return Qnil;
2389 }
2390
2391 return Qt;
2392 }
2393
2394 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
2395 Destructively remove any duplicate entries from a plist.
2396 In such cases, the first entry applies.
2397
2398 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2399 a nil value is removed. This feature is a virus that has infected
2400 old Lisp implementations, but should not be used except for backward
2401 compatibility.
2402
2403 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2404 return value may not be EQ to the passed-in value, so make sure to
2405 `setq' the value back into where it came from.
2406 */
2407 (plist, nil_means_not_present))
2408 {
2409 Lisp_Object head = plist;
2410
2411 Fcheck_valid_plist (plist);
2412
2413 while (!NILP (plist))
2414 {
2415 Lisp_Object prop = Fcar (plist);
2416 Lisp_Object next = Fcdr (plist);
2417
2418 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2419 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2420 {
2421 if (EQ (head, plist))
2422 head = Fcdr (next);
2423 plist = Fcdr (next);
2424 continue;
2425 }
2426 /* external_remprop returns 1 if it removed any property.
2427 We have to loop till it didn't remove anything, in case
2428 the property occurs many times. */
2429 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
2430 DO_NOTHING;
2431 plist = Fcdr (next);
2432 }
2433
2434 return head;
2435 }
2436
2437 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
2438 Extract a value from a lax property list.
2439
2440 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2441 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2442 using `equal' instead of `eq'. This function returns the value
2443 corresponding to the given PROP, or DEFAULT if PROP is not one of the
2444 properties on the list.
2445 */
2446 (lax_plist, prop, default_))
2447 {
2448 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2449 if (UNBOUNDP (val))
2450 return default_;
2451 return val;
2452 }
2453
2454 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2455 Change value in LAX-PLIST of PROP to VAL.
2456 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2457 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2458 using `equal' instead of `eq'. PROP is usually a symbol and VAL is
2459 any object. If PROP is already a property on the list, its value is
2460 set to VAL, otherwise the new PROP VAL pair is added. The new plist
2461 is returned; use `(setq x (lax-plist-put x prop val))' to be sure to
2462 use the new value. The LAX-PLIST is modified by side effects.
2463 */
2464 (lax_plist, prop, val))
2465 {
2466 external_plist_put (&lax_plist, prop, val, 1, ERROR_ME);
2467 return lax_plist;
2468 }
2469
2470 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
2471 Remove from LAX-PLIST the property PROP and its value.
2472 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2473 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2474 using `equal' instead of `eq'. PROP is usually a symbol. The new
2475 plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be
2476 sure to use the new value. The LAX-PLIST is modified by side effects.
2477 */
2478 (lax_plist, prop))
2479 {
2480 external_remprop (&lax_plist, prop, 1, ERROR_ME);
2481 return lax_plist;
2482 }
2483
2484 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
2485 Return t if PROP has a value specified in LAX-PLIST.
2486 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2487 VALUE1 PROP2 VALUE2...), where comparisons between properties is done
2488 using `equal' instead of `eq'.
2489 */
2490 (lax_plist, prop))
2491 {
2492 return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt;
2493 }
2494
2495 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
2496 Destructively remove any duplicate entries from a lax plist.
2497 In such cases, the first entry applies.
2498
2499 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
2500 a nil value is removed. This feature is a virus that has infected
2501 old Lisp implementations, but should not be used except for backward
2502 compatibility.
2503
2504 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
2505 return value may not be EQ to the passed-in value, so make sure to
2506 `setq' the value back into where it came from.
2507 */
2508 (lax_plist, nil_means_not_present))
2509 {
2510 Lisp_Object head = lax_plist;
2511
2512 Fcheck_valid_plist (lax_plist);
2513
2514 while (!NILP (lax_plist))
2515 {
2516 Lisp_Object prop = Fcar (lax_plist);
2517 Lisp_Object next = Fcdr (lax_plist);
2518
2519 CHECK_CONS (next); /* just make doubly sure we catch any errors */
2520 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
2521 {
2522 if (EQ (head, lax_plist))
2523 head = Fcdr (next);
2524 lax_plist = Fcdr (next);
2525 continue;
2526 }
2527 /* external_remprop returns 1 if it removed any property.
2528 We have to loop till it didn't remove anything, in case
2529 the property occurs many times. */
2530 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
2531 DO_NOTHING;
2532 lax_plist = Fcdr (next);
2533 }
2534
2535 return head;
2536 }
2537
2538 /* In C because the frame props stuff uses it */
2539
2540 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
2541 Convert association list ALIST into the equivalent property-list form.
2542 The plist is returned. This converts from
2543
2544 \((a . 1) (b . 2) (c . 3))
2545
2546 into
2547
2548 \(a 1 b 2 c 3)
2549
2550 The original alist is destroyed in the process of constructing the plist.
2551 See also `alist-to-plist'.
2552 */
2553 (alist))
2554 {
2555 Lisp_Object head = alist;
2556 while (!NILP (alist))
2557 {
2558 /* remember the alist element. */
2559 Lisp_Object el = Fcar (alist);
2560
2561 Fsetcar (alist, Fcar (el));
2562 Fsetcar (el, Fcdr (el));
2563 Fsetcdr (el, Fcdr (alist));
2564 Fsetcdr (alist, el);
2565 alist = Fcdr (Fcdr (alist));
2566 }
2567
2568 return head;
2569 }
2570
2571 /* Symbol plists are directly accessible, so we need to protect against
2572 invalid property list structure */
2573
2574 static Lisp_Object
2575 symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
2576 {
2577 Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
2578 0, ERROR_ME);
2579 return UNBOUNDP (val) ? default_ : val;
2580 }
2581
2582 static void
2583 symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
2584 {
2585 external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
2586 }
2587
2588 static int
2589 symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
2590 {
2591 return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
2592 }
2593
2594 /* We store the string's extent info as the first element of the string's
2595 property list; and the string's MODIFF as the first or second element
2596 of the string's property list (depending on whether the extent info
2597 is present), but only if the string has been modified. This is ugly
2598 but it reduces the memory allocated for the string in the vast
2599 majority of cases, where the string is never modified and has no
2600 extent info. */
2601
2602
2603 static Lisp_Object *
2604 string_plist_ptr (struct Lisp_String *s)
2605 {
2606 Lisp_Object *ptr = &s->plist;
2607
2608 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
2609 ptr = &XCDR (*ptr);
2610 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
2611 ptr = &XCDR (*ptr);
2612 return ptr;
2613 }
2614
2615 static Lisp_Object
2616 string_getprop (struct Lisp_String *s, Lisp_Object property,
2617 Lisp_Object default_)
2618 {
2619 Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
2620 ERROR_ME);
2621 return UNBOUNDP (val) ? default_ : val;
2622 }
2623
2624 static void
2625 string_putprop (struct Lisp_String *s, Lisp_Object property,
2626 Lisp_Object value)
2627 {
2628 external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
2629 }
2630
2631 static int
2632 string_remprop (struct Lisp_String *s, Lisp_Object property)
2633 {
2634 return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
2635 }
2636
2637 static Lisp_Object
2638 string_plist (struct Lisp_String *s)
2639 {
2640 return *string_plist_ptr (s);
2641 }
2642
2643 DEFUN ("get", Fget, 2, 3, 0, /*
2644 Return the value of OBJECT's PROPNAME property.
2645 This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.
2646 If there is no such property, return optional third arg DEFAULT
2647 \(which defaults to `nil'). OBJECT can be a symbol, face, extent,
2648 or string. See also `put', `remprop', and `object-plist'.
2649 */
2650 (object, propname, default_))
2651 {
2652 /* Various places in emacs call Fget() and expect it not to quit,
2653 so don't quit. */
2654
2655 /* It's easiest to treat symbols specially because they may not
2656 be an lrecord */
2657 if (SYMBOLP (object))
2658 return symbol_getprop (object, propname, default_);
2659 else if (STRINGP (object))
2660 return string_getprop (XSTRING (object), propname, default_);
2661 else if (LRECORDP (object))
2662 {
2663 CONST struct lrecord_implementation *imp
2664 = XRECORD_LHEADER_IMPLEMENTATION (object);
2665 if (!imp->getprop)
2666 goto noprops;
2667
2668 {
2669 Lisp_Object val = (imp->getprop) (object, propname);
2670 if (UNBOUNDP (val))
2671 val = default_;
2672 return val;
2673 }
2674 }
2675 else
2676 {
2677 noprops:
2678 signal_simple_error ("Object type has no properties", object);
2679 return Qnil; /* Not reached */
2680 }
2681 }
2682
2683 DEFUN ("put", Fput, 3, 3, 0, /*
2684 Store OBJECT's PROPNAME property with value VALUE.
2685 It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a
2686 symbol, face, extent, or string.
2687
2688 For a string, no properties currently have predefined meanings.
2689 For the predefined properties for extents, see `set-extent-property'.
2690 For the predefined properties for faces, see `set-face-property'.
2691
2692 See also `get', `remprop', and `object-plist'.
2693 */
2694 (object, propname, value))
2695 {
2696 CHECK_SYMBOL (propname);
2697 CHECK_LISP_WRITEABLE (object);
2698
2699 if (SYMBOLP (object))
2700 symbol_putprop (object, propname, value);
2701 else if (STRINGP (object))
2702 string_putprop (XSTRING (object), propname, value);
2703 else if (LRECORDP (object))
2704 {
2705 CONST struct lrecord_implementation
2706 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2707 if (imp->putprop)
2708 {
2709 if (! (imp->putprop) (object, propname, value))
2710 signal_simple_error ("Can't set property on object", propname);
2711 }
2712 else
2713 goto noprops;
2714 }
2715 else
2716 {
2717 noprops:
2718 signal_simple_error ("Object type has no settable properties", object);
2719 }
2720
2721 return value;
2722 }
2723
2724 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2725 Remove from OBJECT's property list the property PROPNAME and its
2726 value. OBJECT can be a symbol, face, extent, or string. Returns
2727 non-nil if the property list was actually changed (i.e. if PROPNAME
2728 was present in the property list). See also `get', `put', and
2729 `object-plist'.
2730 */
2731 (object, propname))
2732 {
2733 int retval = 0;
2734
2735 CHECK_SYMBOL (propname);
2736 CHECK_LISP_WRITEABLE (object);
2737
2738 if (SYMBOLP (object))
2739 retval = symbol_remprop (object, propname);
2740 else if (STRINGP (object))
2741 retval = string_remprop (XSTRING (object), propname);
2742 else if (LRECORDP (object))
2743 {
2744 CONST struct lrecord_implementation
2745 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2746 if (imp->remprop)
2747 {
2748 retval = (imp->remprop) (object, propname);
2749 if (retval == -1)
2750 signal_simple_error ("Can't remove property from object",
2751 propname);
2752 }
2753 else
2754 goto noprops;
2755 }
2756 else
2757 {
2758 noprops:
2759 signal_simple_error ("Object type has no removable properties", object);
2760 }
2761
2762 return retval ? Qt : Qnil;
2763 }
2764
2765 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2766 Return a property list of OBJECT's props.
2767 For a symbol this is equivalent to `symbol-plist'.
2768 Do not modify the property list directly; this may or may not have
2769 the desired effects. (In particular, for a property with a special
2770 interpretation, this will probably have no effect at all.)
2771 */
2772 (object))
2773 {
2774 if (SYMBOLP (object))
2775 return Fsymbol_plist (object);
2776 else if (STRINGP (object))
2777 return string_plist (XSTRING (object));
2778 else if (LRECORDP (object))
2779 {
2780 CONST struct lrecord_implementation
2781 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2782 if (imp->plist)
2783 return (imp->plist) (object);
2784 else
2785 signal_simple_error ("Object type has no properties", object);
2786 }
2787 else
2788 signal_simple_error ("Object type has no properties", object);
2789
2790 return Qnil;
2791 }
2792
2793
2794 int
2795 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2796 {
2797 if (depth > 200)
2798 error ("Stack overflow in equal");
2799 QUIT;
2800 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2801 return 1;
2802 /* Note that (equal 20 20.0) should be nil */
2803 if (XTYPE (obj1) != XTYPE (obj2))
2804 return 0;
2805 if (LRECORDP (obj1))
2806 {
2807 CONST struct lrecord_implementation
2808 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2809 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2810
2811 return (imp1 == imp2) &&
2812 /* EQ-ness of the objects was noticed above */
2813 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2814 }
2815
2816 return 0;
2817 }
2818
2819 /* Note that we may be calling sub-objects that will use
2820 internal_equal() (instead of internal_old_equal()). Oh well.
2821 We will get an Ebola note if there's any possibility of confusion,
2822 but that seems unlikely. */
2823
2824 static int
2825 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2826 {
2827 if (depth > 200)
2828 error ("Stack overflow in equal");
2829 QUIT;
2830 if (HACKEQ_UNSAFE (obj1, obj2))
2831 return 1;
2832 /* Note that (equal 20 20.0) should be nil */
2833 if (XTYPE (obj1) != XTYPE (obj2))
2834 return 0;
2835
2836 return internal_equal (obj1, obj2, depth);
2837 }
2838
2839 DEFUN ("equal", Fequal, 2, 2, 0, /*
2840 Return t if two Lisp objects have similar structure and contents.
2841 They must have the same data type.
2842 Conses are compared by comparing the cars and the cdrs.
2843 Vectors and strings are compared element by element.
2844 Numbers are compared by value. Symbols must match exactly.
2845 */
2846 (obj1, obj2))
2847 {
2848 return internal_equal (obj1, obj2, 0) ? Qt : Qnil;
2849 }
2850
2851 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2852 Return t if two Lisp objects have similar structure and contents.
2853 They must have the same data type.
2854 \(Note, however, that an exception is made for characters and integers;
2855 this is known as the "char-int confoundance disease." See `eq' and
2856 `old-eq'.)
2857 This function is provided only for byte-code compatibility with v19.
2858 Do not use it.
2859 */
2860 (obj1, obj2))
2861 {
2862 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2863 }
2864
2865
2866 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2867 Store each element of ARRAY with ITEM.
2868 ARRAY is a vector, bit vector, or string.
2869 */
2870 (array, item))
2871 {
2872 retry:
2873 if (STRINGP (array))
2874 {
2875 Emchar charval;
2876 struct Lisp_String *s = XSTRING (array);
2877 Charcount len = string_char_length (s);
2878 Charcount i;
2879 CHECK_CHAR_COERCE_INT (item);
2880 CHECK_LISP_WRITEABLE (array);
2881 charval = XCHAR (item);
2882 for (i = 0; i < len; i++)
2883 set_string_char (s, i, charval);
2884 bump_string_modiff (array);
2885 }
2886 else if (VECTORP (array))
2887 {
2888 Lisp_Object *p = XVECTOR_DATA (array);
2889 int len = XVECTOR_LENGTH (array);
2890 CHECK_LISP_WRITEABLE (array);
2891 while (len--)
2892 *p++ = item;
2893 }
2894 else if (BIT_VECTORP (array))
2895 {
2896 struct Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2897 int len = bit_vector_length (v);
2898 int bit;
2899 CHECK_BIT (item);
2900 CHECK_LISP_WRITEABLE (array);
2901 bit = XINT (item);
2902 while (len--)
2903 set_bit_vector_bit (v, len, bit);
2904 }
2905 else
2906 {
2907 array = wrong_type_argument (Qarrayp, array);
2908 goto retry;
2909 }
2910 return array;
2911 }
2912
2913 Lisp_Object
2914 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
2915 {
2916 Lisp_Object args[2];
2917 struct gcpro gcpro1;
2918 args[0] = arg1;
2919 args[1] = arg2;
2920
2921 GCPRO1 (args[0]);
2922 gcpro1.nvars = 2;
2923
2924 RETURN_UNGCPRO (bytecode_nconc2 (args));
2925 }
2926
2927 Lisp_Object
2928 bytecode_nconc2 (Lisp_Object *args)
2929 {
2930 retry:
2931
2932 if (CONSP (args[0]))
2933 {
2934 /* (setcdr (last args[0]) args[1]) */
2935 Lisp_Object tortoise, hare;
2936 int count;
2937
2938 for (hare = tortoise = args[0], count = 0;
2939 CONSP (XCDR (hare));
2940 hare = XCDR (hare), count++)
2941 {
2942 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
2943
2944 if (count & 1)
2945 tortoise = XCDR (tortoise);
2946 if (EQ (hare, tortoise))
2947 signal_circular_list_error (args[0]);
2948 }
2949 XCDR (hare) = args[1];
2950 return args[0];
2951 }
2952 else if (NILP (args[0]))
2953 {
2954 return args[1];
2955 }
2956 else
2957 {
2958 args[0] = wrong_type_argument (args[0], Qlistp);
2959 goto retry;
2960 }
2961 }
2962
2963 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
2964 Concatenate any number of lists by altering them.
2965 Only the last argument is not altered, and need not be a list.
2966 Also see: `append'.
2967 If the first argument is nil, there is no way to modify it by side
2968 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
2969 changing the value of `foo'.
2970 */
2971 (int nargs, Lisp_Object *args))
2972 {
2973 int argnum = 0;
2974 struct gcpro gcpro1;
2975
2976 /* The modus operandi in Emacs is "caller gc-protects args".
2977 However, nconc (particularly nconc2 ()) is called many times
2978 in Emacs on freshly created stuff (e.g. you see the idiom
2979 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
2980 callers out by protecting the args ourselves to save them
2981 a lot of temporary-variable grief. */
2982
2983 GCPRO1 (args[0]);
2984 gcpro1.nvars = nargs;
2985
2986 while (argnum < nargs)
2987 {
2988 Lisp_Object val;
2989 retry:
2990 val = args[argnum];
2991 if (CONSP (val))
2992 {
2993 /* `val' is the first cons, which will be our return value. */
2994 /* `last_cons' will be the cons cell to mutate. */
2995 Lisp_Object last_cons = val;
2996 Lisp_Object tortoise = val;
2997
2998 for (argnum++; argnum < nargs; argnum++)
2999 {
3000 Lisp_Object next = args[argnum];
3001 retry_next:
3002 if (CONSP (next) || argnum == nargs -1)
3003 {
3004 /* (setcdr (last val) next) */
3005 int count;
3006
3007 for (count = 0;
3008 CONSP (XCDR (last_cons));
3009 last_cons = XCDR (last_cons), count++)
3010 {
3011 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3012
3013 if (count & 1)
3014 tortoise = XCDR (tortoise);
3015 if (EQ (last_cons, tortoise))
3016 signal_circular_list_error (args[argnum-1]);
3017 }
3018 XCDR (last_cons) = next;
3019 }
3020 else if (NILP (next))
3021 {
3022 continue;
3023 }
3024 else
3025 {
3026 next = wrong_type_argument (Qlistp, next);
3027 goto retry_next;
3028 }
3029 }
3030 RETURN_UNGCPRO (val);
3031 }
3032 else if (NILP (val))
3033 argnum++;
3034 else if (argnum == nargs - 1) /* last arg? */
3035 RETURN_UNGCPRO (val);
3036 else
3037 {
3038 args[argnum] = wrong_type_argument (Qlistp, val);
3039 goto retry;
3040 }
3041 }
3042 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3043 }
3044
3045
3046 /* This is the guts of all mapping functions.
3047 Apply fn to each element of seq, one by one,
3048 storing the results into elements of vals, a C vector of Lisp_Objects.
3049 leni is the length of vals, which should also be the length of seq.
3050
3051 If VALS is a null pointer, do not accumulate the results. */
3052
3053 static void
3054 mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
3055 {
3056 Lisp_Object result;
3057 Lisp_Object args[2];
3058 int i;
3059 struct gcpro gcpro1;
3060
3061 if (vals)
3062 {
3063 GCPRO1 (vals[0]);
3064 gcpro1.nvars = 0;
3065 }
3066
3067 args[0] = fn;
3068
3069 if (LISTP (seq))
3070 {
3071 for (i = 0; i < leni; i++)
3072 {
3073 args[1] = XCAR (seq);
3074 seq = XCDR (seq);
3075 result = Ffuncall (2, args);
3076 if (vals) vals[gcpro1.nvars++] = result;
3077 }
3078 }
3079 else if (VECTORP (seq))
3080 {
3081 Lisp_Object *objs = XVECTOR_DATA (seq);
3082 for (i = 0; i < leni; i++)
3083 {
3084 args[1] = *objs++;
3085 result = Ffuncall (2, args);
3086 if (vals) vals[gcpro1.nvars++] = result;
3087 }
3088 }
3089 else if (STRINGP (seq))
3090 {
3091 Bufbyte *p = XSTRING_DATA (seq);
3092 for (i = 0; i < leni; i++)
3093 {
3094 args[1] = make_char (charptr_emchar (p));
3095 INC_CHARPTR (p);
3096 result = Ffuncall (2, args);
3097 if (vals) vals[gcpro1.nvars++] = result;
3098 }
3099 }
3100 else if (BIT_VECTORP (seq))
3101 {
3102 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq);
3103 for (i = 0; i < leni; i++)
3104 {
3105 args[1] = make_int (bit_vector_bit (v, i));
3106 result = Ffuncall (2, args);
3107 if (vals) vals[gcpro1.nvars++] = result;
3108 }
3109 }
3110 else
3111 abort(); /* cannot get here since Flength(seq) did not get an error */
3112
3113 if (vals)
3114 UNGCPRO;
3115 }
3116
3117 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3118 Apply FN to each element of SEQ, and concat the results as strings.
3119 In between each pair of results, stick in SEP.
3120 Thus, " " as SEP results in spaces between the values returned by FN.
3121 */
3122 (fn, seq, sep))
3123 {
3124 size_t len = XINT (Flength (seq));
3125 Lisp_Object *args;
3126 int i;
3127 struct gcpro gcpro1;
3128 int nargs = len + len - 1;
3129
3130 if (nargs < 0) return build_string ("");
3131
3132 args = alloca_array (Lisp_Object, nargs);
3133
3134 GCPRO1 (sep);
3135 mapcar1 (len, args, fn, seq);
3136 UNGCPRO;
3137
3138 for (i = len - 1; i >= 0; i--)
3139 args[i + i] = args[i];
3140
3141 for (i = 1; i < nargs; i += 2)
3142 args[i] = sep;
3143
3144 return Fconcat (nargs, args);
3145 }
3146
3147 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3148 Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
3149 The result is a list just as long as SEQUENCE.
3150 SEQUENCE may be a list, a vector, a bit vector, or a string.
3151 */
3152 (fn, seq))
3153 {
3154 size_t len = XINT (Flength (seq));
3155 Lisp_Object *args = alloca_array (Lisp_Object, len);
3156
3157 mapcar1 (len, args, fn, seq);
3158
3159 return Flist (len, args);
3160 }
3161
3162 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3163 Apply FUNCTION to each element of SEQUENCE, making a vector of the results.
3164 The result is a vector of the same length as SEQUENCE.
3165 SEQUENCE may be a list, a vector or a string.
3166 */
3167 (fn, seq))
3168 {
3169 size_t len = XINT (Flength (seq));
3170 Lisp_Object result = make_vector (len, Qnil);
3171 struct gcpro gcpro1;
3172
3173 GCPRO1 (result);
3174 mapcar1 (len, XVECTOR_DATA (result), fn, seq);
3175 UNGCPRO;
3176
3177 return result;
3178 }
3179
3180 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3181 Apply FUNCTION to each element of SEQUENCE.
3182 SEQUENCE may be a list, a vector, a bit vector, or a string.
3183 This function is like `mapcar' but does not accumulate the results,
3184 which is more efficient if you do not use the results.
3185
3186 The difference between this and `mapc' is that `mapc' supports all
3187 the spiffy Common Lisp arguments. You should normally use `mapc'.
3188 */
3189 (fn, seq))
3190 {
3191 mapcar1 (XINT (Flength (seq)), 0, fn, seq);
3192
3193 return seq;
3194 }
3195
3196
3197 /* #### this function doesn't belong in this file! */
3198
3199 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3200 Return list of 1 minute, 5 minute and 15 minute load averages.
3201 Each of the three load averages is multiplied by 100,
3202 then converted to integer.
3203
3204 When USE-FLOATS is non-nil, floats will be used instead of integers.
3205 These floats are not multiplied by 100.
3206
3207 If the 5-minute or 15-minute load averages are not available, return a
3208 shortened list, containing only those averages which are available.
3209
3210 On some systems, this won't work due to permissions on /dev/kmem,
3211 in which case you can't use this.
3212 */
3213 (use_floats))
3214 {
3215 double load_ave[3];
3216 int loads = getloadavg (load_ave, countof (load_ave));
3217 Lisp_Object ret = Qnil;
3218
3219 if (loads == -2)
3220 error ("load-average not implemented for this operating system");
3221 else if (loads < 0)
3222 signal_simple_error ("Could not get load-average",
3223 lisp_strerror (errno));
3224
3225 while (loads-- > 0)
3226 {
3227 Lisp_Object load = (NILP (use_floats) ?
3228 make_int ((int) (100.0 * load_ave[loads]))
3229 : make_float (load_ave[loads]));
3230 ret = Fcons (load, ret);
3231 }
3232 return ret;
3233 }
3234
3235
3236 Lisp_Object Vfeatures;
3237
3238 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3239 Return non-nil if feature FEXP is present in this Emacs.
3240 Use this to conditionalize execution of lisp code based on the
3241 presence or absence of emacs or environment extensions.
3242 FEXP can be a symbol, a number, or a list.
3243 If it is a symbol, that symbol is looked up in the `features' variable,
3244 and non-nil will be returned if found.
3245 If it is a number, the function will return non-nil if this Emacs
3246 has an equal or greater version number than FEXP.
3247 If it is a list whose car is the symbol `and', it will return
3248 non-nil if all the features in its cdr are non-nil.
3249 If it is a list whose car is the symbol `or', it will return non-nil
3250 if any of the features in its cdr are non-nil.
3251 If it is a list whose car is the symbol `not', it will return
3252 non-nil if the feature is not present.
3253
3254 Examples:
3255
3256 (featurep 'xemacs)
3257 => ; Non-nil on XEmacs.
3258
3259 (featurep '(and xemacs gnus))
3260 => ; Non-nil on XEmacs with Gnus loaded.
3261
3262 (featurep '(or tty-frames (and emacs 19.30)))
3263 => ; Non-nil if this Emacs supports TTY frames.
3264
3265 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3266 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3267
3268 NOTE: The advanced arguments of this function (anything other than a
3269 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3270 for supporting multiple Emacs variants, lobby Richard Stallman at
3271 <bug-gnu-emacs@prep.ai.mit.edu>.
3272 */
3273 (fexp))
3274 {
3275 #ifndef FEATUREP_SYNTAX
3276 CHECK_SYMBOL (fexp);
3277 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3278 #else /* FEATUREP_SYNTAX */
3279 static double featurep_emacs_version;
3280
3281 /* Brute force translation from Erik Naggum's lisp function. */
3282 if (SYMBOLP (fexp))
3283 {
3284 /* Original definition */
3285 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3286 }
3287 else if (INTP (fexp) || FLOATP (fexp))
3288 {
3289 double d = extract_float (fexp);
3290
3291 if (featurep_emacs_version == 0.0)
3292 {
3293 featurep_emacs_version = XINT (Vemacs_major_version) +
3294 (XINT (Vemacs_minor_version) / 100.0);
3295 }
3296 return featurep_emacs_version >= d ? Qt : Qnil;
3297 }
3298 else if (CONSP (fexp))
3299 {
3300 Lisp_Object tem = XCAR (fexp);
3301 if (EQ (tem, Qnot))
3302 {
3303 Lisp_Object negate;
3304
3305 tem = XCDR (fexp);
3306 negate = Fcar (tem);
3307 if (!NILP (tem))
3308 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3309 else
3310 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3311 }
3312 else if (EQ (tem, Qand))
3313 {
3314 tem = XCDR (fexp);
3315 /* Use Fcar/Fcdr for error-checking. */
3316 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3317 {
3318 tem = Fcdr (tem);
3319 }
3320 return NILP (tem) ? Qt : Qnil;
3321 }
3322 else if (EQ (tem, Qor))
3323 {
3324 tem = XCDR (fexp);
3325 /* Use Fcar/Fcdr for error-checking. */
3326 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3327 {
3328 tem = Fcdr (tem);
3329 }
3330 return NILP (tem) ? Qnil : Qt;
3331 }
3332 else
3333 {
3334 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3335 }
3336 }
3337 else
3338 {
3339 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3340 }
3341 }
3342 #endif /* FEATUREP_SYNTAX */
3343
3344 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3345 Announce that FEATURE is a feature of the current Emacs.
3346 This function updates the value of the variable `features'.
3347 */
3348 (feature))
3349 {
3350 Lisp_Object tem;
3351 CHECK_SYMBOL (feature);
3352 if (!NILP (Vautoload_queue))
3353 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3354 tem = Fmemq (feature, Vfeatures);
3355 if (NILP (tem))
3356 Vfeatures = Fcons (feature, Vfeatures);
3357 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3358 return feature;
3359 }
3360
3361 DEFUN ("require", Frequire, 1, 2, 0, /*
3362 If feature FEATURE is not loaded, load it from FILENAME.
3363 If FEATURE is not a member of the list `features', then the feature
3364 is not loaded; so load the file FILENAME.
3365 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3366 */
3367 (feature, file_name))
3368 {
3369 Lisp_Object tem;
3370 CHECK_SYMBOL (feature);
3371 tem = Fmemq (feature, Vfeatures);
3372 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3373 if (!NILP (tem))
3374 return feature;
3375 else
3376 {
3377 int speccount = specpdl_depth ();
3378
3379 /* Value saved here is to be restored into Vautoload_queue */
3380 record_unwind_protect (un_autoload, Vautoload_queue);
3381 Vautoload_queue = Qt;
3382
3383 call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
3384 Qnil, Qt, Qnil);
3385
3386 tem = Fmemq (feature, Vfeatures);
3387 if (NILP (tem))
3388 error ("Required feature %s was not provided",
3389 string_data (XSYMBOL (feature)->name));
3390
3391 /* Once loading finishes, don't undo it. */
3392 Vautoload_queue = Qt;
3393 return unbind_to (speccount, feature);
3394 }
3395 }
3396
3397 /* base64 encode/decode functions.
3398
3399 Originally based on code from GNU recode. Ported to FSF Emacs by
3400 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3401 subsequently heavily hacked by Hrvoje Niksic. */
3402
3403 #define MIME_LINE_LENGTH 72
3404
3405 #define IS_ASCII(Character) \
3406 ((Character) < 128)
3407 #define IS_BASE64(Character) \
3408 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3409
3410 /* Table of characters coding the 64 values. */
3411 static char base64_value_to_char[64] =
3412 {
3413 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3414 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3415 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3416 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3417 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3418 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3419 '8', '9', '+', '/' /* 60-63 */
3420 };
3421
3422 /* Table of base64 values for first 128 characters. */
3423 static short base64_char_to_value[128] =
3424 {
3425 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3426 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3427 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3428 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3429 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3430 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3431 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3432 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3433 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3434 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3435 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3436 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3437 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3438 };
3439
3440 /* The following diagram shows the logical steps by which three octets
3441 get transformed into four base64 characters.
3442
3443 .--------. .--------. .--------.
3444 |aaaaaabb| |bbbbcccc| |ccdddddd|
3445 `--------' `--------' `--------'
3446 6 2 4 4 2 6
3447 .--------+--------+--------+--------.
3448 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3449 `--------+--------+--------+--------'
3450
3451 .--------+--------+--------+--------.
3452 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3453 `--------+--------+--------+--------'
3454
3455 The octets are divided into 6 bit chunks, which are then encoded into
3456 base64 characters. */
3457
3458 #define ADVANCE_INPUT(c, stream) \
3459 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3460 ((ec > 255) ? \
3461 (signal_simple_error ("Non-ascii character in base64 input", \
3462 make_char (ec)), 0) \
3463 : (c = (Bufbyte)ec), 1))
3464
3465 static Bytind
3466 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3467 {
3468 EMACS_INT counter = 0;
3469 Bufbyte *e = to;
3470 Emchar ec;
3471 unsigned int value;
3472
3473 while (1)
3474 {
3475 Bufbyte c;
3476 if (!ADVANCE_INPUT (c, istream))
3477 break;
3478
3479 /* Wrap line every 76 characters. */
3480 if (line_break)
3481 {
3482 if (counter < MIME_LINE_LENGTH / 4)
3483 counter++;
3484 else
3485 {
3486 *e++ = '\n';
3487 counter = 1;
3488 }
3489 }
3490
3491 /* Process first byte of a triplet. */
3492 *e++ = base64_value_to_char[0x3f & c >> 2];
3493 value = (0x03 & c) << 4;
3494
3495 /* Process second byte of a triplet. */
3496 if (!ADVANCE_INPUT (c, istream))
3497 {
3498 *e++ = base64_value_to_char[value];
3499 *e++ = '=';
3500 *e++ = '=';
3501 break;
3502 }
3503
3504 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3505 value = (0x0f & c) << 2;
3506
3507 /* Process third byte of a triplet. */
3508 if (!ADVANCE_INPUT (c, istream))
3509 {
3510 *e++ = base64_value_to_char[value];
3511 *e++ = '=';
3512 break;
3513 }
3514
3515 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3516 *e++ = base64_value_to_char[0x3f & c];
3517 }
3518
3519 return e - to;
3520 }
3521 #undef ADVANCE_INPUT
3522
3523 /* Get next character from the stream, except that non-base64
3524 characters are ignored. This is in accordance with rfc2045. EC
3525 should be an Emchar, so that it can hold -1 as the value for EOF. */
3526 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3527 ec = Lstream_get_emchar (stream); \
3528 ++streampos; \
3529 /* IS_BASE64 may not be called with negative arguments so check for \
3530 EOF first. */ \
3531 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3532 break; \
3533 } while (1)
3534
3535 #define STORE_BYTE(pos, val, ccnt) do { \
3536 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3537 ++ccnt; \
3538 } while (0)
3539
3540 static Bytind
3541 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3542 {
3543 Charcount ccnt = 0;
3544 Bufbyte *e = to;
3545 EMACS_INT streampos = 0;
3546
3547 while (1)
3548 {
3549 Emchar ec;
3550 unsigned long value;
3551
3552 /* Process first byte of a quadruplet. */
3553 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3554 if (ec < 0)
3555 break;
3556 if (ec == '=')
3557 signal_simple_error ("Illegal `=' character while decoding base64",
3558 make_int (streampos));
3559 value = base64_char_to_value[ec] << 18;
3560
3561 /* Process second byte of a quadruplet. */
3562 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3563 if (ec < 0)
3564 error ("Premature EOF while decoding base64");
3565 if (ec == '=')
3566 signal_simple_error ("Illegal `=' character while decoding base64",
3567 make_int (streampos));
3568 value |= base64_char_to_value[ec] << 12;
3569 STORE_BYTE (e, value >> 16, ccnt);
3570
3571 /* Process third byte of a quadruplet. */
3572 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3573 if (ec < 0)
3574 error ("Premature EOF while decoding base64");
3575
3576 if (ec == '=')
3577 {
3578 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3579 if (ec < 0)
3580 error ("Premature EOF while decoding base64");
3581 if (ec != '=')
3582 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3583 make_int (streampos));
3584 continue;
3585 }
3586
3587 value |= base64_char_to_value[ec] << 6;
3588 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3589
3590 /* Process fourth byte of a quadruplet. */
3591 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3592 if (ec < 0)
3593 error ("Premature EOF while decoding base64");
3594 if (ec == '=')
3595 continue;
3596
3597 value |= base64_char_to_value[ec];
3598 STORE_BYTE (e, 0xff & value, ccnt);
3599 }
3600
3601 *ccptr = ccnt;
3602 return e - to;
3603 }
3604 #undef ADVANCE_INPUT
3605 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3606 #undef STORE_BYTE
3607
3608 static Lisp_Object
3609 free_malloced_ptr (Lisp_Object unwind_obj)
3610 {
3611 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3612 xfree (ptr);
3613 free_opaque_ptr (unwind_obj);
3614 return Qnil;
3615 }
3616
3617 /* Don't use alloca for regions larger than this, lest we overflow
3618 the stack. */
3619 #define MAX_ALLOCA 65536
3620
3621 /* We need to setup proper unwinding, because there is a number of
3622 ways these functions can blow up, and we don't want to have memory
3623 leaks in those cases. */
3624 #define XMALLOC_OR_ALLOCA(ptr, len, type) do { \
3625 size_t XOA_len = (len); \
3626 if (XOA_len > MAX_ALLOCA) \
3627 { \
3628 ptr = xnew_array (type, XOA_len); \
3629 record_unwind_protect (free_malloced_ptr, \
3630 make_opaque_ptr ((void *)ptr)); \
3631 } \
3632 else \
3633 ptr = alloca_array (type, XOA_len); \
3634 } while (0)
3635
3636 #define XMALLOC_UNBIND(ptr, len, speccount) do { \
3637 if ((len) > MAX_ALLOCA) \
3638 unbind_to (speccount, Qnil); \
3639 } while (0)
3640
3641 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
3642 Base64-encode the region between BEG and END.
3643 Return the length of the encoded text.
3644 Optional third argument NO-LINE-BREAK means do not break long lines
3645 into shorter lines.
3646 */
3647 (beg, end, no_line_break))
3648 {
3649 Bufbyte *encoded;
3650 Bytind encoded_length;
3651 Charcount allength, length;
3652 struct buffer *buf = current_buffer;
3653 Bufpos begv, zv, old_pt = BUF_PT (buf);
3654 Lisp_Object input;
3655 int speccount = specpdl_depth();
3656
3657 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3658 barf_if_buffer_read_only (buf, begv, zv);
3659
3660 /* We need to allocate enough room for encoding the text.
3661 We need 33 1/3% more space, plus a newline every 76
3662 characters, and then we round up. */
3663 length = zv - begv;
3664 allength = length + length/3 + 1;
3665 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3666
3667 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3668 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3669 base64 characters will be single-byte. */
3670 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3671 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3672 NILP (no_line_break));
3673 if (encoded_length > allength)
3674 abort ();
3675 Lstream_delete (XLSTREAM (input));
3676
3677 /* Now we have encoded the region, so we insert the new contents
3678 and delete the old. (Insert first in order to preserve markers.) */
3679 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3680 XMALLOC_UNBIND (encoded, allength, speccount);
3681 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3682
3683 /* Simulate FSF Emacs implementation of this function: if point was
3684 in the region, place it at the beginning. */
3685 if (old_pt >= begv && old_pt < zv)
3686 BUF_SET_PT (buf, begv);
3687
3688 /* We return the length of the encoded text. */
3689 return make_int (encoded_length);
3690 }
3691
3692 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3693 Base64 encode STRING and return the result.
3694 */
3695 (string, no_line_break))
3696 {
3697 Charcount allength, length;
3698 Bytind encoded_length;
3699 Bufbyte *encoded;
3700 Lisp_Object input, result;
3701 int speccount = specpdl_depth();
3702
3703 CHECK_STRING (string);
3704
3705 length = XSTRING_CHAR_LENGTH (string);
3706 allength = length + length/3 + 1;
3707 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3708
3709 input = make_lisp_string_input_stream (string, 0, -1);
3710 XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte);
3711 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3712 NILP (no_line_break));
3713 if (encoded_length > allength)
3714 abort ();
3715 Lstream_delete (XLSTREAM (input));
3716 result = make_string (encoded, encoded_length);
3717 XMALLOC_UNBIND (encoded, allength, speccount);
3718 return result;
3719 }
3720
3721 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3722 Base64-decode the region between BEG and END.
3723 Return the length of the decoded text.
3724 If the region can't be decoded, return nil and don't modify the buffer.
3725 Characters out of the base64 alphabet are ignored.
3726 */
3727 (beg, end))
3728 {
3729 struct buffer *buf = current_buffer;
3730 Bufpos begv, zv, old_pt = BUF_PT (buf);
3731 Bufbyte *decoded;
3732 Bytind decoded_length;
3733 Charcount length, cc_decoded_length;
3734 Lisp_Object input;
3735 int speccount = specpdl_depth();
3736
3737 get_buffer_range_char (buf, beg, end, &begv, &zv, 0);
3738 barf_if_buffer_read_only (buf, begv, zv);
3739
3740 length = zv - begv;
3741
3742 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3743 /* We need to allocate enough room for decoding the text. */
3744 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3745 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3746 if (decoded_length > length * MAX_EMCHAR_LEN)
3747 abort ();
3748 Lstream_delete (XLSTREAM (input));
3749
3750 /* Now we have decoded the region, so we insert the new contents
3751 and delete the old. (Insert first in order to preserve markers.) */
3752 BUF_SET_PT (buf, begv);
3753 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3754 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3755 buffer_delete_range (buf, begv + cc_decoded_length,
3756 zv + cc_decoded_length, 0);
3757
3758 /* Simulate FSF Emacs implementation of this function: if point was
3759 in the region, place it at the beginning. */
3760 if (old_pt >= begv && old_pt < zv)
3761 BUF_SET_PT (buf, begv);
3762
3763 return make_int (cc_decoded_length);
3764 }
3765
3766 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3767 Base64-decode STRING and return the result.
3768 Characters out of the base64 alphabet are ignored.
3769 */
3770 (string))
3771 {
3772 Bufbyte *decoded;
3773 Bytind decoded_length;
3774 Charcount length, cc_decoded_length;
3775 Lisp_Object input, result;
3776 int speccount = specpdl_depth();
3777
3778 CHECK_STRING (string);
3779
3780 length = XSTRING_CHAR_LENGTH (string);
3781 /* We need to allocate enough room for decoding the text. */
3782 XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte);
3783
3784 input = make_lisp_string_input_stream (string, 0, -1);
3785 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3786 &cc_decoded_length);
3787 if (decoded_length > length * MAX_EMCHAR_LEN)
3788 abort ();
3789 Lstream_delete (XLSTREAM (input));
3790
3791 result = make_string (decoded, decoded_length);
3792 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3793 return result;
3794 }
3795
3796 Lisp_Object Qyes_or_no_p;
3797
3798 void
3799 syms_of_fns (void)
3800 {
3801 defsymbol (&Qstring_lessp, "string-lessp");
3802 defsymbol (&Qidentity, "identity");
3803 defsymbol (&Qyes_or_no_p, "yes-or-no-p");
3804
3805 DEFSUBR (Fidentity);
3806 DEFSUBR (Frandom);
3807 DEFSUBR (Flength);
3808 DEFSUBR (Fsafe_length);
3809 DEFSUBR (Fstring_equal);
3810 DEFSUBR (Fstring_lessp);
3811 DEFSUBR (Fstring_modified_tick);
3812 DEFSUBR (Fappend);
3813 DEFSUBR (Fconcat);
3814 DEFSUBR (Fvconcat);
3815 DEFSUBR (Fbvconcat);
3816 DEFSUBR (Fcopy_list);
3817 DEFSUBR (Fcopy_sequence);
3818 DEFSUBR (Fcopy_alist);
3819 DEFSUBR (Fcopy_tree);
3820 DEFSUBR (Fsubstring);
3821 DEFSUBR (Fsubseq);
3822 DEFSUBR (Fnthcdr);
3823 DEFSUBR (Fnth);
3824 DEFSUBR (Felt);
3825 DEFSUBR (Flast);
3826 DEFSUBR (Fbutlast);
3827 DEFSUBR (Fnbutlast);
3828 DEFSUBR (Fmember);
3829 DEFSUBR (Fold_member);
3830 DEFSUBR (Fmemq);
3831 DEFSUBR (Fold_memq);
3832 DEFSUBR (Fassoc);
3833 DEFSUBR (Fold_assoc);
3834 DEFSUBR (Fassq);
3835 DEFSUBR (Fold_assq);
3836 DEFSUBR (Frassoc);
3837 DEFSUBR (Fold_rassoc);
3838 DEFSUBR (Frassq);
3839 DEFSUBR (Fold_rassq);
3840 DEFSUBR (Fdelete);
3841 DEFSUBR (Fold_delete);
3842 DEFSUBR (Fdelq);
3843 DEFSUBR (Fold_delq);
3844 DEFSUBR (Fremassoc);
3845 DEFSUBR (Fremassq);
3846 DEFSUBR (Fremrassoc);
3847 DEFSUBR (Fremrassq);
3848 DEFSUBR (Fnreverse);
3849 DEFSUBR (Freverse);
3850 DEFSUBR (Fsort);
3851 DEFSUBR (Fplists_eq);
3852 DEFSUBR (Fplists_equal);
3853 DEFSUBR (Flax_plists_eq);
3854 DEFSUBR (Flax_plists_equal);
3855 DEFSUBR (Fplist_get);
3856 DEFSUBR (Fplist_put);
3857 DEFSUBR (Fplist_remprop);
3858 DEFSUBR (Fplist_member);
3859 DEFSUBR (Fcheck_valid_plist);
3860 DEFSUBR (Fvalid_plist_p);
3861 DEFSUBR (Fcanonicalize_plist);
3862 DEFSUBR (Flax_plist_get);
3863 DEFSUBR (Flax_plist_put);
3864 DEFSUBR (Flax_plist_remprop);
3865 DEFSUBR (Flax_plist_member);
3866 DEFSUBR (Fcanonicalize_lax_plist);
3867 DEFSUBR (Fdestructive_alist_to_plist);
3868 DEFSUBR (Fget);
3869 DEFSUBR (Fput);
3870 DEFSUBR (Fremprop);
3871 DEFSUBR (Fobject_plist);
3872 DEFSUBR (Fequal);
3873 DEFSUBR (Fold_equal);
3874 DEFSUBR (Ffillarray);
3875 DEFSUBR (Fnconc);
3876 DEFSUBR (Fmapcar);
3877 DEFSUBR (Fmapvector);
3878 DEFSUBR (Fmapc_internal);
3879 DEFSUBR (Fmapconcat);
3880 DEFSUBR (Fload_average);
3881 DEFSUBR (Ffeaturep);
3882 DEFSUBR (Frequire);
3883 DEFSUBR (Fprovide);
3884 DEFSUBR (Fbase64_encode_region);
3885 DEFSUBR (Fbase64_encode_string);
3886 DEFSUBR (Fbase64_decode_region);
3887 DEFSUBR (Fbase64_decode_string);
3888 }
3889
3890 void
3891 init_provide_once (void)
3892 {
3893 DEFVAR_LISP ("features", &Vfeatures /*
3894 A list of symbols which are the features of the executing emacs.
3895 Used by `featurep' and `require', and altered by `provide'.
3896 */ );
3897 Vfeatures = Qnil;
3898
3899 Fprovide (intern ("base64"));
3900 }