annotate src/fns.c @ 5167:e374ea766cc1

clean up, rearrange allocation statistics code -------------------- ChangeLog entries follow: -------------------- src/ChangeLog addition: 2010-03-21 Ben Wing <ben@xemacs.org> * alloc.c: * alloc.c (assert_proper_sizing): * alloc.c (c_readonly): * alloc.c (malloced_storage_size): * alloc.c (fixed_type_block_overhead): * alloc.c (lisp_object_storage_size): * alloc.c (inc_lrecord_stats): * alloc.c (dec_lrecord_stats): * alloc.c (pluralize_word): * alloc.c (object_memory_usage_stats): * alloc.c (Fobject_memory_usage): * alloc.c (compute_memusage_stats_length): * alloc.c (disksave_object_finalization_1): * alloc.c (Fgarbage_collect): * mc-alloc.c: * mc-alloc.c (mc_alloced_storage_size): * mc-alloc.h: No functionality change here. Collect the allocations-statistics code that was scattered throughout alloc.c into one place. Add remaining section headings so that all sections have headings clearly identifying the start of the section and its purpose. Expose mc_alloced_storage_size() even when not MEMORY_USAGE_STATS; this fixes build problems and is related to the export of lisp_object_storage_size() and malloced_storage_size() when non-MEMORY_USAGE_STATS in the previous change set.
author Ben Wing <ben@xemacs.org>
date Sun, 21 Mar 2010 04:41:49 -0500
parents 7be849cb8828
children 2e528066e2fc
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 Lisp_Object Qstring_lessp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 Lisp_Object Qidentity;
5002
0cd784a6ec44 fix some compile bugs of Aidan's
Ben Wing <ben@xemacs.org>
parents: 5001
diff changeset
59 Lisp_Object Qvector, Qarray, Qbit_vector;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
61 Lisp_Object Qbase64_conversion_error;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
62
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
63 Lisp_Object Vpath_separator;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
64
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
66 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
67
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 static Lisp_Object
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2268
diff changeset
69 mark_bit_vector (Lisp_Object UNUSED (obj))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 static void
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2268
diff changeset
75 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
76 int UNUSED (escapeflag))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
78 Elemcount i;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
79 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
80 Elemcount len = bit_vector_length (v);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
81 Elemcount last = len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 if (INTP (Vprint_length))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
84 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
85 write_ascstring (printcharfun, "#*");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 for (i = 0; i < last; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
88 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
89 write_ascstring (printcharfun, "1");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 else
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
91 write_ascstring (printcharfun, "0");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 }
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 if (last != len)
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
95 write_ascstring (printcharfun, "...");
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 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
99 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
100 int UNUSED (foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
102 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
103 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 !memcmp (v1->bits, v2->bits,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 sizeof (long)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
111 static Hashcode
2286
04bc9d2f42c7 [xemacs-hg @ 2004-09-20 19:18:55 by james]
james
parents: 2268
diff changeset
112 bit_vector_hash (Lisp_Object obj, int UNUSED (depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
114 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 return HASH2 (bit_vector_length (v),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 memory_hash (v->bits,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 sizeof (long)));
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
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
121 static Bytecount
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
122 size_bit_vector (Lisp_Object obj)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
123 {
5127
a9c41067dd88 more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents: 5126
diff changeset
124 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
125 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
126 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
127 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
128
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1067
diff changeset
129 static const struct memory_description bit_vector_description[] = {
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 };
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
5118
e0db3c197671 merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
parents: 5117 4693
diff changeset
134 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
135 mark_bit_vector,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
136 print_bit_vector, 0,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
137 bit_vector_equal,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
138 bit_vector_hash,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
139 bit_vector_description,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
140 size_bit_vector,
623d57b7fbe8 separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents: 5118
diff changeset
141 Lisp_Bit_Vector);
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 872
diff changeset
142
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 DEFUN ("identity", Fidentity, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 Return the argument unchanged.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 return arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 DEFUN ("random", Frandom, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 Return a pseudo-random number.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
154 All fixnums are equally likely. On most systems, this is 31 bits' worth.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 With positive integer argument N, return random number in interval [0,N).
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
156 N can be a bignum, in which case the range of possible values is extended.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 With argument t, set the random number seed from the current time and pid.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 (limit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 EMACS_INT val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 unsigned long denominator;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 if (EQ (limit, Qt))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
165 seed_random (qxe_getpid () + time (NULL));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 if (NATNUMP (limit) && !ZEROP (limit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 /* Try to take our random number from the higher bits of VAL,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 not the lower, since (says Gentzel) the low bits of `random'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 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
171 quotient rather than the remainder. At the high end of the RNG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 it's possible to get a quotient larger than limit; discarding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 these values eliminates the bias that would otherwise appear
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 when using a large limit. */
2039
fd0cbe945410 [xemacs-hg @ 2004-04-22 03:24:00 by james]
james
parents: 1983
diff changeset
175 denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 val = get_random () / denominator;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 while (val >= XINT (limit));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
180 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
181 else if (BIGNUMP (limit))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
182 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
183 bignum_random (scratch_bignum, XBIGNUM_DATA (limit));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
184 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
185 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
186 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 val = get_random ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 return make_int (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 /* Random data-structure functions */
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 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 /* #### Delete this shit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 /* Charcount is a misnomer here as we might be dealing with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 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
201 with Bytecounts in strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 static Charcount
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 length_with_bytecode_hack (Lisp_Object seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 if (!COMPILED_FUNCTIONP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 return XINT (Flength (seq));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
209 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
428
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 (f->flags.interactivep ? COMPILED_INTERACTIVE :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 f->flags.domainp ? COMPILED_DOMAIN :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 COMPILED_DOC_STRING)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 #endif /* LOSING_BYTECODE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 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
221 check_losing_bytecode (const Ascbyte *function, Lisp_Object seq)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 if (COMPILED_FUNCTIONP (seq))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
224 signal_ferror_with_frob
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
225 (Qinvalid_argument, seq,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 "As of 20.3, `%s' no longer works with compiled-function objects",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 DEFUN ("length", Flength, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 Return the length of vector, bit vector, list or string SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 if (STRINGP (sequence))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
237 return make_int (string_char_length (sequence));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 else if (CONSP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
240 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 GET_EXTERNAL_LIST_LENGTH (sequence, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 return make_int (len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 else if (VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 return make_int (XVECTOR_LENGTH (sequence));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 else if (NILP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 return Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 else if (BIT_VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
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 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 check_losing_bytecode ("length", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 goto retry;
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 }
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 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 Return the length of a list, but avoid error or infinite loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 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
261 it returns 0. If LIST is circular, it returns a finite value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 which is at least the number of distinct elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 Lisp_Object hare, tortoise;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
267 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 for (hare = tortoise = list, len = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 hare = XCDR (hare), len++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 if (len & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 return make_int (len);
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 /*** string functions. ***/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 Return t if two strings have identical contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 Case is significant. Text properties are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 \(Under XEmacs, `equal' also ignores text properties and extents in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 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
287 `equal' is the same as in XEmacs, in that respect.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288 Symbols are also allowed; their print names are used instead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
290 (string1, string2))
428
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 Bytecount len;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
293 Lisp_Object p1, p2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
295 if (SYMBOLP (string1))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
296 p1 = XSYMBOL (string1)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
299 CHECK_STRING (string1);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
300 p1 = string1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
303 if (SYMBOLP (string2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
304 p2 = XSYMBOL (string2)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
307 CHECK_STRING (string2);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
308 p2 = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
311 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) &&
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
312 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
315 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
316 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
317 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
318 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
319 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
320 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
321 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
322
c45fdd4e1858 Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents: 4693
diff changeset
323 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
324 Case is significant by default.
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
325
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
326 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
327 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
328 - 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
329 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
330 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
331 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
332 (str1, start1, end1, str2, start2, end2, ignore_case))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
333 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
334 Charcount ccstart1, ccend1, ccstart2, ccend2;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
335 Bytecount bstart1, blen1, bstart2, blen2;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
336 Charcount matching;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
337 int res;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
338
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
339 CHECK_STRING (str1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
340 CHECK_STRING (str2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
341 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
342 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
343 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
344 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
345
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
346 bstart1 = string_index_char_to_byte (str1, ccstart1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
347 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
348 bstart2 = string_index_char_to_byte (str2, ccstart2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
349 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
350
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
351 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
352 (XSTRING_DATA (str1) + bstart1, blen1,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
353 XSTRING_DATA (str2) + bstart2, blen2,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
354 &matching));
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
355
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
356 if (!res)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
357 return Qt;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
358 else if (res > 0)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
359 return make_int (1 + matching);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
360 else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
361 return make_int (-1 - matching);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
362 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
363
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 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
366 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
367 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
368 particularly meaningful results under Mule if characters from
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
369 different charsets are being compared.)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
370
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 Symbols are also allowed; their print names are used instead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
373 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
374 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
375 is implemented.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
377 (string1, string2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
379 Lisp_Object p1, p2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 Charcount end, len2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
383 if (SYMBOLP (string1))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
384 p1 = XSYMBOL (string1)->name;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
385 else
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
386 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
387 CHECK_STRING (string1);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
388 p1 = string1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 }
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 if (SYMBOLP (string2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
392 p2 = XSYMBOL (string2)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 else
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 CHECK_STRING (string2);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
396 p2 = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
399 end = string_char_length (p1);
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
400 len2 = string_char_length (p2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 if (end > len2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 end = len2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
405 Ibyte *ptr1 = XSTRING_DATA (p1);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
406 Ibyte *ptr2 = XSTRING_DATA (p2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 /* #### It is not really necessary to do this: We could compare
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 byte-by-byte and still get a reasonable comparison, since this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 would compare characters with a charset in the same way. With
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 a little rearrangement of the leading bytes, we could make most
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 inter-charset comparisons work out the same, too; even if some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 don't, this is not a big deal because inter-charset comparisons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 aren't really well-defined anyway. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 for (i = 0; i < end; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
417 if (itext_ichar (ptr1) != itext_ichar (ptr2))
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
418 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
419 INC_IBYTEPTR (ptr1);
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
420 INC_IBYTEPTR (ptr2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 won't work right in I18N2 case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 return end < len2 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 Return STRING's tick counter, incremented for each change to the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 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
431 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
432 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 (string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 CHECK_STRING (string);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
436 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
437 return XCAR (XSTRING_PLIST (string));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 return Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 bump_string_modiff (Lisp_Object str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
445 Lisp_Object *ptr = &XSTRING_PLIST (str);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 /* #### remove the `string-translatable' property from the string,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 if there is one. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 /* skip over extent info if it's there */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 ptr = &XCDR (*ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
455 XCAR (*ptr) = make_int (1+XINT (XCAR (*ptr)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 *ptr = Fcons (make_int (1), *ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 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
462 static Lisp_Object concat (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 enum concat_target_type target_type,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
464 int last_special);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
466 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
467 concat2 (Lisp_Object string1, Lisp_Object string2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469 Lisp_Object args[2];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
470 args[0] = string1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
471 args[1] = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 return concat (2, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
476 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 Lisp_Object args[3];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
479 args[0] = string1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
480 args[1] = string2;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
481 args[2] = string3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 return concat (3, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
486 vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 Lisp_Object args[2];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
489 args[0] = vec1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
490 args[1] = vec2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 return concat (2, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
495 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 Lisp_Object args[3];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
498 args[0] = vec1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
499 args[1] = vec2;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
500 args[2] = vec3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 return concat (3, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 DEFUN ("append", Fappend, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505 Concatenate all the arguments and make the result a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 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
507 Each argument may be a list, vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 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
509 Also see: `nconc'.
4693
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
510
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
511 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 (int nargs, Lisp_Object *args))
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 return concat (nargs, args, c_cons, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 Concatenate all the arguments and make the result a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 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
521 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
522
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 As of XEmacs 21.0, this function does NOT accept individual integers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 as arguments. Old code that relies on, for example, (concat "foo" 50)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525 returning "foo50" will fail. To fix such code, either apply
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 `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
527
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
528 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 return concat (nargs, args, c_string, 0);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 Concatenate all the arguments and make the result a vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 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
538 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
539
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
540 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 return concat (nargs, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 Concatenate all the arguments and make the result a bit vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 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
550 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
551
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
552 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 return concat (nargs, args, c_bit_vector, 0);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 /* Copy a (possibly dotted) list. LIST must be a cons.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 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
561 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 copy_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 Lisp_Object last = list_copy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 Lisp_Object hare, tortoise;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
567 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 for (tortoise = hare = XCDR (list), len = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 CONSP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 hare = XCDR (hare), len++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574 last = XCDR (last);
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 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 if (len & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 if (EQ (tortoise, hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 signal_circular_list_error (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 return list_copy;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 Return a copy of list LIST, which may be a dotted list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 The elements of LIST are not copied; they are shared
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 with the original.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 again:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 if (NILP (list)) return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 if (CONSP (list)) return copy_list (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 list = wrong_type_argument (Qlistp, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 goto again;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 Return a copy of list, vector, bit vector or string SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 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
605 with the original. SEQUENCE may be a dotted list.
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 (sequence))
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 again:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 if (NILP (sequence)) return sequence;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 if (CONSP (sequence)) return copy_list (sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 check_losing_bytecode ("copy-sequence", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618 goto again;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 struct merge_string_extents_struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 Lisp_Object string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 Bytecount entry_offset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 Bytecount entry_length;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 concat (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 enum concat_target_type target_type,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 int last_special)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 Lisp_Object tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 int toindex;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 int argnum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 Lisp_Object last_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 Lisp_Object prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 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
640 Ibyte *string_result = 0;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
641 Ibyte *string_result_ptr = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 struct gcpro gcpro1;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
643 int sdep = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 /* The modus operandi in Emacs is "caller gc-protects args".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 However, concat is called many times in Emacs on freshly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 created stuff. So we help those callers out by protecting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 the args ourselves to save them a lot of temporary-variable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 grief. */
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 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 gcpro1.nvars = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 /* #### 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
656 for the `string-translatable' property, then concat should also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 concat the args but use the `string-translatable' strings, and store
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 the result in the returned string's `string-translatable' property. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 if (target_type == c_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 /* In append, the last arg isn't treated like the others */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 if (last_special && nargs > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 nargs--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 last_tail = args[nargs];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 last_tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 /* Check and coerce the arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 for (argnum = 0; argnum < nargs; argnum++)
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 Lisp_Object seq = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 if (LISTP (seq))
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 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 else if (COMPILED_FUNCTIONP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682 /* Urk! We allow this, for "compatibility"... */
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 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 #if 0 /* removed for XEmacs 21 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 else if (INTP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 /* This is too revolting to think about but maintains
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 compatibility with FSF (and lots and lots of old code). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 args[argnum] = Fnumber_to_string (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 else
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 check_losing_bytecode ("concat", seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 args[argnum] = wrong_type_argument (Qsequencep, seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 if (args_mse)
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 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 args_mse[argnum].string = seq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 args_mse[argnum].string = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
706 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707 /* Charcount is a misnomer here as we might be dealing with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 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
709 with Bytecounts in strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 Charcount total_length;
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 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 Charcount thislen = length_with_bytecode_hack (args[argnum]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 Charcount thislen = XINT (Flength (args[argnum]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 total_length += thislen;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 switch (target_type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 case c_cons:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 if (total_length == 0)
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
726 {
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
727 unbind_to (sdep);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
728 /* 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
729 RETURN_UNGCPRO (last_tail);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
730 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 val = Fmake_list (make_int (total_length), Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 case c_vector:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 val = make_vector (total_length, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736 case c_bit_vector:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 val = make_bit_vector (total_length, Qzero);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 case c_string:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 /* 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
741 actual number of bytes. This loop was formerly written
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 to call Fmake_string() here and then call set_string_char()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 for each char. This seems logical enough but is waaaaaaaay
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 slow -- set_string_char() has to scan the whole string up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 to the place where the substitution is called for in order
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 to find the place to change, and may have to do some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 realloc()ing in order to make the char fit properly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 O(N^2) yuckage. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 val = Qnil;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
750 string_result =
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
751 (Ibyte *) MALLOC_OR_ALLOCA (total_length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 string_result_ptr = string_result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 default:
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
755 val = Qnil;
2500
3d8143fc88e1 [xemacs-hg @ 2005-01-24 23:33:30 by ben]
ben
parents: 2367
diff changeset
756 ABORT ();
428
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759
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 if (CONSP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 tail = val, toindex = -1; /* -1 in toindex is flag we are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 making a list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 toindex = 0;
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 prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 Charcount thisleni = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 Charcount thisindex = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 Lisp_Object seq = args[argnum];
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
774 Ibyte *string_source_ptr = 0;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
775 Ibyte *string_prev_result_ptr = string_result_ptr;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 if (!CONSP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 thisleni = length_with_bytecode_hack (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 thisleni = XINT (Flength (seq));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 #endif
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 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 string_source_ptr = XSTRING_DATA (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 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 Lisp_Object elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 /* We've come to the end of this arg, so exit. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 if (NILP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 break;
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 /* Fetch next element of `seq' arg into `elt' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 if (CONSP (seq))
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 elt = XCAR (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 seq = XCDR (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 else
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 if (thisindex >= thisleni)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
809 elt = make_char (itext_ichar (string_source_ptr));
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
810 INC_IBYTEPTR (string_source_ptr);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 else if (VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 elt = XVECTOR_DATA (seq)[thisindex];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 else if (BIT_VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 thisindex));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 elt = Felt (seq, make_int (thisindex));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 thisindex++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 /* Store into result */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 if (toindex < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 /* toindex negative means we are making a list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 XCAR (tail) = elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 else if (VECTORP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 XVECTOR_DATA (val)[toindex++] = elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 else if (BIT_VECTORP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 CHECK_BIT (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 CHECK_CHAR_COERCE_INT (elt);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
840 string_result_ptr += set_itext_ichar (string_result_ptr,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 XCHAR (elt));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 if (args_mse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 args_mse[argnum].entry_offset =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 string_prev_result_ptr - string_result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 args_mse[argnum].entry_length =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849 string_result_ptr - string_prev_result_ptr;
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 /* Now we finally make the string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 if (target_type == c_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 val = make_string (string_result, string_result_ptr - string_result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 for (argnum = 0; argnum < nargs; argnum++)
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 if (STRINGP (args_mse[argnum].string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 copy_string_extents (val, args_mse[argnum].string,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 args_mse[argnum].entry_offset, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 args_mse[argnum].entry_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 if (!NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 XCDR (prev) = last_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
869 unbind_to (sdep);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 Return a copy of ALIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 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
876 but does not share the alist structure with ALIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 The objects mapped (cars and cdrs of elements of the alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 are shared, however.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 Elements of ALIST that are not conses are also shared.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 if (NILP (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 return alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 CHECK_CONS (alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 alist = concat (1, &alist, c_cons, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 for (tail = alist; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 Lisp_Object car = XCAR (tail);
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 if (CONSP (car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 return alist;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 Return a copy of a list and substructures.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 The argument is copied, and any lists contained within it are copied
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 recursively. Circularities and shared substructures are not preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
904 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
905 are not copied.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
906 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 (arg, vecp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 {
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
909 return safe_copy_tree (arg, vecp, 0);
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
910 }
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
911
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
912 Lisp_Object
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
913 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
914 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
915 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
916 stack_overflow ("Stack overflow in copy-tree", arg);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
917
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 if (CONSP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
920 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 rest = arg = Fcopy_sequence (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 while (CONSP (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 Lisp_Object elt = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 if (CONSP (elt) || VECTORP (elt))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
927 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
928 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
929 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
930 rest = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
932 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 else if (VECTORP (arg) && ! NILP (vecp))
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 int i = XVECTOR_LENGTH (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 int j;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937 arg = Fcopy_sequence (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 for (j = 0; j < i; j++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
939 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
940 Lisp_Object elt = XVECTOR_DATA (arg) [j];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
942 if (CONSP (elt) || VECTORP (elt))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
943 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
428
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
946 return arg;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
950 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
951 END may be omitted; then the subsequence runs to the end of SEQUENCE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
952 If START or END is negative, it counts from the end.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
953 The returned subsequence is always of the same type as SEQUENCE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
954 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
955 are copied to the new string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
957 (sequence, start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
959 EMACS_INT len, s, e;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
960
5089
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
961 if (STRINGP (sequence))
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
962 {
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
963 Charcount ccstart, ccend;
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
964 Bytecount bstart, blen;
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
965 Lisp_Object val;
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
966
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
967 CHECK_INT (start);
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
968 get_string_range_char (sequence, start, end, &ccstart, &ccend,
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
969 GB_HISTORICAL_STRING_BEHAVIOR);
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
970 bstart = string_index_char_to_byte (sequence, ccstart);
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
971 blen = string_offset_char_to_byte_len (sequence, bstart, ccend - ccstart);
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
972 val = make_string (XSTRING_DATA (sequence) + bstart, blen);
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
973 /* Copy any applicable extent information into the new string. */
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
974 copy_string_extents (val, sequence, 0, bstart, blen);
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
975 return val;
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
976 }
99f8ebc082d9 Make #'substring an alias of #'subseq; give the latter the byte code.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5051
diff changeset
977
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
978 CHECK_SEQUENCE (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
979
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
980 len = XINT (Flength (sequence));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
981
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
982 CHECK_INT (start);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
983 s = XINT (start);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
984 if (s < 0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
985 s = len + s;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
986
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
987 if (NILP (end))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
988 e = len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
991 CHECK_INT (end);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
992 e = XINT (end);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
993 if (e < 0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
994 e = len + e;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
997 if (!(0 <= s && s <= e && e <= len))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
998 args_out_of_range_3 (sequence, make_int (s), make_int (e));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
999
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1000 if (VECTORP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1002 Lisp_Object result = make_vector (e - s, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 EMACS_INT i;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1004 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 Lisp_Object *out_elts = XVECTOR_DATA (result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1007 for (i = s; i < e; i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1008 out_elts[i - s] = in_elts[i];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1011 else if (LISTP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013 Lisp_Object result = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 EMACS_INT i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1016 sequence = Fnthcdr (make_int (s), sequence);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1017
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1018 for (i = s; i < e; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1020 result = Fcons (Fcar (sequence), result);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1021 sequence = Fcdr (sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022 }
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 return Fnreverse (result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1025 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1026 else if (BIT_VECTORP (sequence))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1027 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1028 Lisp_Object result = make_bit_vector (e - s, Qzero);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1029 EMACS_INT i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1030
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1031 for (i = s; i < e; i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1032 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1033 bit_vector_bit (XBIT_VECTOR (sequence), i));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1034 return result;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1035 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1036 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1037 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
1038 ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
1039 error */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1040 return Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1041 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1042 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1043
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1044 /* 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
1045 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
1046
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1047 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
1048 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
1049 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
1050
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1051 static Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1052 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
1053 Ichar sepchar, int unescape, Ichar escapechar)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1054 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1055 Lisp_Object result = Qnil;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1056 const Ibyte *end = string + size;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1057
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1058 if (unescape)
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1059 {
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1060 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
1061 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
1062 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
1063 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
1064 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
1065 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
1066
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1067 while (1)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1068 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1069 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
1070 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
1071 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
1072
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1073 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
1074 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1075 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
1076
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1077 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
1078 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1079 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
1080 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1081 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1082 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1083 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1084 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
1085 /* 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
1086 && !previous_escaped)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1087 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1088 ++deleting_escapes;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1089 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
1090 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1091 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1092 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1093 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
1094 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1095
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1096 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
1097 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1098
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1099 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
1100 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1101 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
1102 > 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
1103 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1104 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
1105 ((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
1106 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
1107 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1108
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1109 cursor = string;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1110 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
1111 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
1112
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1113 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
1114 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1115 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
1116
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1117 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
1118 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1119 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
1120 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
1121 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
1122 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1123
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1124 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
1125 && (pchar == escapechar);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1126
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1127 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
1128 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1129
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1130 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
1131 unescape_cursor
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1132 - 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
1133 result);
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1134 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1135 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1136 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1137 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
1138 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1139 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
1140 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1141 string = p;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1142 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
1143 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1144 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1145 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1146 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1147 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1148 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1149 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1150 while (1)
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1151 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1152 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
1153 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
1154 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1155 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
1156 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1157 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
1158 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1159 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
1160 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
1161 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1162 string = p;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1163 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
1164 }
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1165 else
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1166 break;
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1167 }
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1168 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1169 return Fnreverse (result);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1170 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1171
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1172 /* 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
1173 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
1174 (':' or whatever). */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1175 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1176 split_external_path (const Extbyte *path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1177 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1178 Bytecount newlen;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1179 Ibyte *newpath;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1180 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1181 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1182
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1183 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
1184
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1185 /* #### Does this make sense? It certainly does for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1186 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
1187 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
1188 string? */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1189 if (!newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1190 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1191
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1192 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
1193 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1194
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1195 Lisp_Object
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1196 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
1197 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1198 const Ibyte *path = 0;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1199 if (evarname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1200 path = egetenv (evarname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1201 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1202 path = default_;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1203 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1204 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
1205 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
1206 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1207
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1208 /* 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
1209 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
1210
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1211 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
1212 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
1213
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1214 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
1215 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
1216 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
1217 */
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1218 (string, sepchar, escape_char))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1219 {
5035
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1220 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
1221
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1222 CHECK_STRING (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1223 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
1224 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
1225 {
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1226 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
1227 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
1228 }
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1229 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
1230 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
1231 XCHAR (sepchar),
b1e48555be7d Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5034
diff changeset
1232 !NILP (escape_char), escape_ichar);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1233 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1234
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1235 /* #### 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
1236 the bootstrap process, so it goes here. Damn. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1237
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1238 DEFUN ("split-path", Fsplit_path, 1, 1, 0, /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1239 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
1240 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
1241 with `path-separator'.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1242 */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1243 (path))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1244 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1245 CHECK_STRING (path);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1246
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1247 while (!STRINGP (Vpath_separator)
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1248 || (string_char_length (Vpath_separator) != 1))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1249 Vpath_separator = signal_continuable_error
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1250 (Qinvalid_state,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1251 "`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
1252 Vpath_separator);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1253
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
1254 return (split_string_by_ichar_1
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1255 (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
1256 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
1257 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1258
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 Take cdr N times on LIST, and return the result.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 (n, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
1265 /* This function can GC */
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 578
diff changeset
1266 REGISTER EMACS_INT i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 for (i = XINT (n); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271 if (CONSP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 else if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277 tail = wrong_type_argument (Qlistp, tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 i++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 DEFUN ("nth", Fnth, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 Return the Nth element of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 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
1287 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288 (n, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
1290 /* This function can GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 return Fcar (Fnthcdr (n, list));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 DEFUN ("elt", Felt, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 Return element of SEQUENCE at index N.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 (sequence, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
1299 /* This function can GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301 CHECK_INT_COERCE_CHAR (n); /* yuck! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 if (LISTP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 Lisp_Object tem = Fnthcdr (n, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 /* #### Utterly, completely, fucking disgusting.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 * #### The whole point of "elt" is that it operates on
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 * #### sequences, and does error- (bounds-) checking.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 if (CONSP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 return XCAR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 /* This is The Way It Has Always Been. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 /* This is The Way Mly and Cltl2 say It Should Be. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 args_out_of_range (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 else if (STRINGP (sequence) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 VECTORP (sequence) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 BIT_VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 return Faref (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 else if (COMPILED_FUNCTIONP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 EMACS_INT idx = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 if (idx < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 lose:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 args_out_of_range (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 /* Utter perversity */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 switch (idx)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 case COMPILED_ARGLIST:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 return compiled_function_arglist (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 case COMPILED_INSTRUCTIONS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 return compiled_function_instructions (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 case COMPILED_CONSTANTS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 return compiled_function_constants (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 case COMPILED_STACK_DEPTH:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 return compiled_function_stack_depth (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 case COMPILED_DOC_STRING:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 return compiled_function_documentation (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 case COMPILED_DOMAIN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 return compiled_function_domain (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350 case COMPILED_INTERACTIVE:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 if (f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 return compiled_function_interactive (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 /* if we return nil, can't tell interactive with no args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 from noninteractive. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 goto lose;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 goto lose;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 #endif /* LOSING_BYTECODE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364 check_losing_bytecode ("elt", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 DEFUN ("last", Flast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 Return the tail of list LIST, of length N (default 1).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 LIST may be a dotted list, but not a circular list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 Optional argument N must be a non-negative integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 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
1375 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
1376 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 EMACS_INT int_n, count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380 Lisp_Object retval, tortoise, hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 for (retval = tortoise = hare = list, count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 CONSP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394 hare = XCDR (hare),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396 count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 signal_circular_list_error (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406 return retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410 Modify LIST to remove the last N (default 1) elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 EMACS_INT int_n;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1423 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1424 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 Lisp_Object last_cons = list;
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 EXTERNAL_LIST_LOOP_1 (list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 if (int_n-- < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 last_cons = XCDR (last_cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436 if (int_n >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1438
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1439 XCDR (last_cons) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1441 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1444 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 Return a copy of LIST with the last N (default 1) elements removed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 If LIST has N or fewer elements, nil is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1450 EMACS_INT int_n;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 CHECK_LIST (list);
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 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 else
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 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1461
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 Lisp_Object retval = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 EXTERNAL_LIST_LOOP_1 (list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1467 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468 if (--int_n < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 retval = Fcons (XCAR (tail), retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 return Fnreverse (retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1476 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1477 }
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 DEFUN ("member", Fmember, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 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
1481 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1482 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1484 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487 if (internal_equal (elt, list_elt, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 return tail;
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 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1492
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1493 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1494 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
1495 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1496 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1499 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1500 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
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 if (internal_old_equal (elt, list_elt, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509 DEFUN ("memq", Fmemq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1510 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
1511 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 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
1525 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 Do not use it.
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 (elt, list))
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 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 if (HACKEQ_UNSAFE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 return Qnil;
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 memq_no_quit (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1542 LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1544 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 return tail;
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 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1551 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
1552 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
1553 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1554 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1556 /* This function can GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1557 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1558 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 if (internal_equal (key, elt_car, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 return elt;
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 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1564
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1566 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
1567 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
1568 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1569 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571 /* This function can GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1572 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 if (internal_old_equal (key, elt_car, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577 return Qnil;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1581 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1585 return unbind_to_1 (speccount, Fassoc (key, alist));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588 DEFUN ("assq", Fassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1589 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
1590 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
1591 Elements of ALIST that are not conses are ignored.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1593 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1595 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1602
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1604 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
1605 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
1606 Elements of ALIST that are not conses are ignored.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1610 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1612 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 if (HACKEQ_UNSAFE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 /* Like Fassq but never report an error and do not allow quits.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621 Use only on lists known never to be circular. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1624 assq_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 /* This cannot GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1627 LIST_LOOP_2 (elt, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629 Lisp_Object elt_car = XCAR (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1634 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1637 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
1638 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
1639 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1640 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1642 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1644 if (internal_equal (value, elt_cdr, 0))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1645 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1646 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1647 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1651 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
1652 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
1653 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1654 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1656 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1658 if (internal_old_equal (value, elt_cdr, 0))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664 DEFUN ("rassq", Frassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1665 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
1666 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
1667 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1668 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1670 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1671 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1672 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 return elt;
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 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1679 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
1680 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
1681 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1682 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1683 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1684 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1686 if (HACKEQ_UNSAFE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 return elt;
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 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1691
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1692 /* Like Frassq, but caller must ensure that ALIST is properly
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693 nil-terminated and ebola-free. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1694 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1695 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1696 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1697 LIST_LOOP_2 (elt, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1698 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699 Lisp_Object elt_cdr = XCDR (elt);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1700 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1701 return elt;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1707 DEFUN ("delete", Fdelete, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1708 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
1709 The modified LIST is returned. Comparison is done with `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1710 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
1711 effect; therefore, write `(setq foo (delete element foo))' to be sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1712 of changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 Also see: `remove'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1714 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 (elt, list))
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 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 (internal_equal (elt, list_elt, 0)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1723 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
1724 The modified LIST is returned. Comparison is done with `old-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1725 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
1726 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 of changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1728 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1732 (internal_old_equal (elt, list_elt, 0)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1733 return list;
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 DEFUN ("delq", Fdelq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 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
1738 The modified LIST is returned. Comparison is done with `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 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
1740 effect; therefore, write `(setq foo (delq element foo))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751 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
1752 The modified LIST is returned. Comparison is done with `old-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1753 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
1754 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
1755 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 (elt, list))
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 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 (HACKEQ_UNSAFE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1763
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 /* Like Fdelq, but caller must ensure that LIST is properly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765 nil-terminated and ebola-free. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768 delq_no_quit (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1770 LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 return list;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 /* Be VERY careful with this. This is like delq_no_quit() but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 also calls free_cons() on the removed conses. You must be SURE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 that no pointers to the freed conses remain around (e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 someone else is pointing to part of the list). This function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 is useful on internal lists that are used frequently and where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780 the actual list doesn't escape beyond known code bounds. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
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 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 REGISTER Lisp_Object prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788 while (!NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790 REGISTER Lisp_Object tem = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 if (EQ (elt, tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 Lisp_Object cons_to_free = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 list = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 XCDR (prev) = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 tail = XCDR (tail);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1799 free_cons (cons_to_free);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1811 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
1812 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
1813 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
1814 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1817 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1819 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 internal_equal (key, XCAR (elt), 0)));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1822 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1826 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1827 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1830 return unbind_to_1 (speccount, Fremassoc (key, alist));
428
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 ("remassq", Fremassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1834 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
1835 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
1836 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
1837 therefore, write `(setq foo (remassq key foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1840 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1841 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1842 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1845 return alist;
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 /* no quit, no errors; be careful */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1851 remassq_no_quit (Lisp_Object key, Lisp_Object 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 LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1856 return alist;
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1860 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
1861 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
1862 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
1863 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1866 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1868 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870 internal_equal (value, XCDR (elt), 0)));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1871 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 }
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 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1875 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
1876 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
1877 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
1878 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 the value of `foo'.
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 (value, 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 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1886 return alist;
428
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 /* Like Fremrassq, fast and unsafe; be careful */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1891 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1893 LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1896 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900 Reverse LIST by destructively modifying cdr pointers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901 Return the beginning of the reversed list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902 Also see: `reverse'.
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 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 struct gcpro gcpro1, gcpro2;
1849
21549d437f09 [xemacs-hg @ 2004-01-03 21:54:41 by james]
james
parents: 1261
diff changeset
1907 Lisp_Object prev = Qnil;
21549d437f09 [xemacs-hg @ 2004-01-03 21:54:41 by james]
james
parents: 1261
diff changeset
1908 Lisp_Object tail = list;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910 /* We gcpro our args; see `nconc' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 GCPRO2 (prev, tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912 while (!NILP (tail))
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 REGISTER Lisp_Object next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 CONCHECK_CONS (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 next = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 XCDR (tail) = prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 tail = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 return prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 DEFUN ("reverse", Freverse, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 Reverse LIST, copying. Return the beginning of the reversed list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 See also the function `nreverse', which is used more often.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931 Lisp_Object reversed_list = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 EXTERNAL_LIST_LOOP_2 (elt, list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 reversed_list = Fcons (elt, reversed_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1936 return reversed_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 Lisp_Object lisp_arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 int (*pred_fn) (Lisp_Object, Lisp_Object,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 Lisp_Object lisp_arg));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
1944 /* The sort function should return > 0 if OBJ1 < OBJ2, < 0 otherwise.
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
1945 NOTE: This is backwards from the way qsort() works. */
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
1946
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 list_sort (Lisp_Object list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 Lisp_Object lisp_arg,
872
79c6ff3eef26 [xemacs-hg @ 2002-06-20 21:18:01 by ben]
ben
parents: 867
diff changeset
1950 int (*pred_fn) (Lisp_Object obj1, Lisp_Object obj2,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 Lisp_Object lisp_arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 struct gcpro gcpro1, gcpro2, gcpro3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 Lisp_Object back, tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 Lisp_Object front = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 Lisp_Object len = Flength (list);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1957
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1958 if (XINT (len) < 2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1961 len = make_int (XINT (len) / 2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 tem = Fnthcdr (len, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 back = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 Fsetcdr (tem, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 GCPRO3 (front, back, lisp_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 front = list_sort (front, lisp_arg, pred_fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 back = list_sort (back, lisp_arg, pred_fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 return list_merge (front, back, lisp_arg, pred_fn);
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 Lisp_Object pred)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978 Lisp_Object tmp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 /* prevents the GC from happening in call2 */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1981 /* Emacs' GC doesn't actually relocate pointers, so this probably
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1982 isn't strictly necessary */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1983 int speccount = begin_gc_forbidden ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 tmp = call2 (pred, obj1, obj2);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1985 unbind_to (speccount);
428
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 if (NILP (tmp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 return -1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 DEFUN ("sort", Fsort, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 Sort LIST, stably, comparing elements using PREDICATE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 Returns the sorted list. LIST is modified by side effects.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1996 PREDICATE is called with two elements of LIST, and should return T
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 if the first element is "less" than the second.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1999 (list, predicate))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2001 return list_sort (list, predicate, merge_pred_function);
428
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2005 merge (Lisp_Object org_l1, Lisp_Object org_l2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2006 Lisp_Object pred)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 return list_merge (org_l1, org_l2, pred, merge_pred_function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2012 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014 Lisp_Object lisp_arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 Lisp_Object value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020 Lisp_Object l1, l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 l1 = org_l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024 l2 = org_l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 value = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028 /* It is sufficient to protect org_l1 and org_l2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029 When l1 and l2 are updated, we copy the new values
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 back into the org_ vars. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 GCPRO4 (org_l1, org_l2, lisp_arg, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 if (NILP (l1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 return l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 Fsetcdr (tail, l2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 return value;
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 if (NILP (l2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 return l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 Fsetcdr (tail, l1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2050 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
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 tem = l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 l1 = Fcdr (l1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 org_l1 = l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2058 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 tem = l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062 l2 = Fcdr (l2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063 org_l2 = l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 value = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 Fsetcdr (tail, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069 tail = tem;
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 /* property-list functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 /* For properties of text, we need to do order-insensitive comparison of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 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
2080 same if they have the same set of keys, and equivalent values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081 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
2082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 LAXP means use `equal' for comparisons.
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 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 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
2088 int laxp, int depth, int foldcase)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 434
diff changeset
2090 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
2091 int la, lb, m, i, fill;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 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
2093 Boolbyte *flags;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 Lisp_Object rest;
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 if (NILP (a) && NILP (b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 Fcheck_valid_plist (a);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100 Fcheck_valid_plist (b);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 la = XINT (Flength (a));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103 lb = XINT (Flength (b));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2104 m = (la > lb ? la : lb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2105 fill = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106 keys = alloca_array (Lisp_Object, m);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2107 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
2108 flags = alloca_array (Boolbyte, m);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2109
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110 /* First extract the pairs from A. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2112 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113 Lisp_Object k = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114 Lisp_Object v = XCAR (XCDR (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2115 /* Maybe be Ebolified. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2116 if (nil_means_not_present && NILP (v)) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2117 keys [fill] = k;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2118 vals [fill] = v;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2119 flags[fill] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2120 fill++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2121 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2122 /* 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
2123 or that doesn't match. As we match, mark them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2124 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2126 Lisp_Object k = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 Lisp_Object v = XCAR (XCDR (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2128 /* Maybe be Ebolified. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129 if (nil_means_not_present && NILP (v)) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2130 for (i = 0; i < fill; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2132 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
2133 internal_equal_0 (k, keys [i], depth, foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2134 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2135 if (eqp
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2136 /* We narrowly escaped being Ebolified here. */
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2137 ? !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
2138 : !internal_equal_0 (v, vals [i], depth, foldcase))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2139 /* a property in B has a different value than in A */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141 flags [i] = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145 if (i == fill)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2146 /* there are some properties in B that are not in A */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2149 /* 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
2150 for (i = 0; i < fill; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2151 if (flags [i] == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2152 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2153
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2154 /* Ok. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2155 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2156
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2157 MISMATCH:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2158 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2159 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2161 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2162 Return non-nil if property lists A and B are `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2163 A property list is an alternating list of keywords and values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2164 This function does order-insensitive comparisons of the property lists:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165 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
2166 Comparison between values is done using `eq'. See also `plists-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2167 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
2168 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
2169 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2170 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2171 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2174 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
2175 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2176 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179 Return non-nil if property lists A and B are `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 A property list is an alternating list of keywords and values. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2181 function does order-insensitive comparisons of the property lists: For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 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
2183 Comparison between values is done using `equal'. See also `plists-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 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
2185 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
2186 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2191 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
2192 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197 Return non-nil if lax property lists A and B are `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198 A property list is an alternating list of keywords and values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 This function does order-insensitive comparisons of the property lists:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200 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
2201 Comparison between values is done using `eq'. See also `plists-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2202 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
2203 keywords is done using `equal' instead of `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204 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
2205 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
2206 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2207 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2208 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2209 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2210 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2211 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
2212 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2214
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2215 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2216 Return non-nil if lax property lists A and B are `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2217 A property list is an alternating list of keywords and values. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2218 function does order-insensitive comparisons of the property lists: For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2219 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
2220 Comparison between values is done using `equal'. See also `plists-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 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
2222 keywords is done using `equal' instead of `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 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
2224 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
2225 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229 {
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2230 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
2231 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2233
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 /* Return the value associated with key PROPERTY in property list PLIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2235 Return nil if key not found. This function is used for internal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 property lists that cannot be directly manipulated by the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 internal_plist_get (Lisp_Object plist, Lisp_Object property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2247 return XCAR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2248 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2249
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2250 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2251 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2252
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2253 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2254 internal_plist_get(). */
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 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2258 Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2260 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2261
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266 XCAR (XCDR (tail)) = value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 *plist = Fcons (property, Fcons (value, *plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2273
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2274 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 internal_remprop (Lisp_Object *plist, Lisp_Object property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277 Lisp_Object tail, prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 for (tail = *plist, prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2280 !NILP (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286 *plist = XCDR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2289 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2290 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2291 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2293 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2295 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298 /* Called on a malformed property list. BADPLACE should be some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299 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
2300 result in a list with an odd length. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 static Lisp_Object
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2303 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
2304 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 (Qlist, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2313 list2 (build_msg_string
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 ("Malformed property list -- list has been truncated"),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 *plist));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2316 /* #### 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
2317 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
2318 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
2319 ERROR_ME and ERROR_ME_NOT don't. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 *badplace = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326 /* Called on a circular property list. BADPLACE should be some place
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 where truncating will result in an even-length list, as above.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328 If doesn't particularly matter where we truncate -- anywhere we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 truncate along the entire list will break the circularity, because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 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
2331 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 static Lisp_Object
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2334 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
2335 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2336 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337 return Fsignal (Qcircular_property_list, list1 (*plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 else
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 (ERRB_EQ (errb, ERROR_ME_WARN))
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 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343 (Qlist, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2344 list2 (build_msg_string
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345 ("Circular property list -- list has been truncated"),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346 *plist));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2347 /* #### 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
2348 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
2349 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
2350 ERROR_ME and ERROR_ME_NOT don't. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2351 *badplace = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2352 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2357 /* Advance the tortoise pointer by two (one iteration of a property-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2358 loop) and the hare pointer by four and verify that no malformations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 or circularities exist. If so, return zero and store a value into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2360 RETVAL that should be returned by the calling function. Otherwise,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2361 return 1. See external_plist_get().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2362 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2363
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2364 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365 advance_plist_pointers (Lisp_Object *plist,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 Lisp_Object **tortoise, Lisp_Object **hare,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2367 Error_Behavior errb, Lisp_Object *retval)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2369 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370 Lisp_Object *tortsave = *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2371
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2372 /* Note that our "fixing" may be more brutal than necessary,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2373 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
2374 manually fucked up a plist. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 for (i = 0; i < 2; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 /* This is a standard iteration of a defensive-loop-checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2379 loop. We just do it twice because we want to advance past
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380 both the property and its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382 If the pointer indirection is confusing you, remember that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 one level of indirection on the hare and tortoise pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 is only due to pass-by-reference for this function. The other
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 level is so that the plist can be fixed in place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2386
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2387 /* When we reach the end of a well-formed plist, **HARE is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2388 nil. In that case, we don't do anything at all except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2389 advance TORTOISE by one. Otherwise, we advance HARE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2390 by two (making sure it's OK to do so), then advance
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2391 TORTOISE by one (it will always be OK to do so because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2392 the HARE is always ahead of the TORTOISE and will have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2393 already verified the path), then make sure TORTOISE and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 HARE don't contain the same non-nil object -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 TORTOISE and the HARE ever meet, then obviously we're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396 in a circularity, and if we're in a circularity, then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2397 the TORTOISE and the HARE can't cross paths without
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2398 meeting, since the HARE only gains one step over the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2399 TORTOISE per iteration. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2400
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401 if (!NILP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403 Lisp_Object *haresave = *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404 if (!CONSP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406 *retval = bad_bad_bunny (plist, haresave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 *hare = &XCDR (**hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410 /* 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
2411 **HARE, which is OK (it just means the list has an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2412 odd number of elements). In a plist, it's not OK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2413 for the list to have an odd number of elements. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 if (!CONSP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2415 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 *retval = bad_bad_bunny (plist, haresave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 *hare = &XCDR (**hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2420 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2421
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 *tortoise = &XCDR (**tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2423 if (!NILP (**hare) && EQ (**tortoise, **hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2424 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2425 *retval = bad_bad_turtle (plist, tortsave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2426 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2427 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2429
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2431 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433 /* Return the value of PROPERTY from PLIST, or Qunbound if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2434 property is not on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2436 PLIST is a Lisp-accessible property list, meaning that it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2437 has to be checked for malformations and circularities.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2438
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2439 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2440 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
2441 on finding a malformation or a circularity, it issues a warning and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2442 attempts to silently fix the problem.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2443
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2444 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
2445 "fixed" even if the error is at the beginning of the plist. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448 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
2449 int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2450 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2451 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2452 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2454 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2455 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2457 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2458
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2459 /* We do the standard tortoise/hare march. We isolate the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2460 grungy stuff to do this in advance_plist_pointers(), though.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2461 To us, all this function does is advance the tortoise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462 pointer by two and the hare pointer by four and make sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463 everything's OK. We first advance the pointers and then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464 check if a property matched; this ensures that our
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 check for a matching property is safe. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 return retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472 return XCAR (XCDR (*tortsave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 malformed or circular plist. Analogous to external_plist_get(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482 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
2483 Lisp_Object value, int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2484 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2485 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2486 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2489 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2490 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2491 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2492
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2493 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2494 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2498 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 XCAR (XCDR (*tortsave)) = value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2503 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505 *plist = Fcons (property, Fcons (value, *plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 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
2510 int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2516 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2518 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2523
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2525 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2526 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 /* Now you see why it's so convenient to have that level
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2528 of indirection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529 *tortsave = XCDR (XCDR (*tortsave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2530 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2531 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2532 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2535 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2538 Extract a value from a property list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 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
2540 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2541 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2542 This function returns the value corresponding to the PROPERTY,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2543 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
2544 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2545 (plist, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2547 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2548 return UNBOUNDP (value) ? default_ : value;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2552 Change value in PLIST of PROPERTY to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2553 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
2554 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2555 PROPERTY is usually a symbol and VALUE is any object.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2556 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
2557 otherwise the new PROPERTY VALUE pair is added.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2558 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
2559 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
2560 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2561 (plist, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2562 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2563 external_plist_put (&plist, property, value, 0, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2564 return plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2567 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2568 Remove from PLIST the property PROPERTY and its value.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2569 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
2570 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2571 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2572 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
2573 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
2574 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2575 (plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2577 external_remprop (&plist, property, 0, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 return plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2579 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2581 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2582 Return t if PROPERTY has a value specified in PLIST.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2584 (plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2586 Lisp_Object value = Fplist_get (plist, property, Qunbound);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2587 return UNBOUNDP (value) ? Qnil : Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2588 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2589
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591 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
2592 This means that it's a malformed or circular plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2593 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2594 (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2596 Lisp_Object *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597 Lisp_Object *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599 start_over:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2600 tortoise = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 hare = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2604 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2605
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2606 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608 &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 goto start_over;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2614
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616 Given a plist, return non-nil if its format is correct.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617 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
2618 the plist; that means it's a malformed or circular plist.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2620 (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2621 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 Lisp_Object *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623 Lisp_Object *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2624
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625 tortoise = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2626 hare = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2631 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633 &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2635 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2637 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2640 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2641 Destructively remove any duplicate entries from a plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2642 In such cases, the first entry applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2643
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644 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
2645 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
2646 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649 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
2650 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
2651 `setq' the value back into where it came from.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2652 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2653 (plist, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2654 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2655 Lisp_Object head = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2657 Fcheck_valid_plist (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2658
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2659 while (!NILP (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2661 Lisp_Object prop = Fcar (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2662 Lisp_Object next = Fcdr (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2664 CHECK_CONS (next); /* just make doubly sure we catch any errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 if (EQ (head, plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668 head = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 /* external_remprop returns 1 if it removed any property.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2673 We have to loop till it didn't remove anything, in case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674 the property occurs many times. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 DO_NOTHING;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2677 plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2681 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2682
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2683 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2684 Extract a value from a lax property list.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2685 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
2686 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2687 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2688 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2689 This function returns the value corresponding to PROPERTY,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2690 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
2691 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2692 (lax_plist, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2694 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
2695 return UNBOUNDP (value) ? default_ : value;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2697
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2699 Change value in LAX-PLIST of PROPERTY to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2700 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
2701 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2702 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2703 PROPERTY is usually a symbol and VALUE is any object.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2704 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
2705 VALUE, otherwise the new PROPERTY VALUE pair is added.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2706 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
2707 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
2708 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2709 (lax_plist, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2711 external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 return lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2714
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2715 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2716 Remove from LAX-PLIST the property PROPERTY and its value.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2717 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
2718 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2719 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2720 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2721 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
2722 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
2723 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2724 (lax_plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2726 external_remprop (&lax_plist, property, 1, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2727 return lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2728 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2729
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2731 Return t if PROPERTY has a value specified in LAX-PLIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2732 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
2733 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2734 properties is done using `equal' instead of `eq'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2735 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2736 (lax_plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2738 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2739 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 Destructively remove any duplicate entries from a lax plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 In such cases, the first entry applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2745 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
2746 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
2747 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2750 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
2751 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
2752 `setq' the value back into where it came from.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2753 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 (lax_plist, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2755 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 Lisp_Object head = lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2758 Fcheck_valid_plist (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2760 while (!NILP (lax_plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2761 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2762 Lisp_Object prop = Fcar (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2763 Lisp_Object next = Fcdr (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2764
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2765 CHECK_CONS (next); /* just make doubly sure we catch any errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2766 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768 if (EQ (head, lax_plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769 head = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 lax_plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2773 /* external_remprop returns 1 if it removed any property.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2774 We have to loop till it didn't remove anything, in case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775 the property occurs many times. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2776 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2777 DO_NOTHING;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2778 lax_plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2779 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 /* In C because the frame props stuff uses it */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787 Convert association list ALIST into the equivalent property-list form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2788 The plist is returned. This converts from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 \((a . 1) (b . 2) (c . 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2792 into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2793
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2794 \(a 1 b 2 c 3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2795
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2796 The original alist is destroyed in the process of constructing the plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797 See also `alist-to-plist'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2799 (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2800 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2801 Lisp_Object head = alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802 while (!NILP (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2803 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2804 /* remember the alist element. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2805 Lisp_Object el = Fcar (alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2806
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2807 Fsetcar (alist, Fcar (el));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2808 Fsetcar (el, Fcdr (el));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 Fsetcdr (el, Fcdr (alist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2810 Fsetcdr (alist, el);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2811 alist = Fcdr (Fcdr (alist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2812 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2813
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2817 DEFUN ("get", Fget, 2, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2818 Return the value of OBJECT's PROPERTY property.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2819 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820 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
2821 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2822 face, or glyph. See also `put', `remprop', and `object-plist'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2824 (object, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 /* Various places in emacs call Fget() and expect it not to quit,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827 so don't quit. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2828 Lisp_Object val;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2829
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2830 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2831 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2833 invalid_operation ("Object type has no properties", object);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2834
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2835 return UNBOUNDP (val) ? default_ : val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 DEFUN ("put", Fput, 3, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2839 Set OBJECT's PROPERTY to VALUE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2840 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2841 OBJECT can be a symbol, face, extent, or string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842 For a string, no properties currently have predefined meanings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 For the predefined properties for extents, see `set-extent-property'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 For the predefined properties for faces, see `set-face-property'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845 See also `get', `remprop', and `object-plist'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2847 (object, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 {
1920
c66036f59678 [xemacs-hg @ 2004-02-20 07:29:16 by stephent]
stephent
parents: 1849
diff changeset
2849 /* This function cannot GC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2850 CHECK_LISP_WRITEABLE (object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2852 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2854 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2855 (object, property, value))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2856 invalid_change ("Can't set property on object", property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2859 invalid_change ("Object type has no settable properties", object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2865 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2866 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2867 if the property list was actually modified (i.e. if PROPERTY was present
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2868 in the property list). See also `get', `put', and `object-plist'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2870 (object, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2872 int ret = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2873
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874 CHECK_LISP_WRITEABLE (object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2876 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2878 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2879 if (ret == -1)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2880 invalid_change ("Can't remove property from object", property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2883 invalid_change ("Object type has no removable properties", object);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2884
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2885 return ret ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2889 Return a property list of OBJECT's properties.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2890 For a symbol, this is equivalent to `symbol-plist'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2891 OBJECT can be a symbol, string, extent, face, or glyph.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2892 Do not modify the returned property list directly;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2893 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
2894 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2896 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2897 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2898 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2899 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2900 invalid_operation ("Object type has no properties", object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2906 static Lisp_Object
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2907 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
2908 Lisp_Object depth)
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2909 {
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2910 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
2911 }
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2912
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2913 int
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2914 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
2915 const Ascbyte *warning_string,
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2916 int flags,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2917 struct call_trapping_problems_result *p,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2918 int retval,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2919 Lisp_Object obj1, Lisp_Object obj2,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2920 int depth)
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2921 {
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2922 Lisp_Object glorp =
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2923 va_call_trapping_problems (warning_class, warning_string,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2924 flags, p,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2925 (lisp_fn_t) tweaked_internal_equal,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2926 3, obj1, obj2, make_int (depth));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2927 if (UNBOUNDP (glorp))
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2928 return retval;
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2929 else
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2930 return XINT (glorp);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2931 }
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2932
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2933 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2934 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2935 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2936 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2937 stack_overflow ("Stack overflow in equal", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2938 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2939 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2941 /* Note that (equal 20 20.0) should be nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2942 if (XTYPE (obj1) != XTYPE (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2943 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2944 if (LRECORDP (obj1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2945 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2946 const struct lrecord_implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2947 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2948 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2949
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2950 return (imp1 == imp2) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2951 /* 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
2952 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2953 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2954
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2955 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2956 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2957
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2958 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
2959 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2960 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
2961 ARRAY_STRING,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2962 ARRAY_VECTOR,
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2963 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
2964 };
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2965
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2966 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
2967 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
2968 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2969 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
2970 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
2971 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
2972 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
2973 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
2974 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
2975 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
2976 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2977
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2978 int
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2979 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
2980 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2981 if (depth > 200)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2982 stack_overflow ("Stack overflow in equalp", Qunbound);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2983 QUIT;
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2984
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2985 /* 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
2986 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
2987 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2988 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
2989
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2990 /* 2. If both numbers, compare with `='. */
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
2991 if (NUMBERP (obj1) && NUMBERP (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
2992 {
4910
6bc1f3f6cf0d Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4906
diff changeset
2993 return (0 == bytecode_arithcompare (obj1, obj2));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1920
diff changeset
2994 }
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2995
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
2996 /* 3. If characters, compare case-insensitively. */
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2997 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
2998 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
2999
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3000 /* 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
3001 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
3002 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3003 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
3004 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
3005 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
3006 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
3007 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3008 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
3009 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
3010 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
3011 /* 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
3012 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
3013 return 0;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3014 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
3015 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
3016 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
3017 return 0;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3018 return 1;
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3019 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3020 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3021 /* 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
3022 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
3023 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
3024 if (XTYPE (obj1) != XTYPE (obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3025 return 0;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3026 if (LRECORDP (obj1))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3027 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3028 const struct lrecord_implementation
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3029 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3030 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3031
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3032 return (imp1 == imp2) &&
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3033 /* 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
3034 (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
3035 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3036
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3037 return 0;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3038 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3039
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3040 int
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3041 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
3042 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3043 if (foldcase)
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3044 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
3045 else
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3046 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
3047 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3048
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3049 /* Note that we may be calling sub-objects that will use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3050 internal_equal() (instead of internal_old_equal()). Oh well.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3051 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
3052 but that seems unlikely. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3054 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3055 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3058 stack_overflow ("Stack overflow in equal", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3059 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3060 if (HACKEQ_UNSAFE (obj1, obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 /* Note that (equal 20 20.0) should be nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 if (XTYPE (obj1) != XTYPE (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 return 0;
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 return internal_equal (obj1, obj2, depth);
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 DEFUN ("equal", Fequal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 Return t if two Lisp objects have similar structure and contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3071 They must have the same data type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3072 Conses are compared by comparing the cars and the cdrs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073 Vectors and strings are compared element by element.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 Numbers are compared by value. Symbols must match exactly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3076 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3077 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3078 return internal_equal (object1, object2, 0) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080
4906
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3081 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
3082 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
3083
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3084 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
3085 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
3086 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
3087
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3088 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
3089 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
3090 `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
3091
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3092 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
3093 `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
3094 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
3095 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
3096 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
3097 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
3098 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
3099 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
3100
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3101 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
3102 (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
3103 `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
3104 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
3105 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
3106 */
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3107 (object1, object2))
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3108 {
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3109 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
3110 }
6ef8256a020a implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3111
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113 Return t if two Lisp objects have similar structure and contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114 They must have the same data type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115 \(Note, however, that an exception is made for characters and integers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 this is known as the "char-int confoundance disease." See `eq' and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 `old-eq'.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3121 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3122 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3123 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3125
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3127 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3128 Destructively modify ARRAY by replacing each element with ITEM.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3129 ARRAY is a vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3130 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3131 (array, item))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3132 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3133 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3134 if (STRINGP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3135 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3136 Bytecount old_bytecount = XSTRING_LENGTH (array);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3137 Bytecount new_bytecount;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3138 Bytecount item_bytecount;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
3139 Ibyte item_buf[MAX_ICHAR_LEN];
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
3140 Ibyte *p;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
3141 Ibyte *end;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3142
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3143 CHECK_CHAR_COERCE_INT (item);
2720
6fa9919a9a0b [xemacs-hg @ 2005-04-08 23:10:01 by crestani]
crestani
parents: 2500
diff changeset
3144
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3145 CHECK_LISP_WRITEABLE (array);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3146 sledgehammer_check_ascii_begin (array);
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
3147 item_bytecount = set_itext_ichar (item_buf, XCHAR (item));
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3148 new_bytecount = item_bytecount * (Bytecount) string_char_length (array);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3149
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3150 resize_string (array, -1, new_bytecount - old_bytecount);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3151
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3152 for (p = XSTRING_DATA (array), end = p + new_bytecount;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3153 p < end;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3154 p += item_bytecount)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3155 memcpy (p, item_buf, item_bytecount);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3156 *p = '\0';
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3157
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3158 XSET_STRING_ASCII_BEGIN (array,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3159 item_bytecount == 1 ?
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3160 min (new_bytecount, MAX_STRING_ASCII_BEGIN) :
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
3161 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3162 bump_string_modiff (array);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3163 sledgehammer_check_ascii_begin (array);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3164 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3165 else if (VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3166 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3167 Lisp_Object *p = XVECTOR_DATA (array);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3168 Elemcount len = XVECTOR_LENGTH (array);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3169 CHECK_LISP_WRITEABLE (array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3170 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3171 *p++ = item;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173 else if (BIT_VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3174 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3175 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3176 Elemcount len = bit_vector_length (v);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3177 int bit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 CHECK_BIT (item);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3179 bit = XINT (item);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180 CHECK_LISP_WRITEABLE (array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3181 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3182 set_bit_vector_bit (v, len, bit);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3183 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3184 else
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 array = wrong_type_argument (Qarrayp, array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3187 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3188 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3189 return array;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3190 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3192 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3193 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3194 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197 args[0] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 args[1] = arg2;
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 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3202
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 RETURN_UNGCPRO (bytecode_nconc2 (args));
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 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 bytecode_nconc2 (Lisp_Object *args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 if (CONSP (args[0]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 /* (setcdr (last args[0]) args[1]) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3214 Lisp_Object tortoise, hare;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3215 Elemcount count;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 for (hare = tortoise = args[0], count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 CONSP (XCDR (hare));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219 hare = XCDR (hare), count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3221 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3222
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3223 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3224 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3225 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3226 signal_circular_list_error (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3227 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3228 XCDR (hare) = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229 return args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3230 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231 else if (NILP (args[0]))
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 return args[1];
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 else
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 args[0] = wrong_type_argument (args[0], Qlistp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238 goto retry;
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243 Concatenate any number of lists by altering them.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 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
3245 Also see: `append'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3246 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
3247 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248 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
3249
80cd90837ac5 Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents: 3842
diff changeset
3250 arguments: (&rest ARGS)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3251 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3252 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3253 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3254 int argnum = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3255 struct gcpro gcpro1;
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 /* The modus operandi in Emacs is "caller gc-protects args".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 However, nconc (particularly nconc2 ()) is called many times
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259 in Emacs on freshly created stuff (e.g. you see the idiom
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3260 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3261 callers out by protecting the args ourselves to save them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3262 a lot of temporary-variable grief. */
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 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265 gcpro1.nvars = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3266
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 while (argnum < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3268 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3270 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3271 val = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3272 if (CONSP (val))
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 /* `val' is the first cons, which will be our return value. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275 /* `last_cons' will be the cons cell to mutate. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3276 Lisp_Object last_cons = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3277 Lisp_Object tortoise = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 for (argnum++; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281 Lisp_Object next = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282 retry_next:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283 if (CONSP (next) || argnum == nargs -1)
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 /* (setcdr (last val) next) */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3286 Elemcount count;
428
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 for (count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3289 CONSP (XCDR (last_cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 last_cons = XCDR (last_cons), count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 if (EQ (last_cons, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 signal_circular_list_error (args[argnum-1]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299 XCDR (last_cons) = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3300 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 else if (NILP (next))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3302 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3307 next = wrong_type_argument (Qlistp, next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 goto retry_next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3309 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3310 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311 RETURN_UNGCPRO (val);
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 else if (NILP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314 argnum++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 else if (argnum == nargs - 1) /* last arg? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3318 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3319 args[argnum] = wrong_type_argument (Qlistp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3321 }
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 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3324 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3325
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3326
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3327 /* 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
3328
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3329 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
3330 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
3331 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
3332 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
3333 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
3334 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
3335
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3336 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
3337 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
3338 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
3339 mapcarX.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3340
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3341 Otherwise, mapcarX signals a wrong-type-error if it encounters a
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3342 non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3343 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
3344 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
3345 traversal operation.
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3346
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3347 If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3348 values given by FUNCTION the first time it is non-nil, and abandon the
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
3349 iterations. LISP_VALS must be a cons, and the return value will be
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
3350 stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
3351 in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
3352 alone. */
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3353
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3354 #define SOME_OR_EVERY_NEITHER 0
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3355 #define SOME_OR_EVERY_SOME 1
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3356 #define SOME_OR_EVERY_EVERY 2
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3357
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3358 static void
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3359 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
3360 Lisp_Object function, int nsequences, Lisp_Object *sequences,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3361 int some_or_every)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3362 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3363 Lisp_Object called, *args;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3364 struct gcpro gcpro1, gcpro2;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3365 int i, j;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3366 enum lrecord_type lisp_vals_type;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3367
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3368 assert (LRECORDP (lisp_vals));
4999
ebafcd6e9f4b fix compile error in mapcarX
Ben Wing <ben@xemacs.org>
parents: 4998
diff changeset
3369 lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3370
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3371 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
3372 args[0] = function;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3373 for (i = 1; i <= nsequences; ++i)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3375 args[i] = Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3378 if (vals != NULL)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3380 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
3381 gcpro1.nvars = nsequences + 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3382 gcpro2.nvars = 0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3383 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3384 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3385 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3386 GCPRO1 (args[0]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3387 gcpro1.nvars = nsequences + 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3388 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3389
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3390 /* 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
3391 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
3392 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
3393 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
3394 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
3395 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3396 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
3397 Lisp_Object *val = vals;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3398 for (i = 0; i < call_count; ++i)
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3399 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3400 *val++ = XCAR (lst);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3401 lst = XCDR (lst);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3403 gcpro2.nvars = call_count;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3404
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3405 for (i = 0; i < call_count; ++i)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3407 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
3408 vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args));
428
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 else
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3412 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3413 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
3414 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
3415 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3416 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
3417 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3418
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3419 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
3420 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3421 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
3422 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3423 switch (sequence_types[j])
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3424 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3425 case lrecord_type_cons:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3426 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3427 if (!CONSP (sequences[j]))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3428 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3429 /* This means FUNCTION has probably messed
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3430 around with a cons in one of the sequences,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3431 since we checked the type
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3432 (CHECK_SEQUENCE()) and the length and
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3433 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
3434 callers. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3435 dead_wrong_type_argument (Qconsp, sequences[j]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3436 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3437 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
3438 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
3439 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3440 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3441 case lrecord_type_vector:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3442 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3443 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
3444 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3445 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3446 case lrecord_type_string:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3447 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3448 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
3449 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3450 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3451 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
3452 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3453 args[j + 1]
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3454 = 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
3455 i));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3456 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3457 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3458 default:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3459 ABORT();
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3460 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3461 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3462 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
3463 if (vals != NULL)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3464 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3465 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
3466 gcpro2.nvars += 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3467 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3468 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3469 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3470 switch (lisp_vals_type)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3471 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3472 case lrecord_type_symbol:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3473 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3474 case lrecord_type_cons:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3475 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3476 if (SOME_OR_EVERY_NEITHER == some_or_every)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3477 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3478 called = IGNORE_MULTIPLE_VALUES (called);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3479 if (!CONSP (lisp_vals))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3480 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3481 /* If FUNCTION has inserted a non-cons non-nil
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3482 cdr into the list before we've processed the
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3483 relevant part, error. */
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3484 dead_wrong_type_argument (Qconsp, lisp_vals);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3485 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3486
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3487 XSETCAR (lisp_vals, called);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3488 lisp_vals = XCDR (lisp_vals);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3489 break;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3490 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3491
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3492 if (SOME_OR_EVERY_SOME == some_or_every)
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3493 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3494 if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3495 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3496 XCAR (lisp_vals) = called;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3497 UNGCPRO;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3498 return;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3499 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3500 break;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3501 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3502
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3503 if (SOME_OR_EVERY_EVERY == some_or_every)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3504 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3505 called = IGNORE_MULTIPLE_VALUES (called);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3506 if (NILP (called))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3507 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3508 XCAR (lisp_vals) = Qnil;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3509 UNGCPRO;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3510 return;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3511 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3512 break;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3513 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3514
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
3515 goto bad_some_or_every_flag;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3516 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3517 case lrecord_type_vector:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3518 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3519 called = 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
3520 i < XVECTOR_LENGTH (lisp_vals) ?
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3521 (XVECTOR_DATA (lisp_vals)[i] = called) :
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3522 /* Let #'aset error. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3523 Faset (lisp_vals, make_int (i), called);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3524 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3525 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3526 case lrecord_type_string:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3527 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3528 /* If this ever becomes a code hotspot, we can keep
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3529 around pointers into the data of the string, checking
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3530 each time that it hasn't been relocated. */
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3531 called = 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
3532 Faset (lisp_vals, make_int (i), called);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3533 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3534 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3535 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
3536 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3537 called = 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
3538 (BITP (called) &&
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3539 i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3540 set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3541 XINT (called)) :
5002
0cd784a6ec44 fix some compile bugs of Aidan's
Ben Wing <ben@xemacs.org>
parents: 5001
diff changeset
3542 (void) Faset (lisp_vals, make_int (i), called);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3543 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3544 }
5034
1b96882bdf37 Fix a multiple-value bug, mapcarX; correct a comment and a label name.
Aidan Kehoe <kehoea@parhasard.net>
parents: 5002
diff changeset
3545 bad_some_or_every_flag:
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3546 default:
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3547 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3548 ABORT();
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3549 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3550 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3551 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3552 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3553 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3554 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3555 UNGCPRO;
428
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
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3558 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
3559 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
3560 Between each pair of results, insert SEPARATOR.
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3561
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3562 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
3563 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
3564 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
3565
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3566 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
3567 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
3568 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
3569 `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
3570
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3571 arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3572 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3573 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3574 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3575 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
3576 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
3577 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
3578 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
3579 Lisp_Object *args0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3580 EMACS_INT i, nargs0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3581
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3582 args[2] = sequence;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3583 args[1] = separator;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3584
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3585 for (i = 2; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3586 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3587 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3588 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3589 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
3591 if (len == 0) return build_ascstring ("");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3593 nargs0 = len + len - 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3594 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
3595
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3596 /* 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
3597 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
3598 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
3599 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
3600 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3601 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
3602 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3603 args0[i] = XCAR (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3604 sequence = XCDR (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3605 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3606 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3607 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3608 {
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3609 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3610 SOME_OR_EVERY_NEITHER);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3611 }
428
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 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
3614 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
3615
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3616 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
3617 args0[i] = separator;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3618
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3619 return Fconcat (nargs0, args0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3622 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
3623 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
3624 The result is a list of the same length as SEQUENCE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 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
3626
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3627 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
3628 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
3629 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
3630 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
3631
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3632 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3633 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3634 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3635 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3636 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
3637 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
3638 Lisp_Object *args0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3639 int i;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3640
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3641 for (i = 1; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3642 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3643 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3644 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3645 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3646
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3647 args0 = alloca_array (Lisp_Object, len);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3648 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3649 SOME_OR_EVERY_NEITHER);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3650
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3651 return Flist ((int) len, args0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3654 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
3655 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
3656 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
3657 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
3658
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3659 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
3660 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
3661 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
3662 `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
3663
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3664 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3666 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3668 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
3669 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
3670 Lisp_Object result;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671 struct gcpro gcpro1;
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3672 int i;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3673
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3674 for (i = 1; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3675 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3676 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3677 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3678 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3679
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3680 result = make_vector (len, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3681 GCPRO1 (result);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3682 /* 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
3683 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
3684 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3685 SOME_OR_EVERY_NEITHER);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686 UNGCPRO;
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 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3691 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
3692 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
3693
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3694 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
3695 together using `nconc'.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3696
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3697 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
3698 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
3699 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
3700 `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
3701
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3702 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
3703 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3704 (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
3705 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3706 Lisp_Object function = args[0], nconcing;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3707 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
3708 Lisp_Object *args0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3709 struct gcpro gcpro1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3710 int i;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3711
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3712 for (i = 1; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3713 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3714 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3715 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3716 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3717
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3718 args0 = alloca_array (Lisp_Object, len + 1);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3719 mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3720 SOME_OR_EVERY_NEITHER);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3721
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3722 if (len < 2)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3723 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3724 return len ? args0[1] : Qnil;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3725 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3726
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3727 /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3728 mapcarX is no longer doing this for us. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3729 args0[0] = Fcons (Qnil, Qnil);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3730 GCPRO1 (args0[0]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3731 gcpro1.nvars = len + 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3732
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3733 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
3734 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3735 nconcing = bytecode_nconc2 (args0 + i);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3736 args0[i + 1] = nconcing;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3737 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3738
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3739 RETURN_UNGCPRO (XCDR (nconcing));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3740 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3741
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3742 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
3743 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
3744
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 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
3746 This function is like `mapcar' but does not accumulate the results,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3747 which is more efficient if you do not use the results.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3749 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
3750 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
3751 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
3752 `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
3753
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3754 Return SEQUENCE.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3755
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3756 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
3757 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3758 (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
3759 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3760 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
3761 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
3762 struct gcpro gcpro1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3763 int i;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3764
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3765 for (i = 1; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3766 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3767 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3768 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3769 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3770
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3771 /* 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
3772 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
3773 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
3774 GCPRO1 (sequence);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3775 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3776 SOME_OR_EVERY_NEITHER);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3777 RETURN_UNGCPRO (sequence);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3778 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3779
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3780 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
3781 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
3782
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3783 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
3784 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
3785
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3786 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
3787 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
3788
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3789 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
3790 `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
3791 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
3792
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3793 arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 */
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3795 (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
3796 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3797 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
3798 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
3799 Lisp_Object result = Qnil;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3800 Lisp_Object *args0 = NULL;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3801 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
3802 int i;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3803 struct gcpro gcpro1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3804
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3805 for (i = 2; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3806 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3807 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3808 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3809 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3810
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3811 if (!NILP (type))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3812 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3813 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
3814 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3815
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3816 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3817 SOME_OR_EVERY_NEITHER);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3818
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3819 if (EQ (type, Qnil))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3820 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3821 return result;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3822 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3823
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3824 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
3825 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3826 result = Fvector (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3827 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3828 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
3829 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3830 result = Fstring (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3831 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3832 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
3833 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3834 result = Flist (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3835 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3836 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
3837 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3838 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
3839 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3840 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3841 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3842 result = Flist (len, args0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3843 GCPRO1 (result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3844 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
3845 UNGCPRO;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3846 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3847
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3848 return result;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3849 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3850
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3851 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
3852 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
3853
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3854 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
3855
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3856 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
3857 \(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
3858 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
3859 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
3860
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3861 Return RESULT-SEQUENCE.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3862
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3863 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
3864 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3865 (int nargs, Lisp_Object *args))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 {
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3867 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
3868 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
3869 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
3870 int i;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3871
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3872 args[0] = function;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3873 args[1] = result_sequence;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3874
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3875 for (i = 1; i < nargs; ++i)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3876 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3877 CHECK_SEQUENCE (args[i]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3878 len = min (len, XINT (Flength (args[i])));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3879 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3880
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3881 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3882 SOME_OR_EVERY_NEITHER);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3883
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3884 return result_sequence;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3885 }
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3886
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3887 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
3888 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
3889
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3890 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
3891
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3892 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
3893 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
3894
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3895 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3896 */
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3897 (int nargs, Lisp_Object *args))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3898 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3899 Lisp_Object result_box = Fcons (Qnil, Qnil);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3900 struct gcpro gcpro1;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3901 Elemcount len = EMACS_INT_MAX;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3902 int i;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3903
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3904 GCPRO1 (result_box);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3905
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3906 for (i = 1; i < nargs; ++i)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3907 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3908 CHECK_SEQUENCE (args[i]);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3909 len = min (len, XINT (Flength (args[i])));
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3910 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3911
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3912 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3913 SOME_OR_EVERY_SOME);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3914
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3915 RETURN_UNGCPRO (XCAR (result_box));
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3916 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3917
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3918 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
3919 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
3920
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3921 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
3922 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
3923
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3924 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
3925
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3926 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3927 */
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3928 (int nargs, Lisp_Object *args))
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3929 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3930 Lisp_Object result_box = Fcons (Qt, Qnil);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3931 struct gcpro gcpro1;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3932 Elemcount len = EMACS_INT_MAX;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3933 int i;
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3934
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3935 GCPRO1 (result_box);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3936
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3937 for (i = 1; i < nargs; ++i)
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3938 {
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3939 CHECK_SEQUENCE (args[i]);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3940 len = min (len, XINT (Flength (args[i])));
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3941 }
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3942
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3943 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1,
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3944 SOME_OR_EVERY_EVERY);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3945
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3946 RETURN_UNGCPRO (XCAR (result_box));
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
3947 }
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3948
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3949 /* 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
3950 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
3951 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
3952
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3953 If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3954 values from FUNCTION; if NCONCP is non-zero, nconc them together.
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3955
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3956 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
3957 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
3958 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
3959
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3960 static Lisp_Object
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3961 maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp,
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3962 int nconcp)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3963 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3964 Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3965 Lisp_Object nconcing[2], accum = result, *args;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3966 struct gcpro gcpro1, gcpro2, gcpro3;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3967 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
3968
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3969 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
3970 args[0] = function;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3971 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
3972 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3973 args[i] = Qnil;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3974 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3975
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3976 if (nconcp)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3977 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3978 nconcing[0] = result;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3979 nconcing[1] = Qnil;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3980 GCPRO3 (args[0], nconcing[0], result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3981 gcpro1.nvars = 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3982 gcpro2.nvars = 2;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3983 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3984 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3985 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3986 GCPRO2 (args[0], result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3987 gcpro1.nvars = 1;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3988 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3989
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3990 while (continuing)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3991 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3992 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
3993 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3994 if (CONSP (lists[j]))
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3995 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3996 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
3997 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
3998 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
3999 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
4000 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4001 continuing = 0;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4002 break;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4003 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4004 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4005 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4006 dead_wrong_type_argument (Qlistp, lists[j]);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4007 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4008 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4009 if (!continuing) break;
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4010 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args));
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4011 if (!maplp)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4012 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4013 if (nconcp)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4014 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4015 /* This order of calls means we check that each list is
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4016 well-formed once and once only. The last result does
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4017 not have to be a list. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4018 nconcing[1] = funcalled;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4019 nconcing[0] = bytecode_nconc2 (nconcing);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4020 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4021 else
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4022 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4023 /* Add to the end, avoiding the need to call nreverse
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4024 once we're done: */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4025 XSETCDR (accum, Fcons (funcalled, Qnil));
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4026 accum = XCDR (accum);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4027 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4028 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4029
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4030 if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4031
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4032 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
4033 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4034 EXTERNAL_LIST_LOOP_1 (lists[j])
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4035 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4036 /* Just check the lists aren't circular, using the
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4037 EXTERNAL_LIST_LOOP_1 macro. */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4038 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4039 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4040 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4041
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4042 if (!maplp)
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4043 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4044 result = XCDR (result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4045 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4046
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4047 RETURN_UNGCPRO (result);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4048 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4049
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4050 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
4051 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
4052 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
4053 the elements themselves."
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4054
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4055 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
4056 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4057 (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
4058 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4059 return maplist (args[0], nargs - 1, args + 1, 0, 0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4060 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4061
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4062 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
4063 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
4064
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4065 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
4066 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4067 (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
4068 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4069 return maplist (args[0], nargs - 1, args + 1, 1, 0);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4070 }
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4071
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4072 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
4073 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
4074
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4075 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
4076 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
4077
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4078 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
4079 */
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4080 (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
4081 {
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4082 return maplist (args[0], nargs - 1, args + 1, 0, 1);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4083 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4084
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4085 /* Extra random functions */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4086
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4087 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4088 Destructively replace the list OLD with NEW.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4089 This is like (copy-sequence NEW) except that it reuses the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4090 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
4091 length, no consing will take place.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4092 */
3025
facf3239ba30 [xemacs-hg @ 2005-10-25 11:16:19 by ben]
ben
parents: 2720
diff changeset
4093 (old, new_))
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4094 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4095 Lisp_Object oldtail = old, prevoldtail = Qnil;
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4096
3025
facf3239ba30 [xemacs-hg @ 2005-10-25 11:16:19 by ben]
ben
parents: 2720
diff changeset
4097 EXTERNAL_LIST_LOOP_2 (elt, new_)
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4098 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4099 if (!NILP (oldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4100 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4101 CHECK_CONS (oldtail);
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4102 XCAR (oldtail) = elt;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4103 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4104 else if (!NILP (prevoldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4105 {
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4106 XCDR (prevoldtail) = Fcons (elt, Qnil);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4107 prevoldtail = XCDR (prevoldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4108 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4109 else
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4110 old = oldtail = Fcons (elt, Qnil);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4111
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4112 if (!NILP (oldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4113 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4114 prevoldtail = oldtail;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4115 oldtail = XCDR (oldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4116 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4117 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4118
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4119 if (!NILP (prevoldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4120 XCDR (prevoldtail) = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4121 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4122 old = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4123
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4124 return old;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4125 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4126
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4127
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4128 Lisp_Object
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4129 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
4130 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4131 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
4132 build_ascstring (ascii_string)),
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4133 Qnil);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4134 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4135
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4136 Lisp_Object
2367
ecf1ebac70d8 [xemacs-hg @ 2004-11-04 23:05:23 by ben]
ben
parents: 2286
diff changeset
4137 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
4138 {
4952
19a72041c5ed Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents: 4797
diff changeset
4139 return Fintern (concat2 (build_ascstring (ascii_string),
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4140 Fsymbol_name (symbol)),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4141 Qnil);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4142 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4143
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4144
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4145 /* #### this function doesn't belong in this file! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4146
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4147 #ifdef HAVE_GETLOADAVG
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4148 #ifdef HAVE_SYS_LOADAVG_H
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4149 #include <sys/loadavg.h>
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4150 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4151 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4152 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4153 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4154
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4155 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4156 Return list of 1 minute, 5 minute and 15 minute load averages.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4157 Each of the three load averages is multiplied by 100,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4158 then converted to integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4159
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4160 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
4161 These floats are not multiplied by 100.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4163 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
4164 shortened list, containing only those averages which are available.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4165
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4166 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
4167 in which case you can't use this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4168 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4169 (use_floats))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4170 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4171 double load_ave[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4172 int loads = getloadavg (load_ave, countof (load_ave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4173 Lisp_Object ret = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4174
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4175 if (loads == -2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4176 signal_error (Qunimplemented,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4177 "load-average not implemented for this operating system",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4178 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4179 else if (loads < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4180 invalid_operation ("Could not get load-average", lisp_strerror (errno));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4181
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4182 while (loads-- > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4183 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4184 Lisp_Object load = (NILP (use_floats) ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4185 make_int ((int) (100.0 * load_ave[loads]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4186 : make_float (load_ave[loads]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4187 ret = Fcons (load, ret);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4188 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4189 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4190 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4191
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4192
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4193 Lisp_Object Vfeatures;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4194
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4195 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4196 Return non-nil if feature FEXP is present in this Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4197 Use this to conditionalize execution of lisp code based on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4198 presence or absence of emacs or environment extensions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4199 FEXP can be a symbol, a number, or a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4200 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
4201 and non-nil will be returned if found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4202 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
4203 has an equal or greater version number than FEXP.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4204 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
4205 non-nil if all the features in its cdr are non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4206 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
4207 if any of the features in its cdr are non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4208 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
4209 non-nil if the feature is not present.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4210
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4211 Examples:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4212
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4213 (featurep 'xemacs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4214 => ; Non-nil on XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4215
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4216 (featurep '(and xemacs gnus))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4217 => ; Non-nil on XEmacs with Gnus loaded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4218
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4219 (featurep '(or tty-frames (and emacs 19.30)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4220 => ; Non-nil if this Emacs supports TTY frames.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4221
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4222 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4223 => ; 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
4224
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4225 (featurep '(and xemacs 21.02))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4226 => ; Non-nil on XEmacs 21.2 and later.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4227
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4228 NOTE: The advanced arguments of this function (anything other than a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4229 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
4230 for supporting multiple Emacs variants, lobby Richard Stallman at
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4231 <bug-gnu-emacs@gnu.org>.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4232 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4233 (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4234 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4235 #ifndef FEATUREP_SYNTAX
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4236 CHECK_SYMBOL (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4237 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4238 #else /* FEATUREP_SYNTAX */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4239 static double featurep_emacs_version;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4241 /* Brute force translation from Erik Naggum's lisp function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4242 if (SYMBOLP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4243 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4244 /* Original definition */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4245 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4246 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4247 else if (INTP (fexp) || FLOATP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4248 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4249 double d = extract_float (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4250
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4251 if (featurep_emacs_version == 0.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4252 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4253 featurep_emacs_version = XINT (Vemacs_major_version) +
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4254 (XINT (Vemacs_minor_version) / 100.0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4255 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4256 return featurep_emacs_version >= d ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4257 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4258 else if (CONSP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4259 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4260 Lisp_Object tem = XCAR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4261 if (EQ (tem, Qnot))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4262 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4263 Lisp_Object negate;
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 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4266 negate = Fcar (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4267 if (!NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4268 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4269 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4270 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4271 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4272 else if (EQ (tem, Qand))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4273 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4274 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4275 /* Use Fcar/Fcdr for error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4276 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
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 tem = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4279 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4280 return NILP (tem) ? Qt : Qnil;
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 else if (EQ (tem, Qor))
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 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4285 /* Use Fcar/Fcdr for error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4286 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4287 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4288 tem = Fcdr (tem);
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 return NILP (tem) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4291 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4292 else
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 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4297 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4298 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4299 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
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 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4302 #endif /* FEATUREP_SYNTAX */
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 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4305 Announce that FEATURE is a feature of the current Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4306 This function updates the value of the variable `features'.
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 (feature))
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 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4311 CHECK_SYMBOL (feature);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4312 if (!NILP (Vautoload_queue))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4313 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4314 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4315 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4316 Vfeatures = Fcons (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4317 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4318 return feature;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4319 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4320
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
4321 DEFUN ("require", Frequire, 1, 3, 0, /*
3842
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
4322 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
4323 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
4324 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
4325 the print name of FEATURE.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
4326 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
4327 `file-error' if loading the library fails.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
4328
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
4329 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
4330 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
4331 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
4332 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
4333 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
4334 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
4335 `invalid-state'.
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
4336
1c2a46ea1f78 [xemacs-hg @ 2007-02-22 16:53:20 by stephent]
stephent
parents: 3794
diff changeset
4337 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
4338 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
4339 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
4340 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
4341 requires an explicit \(eval-and-compile ...\) block.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4342 */
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
4343 (feature, filename, noerror))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4344 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4345 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4346 CHECK_SYMBOL (feature);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4347 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4348 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4349 if (!NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4350 return feature;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4351 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4352 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4353 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4354
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4355 /* Value saved here is to be restored into Vautoload_queue */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4356 record_unwind_protect (un_autoload, Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4357 Vautoload_queue = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4358
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
4359 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
4360 noerror, Qrequire, Qnil);
1067
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
4361 /* If load failed entirely, return nil. */
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
4362 if (NILP (tem))
a0a7ace216fe [xemacs-hg @ 2002-10-24 13:55:42 by youngs]
youngs
parents: 949
diff changeset
4363 return unbind_to_1 (speccount, Qnil);
428
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 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4366 if (NILP (tem))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4367 invalid_state ("Required feature was not provided", feature);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4368
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4369 /* Once loading finishes, don't undo it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4370 Vautoload_queue = Qt;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4371 return unbind_to_1 (speccount, feature);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4372 }
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4375 /* base64 encode/decode functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4377 Originally based on code from GNU recode. Ported to FSF Emacs by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4378 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4379 subsequently heavily hacked by Hrvoje Niksic. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4381 #define MIME_LINE_LENGTH 72
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 #define IS_ASCII(Character) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4384 ((Character) < 128)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4385 #define IS_BASE64(Character) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4386 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4388 /* 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
4389 static Ascbyte base64_value_to_char[64] =
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4390 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4391 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4392 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4393 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4394 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4395 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4396 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4397 '8', '9', '+', '/' /* 60-63 */
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
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4400 /* Table of base64 values for first 128 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4401 static short base64_char_to_value[128] =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4403 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4404 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4405 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4406 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4407 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4408 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4409 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4410 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4411 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4412 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4413 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4414 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4415 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4416 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4417
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4418 /* The following diagram shows the logical steps by which three octets
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4419 get transformed into four base64 characters.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4420
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4421 .--------. .--------. .--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4422 |aaaaaabb| |bbbbcccc| |ccdddddd|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4423 `--------' `--------' `--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4424 6 2 4 4 2 6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4425 .--------+--------+--------+--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4426 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4427 `--------+--------+--------+--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4429 .--------+--------+--------+--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4430 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4431 `--------+--------+--------+--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4433 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
4434 base64 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4435
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
4436 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
4437 Lisp_Object));
61855263cb07 [xemacs-hg @ 2004-09-14 14:32:29 by james]
james
parents: 2039
diff changeset
4438
575
d5e8f5ad5043 [xemacs-hg @ 2001-05-25 04:22:31 by martinb]
martinb
parents: 563
diff changeset
4439 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
4440 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
4441 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4442 signal_error (Qbase64_conversion_error, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4443 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4444
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4445 #define ADVANCE_INPUT(c, stream) \
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4446 ((ec = Lstream_get_ichar (stream)) == -1 ? 0 : \
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4447 ((ec > 255) ? \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4448 (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
4449 make_char (ec)), 0) \
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4450 : (c = (Ibyte)ec), 1))
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4451
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4452 static Bytebpos
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4453 base64_encode_1 (Lstream *istream, Ibyte *to, int line_break)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4454 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4455 EMACS_INT counter = 0;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4456 Ibyte *e = to;
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4457 Ichar ec;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4458 unsigned int value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4460 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4461 {
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1067
diff changeset
4462 Ibyte c = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4463 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4464 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4465
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4466 /* Wrap line every 76 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4467 if (line_break)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4468 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4469 if (counter < MIME_LINE_LENGTH / 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4470 counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4471 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4472 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4473 *e++ = '\n';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4474 counter = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4475 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4476 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4477
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4478 /* Process first byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4479 *e++ = base64_value_to_char[0x3f & c >> 2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4480 value = (0x03 & c) << 4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4482 /* Process second byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4483 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4484 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4485 *e++ = base64_value_to_char[value];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4486 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4487 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4488 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4489 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4490
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4491 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4492 value = (0x0f & c) << 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4494 /* Process third byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4495 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4496 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4497 *e++ = base64_value_to_char[value];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4498 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4499 break;
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 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4503 *e++ = base64_value_to_char[0x3f & c];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4504 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4506 return e - to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4507 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4508 #undef ADVANCE_INPUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4509
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4510 /* Get next character from the stream, except that non-base64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4511 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
4512 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
4513 #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
4514 ec = Lstream_get_ichar (stream); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4515 ++streampos; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4516 /* IS_BASE64 may not be called with negative arguments so check for \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4517 EOF first. */ \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4518 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4519 break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4520 } while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4521
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4522 #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
4523 pos += set_itext_ichar (pos, (Ichar)((Binbyte)(val))); \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4524 ++ccnt; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4525 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4526
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4527 static Bytebpos
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4528 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4529 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4530 Charcount ccnt = 0;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4531 Ibyte *e = to;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4532 EMACS_INT streampos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4533
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4534 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4535 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4536 Ichar ec;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4537 unsigned long value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4538
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4539 /* Process first byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4540 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4541 if (ec < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4542 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4543 if (ec == '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4544 base64_conversion_error ("Illegal `=' character while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4545 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4546 value = base64_char_to_value[ec] << 18;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4548 /* Process second byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4549 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4550 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4551 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4552 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4553 if (ec == '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4554 base64_conversion_error ("Illegal `=' character while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4555 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4556 value |= base64_char_to_value[ec] << 12;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4557 STORE_BYTE (e, value >> 16, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4558
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4559 /* Process third byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4560 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4561 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4562 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4563 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4564
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4565 if (ec == '=')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4566 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4567 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4568 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4569 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4570 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4571 if (ec != '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4572 base64_conversion_error
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4573 ("Padding `=' expected but not found while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4574 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4575 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4576 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4578 value |= base64_char_to_value[ec] << 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4579 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4580
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4581 /* Process fourth byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4582 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4583 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4584 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4585 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4586 if (ec == '=')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4587 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4588
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4589 value |= base64_char_to_value[ec];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4590 STORE_BYTE (e, 0xff & value, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4591 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4593 *ccptr = ccnt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4594 return e - to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4595 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4596 #undef ADVANCE_INPUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4597 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4598 #undef STORE_BYTE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4599
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4600 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4601 Base64-encode the region between START and END.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4602 Return the length of the encoded text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4603 Optional third argument NO-LINE-BREAK means do not break long lines
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4604 into shorter lines.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4605 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4606 (start, end, no_line_break))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4607 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4608 Ibyte *encoded;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4609 Bytebpos encoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4610 Charcount allength, length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4611 struct buffer *buf = current_buffer;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4612 Charbpos begv, zv, old_pt = BUF_PT (buf);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4613 Lisp_Object input;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4614 int speccount = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4615
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4616 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4617 barf_if_buffer_read_only (buf, begv, zv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4619 /* We need to allocate enough room for encoding the text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4620 We need 33 1/3% more space, plus a newline every 76
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4621 characters, and then we round up. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4622 length = zv - begv;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4623 allength = length + length/3 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4624 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4626 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
4627 /* 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
4628 base64 characters will be single-byte. */
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4629 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4630 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4631 NILP (no_line_break));
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
4632 assert (encoded_length <= allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4633 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4634
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4635 /* Now we have encoded the region, so we insert the new contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4636 and delete the old. (Insert first in order to preserve markers.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4637 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
4638 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4639 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4640
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4641 /* Simulate FSF Emacs implementation of this function: if point was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4642 in the region, place it at the beginning. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4643 if (old_pt >= begv && old_pt < zv)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4644 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4645
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4646 /* We return the length of the encoded text. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4647 return make_int (encoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4648 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4649
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4650 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4651 Base64 encode STRING and return the result.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4652 Optional argument NO-LINE-BREAK means do not break long lines
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4653 into shorter lines.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4654 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4655 (string, no_line_break))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4656 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4657 Charcount allength, length;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4658 Bytebpos encoded_length;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4659 Ibyte *encoded;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4660 Lisp_Object input, result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4661 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4662
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4663 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4664
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
4665 length = string_char_length (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4666 allength = length + length/3 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4667 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4668
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4669 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
4670 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4671 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4672 NILP (no_line_break));
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
4673 assert (encoded_length <= allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4674 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4675 result = make_string (encoded, encoded_length);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4676 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4677 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4678 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4679
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4680 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4681 Base64-decode the region between START and END.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4682 Return the length of the decoded text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4683 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
4684 Characters out of the base64 alphabet are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4685 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4686 (start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4687 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4688 struct buffer *buf = current_buffer;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4689 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
4690 Ibyte *decoded;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4691 Bytebpos decoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4692 Charcount length, cc_decoded_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4693 Lisp_Object input;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4694 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4695
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
4696 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4697 barf_if_buffer_read_only (buf, begv, zv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4699 length = zv - begv;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4700
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4701 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4702 /* 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
4703 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4704 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
4705 assert (decoded_length <= length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4706 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4707
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4708 /* Now we have decoded the region, so we insert the new contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4709 and delete the old. (Insert first in order to preserve markers.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4710 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4711 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
4712 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4713 buffer_delete_range (buf, begv + cc_decoded_length,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4714 zv + cc_decoded_length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4715
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4716 /* Simulate FSF Emacs implementation of this function: if point was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4717 in the region, place it at the beginning. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4718 if (old_pt >= begv && old_pt < zv)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4719 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4720
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4721 return make_int (cc_decoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4722 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4723
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4724 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4725 Base64-decode STRING and return the result.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4726 Characters out of the base64 alphabet are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4727 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4728 (string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4729 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4730 Ibyte *decoded;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
4731 Bytebpos decoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4732 Charcount length, cc_decoded_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4733 Lisp_Object input, result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4734 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4735
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4736 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4737
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
4738 length = string_char_length (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4739 /* 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
4740 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4741
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4742 input = make_lisp_string_input_stream (string, 0, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4743 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4744 &cc_decoded_length);
5050
6f2158fa75ed Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents: 5002
diff changeset
4745 assert (decoded_length <= length * MAX_ICHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4746 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4747
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4748 result = make_string (decoded, decoded_length);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
4749 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4750 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4751 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4752
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4753 Lisp_Object Qyes_or_no_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4754
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4755 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4756 syms_of_fns (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4757 {
5117
3742ea8250b5 Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents: 3025
diff changeset
4758 INIT_LISP_OBJECT (bit_vector);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4759
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4760 DEFSYMBOL (Qstring_lessp);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4761 DEFSYMBOL (Qidentity);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4762 DEFSYMBOL (Qvector);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4763 DEFSYMBOL (Qarray);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4764 DEFSYMBOL (Qstring);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4765 DEFSYMBOL (Qlist);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4766 DEFSYMBOL (Qbit_vector);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4767
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4768 DEFSYMBOL (Qyes_or_no_p);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4769
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
4770 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4771
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4772 DEFSUBR (Fidentity);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4773 DEFSUBR (Frandom);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4774 DEFSUBR (Flength);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4775 DEFSUBR (Fsafe_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4776 DEFSUBR (Fstring_equal);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
4777 DEFSUBR (Fcompare_strings);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4778 DEFSUBR (Fstring_lessp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4779 DEFSUBR (Fstring_modified_tick);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4780 DEFSUBR (Fappend);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4781 DEFSUBR (Fconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4782 DEFSUBR (Fvconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4783 DEFSUBR (Fbvconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4784 DEFSUBR (Fcopy_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4785 DEFSUBR (Fcopy_sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4786 DEFSUBR (Fcopy_alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4787 DEFSUBR (Fcopy_tree);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4788 DEFSUBR (Fsubseq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4789 DEFSUBR (Fnthcdr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4790 DEFSUBR (Fnth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4791 DEFSUBR (Felt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4792 DEFSUBR (Flast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4793 DEFSUBR (Fbutlast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4794 DEFSUBR (Fnbutlast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4795 DEFSUBR (Fmember);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4796 DEFSUBR (Fold_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4797 DEFSUBR (Fmemq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4798 DEFSUBR (Fold_memq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4799 DEFSUBR (Fassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4800 DEFSUBR (Fold_assoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4801 DEFSUBR (Fassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4802 DEFSUBR (Fold_assq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4803 DEFSUBR (Frassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4804 DEFSUBR (Fold_rassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4805 DEFSUBR (Frassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4806 DEFSUBR (Fold_rassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4807 DEFSUBR (Fdelete);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4808 DEFSUBR (Fold_delete);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4809 DEFSUBR (Fdelq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4810 DEFSUBR (Fold_delq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4811 DEFSUBR (Fremassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4812 DEFSUBR (Fremassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4813 DEFSUBR (Fremrassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4814 DEFSUBR (Fremrassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4815 DEFSUBR (Fnreverse);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4816 DEFSUBR (Freverse);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4817 DEFSUBR (Fsort);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4818 DEFSUBR (Fplists_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4819 DEFSUBR (Fplists_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4820 DEFSUBR (Flax_plists_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4821 DEFSUBR (Flax_plists_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4822 DEFSUBR (Fplist_get);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4823 DEFSUBR (Fplist_put);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4824 DEFSUBR (Fplist_remprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4825 DEFSUBR (Fplist_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4826 DEFSUBR (Fcheck_valid_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4827 DEFSUBR (Fvalid_plist_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4828 DEFSUBR (Fcanonicalize_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4829 DEFSUBR (Flax_plist_get);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4830 DEFSUBR (Flax_plist_put);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4831 DEFSUBR (Flax_plist_remprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4832 DEFSUBR (Flax_plist_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4833 DEFSUBR (Fcanonicalize_lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4834 DEFSUBR (Fdestructive_alist_to_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4835 DEFSUBR (Fget);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4836 DEFSUBR (Fput);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4837 DEFSUBR (Fremprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4838 DEFSUBR (Fobject_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4839 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
4840 DEFSUBR (Fequalp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4841 DEFSUBR (Fold_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4842 DEFSUBR (Ffillarray);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4843 DEFSUBR (Fnconc);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4844 DEFSUBR (FmapcarX);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4845 DEFSUBR (Fmapvector);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4846 DEFSUBR (Fmapcan);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4847 DEFSUBR (Fmapc);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4848 DEFSUBR (Fmapconcat);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4849 DEFSUBR (Fmap);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4850 DEFSUBR (Fmap_into);
4997
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4851 DEFSUBR (Fsome);
8800b5350a13 Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4996
diff changeset
4852 DEFSUBR (Fevery);
4995
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4853 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
4854 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
4855 DEFSUBR (Fmaplist);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4856 DEFSUBR (Fmapl);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4857 DEFSUBR (Fmapcon);
8431b52e43b1 Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents: 4797
diff changeset
4858
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4859 DEFSUBR (Freplace_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4860 DEFSUBR (Fload_average);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4861 DEFSUBR (Ffeaturep);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4862 DEFSUBR (Frequire);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4863 DEFSUBR (Fprovide);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4864 DEFSUBR (Fbase64_encode_region);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4865 DEFSUBR (Fbase64_encode_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4866 DEFSUBR (Fbase64_decode_region);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4867 DEFSUBR (Fbase64_decode_string);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4868
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4869 DEFSUBR (Fsplit_string_by_char);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4870 DEFSUBR (Fsplit_path); /* #### */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4871 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4872
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4873 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4874 vars_of_fns (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4875 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4876 DEFVAR_LISP ("path-separator", &Vpath_separator /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4877 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
4878 */ );
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4879 {
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
4880 Ascbyte c = SEPCHAR;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 853
diff changeset
4881 Vpath_separator = make_string ((Ibyte *) &c, 1);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4882 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4883 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4884
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4885 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4886 init_provide_once (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4887 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4888 DEFVAR_LISP ("features", &Vfeatures /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4889 A list of symbols which are the features of the executing emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4890 Used by `featurep' and `require', and altered by `provide'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4891 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4892 Vfeatures = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4893
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4894 Fprovide (intern ("base64"));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4895 }