annotate src/fns.c @ 5303:4c4085177ca5

Fix some bugs in fns.c, discovered in passing while doing other work. 2010-11-14 Aidan Kehoe <kehoea@parhasard.net> * fns.c (Fnreverse): Check that non-list sequences are writable from Lisp before modifying them. (There's an argument that we should do this for list sequences too, but for the moment other code (e.g. #'setcar) doesn't.) (mapcarX): Initialise lisp_vals_staging, lisp_vals_type explicitly, for the sake of compile warnings. Check if lisp_vals_staging is non-NULL when deciding whether to replace a string's range. (Fsome): Cross-reference to #'find-if in the doc string for this function. (Freduce): GCPRO accum in this function, when a key argument is specicified it can be silently garbage-collected. When deciding whether to iterate across a string, check whether the cursor exceeds the byte len; while iterating, increment an integer counter. Don't ABORT() if check_sequence_range() returns when handed a suspicious sequence; it is legal to supply the length of SEQUENCE as the :end keyword value, and this will provoke our suspicions, legitimately enough. (Problems with this function revealed by Paul Dietz' ANSI test suite, thank you Paul Dietz.) (Freplace): Check list sequence lengths using the arguments, not the conses we're currently looking at, thank you Paul Dietz.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 14 Nov 2010 14:54:09 +0000
parents 6468cf6f0b9d
children cde1608596d0 002cb5224e4f
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Random utility Lisp functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 /* Synched up with: Mule 2.0, FSF 19.30. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 /* This file has been Mule-ized. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 /* Note on some machines this defines `vector' as a typedef,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 so make sure we don't use that name in this file. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 #undef vector
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 #define vector *****
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 #include "sysfile.h"
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
40 #include "sysproc.h" /* for qxe_getpid() */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 #include "device.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 #include "events.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 #include "extents.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #include "frame.h"
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
48 #include "process.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 #include "systime.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 #include "insdel.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 #include "lstream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52 #include "opaque.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 /* NOTE: This symbol is also used in lread.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 #define FEATUREP_SYNTAX
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
57 Lisp_Object Qstring_lessp, Qsort, Qmerge, Qfill, Qreplace;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 Lisp_Object Qidentity;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
59 Lisp_Object Qvector, Qarray, Qbit_vector, QsortX, Q_from_end, Q_initial_value;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
60 Lisp_Object Qmapconcat, QmapcarX, Qmapvector, Qmapcan, Qmapc, Qmap, Qmap_into;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
61 Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce;
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
62 Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
64 Lisp_Object Qbase64_conversion_error;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
65
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
66 Lisp_Object Vpath_separator;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
67
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
69 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
71 static DOESNT_RETURN
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
72 mapping_interaction_error (Lisp_Object func, Lisp_Object object)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
73 {
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
74 invalid_state_2 ("object modified while traversing it", func, object);
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
75 }
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
76
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
77 static void
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
78 check_sequence_range (Lisp_Object sequence, Lisp_Object start,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
79 Lisp_Object end, Lisp_Object length)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
80 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
81 Elemcount starting = XINT (start), ending, len = XINT (length);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
82
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
83 ending = NILP (end) ? XINT (length) : XINT (end);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
84
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
85 if (!(0 <= starting && starting <= ending && ending <= len))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
86 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
87 args_out_of_range_3 (sequence, start, make_int (ending));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
88 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
89 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
90
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 static Lisp_Object
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2268
diff changeset
92 mark_bit_vector (Lisp_Object UNUSED (obj))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 static void
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2268
diff changeset
98 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun,
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2268
diff changeset
99 int UNUSED (escapeflag))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
101 Elemcount i;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
102 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
103 Elemcount len = bit_vector_length (v);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
104 Elemcount last = len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 if (INTP (Vprint_length))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 last = min (len, XINT (Vprint_length));
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
108 write_ascstring (printcharfun, "#*");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 for (i = 0; i < last; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 if (bit_vector_bit (v, i))
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
112 write_ascstring (printcharfun, "1");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 else
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
114 write_ascstring (printcharfun, "0");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 if (last != len)
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
118 write_ascstring (printcharfun, "...");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 static int
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
122 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
123 int UNUSED (foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
125 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
126 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 !memcmp (v1->bits, v2->bits,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 sizeof (long)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
133
5191
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
134 /* This needs to be algorithmically identical to internal_array_hash in
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
135 elhash.c when equalp is one, so arrays and bit vectors with the same
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
136 contents hash the same. It would be possible to enforce this by giving
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
137 internal_ARRAYLIKE_hash its own file and including it twice, but right
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
138 now that doesn't seem worth it. */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
139 static Hashcode
5191
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
140 internal_bit_vector_equalp_hash (Lisp_Bit_Vector *v)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
141 {
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
142 int ii, size = bit_vector_length (v);
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
143 Hashcode hash = 0;
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
144
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
145 if (size <= 5)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
146 {
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
147 for (ii = 0; ii < size; ii++)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
148 {
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
149 hash = HASH2
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
150 (hash,
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
151 FLOAT_HASHCODE_FROM_DOUBLE ((double) (bit_vector_bit (v, ii))));
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
152 }
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
153 return hash;
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
154 }
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
155
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
156 /* just pick five elements scattered throughout the array.
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
157 A slightly better approach would be to offset by some
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
158 noise factor from the points chosen below. */
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
159 for (ii = 0; ii < 5; ii++)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
160 hash = HASH2 (hash,
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
161 FLOAT_HASHCODE_FROM_DOUBLE
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
162 ((double) (bit_vector_bit (v, ii * size / 5))));
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
163
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
164 return hash;
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
165 }
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
166
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
167 static Hashcode
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
168 bit_vector_hash (Lisp_Object obj, int UNUSED (depth), Boolint equalp)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
170 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
5191
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
171 if (equalp)
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
172 {
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
173 return HASH2 (bit_vector_length (v),
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
174 internal_bit_vector_equalp_hash (v));
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
175 }
71ee43b8a74d Add #'equalp as a hash test by default; add #'define-hash-table-test, GNU API
Aidan Kehoe <kehoea@parhasard.net>
parents: 5187
diff changeset
176
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 return HASH2 (bit_vector_length (v),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 memory_hash (v->bits,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180 sizeof (long)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
183 static Bytecount
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
184 size_bit_vector (Lisp_Object obj)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
185 {
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
186 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
187 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
188 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
189 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
190
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1067
diff changeset
191 static const struct memory_description bit_vector_description[] = {
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4693
diff changeset
196 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("bit-vector", bit_vector,
5124
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
197 mark_bit_vector,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
198 print_bit_vector, 0,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
199 bit_vector_equal,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
200 bit_vector_hash,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
201 bit_vector_description,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
202 size_bit_vector,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
203 Lisp_Bit_Vector);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
204
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 DEFUN ("identity", Fidentity, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 Return the argument unchanged.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 return arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 DEFUN ("random", Frandom, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 Return a pseudo-random number.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
216 All fixnums are equally likely. On most systems, this is 31 bits' worth.
5302
6468cf6f0b9d Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5300
diff changeset
217 With positive integer argument LIMIT, return random number in interval [0,
6468cf6f0b9d Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5300
diff changeset
218 LIMIT). LIMIT can be a bignum, in which case the range of possible values
6468cf6f0b9d Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5300
diff changeset
219 is extended. With argument t, set the random number seed from the current
6468cf6f0b9d Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5300
diff changeset
220 time and pid.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 (limit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 EMACS_INT val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 unsigned long denominator;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 if (EQ (limit, Qt))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
228 seed_random (qxe_getpid () + time (NULL));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 if (NATNUMP (limit) && !ZEROP (limit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 /* Try to take our random number from the higher bits of VAL,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 not the lower, since (says Gentzel) the low bits of `random'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 are less random than the higher ones. We do this by using the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 quotient rather than the remainder. At the high end of the RNG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 it's possible to get a quotient larger than limit; discarding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 these values eliminates the bias that would otherwise appear
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 when using a large limit. */
2039
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1983
diff changeset
238 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 val = get_random () / denominator;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 while (val >= XINT (limit));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
243 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
244 else if (BIGNUMP (limit))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
245 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
246 bignum_random (scratch_bignum, XBIGNUM_DATA (limit));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
247 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
248 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
249 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 val = get_random ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 return make_int (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256 /* Random data-structure functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 /* #### Delete this shit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 /* Charcount is a misnomer here as we might be dealing with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 length of a vector or list, but emphasizes that we're not dealing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 with Bytecounts in strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 static Charcount
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 length_with_bytecode_hack (Lisp_Object seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 if (!COMPILED_FUNCTIONP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 return XINT (Flength (seq));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
272 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 f->flags.domainp ? COMPILED_DOMAIN :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 COMPILED_DOC_STRING)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 #endif /* LOSING_BYTECODE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 void
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
284 check_losing_bytecode (const Ascbyte *function, Lisp_Object seq)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 if (COMPILED_FUNCTIONP (seq))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
287 signal_ferror_with_frob
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
288 (Qinvalid_argument, seq,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 "As of 20.3, `%s' no longer works with compiled-function objects",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 DEFUN ("length", Flength, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 Return the length of vector, bit vector, list or string SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296 (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 if (STRINGP (sequence))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
300 return make_int (string_char_length (sequence));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 else if (CONSP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
303 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 GET_EXTERNAL_LIST_LENGTH (sequence, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 return make_int (len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307 else if (VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 return make_int (XVECTOR_LENGTH (sequence));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 else if (NILP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 return Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 else if (BIT_VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 check_losing_bytecode ("length", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 Return the length of a list, but avoid error or infinite loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 This function never gets an error. If LIST is not really a list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 it returns 0. If LIST is circular, it returns a finite value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 which is at least the number of distinct elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 Lisp_Object hare, tortoise;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
330 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 for (hare = tortoise = list, len = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 hare = XCDR (hare), len++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 if (len & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 return make_int (len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
343 /* This is almost the above, but is defined by Common Lisp. We need it in C
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
344 for shortest_length_among_sequences(), below, for the various sequence
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
345 functions that can usefully operate on circular lists. */
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
346
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
347 DEFUN ("list-length", Flist_length, 1, 1, 0, /*
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
348 Return the length of LIST. Return nil if LIST is circular.
5299
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5285
diff changeset
349 Error if LIST is dotted.
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
350 */
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
351 (list))
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
352 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
353 Lisp_Object hare, tortoise;
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
354 Elemcount len;
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
355
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
356 for (hare = tortoise = list, len = 0;
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
357 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
358 hare = XCDR (hare), len++)
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
359 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
360 if (len & 1)
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
361 tortoise = XCDR (tortoise);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
362 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
363
5299
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5285
diff changeset
364 if (!LISTP (hare))
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5285
diff changeset
365 {
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5285
diff changeset
366 signal_malformed_list_error (list);
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5285
diff changeset
367 }
28651c24b3f8 Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents: 5285
diff changeset
368
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
369 return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
370 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
371
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372 /*** string functions. ***/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 Return t if two strings have identical contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 Case is significant. Text properties are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 \(Under XEmacs, `equal' also ignores text properties and extents in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 `equal' is the same as in XEmacs, in that respect.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 Symbols are also allowed; their print names are used instead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
382 (string1, string2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 Bytecount len;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
385 Lisp_Object p1, p2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
387 if (SYMBOLP (string1))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
388 p1 = XSYMBOL (string1)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
391 CHECK_STRING (string1);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
392 p1 = string1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
395 if (SYMBOLP (string2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
396 p2 = XSYMBOL (string2)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
399 CHECK_STRING (string2);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
400 p2 = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
403 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) &&
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
404 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
407 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
408 Compare the contents of two strings, maybe ignoring case.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
409 In string STR1, skip the first START1 characters and stop at END1.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
410 In string STR2, skip the first START2 characters and stop at END2.
4796
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
411 END1 and END2 default to the full lengths of the respective strings,
4797
a5eca70cf401 Fix typo in last patch.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4796
diff changeset
412 and arguments that are outside the string (negative STARTi or ENDi
4796
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
413 greater than length) are coerced to 0 or string length as appropriate.
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
414
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
415 Optional IGNORE-CASE non-nil means use case-insensitive comparison.
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
416 Case is significant by default.
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
417
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
418 The value is t if the strings (or specified portions) match.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
419 If string STR1 is less, the value is a negative number N;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
420 - 1 - N is the number of characters that match at the beginning.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
421 If string STR1 is greater, the value is a positive number N;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
422 N - 1 is the number of characters that match at the beginning.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
423 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
424 (str1, start1, end1, str2, start2, end2, ignore_case))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
425 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
426 Charcount ccstart1, ccend1, ccstart2, ccend2;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
427 Bytecount bstart1, blen1, bstart2, blen2;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
428 Charcount matching;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
429 int res;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
430
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
431 CHECK_STRING (str1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
432 CHECK_STRING (str2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
433 get_string_range_char (str1, start1, end1, &ccstart1, &ccend1,
4796
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
434 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
435 get_string_range_char (str2, start2, end2, &ccstart2, &ccend2,
4796
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
436 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
437
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
438 bstart1 = string_index_char_to_byte (str1, ccstart1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
439 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
440 bstart2 = string_index_char_to_byte (str2, ccstart2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
441 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
442
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
443 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
444 (XSTRING_DATA (str1) + bstart1, blen1,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
445 XSTRING_DATA (str2) + bstart2, blen2,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
446 &matching));
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
447
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
448 if (!res)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
449 return Qt;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
450 else if (res > 0)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
451 return make_int (1 + matching);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
452 else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
453 return make_int (-1 - matching);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
454 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
455
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 Return t if first arg string is less than second in lexicographic order.
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
458 Comparison is simply done on a character-by-character basis using the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
459 numeric value of a character. (Note that this may not produce
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
460 particularly meaningful results under Mule if characters from
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
461 different charsets are being compared.)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 Symbols are also allowed; their print names are used instead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
465 Currently we don't do proper language-specific collation or handle
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
466 multiple character sets. This may be changed when Unicode support
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
467 is implemented.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
469 (string1, string2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
471 Lisp_Object p1, p2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 Charcount end, len2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
475 if (SYMBOLP (string1))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
476 p1 = XSYMBOL (string1)->name;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
477 else
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
478 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
479 CHECK_STRING (string1);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
480 p1 = string1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
483 if (SYMBOLP (string2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
484 p2 = XSYMBOL (string2)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
487 CHECK_STRING (string2);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
488 p2 = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
491 end = string_char_length (p1);
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
492 len2 = string_char_length (p2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 if (end > len2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 end = len2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
497 Ibyte *ptr1 = XSTRING_DATA (p1);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
498 Ibyte *ptr2 = XSTRING_DATA (p2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 /* #### It is not really necessary to do this: We could compare
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 byte-by-byte and still get a reasonable comparison, since this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 would compare characters with a charset in the same way. With
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 a little rearrangement of the leading bytes, we could make most
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 inter-charset comparisons work out the same, too; even if some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 don't, this is not a big deal because inter-charset comparisons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 aren't really well-defined anyway. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 for (i = 0; i < end; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
509 if (itext_ichar (ptr1) != itext_ichar (ptr2))
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
510 return itext_ichar (ptr1) < itext_ichar (ptr2) ? Qt : Qnil;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
511 INC_IBYTEPTR (ptr1);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
512 INC_IBYTEPTR (ptr2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 won't work right in I18N2 case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 return end < len2 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 Return STRING's tick counter, incremented for each change to the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 Each string has a tick counter which is incremented each time the contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 of the string are changed (e.g. with `aset'). It wraps around occasionally.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 (string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 CHECK_STRING (string);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
528 if (CONSP (XSTRING_PLIST (string)) && INTP (XCAR (XSTRING_PLIST (string))))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
529 return XCAR (XSTRING_PLIST (string));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 return Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 bump_string_modiff (Lisp_Object str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
537 Lisp_Object *ptr = &XSTRING_PLIST (str);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 /* #### remove the `string-translatable' property from the string,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 if there is one. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 /* skip over extent info if it's there */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 ptr = &XCDR (*ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
547 XCAR (*ptr) = make_int (1+XINT (XCAR (*ptr)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 *ptr = Fcons (make_int (1), *ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 static Lisp_Object concat (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 enum concat_target_type target_type,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 int last_special);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
559 concat2 (Lisp_Object string1, Lisp_Object string2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 Lisp_Object args[2];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
562 args[0] = string1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
563 args[1] = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 return concat (2, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
568 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 Lisp_Object args[3];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
571 args[0] = string1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
572 args[1] = string2;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
573 args[2] = string3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 return concat (3, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
578 vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 Lisp_Object args[2];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
581 args[0] = vec1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
582 args[1] = vec2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 return concat (2, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
587 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 Lisp_Object args[3];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
590 args[0] = vec1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
591 args[1] = vec2;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
592 args[2] = vec3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 return concat (3, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 DEFUN ("append", Fappend, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 Concatenate all the arguments and make the result a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 The result is a list whose elements are the elements of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 Each argument may be a list, vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 The last argument is not copied, just used as the tail of the new list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 Also see: `nconc'.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
602
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
603 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 return concat (nargs, args, c_cons, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 Concatenate all the arguments and make the result a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 The result is a string whose elements are the elements of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 Each argument may be a string or a list or vector of characters.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 As of XEmacs 21.0, this function does NOT accept individual integers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 as arguments. Old code that relies on, for example, (concat "foo" 50)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 returning "foo50" will fail. To fix such code, either apply
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 `int-to-string' to the integer argument, or use `format'.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
619
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
620 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 return concat (nargs, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 Concatenate all the arguments and make the result a vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 The result is a vector whose elements are the elements of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 Each argument may be a list, vector, bit vector, or string.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
631
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
632 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 return concat (nargs, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 Concatenate all the arguments and make the result a bit vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 The result is a bit vector whose elements are the elements of all the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 arguments. Each argument may be a list, vector, bit vector, or string.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
643
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
644 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 return concat (nargs, args, c_bit_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 /* Copy a (possibly dotted) list. LIST must be a cons.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 copy_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 Lisp_Object last = list_copy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 Lisp_Object hare, tortoise;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
659 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 for (tortoise = hare = XCDR (list), len = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 CONSP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 hare = XCDR (hare), len++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 last = XCDR (last);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 if (len & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 if (EQ (tortoise, hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 signal_circular_list_error (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 return list_copy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 Return a copy of list LIST, which may be a dotted list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 The elements of LIST are not copied; they are shared
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 with the original.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 again:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 if (NILP (list)) return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 if (CONSP (list)) return copy_list (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 list = wrong_type_argument (Qlistp, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 goto again;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 Return a copy of list, vector, bit vector or string SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 The elements of a list or vector are not copied; they are shared
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 with the original. SEQUENCE may be a dotted list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 again:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 if (NILP (sequence)) return sequence;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 if (CONSP (sequence)) return copy_list (sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 check_losing_bytecode ("copy-sequence", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 goto again;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 struct merge_string_extents_struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 Lisp_Object string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 Bytecount entry_offset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 Bytecount entry_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 concat (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 enum concat_target_type target_type,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 int last_special)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 Lisp_Object tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 int toindex;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 int argnum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 Lisp_Object last_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 Lisp_Object prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 struct merge_string_extents_struct *args_mse = 0;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
732 Ibyte *string_result = 0;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
733 Ibyte *string_result_ptr = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 struct gcpro gcpro1;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
735 int sdep = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 /* The modus operandi in Emacs is "caller gc-protects args".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 However, concat is called many times in Emacs on freshly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 created stuff. So we help those callers out by protecting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 the args ourselves to save them a lot of temporary-variable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 grief. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 gcpro1.nvars = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 /* #### if the result is a string and any of the strings have a string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 for the `string-translatable' property, then concat should also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 concat the args but use the `string-translatable' strings, and store
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 the result in the returned string's `string-translatable' property. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 if (target_type == c_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 /* In append, the last arg isn't treated like the others */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 if (last_special && nargs > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 nargs--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 last_tail = args[nargs];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 last_tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 /* Check and coerce the arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 Lisp_Object seq = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 if (LISTP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 else if (COMPILED_FUNCTIONP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 /* Urk! We allow this, for "compatibility"... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 #if 0 /* removed for XEmacs 21 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 else if (INTP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 /* This is too revolting to think about but maintains
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 compatibility with FSF (and lots and lots of old code). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 args[argnum] = Fnumber_to_string (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 check_losing_bytecode ("concat", seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 args[argnum] = wrong_type_argument (Qsequencep, seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 if (args_mse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 args_mse[argnum].string = seq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 args_mse[argnum].string = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 /* Charcount is a misnomer here as we might be dealing with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 length of a vector or list, but emphasizes that we're not dealing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 with Bytecounts in strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 Charcount total_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 Charcount thislen = length_with_bytecode_hack (args[argnum]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 Charcount thislen = XINT (Flength (args[argnum]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 total_length += thislen;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 switch (target_type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 case c_cons:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 if (total_length == 0)
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
818 {
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
819 unbind_to (sdep);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
820 /* In append, if all but last arg are nil, return last arg */
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
821 RETURN_UNGCPRO (last_tail);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
822 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 val = Fmake_list (make_int (total_length), Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 case c_vector:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 val = make_vector (total_length, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 case c_bit_vector:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 val = make_bit_vector (total_length, Qzero);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 case c_string:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 /* We don't make the string yet because we don't know the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 actual number of bytes. This loop was formerly written
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 to call Fmake_string() here and then call set_string_char()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 for each char. This seems logical enough but is waaaaaaaay
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 slow -- set_string_char() has to scan the whole string up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 to the place where the substitution is called for in order
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 to find the place to change, and may have to do some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 realloc()ing in order to make the char fit properly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 O(N^2) yuckage. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 val = Qnil;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
842 string_result =
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
843 (Ibyte *) MALLOC_OR_ALLOCA (total_length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 string_result_ptr = string_result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 default:
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
847 val = Qnil;
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
848 ABORT ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 if (CONSP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 tail = val, toindex = -1; /* -1 in toindex is flag we are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 making a list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 toindex = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 Charcount thisleni = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 Charcount thisindex = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865 Lisp_Object seq = args[argnum];
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
866 Ibyte *string_source_ptr = 0;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
867 Ibyte *string_prev_result_ptr = string_result_ptr;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 if (!CONSP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 thisleni = length_with_bytecode_hack (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 thisleni = XINT (Flength (seq));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 string_source_ptr = XSTRING_DATA (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 Lisp_Object elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 /* We've come to the end of this arg, so exit. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 if (NILP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 /* Fetch next element of `seq' arg into `elt' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 if (CONSP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 elt = XCAR (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 seq = XCDR (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 if (thisindex >= thisleni)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
901 elt = make_char (itext_ichar (string_source_ptr));
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
902 INC_IBYTEPTR (string_source_ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 else if (VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 elt = XVECTOR_DATA (seq)[thisindex];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 else if (BIT_VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 thisindex));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 elt = Felt (seq, make_int (thisindex));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 thisindex++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 /* Store into result */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 if (toindex < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 /* toindex negative means we are making a list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 XCAR (tail) = elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 else if (VECTORP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 XVECTOR_DATA (val)[toindex++] = elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 else if (BIT_VECTORP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 CHECK_BIT (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
927 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
929 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 CHECK_CHAR_COERCE_INT (elt);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
932 string_result_ptr += set_itext_ichar (string_result_ptr,
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
933 XCHAR (elt));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
934 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
935 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 if (args_mse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 args_mse[argnum].entry_offset =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 string_prev_result_ptr - string_result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 args_mse[argnum].entry_length =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 string_result_ptr - string_prev_result_ptr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
943 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
944
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
945 /* Now we finally make the string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 if (target_type == c_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 val = make_string (string_result, string_result_ptr - string_result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
951 if (STRINGP (args_mse[argnum].string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
952 copy_string_extents (val, args_mse[argnum].string,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
953 args_mse[argnum].entry_offset, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
954 args_mse[argnum].entry_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
955 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 if (!NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 XCDR (prev) = last_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
961 unbind_to (sdep);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 Return a copy of ALIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
967 This is an alist which represents the same mapping from objects to objects,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
968 but does not share the alist structure with ALIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 The objects mapped (cars and cdrs of elements of the alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 are shared, however.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 Elements of ALIST that are not conses are also shared.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
976
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977 if (NILP (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 return alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 CHECK_CONS (alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 alist = concat (1, &alist, c_cons, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 for (tail = alist; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
984 Lisp_Object car = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 if (CONSP (car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 return alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
993 Return a copy of a list and substructures.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 The argument is copied, and any lists contained within it are copied
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 recursively. Circularities and shared substructures are not preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 are not copied.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 (arg, vecp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 {
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1001 return safe_copy_tree (arg, vecp, 0);
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1002 }
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1003
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1004 Lisp_Object
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1005 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1006 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1007 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
1008 stack_overflow ("Stack overflow in copy-tree", arg);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1009
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 if (CONSP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1011 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 rest = arg = Fcopy_sequence (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 while (CONSP (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 Lisp_Object elt = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 if (CONSP (elt) || VECTORP (elt))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1019 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1020 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1021 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 rest = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1023 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1024 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 else if (VECTORP (arg) && ! NILP (vecp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1026 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 int i = XVECTOR_LENGTH (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028 int j;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 arg = Fcopy_sequence (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 for (j = 0; j < i; j++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 Lisp_Object elt = XVECTOR_DATA (arg) [j];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 if (CONSP (elt) || VECTORP (elt))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
1035 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1036 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1037 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1038 return arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1039 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1040
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1041 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1042 Return the subsequence of SEQUENCE starting at START and ending before END.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1043 END may be omitted; then the subsequence runs to the end of SEQUENCE.
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1044
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1045 If START or END is negative, it counts from the end, in contravention of
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1046 Common Lisp.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1047 The returned subsequence is always of the same type as SEQUENCE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1048 If SEQUENCE is a string, relevant parts of the string-extent-data
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1049 are copied to the new string.
5224
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1050
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1051 See also `substring-no-properties', which only operates on strings, and does
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1052 not copy extent data.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1053 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1054 (sequence, start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1055 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1056 Elemcount len, ss, ee = EMACS_INT_MAX, ii;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1057 Lisp_Object result = Qnil;
5089
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
1058
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
1059 CHECK_SEQUENCE (sequence);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1060 CHECK_INT (start);
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1061 ss = XINT (start);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1062
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1063 if (!NILP (end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1064 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1065 CHECK_INT (end);
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1066 ee = XINT (end);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1067 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1068
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1069 if (STRINGP (sequence))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1070 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1071 Bytecount bstart, blen;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1072
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1073 get_string_range_char (sequence, start, end, &ss, &ee,
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1074 GB_HISTORICAL_STRING_BEHAVIOR);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1075 bstart = string_index_char_to_byte (sequence, ss);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1076 blen = string_offset_char_to_byte_len (sequence, bstart, ee - ss);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1077
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1078 result = make_string (XSTRING_DATA (sequence) + bstart, blen);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1079 /* Copy any applicable extent information into the new string. */
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1080 copy_string_extents (result, sequence, 0, bstart, blen);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1081 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1082 else if (CONSP (sequence))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1083 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1084 Lisp_Object result_tail, saved = sequence;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1085
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1086 if (ss < 0 || ee < 0)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1087 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1088 len = XINT (Flength (sequence));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1089 if (ss < 0)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1090 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1091 ss = len + ss;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1092 start = make_integer (ss);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1093 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1094
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1095 if (ee < 0)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1096 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1097 ee = len + ee;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1098 end = make_integer (ee);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1099 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1100 else
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1101 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1102 ee = min (ee, len);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1103 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1104 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1105
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1106 if (0 != ss)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1107 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1108 sequence = Fnthcdr (make_int (ss), sequence);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1109 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1110
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
1111 ii = ss + 1;
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
1112
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1113 if (ss < ee && !NILP (sequence))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1114 {
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
1115 result = result_tail = Fcons (Fcar (sequence), Qnil);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1116 sequence = Fcdr (sequence);
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1117
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1118 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1119 EXTERNAL_LIST_LOOP_2 (elt, sequence)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1120 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1121 if (!(ii < ee))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1122 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1123 break;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1124 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1125
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1126 XSETCDR (result_tail, Fcons (elt, Qnil));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1127 result_tail = XCDR (result_tail);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1128 ii++;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1129 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1130 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1131 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1132
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1133 if (NILP (result) || (ii < ee && !NILP (end)))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1134 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1135 /* We were handed a cons, which definitely has elements. nil
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1136 result means either ss >= ee or SEQUENCE was nil after the
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1137 nthcdr; in both cases that means START and END were incorrectly
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1138 specified for this sequence. ii < ee with a non-nil end means
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1139 the user handed us a bogus end value. */
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1140 check_sequence_range (saved, start, end, Flength (saved));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1141 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1142 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1143 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1144 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1145 len = XINT (Flength (sequence));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1146 if (ss < 0)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1147 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1148 ss = len + ss;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1149 start = make_integer (ss);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1150 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1151
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1152 if (ee < 0)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1153 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1154 ee = len + ee;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1155 end = make_integer (ee);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1156 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1157 else
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1158 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1159 ee = min (len, ee);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1160 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1161
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1162 check_sequence_range (sequence, start, end, make_int (len));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1163
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1164 if (VECTORP (sequence))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1165 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1166 result = Fvector (ee - ss, XVECTOR_DATA (sequence) + ss);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1167 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1168 else if (BIT_VECTORP (sequence))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1169 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1170 result = make_bit_vector (ee - ss, Qzero);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1171
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1172 for (ii = ss; ii < ee; ii++)
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1173 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1174 set_bit_vector_bit (XBIT_VECTOR (result), ii - ss,
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1175 bit_vector_bit (XBIT_VECTOR (sequence), ii));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1176 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1177 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1178 else if (NILP (sequence))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1179 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1180 DO_NOTHING;
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1181 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1182 else
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1183 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1184 /* Won't happen, since CHECK_SEQUENCE didn't error. */
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1185 ABORT ();
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1186 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1187 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1188
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
1189 return result;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191
5224
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1192 DEFUN ("substring-no-properties", Fsubstring_no_properties, 1, 3, 0, /*
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1193 Return a substring of STRING, without copying the extents.
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1194 END may be nil or omitted; then the substring runs to the end of STRING.
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1195 If START or END is negative, it counts from the end.
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1196
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1197 With one argument, copy STRING without its properties.
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1198 */
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1199 (string, start, end))
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1200 {
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1201 Charcount ccstart, ccend;
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1202 Bytecount bstart, blen;
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1203 Lisp_Object val;
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1204
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1205 get_string_range_char (string, start, end, &ccstart, &ccend,
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1206 GB_HISTORICAL_STRING_BEHAVIOR);
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1207 bstart = string_index_char_to_byte (string, ccstart);
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1208 blen = string_offset_char_to_byte_len (string, bstart, ccend - ccstart);
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1209 val = make_string (XSTRING_DATA (string) + bstart, blen);
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1210
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1211 return val;
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1212 }
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
1213
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1214 /* Split STRING into a list of substrings. The substrings are the
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1215 parts of original STRING separated by SEPCHAR.
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1216
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1217 If UNESCAPE is non-zero, ESCAPECHAR specifies a character that will quote
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1218 SEPCHAR, and cause it not to split STRING. A double ESCAPECHAR is
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1219 necessary for ESCAPECHAR to appear once in a substring. */
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1220
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1221 static Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1222 split_string_by_ichar_1 (const Ibyte *string, Bytecount size,
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1223 Ichar sepchar, int unescape, Ichar escapechar)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1224 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1225 Lisp_Object result = Qnil;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1226 const Ibyte *end = string + size;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1227
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1228 if (unescape)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1229 {
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1230 Ibyte unescape_buffer[64], *unescape_buffer_ptr = unescape_buffer,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1231 escaped[MAX_ICHAR_LEN], *unescape_cursor;
5036
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents: 5035
diff changeset
1232 Bytecount unescape_buffer_size = countof (unescape_buffer),
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents: 5035
diff changeset
1233 escaped_len = set_itext_ichar (escaped, escapechar);
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents: 5035
diff changeset
1234 Boolint deleting_escapes, previous_escaped;
9624523604c5 Use better types when ESCAPECHAR is specified, split_string_by_ichar_1
Aidan Kehoe <kehoea@parhasard.net>
parents: 5035
diff changeset
1235 Ichar pchar;
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1236
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1237 while (1)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1238 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1239 const Ibyte *p = string, *cursor;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1240 deleting_escapes = 0;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1241 previous_escaped = 0;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1242
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1243 while (p < end)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1244 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1245 pchar = itext_ichar (p);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1246
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1247 if (pchar == sepchar)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1248 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1249 if (!previous_escaped)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1250 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1251 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1252 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1253 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1254 else if (pchar == escapechar
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1255 /* Doubled escapes don't escape: */
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1256 && !previous_escaped)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1257 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1258 ++deleting_escapes;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1259 previous_escaped = 1;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1260 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1261 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1262 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1263 previous_escaped = 0;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1264 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1265
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1266 INC_IBYTEPTR (p);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1267 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1268
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1269 if (deleting_escapes)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1270 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1271 if (((p - string) - (escaped_len * deleting_escapes))
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1272 > unescape_buffer_size)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1273 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1274 unescape_buffer_size =
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1275 ((p - string) - (escaped_len * deleting_escapes)) * 1.5;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1276 unescape_buffer_ptr = alloca_ibytes (unescape_buffer_size);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1277 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1278
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1279 cursor = string;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1280 unescape_cursor = unescape_buffer_ptr;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1281 previous_escaped = 0;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1282
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1283 while (cursor < p)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1284 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1285 pchar = itext_ichar (cursor);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1286
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1287 if (pchar != escapechar || previous_escaped)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1288 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1289 memcpy (unescape_cursor, cursor,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1290 itext_ichar_len (cursor));
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1291 INC_IBYTEPTR (unescape_cursor);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1292 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1293
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1294 previous_escaped = !previous_escaped
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1295 && (pchar == escapechar);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1296
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1297 INC_IBYTEPTR (cursor);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1298 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1299
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1300 result = Fcons (make_string (unescape_buffer_ptr,
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1301 unescape_cursor
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1302 - unescape_buffer_ptr),
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1303 result);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1304 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1305 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1306 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1307 result = Fcons (make_string (string, p - string), result);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1308 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1309 if (p < end)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1310 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1311 string = p;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1312 INC_IBYTEPTR (string); /* skip sepchar */
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1313 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1314 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1315 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1316 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1317 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1318 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1319 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1320 while (1)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1321 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1322 const Ibyte *p = string;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1323 while (p < end)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1324 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1325 if (itext_ichar (p) == sepchar)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1326 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1327 INC_IBYTEPTR (p);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1328 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1329 result = Fcons (make_string (string, p - string), result);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1330 if (p < end)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1331 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1332 string = p;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1333 INC_IBYTEPTR (string); /* skip sepchar */
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1334 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1335 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1336 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1337 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1338 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1339 return Fnreverse (result);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1340 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1341
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1342 /* The same as the above, except PATH is an external C string (it is
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1343 converted using Qfile_name), and sepchar is hardcoded to SEPCHAR
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1344 (':' or whatever). */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1345 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1346 split_external_path (const Extbyte *path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1347 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1348 Bytecount newlen;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1349 Ibyte *newpath;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1350 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1351 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1352
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1353 TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1354
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1355 /* #### Does this make sense? It certainly does for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1356 split_env_path(), but it looks dubious here. Does any code
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1357 depend on split_external_path("") returning nil instead of an empty
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1358 string? */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1359 if (!newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1360 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1361
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1362 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR, 0, 0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1363 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1364
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1365 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1366 split_env_path (const CIbyte *evarname, const Ibyte *default_)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1367 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1368 const Ibyte *path = 0;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1369 if (evarname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1370 path = egetenv (evarname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1371 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1372 path = default_;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1373 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1374 return Qnil;
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1375 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR, 0, 0);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1376 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1377
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1378 /* Ben thinks this function should not exist or be exported to Lisp.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1379 We use it to define split-path-string in subr.el (not!). */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1380
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1381 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 3, 0, /*
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1382 Split STRING into a list of substrings originally separated by SEPCHAR.
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1383
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1384 With optional ESCAPE-CHAR, any instances of SEPCHAR preceded by that
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1385 character will not split the string, and a double instance of ESCAPE-CHAR
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1386 will be necessary for a single ESCAPE-CHAR to appear in the output string.
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1387 */
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1388 (string, sepchar, escape_char))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1389 {
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1390 Ichar escape_ichar = 0;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1391
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1392 CHECK_STRING (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1393 CHECK_CHAR (sepchar);
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1394 if (!NILP (escape_char))
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1395 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1396 CHECK_CHAR (escape_char);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1397 escape_ichar = XCHAR (escape_char);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1398 }
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1399 return split_string_by_ichar_1 (XSTRING_DATA (string),
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1400 XSTRING_LENGTH (string),
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1401 XCHAR (sepchar),
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1402 !NILP (escape_char), escape_ichar);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1403 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1404
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1405 /* #### This was supposed to be in subr.el, but is used VERY early in
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1406 the bootstrap process, so it goes here. Damn. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1407
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1408 DEFUN ("split-path", Fsplit_path, 1, 1, 0, /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1409 Explode a search path into a list of strings.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1410 The path components are separated with the characters specified
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1411 with `path-separator'.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1412 */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1413 (path))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1414 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1415 CHECK_STRING (path);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1416
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1417 while (!STRINGP (Vpath_separator)
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1418 || (string_char_length (Vpath_separator) != 1))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1419 Vpath_separator = signal_continuable_error
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1420 (Qinvalid_state,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1421 "`path-separator' should be set to a single-character string",
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1422 Vpath_separator);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1423
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1424 return (split_string_by_ichar_1
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1425 (XSTRING_DATA (path), XSTRING_LENGTH (path),
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1426 itext_ichar (XSTRING_DATA (Vpath_separator)), 0, 0));
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1427 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1428
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1429
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 Take cdr N times on LIST, and return the result.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 (n, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
1435 /* This function can GC */
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 578
diff changeset
1436 REGISTER EMACS_INT i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 for (i = XINT (n); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 if (CONSP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 else if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 tail = wrong_type_argument (Qlistp, tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 i++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1454 DEFUN ("nth", Fnth, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 Return the Nth element of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 N counts from zero. If LIST is not that long, nil is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1457 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 (n, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
1460 /* This function can GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461 return Fcar (Fnthcdr (n, list));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1462 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1463
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 DEFUN ("elt", Felt, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465 Return element of SEQUENCE at index N.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 (sequence, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
1469 /* This function can GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 CHECK_INT_COERCE_CHAR (n); /* yuck! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 if (LISTP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474 Lisp_Object tem = Fnthcdr (n, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 /* #### Utterly, completely, fucking disgusting.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1476 * #### The whole point of "elt" is that it operates on
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 * #### sequences, and does error- (bounds-) checking.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1478 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479 if (CONSP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 return XCAR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 /* This is The Way It Has Always Been. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486 /* This is The Way Mly and Cltl2 say It Should Be. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487 args_out_of_range (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1489 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1490 else if (STRINGP (sequence) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491 VECTORP (sequence) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1492 BIT_VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1493 return Faref (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1494 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1495 else if (COMPILED_FUNCTIONP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1496 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 EMACS_INT idx = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498 if (idx < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1500 lose:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 args_out_of_range (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503 /* Utter perversity */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 switch (idx)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 case COMPILED_ARGLIST:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509 return compiled_function_arglist (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1510 case COMPILED_INSTRUCTIONS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 return compiled_function_instructions (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 case COMPILED_CONSTANTS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513 return compiled_function_constants (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514 case COMPILED_STACK_DEPTH:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 return compiled_function_stack_depth (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 case COMPILED_DOC_STRING:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 return compiled_function_documentation (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 case COMPILED_DOMAIN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 return compiled_function_domain (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 case COMPILED_INTERACTIVE:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 if (f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 return compiled_function_interactive (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523 /* if we return nil, can't tell interactive with no args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 from noninteractive. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 goto lose;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 goto lose;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 #endif /* LOSING_BYTECODE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 check_losing_bytecode ("elt", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 DEFUN ("last", Flast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 Return the tail of list LIST, of length N (default 1).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542 LIST may be a dotted list, but not a circular list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543 Optional argument N must be a non-negative integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 If N is zero, then the atom that terminates the list is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 If N is greater than the length of LIST, then LIST itself is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1549 EMACS_INT int_n, count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 Lisp_Object retval, tortoise, hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1551
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1552 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1554 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562 for (retval = tortoise = hare = list, count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563 CONSP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1564 hare = XCDR (hare),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566 count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1567 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1568 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1569
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1572 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 signal_circular_list_error (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 return retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580 Modify LIST to remove the last N (default 1) elements.
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1581
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1583 Otherwise, LIST may be dotted, but not circular.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 {
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1587 Elemcount int_n = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1591 if (!NILP (n))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1597 if (CONSP (list))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1598 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1599 Lisp_Object last_cons = list;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1600
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1601 EXTERNAL_LIST_LOOP_3 (elt, list, tail)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1602 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1603 if (int_n-- < 0)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1604 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1605 last_cons = XCDR (last_cons);
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1606 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1607
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1608 if (!CONSP (XCDR (tail)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1609 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1610 break;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1611 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1612 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1613
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1614 if (int_n >= 0)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1615 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1616 return Qnil;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1617 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1618
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1619 XCDR (last_cons) = Qnil;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1620 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1621
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1622 return list;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 Return a copy of LIST with the last N (default 1) elements removed.
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1627
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 If LIST has N or fewer elements, nil is returned.
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1629 Otherwise, LIST may be dotted, but not circular, and `(butlast LIST 0)'
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1630 converts a dotted into a true list.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 {
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1634 Lisp_Object retval = Qnil, retval_tail = Qnil;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1635 Elemcount int_n = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1639 if (!NILP (n))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644
5285
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1645 if (CONSP (list))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1646 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1647 Lisp_Object tail = list;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1648
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1649 EXTERNAL_LIST_LOOP_3 (elt, list, list_tail)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1650 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1651 if (--int_n < 0)
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1652 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1653 if (NILP (retval_tail))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1654 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1655 retval = retval_tail = Fcons (XCAR (tail), Qnil);
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1656 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1657 else
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1658 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1659 XSETCDR (retval_tail, Fcons (XCAR (tail), Qnil));
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1660 retval_tail = XCDR (retval_tail);
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1661 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1662
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1663 tail = XCDR (tail);
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1664 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1665
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1666 if (!CONSP (XCDR (list_tail)))
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1667 {
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1668 break;
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1669 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1670 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1671 }
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1672
99de5fd48e87 Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents: 5283
diff changeset
1673 return retval;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 DEFUN ("member", Fmember, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1684 if (internal_equal (elt, list_elt, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1689
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1691 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1692 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1694 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1695 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1696 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1697 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1700 if (internal_old_equal (elt, list_elt, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1701 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1702 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1703 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1704 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1706 DEFUN ("memq", Fmemq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1707 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1708 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1709 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1710 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1711 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1712 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1717 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1721 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 if (HACKEQ_UNSAFE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1734 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1735
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1736 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 memq_no_quit (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1738 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1748 Return non-nil if KEY is `equal' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1749 The value is actually the element of ALIST whose car equals KEY.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1751 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1752 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1753 /* This function can GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1754 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 if (internal_equal (key, elt_car, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1763 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1764 The value is actually the element of ALIST whose car equals KEY.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1766 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768 /* This function can GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1769 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1770 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771 if (internal_old_equal (key, elt_car, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1778 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1782 return unbind_to_1 (speccount, Fassoc (key, alist));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785 DEFUN ("assq", Fassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1786 Return non-nil if KEY is `eq' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1787 The value is actually the element of ALIST whose car is KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1788 Elements of ALIST that are not conses are ignored.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1790 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1792 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1801 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1802 The value is actually the element of ALIST whose car is KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1803 Elements of ALIST that are not conses are ignored.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1807 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1809 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 if (HACKEQ_UNSAFE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 /* Like Fassq but never report an error and do not allow quits.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 Use only on lists known never to be circular. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1821 assq_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 /* This cannot GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1824 LIST_LOOP_2 (elt, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1826 Lisp_Object elt_car = XCAR (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1830 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1834 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1835 The value is actually the element of ALIST whose cdr equals VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1837 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1839 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1841 if (internal_equal (value, elt_cdr, 0))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1848 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1849 The value is actually the element of ALIST whose cdr equals VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1851 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1853 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1855 if (internal_old_equal (value, elt_cdr, 0))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 DEFUN ("rassq", Frassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1862 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1863 The value is actually the element of ALIST whose cdr is VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1865 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1867 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1869 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1876 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1877 The value is actually the element of ALIST whose cdr is VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1879 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1881 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1883 if (HACKEQ_UNSAFE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1889 /* Like Frassq, but caller must ensure that ALIST is properly
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 nil-terminated and ebola-free. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1892 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1894 LIST_LOOP_2 (elt, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896 Lisp_Object elt_cdr = XCDR (elt);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1897 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1904 DEFUN ("delete", Fdelete, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 The modified LIST is returned. Comparison is done with `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1907 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1908 effect; therefore, write `(setq foo (delete element foo))' to be sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909 of changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910 Also see: `remove'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1913 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 (internal_equal (elt, list_elt, 0)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 The modified LIST is returned. Comparison is done with `old-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 of changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 (internal_old_equal (elt, list_elt, 0)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 DEFUN ("delq", Fdelq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935 The modified LIST is returned. Comparison is done with `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1936 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937 effect; therefore, write `(setq foo (delq element foo))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 The modified LIST is returned. Comparison is done with `old-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 (HACKEQ_UNSAFE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 /* Like Fdelq, but caller must ensure that LIST is properly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 nil-terminated and ebola-free. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 delq_no_quit (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 /* Be VERY careful with this. This is like delq_no_quit() but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 also calls free_cons() on the removed conses. You must be SURE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 that no pointers to the freed conses remain around (e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 someone else is pointing to part of the list). This function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 is useful on internal lists that are used frequently and where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 the actual list doesn't escape beyond known code bounds. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 REGISTER Lisp_Object prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 while (!NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1987 REGISTER Lisp_Object tem = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 if (EQ (elt, tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 Lisp_Object cons_to_free = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992 list = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 XCDR (prev) = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 tail = XCDR (tail);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1996 free_cons (cons_to_free);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2003 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2004 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2008 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2009 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 that is `equal' to KEY, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2012 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2014 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2016 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 internal_equal (key, XCAR (elt), 0)));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2019 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2023 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2027 return unbind_to_1 (speccount, Fremassoc (key, alist));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2031 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2032 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 that is `eq' to KEY, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 therefore, write `(setq foo (remassq key foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2037 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2039 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2042 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045 /* no quit, no errors; be careful */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2048 remassq_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2050 LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2053 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2055
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2057 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2058 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 that is `equal' to VALUE, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2063 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2065 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 internal_equal (value, XCDR (elt), 0)));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2068 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2070
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2072 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2073 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 that is `eq' to VALUE, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2078 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2080 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2083 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 /* Like Fremrassq, fast and unsafe; be careful */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2088 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2090 LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2091 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2093 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2097 Reverse SEQUENCE, destructively.
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2098
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2099 Return the beginning of the reversed sequence, which will be a distinct Lisp
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2100 object if SEQUENCE is a list with length greater than one. See also
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2101 `reverse', the non-destructive version of this function.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 */
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2103 (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2104 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2105 CHECK_SEQUENCE (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2106
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2107 if (CONSP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2108 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2109 struct gcpro gcpro1, gcpro2;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2110 Lisp_Object prev = Qnil;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2111 Lisp_Object tail = sequence;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2112
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2113 /* We gcpro our args; see `nconc' */
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2114 GCPRO2 (prev, tail);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2115 while (!NILP (tail))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2116 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2117 REGISTER Lisp_Object next;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2118 CONCHECK_CONS (tail);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2119 next = XCDR (tail);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2120 XCDR (tail) = prev;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2121 prev = tail;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2122 tail = next;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2123 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2124 UNGCPRO;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2125 return prev;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2126 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2127 else if (VECTORP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2128 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2129 Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2130 Elemcount half = length / 2;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2131 Lisp_Object swap = Qnil;
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
2132 CHECK_LISP_WRITEABLE (sequence);
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2133
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2134 while (ii > half)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2135 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2136 swap = XVECTOR_DATA (sequence) [length - ii];
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2137 XVECTOR_DATA (sequence) [length - ii]
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2138 = XVECTOR_DATA (sequence) [ii - 1];
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2139 XVECTOR_DATA (sequence) [ii - 1] = swap;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2140 --ii;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2141 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2142 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2143 else if (STRINGP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2144 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2145 Elemcount length = XSTRING_LENGTH (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2146 Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2147 Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2148
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
2149 CHECK_LISP_WRITEABLE (sequence);
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2150 while (cursor < endp)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2151 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2152 staging_end -= itext_ichar_len (cursor);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2153 itext_copy_ichar (cursor, staging_end);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2154 INC_IBYTEPTR (cursor);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2155 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2156
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2157 assert (staging == staging_end);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2158
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2159 memcpy (XSTRING_DATA (sequence), staging, length);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2160 init_string_ascii_begin (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2161 bump_string_modiff (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2162 sledgehammer_check_ascii_begin (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2163 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2164 else if (BIT_VECTORP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2165 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2166 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2167 Elemcount length = bit_vector_length (bv), ii = length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2168 Elemcount half = length / 2;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2169 int swap = 0;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2170
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
2171 CHECK_LISP_WRITEABLE (sequence);
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2172 while (ii > half)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2173 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2174 swap = bit_vector_bit (bv, length - ii);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2175 set_bit_vector_bit (bv, length - ii, bit_vector_bit (bv, ii - 1));
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2176 set_bit_vector_bit (bv, ii - 1, swap);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2177 --ii;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2178 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2179 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2180 else
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2181 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2182 assert (NILP (sequence));
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2183 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2184
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2185 return sequence;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188 DEFUN ("reverse", Freverse, 1, 1, 0, /*
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2189 Reverse SEQUENCE, copying. Return the reversed sequence.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 See also the function `nreverse', which is used more often.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 */
5300
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2192 (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2193 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2194 Lisp_Object result = Qnil;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2195
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2196 CHECK_SEQUENCE (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2197
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2198 if (CONSP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2199 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2200 EXTERNAL_LIST_LOOP_2 (elt, sequence)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2201 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2202 result = Fcons (elt, result);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2203 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2204 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2205 else if (VECTORP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2206 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2207 Elemcount length = XVECTOR_LENGTH (sequence), ii = length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2208 Lisp_Object *staging = alloca_array (Lisp_Object, length);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2209
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2210 while (ii > 0)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2211 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2212 staging[length - ii] = XVECTOR_DATA (sequence) [ii - 1];
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2213 --ii;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2214 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2215
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2216 result = Fvector (length, staging);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2217 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2218 else if (STRINGP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2219 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2220 Elemcount length = XSTRING_LENGTH (sequence);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2221 Ibyte *staging = alloca_ibytes (length), *staging_end = staging + length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2222 Ibyte *cursor = XSTRING_DATA (sequence), *endp = cursor + length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2223
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2224 while (cursor < endp)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2225 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2226 staging_end -= itext_ichar_len (cursor);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2227 itext_copy_ichar (cursor, staging_end);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2228 INC_IBYTEPTR (cursor);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2229 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2230
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2231 assert (staging == staging_end);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2232
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2233 result = make_string (staging, length);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2234 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2235 else if (BIT_VECTORP (sequence))
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2236 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2237 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence), *res;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2238 Elemcount length = bit_vector_length (bv), ii = length;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2239
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2240 result = make_bit_vector (length, Qzero);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2241 res = XBIT_VECTOR (result);
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2242
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2243 while (ii > 0)
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2244 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2245 set_bit_vector_bit (res, length - ii, bit_vector_bit (bv, ii - 1));
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2246 --ii;
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2247 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2248 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2249 else
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2250 {
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2251 assert (NILP (sequence));
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2252 }
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2253
9f738305f80f Accept sequences generally, not just lists, #'reverse, #'nreverse.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5299
diff changeset
2254 return result;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2255 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2257 static Lisp_Object
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2258 c_merge_predicate_key (Lisp_Object obj1, Lisp_Object obj2,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2259 Lisp_Object pred, Lisp_Object key_func)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2260 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2261 struct gcpro gcpro1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2262 Lisp_Object args[3];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2263
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2264 /* We could use call2() and call3() here, but we're called O(nlogn) times
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2265 for a sequence of length n, it make some sense to inline them. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2266 args[0] = key_func;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2267 args[1] = obj1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2268 args[2] = Qnil;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2269
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2270 GCPRO1 (args[0]);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2271 gcpro1.nvars = countof (args);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2272
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2273 obj1 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2274
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2275 args[1] = obj2;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2276 obj2 = IGNORE_MULTIPLE_VALUES (Ffuncall (2, args));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2277
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2278 args[0] = pred;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2279 args[1] = obj1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2280 args[2] = obj2;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2281
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2282 RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2285 static Lisp_Object
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2286 c_merge_predicate_nokey (Lisp_Object obj1, Lisp_Object obj2,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2287 Lisp_Object pred, Lisp_Object UNUSED (key_func))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2289 struct gcpro gcpro1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2290 Lisp_Object args[3];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2291
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2292 /* This is (almost) the implementation of call2, it makes some sense to
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2293 inline it here. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2294 args[0] = pred;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2295 args[1] = obj1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2296 args[2] = obj2;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2297
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2298 GCPRO1 (args[0]);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2299 gcpro1.nvars = countof (args);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2300
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2301 RETURN_UNGCPRO (IGNORE_MULTIPLE_VALUES (Ffuncall (countof (args), args)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2306 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2307 Lisp_Object, Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2308 Lisp_Object predicate, Lisp_Object key_func)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 Lisp_Object value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 Lisp_Object l1, l2;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2314 Lisp_Object tortoises[2];
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2315 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
5283
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2316 int l1_count = 0, l2_count = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2317
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 l1 = org_l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 l2 = org_l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 value = Qnil;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2322 tortoises[0] = org_l1;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2323 tortoises[1] = org_l2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2325 if (NULL == c_predicate)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2326 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2327 c_predicate = EQ (key_func, Qidentity) ?
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2328 c_merge_predicate_nokey : c_merge_predicate_key;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2329 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2330
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2331 /* It is sufficient to protect org_l1 and org_l2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332 When l1 and l2 are updated, we copy the new values
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 back into the org_ vars. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2334
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2335 GCPRO5 (org_l1, org_l2, predicate, value, tortoises[0]);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2336 gcpro5.nvars = 2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2340 if (NILP (l1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2342 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2344 return l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345 Fsetcdr (tail, l2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2347 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2348 if (NILP (l2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2349 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2350 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2351 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2352 return l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353 Fsetcdr (tail, l1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2355 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2357 if (NILP (c_predicate (Fcar (l2), Fcar (l1), predicate, key_func)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2358 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 tem = l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2360 l1 = Fcdr (l1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2361 org_l1 = l1;
5283
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2362
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2363 if (l1_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2364 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2365 if (l1_count & 1)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2366 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2367 if (!CONSP (tortoises[0]))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2368 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2369 mapping_interaction_error (Qmerge, tortoises[0]);
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2370 }
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2371
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2372 tortoises[0] = XCDR (tortoises[0]);
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2373 }
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2374
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2375 if (EQ (org_l1, tortoises[0]))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2376 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2377 signal_circular_list_error (org_l1);
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2378 }
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2379 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 tem = l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 l2 = Fcdr (l2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 org_l2 = l2;
5283
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2386
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2387 if (l2_count++ > CIRCULAR_LIST_SUSPICION_LENGTH)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2388 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2389 if (l2_count & 1)
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2390 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2391 if (!CONSP (tortoises[1]))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2392 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2393 mapping_interaction_error (Qmerge, tortoises[1]);
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2394 }
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2395
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2396 tortoises[1] = XCDR (tortoises[1]);
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2397 }
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2398
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2399 if (EQ (org_l2, tortoises[1]))
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2400 {
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2401 signal_circular_list_error (org_l2);
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2402 }
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2403 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 }
5283
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2405
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 value = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 Fsetcdr (tail, tem);
5283
be436ac36ba4 Don't share a counter when checking for circularity, list_merge().
Aidan Kehoe <kehoea@parhasard.net>
parents: 5277
diff changeset
2410
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2411 tail = tem;
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2412 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2413 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2414
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2415 static void
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2416 array_merge (Lisp_Object *dest, Elemcount dest_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2417 Lisp_Object *front, Elemcount front_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2418 Lisp_Object *back, Elemcount back_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2419 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2420 Lisp_Object, Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2421 Lisp_Object predicate, Lisp_Object key_func)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2422 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2423 Elemcount ii, fronting, backing;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2424 Lisp_Object *front_staging = front;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2425 Lisp_Object *back_staging = back;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2426 struct gcpro gcpro1, gcpro2;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2427
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2428 assert (dest_len == (back_len + front_len));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2429
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2430 if (0 == dest_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2431 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2432 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2433 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2434
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2435 if (front >= dest && front < (dest + dest_len))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2436 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2437 front_staging = alloca_array (Lisp_Object, front_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2438
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2439 for (ii = 0; ii < front_len; ++ii)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2440 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2441 front_staging[ii] = front[ii];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2442 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2443 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2444
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2445 if (back >= dest && back < (dest + dest_len))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2446 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2447 back_staging = alloca_array (Lisp_Object, back_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2448
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2449 for (ii = 0; ii < back_len; ++ii)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2450 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2451 back_staging[ii] = back[ii];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2452 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2453 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2454
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2455 GCPRO2 (front_staging[0], back_staging[0]);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2456 gcpro1.nvars = front_len;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2457 gcpro2.nvars = back_len;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2458
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2459 for (ii = fronting = backing = 0; ii < dest_len; ++ii)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2460 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2461 if (fronting >= front_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2462 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2463 while (ii < dest_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2464 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2465 dest[ii] = back_staging[backing];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2466 ++ii, ++backing;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2467 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2468 UNGCPRO;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2469 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2470 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2471
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2472 if (backing >= back_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2473 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2474 while (ii < dest_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2475 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2476 dest[ii] = front_staging[fronting];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2477 ++ii, ++fronting;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2478 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2479 UNGCPRO;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2480 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2481 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2482
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2483 if (NILP (c_predicate (back_staging[backing], front_staging[fronting],
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2484 predicate, key_func)))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2485 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2486 dest[ii] = front_staging[fronting];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2487 ++fronting;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2488 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2489 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2490 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2491 dest[ii] = back_staging[backing];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2492 ++backing;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2493 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2494 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2495
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2496 UNGCPRO;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2497 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2498
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2499 static Lisp_Object
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2500 list_array_merge_into_list (Lisp_Object list,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2501 Lisp_Object *array, Elemcount array_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2502 Lisp_Object (*c_predicate) (Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2503 Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2504 Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2505 Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2506 Lisp_Object predicate, Lisp_Object key_func,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2507 Boolint reverse_order)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2508 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2509 Lisp_Object tail = Qnil, value = Qnil, tortoise = list;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2510 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2511 Elemcount array_index = 0;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2512 int looped = 0;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2513
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2514 GCPRO4 (list, tail, value, tortoise);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2515
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2516 while (1)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2517 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2518 if (NILP (list))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2519 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2520 UNGCPRO;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2521
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2522 if (NILP (tail))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2523 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2524 return Flist (array_len, array);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2525 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2526
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2527 Fsetcdr (tail, Flist (array_len - array_index, array + array_index));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2528 return value;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2529 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2530
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2531 if (array_index >= array_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2532 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2533 UNGCPRO;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2534 if (NILP (tail))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2535 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2536 return list;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2537 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2538
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2539 Fsetcdr (tail, list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2540 return value;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2541 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2542
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2543
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2544 if (reverse_order ?
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2545 !NILP (c_predicate (Fcar (list), array [array_index], predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2546 key_func)) :
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2547 NILP (c_predicate (array [array_index], Fcar (list), predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2548 key_func)))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2549 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2550 if (NILP (tail))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2551 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2552 value = tail = list;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2553 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2554 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2555 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2556 Fsetcdr (tail, list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2557 tail = XCDR (tail);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2558 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2559
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2560 list = Fcdr (list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2561 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2562 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2563 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2564 if (NILP (tail))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2565 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2566 value = tail = Fcons (array [array_index], Qnil);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2567 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2568 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2569 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2570 Fsetcdr (tail, Fcons (array [array_index], tail));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2571 tail = XCDR (tail);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2572 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2573 ++array_index;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2574 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2575
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2576 if (++looped > CIRCULAR_LIST_SUSPICION_LENGTH)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2577 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2578 if (looped & 1)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2579 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2580 tortoise = XCDR (tortoise);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2581 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2582
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2583 if (EQ (list, tortoise))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2584 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2585 signal_circular_list_error (list);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2586 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2587 }
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2588 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2589 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2590
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2591 static void
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2592 list_list_merge_into_array (Lisp_Object *output, Elemcount output_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2593 Lisp_Object list_one, Lisp_Object list_two,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2594 Lisp_Object (*c_predicate) (Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2595 Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2596 Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2597 Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2598 Lisp_Object predicate, Lisp_Object key_func)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2599 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2600 Elemcount output_index = 0;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2601
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2602 while (output_index < output_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2603 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2604 if (NILP (list_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2605 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2606 while (output_index < output_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2607 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2608 output [output_index] = Fcar (list_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2609 list_two = Fcdr (list_two), ++output_index;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2610 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2611 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2612 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2613
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2614 if (NILP (list_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2615 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2616 while (output_index < output_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2617 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2618 output [output_index] = Fcar (list_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2619 list_one = Fcdr (list_one), ++output_index;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2620 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2621 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2622 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2623
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2624 if (NILP (c_predicate (Fcar (list_two), Fcar (list_one), predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2625 key_func)))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2626 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2627 output [output_index] = XCAR (list_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2628 list_one = XCDR (list_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2629 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2630 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2631 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2632 output [output_index] = XCAR (list_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2633 list_two = XCDR (list_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2634 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2635
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2636 ++output_index;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2637
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2638 /* No need to check for circularity. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2639 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2640 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2641
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2642 static void
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2643 list_array_merge_into_array (Lisp_Object *output, Elemcount output_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2644 Lisp_Object list,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2645 Lisp_Object *array, Elemcount array_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2646 Lisp_Object (*c_predicate) (Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2647 Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2648 Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2649 Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2650 Lisp_Object predicate, Lisp_Object key_func,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2651 Boolint reverse_order)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2652 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2653 Elemcount output_index = 0, array_index = 0;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2654
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2655 while (output_index < output_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2656 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2657 if (NILP (list))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2658 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2659 if (array_len - array_index != output_len - output_index)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2660 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
2661 mapping_interaction_error (Qmerge, list);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2662 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2663
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2664 while (array_index < array_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2665 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2666 output [output_index++] = array [array_index++];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2667 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2668
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2669 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2670 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2671
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2672 if (array_index >= array_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2673 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2674 while (output_index < output_len)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2675 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2676 output [output_index++] = Fcar (list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2677 list = Fcdr (list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2678 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2679
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2680 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2681 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2682
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2683 if (reverse_order ?
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2684 !NILP (c_predicate (Fcar (list), array [array_index], predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2685 key_func)) :
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2686 NILP (c_predicate (array [array_index], Fcar (list), predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2687 key_func)))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2688 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2689 output [output_index] = XCAR (list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2690 list = XCDR (list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2691 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2692 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2693 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2694 output [output_index] = array [array_index];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2695 ++array_index;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2696 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2697
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2698 ++output_index;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2699 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2701
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2702 #define STRING_DATA_TO_OBJECT_ARRAY(strdata, c_array, counter, len) \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2703 do { \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2704 c_array = alloca_array (Lisp_Object, len); \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2705 for (counter = 0; counter < len; ++counter) \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2706 { \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2707 c_array[counter] = make_char (itext_ichar (strdata)); \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2708 INC_IBYTEPTR (strdata); \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2709 } \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2710 } while (0)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2711
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2712 #define BIT_VECTOR_TO_OBJECT_ARRAY(v, c_array, counter, len) do { \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2713 c_array = alloca_array (Lisp_Object, len); \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2714 for (counter = 0; counter < len; ++counter) \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2715 { \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2716 c_array[counter] = make_int (bit_vector_bit (v, counter)); \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2717 } \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2718 } while (0)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2719
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2720 /* This macro might eventually find a better home than here. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2721
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2722 #define CHECK_KEY_ARGUMENT(key) \
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2723 do { \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2724 if (NILP (key)) \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2725 { \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2726 key = Qidentity; \
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2727 } \
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2728 \
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2729 if (!EQ (key, Qidentity)) \
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2730 { \
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2731 key = indirect_function (key, 1); \
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2732 } \
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2733 } while (0)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2734
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2735 DEFUN ("merge", Fmerge, 4, MANY, 0, /*
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2736 Destructively merge SEQUENCE-ONE and SEQUENCE-TWO, producing a new sequence.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2737
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2738 TYPE is the type of sequence to return. PREDICATE is a `less-than'
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2739 predicate on the elements.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2740
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2741 Optional keyword argument KEY is a function used to extract an object to be
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2742 used for comparison from each element of SEQUENCE-ONE and SEQUENCE-TWO.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2743
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2744 arguments: (TYPE SEQUENCE-ONE SEQUENCE-TWO PREDICATE &key (KEY #'IDENTITY))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2745 */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2746 (int nargs, Lisp_Object *args))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2747 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2748 Lisp_Object type = args[0], sequence_one = args[1], sequence_two = args[2],
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2749 predicate = args[3], result = Qnil;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2750 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2751 Lisp_Object);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2752
5277
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
2753 PARSE_KEYWORDS (Fmerge, nargs, args, 1, (key), NULL);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2754
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2755 CHECK_SEQUENCE (sequence_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2756 CHECK_SEQUENCE (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2757
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2758 CHECK_KEY_ARGUMENT (key);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2759
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2760 c_predicate = EQ (key, Qidentity) ?
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
2761 c_merge_predicate_nokey : c_merge_predicate_key;
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2762
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2763 if (EQ (type, Qlist) && (LISTP (sequence_one) || LISTP (sequence_two)))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2764 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2765 if (NILP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2766 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2767 result = Fappend (2, args + 1);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2768 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2769 else if (NILP (sequence_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2770 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2771 args[3] = Qnil; /* Overwriting PREDICATE, and losing its GC
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2772 protection, but that doesn't matter. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2773 result = Fappend (2, args + 2);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2774 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2775 else if (CONSP (sequence_one) && CONSP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2776 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2777 result = list_merge (sequence_one, sequence_two, c_predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2778 predicate, key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2779 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2780 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2781 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2782 Lisp_Object *array_storage, swap;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2783 Elemcount array_length, i;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2784 Boolint reverse_order = 0;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2785
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2786 if (!CONSP (sequence_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2787 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2788 /* Make sequence_one the cons, sequence_two the array: */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2789 swap = sequence_one;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2790 sequence_one = sequence_two;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2791 sequence_two = swap;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2792 reverse_order = 1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2793 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2794
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2795 if (VECTORP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2796 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2797 array_storage = XVECTOR_DATA (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2798 array_length = XVECTOR_LENGTH (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2799 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2800 else if (STRINGP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2801 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2802 Ibyte *strdata = XSTRING_DATA (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2803 array_length = string_char_length (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2804 /* No need to GCPRO, characters are immediate. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2805 STRING_DATA_TO_OBJECT_ARRAY (strdata, array_storage, i,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2806 array_length);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2807
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2808 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2809 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2810 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2811 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2812 array_length = bit_vector_length (v);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2813 /* No need to GCPRO, fixnums are immediate. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2814 BIT_VECTOR_TO_OBJECT_ARRAY (v, array_storage, i, array_length);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2815 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2816
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2817 result = list_array_merge_into_list (sequence_one,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2818 array_storage, array_length,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2819 c_predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2820 predicate, key,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2821 reverse_order);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2822 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2823 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2824 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2825 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2826 Elemcount sequence_one_len = XINT (Flength (sequence_one)),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2827 sequence_two_len = XINT (Flength (sequence_two)), i;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2828 Elemcount output_len = 1 + sequence_one_len + sequence_two_len;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2829 Lisp_Object *output = alloca_array (Lisp_Object, output_len),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2830 *sequence_one_storage = NULL, *sequence_two_storage = NULL;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2831 Boolint do_coerce = !(EQ (type, Qvector) || EQ (type, Qstring)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2832 || EQ (type, Qbit_vector) || EQ (type, Qlist));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2833 Ibyte *strdata = NULL;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2834 Lisp_Bit_Vector *v = NULL;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2835 struct gcpro gcpro1;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2836
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2837 output[0] = do_coerce ? Qlist : type;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2838 for (i = 1; i < output_len; ++i)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2839 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2840 output[i] = Qnil;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2841 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2842
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2843 GCPRO1 (output[0]);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2844 gcpro1.nvars = output_len;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2845
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2846 if (VECTORP (sequence_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2847 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2848 sequence_one_storage = XVECTOR_DATA (sequence_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2849 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2850 else if (STRINGP (sequence_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2851 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2852 strdata = XSTRING_DATA (sequence_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2853 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_one_storage,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2854 i, sequence_one_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2855 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2856 else if (BIT_VECTORP (sequence_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2857 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2858 v = XBIT_VECTOR (sequence_one);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2859 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_one_storage,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2860 i, sequence_one_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2861 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2862
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2863 if (VECTORP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2864 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2865 sequence_two_storage = XVECTOR_DATA (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2866 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2867 else if (STRINGP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2868 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2869 strdata = XSTRING_DATA (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2870 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_two_storage,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2871 i, sequence_two_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2872 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2873 else if (BIT_VECTORP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2874 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2875 v = XBIT_VECTOR (sequence_two);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2876 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_two_storage,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2877 i, sequence_two_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2878 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2879
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2880 if (LISTP (sequence_one) && LISTP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2881 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2882 list_list_merge_into_array (output + 1, output_len - 1,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2883 sequence_one, sequence_two,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2884 c_predicate, predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2885 key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2886 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2887 else if (LISTP (sequence_one))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2888 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2889 list_array_merge_into_array (output + 1, output_len - 1,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2890 sequence_one,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2891 sequence_two_storage,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2892 sequence_two_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2893 c_predicate, predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2894 key, 0);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2895 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2896 else if (LISTP (sequence_two))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2897 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2898 list_array_merge_into_array (output + 1, output_len - 1,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2899 sequence_two,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2900 sequence_one_storage,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2901 sequence_one_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2902 c_predicate, predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2903 key, 1);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2904 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2905 else
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2906 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2907 array_merge (output + 1, output_len - 1,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2908 sequence_one_storage, sequence_one_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2909 sequence_two_storage, sequence_two_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2910 c_predicate, predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2911 key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2912 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2913
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2914 result = Ffuncall (output_len, output);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2915
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2916 if (do_coerce)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2917 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2918 result = call2 (Qcoerce, result, type);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2919 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2920
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2921 UNGCPRO;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2922 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2923
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2924 return result;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2925 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2926
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2927 /* The sort function should return non-nil if OBJ1 < OBJ2, nil otherwise.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2928 NOTE: This is backwards from the way qsort() works. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2929 Lisp_Object
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2930 list_sort (Lisp_Object list,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2931 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2932 Lisp_Object, Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2933 Lisp_Object predicate, Lisp_Object key_func)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2934 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2935 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2936 Lisp_Object back, tem;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2937 Lisp_Object front = list;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2938 Lisp_Object len = Flength (list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2939
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2940 if (XINT (len) < 2)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2941 return list;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2942
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2943 if (NULL == c_predicate)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2944 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2945 c_predicate = EQ (key_func, Qidentity) ? c_merge_predicate_nokey :
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2946 c_merge_predicate_key;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2947 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2948
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2949 len = make_int (XINT (len) / 2 - 1);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2950 tem = Fnthcdr (len, list);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2951 back = Fcdr (tem);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2952 Fsetcdr (tem, Qnil);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2953
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2954 GCPRO4 (front, back, predicate, key_func);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2955 front = list_sort (front, c_predicate, predicate, key_func);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2956 back = list_sort (back, c_predicate, predicate, key_func);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2957
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2958 RETURN_UNGCPRO (list_merge (front, back, c_predicate, predicate, key_func));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2959 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2960
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2961 static void
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2962 array_sort (Lisp_Object *array, Elemcount array_len,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2963 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2964 Lisp_Object, Lisp_Object),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2965 Lisp_Object predicate, Lisp_Object key_func)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2966 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2967 Elemcount split;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2968
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2969 if (array_len < 2)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2970 return;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2971
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2972 split = array_len / 2;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2973
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2974 array_sort (array, split, c_predicate, predicate, key_func);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2975 array_sort (array + split, array_len - split, c_predicate, predicate,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2976 key_func);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2977 array_merge (array, array_len, array, split, array + split,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2978 array_len - split, c_predicate, predicate, key_func);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2979 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2980
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2981 DEFUN ("sort*", FsortX, 2, MANY, 0, /*
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2982 Sort SEQUENCE, comparing elements using PREDICATE.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2983 Returns the sorted sequence. SEQUENCE is modified by side effect.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2984
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2985 PREDICATE is called with two elements of SEQUENCE, and should return t if
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2986 the first element is `less' than the second.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2987
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2988 Optional keyword argument KEY is a function used to extract an object to be
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2989 used for comparison from each element of SEQUENCE.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2990
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2991 In this implementation, sorting is always stable; but call `stable-sort' if
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2992 this stability is important to you, other implementations may not make the
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2993 same guarantees.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2994
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2995 arguments: (SEQUENCE PREDICATE &key (KEY #'IDENTITY))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2996 */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2997 (int nargs, Lisp_Object *args))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2998 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
2999 Lisp_Object sequence = args[0], predicate = args[1];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3000 Lisp_Object *sequence_carray;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3001 Lisp_Object (*c_predicate) (Lisp_Object, Lisp_Object, Lisp_Object,
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3002 Lisp_Object);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3003 Elemcount sequence_len, i;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3004
5277
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
3005 PARSE_KEYWORDS (FsortX, nargs, args, 1, (key), NULL);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3006
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3007 CHECK_SEQUENCE (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3008
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
3009 CHECK_KEY_ARGUMENT (key);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
3010
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
3011 c_predicate = EQ (key, Qidentity) ?
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
3012 c_merge_predicate_nokey : c_merge_predicate_key;
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3013
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3014 if (LISTP (sequence))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3015 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3016 sequence = list_sort (sequence, c_predicate, predicate, key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3017 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3018 else if (VECTORP (sequence))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3019 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3020 array_sort (XVECTOR_DATA (sequence), XVECTOR_LENGTH (sequence),
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3021 c_predicate, predicate, key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3022 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3023 else if (STRINGP (sequence))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3024 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3025 Ibyte *strdata = XSTRING_DATA (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3026
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3027 sequence_len = string_char_length (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3028
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3029 STRING_DATA_TO_OBJECT_ARRAY (strdata, sequence_carray, i, sequence_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3030
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3031 /* No GCPRO necessary, characters are immediate. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3032 array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3033
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3034 strdata = XSTRING_DATA (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3035
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3036 CHECK_LISP_WRITEABLE (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3037 for (i = 0; i < sequence_len; ++i)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3038 {
5184
039d9a7f2e6d Call init_string_ascii_begin() in #'sort*, #'fill, don't be clever.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5182
diff changeset
3039 strdata += set_itext_ichar (strdata, XCHAR (sequence_carray[i]));
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3040 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3041
5184
039d9a7f2e6d Call init_string_ascii_begin() in #'sort*, #'fill, don't be clever.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5182
diff changeset
3042 init_string_ascii_begin (sequence);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3043 bump_string_modiff (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3044 sledgehammer_check_ascii_begin (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3045 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3046 else if (BIT_VECTORP (sequence))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3047 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3048 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3049 sequence_len = bit_vector_length (v);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3050
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3051 BIT_VECTOR_TO_OBJECT_ARRAY (v, sequence_carray, i, sequence_len);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3052
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3053 /* No GCPRO necessary, bits are immediate. */
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3054 array_sort (sequence_carray, sequence_len, c_predicate, predicate, key);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3055
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3056 for (i = 0; i < sequence_len; ++i)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3057 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3058 set_bit_vector_bit (v, i, XINT (sequence_carray [i]));
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3059 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3060 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3061
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3062 return sequence;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
3063 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3065 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3066 /* property-list functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3067 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3068
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 /* For properties of text, we need to do order-insensitive comparison of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 plists. That is, we need to compare two plists such that they are the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3071 same if they have the same set of keys, and equivalent values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3072 So (a 1 b 2) would be equal to (b 2 a 1).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 LAXP means use `equal' for comparisons.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3077 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3078 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3079 int laxp, int depth, int foldcase)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 434
diff changeset
3081 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3082 int la, lb, m, i, fill;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3083 Lisp_Object *keys, *vals;
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
3084 Boolbyte *flags;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087 if (NILP (a) && NILP (b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 Fcheck_valid_plist (a);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 Fcheck_valid_plist (b);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 la = XINT (Flength (a));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 lb = XINT (Flength (b));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095 m = (la > lb ? la : lb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 fill = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 keys = alloca_array (Lisp_Object, m);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098 vals = alloca_array (Lisp_Object, m);
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
3099 flags = alloca_array (Boolbyte, m);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3100
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3101 /* First extract the pairs from A. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3102 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3103 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3104 Lisp_Object k = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3105 Lisp_Object v = XCAR (XCDR (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106 /* Maybe be Ebolified. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107 if (nil_means_not_present && NILP (v)) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3108 keys [fill] = k;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3109 vals [fill] = v;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 flags[fill] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 fill++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113 /* Now iterate over B, and stop if we find something that's not in A,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114 or that doesn't match. As we match, mark them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 Lisp_Object k = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 Lisp_Object v = XCAR (XCDR (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 /* Maybe be Ebolified. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 if (nil_means_not_present && NILP (v)) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3121 for (i = 0; i < fill; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3123 if (!laxp ? EQ (k, keys [i]) :
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3124 internal_equal_0 (k, keys [i], depth, foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3126 if (eqp
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3127 /* We narrowly escaped being Ebolified here. */
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3128 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3129 : !internal_equal_0 (v, vals [i], depth, foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 /* a property in B has a different value than in A */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132 flags [i] = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3136 if (i == fill)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3137 /* there are some properties in B that are not in A */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3138 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3139 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140 /* Now check to see that all the properties in A were also in B */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3141 for (i = 0; i < fill; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3142 if (flags [i] == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 /* Ok. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3146 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3147
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3148 MISMATCH:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3149 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3150 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3152 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3153 Return non-nil if property lists A and B are `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3154 A property list is an alternating list of keywords and values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3155 This function does order-insensitive comparisons of the property lists:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3156 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3157 Comparison between values is done using `eq'. See also `plists-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3158 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3159 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3160 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3161 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3163 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3165 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3168
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3170 Return non-nil if property lists A and B are `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 A property list is an alternating list of keywords and values. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 function does order-insensitive comparisons of the property lists: For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 Comparison between values is done using `equal'. See also `plists-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3176 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3177 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3181 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3182 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3183 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3184 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3185
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 Return non-nil if lax property lists A and B are `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189 A property list is an alternating list of keywords and values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3190 This function does order-insensitive comparisons of the property lists:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3191 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 Comparison between values is done using `eq'. See also `plists-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 A lax property list is like a regular one except that comparisons between
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194 keywords is done using `equal' instead of `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3199 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3200 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3202 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3204 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3206 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 Return non-nil if lax property lists A and B are `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 A property list is an alternating list of keywords and values. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 function does order-insensitive comparisons of the property lists: For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 Comparison between values is done using `equal'. See also `plists-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212 A lax property list is like a regular one except that comparisons between
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 keywords is done using `equal' instead of `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3221 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3222 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3225 /* Return the value associated with key PROPERTY in property list PLIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3226 Return nil if key not found. This function is used for internal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3227 property lists that cannot be directly manipulated by the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3228 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231 internal_plist_get (Lisp_Object plist, Lisp_Object property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3232 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3233 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3234
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3235 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3236 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3237 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238 return XCAR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3239 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3245 internal_plist_get(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3246
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3247 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3249 Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3250 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3251 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3253 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3254 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3255 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3256 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3257 XCAR (XCDR (tail)) = value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3260 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3261
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3262 *plist = Fcons (property, Fcons (value, *plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266 internal_remprop (Lisp_Object *plist, Lisp_Object property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 Lisp_Object tail, prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3270 for (tail = *plist, prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3271 !NILP (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3272 tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3273 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3274 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3276 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3277 *plist = XCDR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3287 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3289 /* Called on a malformed property list. BADPLACE should be some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 place where truncating will form a good list -- i.e. we shouldn't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 result in a list with an odd length. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 static Lisp_Object
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
3294 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3300 if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 (Qlist, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3304 list2 (build_msg_string
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 ("Malformed property list -- list has been truncated"),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306 *plist));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3307 /* #### WARNING: This is more dangerous than it seems; perhaps
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3308 not a good idea. It also violates the principle of least
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3309 surprise -- passing in ERROR_ME_WARN causes truncation, but
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3310 ERROR_ME and ERROR_ME_NOT don't. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 *badplace = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 /* Called on a circular property list. BADPLACE should be some place
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318 where truncating will result in an even-length list, as above.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319 If doesn't particularly matter where we truncate -- anywhere we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 truncate along the entire list will break the circularity, because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 it will create a terminus and the list currently doesn't have one.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3322 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3324 static Lisp_Object
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
3325 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3327 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3328 return Fsignal (Qcircular_property_list, list1 (*plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3329 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3330 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3331 if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3332 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3333 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3334 (Qlist, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3335 list2 (build_msg_string
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3336 ("Circular property list -- list has been truncated"),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3337 *plist));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3338 /* #### WARNING: This is more dangerous than it seems; perhaps
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3339 not a good idea. It also violates the principle of least
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3340 surprise -- passing in ERROR_ME_WARN causes truncation, but
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3341 ERROR_ME and ERROR_ME_NOT don't. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3342 *badplace = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3343 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3344 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3345 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3346 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3347
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3348 /* Advance the tortoise pointer by two (one iteration of a property-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3349 loop) and the hare pointer by four and verify that no malformations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3350 or circularities exist. If so, return zero and store a value into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3351 RETVAL that should be returned by the calling function. Otherwise,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3352 return 1. See external_plist_get().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3354
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3355 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3356 advance_plist_pointers (Lisp_Object *plist,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3357 Lisp_Object **tortoise, Lisp_Object **hare,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
3358 Error_Behavior errb, Lisp_Object *retval)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3361 Lisp_Object *tortsave = *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3363 /* Note that our "fixing" may be more brutal than necessary,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3364 but it's the user's own problem, not ours, if they went in and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3365 manually fucked up a plist. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3367 for (i = 0; i < 2; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3368 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369 /* This is a standard iteration of a defensive-loop-checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 loop. We just do it twice because we want to advance past
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 both the property and its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373 If the pointer indirection is confusing you, remember that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374 one level of indirection on the hare and tortoise pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 is only due to pass-by-reference for this function. The other
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 level is so that the plist can be fixed in place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3378 /* When we reach the end of a well-formed plist, **HARE is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379 nil. In that case, we don't do anything at all except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 advance TORTOISE by one. Otherwise, we advance HARE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381 by two (making sure it's OK to do so), then advance
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 TORTOISE by one (it will always be OK to do so because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 the HARE is always ahead of the TORTOISE and will have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384 already verified the path), then make sure TORTOISE and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385 HARE don't contain the same non-nil object -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 TORTOISE and the HARE ever meet, then obviously we're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387 in a circularity, and if we're in a circularity, then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388 the TORTOISE and the HARE can't cross paths without
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 meeting, since the HARE only gains one step over the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3390 TORTOISE per iteration. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3391
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3392 if (!NILP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3394 Lisp_Object *haresave = *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395 if (!CONSP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3397 *retval = bad_bad_bunny (plist, haresave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3398 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3399 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3400 *hare = &XCDR (**hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 /* In a non-plist, we'd check here for a nil value for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 **HARE, which is OK (it just means the list has an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 odd number of elements). In a plist, it's not OK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 for the list to have an odd number of elements. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405 if (!CONSP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 *retval = bad_bad_bunny (plist, haresave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410 *hare = &XCDR (**hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413 *tortoise = &XCDR (**tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 if (!NILP (**hare) && EQ (**tortoise, **hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 *retval = bad_bad_turtle (plist, tortsave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424 /* Return the value of PROPERTY from PLIST, or Qunbound if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 property is not on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3427 PLIST is a Lisp-accessible property list, meaning that it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 has to be checked for malformations and circularities.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431 function will never signal an error; and if ERRB is ERROR_ME_WARN,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432 on finding a malformation or a circularity, it issues a warning and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 attempts to silently fix the problem.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435 A pointer to PLIST is passed in so that PLIST can be successfully
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 "fixed" even if the error is at the beginning of the plist. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3439 external_plist_get (Lisp_Object *plist, Lisp_Object property,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
3440 int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3441 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3449
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3450 /* We do the standard tortoise/hare march. We isolate the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451 grungy stuff to do this in advance_plist_pointers(), though.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 To us, all this function does is advance the tortoise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 pointer by two and the hare pointer by four and make sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454 everything's OK. We first advance the pointers and then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 check if a property matched; this ensures that our
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 check for a matching property is safe. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 return retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 return XCAR (XCDR (*tortsave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3466 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 malformed or circular plist. Analogous to external_plist_get(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473 external_plist_put (Lisp_Object *plist, Lisp_Object property,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
3474 Lisp_Object value, int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3479 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491 XCAR (XCDR (*tortsave)) = value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 *plist = Fcons (property, Fcons (value, *plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3498
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500 external_remprop (Lisp_Object *plist, Lisp_Object property,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
3501 int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3506 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3507 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3508 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3509 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3510
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3511 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3512 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3515 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3516 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3517 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3518 /* Now you see why it's so convenient to have that level
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3519 of indirection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3520 *tortsave = XCDR (XCDR (*tortsave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3521 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3522 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3523 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3524
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3525 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3526 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3527
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3528 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3529 Extract a value from a property list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3530 PLIST is a property list, which is a list of the form
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3531 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3532 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3533 This function returns the value corresponding to the PROPERTY,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3534 or DEFAULT if PROPERTY is not one of the properties on the list.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3535 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3536 (plist, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3537 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3538 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3539 return UNBOUNDP (value) ? default_ : value;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3540 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3541
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3542 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3543 Change value in PLIST of PROPERTY to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3544 PLIST is a property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3545 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3546 PROPERTY is usually a symbol and VALUE is any object.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3547 If PROPERTY is already a property on the list, its value is set to VALUE,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3548 otherwise the new PROPERTY VALUE pair is added.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3549 The new plist is returned; use `(setq x (plist-put x property value))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3550 to be sure to use the new value. PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3551 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3552 (plist, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3553 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3554 external_plist_put (&plist, property, value, 0, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3555 return plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3556 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3557
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3558 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3559 Remove from PLIST the property PROPERTY and its value.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3560 PLIST is a property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3561 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3562 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3563 The new plist is returned; use `(setq x (plist-remprop x property))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3564 to be sure to use the new value. PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3565 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3566 (plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3567 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3568 external_remprop (&plist, property, 0, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3569 return plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3570 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3572 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3573 Return t if PROPERTY has a value specified in PLIST.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3574 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3575 (plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3576 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3577 Lisp_Object value = Fplist_get (plist, property, Qunbound);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3578 return UNBOUNDP (value) ? Qnil : Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3579 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3581 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3582 Given a plist, signal an error if there is anything wrong with it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3583 This means that it's a malformed or circular plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3584 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3585 (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 Lisp_Object *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3588 Lisp_Object *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3589
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590 start_over:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3591 tortoise = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592 hare = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3597 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 goto start_over;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3604 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3605
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3606 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3607 Given a plist, return non-nil if its format is correct.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 If it returns nil, `check-valid-plist' will signal an error when given
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3609 the plist; that means it's a malformed or circular plist.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611 (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3612 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613 Lisp_Object *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 Lisp_Object *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 tortoise = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 hare = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3622 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3623 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3624 &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3631 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3632 Destructively remove any duplicate entries from a plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633 In such cases, the first entry applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3634
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3635 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3636 a nil value is removed. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3637 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3638 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3640 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3641 return value may not be EQ to the passed-in value, so make sure to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3642 `setq' the value back into where it came from.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3643 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3644 (plist, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3645 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 Lisp_Object head = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3648 Fcheck_valid_plist (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 while (!NILP (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652 Lisp_Object prop = Fcar (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653 Lisp_Object next = Fcdr (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3654
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 CHECK_CONS (next); /* just make doubly sure we catch any errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3658 if (EQ (head, plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659 head = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3661 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3663 /* external_remprop returns 1 if it removed any property.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3664 We have to loop till it didn't remove anything, in case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 the property occurs many times. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667 DO_NOTHING;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668 plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3669 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3670
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3674 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3675 Extract a value from a lax property list.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3676 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3677 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3678 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3679 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3680 This function returns the value corresponding to PROPERTY,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3681 or DEFAULT if PROPERTY is not one of the properties on the list.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3683 (lax_plist, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3685 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3686 return UNBOUNDP (value) ? default_ : value;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3690 Change value in LAX-PLIST of PROPERTY to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3691 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3692 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3693 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3694 PROPERTY is usually a symbol and VALUE is any object.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3695 If PROPERTY is already a property on the list, its value is set to
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3696 VALUE, otherwise the new PROPERTY VALUE pair is added.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3697 The new plist is returned; use `(setq x (lax-plist-put x property value))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3698 to be sure to use the new value. LAX-PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3700 (lax_plist, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3702 external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703 return lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3707 Remove from LAX-PLIST the property PROPERTY and its value.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3708 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3709 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3710 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3711 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3712 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3713 to be sure to use the new value. LAX-PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3714 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3715 (lax_plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3716 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3717 external_remprop (&lax_plist, property, 1, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3718 return lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3719 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3720
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3722 Return t if PROPERTY has a value specified in LAX-PLIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3723 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3724 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3725 properties is done using `equal' instead of `eq'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3727 (lax_plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3729 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3732 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3733 Destructively remove any duplicate entries from a lax plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3734 In such cases, the first entry applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3735
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3736 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3737 a nil value is removed. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3738 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3740
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3741 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 return value may not be EQ to the passed-in value, so make sure to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3743 `setq' the value back into where it came from.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3744 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 (lax_plist, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3746 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3747 Lisp_Object head = lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 Fcheck_valid_plist (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3750
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3751 while (!NILP (lax_plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753 Lisp_Object prop = Fcar (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3754 Lisp_Object next = Fcdr (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3755
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3756 CHECK_CONS (next); /* just make doubly sure we catch any errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 if (EQ (head, lax_plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3760 head = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3761 lax_plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3762 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3764 /* external_remprop returns 1 if it removed any property.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3765 We have to loop till it didn't remove anything, in case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3766 the property occurs many times. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3767 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768 DO_NOTHING;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769 lax_plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3770 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3771
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3774
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775 /* In C because the frame props stuff uses it */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3777 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 Convert association list ALIST into the equivalent property-list form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 The plist is returned. This converts from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 \((a . 1) (b . 2) (c . 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3785 \(a 1 b 2 c 3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 The original alist is destroyed in the process of constructing the plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788 See also `alist-to-plist'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3792 Lisp_Object head = alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3793 while (!NILP (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795 /* remember the alist element. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796 Lisp_Object el = Fcar (alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3798 Fsetcar (alist, Fcar (el));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3799 Fsetcar (el, Fcdr (el));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3800 Fsetcdr (el, Fcdr (alist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3801 Fsetcdr (alist, el);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3802 alist = Fcdr (Fcdr (alist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3804
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3806 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3808 DEFUN ("get", Fget, 2, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3809 Return the value of OBJECT's PROPERTY property.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3810 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3811 If there is no such property, return optional third arg DEFAULT
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3812 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
5255
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3813 face, glyph, or process. See also `put', `remprop', `object-plist', and
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3814 `object-setplist'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3816 (object, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 /* Various places in emacs call Fget() and expect it not to quit,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 so don't quit. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3820 Lisp_Object val;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3821
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3822 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3823 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3824 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3825 invalid_operation ("Object type has no properties", object);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3826
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3827 return UNBOUNDP (val) ? default_ : val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 DEFUN ("put", Fput, 3, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3831 Set OBJECT's PROPERTY to VALUE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3832 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3833 OBJECT can be a symbol, face, extent, or string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834 For a string, no properties currently have predefined meanings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835 For the predefined properties for extents, see `set-extent-property'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 For the predefined properties for faces, see `set-face-property'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3837 See also `get', `remprop', and `object-plist'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3838 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3839 (object, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
3841 /* This function cannot GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3842 CHECK_LISP_WRITEABLE (object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3843
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3844 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3845 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3846 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3847 (object, property, value))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3848 invalid_change ("Can't set property on object", property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3849 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3850 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3851 invalid_change ("Object type has no settable properties", object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3852
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3853 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3854 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3857 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
5255
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3858 OBJECT can be a symbol, string, extent, face, glyph, or process.
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3859 Return non-nil if the property list was actually modified (i.e. if PROPERTY
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3860 was present in the property list). See also `get', `put', `object-plist',
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3861 and `object-setplist'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3863 (object, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3865 int ret = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3866
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867 CHECK_LISP_WRITEABLE (object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3869 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3870 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3871 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3872 if (ret == -1)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3873 invalid_change ("Can't remove property from object", property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3874 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3875 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3876 invalid_change ("Object type has no removable properties", object);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3877
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3878 return ret ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3880
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3882 Return a property list of OBJECT's properties.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3883 For a symbol, this is equivalent to `symbol-plist'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3884 OBJECT can be a symbol, string, extent, face, or glyph.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3885 Do not modify the returned property list directly;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3886 this may or may not have the desired effects. Use `put' instead.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3887 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3890 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3891 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3893 invalid_operation ("Object type has no properties", object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3897
5255
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3898 DEFUN ("object-setplist", Fobject_setplist, 2, 2, 0, /*
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3899 Set OBJECT's property list to NEWPLIST, and return NEWPLIST.
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3900 For a symbol, this is equivalent to `setplist'.
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3901
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3902 OBJECT can be a symbol or a process, other objects with visible plists do
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3903 not allow their modification with `object-setplist'.
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3904 */
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3905 (object, newplist))
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3906 {
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3907 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->setplist)
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3908 {
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3909 return XRECORD_LHEADER_IMPLEMENTATION (object)->setplist (object,
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3910 newplist);
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3911 }
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3912
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3913 invalid_operation ("Not possible to set object's plist", object);
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3914 return Qnil;
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3915 }
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3916
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
3917
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3918
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3919 static Lisp_Object
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3920 tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3921 Lisp_Object depth)
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3922 {
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3923 return make_int (internal_equal (obj1, obj2, XINT (depth)));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3924 }
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3925
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3926 int
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3927 internal_equal_trapping_problems (Lisp_Object warning_class,
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
3928 const Ascbyte *warning_string,
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3929 int flags,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3930 struct call_trapping_problems_result *p,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3931 int retval,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3932 Lisp_Object obj1, Lisp_Object obj2,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3933 int depth)
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3934 {
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3935 Lisp_Object glorp =
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3936 va_call_trapping_problems (warning_class, warning_string,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3937 flags, p,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3938 (lisp_fn_t) tweaked_internal_equal,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3939 3, obj1, obj2, make_int (depth));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3940 if (UNBOUNDP (glorp))
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3941 return retval;
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3942 else
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3943 return XINT (glorp);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3944 }
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
3945
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3946 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3947 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3950 stack_overflow ("Stack overflow in equal", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3954 /* Note that (equal 20 20.0) should be nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3955 if (XTYPE (obj1) != XTYPE (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3956 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3957 if (LRECORDP (obj1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3958 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3959 const struct lrecord_implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3960 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3961 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963 return (imp1 == imp2) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3964 /* EQ-ness of the objects was noticed above */
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3965 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3971 enum array_type
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3972 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3973 ARRAY_NONE = 0,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3974 ARRAY_STRING,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3975 ARRAY_VECTOR,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3976 ARRAY_BIT_VECTOR
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3977 };
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3978
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3979 static enum array_type
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3980 array_type (Lisp_Object obj)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3981 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3982 if (STRINGP (obj))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3983 return ARRAY_STRING;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3984 if (VECTORP (obj))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3985 return ARRAY_VECTOR;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3986 if (BIT_VECTORP (obj))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3987 return ARRAY_BIT_VECTOR;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3988 return ARRAY_NONE;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3989 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3990
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3991 int
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3992 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3993 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3994 if (depth > 200)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3995 stack_overflow ("Stack overflow in equalp", Qunbound);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3996 QUIT;
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3997
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3998 /* 1. Objects that are `eq' are equal. This will catch the common case
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3999 of two equal fixnums or the same object seen twice. */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4000 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4001 return 1;
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4002
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4003 /* 2. If both numbers, compare with `='. */
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
4004 if (NUMBERP (obj1) && NUMBERP (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
4005 {
4910
6bc1f3f6cf0d Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
4006 return (0 == bytecode_arithcompare (obj1, obj2));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
4007 }
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4008
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4009 /* 3. If characters, compare case-insensitively. */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4010 if (CHARP (obj1) && CHARP (obj2))
4910
6bc1f3f6cf0d Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
4011 return CANONCASE (0, XCHAR (obj1)) == CANONCASE (0, XCHAR (obj2));
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4012
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4013 /* 4. If arrays of different types, compare their lengths, and
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4014 then compare element-by-element. */
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4015 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4016 enum array_type artype1, artype2;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4017 artype1 = array_type (obj1);
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4018 artype2 = array_type (obj2);
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4019 if (artype1 != artype2 && artype1 && artype2)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4020 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4021 EMACS_INT i;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4022 EMACS_INT l1 = XINT (Flength (obj1));
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4023 EMACS_INT l2 = XINT (Flength (obj2));
4910
6bc1f3f6cf0d Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
4024 /* Both arrays, but of different lengths */
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4025 if (l1 != l2)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4026 return 0;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4027 for (i = 0; i < l1; i++)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4028 if (!internal_equalp (Faref (obj1, make_int (i)),
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4029 Faref (obj2, make_int (i)), depth + 1))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4030 return 0;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4031 return 1;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4032 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4033 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4034 /* 5. Else, they must be the same type. If so, call the equal() method,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4035 telling it to fold case. For objects that care about case-folding
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4036 their contents, the equal() method will call internal_equal_0(). */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4037 if (XTYPE (obj1) != XTYPE (obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4038 return 0;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4039 if (LRECORDP (obj1))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4040 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4041 const struct lrecord_implementation
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4042 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4043 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4044
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4045 return (imp1 == imp2) &&
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4046 /* EQ-ness of the objects was noticed above */
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4047 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1));
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4048 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4049
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4050 return 0;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4051 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4052
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4053 int
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4054 internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4055 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4056 if (foldcase)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4057 return internal_equalp (obj1, obj2, depth);
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4058 else
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4059 return internal_equal (obj1, obj2, depth);
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4060 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4061
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4062 /* Note that we may be calling sub-objects that will use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4063 internal_equal() (instead of internal_old_equal()). Oh well.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4064 We will get an Ebola note if there's any possibility of confusion,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4065 but that seems unlikely. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4066
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4067 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4071 stack_overflow ("Stack overflow in equal", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 if (HACKEQ_UNSAFE (obj1, obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 /* Note that (equal 20 20.0) should be nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076 if (XTYPE (obj1) != XTYPE (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4077 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4078
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4079 return internal_equal (obj1, obj2, depth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4080 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4081
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4082 DEFUN ("equal", Fequal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4083 Return t if two Lisp objects have similar structure and contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4084 They must have the same data type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4085 Conses are compared by comparing the cars and the cdrs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4086 Vectors and strings are compared element by element.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4087 Numbers are compared by value. Symbols must match exactly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4088 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4089 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4090 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4091 return internal_equal (object1, object2, 0) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4092 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4093
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4094 DEFUN ("equalp", Fequalp, 2, 2, 0, /*
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4095 Return t if two Lisp objects have similar structure and contents.
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4096
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4097 This is like `equal', except that it accepts numerically equal
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4098 numbers of different types (float, integer, bignum, bigfloat), and also
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4099 compares strings and characters case-insensitively.
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4100
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4101 Type objects that are arrays (that is, strings, bit-vectors, and vectors)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4102 of the same length and with contents that are `equalp' are themselves
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4103 `equalp', regardless of whether the two objects have the same type.
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4104
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4105 Other objects whose primary purpose is as containers of other objects are
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4106 `equalp' if they would otherwise be equal (same length, type, etc.) and
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4107 their contents are `equalp'. This goes for conses, weak lists,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4108 weak boxes, ephemerons, specifiers, hash tables, char tables and range
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4109 tables. However, objects that happen to contain other objects but are not
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4110 primarily designed for this purpose (e.g. compiled functions, events or
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4111 display-related objects such as glyphs, faces or extents) are currently
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4112 compared using `equalp' the same way as using `equal'.
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4113
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4114 More specifically, two hash tables are `equalp' if they have the same test
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4115 (see `hash-table-test'), the same number of entries, and the same value for
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4116 `hash-table-weakness', and if, for each entry in one hash table, its key is
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4117 equivalent to a key in the other hash table using the hash table test, and
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4118 its value is `equalp' to the other hash table's value for that key.
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4119 */
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4120 (object1, object2))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4121 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4122 return internal_equalp (object1, object2, 0) ? Qt : Qnil;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4123 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4124
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4125 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4126 Return t if two Lisp objects have similar structure and contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4127 They must have the same data type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4128 \(Note, however, that an exception is made for characters and integers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4129 this is known as the "char-int confoundance disease." See `eq' and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4130 `old-eq'.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4131 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4132 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4133 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4134 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4135 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4136 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4137 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4139
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4140 static Lisp_Object replace_string_range_1 (Lisp_Object dest,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4141 Lisp_Object start,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4142 Lisp_Object end,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4143 const Ibyte *source,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4144 const Ibyte *source_limit,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4145 Lisp_Object item);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4146
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4147 /* Fill the substring of DEST beginning at START and ending before END with
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4148 the character ITEM. If DEST does not have sufficient space for END -
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4149 START characters at START, write as many as is possible without changing
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4150 the character length of DEST. Update the string modification flag and do
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4151 any sledgehammer checks we have turned on.
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4152
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4153 START must be a Lisp integer. END can be nil, indicating the length of the
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4154 string, or a Lisp integer. The condition (<= 0 START END (length DEST))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4155 must hold, or fill_string_range() will signal an error. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4156 static Lisp_Object
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4157 fill_string_range (Lisp_Object dest, Lisp_Object item, Lisp_Object start,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4158 Lisp_Object end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4159 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4160 return replace_string_range_1 (dest, start, end, NULL, NULL, item);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4161 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4162
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4163 DEFUN ("fill", Ffill, 2, MANY, 0, /*
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4164 Destructively modify SEQUENCE by replacing each element with ITEM.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4165 SEQUENCE is a list, vector, bit vector, or string.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4166
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4167 Optional keyword START is the index of the first element of SEQUENCE
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4168 to be modified, and defaults to zero. Optional keyword END is the
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4169 exclusive upper bound on the elements of SEQUENCE to be modified, and
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4170 defaults to the length of SEQUENCE.
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4171
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4172 arguments: (SEQUENCE ITEM &key (START 0) (END (length SEQUENCE)))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 */
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4174 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4175 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4176 Lisp_Object sequence = args[0];
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4177 Lisp_Object item = args[1];
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4178 Elemcount starting = 0, ending = EMACS_INT_MAX, ii, len;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4179
5277
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
4180 PARSE_KEYWORDS (Ffill, nargs, args, 2, (start, end), (start = Qzero));
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4181
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4182 CHECK_NATNUM (start);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4183 starting = XINT (start);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4184
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4185 if (!NILP (end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4186 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4187 CHECK_NATNUM (end);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4188 ending = XINT (end);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4189 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4190
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4191 retry:
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4192 if (STRINGP (sequence))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4193 {
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194 CHECK_CHAR_COERCE_INT (item);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4195 CHECK_LISP_WRITEABLE (sequence);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4196
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4197 fill_string_range (sequence, item, start, end);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4198 }
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4199 else if (VECTORP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4201 Lisp_Object *p = XVECTOR_DATA (sequence);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4202
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4203 CHECK_LISP_WRITEABLE (sequence);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4204 len = XVECTOR_LENGTH (sequence);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4205
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4206 check_sequence_range (sequence, start, end, make_int (len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4207 ending = min (ending, len);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4208
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4209 for (ii = starting; ii < ending; ++ii)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4210 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4211 p[ii] = item;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4212 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 }
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4214 else if (BIT_VECTORP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4216 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217 int bit;
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4218
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219 CHECK_BIT (item);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4220 bit = XINT (item);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4221 CHECK_LISP_WRITEABLE (sequence);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4222 len = bit_vector_length (v);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4223
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4224 check_sequence_range (sequence, start, end, make_int (len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4225 ending = min (ending, len);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4226
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4227 for (ii = starting; ii < ending; ++ii)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4228 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4229 set_bit_vector_bit (v, ii, bit);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4230 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4231 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4232 else if (LISTP (sequence))
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4233 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4234 Elemcount counting = 0;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4235
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4236 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4237 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4238 if (counting >= starting)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4239 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4240 if (counting < ending)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4241 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4242 XSETCAR (tail, item);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4243 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4244 else if (counting == ending)
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4245 {
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4246 break;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4247 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4248 }
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4249 ++counting;
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4250 }
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4251
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
4252 if (counting < starting || (counting != ending && !NILP (end)))
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4253 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
4254 check_sequence_range (args[0], start, end, Flength (args[0]));
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4255 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4257 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4258 {
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4259 sequence = wrong_type_argument (Qsequencep, sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4260 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 }
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
4262 return sequence;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4265 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4266 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4267 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4268 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4269 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4270 args[0] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271 args[1] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4273 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4274 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4275
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4276 RETURN_UNGCPRO (bytecode_nconc2 (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4277 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4279 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4280 bytecode_nconc2 (Lisp_Object *args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4281 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4282 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4284 if (CONSP (args[0]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4285 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4286 /* (setcdr (last args[0]) args[1]) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4287 Lisp_Object tortoise, hare;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4288 Elemcount count;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4289
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4290 for (hare = tortoise = args[0], count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4291 CONSP (XCDR (hare));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4292 hare = XCDR (hare), count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4293 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4294 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4295
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4296 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4297 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4298 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4299 signal_circular_list_error (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4300 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4301 XCDR (hare) = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4302 return args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4303 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4304 else if (NILP (args[0]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4305 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306 return args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4307 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4308 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4309 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4310 args[0] = wrong_type_argument (args[0], Qlistp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4311 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316 Concatenate any number of lists by altering them.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 Only the last argument is not altered, and need not be a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318 Also see: `append'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 If the first argument is nil, there is no way to modify it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4320 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4321 changing the value of `foo'.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
4322
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
4323 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4324 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4325 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4327 int argnum = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4328 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4329
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4330 /* The modus operandi in Emacs is "caller gc-protects args".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4331 However, nconc (particularly nconc2 ()) is called many times
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4332 in Emacs on freshly created stuff (e.g. you see the idiom
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4333 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4334 callers out by protecting the args ourselves to save them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4335 a lot of temporary-variable grief. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4336
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4337 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4338 gcpro1.nvars = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4339
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4340 while (argnum < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4341 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4342 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4343 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 val = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 if (CONSP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 /* `val' is the first cons, which will be our return value. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4348 /* `last_cons' will be the cons cell to mutate. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 Lisp_Object last_cons = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 Lisp_Object tortoise = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4352 for (argnum++; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354 Lisp_Object next = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355 retry_next:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 if (CONSP (next) || argnum == nargs -1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358 /* (setcdr (last val) next) */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4359 Elemcount count;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4361 for (count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4362 CONSP (XCDR (last_cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4363 last_cons = XCDR (last_cons), count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4364 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4365 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4367 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4368 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4369 if (EQ (last_cons, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4370 signal_circular_list_error (args[argnum-1]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4371 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 XCDR (last_cons) = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4373 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4374 else if (NILP (next))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4377 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380 next = wrong_type_argument (Qlistp, next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 goto retry_next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4382 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4383 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 else if (NILP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4387 argnum++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4388 else if (argnum == nargs - 1) /* last arg? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4389 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4390 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 args[argnum] = wrong_type_argument (Qlistp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4393 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4394 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4398
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4399
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4400 /* Replace the substring of DEST beginning at START and ending before END
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4401 with the text at SOURCE, which is END - START characters long and
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4402 SOURCE_LIMIT - SOURCE octets long. If DEST does not have sufficient
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4403 space for END - START characters at START, write as many as is possible
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4404 without changing the length of DEST. Update the string modification flag
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4405 and do any sledgehammer checks we have turned on in this build.
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4406
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4407 START must be a Lisp integer. END can be nil, indicating the length of the
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4408 string, or a Lisp integer. The condition (<= 0 START END (length DEST))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4409 must hold, or replace_string_range() will signal an error. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4410 static Lisp_Object
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4411 replace_string_range (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4412 const Ibyte *source, const Ibyte *source_limit)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4413 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4414 return replace_string_range_1 (dest, start, end, source, source_limit,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4415 Qnil);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4416 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4417
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
4418 /* This is the guts of several mapping functions.
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4419
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4420 Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4421 taking the elements from SEQUENCES. If VALS is non-NULL, store the
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4422 results into VALS, a C array of Lisp_Objects; else, if LISP_VALS is
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4423 non-nil, store the results into LISP_VALS, a sequence with sufficient
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
4424 room for CALL_COUNT results (but see the documentation of SOME_OR_EVERY.)
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
4425 Else, do not accumulate any result.
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4426
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4427 If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4428 mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4429 so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4430 mapcarX.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4431
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4432 Otherwise, mapcarX signals an invalid state error (see
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4433 mapping_interaction_error(), above) if it encounters a non-cons,
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4434 non-array when traversing SEQUENCES. Common Lisp specifies in
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4435 MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4436 destructively modifies SEQUENCES in a way that might affect the ongoing
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4437 traversal operation.
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4438
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4439 CALLER is a symbol describing the Lisp-visible function that was called,
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4440 and any errors thrown because SEQUENCES was modified will reflect it.
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4441
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4442 If CALLER is Qsome, return the (possibly multiple) values given by
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4443 FUNCTION the first time it is non-nil, and abandon the iterations.
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4444 LISP_VALS must be the result of calling STORE_VOID_IN_LISP on the address
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4445 of a Lisp object, and the return value will be stored at that address.
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4446 If CALLER is Qevery, LISP_VALS must also reflect a pointer to a Lisp
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4447 object, and Qnil will be stored at that address if FUNCTION gives nil;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4448 otherwise it will be left alone. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4449
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4450 static void
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4451 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals,
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4452 Lisp_Object function, int nsequences, Lisp_Object *sequences,
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4453 Lisp_Object caller)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4454 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4455 Lisp_Object called, *args;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4456 struct gcpro gcpro1, gcpro2;
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4457 Ibyte *lisp_vals_staging = NULL, *cursor = NULL;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4458 int i, j;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4459
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4460 assert ((EQ (caller, Qsome) || EQ (caller, Qevery)) ? vals == NULL : 1);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4461
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4462 args = alloca_array (Lisp_Object, nsequences + 1);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4463 args[0] = function;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4464 for (i = 1; i <= nsequences; ++i)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4465 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4466 args[i] = Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4467 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4468
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4469 if (vals != NULL)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4470 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4471 GCPRO2 (args[0], vals[0]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4472 gcpro1.nvars = nsequences + 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4473 gcpro2.nvars = 0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4474 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4475 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4476 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4477 GCPRO1 (args[0]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4478 gcpro1.nvars = nsequences + 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4479 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4480
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4481 /* Be extra nice in the event that we've been handed one list and one
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4482 only; make it possible for FUNCTION to set cdrs not yet processed to
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4483 non-cons, non-nil objects without ill-effect, if we have been handed
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4484 the stack space to do that. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4485 if (vals != NULL && 1 == nsequences && CONSP (sequences[0]))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4486 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4487 Lisp_Object lst = sequences[0];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4488 Lisp_Object *val = vals;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4489 for (i = 0; i < call_count; ++i)
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
4490 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4491 *val++ = XCAR (lst);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4492 lst = XCDR (lst);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4493 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4494 gcpro2.nvars = call_count;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4495
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4496 for (i = 0; i < call_count; ++i)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4497 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4498 args[1] = vals[i];
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
4499 vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4500 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4501 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4502 else
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4503 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4504 enum lrecord_type lisp_vals_type = lrecord_type_symbol;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4505 Binbyte *sequence_types = alloca_array (Binbyte, nsequences);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4506 for (j = 0; j < nsequences; ++j)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4507 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4508 sequence_types[j] = XRECORD_LHEADER (sequences[j])->type;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4509 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4510
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4511 if (!EQ (caller, Qsome) && !EQ (caller, Qevery))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4512 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4513 assert (LRECORDP (lisp_vals));
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4514
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4515 lisp_vals_type
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4516 = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4517
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4518 if (lrecord_type_string == lisp_vals_type)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4519 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4520 lisp_vals_staging = cursor
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4521 = alloca_ibytes (call_count * MAX_ICHAR_LEN);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4522 }
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4523 else if (ARRAYP (lisp_vals))
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4524 {
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4525 CHECK_LISP_WRITEABLE (lisp_vals);
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4526 }
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4527 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4528
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4529 for (i = 0; i < call_count; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4530 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4531 for (j = 0; j < nsequences; ++j)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4532 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4533 switch (sequence_types[j])
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4534 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4535 case lrecord_type_cons:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4536 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4537 if (!CONSP (sequences[j]))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4538 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4539 /* This means FUNCTION has messed around with a cons
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4540 in one of the sequences, since we checked the
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4541 type (CHECK_SEQUENCE()) and the length and
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4542 structure (with Flength()) correctly in our
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4543 callers. */
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4544 mapping_interaction_error (caller, sequences[j]);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4545 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4546 args[j + 1] = XCAR (sequences[j]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4547 sequences[j] = XCDR (sequences[j]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4548 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4549 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4550 case lrecord_type_vector:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4551 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4552 args[j + 1] = XVECTOR_DATA (sequences[j])[i];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4553 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4554 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4555 case lrecord_type_string:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4556 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4557 args[j + 1] = make_char (string_ichar (sequences[j], i));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4558 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4559 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4560 case lrecord_type_bit_vector:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4561 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4562 args[j + 1]
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4563 = make_int (bit_vector_bit (XBIT_VECTOR (sequences[j]),
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4564 i));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4565 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4566 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4567 default:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4568 ABORT();
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4569 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4570 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4571 called = Ffuncall (nsequences + 1, args);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4572 if (vals != NULL)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4573 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4574 vals[i] = IGNORE_MULTIPLE_VALUES (called);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4575 gcpro2.nvars += 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4576 }
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4577 else if (EQ (Qsome, caller))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4578 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4579 if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4580 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4581 Lisp_Object *result
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4582 = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4583 *result = called;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4584 UNGCPRO;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4585 return;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4586 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4587 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4588 else if (EQ (Qevery, caller))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4589 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4590 if (NILP (IGNORE_MULTIPLE_VALUES (called)))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4591 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4592 Lisp_Object *result
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4593 = (Lisp_Object *) GET_VOID_FROM_LISP (lisp_vals);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4594 *result = Qnil;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4595 UNGCPRO;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4596 return;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4597 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4598 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4599 else
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4600 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4601 called = IGNORE_MULTIPLE_VALUES (called);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4602 switch (lisp_vals_type)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4603 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4604 case lrecord_type_symbol:
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4605 /* Discard the result of funcall. */
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4606 break;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4607 case lrecord_type_cons:
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4608 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4609 if (!CONSP (lisp_vals))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4610 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4611 /* If FUNCTION has inserted a non-cons non-nil
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4612 cdr into the list before we've processed the
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4613 relevant part, error. */
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4614 mapping_interaction_error (caller, lisp_vals);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4615 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4616 XSETCAR (lisp_vals, called);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4617 lisp_vals = XCDR (lisp_vals);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4618 break;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4619 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4620 case lrecord_type_vector:
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4621 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4622 i < XVECTOR_LENGTH (lisp_vals) ?
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4623 (XVECTOR_DATA (lisp_vals)[i] = called) :
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4624 /* Let #'aset error. */
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4625 Faset (lisp_vals, make_int (i), called);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4626 break;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4627 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4628 case lrecord_type_string:
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4629 {
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4630 CHECK_CHAR_COERCE_INT (called);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4631 cursor += set_itext_ichar (cursor, XCHAR (called));
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4632 break;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4633 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4634 case lrecord_type_bit_vector:
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4635 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4636 (BITP (called) &&
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4637 i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4638 set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4639 XINT (called)) :
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4640 (void) Faset (lisp_vals, make_int (i), called);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4641 break;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4642 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4643 default:
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4644 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4645 ABORT();
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4646 break;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4647 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4648 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4649 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4650 }
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4651
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4652 if (lisp_vals_staging != NULL)
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4653 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4654 CHECK_LISP_WRITEABLE (lisp_vals);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4655 replace_string_range (lisp_vals, Qzero, make_int (call_count),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4656 lisp_vals_staging, cursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4657 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4658 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
4659
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4660 UNGCPRO;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4661 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4662
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4663 /* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4664 the length of the shortest sequence. Error if all are circular, or if any
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4665 one of them is not a sequence. */
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4666 static Elemcount
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4667 shortest_length_among_sequences (int nsequences, Lisp_Object *sequences)
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4668 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4669 Elemcount len = EMACS_INT_MAX;
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4670 Lisp_Object length = Qnil;
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4671 int i;
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4672
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4673 for (i = 0; i < nsequences; ++i)
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4674 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4675 if (CONSP (sequences[i]))
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4676 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4677 length = Flist_length (sequences[i]);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4678 if (!NILP (length))
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4679 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4680 len = min (len, XINT (length));
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4681 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4682 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4683 else
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4684 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4685 CHECK_SEQUENCE (sequences[i]);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4686 length = Flength (sequences[i]);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4687 len = min (len, XINT (length));
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4688 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4689 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4690
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4691 if (NILP (length))
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4692 {
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4693 signal_circular_list_error (sequences[0]);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4694 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4695
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4696 return len;
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4697 }
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4698
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4699 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4700 Call FUNCTION on each element of SEQUENCE, and concat results to a string.
751
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
4701 Between each pair of results, insert SEPARATOR.
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
4702
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
4703 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
4704 results in spaces between the values returned by FUNCTION. SEQUENCE itself
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
4705 may be a list, a vector, a bit vector, or a string.
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4706
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4707 With optional SEQUENCES, call FUNCTION each time with as many arguments as
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4708 there are SEQUENCES, plus one for the element from SEQUENCE. One element
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4709 from each sequence will be used each time FUNCTION is called, and
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4710 `mapconcat' will give up once the shortest sequence is exhausted.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4711
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4712 arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4713 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4714 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4715 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4716 Lisp_Object function = args[0];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4717 Lisp_Object sequence = args[1];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4718 Lisp_Object separator = args[2];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4719 Elemcount len = EMACS_INT_MAX;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4720 Lisp_Object *args0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4721 EMACS_INT i, nargs0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4722
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4723 args[2] = sequence;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4724 args[1] = separator;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4725
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4726 len = shortest_length_among_sequences (nargs - 2, args + 2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4727
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4728 if (len == 0) return build_ascstring ("");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4729
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4730 nargs0 = len + len - 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4731 args0 = alloca_array (Lisp_Object, nargs0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4732
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4733 /* Special-case this, it's very common and doesn't require any
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4734 funcalls. Upside of doing it here, instead of cl-macs.el: no consing,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4735 apart from the final string, we allocate everything on the stack. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4736 if (EQ (function, Qidentity) && 3 == nargs && CONSP (sequence))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4737 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4738 for (i = 0; i < len; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4739 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4740 args0[i] = XCAR (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4741 sequence = XCDR (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4742 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4743 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4744 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4745 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4746 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmapconcat);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4747 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4748
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4749 for (i = len - 1; i >= 0; i--)
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4750 args0[i + i] = args0[i];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4751
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4752 for (i = 1; i < nargs0; i += 2)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4753 args0[i] = separator;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4754
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4755 return Fconcat (nargs0, args0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4756 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4757
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4758 DEFUN ("mapcar*", FmapcarX, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4759 Call FUNCTION on each element of SEQUENCE; return a list of the results.
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
4760 The result is a list of the same length as SEQUENCE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4761 SEQUENCE may be a list, a vector, a bit vector, or a string.
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4762
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4763 With optional SEQUENCES, call FUNCTION each time with as many arguments as
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4764 there are SEQUENCES, plus one for the element from SEQUENCE. One element
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4765 from each sequence will be used each time FUNCTION is called, and `mapcar'
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4766 stops calling FUNCTION once the shortest sequence is exhausted.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4767
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4768 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4769 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4770 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4771 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4772 Lisp_Object function = args[0];
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4773 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4774 Lisp_Object *args0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4775
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4776 args0 = alloca_array (Lisp_Object, len);
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4777 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4778
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4779 return Flist ((int) len, args0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4780 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4781
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4782 DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4783 Call FUNCTION on each element of SEQUENCE; return a vector of the results.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4784 The result is a vector of the same length as SEQUENCE.
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
4785 SEQUENCE may be a list, a vector, a bit vector, or a string.
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4786
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4787 With optional SEQUENCES, call FUNCTION each time with as many arguments as
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4788 there are SEQUENCES, plus one for the element from SEQUENCE. One element
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4789 from each sequence will be used each time FUNCTION is called, and
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4790 `mapvector' stops calling FUNCTION once the shortest sequence is exhausted.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4791
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4792 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4793 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4794 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4795 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4796 Lisp_Object function = args[0];
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4797 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4798 Lisp_Object result = make_vector (len, Qnil);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4799
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4800 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4801 GCPRO1 (result);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4802 /* Don't pass result as the lisp_object argument, we want mapcarX to protect
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4803 a single list argument's elements from being garbage-collected. */
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4804 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4805 Qmapvector);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4806 RETURN_UNGCPRO (result);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4807 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4808
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4809 DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4810 Call FUNCTION on each element of SEQUENCE; chain the results together.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4811
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4812 FUNCTION must normally return a list; the results will be concatenated
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4813 together using `nconc'.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4814
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4815 With optional SEQUENCES, call FUNCTION each time with as many arguments as
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4816 there are SEQUENCES, plus one for the element from SEQUENCE. One element
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4817 from each sequence will be used each time FUNCTION is called, and
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4818 `mapcan' stops calling FUNCTION once the shortest sequence is exhausted.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4819
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4820 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4821 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4822 (int nargs, Lisp_Object *args))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4823 {
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4824 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4825 Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len);
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4826
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4827 mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4828
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4829 /* #'nconc GCPROs its args in case of signals and error. */
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4830 return Fnconc (len, result);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4831 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4832
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4833 DEFUN ("mapc", Fmapc, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4834 Call FUNCTION on each element of SEQUENCE.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4835
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4836 SEQUENCE may be a list, a vector, a bit vector, or a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4837 This function is like `mapcar' but does not accumulate the results,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4838 which is more efficient if you do not use the results.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4839
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4840 With optional SEQUENCES, call FUNCTION each time with as many arguments as
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4841 there are SEQUENCES, plus one for the elements from SEQUENCE. One element
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4842 from each sequence will be used each time FUNCTION is called, and
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4843 `mapc' stops calling FUNCTION once the shortest sequence is exhausted.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4844
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4845 Return SEQUENCE.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4846
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4847 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4848 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4849 (int nargs, Lisp_Object *args))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4850 {
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4851 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4852 Lisp_Object sequence = args[1];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4853 struct gcpro gcpro1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4854 /* We need to GCPRO sequence, because mapcarX will modify the
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4855 elements of the args array handed to it, and this may involve
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4856 elements of sequence getting garbage collected. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4857 GCPRO1 (sequence);
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4858 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4859 RETURN_UNGCPRO (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4860 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4861
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4862 DEFUN ("map", Fmap, 3, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4863 Map FUNCTION across one or more sequences, returning a sequence.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4864
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4865 TYPE is the sequence type to return, FUNCTION is the function, SEQUENCE is
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4866 the first argument sequence, SEQUENCES are the other argument sequences.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4867
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4868 FUNCTION will be called with (1+ (length SEQUENCES)) arguments, and must be
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4869 capable of accepting this number of arguments.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4870
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4871 Certain TYPEs are recognised internally by `map', but others are not, and
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4872 `coerce' may throw an error on an attempt to convert to a TYPE it does not
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4873 understand. A null TYPE means do not accumulate any values.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4874
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4875 arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4876 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4877 (int nargs, Lisp_Object *args))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4878 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4879 Lisp_Object type = args[0];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4880 Lisp_Object function = args[1];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4881 Lisp_Object result = Qnil;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4882 Lisp_Object *args0 = NULL;
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4883 Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4884 struct gcpro gcpro1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4885
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4886 if (!NILP (type))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4887 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4888 args0 = alloca_array (Lisp_Object, len);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4889 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4890
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4891 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2, Qmap);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4892
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4893 if (EQ (type, Qnil))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4894 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4895 return result;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4896 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4897
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4898 if (EQ (type, Qvector) || EQ (type, Qarray))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4899 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4900 result = Fvector (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4901 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4902 else if (EQ (type, Qstring))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4903 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4904 result = Fstring (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4905 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4906 else if (EQ (type, Qlist))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4907 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4908 result = Flist (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4909 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4910 else if (EQ (type, Qbit_vector))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4911 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4912 result = Fbit_vector (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4913 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4914 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4915 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4916 result = Flist (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4917 GCPRO1 (result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4918 result = call2 (Qcoerce, result, type);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4919 UNGCPRO;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4920 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4921
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4922 return result;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4923 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4924
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4925 DEFUN ("map-into", Fmap_into, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4926 Modify RESULT-SEQUENCE using the return values of FUNCTION on SEQUENCES.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4927
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4928 RESULT-SEQUENCE and SEQUENCES can be lists or arrays.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4929
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4930 FUNCTION must accept at least as many arguments as there are SEQUENCES
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4931 \(possibly zero). If RESULT-SEQUENCE and the elements of SEQUENCES are not
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4932 the same length, stop when the shortest is exhausted; any elements of
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4933 RESULT-SEQUENCE beyond that are unmodified.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4934
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4935 Return RESULT-SEQUENCE.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4936
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4937 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4938 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4939 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4940 {
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4941 Elemcount len;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4942 Lisp_Object result_sequence = args[0];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4943 Lisp_Object function = args[1];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4944
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4945 args[0] = function;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4946 args[1] = result_sequence;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4947
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4948 len = shortest_length_among_sequences (nargs - 1, args + 1);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4949
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4950 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4951 Qmap_into);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4952
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4953 return result_sequence;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4954 }
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4955
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4956 DEFUN ("some", Fsome, 2, MANY, 0, /*
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4957 Return true if PREDICATE gives non-nil for an element of SEQUENCE.
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4958
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4959 If so, return the value (possibly multiple) given by PREDICATE.
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4960
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4961 With optional SEQUENCES, call PREDICATE each time with as many arguments as
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4962 there are SEQUENCES (plus one for the element from SEQUENCE).
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4963
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4964 See also `find-if', which returns the corresponding element of SEQUENCE,
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4965 rather than the value given by PREDICATE, and accepts bounding index
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4966 keywords.
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
4967
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4968 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4969 */
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4970 (int nargs, Lisp_Object *args))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4971 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4972 Lisp_Object result = Qnil,
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4973 result_ptr = STORE_VOID_IN_LISP ((void *) &result);
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4974 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4975
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4976 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4977
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4978 return result;
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4979 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4980
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4981 DEFUN ("every", Fevery, 2, MANY, 0, /*
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4982 Return true if PREDICATE is true of every element of SEQUENCE.
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4983
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4984 With optional SEQUENCES, call PREDICATE each time with as many arguments as
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4985 there are SEQUENCES (plus one for the element from SEQUENCE).
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4986
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4987 In contrast to `some', `every' never returns multiple values.
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4988
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4989 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4990 */
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4991 (int nargs, Lisp_Object *args))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4992 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4993 Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result);
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
4994 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4995
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4996 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4997
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
4998 return result;
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4999 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5000
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5001 /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5002 corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]),
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5003 until that #'nthcdr expression gives nil for some element of LISTS.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5004
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5005 CALLER is a symbol reflecting the Lisp-visible function that was called,
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5006 and any errors thrown because SEQUENCES was modified will reflect it.
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5007
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5008 If CALLER is Qmapl, return LISTS[0]. Otherwise, return a list of the
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5009 return values from FUNCTION; if caller is Qmapcan, nconc them together.
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5010
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5011 In contrast to mapcarX, we don't require our callers to check LISTS for
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5012 well-formedness, we signal wrong-type-argument if it's not a list, or
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5013 circular-list if it's circular. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5014
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5015 static Lisp_Object
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5016 maplist (Lisp_Object function, int nlists, Lisp_Object *lists,
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5017 Lisp_Object caller)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5018 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5019 Lisp_Object nconcing[2], accum = Qnil, *args, *tortoises, funcalled;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5020 Lisp_Object result = EQ (caller, Qmapl) ? lists[0] : Qnil;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5021 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5022 int i, j, continuing = (nlists > 0), called_count = 0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5023
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5024 args = alloca_array (Lisp_Object, nlists + 1);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5025 args[0] = function;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5026 for (i = 1; i <= nlists; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5027 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5028 args[i] = Qnil;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5029 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5030
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5031 tortoises = alloca_array (Lisp_Object, nlists);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5032 memcpy (tortoises, lists, nlists * sizeof (Lisp_Object));
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5033
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5034 if (EQ (caller, Qmapcon))
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5035 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5036 nconcing[0] = Qnil;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5037 nconcing[1] = Qnil;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5038 GCPRO4 (args[0], nconcing[0], tortoises[0], result);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5039 gcpro1.nvars = 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5040 gcpro2.nvars = 2;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5041 gcpro3.nvars = nlists;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5042 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5043 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5044 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5045 GCPRO3 (args[0], tortoises[0], result);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5046 gcpro1.nvars = 1;
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5047 gcpro2.nvars = nlists;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5048 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5049
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5050 while (continuing)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5051 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5052 for (j = 0; j < nlists; ++j)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5053 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5054 if (CONSP (lists[j]))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5055 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5056 args[j + 1] = lists[j];
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5057 lists[j] = XCDR (lists[j]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5058 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5059 else if (NILP (lists[j]))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5060 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5061 continuing = 0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5062 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5063 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5064 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5065 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5066 lists[j] = wrong_type_argument (Qlistp, lists[j]);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5067 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5068 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5069 if (!continuing) break;
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
5070 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args));
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5071
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5072 if (EQ (caller, Qmapl))
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5073 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5074 DO_NOTHING;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5075 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5076 else if (EQ (caller, Qmapcon))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5077 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5078 nconcing[1] = funcalled;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5079 accum = bytecode_nconc2 (nconcing);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5080 if (NILP (result))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5081 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5082 result = accum;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5083 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5084 /* Only check a given stretch of result for well-formedness
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5085 once: */
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5086 nconcing[0] = funcalled;
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5087 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5088 else if (NILP (accum))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5089 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5090 accum = result = Fcons (funcalled, Qnil);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5091 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5092 else
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5093 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5094 /* Add to the end, avoiding the need to call nreverse
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5095 once we're done: */
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5096 XSETCDR (accum, Fcons (funcalled, Qnil));
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5097 accum = XCDR (accum);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5098 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5099
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5100 if (++called_count > CIRCULAR_LIST_SUSPICION_LENGTH)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5101 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5102 if (called_count & 1)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5103 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5104 for (j = 0; j < nlists; ++j)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5105 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5106 tortoises[j] = XCDR (tortoises[j]);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5107 if (EQ (lists[j], tortoises[j]))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5108 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5109 signal_circular_list_error (lists[j]);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5110 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5111 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5112 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5113 else
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5114 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5115 for (j = 0; j < nlists; ++j)
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5116 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5117 if (EQ (lists[j], tortoises[j]))
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5118 {
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5119 signal_circular_list_error (lists[j]);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5120 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5121 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5122 }
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5123 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5124 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5125
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5126 RETURN_UNGCPRO (result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5127 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5128
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5129 DEFUN ("maplist", Fmaplist, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5130 Call FUNCTION on each sublist of LIST and LISTS.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5131 Like `mapcar', except applies to lists and their cdr's rather than to
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5132 the elements themselves."
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5133
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5134 arguments: (FUNCTION LIST &rest LISTS)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5135 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5136 (int nargs, Lisp_Object *args))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5137 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5138 return maplist (args[0], nargs - 1, args + 1, Qmaplist);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5139 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5140
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5141 DEFUN ("mapl", Fmapl, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5142 Like `maplist', but do not accumulate values returned by the function.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5143
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5144 arguments: (FUNCTION LIST &rest LISTS)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5145 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5146 (int nargs, Lisp_Object *args))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5147 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5148 return maplist (args[0], nargs - 1, args + 1, Qmapl);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5149 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5150
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5151 DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /*
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5152 Like `maplist', but chains together the values returned by FUNCTION.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5153
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5154 FUNCTION must return a list (unless it happens to be the last
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5155 iteration); the results will be concatenated together using `nconc'.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5156
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5157 arguments: (FUNCTION LIST &rest LISTS)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5158 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5159 (int nargs, Lisp_Object *args))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5160 {
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
5161 return maplist (args[0], nargs - 1, args + 1, Qmapcon);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
5162 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5163
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
5164 /* Extra random functions */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5165
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5166 DEFUN ("reduce", Freduce, 2, MANY, 0, /*
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5167 Combine the elements of sequence using FUNCTION, a binary operation.
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5168
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5169 For example, `(reduce #'+ SEQUENCE)' returns the sum of all elements in
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5170 SEQUENCE, and `(reduce #'union SEQUENCE)' returns the union of all elements
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5171 in SEQUENCE.
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5172
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5173 Keywords supported: :start :end :from-end :initial-value :key
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5174 See `remove*' for the meaning of :start, :end, :from-end and :key.
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5175
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5176 :initial-value specifies an element (typically an identity element, such as
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5177 0) that is conceptually prepended to the sequence (or appended, when
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5178 :from-end is given).
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5179
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5180 If the sequence has one element, that element is returned directly.
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5181 If the sequence has no elements, :initial-value is returned if given;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5182 otherwise, FUNCTION is called with no arguments, and its result returned.
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5183
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5184 arguments: (FUNCTION SEQUENCE &key (START 0) (END (length SEQUENCE)) FROM-END INITIAL-VALUE (KEY #'identity))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5185 */
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5186 (int nargs, Lisp_Object *args))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5187 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5188 Lisp_Object function = args[0], sequence = args[1], accum = Qunbound;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5189 Elemcount starting, ending = EMACS_INT_MAX, ii = 0;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5190
5277
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
5191 PARSE_KEYWORDS (Freduce, nargs, args, 5,
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5192 (start, end, from_end, initial_value, key),
5277
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
5193 (start = Qzero, initial_value = Qunbound));
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5194
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5195 CHECK_SEQUENCE (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5196 CHECK_NATNUM (start);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5197
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5198 CHECK_KEY_ARGUMENT (key);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5199
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5200 #define KEY(key, item) (EQ (Qidentity, key) ? item : \
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5201 IGNORE_MULTIPLE_VALUES (call1 (key, item)))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5202 #define CALL2(function, accum, item) \
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5203 IGNORE_MULTIPLE_VALUES (call2 (function, accum, item))
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5204
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5205 starting = XINT (start);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5206 if (!NILP (end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5207 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5208 CHECK_NATNUM (end);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5209 ending = XINT (end);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5210 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5211
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5212 if (!(starting <= ending))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5213 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5214 check_sequence_range (sequence, start, end, Flength (sequence));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5215 }
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5216
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5217 if (VECTORP (sequence))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5218 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5219 Lisp_Vector *vv = XVECTOR (sequence);
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5220 struct gcpro gcpro1;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5221
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5222 check_sequence_range (sequence, start, end, make_int (vv->size));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5223
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5224 ending = min (ending, vv->size);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5225
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5226 GCPRO1 (accum);
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5227
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5228 if (!UNBOUNDP (initial_value))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5229 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5230 accum = initial_value;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5231 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5232 else if (ending - starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5233 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5234 if (NILP (from_end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5235 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5236 accum = KEY (key, vv->contents[starting]);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5237 starting++;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5238 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5239 else
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5240 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5241 accum = KEY (key, vv->contents[ending - 1]);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5242 ending--;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5243 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5244 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5245
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5246 if (NILP (from_end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5247 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5248 for (ii = starting; ii < ending; ++ii)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5249 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5250 accum = CALL2 (function, accum, KEY (key, vv->contents[ii]));
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5251 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5252 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5253 else
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5254 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5255 for (ii = ending - 1; ii >= starting; --ii)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5256 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5257 accum = CALL2 (function, KEY (key, vv->contents[ii]), accum);
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5258 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5259 }
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5260
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5261 UNGCPRO;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5262 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5263 else if (BIT_VECTORP (sequence))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5264 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5265 Lisp_Bit_Vector *bv = XBIT_VECTOR (sequence);
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5266 struct gcpro gcpro1;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5267
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5268 check_sequence_range (sequence, start, end, make_int (bv->size));
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5269 ending = min (ending, bv->size);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5270
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5271 GCPRO1 (accum);
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5272
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5273 if (!UNBOUNDP (initial_value))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5274 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5275 accum = initial_value;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5276 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5277 else if (ending - starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5278 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5279 if (NILP (from_end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5280 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5281 accum = KEY (key, make_int (bit_vector_bit (bv, starting)));
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5282 starting++;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5283 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5284 else
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5285 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5286 accum = KEY (key, make_int (bit_vector_bit (bv, ending - 1)));
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5287 ending--;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5288 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5289 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5290
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5291 if (NILP (from_end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5292 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5293 for (ii = starting; ii < ending; ++ii)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5294 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5295 accum = CALL2 (function, accum,
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5296 KEY (key, make_int (bit_vector_bit (bv, ii))));
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5297 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5298 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5299 else
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5300 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5301 for (ii = ending - 1; ii >= starting; --ii)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5302 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5303 accum = CALL2 (function, KEY (key,
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5304 make_int (bit_vector_bit (bv,
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5305 ii))),
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5306 accum);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5307 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5308 }
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5309
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5310 UNGCPRO;
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5311
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5312 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5313 else if (STRINGP (sequence))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5314 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5315 struct gcpro gcpro1;
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5316
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5317 GCPRO1 (accum);
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5318
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5319 if (NILP (from_end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5320 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5321 Bytecount byte_len = XSTRING_LENGTH (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5322 Bytecount cursor_offset = 0;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5323 const Ibyte *startp = XSTRING_DATA (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5324 const Ibyte *cursor = startp;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5325
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5326 for (ii = 0; ii != starting && cursor_offset < byte_len; ++ii)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5327 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5328 INC_IBYTEPTR (cursor);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5329 cursor_offset = cursor - startp;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5330 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5331
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5332 if (!UNBOUNDP (initial_value))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5333 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5334 accum = initial_value;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5335 }
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5336 else if (ending - starting && cursor_offset < byte_len)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5337 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5338 accum = KEY (key, make_char (itext_ichar (cursor)));
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5339 starting++;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5340 startp = XSTRING_DATA (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5341 cursor = startp + cursor_offset;
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5342
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5343 if (byte_len != XSTRING_LENGTH (sequence)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5344 || !valid_ibyteptr_p (cursor))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5345 {
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5346 mapping_interaction_error (Qreduce, sequence);
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5347 }
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5348
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5349 INC_IBYTEPTR (cursor);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5350 cursor_offset = cursor - startp;
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5351 ii++;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5352 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5353
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5354 while (cursor_offset < byte_len && ii < ending)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5355 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5356 accum = CALL2 (function, accum,
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5357 KEY (key, make_char (itext_ichar (cursor))));
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5358
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5359 startp = XSTRING_DATA (sequence);
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5360 cursor = startp + cursor_offset;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5361
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5362 if (byte_len != XSTRING_LENGTH (sequence)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5363 || !valid_ibyteptr_p (cursor))
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5364 {
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5365 mapping_interaction_error (Qreduce, sequence);
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5366 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5367
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5368 INC_IBYTEPTR (cursor);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5369 cursor_offset = cursor - startp;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5370 ++ii;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5371 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5372
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5373 if (ii < starting || (ii < ending && !NILP (end)))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5374 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5375 check_sequence_range (sequence, start, end, Flength (sequence));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5376 }
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5377 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5378 else
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5379 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5380 Elemcount len = string_char_length (sequence);
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5381 Bytecount cursor_offset, byte_len = XSTRING_LENGTH (sequence);
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5382 const Ibyte *cursor;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5383
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5384 check_sequence_range (sequence, start, end, make_int (len));
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5385 ending = min (ending, len);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5386 cursor = string_char_addr (sequence, ending - 1);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5387 cursor_offset = cursor - XSTRING_DATA (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5388
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5389 if (!UNBOUNDP (initial_value))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5390 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5391 accum = initial_value;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5392 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5393 else if (ending - starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5394 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5395 accum = KEY (key, make_char (itext_ichar (cursor)));
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5396 ending--;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5397 if (ending > 0)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5398 {
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5399 cursor = XSTRING_DATA (sequence) + cursor_offset;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5400
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5401 if (!valid_ibyteptr_p (cursor))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5402 {
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5403 mapping_interaction_error (Qreduce, sequence);
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5404 }
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5405
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5406 DEC_IBYTEPTR (cursor);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5407 cursor_offset = cursor - XSTRING_DATA (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5408 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5409 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5410
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5411 for (ii = ending - 1; ii >= starting; --ii)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5412 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5413 accum = CALL2 (function, KEY (key,
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5414 make_char (itext_ichar (cursor))),
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5415 accum);
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5416 if (ii > 0)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5417 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5418 cursor = XSTRING_DATA (sequence) + cursor_offset;
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5419
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5420 if (byte_len != XSTRING_LENGTH (sequence)
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5421 || !valid_ibyteptr_p (cursor))
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5422 {
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5423 mapping_interaction_error (Qreduce, sequence);
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5424 }
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5425
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5426 DEC_IBYTEPTR (cursor);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5427 cursor_offset = cursor - XSTRING_DATA (sequence);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5428 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5429 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5430 }
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5431
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5432 UNGCPRO;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5433 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5434 else if (LISTP (sequence))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5435 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5436 if (NILP (from_end))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5437 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5438 struct gcpro gcpro1, gcpro2;
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5439 Lisp_Object tailed = Qnil;
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5440
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5441 GCPRO2 (tailed, accum);
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5442
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5443 if (!UNBOUNDP (initial_value))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5444 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5445 accum = initial_value;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5446 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5447 else if (ending - starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5448 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5449 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5450 {
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5451 /* KEY may amputate the list behind us; make sure what
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5452 remains to be processed is still reachable. */
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5453 tailed = tail;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5454 if (ii == starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5455 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5456 accum = KEY (key, elt);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5457 starting++;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5458 break;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5459 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5460 ++ii;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5461 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5462 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5463
5275
5a9aa6c40c9b Avoid statement-before-declaration problems with strict C89 builds, fns.c
Aidan Kehoe <kehoea@parhasard.net>
parents: 5273
diff changeset
5464 ii = 0;
5a9aa6c40c9b Avoid statement-before-declaration problems with strict C89 builds, fns.c
Aidan Kehoe <kehoea@parhasard.net>
parents: 5273
diff changeset
5465
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5466 if (ending - starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5467 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5468 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5469 {
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5470 /* KEY or FUNCTION may amputate the list behind us; make
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5471 sure what remains to be processed is still
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5472 reachable. */
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5473 tailed = tail;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5474 if (ii >= starting)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5475 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5476 if (ii < ending)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5477 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5478 accum = CALL2 (function, accum, KEY (key, elt));
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5479 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5480 else if (ii == ending)
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5481 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5482 break;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5483 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5484 }
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5485 ++ii;
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5486 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5487 }
5241
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5488
d579d76f3dcc Be more careful about side-effects from Lisp code, #'reduce
Aidan Kehoe <kehoea@parhasard.net>
parents: 5227
diff changeset
5489 UNGCPRO;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5490
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5491 if (ii < starting || (ii < ending && !NILP (end)))
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5492 {
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5493 check_sequence_range (sequence, start, end, Flength (sequence));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5494 }
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5495 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5496 else
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5497 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5498 Boolint need_accum = 0;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5499 Lisp_Object *subsequence = NULL;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5500 Elemcount counting = 0, len = 0;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5501 struct gcpro gcpro1;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5502
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5503 len = XINT (Flength (sequence));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5504 check_sequence_range (sequence, start, end, make_int (len));
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5505 ending = min (ending, len);
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5506
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5507 /* :from-end with a list; make an alloca copy of the relevant list
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5508 data, attempting to go backwards isn't worth the trouble. */
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5509 if (!UNBOUNDP (initial_value))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5510 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5511 accum = initial_value;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5512 if (ending - starting && starting < ending)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5513 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5514 subsequence = alloca_array (Lisp_Object, ending - starting);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5515 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5516 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5517 else if (ending - starting && starting < ending)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5518 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5519 subsequence = alloca_array (Lisp_Object, ending - starting);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5520 need_accum = 1;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5521 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5522
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5523 if (ending - starting && starting < ending)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5524 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5525 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5526 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5527 if (counting >= starting)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5528 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5529 if (counting < ending)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5530 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5531 subsequence[ii++] = elt;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5532 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5533 else if (counting == ending)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5534 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5535 break;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5536 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5537 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5538 ++counting;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5539 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5540 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5541
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5542 if (subsequence != NULL)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5543 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5544 len = ending - starting;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5545 /* If we could be sure that neither FUNCTION nor KEY modify
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5546 SEQUENCE, this wouldn't be necessary, since all the
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5547 elements of SUBSEQUENCE would definitely always be
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5548 reachable via SEQUENCE. */
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5549 GCPRO1 (subsequence[0]);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5550 gcpro1.nvars = len;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5551 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5552
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5553 if (need_accum)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5554 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5555 accum = KEY (key, subsequence[len - 1]);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5556 --len;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5557 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5558
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5559 for (ii = len; ii != 0;)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5560 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5561 --ii;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5562 accum = CALL2 (function, KEY (key, subsequence[ii]), accum);
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5563 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5564
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5565 if (subsequence != NULL)
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5566 {
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5567 UNGCPRO;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5568 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5569 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5570 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5571
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5572 /* At this point, if ACCUM is unbound, SEQUENCE has no elements; we
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5573 need to return the result of calling FUNCTION with zero
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5574 arguments. */
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5575 if (UNBOUNDP (accum))
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5576 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5577 accum = IGNORE_MULTIPLE_VALUES (call0 (function));
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5578 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5579
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5580 return accum;
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5581 }
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
5582
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5583 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5584 Destructively replace the list OLD with NEW.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5585 This is like (copy-sequence NEW) except that it reuses the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5586 conses in OLD as much as possible. If OLD and NEW are the same
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5587 length, no consing will take place.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5588 */
3025
facf3239ba30 [xemacs-hg @ 2005-10-25 11:16:19 by ben]
ben
parents: 2720
diff changeset
5589 (old, new_))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5590 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5591 Lisp_Object oldtail = old, prevoldtail = Qnil;
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5592
3025
facf3239ba30 [xemacs-hg @ 2005-10-25 11:16:19 by ben]
ben
parents: 2720
diff changeset
5593 EXTERNAL_LIST_LOOP_2 (elt, new_)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5594 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5595 if (!NILP (oldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5596 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5597 CHECK_CONS (oldtail);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5598 XCAR (oldtail) = elt;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5599 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5600 else if (!NILP (prevoldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5601 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5602 XCDR (prevoldtail) = Fcons (elt, Qnil);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5603 prevoldtail = XCDR (prevoldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5604 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5605 else
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
5606 old = oldtail = Fcons (elt, Qnil);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5607
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5608 if (!NILP (oldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5609 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5610 prevoldtail = oldtail;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5611 oldtail = XCDR (oldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5612 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5613 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5614
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5615 if (!NILP (prevoldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5616 XCDR (prevoldtail) = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5617 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5618 old = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5619
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5620 return old;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5621 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
5622
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5623 /* This function is the implementation of fill_string_range() and
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5624 replace_string_range(); see the comments for those functions. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5625 static Lisp_Object
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5626 replace_string_range_1 (Lisp_Object dest, Lisp_Object start, Lisp_Object end,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5627 const Ibyte *source, const Ibyte *source_limit,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5628 Lisp_Object item)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5629 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5630 Ibyte *destp = XSTRING_DATA (dest), *p = destp,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5631 *pend = p + XSTRING_LENGTH (dest), *pcursor, item_buf[MAX_ICHAR_LEN];
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5632 Bytecount prefix_bytecount, source_len = source_limit - source;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5633 Charcount ii = 0, starting = XINT (start), ending, len;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5634 Elemcount delta;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5635
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5636 while (ii < starting && p < pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5637 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5638 INC_IBYTEPTR (p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5639 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5640 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5641
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5642 pcursor = p;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5643
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5644 if (NILP (end))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5645 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5646 while (pcursor < pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5647 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5648 INC_IBYTEPTR (pcursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5649 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5650 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5651
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5652 ending = len = ii;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5653 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5654 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5655 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5656 ending = XINT (end);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5657 while (ii < ending && pcursor < pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5658 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5659 INC_IBYTEPTR (pcursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5660 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5661 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5662 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5663
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5664 if (pcursor == pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5665 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5666 /* We have the length, check it for our callers. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5667 check_sequence_range (dest, start, end, make_int (ii));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5668 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5669
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5670 if (!(p == pend || p == pcursor))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5671 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5672 prefix_bytecount = p - destp;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5673
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5674 if (!NILP (item))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5675 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5676 assert (source == NULL && source_limit == NULL);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5677 source_len = set_itext_ichar (item_buf, XCHAR (item));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5678 delta = (source_len * (ending - starting)) - (pcursor - p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5679 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5680 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5681 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5682 assert (source != NULL && source_limit != NULL);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5683 delta = source_len - (pcursor - p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5684 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5685
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5686 if (delta)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5687 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5688 resize_string (dest, prefix_bytecount, delta);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5689 destp = XSTRING_DATA (dest);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5690 pcursor = destp + prefix_bytecount + (pcursor - p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5691 p = destp + prefix_bytecount;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5692 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5693
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5694 if (CHARP (item))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5695 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5696 while (starting < ending)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5697 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5698 memcpy (p, item_buf, source_len);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5699 p += source_len;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5700 starting++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5701 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5702 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5703 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5704 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5705 while (starting < ending && source < source_limit)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5706 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5707 source_len = itext_copy_ichar (source, p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5708 p += source_len, source += source_len;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5709 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5710 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5711
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5712 init_string_ascii_begin (dest);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5713 bump_string_modiff (dest);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5714 sledgehammer_check_ascii_begin (dest);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5715 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5716
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5717 return dest;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5718 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5719
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5720 DEFUN ("replace", Freplace, 2, MANY, 0, /*
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5721 Replace the elements of SEQUENCE-ONE with the elements of SEQUENCE-TWO.
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5722
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5723 SEQUENCE-ONE is destructively modified, and returned. Its length is not
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5724 changed.
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5725
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5726 Keywords :start1 and :end1 specify a subsequence of SEQUENCE-ONE, and
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5727 :start2 and :end2 a subsequence of SEQUENCE-TWO. See `search' for more
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5728 information.
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5729
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5730 arguments: (SEQUENCE-ONE SEQUENCE-TWO &key (START1 0) (END1 (length SEQUENCE-ONE)) (START2 0) (END2 (length SEQUENCE-TWO)))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5731 */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5732 (int nargs, Lisp_Object *args))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5733 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5734 Lisp_Object sequence1 = args[0], sequence2 = args[1],
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5735 result = sequence1;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5736 Elemcount starting1, ending1 = EMACS_INT_MAX, starting2;
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5737 Elemcount ending2 = EMACS_INT_MAX, counting = 0, startcounting;
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5738 Boolint sequence1_listp, sequence2_listp,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5739 overwriting = EQ (sequence1, sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5740
5277
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
5741 PARSE_KEYWORDS (Freplace, nargs, args, 4, (start1, end1, start2, end2),
d804e621add0 Simplify the API of PARSE_KEYWORDS for callers.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5275
diff changeset
5742 (start1 = start2 = Qzero));
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5743
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5744 CHECK_SEQUENCE (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5745 CHECK_LISP_WRITEABLE (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5746
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5747 CHECK_SEQUENCE (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5748
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5749 CHECK_NATNUM (start1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5750 starting1 = XINT (start1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5751 CHECK_NATNUM (start2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5752 starting2 = XINT (start2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5753
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5754 if (!NILP (end1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5755 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5756 CHECK_NATNUM (end1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5757 ending1 = XINT (end1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5758
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5759 if (!(starting1 <= ending1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5760 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5761 args_out_of_range_3 (sequence1, start1, end1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5762 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5763 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5764
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5765 if (!NILP (end2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5766 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5767 CHECK_NATNUM (end2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5768 ending2 = XINT (end2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5769
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5770 if (!(starting2 <= ending2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5771 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5772 args_out_of_range_3 (sequence1, start2, end2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5773 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5774 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5775
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5776 sequence1_listp = LISTP (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5777 sequence2_listp = LISTP (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5778
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5779 overwriting = overwriting && starting2 <= starting1;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5780
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5781 if (sequence1_listp && !ZEROP (start1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5782 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5783 sequence1 = Fnthcdr (start1, sequence1);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5784
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5785 if (NILP (sequence1))
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5786 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5787 check_sequence_range (args[0], start1, end1, Flength (args[0]));
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5788 /* Give up early here. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5789 return result;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5790 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5791
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5792 ending1 -= starting1;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5793 starting1 = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5794 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5795
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5796 if (sequence2_listp && !ZEROP (start2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5797 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5798 sequence2 = Fnthcdr (start2, sequence2);
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5799
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5800 if (NILP (sequence2))
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5801 {
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5802 check_sequence_range (args[1], start1, end1, Flength (args[1]));
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5803 /* Nothing available to replace sequence1's contents. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5804 return result;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5805 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5806
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5807 ending2 -= starting2;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5808 starting2 = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5809 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5810
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5811 if (overwriting)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5812 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5813 if (EQ (start1, start2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5814 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5815 return result;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5816 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5817
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5818 /* Our ranges may overlap. Save the data that might be overwritten. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5819
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5820 if (CONSP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5821 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5822 Elemcount len = XINT (Flength (sequence2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5823 Lisp_Object *subsequence
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5824 = alloca_array (Lisp_Object, min (ending2, len));
5272
66dbef5f8076 Be better about bounds-checking, #'subseq, #'fill; add same, #'reduce.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5262
diff changeset
5825 Elemcount ii = 0;
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5826
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5827 LIST_LOOP_2 (elt, sequence2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5828 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5829 if (counting == ending2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5830 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5831 break;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5832 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5833
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5834 subsequence[ii++] = elt;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5835 counting++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5836 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5837
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5838 check_sequence_range (sequence1, start1, end1,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5839 /* The XINT (start2) is intentional here; we
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5840 called #'length after doing (nthcdr
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5841 start2 sequence2). */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5842 make_int (XINT (start2) + len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5843 check_sequence_range (sequence2, start2, end2,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5844 make_int (XINT (start2) + len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5845
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5846 while (starting1 < ending1
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5847 && starting2 < ending2 && !NILP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5848 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5849 XSETCAR (sequence1, subsequence[starting2]);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5850 sequence1 = XCDR (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5851 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5852 starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5853 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5854 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5855 else if (STRINGP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5856 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5857 Ibyte *p = XSTRING_DATA (sequence2),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5858 *pend = p + XSTRING_LENGTH (sequence2), *pcursor,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5859 *staging;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5860 Bytecount ii = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5861
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5862 while (ii < starting2 && p < pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5863 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5864 INC_IBYTEPTR (p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5865 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5866 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5867
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5868 pcursor = p;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5869
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5870 while (ii < ending2 && starting1 < ending1 && pcursor < pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5871 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5872 INC_IBYTEPTR (pcursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5873 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5874 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5875 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5876
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5877 if (pcursor == pend)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5878 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5879 check_sequence_range (sequence1, start1, end1, make_int (ii));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5880 check_sequence_range (sequence2, start2, end2, make_int (ii));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5881 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5882 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5883 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5884 assert ((pcursor - p) > 0);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5885 staging = alloca_ibytes (pcursor - p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5886 memcpy (staging, p, pcursor - p);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5887 replace_string_range (result, start1,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5888 make_int (starting1),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5889 staging, staging + (pcursor - p));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5890 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5891 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5892 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5893 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5894 Elemcount seq_len = XINT (Flength (sequence2)), ii = 0,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5895 subseq_len = min (min (ending1 - starting1, seq_len - starting1),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5896 min (ending2 - starting2, seq_len - starting2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5897 Lisp_Object *subsequence = alloca_array (Lisp_Object, subseq_len);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5898
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5899 check_sequence_range (sequence1, start1, end1, make_int (seq_len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5900 check_sequence_range (sequence2, start2, end2, make_int (seq_len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5901
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5902 while (starting2 < ending2 && ii < seq_len)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5903 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5904 subsequence[ii] = Faref (sequence2, make_int (starting2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5905 ii++, starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5906 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5907
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5908 ii = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5909
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5910 while (starting1 < ending1 && ii < seq_len)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5911 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5912 Faset (sequence1, make_int (starting1), subsequence[ii]);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5913 ii++, starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5914 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5915 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5916 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5917 else if (sequence1_listp && sequence2_listp)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5918 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5919 Lisp_Object sequence1_tortoise = sequence1,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5920 sequence2_tortoise = sequence2;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5921 Elemcount shortest_len = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5922
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5923 counting = startcounting = min (ending1, ending2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5924
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5925 while (counting-- > 0 && !NILP (sequence1) && !NILP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5926 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5927 XSETCAR (sequence1,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5928 CONSP (sequence2) ? XCAR (sequence2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5929 : Fcar (sequence2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5930 sequence1 = CONSP (sequence1) ? XCDR (sequence1)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5931 : Fcdr (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5932 sequence2 = CONSP (sequence2) ? XCDR (sequence2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5933 : Fcdr (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5934
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5935 shortest_len++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5936
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5937 if (startcounting - counting > CIRCULAR_LIST_SUSPICION_LENGTH)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5938 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5939 if (counting & 1)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5940 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5941 sequence1_tortoise = XCDR (sequence1_tortoise);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5942 sequence2_tortoise = XCDR (sequence2_tortoise);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5943 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5944
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5945 if (EQ (sequence1, sequence1_tortoise))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5946 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5947 signal_circular_list_error (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5948 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5949
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5950 if (EQ (sequence2, sequence2_tortoise))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5951 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5952 signal_circular_list_error (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5953 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5954 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5955 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5956
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5957 if (NILP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5958 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5959 check_sequence_range (args[0], start1, end1,
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5960 make_int (XINT (start1) + shortest_len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5961 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5962 else if (NILP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5963 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
5964 check_sequence_range (args[1], start2, end2,
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5965 make_int (XINT (start2) + shortest_len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5966 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5967 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5968 else if (sequence1_listp)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5969 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5970 if (STRINGP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5971 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5972 Ibyte *s2_data = XSTRING_DATA (sequence2),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5973 *s2_end = s2_data + XSTRING_LENGTH (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5974 Elemcount char_count = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5975 Lisp_Object character;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5976
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5977 while (char_count < starting2 && s2_data < s2_end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5978 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5979 INC_IBYTEPTR (s2_data);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5980 char_count++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5981 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5982
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5983 while (starting1 < ending1 && starting2 < ending2
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5984 && s2_data < s2_end && !NILP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5985 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5986 character = make_char (itext_ichar (s2_data));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5987 CONSP (sequence1) ?
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5988 XSETCAR (sequence1, character)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5989 : Fsetcar (sequence1, character);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5990 sequence1 = XCDR (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5991 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5992 starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5993 char_count++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5994 INC_IBYTEPTR (s2_data);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5995 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5996
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5997 if (NILP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5998 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
5999 check_sequence_range (sequence1, start1, end1,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6000 make_int (XINT (start1) + starting1));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6001 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6002
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6003 if (s2_data == s2_end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6004 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6005 check_sequence_range (sequence2, start2, end2,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6006 make_int (char_count));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6007 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6008 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6009 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6010 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6011 Elemcount len2 = XINT (Flength (sequence2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6012 check_sequence_range (sequence2, start2, end2, make_int (len2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6013
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6014 ending2 = min (ending2, len2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6015 while (starting2 < ending2
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6016 && starting1 < ending1 && !NILP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6017 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6018 CHECK_CONS (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6019 XSETCAR (sequence1, Faref (sequence2, make_int (starting2)));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6020 sequence1 = XCDR (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6021 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6022 starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6023 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6024
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6025 if (NILP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6026 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
6027 check_sequence_range (args[0], start1, end1,
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6028 make_int (XINT (start1) + starting1));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6029 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6030 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6031 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6032 else if (sequence2_listp)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6033 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6034 if (STRINGP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6035 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6036 Elemcount ii = 0, count, len = string_char_length (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6037 Ibyte *staging, *cursor;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6038 Lisp_Object obj;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6039
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6040 check_sequence_range (sequence1, start1, end1, make_int (len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6041 ending1 = min (ending1, len);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6042 count = ending1 - starting1;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6043 staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6044
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6045 while (ii < count && !NILP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6046 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6047 obj = CONSP (sequence2) ? XCAR (sequence2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6048 : Fcar (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6049
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6050 CHECK_CHAR_COERCE_INT (obj);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6051 cursor += set_itext_ichar (cursor, XCHAR (obj));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6052 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6053 sequence2 = XCDR (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6054 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6055
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6056 if (NILP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6057 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6058 check_sequence_range (sequence2, start2, end2,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6059 make_int (XINT (start2) + ii));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6060 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6061
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6062 replace_string_range (result, start1, make_int (XINT (start1) + ii),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6063 staging, cursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6064 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6065 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6066 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6067 Elemcount len = XINT (Flength (sequence1));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6068
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6069 check_sequence_range (sequence1, start2, end1, make_int (len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6070 ending1 = min (ending2, min (ending1, len));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6071
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6072 while (starting1 < ending1 && !NILP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6073 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6074 Faset (sequence1, make_int (starting1),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6075 CONSP (sequence2) ? XCAR (sequence2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6076 : Fcar (sequence2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6077 sequence2 = XCDR (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6078 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6079 starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6080 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6081
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6082 if (NILP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6083 {
5303
4c4085177ca5 Fix some bugs in fns.c, discovered in passing while doing other work.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5302
diff changeset
6084 check_sequence_range (args[1], start2, end2,
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6085 make_int (XINT (start2) + starting2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6086 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6087 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6088 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6089 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6090 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6091 if (STRINGP (sequence1) && STRINGP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6092 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6093 Ibyte *p2 = XSTRING_DATA (sequence2),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6094 *p2end = p2 + XSTRING_LENGTH (sequence2), *p2cursor;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6095 Charcount ii = 0, len1 = string_char_length (sequence1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6096
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6097 while (ii < starting2 && p2 < p2end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6098 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6099 INC_IBYTEPTR (p2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6100 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6101 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6102
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6103 p2cursor = p2;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6104 ending1 = min (ending1, len1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6105
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6106 while (ii < ending2 && starting1 < ending1 && p2cursor < p2end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6107 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6108 INC_IBYTEPTR (p2cursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6109 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6110 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6111 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6112
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6113 if (p2cursor == p2end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6114 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6115 check_sequence_range (sequence2, start2, end2, make_int (ii));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6116 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6117
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6118 /* This isn't great; any error message won't necessarily reflect
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6119 the END1 that was supplied to #'replace. */
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6120 replace_string_range (result, start1, make_int (starting1),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6121 p2, p2cursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6122 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6123 else if (STRINGP (sequence1))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6124 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6125 Ibyte *staging, *cursor;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6126 Elemcount count, len1 = string_char_length (sequence1);
5262
75bcb5bef459 Replace a doubled semi-colon with a single semi-colon, fns.c, for VS6's sake.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5261
diff changeset
6127 Elemcount len2 = XINT (Flength (sequence2)), ii = 0;
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6128 Lisp_Object obj;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6129
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6130 check_sequence_range (sequence1, start1, end1, make_int (len1));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6131 check_sequence_range (sequence2, start2, end2, make_int (len2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6132
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6133 ending1 = min (ending1, len1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6134 ending2 = min (ending2, len2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6135 count = min (ending1 - starting1, ending2 - starting2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6136 staging = cursor = alloca_ibytes (count * MAX_ICHAR_LEN);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6137
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6138 ii = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6139 while (ii < count)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6140 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6141 obj = Faref (sequence2, make_int (starting2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6142
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6143 CHECK_CHAR_COERCE_INT (obj);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6144 cursor += set_itext_ichar (cursor, XCHAR (obj));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6145 starting2++, ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6146 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6147
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6148 replace_string_range (result, start1,
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6149 make_int (XINT (start1) + count),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6150 staging, cursor);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6151 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6152 else if (STRINGP (sequence2))
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6153 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6154 Ibyte *p2 = XSTRING_DATA (sequence2),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6155 *p2end = p2 + XSTRING_LENGTH (sequence2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6156 Elemcount len1 = XINT (Flength (sequence1)), ii = 0;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6157
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6158 check_sequence_range (sequence1, start1, end1, make_int (len1));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6159 ending1 = min (ending1, len1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6160
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6161 while (ii < starting2 && p2 < p2end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6162 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6163 INC_IBYTEPTR (p2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6164 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6165 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6166
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6167 while (p2 < p2end && starting1 < ending1 && starting2 < ending2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6168 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6169 Faset (sequence1, make_int (starting1),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6170 make_char (itext_ichar (p2)));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6171 INC_IBYTEPTR (p2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6172 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6173 starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6174 ii++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6175 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6176
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6177 if (p2 == p2end)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6178 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6179 check_sequence_range (sequence2, start2, end2, make_int (ii));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6180 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6181 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6182 else
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6183 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6184 Elemcount len1 = XINT (Flength (sequence1)),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6185 len2 = XINT (Flength (sequence2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6186
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6187 check_sequence_range (sequence1, start1, end1, make_int (len1));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6188 check_sequence_range (sequence2, start2, end2, make_int (len2));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6189
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6190 ending1 = min (ending1, len1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6191 ending2 = min (ending2, len2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6192
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6193 while (starting1 < ending1 && starting2 < ending2)
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6194 {
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6195 Faset (sequence1, make_int (starting1),
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6196 Faref (sequence2, make_int (starting2)));
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6197 starting1++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6198 starting2++;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6199 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6200 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6201 }
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6202
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6203 return result;
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6204 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6205
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6206 Lisp_Object
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
6207 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6208 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6209 return Fintern (concat2 (Fsymbol_name (symbol),
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
6210 build_ascstring (ascii_string)),
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6211 Qnil);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6212 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6213
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6214 Lisp_Object
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
6215 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6216 {
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
6217 return Fintern (concat2 (build_ascstring (ascii_string),
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6218 Fsymbol_name (symbol)),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6219 Qnil);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6220 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6221
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6222
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6223 /* #### this function doesn't belong in this file! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6224
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6225 #ifdef HAVE_GETLOADAVG
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6226 #ifdef HAVE_SYS_LOADAVG_H
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6227 #include <sys/loadavg.h>
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6228 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6229 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6230 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6231 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6232
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6233 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6234 Return list of 1 minute, 5 minute and 15 minute load averages.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6235 Each of the three load averages is multiplied by 100,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6236 then converted to integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6237
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6238 When USE-FLOATS is non-nil, floats will be used instead of integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6239 These floats are not multiplied by 100.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6241 If the 5-minute or 15-minute load averages are not available, return a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6242 shortened list, containing only those averages which are available.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6244 On some systems, this won't work due to permissions on /dev/kmem,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6245 in which case you can't use this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6246 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6247 (use_floats))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6248 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6249 double load_ave[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6250 int loads = getloadavg (load_ave, countof (load_ave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6251 Lisp_Object ret = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6253 if (loads == -2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6254 signal_error (Qunimplemented,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6255 "load-average not implemented for this operating system",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6256 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6257 else if (loads < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6258 invalid_operation ("Could not get load-average", lisp_strerror (errno));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6260 while (loads-- > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6261 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6262 Lisp_Object load = (NILP (use_floats) ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6263 make_int ((int) (100.0 * load_ave[loads]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6264 : make_float (load_ave[loads]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6265 ret = Fcons (load, ret);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6266 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6267 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6268 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6269
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6270
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6271 Lisp_Object Vfeatures;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6273 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6274 Return non-nil if feature FEXP is present in this Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6275 Use this to conditionalize execution of lisp code based on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6276 presence or absence of emacs or environment extensions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6277 FEXP can be a symbol, a number, or a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6278 If it is a symbol, that symbol is looked up in the `features' variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6279 and non-nil will be returned if found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6280 If it is a number, the function will return non-nil if this Emacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6281 has an equal or greater version number than FEXP.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6282 If it is a list whose car is the symbol `and', it will return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6283 non-nil if all the features in its cdr are non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6284 If it is a list whose car is the symbol `or', it will return non-nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6285 if any of the features in its cdr are non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6286 If it is a list whose car is the symbol `not', it will return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6287 non-nil if the feature is not present.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6289 Examples:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6291 (featurep 'xemacs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6292 => ; Non-nil on XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6294 (featurep '(and xemacs gnus))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6295 => ; Non-nil on XEmacs with Gnus loaded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6296
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6297 (featurep '(or tty-frames (and emacs 19.30)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6298 => ; Non-nil if this Emacs supports TTY frames.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6300 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6301 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6302
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6303 (featurep '(and xemacs 21.02))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6304 => ; Non-nil on XEmacs 21.2 and later.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6305
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6306 NOTE: The advanced arguments of this function (anything other than a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6307 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6308 for supporting multiple Emacs variants, lobby Richard Stallman at
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6309 <bug-gnu-emacs@gnu.org>.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6310 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6311 (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6313 #ifndef FEATUREP_SYNTAX
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6314 CHECK_SYMBOL (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6315 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6316 #else /* FEATUREP_SYNTAX */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6317 static double featurep_emacs_version;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6318
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6319 /* Brute force translation from Erik Naggum's lisp function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6320 if (SYMBOLP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6321 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6322 /* Original definition */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6323 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6325 else if (INTP (fexp) || FLOATP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6327 double d = extract_float (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6328
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6329 if (featurep_emacs_version == 0.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6330 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6331 featurep_emacs_version = XINT (Vemacs_major_version) +
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6332 (XINT (Vemacs_minor_version) / 100.0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6333 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6334 return featurep_emacs_version >= d ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6335 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6336 else if (CONSP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6337 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6338 Lisp_Object tem = XCAR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6339 if (EQ (tem, Qnot))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6340 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6341 Lisp_Object negate;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6343 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6344 negate = Fcar (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6345 if (!NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6346 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6347 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6348 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6349 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6350 else if (EQ (tem, Qand))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6351 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6352 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6353 /* Use Fcar/Fcdr for error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6354 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6355 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6356 tem = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6357 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6358 return NILP (tem) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6359 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6360 else if (EQ (tem, Qor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6361 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6362 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6363 /* Use Fcar/Fcdr for error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6364 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6365 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6366 tem = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6367 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6368 return NILP (tem) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6369 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6370 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6371 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6372 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6373 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6374 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6375 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6376 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6377 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6378 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6379 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6380 #endif /* FEATUREP_SYNTAX */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6382 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6383 Announce that FEATURE is a feature of the current Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6384 This function updates the value of the variable `features'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6385 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6386 (feature))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6387 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6388 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6389 CHECK_SYMBOL (feature);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6390 if (!NILP (Vautoload_queue))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6391 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6392 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6393 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6394 Vfeatures = Fcons (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6395 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6396 return feature;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6397 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6398
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
6399 DEFUN ("require", Frequire, 1, 3, 0, /*
3842
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6400 Ensure that FEATURE is present in the Lisp environment.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6401 FEATURE is a symbol naming a collection of resources (functions, etc).
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6402 Optional FILENAME is a library from which to load resources; it defaults to
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6403 the print name of FEATURE.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6404 Optional NOERROR, if non-nil, causes require to return nil rather than signal
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6405 `file-error' if loading the library fails.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6406
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6407 If feature FEATURE is present in `features', update `load-history' to reflect
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6408 the require and return FEATURE. Otherwise, try to load it from a library.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6409 The normal messages at start and end of loading are suppressed.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6410 If the library is successfully loaded and it calls `(provide FEATURE)', add
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6411 FEATURE to `features', update `load-history' and return FEATURE.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6412 If the load succeeds but FEATURE is not provided by the library, signal
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6413 `invalid-state'.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6414
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6415 The byte-compiler treats top-level calls to `require' specially, by evaluating
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6416 them at compile time (and then compiling them normally). Thus a library may
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6417 request that definitions that should be inlined such as macros and defsubsts
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6418 be loaded into its compilation environment. Achieving this in other contexts
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
6419 requires an explicit \(eval-and-compile ...\) block.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6420 */
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
6421 (feature, filename, noerror))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6422 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6423 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6424 CHECK_SYMBOL (feature);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6425 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6426 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6427 if (!NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6428 return feature;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6429 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6430 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6431 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6433 /* Value saved here is to be restored into Vautoload_queue */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6434 record_unwind_protect (un_autoload, Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6435 Vautoload_queue = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6436
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
6437 tem = call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename,
1261
465bd3c7d932 [xemacs-hg @ 2003-02-06 06:35:47 by ben]
ben
parents: 1204
diff changeset
6438 noerror, Qrequire, Qnil);
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
6439 /* If load failed entirely, return nil. */
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
6440 if (NILP (tem))
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
6441 return unbind_to_1 (speccount, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6443 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6444 if (NILP (tem))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6445 invalid_state ("Required feature was not provided", feature);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6446
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6447 /* Once loading finishes, don't undo it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6448 Vautoload_queue = Qt;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6449 return unbind_to_1 (speccount, feature);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6450 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6451 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6452
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6453 /* base64 encode/decode functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6455 Originally based on code from GNU recode. Ported to FSF Emacs by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6456 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6457 subsequently heavily hacked by Hrvoje Niksic. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6458
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6459 #define MIME_LINE_LENGTH 72
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6460
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6461 #define IS_ASCII(Character) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6462 ((Character) < 128)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6463 #define IS_BASE64(Character) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6464 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6466 /* Table of characters coding the 64 values. */
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
6467 static Ascbyte base64_value_to_char[64] =
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6468 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6469 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6470 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6471 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6472 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6473 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6474 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6475 '8', '9', '+', '/' /* 60-63 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6476 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6478 /* Table of base64 values for first 128 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6479 static short base64_char_to_value[128] =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6480 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6481 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6482 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6483 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6484 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6485 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6486 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6487 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6488 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6489 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6490 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6491 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6492 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6493 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6494 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6495
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6496 /* The following diagram shows the logical steps by which three octets
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6497 get transformed into four base64 characters.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6498
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6499 .--------. .--------. .--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6500 |aaaaaabb| |bbbbcccc| |ccdddddd|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6501 `--------' `--------' `--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6502 6 2 4 4 2 6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6503 .--------+--------+--------+--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6504 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6505 `--------+--------+--------+--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6507 .--------+--------+--------+--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6508 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6509 `--------+--------+--------+--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6510
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6511 The octets are divided into 6 bit chunks, which are then encoded into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6512 base64 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6513
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
6514 static DECLARE_DOESNT_RETURN (base64_conversion_error (const Ascbyte *,
2268
61855263cb07 [xemacs-hg @ 2004-09-14 14:32:29 by james]
james
parents: 2039
diff changeset
6515 Lisp_Object));
61855263cb07 [xemacs-hg @ 2004-09-14 14:32:29 by james]
james
parents: 2039
diff changeset
6516
575
d5e8f5ad5043 [xemacs-hg @ 2001-05-25 04:22:31 by martinb]
martinb
parents: 563
diff changeset
6517 static DOESNT_RETURN
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
6518 base64_conversion_error (const Ascbyte *reason, Lisp_Object frob)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6519 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6520 signal_error (Qbase64_conversion_error, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6521 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6522
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6523 #define ADVANCE_INPUT(c, stream) \
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6524 ((ec = Lstream_get_ichar (stream)) == -1 ? 0 : \
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6525 ((ec > 255) ? \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6526 (base64_conversion_error ("Non-ascii character in base64 input", \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6527 make_char (ec)), 0) \
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6528 : (c = (Ibyte)ec), 1))
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6529
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6530 static Bytebpos
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6531 base64_encode_1 (Lstream *istream, Ibyte *to, int line_break)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6532 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6533 EMACS_INT counter = 0;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6534 Ibyte *e = to;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6535 Ichar ec;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6536 unsigned int value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6537
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6538 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6539 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1067
diff changeset
6540 Ibyte c = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6541 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6542 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6543
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6544 /* Wrap line every 76 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6545 if (line_break)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6546 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6547 if (counter < MIME_LINE_LENGTH / 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6548 counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6549 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6550 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6551 *e++ = '\n';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6552 counter = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6553 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6554 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6555
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6556 /* Process first byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6557 *e++ = base64_value_to_char[0x3f & c >> 2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6558 value = (0x03 & c) << 4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6559
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6560 /* Process second byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6561 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6562 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6563 *e++ = base64_value_to_char[value];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6564 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6565 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6566 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6567 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6568
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6569 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6570 value = (0x0f & c) << 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6572 /* Process third byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6573 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6574 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6575 *e++ = base64_value_to_char[value];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6576 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6577 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6578 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6579
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6580 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6581 *e++ = base64_value_to_char[0x3f & c];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6582 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6583
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6584 return e - to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6585 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6586 #undef ADVANCE_INPUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6587
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6588 /* Get next character from the stream, except that non-base64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6589 characters are ignored. This is in accordance with rfc2045. EC
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6590 should be an Ichar, so that it can hold -1 as the value for EOF. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6591 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6592 ec = Lstream_get_ichar (stream); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6593 ++streampos; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6594 /* IS_BASE64 may not be called with negative arguments so check for \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6595 EOF first. */ \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6596 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6597 break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6598 } while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6599
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6600 #define STORE_BYTE(pos, val, ccnt) do { \
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
6601 pos += set_itext_ichar (pos, (Ichar)((Binbyte)(val))); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6602 ++ccnt; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6603 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6604
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6605 static Bytebpos
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6606 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6607 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6608 Charcount ccnt = 0;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6609 Ibyte *e = to;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6610 EMACS_INT streampos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6611
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6612 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6613 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6614 Ichar ec;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6615 unsigned long value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6616
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6617 /* Process first byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6618 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6619 if (ec < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6620 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6621 if (ec == '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6622 base64_conversion_error ("Illegal `=' character while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6623 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6624 value = base64_char_to_value[ec] << 18;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6626 /* Process second byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6627 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6628 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6629 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6630 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6631 if (ec == '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6632 base64_conversion_error ("Illegal `=' character while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6633 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6634 value |= base64_char_to_value[ec] << 12;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6635 STORE_BYTE (e, value >> 16, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6637 /* Process third byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6638 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6639 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6640 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6641 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6642
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6643 if (ec == '=')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6644 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6645 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6646 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6647 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6648 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6649 if (ec != '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6650 base64_conversion_error
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6651 ("Padding `=' expected but not found while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6652 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6653 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6654 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6655
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6656 value |= base64_char_to_value[ec] << 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6657 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6658
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6659 /* Process fourth byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6660 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6661 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6662 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6663 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6664 if (ec == '=')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6665 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6666
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6667 value |= base64_char_to_value[ec];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6668 STORE_BYTE (e, 0xff & value, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6669 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6670
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6671 *ccptr = ccnt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6672 return e - to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6673 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6674 #undef ADVANCE_INPUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6675 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6676 #undef STORE_BYTE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6677
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6678 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6679 Base64-encode the region between START and END.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6680 Return the length of the encoded text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6681 Optional third argument NO-LINE-BREAK means do not break long lines
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6682 into shorter lines.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6683 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6684 (start, end, no_line_break))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6685 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6686 Ibyte *encoded;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6687 Bytebpos encoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6688 Charcount allength, length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6689 struct buffer *buf = current_buffer;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6690 Charbpos begv, zv, old_pt = BUF_PT (buf);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6691 Lisp_Object input;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6692 int speccount = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6693
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6694 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6695 barf_if_buffer_read_only (buf, begv, zv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6696
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6697 /* We need to allocate enough room for encoding the text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6698 We need 33 1/3% more space, plus a newline every 76
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6699 characters, and then we round up. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6700 length = zv - begv;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6701 allength = length + length/3 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6702 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6703
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6704 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6705 /* We needn't multiply allength with MAX_ICHAR_LEN because all the
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6706 base64 characters will be single-byte. */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6707 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6708 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6709 NILP (no_line_break));
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
6710 assert (encoded_length <= allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6711 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6713 /* Now we have encoded the region, so we insert the new contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6714 and delete the old. (Insert first in order to preserve markers.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6715 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6716 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6717 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6718
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6719 /* Simulate FSF Emacs implementation of this function: if point was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6720 in the region, place it at the beginning. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6721 if (old_pt >= begv && old_pt < zv)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6722 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6723
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6724 /* We return the length of the encoded text. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6725 return make_int (encoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6726 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6727
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6728 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6729 Base64 encode STRING and return the result.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6730 Optional argument NO-LINE-BREAK means do not break long lines
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6731 into shorter lines.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6732 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6733 (string, no_line_break))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6734 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6735 Charcount allength, length;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6736 Bytebpos encoded_length;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6737 Ibyte *encoded;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6738 Lisp_Object input, result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6739 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6740
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6741 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6742
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
6743 length = string_char_length (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6744 allength = length + length/3 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6745 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6746
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6747 input = make_lisp_string_input_stream (string, 0, -1);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6748 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6749 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6750 NILP (no_line_break));
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
6751 assert (encoded_length <= allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6752 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6753 result = make_string (encoded, encoded_length);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6754 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6755 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6756 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6757
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6758 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6759 Base64-decode the region between START and END.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6760 Return the length of the decoded text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6761 If the region can't be decoded, return nil and don't modify the buffer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6762 Characters out of the base64 alphabet are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6763 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6764 (start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6765 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6766 struct buffer *buf = current_buffer;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6767 Charbpos begv, zv, old_pt = BUF_PT (buf);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6768 Ibyte *decoded;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6769 Bytebpos decoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6770 Charcount length, cc_decoded_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6771 Lisp_Object input;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6772 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6773
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
6774 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6775 barf_if_buffer_read_only (buf, begv, zv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6777 length = zv - begv;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6778
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6779 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6780 /* We need to allocate enough room for decoding the text. */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6781 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6782 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
6783 assert (decoded_length <= length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6784 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6786 /* Now we have decoded the region, so we insert the new contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6787 and delete the old. (Insert first in order to preserve markers.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6788 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6789 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6790 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6791 buffer_delete_range (buf, begv + cc_decoded_length,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6792 zv + cc_decoded_length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6793
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6794 /* Simulate FSF Emacs implementation of this function: if point was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6795 in the region, place it at the beginning. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6796 if (old_pt >= begv && old_pt < zv)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6797 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6798
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6799 return make_int (cc_decoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6800 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6801
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6802 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6803 Base64-decode STRING and return the result.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6804 Characters out of the base64 alphabet are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6805 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6806 (string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6807 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6808 Ibyte *decoded;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
6809 Bytebpos decoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6810 Charcount length, cc_decoded_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6811 Lisp_Object input, result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6812 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6814 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6815
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
6816 length = string_char_length (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6817 /* We need to allocate enough room for decoding the text. */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6818 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6819
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6820 input = make_lisp_string_input_stream (string, 0, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6821 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6822 &cc_decoded_length);
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
6823 assert (decoded_length <= length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6824 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6825
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6826 result = make_string (decoded, decoded_length);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
6827 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6828 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6829 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6830
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6831 Lisp_Object Qyes_or_no_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6832
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6833 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6834 syms_of_fns (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6835 {
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3025
diff changeset
6836 INIT_LISP_OBJECT (bit_vector);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6837
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6838 DEFSYMBOL (Qstring_lessp);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6839 DEFSYMBOL (Qsort);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6840 DEFSYMBOL (Qmerge);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6841 DEFSYMBOL (Qfill);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6842 DEFSYMBOL (Qidentity);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6843 DEFSYMBOL (Qvector);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6844 DEFSYMBOL (Qarray);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6845 DEFSYMBOL (Qstring);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6846 DEFSYMBOL (Qlist);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6847 DEFSYMBOL (Qbit_vector);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6848 defsymbol (&QsortX, "sort*");
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
6849 DEFSYMBOL (Qreduce);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6850 DEFSYMBOL (Qreplace);
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
6851
5253
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6852 DEFSYMBOL (Qmapconcat);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6853 defsymbol (&QmapcarX, "mapcar*");
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6854 DEFSYMBOL (Qmapvector);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6855 DEFSYMBOL (Qmapcan);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6856 DEFSYMBOL (Qmapc);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6857 DEFSYMBOL (Qmap);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6858 DEFSYMBOL (Qmap_into);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6859 DEFSYMBOL (Qsome);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6860 DEFSYMBOL (Qevery);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6861 DEFSYMBOL (Qmaplist);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6862 DEFSYMBOL (Qmapl);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6863 DEFSYMBOL (Qmapcon);
b6a398dbb403 Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents: 5241
diff changeset
6864
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
6865 DEFKEYWORD (Q_from_end);
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
6866 DEFKEYWORD (Q_initial_value);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6867 DEFKEYWORD (Q_start1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6868 DEFKEYWORD (Q_start2);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6869 DEFKEYWORD (Q_end1);
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6870 DEFKEYWORD (Q_end2);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6871
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6872 DEFSYMBOL (Qyes_or_no_p);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6873
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
6874 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6875
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6876 DEFSUBR (Fidentity);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6877 DEFSUBR (Frandom);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6878 DEFSUBR (Flength);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6879 DEFSUBR (Fsafe_length);
5273
799742b751c8 Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5272
diff changeset
6880 DEFSUBR (Flist_length);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6881 DEFSUBR (Fstring_equal);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
6882 DEFSUBR (Fcompare_strings);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6883 DEFSUBR (Fstring_lessp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6884 DEFSUBR (Fstring_modified_tick);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6885 DEFSUBR (Fappend);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6886 DEFSUBR (Fconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6887 DEFSUBR (Fvconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6888 DEFSUBR (Fbvconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6889 DEFSUBR (Fcopy_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6890 DEFSUBR (Fcopy_sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6891 DEFSUBR (Fcopy_alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6892 DEFSUBR (Fcopy_tree);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6893 DEFSUBR (Fsubseq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6894 DEFSUBR (Fnthcdr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6895 DEFSUBR (Fnth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6896 DEFSUBR (Felt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6897 DEFSUBR (Flast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6898 DEFSUBR (Fbutlast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6899 DEFSUBR (Fnbutlast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6900 DEFSUBR (Fmember);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6901 DEFSUBR (Fold_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6902 DEFSUBR (Fmemq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6903 DEFSUBR (Fold_memq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6904 DEFSUBR (Fassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6905 DEFSUBR (Fold_assoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6906 DEFSUBR (Fassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6907 DEFSUBR (Fold_assq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6908 DEFSUBR (Frassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6909 DEFSUBR (Fold_rassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6910 DEFSUBR (Frassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6911 DEFSUBR (Fold_rassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6912 DEFSUBR (Fdelete);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6913 DEFSUBR (Fold_delete);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6914 DEFSUBR (Fdelq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6915 DEFSUBR (Fold_delq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6916 DEFSUBR (Fremassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6917 DEFSUBR (Fremassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6918 DEFSUBR (Fremrassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6919 DEFSUBR (Fremrassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6920 DEFSUBR (Fnreverse);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6921 DEFSUBR (Freverse);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6922 DEFSUBR (FsortX);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6923 Ffset (intern ("sort"), QsortX);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6924 DEFSUBR (Fmerge);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6925 DEFSUBR (Fplists_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6926 DEFSUBR (Fplists_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6927 DEFSUBR (Flax_plists_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6928 DEFSUBR (Flax_plists_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6929 DEFSUBR (Fplist_get);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6930 DEFSUBR (Fplist_put);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6931 DEFSUBR (Fplist_remprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6932 DEFSUBR (Fplist_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6933 DEFSUBR (Fcheck_valid_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6934 DEFSUBR (Fvalid_plist_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6935 DEFSUBR (Fcanonicalize_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6936 DEFSUBR (Flax_plist_get);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6937 DEFSUBR (Flax_plist_put);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6938 DEFSUBR (Flax_plist_remprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6939 DEFSUBR (Flax_plist_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6940 DEFSUBR (Fcanonicalize_lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6941 DEFSUBR (Fdestructive_alist_to_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6942 DEFSUBR (Fget);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6943 DEFSUBR (Fput);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6944 DEFSUBR (Fremprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6945 DEFSUBR (Fobject_plist);
5255
b5611afbcc76 Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5253
diff changeset
6946 DEFSUBR (Fobject_setplist);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6947 DEFSUBR (Fequal);
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
6948 DEFSUBR (Fequalp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6949 DEFSUBR (Fold_equal);
5182
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6950 DEFSUBR (Ffill);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6951 Ffset (intern ("fillarray"), Qfill);
2e528066e2fc Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5128
diff changeset
6952
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6953 DEFSUBR (Fnconc);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6954 DEFSUBR (FmapcarX);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6955 DEFSUBR (Fmapvector);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6956 DEFSUBR (Fmapcan);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6957 DEFSUBR (Fmapc);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6958 DEFSUBR (Fmapconcat);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6959 DEFSUBR (Fmap);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6960 DEFSUBR (Fmap_into);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
6961 DEFSUBR (Fsome);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
6962 DEFSUBR (Fevery);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6963 Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc")));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6964 Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*")));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6965 DEFSUBR (Fmaplist);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6966 DEFSUBR (Fmapl);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6967 DEFSUBR (Fmapcon);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
6968
5227
fbd1485af104 Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5224
diff changeset
6969 DEFSUBR (Freduce);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
6970 DEFSUBR (Freplace_list);
5261
69f687b3ba9d Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5255
diff changeset
6971 DEFSUBR (Freplace);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6972 DEFSUBR (Fload_average);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6973 DEFSUBR (Ffeaturep);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6974 DEFSUBR (Frequire);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6975 DEFSUBR (Fprovide);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6976 DEFSUBR (Fbase64_encode_region);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6977 DEFSUBR (Fbase64_encode_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6978 DEFSUBR (Fbase64_decode_region);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6979 DEFSUBR (Fbase64_decode_string);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6980
5224
35c2b7e9c03f Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5191
diff changeset
6981 DEFSUBR (Fsubstring_no_properties);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6982 DEFSUBR (Fsplit_string_by_char);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6983 DEFSUBR (Fsplit_path); /* #### */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6984 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6985
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6986 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6987 vars_of_fns (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6988 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6989 DEFVAR_LISP ("path-separator", &Vpath_separator /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6990 The directory separator in search paths, as a string.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6991 */ );
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6992 {
5000
44d7bde26046 fix compile errors, fix revert-buffer bug on binary/Latin 1 files, Mule-ize some files
Ben Wing <ben@xemacs.org>
parents: 4966
diff changeset
6993 Ascbyte c = SEPCHAR;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
6994 Vpath_separator = make_string ((Ibyte *) &c, 1);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
6995 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6996 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6997
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6998 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6999 init_provide_once (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7000 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7001 DEFVAR_LISP ("features", &Vfeatures /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7002 A list of symbols which are the features of the executing emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7003 Used by `featurep' and `require', and altered by `provide'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7004 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7005 Vfeatures = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7006
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7007 Fprovide (intern ("base64"));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7008 }