Mercurial > hg > xemacs-beta
annotate src/fns.c @ 5887:6eca500211f4
Prototype for X509_check_host() has changed, detect this in configure.ac
ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* configure.ac:
If X509_check_host() is available, check the number of arguments
it takes. Don't use it if it takes any number of arguments other
than five. Also don't use it if <openssl/x509v3.h> does not
declare it, since if that is so there is no portable way to tell
how many arguments it should take, and so we would end up smashing
the stack.
* configure: Regenerate.
src/ChangeLog addition:
2015-04-09 Aidan Kehoe <kehoea@parhasard.net>
* tls.c:
#include <openssl/x509v3.h> for its prototype for
X509_check_host().
* tls.c (tls_open):
Pass the new fifth argument to X509_check_host().
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 09 Apr 2015 14:27:02 +0100 |
| parents | 1a507c4c6c42 |
| children | e2fae7783046 |
| rev | line source |
|---|---|
| 428 | 1 /* Random utility Lisp functions. |
| 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 | 4 |
| 5 This file is part of XEmacs. | |
| 6 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5277
diff
changeset
|
7 XEmacs is free software: you can redistribute it and/or modify it |
| 428 | 8 under the terms of the GNU General Public License as published by the |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5277
diff
changeset
|
9 Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5277
diff
changeset
|
10 option) any later version. |
| 428 | 11 |
| 12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
| 13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
| 14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
| 15 for more details. | |
| 16 | |
| 17 You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5277
diff
changeset
|
18 along with XEmacs. If not, see <http://www.gnu.org/licenses/>. */ |
| 428 | 19 |
| 20 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
| 21 | |
| 22 /* This file has been Mule-ized. */ | |
| 23 | |
| 24 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */ | |
| 25 | |
| 26 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */ | |
| 27 | |
| 28 #include <config.h> | |
| 29 | |
| 30 /* Note on some machines this defines `vector' as a typedef, | |
| 31 so make sure we don't use that name in this file. */ | |
| 32 #undef vector | |
| 33 #define vector ***** | |
| 34 | |
| 35 #include "lisp.h" | |
| 36 | |
| 442 | 37 #include "sysfile.h" |
| 771 | 38 #include "sysproc.h" /* for qxe_getpid() */ |
| 428 | 39 |
| 40 #include "buffer.h" | |
| 41 #include "bytecode.h" | |
| 42 #include "device.h" | |
| 43 #include "events.h" | |
| 44 #include "extents.h" | |
| 45 #include "frame.h" | |
| 872 | 46 #include "process.h" |
| 428 | 47 #include "systime.h" |
| 48 #include "insdel.h" | |
| 49 #include "lstream.h" | |
| 50 #include "opaque.h" | |
| 51 | |
| 52 /* NOTE: This symbol is also used in lread.c */ | |
| 53 #define FEATUREP_SYNTAX | |
| 54 | |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
55 extern Fixnum max_lisp_eval_depth; |
|
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
56 extern int lisp_eval_depth; |
|
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
57 |
|
5607
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
58 Lisp_Object Qmapl, Qmapcon, Qmaplist, Qbase64_conversion_error; |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
59 |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
60 Lisp_Object Vpath_separator; |
| 428 | 61 |
| 62 DEFUN ("identity", Fidentity, 1, 1, 0, /* | |
| 63 Return the argument unchanged. | |
| 64 */ | |
| 65 (arg)) | |
| 66 { | |
| 67 return arg; | |
| 68 } | |
| 69 | |
| 70 DEFUN ("random", Frandom, 0, 1, 0, /* | |
| 71 Return a pseudo-random number. | |
| 1983 | 72 All fixnums are equally likely. On most systems, this is 31 bits' worth. |
|
5302
6468cf6f0b9d
Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
73 With positive integer argument LIMIT, return random number in interval [0, |
|
6468cf6f0b9d
Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
74 LIMIT). LIMIT can be a bignum, in which case the range of possible values |
|
6468cf6f0b9d
Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
75 is extended. With argument t, set the random number seed from the current |
|
6468cf6f0b9d
Correct argument name in docstring, #'random.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5300
diff
changeset
|
76 time and pid. |
| 428 | 77 */ |
| 78 (limit)) | |
| 79 { | |
| 80 EMACS_INT val; | |
| 81 unsigned long denominator; | |
| 82 | |
| 83 if (EQ (limit, Qt)) | |
| 771 | 84 seed_random (qxe_getpid () + time (NULL)); |
| 428 | 85 if (NATNUMP (limit) && !ZEROP (limit)) |
| 86 { | |
|
5307
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
87 #ifdef HAVE_BIGNUM |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
88 if (BIGNUMP (limit)) |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
89 { |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
90 bignum_random (scratch_bignum, XBIGNUM_DATA (limit)); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
91 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
92 } |
|
c096d8051f89
Have NATNUMP give t for positive bignums; check limits appropriately.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5306
diff
changeset
|
93 #endif |
| 428 | 94 /* Try to take our random number from the higher bits of VAL, |
| 95 not the lower, since (says Gentzel) the low bits of `random' | |
| 96 are less random than the higher ones. We do this by using the | |
| 97 quotient rather than the remainder. At the high end of the RNG | |
| 98 it's possible to get a quotient larger than limit; discarding | |
| 99 these values eliminates the bias that would otherwise appear | |
| 100 when using a large limit. */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
101 denominator = ((unsigned long)1 << FIXNUM_VALBITS) / XFIXNUM (limit); |
| 428 | 102 do |
| 103 val = get_random () / denominator; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
104 while (val >= XFIXNUM (limit)); |
| 428 | 105 } |
| 106 else | |
| 107 val = get_random (); | |
| 108 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
109 return make_fixnum (val); |
| 428 | 110 } |
| 111 | |
| 112 /* Random data-structure functions */ | |
| 113 | |
| 114 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
|
115 check_losing_bytecode (const Ascbyte *function, Lisp_Object seq) |
| 428 | 116 { |
| 117 if (COMPILED_FUNCTIONP (seq)) | |
| 563 | 118 signal_ferror_with_frob |
| 119 (Qinvalid_argument, seq, | |
| 428 | 120 "As of 20.3, `%s' no longer works with compiled-function objects", |
| 121 function); | |
| 122 } | |
| 123 | |
| 124 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /* | |
| 125 Return the length of a list, but avoid error or infinite loop. | |
| 126 This function never gets an error. If LIST is not really a list, | |
| 127 it returns 0. If LIST is circular, it returns a finite value | |
| 128 which is at least the number of distinct elements. | |
| 129 */ | |
| 130 (list)) | |
| 131 { | |
| 132 Lisp_Object hare, tortoise; | |
| 665 | 133 Elemcount len; |
| 428 | 134 |
| 135 for (hare = tortoise = list, len = 0; | |
| 136 CONSP (hare) && (! EQ (hare, tortoise) || len == 0); | |
| 137 hare = XCDR (hare), len++) | |
| 138 { | |
| 139 if (len & 1) | |
| 140 tortoise = XCDR (tortoise); | |
| 141 } | |
| 142 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
143 return make_fixnum (len); |
| 428 | 144 } |
| 145 | |
|
5273
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
146 /* This is almost the above, but is defined by Common Lisp. We need it in C |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
147 for shortest_length_among_sequences(), below, for the various sequence |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
148 functions that can usefully operate on circular lists. */ |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
149 |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
150 DEFUN ("list-length", Flist_length, 1, 1, 0, /* |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
151 Return the length of LIST. Return nil if LIST is circular. |
|
5299
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
152 Error if LIST is dotted. |
|
5273
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
153 */ |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
154 (list)) |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
155 { |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
156 Lisp_Object hare, tortoise; |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
157 Elemcount len; |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
158 |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
159 for (hare = tortoise = list, len = 0; |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
160 CONSP (hare) && (! EQ (hare, tortoise) || len == 0); |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
161 hare = XCDR (hare), len++) |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
162 { |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
163 if (len & 1) |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
164 tortoise = XCDR (tortoise); |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
165 } |
|
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
166 |
|
5299
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
167 if (!LISTP (hare)) |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
168 { |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
169 signal_malformed_list_error (list); |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
170 } |
|
28651c24b3f8
Error in #'list-length if LIST is dotted; check for this error with #'mapcar
Aidan Kehoe <kehoea@parhasard.net>
parents:
5285
diff
changeset
|
171 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
172 return EQ (hare, tortoise) && len != 0 ? Qnil : make_fixnum (len); |
|
5273
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
173 } |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
174 |
| 428 | 175 /*** string functions. ***/ |
| 176 | |
| 177 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* | |
| 178 Return t if two strings have identical contents. | |
| 179 Case is significant. Text properties are ignored. | |
| 180 \(Under XEmacs, `equal' also ignores text properties and extents in | |
| 181 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20 | |
| 182 `equal' is the same as in XEmacs, in that respect.) | |
| 183 Symbols are also allowed; their print names are used instead. | |
| 184 */ | |
| 444 | 185 (string1, string2)) |
| 428 | 186 { |
| 187 Bytecount len; | |
| 793 | 188 Lisp_Object p1, p2; |
| 428 | 189 |
| 444 | 190 if (SYMBOLP (string1)) |
| 191 p1 = XSYMBOL (string1)->name; | |
| 428 | 192 else |
| 193 { | |
| 444 | 194 CHECK_STRING (string1); |
| 793 | 195 p1 = string1; |
| 428 | 196 } |
| 197 | |
| 444 | 198 if (SYMBOLP (string2)) |
| 199 p2 = XSYMBOL (string2)->name; | |
| 428 | 200 else |
| 201 { | |
| 444 | 202 CHECK_STRING (string2); |
| 793 | 203 p2 = string2; |
| 428 | 204 } |
| 205 | |
| 793 | 206 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) && |
| 207 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil; | |
| 428 | 208 } |
| 209 | |
| 801 | 210 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /* |
| 211 Compare the contents of two strings, maybe ignoring case. | |
| 212 In string STR1, skip the first START1 characters and stop at END1. | |
| 213 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
|
214 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
|
215 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
|
216 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
|
217 |
|
c45fdd4e1858
Don't args-out-of-range in compare-strings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4693
diff
changeset
|
218 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
|
219 Case is significant by default. |
| 801 | 220 |
| 221 The value is t if the strings (or specified portions) match. | |
| 222 If string STR1 is less, the value is a negative number N; | |
| 223 - 1 - N is the number of characters that match at the beginning. | |
| 224 If string STR1 is greater, the value is a positive number N; | |
| 225 N - 1 is the number of characters that match at the beginning. | |
| 226 */ | |
| 227 (str1, start1, end1, str2, start2, end2, ignore_case)) | |
| 228 { | |
| 229 Charcount ccstart1, ccend1, ccstart2, ccend2; | |
| 230 Bytecount bstart1, blen1, bstart2, blen2; | |
| 231 Charcount matching; | |
| 232 int res; | |
| 233 | |
| 234 CHECK_STRING (str1); | |
| 235 CHECK_STRING (str2); | |
| 236 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
|
237 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
| 801 | 238 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
|
239 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE); |
| 801 | 240 |
| 241 bstart1 = string_index_char_to_byte (str1, ccstart1); | |
| 242 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1); | |
| 243 bstart2 = string_index_char_to_byte (str2, ccstart2); | |
| 244 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2); | |
| 245 | |
| 246 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching) | |
| 247 (XSTRING_DATA (str1) + bstart1, blen1, | |
| 248 XSTRING_DATA (str2) + bstart2, blen2, | |
| 249 &matching)); | |
| 250 | |
| 251 if (!res) | |
| 252 return Qt; | |
| 253 else if (res > 0) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
254 return make_fixnum (1 + matching); |
| 801 | 255 else |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
256 return make_fixnum (-1 - matching); |
| 801 | 257 } |
| 258 | |
| 428 | 259 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /* |
| 260 Return t if first arg string is less than second in lexicographic order. | |
| 771 | 261 Comparison is simply done on a character-by-character basis using the |
| 262 numeric value of a character. (Note that this may not produce | |
| 263 particularly meaningful results under Mule if characters from | |
| 264 different charsets are being compared.) | |
| 428 | 265 |
| 266 Symbols are also allowed; their print names are used instead. | |
| 267 | |
| 771 | 268 Currently we don't do proper language-specific collation or handle |
| 269 multiple character sets. This may be changed when Unicode support | |
| 270 is implemented. | |
| 428 | 271 */ |
| 444 | 272 (string1, string2)) |
| 428 | 273 { |
| 793 | 274 Lisp_Object p1, p2; |
| 428 | 275 Charcount end, len2; |
| 276 int i; | |
| 277 | |
| 444 | 278 if (SYMBOLP (string1)) |
| 279 p1 = XSYMBOL (string1)->name; | |
| 793 | 280 else |
| 281 { | |
| 444 | 282 CHECK_STRING (string1); |
| 793 | 283 p1 = string1; |
| 428 | 284 } |
| 285 | |
| 444 | 286 if (SYMBOLP (string2)) |
| 287 p2 = XSYMBOL (string2)->name; | |
| 428 | 288 else |
| 289 { | |
| 444 | 290 CHECK_STRING (string2); |
| 793 | 291 p2 = string2; |
| 428 | 292 } |
| 293 | |
| 826 | 294 end = string_char_length (p1); |
| 295 len2 = string_char_length (p2); | |
| 428 | 296 if (end > len2) |
| 297 end = len2; | |
| 298 | |
| 299 { | |
| 867 | 300 Ibyte *ptr1 = XSTRING_DATA (p1); |
| 301 Ibyte *ptr2 = XSTRING_DATA (p2); | |
| 428 | 302 |
| 303 /* #### It is not really necessary to do this: We could compare | |
| 304 byte-by-byte and still get a reasonable comparison, since this | |
| 305 would compare characters with a charset in the same way. With | |
| 306 a little rearrangement of the leading bytes, we could make most | |
| 307 inter-charset comparisons work out the same, too; even if some | |
| 308 don't, this is not a big deal because inter-charset comparisons | |
| 309 aren't really well-defined anyway. */ | |
| 310 for (i = 0; i < end; i++) | |
| 311 { | |
| 867 | 312 if (itext_ichar (ptr1) != itext_ichar (ptr2)) |
| 313 return itext_ichar (ptr1) < itext_ichar (ptr2) ? Qt : Qnil; | |
| 314 INC_IBYTEPTR (ptr1); | |
| 315 INC_IBYTEPTR (ptr2); | |
| 428 | 316 } |
| 317 } | |
| 318 /* Can't do i < len2 because then comparison between "foo" and "foo^@" | |
| 319 won't work right in I18N2 case */ | |
| 320 return end < len2 ? Qt : Qnil; | |
| 321 } | |
| 322 | |
| 323 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /* | |
| 324 Return STRING's tick counter, incremented for each change to the string. | |
| 325 Each string has a tick counter which is incremented each time the contents | |
| 326 of the string are changed (e.g. with `aset'). It wraps around occasionally. | |
| 327 */ | |
| 328 (string)) | |
| 329 { | |
| 330 CHECK_STRING (string); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
331 if (CONSP (XSTRING_PLIST (string)) && FIXNUMP (XCAR (XSTRING_PLIST (string)))) |
| 793 | 332 return XCAR (XSTRING_PLIST (string)); |
| 428 | 333 else |
| 334 return Qzero; | |
| 335 } | |
| 336 | |
| 337 void | |
| 338 bump_string_modiff (Lisp_Object str) | |
| 339 { | |
| 793 | 340 Lisp_Object *ptr = &XSTRING_PLIST (str); |
| 428 | 341 |
| 342 #ifdef I18N3 | |
| 343 /* #### remove the `string-translatable' property from the string, | |
| 344 if there is one. */ | |
| 345 #endif | |
| 346 /* skip over extent info if it's there */ | |
| 347 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) | |
| 348 ptr = &XCDR (*ptr); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
349 if (CONSP (*ptr) && FIXNUMP (XCAR (*ptr))) |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
350 XCAR (*ptr) = make_fixnum (1+XFIXNUM (XCAR (*ptr))); |
| 428 | 351 else |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
352 *ptr = Fcons (make_fixnum (1), *ptr); |
| 428 | 353 } |
| 354 | |
| 355 | |
| 356 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector }; | |
| 357 static Lisp_Object concat (int nargs, Lisp_Object *args, | |
| 358 enum concat_target_type target_type, | |
| 359 int last_special); | |
| 360 | |
| 361 Lisp_Object | |
| 444 | 362 concat2 (Lisp_Object string1, Lisp_Object string2) |
| 428 | 363 { |
| 364 Lisp_Object args[2]; | |
| 444 | 365 args[0] = string1; |
| 366 args[1] = string2; | |
| 428 | 367 return concat (2, args, c_string, 0); |
| 368 } | |
| 369 | |
| 370 Lisp_Object | |
| 444 | 371 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3) |
| 428 | 372 { |
| 373 Lisp_Object args[3]; | |
| 444 | 374 args[0] = string1; |
| 375 args[1] = string2; | |
| 376 args[2] = string3; | |
| 428 | 377 return concat (3, args, c_string, 0); |
| 378 } | |
| 379 | |
| 380 Lisp_Object | |
| 444 | 381 vconcat2 (Lisp_Object vec1, Lisp_Object vec2) |
| 428 | 382 { |
| 383 Lisp_Object args[2]; | |
| 444 | 384 args[0] = vec1; |
| 385 args[1] = vec2; | |
| 428 | 386 return concat (2, args, c_vector, 0); |
| 387 } | |
| 388 | |
| 389 Lisp_Object | |
| 444 | 390 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3) |
| 428 | 391 { |
| 392 Lisp_Object args[3]; | |
| 444 | 393 args[0] = vec1; |
| 394 args[1] = vec2; | |
| 395 args[2] = vec3; | |
| 428 | 396 return concat (3, args, c_vector, 0); |
| 397 } | |
| 398 | |
| 399 DEFUN ("append", Fappend, 0, MANY, 0, /* | |
| 400 Concatenate all the arguments and make the result a list. | |
| 401 The result is a list whose elements are the elements of all the arguments. | |
| 402 Each argument may be a list, vector, bit vector, or string. | |
| 403 The last argument is not copied, just used as the tail of the new list. | |
| 404 Also see: `nconc'. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
405 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
406 arguments: (&rest ARGS) |
| 428 | 407 */ |
| 408 (int nargs, Lisp_Object *args)) | |
| 409 { | |
| 410 return concat (nargs, args, c_cons, 1); | |
| 411 } | |
| 412 | |
| 413 DEFUN ("concat", Fconcat, 0, MANY, 0, /* | |
| 414 Concatenate all the arguments and make the result a string. | |
| 415 The result is a string whose elements are the elements of all the arguments. | |
| 416 Each argument may be a string or a list or vector of characters. | |
| 417 | |
| 418 As of XEmacs 21.0, this function does NOT accept individual integers | |
| 419 as arguments. Old code that relies on, for example, (concat "foo" 50) | |
| 420 returning "foo50" will fail. To fix such code, either apply | |
| 421 `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
|
422 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
423 arguments: (&rest ARGS) |
| 428 | 424 */ |
| 425 (int nargs, Lisp_Object *args)) | |
| 426 { | |
| 427 return concat (nargs, args, c_string, 0); | |
| 428 } | |
| 429 | |
| 430 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /* | |
| 431 Concatenate all the arguments and make the result a vector. | |
| 432 The result is a vector whose elements are the elements of all the arguments. | |
| 433 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
|
434 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
435 arguments: (&rest ARGS) |
| 428 | 436 */ |
| 437 (int nargs, Lisp_Object *args)) | |
| 438 { | |
| 439 return concat (nargs, args, c_vector, 0); | |
| 440 } | |
| 441 | |
| 442 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /* | |
| 443 Concatenate all the arguments and make the result a bit vector. | |
| 444 The result is a bit vector whose elements are the elements of all the | |
| 445 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
|
446 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
447 arguments: (&rest ARGS) |
| 428 | 448 */ |
| 449 (int nargs, Lisp_Object *args)) | |
| 450 { | |
| 451 return concat (nargs, args, c_bit_vector, 0); | |
| 452 } | |
| 453 | |
| 454 /* Copy a (possibly dotted) list. LIST must be a cons. | |
| 455 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */ | |
| 456 static Lisp_Object | |
| 457 copy_list (Lisp_Object list) | |
| 458 { | |
| 459 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); | |
| 460 Lisp_Object last = list_copy; | |
| 461 Lisp_Object hare, tortoise; | |
| 665 | 462 Elemcount len; |
| 428 | 463 |
| 464 for (tortoise = hare = XCDR (list), len = 1; | |
| 465 CONSP (hare); | |
| 466 hare = XCDR (hare), len++) | |
| 467 { | |
| 468 XCDR (last) = Fcons (XCAR (hare), XCDR (hare)); | |
| 469 last = XCDR (last); | |
| 470 | |
| 471 if (len < CIRCULAR_LIST_SUSPICION_LENGTH) | |
| 472 continue; | |
| 473 if (len & 1) | |
| 474 tortoise = XCDR (tortoise); | |
| 475 if (EQ (tortoise, hare)) | |
| 476 signal_circular_list_error (list); | |
| 477 } | |
| 478 | |
| 479 return list_copy; | |
| 480 } | |
| 481 | |
| 482 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /* | |
| 483 Return a copy of list LIST, which may be a dotted list. | |
| 484 The elements of LIST are not copied; they are shared | |
| 485 with the original. | |
| 486 */ | |
| 487 (list)) | |
| 488 { | |
| 489 again: | |
| 490 if (NILP (list)) return list; | |
| 491 if (CONSP (list)) return copy_list (list); | |
| 492 | |
| 493 list = wrong_type_argument (Qlistp, list); | |
| 494 goto again; | |
| 495 } | |
| 496 | |
| 497 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /* | |
| 498 Return a copy of list, vector, bit vector or string SEQUENCE. | |
| 499 The elements of a list or vector are not copied; they are shared | |
| 500 with the original. SEQUENCE may be a dotted list. | |
| 501 */ | |
| 502 (sequence)) | |
| 503 { | |
| 504 again: | |
| 505 if (NILP (sequence)) return sequence; | |
| 506 if (CONSP (sequence)) return copy_list (sequence); | |
| 507 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0); | |
| 508 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0); | |
| 509 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0); | |
| 510 | |
| 511 check_losing_bytecode ("copy-sequence", sequence); | |
| 512 sequence = wrong_type_argument (Qsequencep, sequence); | |
| 513 goto again; | |
| 514 } | |
| 515 | |
| 516 struct merge_string_extents_struct | |
| 517 { | |
| 518 Lisp_Object string; | |
| 519 Bytecount entry_offset; | |
| 520 Bytecount entry_length; | |
| 521 }; | |
| 522 | |
| 523 static Lisp_Object | |
| 524 concat (int nargs, Lisp_Object *args, | |
| 525 enum concat_target_type target_type, | |
| 526 int last_special) | |
| 527 { | |
| 528 Lisp_Object val; | |
| 529 Lisp_Object tail = Qnil; | |
| 530 int toindex; | |
| 531 int argnum; | |
| 532 Lisp_Object last_tail; | |
| 533 Lisp_Object prev; | |
| 534 struct merge_string_extents_struct *args_mse = 0; | |
| 867 | 535 Ibyte *string_result = 0; |
| 536 Ibyte *string_result_ptr = 0; | |
| 428 | 537 struct gcpro gcpro1; |
| 851 | 538 int sdep = specpdl_depth (); |
| 428 | 539 |
| 540 /* The modus operandi in Emacs is "caller gc-protects args". | |
| 541 However, concat is called many times in Emacs on freshly | |
| 542 created stuff. So we help those callers out by protecting | |
| 543 the args ourselves to save them a lot of temporary-variable | |
| 544 grief. */ | |
| 545 | |
| 546 GCPRO1 (args[0]); | |
| 547 gcpro1.nvars = nargs; | |
| 548 | |
| 549 #ifdef I18N3 | |
| 550 /* #### if the result is a string and any of the strings have a string | |
| 551 for the `string-translatable' property, then concat should also | |
| 552 concat the args but use the `string-translatable' strings, and store | |
| 553 the result in the returned string's `string-translatable' property. */ | |
| 554 #endif | |
| 555 if (target_type == c_string) | |
| 556 args_mse = alloca_array (struct merge_string_extents_struct, nargs); | |
| 557 | |
| 558 /* In append, the last arg isn't treated like the others */ | |
| 559 if (last_special && nargs > 0) | |
| 560 { | |
| 561 nargs--; | |
| 562 last_tail = args[nargs]; | |
| 563 } | |
| 564 else | |
| 565 last_tail = Qnil; | |
| 566 | |
| 567 /* Check and coerce the arguments. */ | |
| 568 for (argnum = 0; argnum < nargs; argnum++) | |
| 569 { | |
| 570 Lisp_Object seq = args[argnum]; | |
| 571 if (LISTP (seq)) | |
| 572 ; | |
| 573 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq)) | |
| 574 ; | |
| 575 #if 0 /* removed for XEmacs 21 */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
576 else if (FIXNUMP (seq)) |
| 428 | 577 /* This is too revolting to think about but maintains |
| 578 compatibility with FSF (and lots and lots of old code). */ | |
| 579 args[argnum] = Fnumber_to_string (seq); | |
| 580 #endif | |
| 581 else | |
| 582 { | |
| 583 check_losing_bytecode ("concat", seq); | |
| 584 args[argnum] = wrong_type_argument (Qsequencep, seq); | |
| 585 } | |
| 586 | |
| 587 if (args_mse) | |
| 588 { | |
| 589 if (STRINGP (seq)) | |
| 590 args_mse[argnum].string = seq; | |
| 591 else | |
| 592 args_mse[argnum].string = Qnil; | |
| 593 } | |
| 594 } | |
| 595 | |
| 596 { | |
| 597 /* Charcount is a misnomer here as we might be dealing with the | |
| 598 length of a vector or list, but emphasizes that we're not dealing | |
| 599 with Bytecounts in strings */ | |
| 600 Charcount total_length; | |
| 601 | |
| 602 for (argnum = 0, total_length = 0; argnum < nargs; argnum++) | |
| 603 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
604 Charcount thislen = XFIXNUM (Flength (args[argnum])); |
| 428 | 605 total_length += thislen; |
| 606 } | |
| 607 | |
| 608 switch (target_type) | |
| 609 { | |
| 610 case c_cons: | |
| 611 if (total_length == 0) | |
| 851 | 612 { |
| 613 unbind_to (sdep); | |
| 614 /* In append, if all but last arg are nil, return last arg */ | |
| 615 RETURN_UNGCPRO (last_tail); | |
| 616 } | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
617 val = Fmake_list (make_fixnum (total_length), Qnil); |
| 428 | 618 break; |
| 619 case c_vector: | |
| 620 val = make_vector (total_length, Qnil); | |
| 621 break; | |
| 622 case c_bit_vector: | |
| 623 val = make_bit_vector (total_length, Qzero); | |
| 624 break; | |
| 625 case c_string: | |
| 626 /* We don't make the string yet because we don't know the | |
| 627 actual number of bytes. This loop was formerly written | |
| 628 to call Fmake_string() here and then call set_string_char() | |
| 629 for each char. This seems logical enough but is waaaaaaaay | |
| 630 slow -- set_string_char() has to scan the whole string up | |
| 631 to the place where the substitution is called for in order | |
| 632 to find the place to change, and may have to do some | |
| 633 realloc()ing in order to make the char fit properly. | |
| 634 O(N^2) yuckage. */ | |
| 635 val = Qnil; | |
| 851 | 636 string_result = |
| 867 | 637 (Ibyte *) MALLOC_OR_ALLOCA (total_length * MAX_ICHAR_LEN); |
| 428 | 638 string_result_ptr = string_result; |
| 639 break; | |
| 640 default: | |
| 442 | 641 val = Qnil; |
| 2500 | 642 ABORT (); |
| 428 | 643 } |
| 644 } | |
| 645 | |
| 646 | |
| 647 if (CONSP (val)) | |
| 648 tail = val, toindex = -1; /* -1 in toindex is flag we are | |
| 649 making a list */ | |
| 650 else | |
| 651 toindex = 0; | |
| 652 | |
| 653 prev = Qnil; | |
| 654 | |
| 655 for (argnum = 0; argnum < nargs; argnum++) | |
| 656 { | |
| 657 Charcount thisleni = 0; | |
| 658 Charcount thisindex = 0; | |
| 659 Lisp_Object seq = args[argnum]; | |
| 867 | 660 Ibyte *string_source_ptr = 0; |
| 661 Ibyte *string_prev_result_ptr = string_result_ptr; | |
| 428 | 662 |
| 663 if (!CONSP (seq)) | |
| 664 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
665 thisleni = XFIXNUM (Flength (seq)); |
| 428 | 666 } |
| 667 if (STRINGP (seq)) | |
| 668 string_source_ptr = XSTRING_DATA (seq); | |
| 669 | |
| 670 while (1) | |
| 671 { | |
| 672 Lisp_Object elt; | |
| 673 | |
| 674 /* We've come to the end of this arg, so exit. */ | |
| 675 if (NILP (seq)) | |
| 676 break; | |
| 677 | |
| 678 /* Fetch next element of `seq' arg into `elt' */ | |
| 679 if (CONSP (seq)) | |
| 680 { | |
| 681 elt = XCAR (seq); | |
| 682 seq = XCDR (seq); | |
| 683 } | |
| 684 else | |
| 685 { | |
| 686 if (thisindex >= thisleni) | |
| 687 break; | |
| 688 | |
| 689 if (STRINGP (seq)) | |
| 690 { | |
| 867 | 691 elt = make_char (itext_ichar (string_source_ptr)); |
| 692 INC_IBYTEPTR (string_source_ptr); | |
| 428 | 693 } |
| 694 else if (VECTORP (seq)) | |
| 695 elt = XVECTOR_DATA (seq)[thisindex]; | |
| 696 else if (BIT_VECTORP (seq)) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
697 elt = make_fixnum (bit_vector_bit (XBIT_VECTOR (seq), |
| 428 | 698 thisindex)); |
| 699 else | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
700 elt = Felt (seq, make_fixnum (thisindex)); |
| 428 | 701 thisindex++; |
| 702 } | |
| 703 | |
| 704 /* Store into result */ | |
| 705 if (toindex < 0) | |
| 706 { | |
| 707 /* toindex negative means we are making a list */ | |
| 708 XCAR (tail) = elt; | |
| 709 prev = tail; | |
| 710 tail = XCDR (tail); | |
| 711 } | |
| 712 else if (VECTORP (val)) | |
| 713 XVECTOR_DATA (val)[toindex++] = elt; | |
| 714 else if (BIT_VECTORP (val)) | |
| 715 { | |
| 716 CHECK_BIT (elt); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
717 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XFIXNUM (elt)); |
| 428 | 718 } |
| 719 else | |
| 720 { | |
| 721 CHECK_CHAR_COERCE_INT (elt); | |
| 867 | 722 string_result_ptr += set_itext_ichar (string_result_ptr, |
|
5261
69f687b3ba9d
Move #'replace to C, add bounds-checking to it and to #'fill.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5255
diff
changeset
|
723 XCHAR (elt)); |
| 428 | 724 } |
| 725 } | |
| 726 if (args_mse) | |
| 727 { | |
| 728 args_mse[argnum].entry_offset = | |
| 729 string_prev_result_ptr - string_result; | |
| 730 args_mse[argnum].entry_length = | |
| 731 string_result_ptr - string_prev_result_ptr; | |
| 732 } | |
| 733 } | |
| 734 | |
| 735 /* Now we finally make the string. */ | |
| 736 if (target_type == c_string) | |
| 737 { | |
| 738 val = make_string (string_result, string_result_ptr - string_result); | |
| 739 for (argnum = 0; argnum < nargs; argnum++) | |
| 740 { | |
| 741 if (STRINGP (args_mse[argnum].string)) | |
| 742 copy_string_extents (val, args_mse[argnum].string, | |
| 743 args_mse[argnum].entry_offset, 0, | |
| 744 args_mse[argnum].entry_length); | |
| 745 } | |
| 746 } | |
| 747 | |
| 748 if (!NILP (prev)) | |
| 749 XCDR (prev) = last_tail; | |
| 750 | |
| 851 | 751 unbind_to (sdep); |
| 428 | 752 RETURN_UNGCPRO (val); |
| 753 } | |
| 754 | |
| 755 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /* | |
| 756 Return a copy of ALIST. | |
| 757 This is an alist which represents the same mapping from objects to objects, | |
| 758 but does not share the alist structure with ALIST. | |
| 759 The objects mapped (cars and cdrs of elements of the alist) | |
| 760 are shared, however. | |
| 761 Elements of ALIST that are not conses are also shared. | |
| 762 */ | |
| 763 (alist)) | |
| 764 { | |
| 765 Lisp_Object tail; | |
| 766 | |
| 767 if (NILP (alist)) | |
| 768 return alist; | |
| 769 CHECK_CONS (alist); | |
| 770 | |
| 771 alist = concat (1, &alist, c_cons, 0); | |
| 772 for (tail = alist; CONSP (tail); tail = XCDR (tail)) | |
| 773 { | |
| 774 Lisp_Object car = XCAR (tail); | |
| 775 | |
| 776 if (CONSP (car)) | |
| 777 XCAR (tail) = Fcons (XCAR (car), XCDR (car)); | |
| 778 } | |
| 779 return alist; | |
| 780 } | |
| 781 | |
|
5224
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
782 DEFUN ("substring-no-properties", Fsubstring_no_properties, 1, 3, 0, /* |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
783 Return a substring of STRING, without copying the extents. |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
784 END may be nil or omitted; then the substring runs to the end of STRING. |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
785 If START or END is negative, it counts from the end. |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
786 |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
787 With one argument, copy STRING without its properties. |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
788 */ |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
789 (string, start, end)) |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
790 { |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
791 Charcount ccstart, ccend; |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
792 Bytecount bstart, blen; |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
793 Lisp_Object val; |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
794 |
|
5360
46b53e84ea7a
#'substring-no-properties: check STRING's type, get_string_range_char won't.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5359
diff
changeset
|
795 CHECK_STRING (string); |
|
5224
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
796 get_string_range_char (string, start, end, &ccstart, &ccend, |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
797 GB_HISTORICAL_STRING_BEHAVIOR); |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
798 bstart = string_index_char_to_byte (string, ccstart); |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
799 blen = string_offset_char_to_byte_len (string, bstart, ccend - ccstart); |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
800 val = make_string (XSTRING_DATA (string) + bstart, blen); |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
801 |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
802 return val; |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
803 } |
|
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
804 |
|
5521
3310f36295a0
Correct a couple of comments, remove a superfluous gcpro1, fns.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5517
diff
changeset
|
805 /* Split STRING into a list of substrings. The substrings are the parts of |
|
3310f36295a0
Correct a couple of comments, remove a superfluous gcpro1, fns.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5517
diff
changeset
|
806 original STRING 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
|
807 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
808 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
|
809 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
|
810 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
|
811 |
| 771 | 812 static Lisp_Object |
| 867 | 813 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
|
814 Ichar sepchar, int unescape, Ichar escapechar) |
| 771 | 815 { |
| 816 Lisp_Object result = Qnil; | |
| 867 | 817 const Ibyte *end = string + size; |
| 771 | 818 |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
819 if (unescape) |
| 771 | 820 { |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
821 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
|
822 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
|
823 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
|
824 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
|
825 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
|
826 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
|
827 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
828 while (1) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
829 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
830 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
|
831 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
|
832 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
|
833 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
834 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
|
835 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
836 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
|
837 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
838 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
|
839 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
840 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
|
841 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
842 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
843 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
844 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
845 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
|
846 /* 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
|
847 && !previous_escaped) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
848 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
849 ++deleting_escapes; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
850 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
|
851 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
852 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
853 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
854 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
|
855 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
856 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
857 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
|
858 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
859 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
860 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
|
861 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
862 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
|
863 > 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
|
864 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
865 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
|
866 ((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
|
867 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
|
868 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
869 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
870 cursor = string; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
871 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
|
872 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
|
873 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
874 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
|
875 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
876 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
|
877 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
878 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
|
879 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
880 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
|
881 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
|
882 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
|
883 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
884 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
885 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
|
886 && (pchar == escapechar); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
887 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
888 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
|
889 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
890 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
891 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
|
892 unescape_cursor |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
893 - 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
|
894 result); |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
895 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
896 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
897 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
898 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
|
899 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
900 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
|
901 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
902 string = p; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
903 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
|
904 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
905 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
906 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
907 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
908 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
909 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
910 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
911 while (1) |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
912 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
913 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
|
914 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
|
915 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
916 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
|
917 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
918 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
|
919 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
920 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
|
921 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
|
922 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
923 string = p; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
924 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
|
925 } |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
926 else |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
927 break; |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
928 } |
| 771 | 929 } |
| 930 return Fnreverse (result); | |
| 931 } | |
| 932 | |
| 933 /* The same as the above, except PATH is an external C string (it is | |
| 934 converted using Qfile_name), and sepchar is hardcoded to SEPCHAR | |
| 935 (':' or whatever). */ | |
| 936 Lisp_Object | |
| 937 split_external_path (const Extbyte *path) | |
| 938 { | |
| 939 Bytecount newlen; | |
| 867 | 940 Ibyte *newpath; |
| 771 | 941 if (!path) |
| 942 return Qnil; | |
| 943 | |
| 944 TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name); | |
| 945 | |
| 946 /* #### Does this make sense? It certainly does for | |
| 947 split_env_path(), but it looks dubious here. Does any code | |
| 948 depend on split_external_path("") returning nil instead of an empty | |
| 949 string? */ | |
| 950 if (!newlen) | |
| 951 return Qnil; | |
| 952 | |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
953 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR, 0, 0); |
| 771 | 954 } |
| 955 | |
| 956 Lisp_Object | |
| 867 | 957 split_env_path (const CIbyte *evarname, const Ibyte *default_) |
| 771 | 958 { |
| 867 | 959 const Ibyte *path = 0; |
| 771 | 960 if (evarname) |
| 961 path = egetenv (evarname); | |
| 962 if (!path) | |
| 963 path = default_; | |
| 964 if (!path) | |
| 965 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
|
966 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR, 0, 0); |
| 771 | 967 } |
| 968 | |
|
5504
d3e0482c7899
Move #'split-path to subr.el, as was always the intention.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5475
diff
changeset
|
969 /* Ben thinks [or thought in 1998] this function should not exist or be |
|
d3e0482c7899
Move #'split-path to subr.el, as was always the intention.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5475
diff
changeset
|
970 exported to Lisp. It's used to define #'split-path in subr.el, and for |
|
d3e0482c7899
Move #'split-path to subr.el, as was always the intention.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5475
diff
changeset
|
971 parsing Carbon font names under that window system. */ |
| 771 | 972 |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
973 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 3, 0, /* |
| 771 | 974 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
|
975 |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
976 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
|
977 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
|
978 will be necessary for a single ESCAPE-CHAR to appear in the output string. |
| 771 | 979 */ |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
980 (string, sepchar, escape_char)) |
| 771 | 981 { |
|
5035
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
982 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
|
983 |
| 771 | 984 CHECK_STRING (string); |
| 985 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
|
986 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
|
987 { |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
988 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
|
989 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
|
990 } |
| 867 | 991 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
|
992 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
|
993 XCHAR (sepchar), |
|
b1e48555be7d
Add a new optional ESCAPE-CHAR argument to #'split-string-by-char.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5034
diff
changeset
|
994 !NILP (escape_char), escape_ichar); |
| 771 | 995 } |
| 428 | 996 |
| 997 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /* | |
| 998 Take cdr N times on LIST, and return the result. | |
| 999 */ | |
| 1000 (n, list)) | |
| 1001 { | |
| 1920 | 1002 /* This function can GC */ |
| 647 | 1003 REGISTER EMACS_INT i; |
| 428 | 1004 REGISTER Lisp_Object tail = list; |
| 1005 CHECK_NATNUM (n); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1006 for (i = BIGNUMP (n) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (n); i; i--) |
| 428 | 1007 { |
| 1008 if (CONSP (tail)) | |
| 1009 tail = XCDR (tail); | |
| 1010 else if (NILP (tail)) | |
| 1011 return Qnil; | |
| 1012 else | |
| 1013 { | |
| 1014 tail = wrong_type_argument (Qlistp, tail); | |
| 1015 i++; | |
| 1016 } | |
| 1017 } | |
| 1018 return tail; | |
| 1019 } | |
| 1020 | |
| 1021 DEFUN ("nth", Fnth, 2, 2, 0, /* | |
| 1022 Return the Nth element of LIST. | |
| 1023 N counts from zero. If LIST is not that long, nil is returned. | |
| 1024 */ | |
| 1025 (n, list)) | |
| 1026 { | |
| 1920 | 1027 /* This function can GC */ |
| 428 | 1028 return Fcar (Fnthcdr (n, list)); |
| 1029 } | |
| 1030 | |
| 1031 DEFUN ("last", Flast, 1, 2, 0, /* | |
| 1032 Return the tail of list LIST, of length N (default 1). | |
| 1033 LIST may be a dotted list, but not a circular list. | |
| 1034 Optional argument N must be a non-negative integer. | |
| 1035 If N is zero, then the atom that terminates the list is returned. | |
| 1036 If N is greater than the length of LIST, then LIST itself is returned. | |
| 1037 */ | |
| 1038 (list, n)) | |
| 1039 { | |
| 1040 EMACS_INT int_n, count; | |
| 1041 Lisp_Object retval, tortoise, hare; | |
| 1042 | |
| 1043 CHECK_LIST (list); | |
| 1044 | |
| 1045 if (NILP (n)) | |
| 1046 int_n = 1; | |
| 1047 else | |
| 1048 { | |
| 1049 CHECK_NATNUM (n); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1050 int_n = BIGNUMP (n) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (n); |
| 428 | 1051 } |
| 1052 | |
| 1053 for (retval = tortoise = hare = list, count = 0; | |
| 1054 CONSP (hare); | |
| 1055 hare = XCDR (hare), | |
| 1056 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0), | |
| 1057 count++) | |
| 1058 { | |
| 1059 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 1060 | |
| 1061 if (count & 1) | |
| 1062 tortoise = XCDR (tortoise); | |
| 1063 if (EQ (hare, tortoise)) | |
| 1064 signal_circular_list_error (list); | |
| 1065 } | |
| 1066 | |
| 1067 return retval; | |
| 1068 } | |
| 1069 | |
| 1070 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /* | |
| 1071 Modify LIST to remove the last N (default 1) elements. | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1072 |
| 428 | 1073 If LIST has N or fewer elements, nil is returned and LIST is unmodified. |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1074 Otherwise, LIST may be dotted, but not circular. |
| 428 | 1075 */ |
| 1076 (list, n)) | |
| 1077 { | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1078 Elemcount int_n = 1; |
| 428 | 1079 |
| 1080 CHECK_LIST (list); | |
| 1081 | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1082 if (!NILP (n)) |
| 428 | 1083 { |
| 1084 CHECK_NATNUM (n); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1085 int_n = BIGNUMP (n) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (n); |
| 428 | 1086 } |
| 1087 | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1088 if (CONSP (list)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1089 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1090 Lisp_Object last_cons = list; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1091 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1092 EXTERNAL_LIST_LOOP_3 (elt, list, tail) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1093 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1094 if (int_n-- < 0) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1095 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1096 last_cons = XCDR (last_cons); |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1097 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1098 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1099 if (!CONSP (XCDR (tail))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1100 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1101 break; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1102 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1103 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1104 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1105 if (int_n >= 0) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1106 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1107 return Qnil; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1108 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1109 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1110 XCDR (last_cons) = Qnil; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1111 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1112 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1113 return list; |
| 428 | 1114 } |
| 1115 | |
| 1116 DEFUN ("butlast", Fbutlast, 1, 2, 0, /* | |
| 1117 Return a copy of LIST with the last N (default 1) elements removed. | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1118 |
| 428 | 1119 If LIST has N or fewer elements, nil is returned. |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1120 Otherwise, LIST may be dotted, but not circular, and `(butlast LIST 0)' |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1121 converts a dotted into a true list. |
| 428 | 1122 */ |
| 1123 (list, n)) | |
| 1124 { | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1125 Lisp_Object retval = Qnil, retval_tail = Qnil; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1126 Elemcount int_n = 1; |
| 428 | 1127 |
| 1128 CHECK_LIST (list); | |
| 1129 | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1130 if (!NILP (n)) |
| 428 | 1131 { |
| 1132 CHECK_NATNUM (n); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1133 int_n = BIGNUMP (n) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (n); |
| 428 | 1134 } |
| 1135 | |
|
5285
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1136 if (CONSP (list)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1137 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1138 Lisp_Object tail = list; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1139 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1140 EXTERNAL_LIST_LOOP_3 (elt, list, list_tail) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1141 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1142 if (--int_n < 0) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1143 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1144 if (NILP (retval_tail)) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1145 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1146 retval = retval_tail = Fcons (XCAR (tail), Qnil); |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1147 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1148 else |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1149 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1150 XSETCDR (retval_tail, Fcons (XCAR (tail), Qnil)); |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1151 retval_tail = XCDR (retval_tail); |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1152 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1153 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1154 tail = XCDR (tail); |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1155 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1156 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1157 if (!CONSP (XCDR (list_tail))) |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1158 { |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1159 break; |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1160 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1161 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1162 } |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1163 |
|
99de5fd48e87
Tighten up Common Lisp compatibility, #'butlast, #'nbutlast, #'tailp, #'ldiff
Aidan Kehoe <kehoea@parhasard.net>
parents:
5283
diff
changeset
|
1164 return retval; |
| 428 | 1165 } |
| 1166 | |
| 1167 | |
| 1168 /************************************************************************/ | |
| 1169 /* property-list functions */ | |
| 1170 /************************************************************************/ | |
| 1171 | |
| 1172 /* For properties of text, we need to do order-insensitive comparison of | |
| 1173 plists. That is, we need to compare two plists such that they are the | |
| 1174 same if they have the same set of keys, and equivalent values. | |
| 1175 So (a 1 b 2) would be equal to (b 2 a 1). | |
| 1176 | |
| 1177 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc. | |
| 1178 LAXP means use `equal' for comparisons. | |
| 1179 */ | |
| 1180 int | |
| 1181 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
|
1182 int laxp, int depth, int foldcase) |
| 428 | 1183 { |
| 438 | 1184 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ |
| 428 | 1185 int la, lb, m, i, fill; |
| 1186 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
|
1187 Boolbyte *flags; |
| 428 | 1188 Lisp_Object rest; |
| 1189 | |
| 1190 if (NILP (a) && NILP (b)) | |
| 1191 return 0; | |
| 1192 | |
| 1193 Fcheck_valid_plist (a); | |
| 1194 Fcheck_valid_plist (b); | |
| 1195 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1196 la = XFIXNUM (Flength (a)); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
1197 lb = XFIXNUM (Flength (b)); |
| 428 | 1198 m = (la > lb ? la : lb); |
| 1199 fill = 0; | |
| 1200 keys = alloca_array (Lisp_Object, m); | |
| 1201 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
|
1202 flags = alloca_array (Boolbyte, m); |
| 428 | 1203 |
| 1204 /* First extract the pairs from A. */ | |
| 1205 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest))) | |
| 1206 { | |
| 1207 Lisp_Object k = XCAR (rest); | |
| 1208 Lisp_Object v = XCAR (XCDR (rest)); | |
| 1209 /* Maybe be Ebolified. */ | |
| 1210 if (nil_means_not_present && NILP (v)) continue; | |
| 1211 keys [fill] = k; | |
| 1212 vals [fill] = v; | |
| 1213 flags[fill] = 0; | |
| 1214 fill++; | |
| 1215 } | |
| 1216 /* Now iterate over B, and stop if we find something that's not in A, | |
| 1217 or that doesn't match. As we match, mark them. */ | |
| 1218 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest))) | |
| 1219 { | |
| 1220 Lisp_Object k = XCAR (rest); | |
| 1221 Lisp_Object v = XCAR (XCDR (rest)); | |
| 1222 /* Maybe be Ebolified. */ | |
| 1223 if (nil_means_not_present && NILP (v)) continue; | |
| 1224 for (i = 0; i < fill; i++) | |
| 1225 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
1226 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
|
1227 internal_equal_0 (k, keys [i], depth, foldcase)) |
| 428 | 1228 { |
| 434 | 1229 if (eqp |
| 1230 /* We narrowly escaped being Ebolified here. */ | |
| 1231 ? !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
|
1232 : !internal_equal_0 (v, vals [i], depth, foldcase)) |
| 428 | 1233 /* a property in B has a different value than in A */ |
| 1234 goto MISMATCH; | |
| 1235 flags [i] = 1; | |
| 1236 break; | |
| 1237 } | |
| 1238 } | |
| 1239 if (i == fill) | |
| 1240 /* there are some properties in B that are not in A */ | |
| 1241 goto MISMATCH; | |
| 1242 } | |
| 1243 /* Now check to see that all the properties in A were also in B */ | |
| 1244 for (i = 0; i < fill; i++) | |
| 1245 if (flags [i] == 0) | |
| 1246 goto MISMATCH; | |
| 1247 | |
| 1248 /* Ok. */ | |
| 1249 return 0; | |
| 1250 | |
| 1251 MISMATCH: | |
| 1252 return 1; | |
| 1253 } | |
| 1254 | |
| 1255 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /* | |
| 1256 Return non-nil if property lists A and B are `eq'. | |
| 1257 A property list is an alternating list of keywords and values. | |
| 1258 This function does order-insensitive comparisons of the property lists: | |
| 1259 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 1260 Comparison between values is done using `eq'. See also `plists-equal'. | |
| 1261 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 1262 a nil value is ignored. This feature is a virus that has infected | |
| 1263 old Lisp implementations, but should not be used except for backward | |
| 1264 compatibility. | |
| 1265 */ | |
| 1266 (a, b, nil_means_not_present)) | |
| 1267 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
1268 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0) |
| 428 | 1269 ? Qnil : Qt); |
| 1270 } | |
| 1271 | |
| 1272 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /* | |
| 1273 Return non-nil if property lists A and B are `equal'. | |
| 1274 A property list is an alternating list of keywords and values. This | |
| 1275 function does order-insensitive comparisons of the property lists: For | |
| 1276 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 1277 Comparison between values is done using `equal'. See also `plists-eq'. | |
| 1278 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 1279 a nil value is ignored. This feature is a virus that has infected | |
| 1280 old Lisp implementations, but should not be used except for backward | |
| 1281 compatibility. | |
| 1282 */ | |
| 1283 (a, b, nil_means_not_present)) | |
| 1284 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
1285 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0) |
| 428 | 1286 ? Qnil : Qt); |
| 1287 } | |
| 1288 | |
| 1289 | |
| 1290 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /* | |
| 1291 Return non-nil if lax property lists A and B are `eq'. | |
| 1292 A property list is an alternating list of keywords and values. | |
| 1293 This function does order-insensitive comparisons of the property lists: | |
| 1294 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 1295 Comparison between values is done using `eq'. See also `plists-equal'. | |
| 1296 A lax property list is like a regular one except that comparisons between | |
| 1297 keywords is done using `equal' instead of `eq'. | |
| 1298 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 1299 a nil value is ignored. This feature is a virus that has infected | |
| 1300 old Lisp implementations, but should not be used except for backward | |
| 1301 compatibility. | |
| 1302 */ | |
| 1303 (a, b, nil_means_not_present)) | |
| 1304 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
1305 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0) |
| 428 | 1306 ? Qnil : Qt); |
| 1307 } | |
| 1308 | |
| 1309 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /* | |
| 1310 Return non-nil if lax property lists A and B are `equal'. | |
| 1311 A property list is an alternating list of keywords and values. This | |
| 1312 function does order-insensitive comparisons of the property lists: For | |
| 1313 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal. | |
| 1314 Comparison between values is done using `equal'. See also `plists-eq'. | |
| 1315 A lax property list is like a regular one except that comparisons between | |
| 1316 keywords is done using `equal' instead of `eq'. | |
| 1317 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 1318 a nil value is ignored. This feature is a virus that has infected | |
| 1319 old Lisp implementations, but should not be used except for backward | |
| 1320 compatibility. | |
| 1321 */ | |
| 1322 (a, b, nil_means_not_present)) | |
| 1323 { | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
1324 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0) |
| 428 | 1325 ? Qnil : Qt); |
| 1326 } | |
| 1327 | |
| 1328 /* Return the value associated with key PROPERTY in property list PLIST. | |
| 1329 Return nil if key not found. This function is used for internal | |
| 1330 property lists that cannot be directly manipulated by the user. | |
| 1331 */ | |
| 1332 | |
| 1333 Lisp_Object | |
| 1334 internal_plist_get (Lisp_Object plist, Lisp_Object property) | |
| 1335 { | |
| 1336 Lisp_Object tail; | |
| 1337 | |
| 1338 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
| 1339 { | |
| 1340 if (EQ (XCAR (tail), property)) | |
| 1341 return XCAR (XCDR (tail)); | |
| 1342 } | |
| 1343 | |
| 1344 return Qunbound; | |
| 1345 } | |
| 1346 | |
| 1347 /* Set PLIST's value for PROPERTY to VALUE. Analogous to | |
| 1348 internal_plist_get(). */ | |
| 1349 | |
| 1350 void | |
| 1351 internal_plist_put (Lisp_Object *plist, Lisp_Object property, | |
| 1352 Lisp_Object value) | |
| 1353 { | |
| 1354 Lisp_Object tail; | |
| 1355 | |
| 1356 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail))) | |
| 1357 { | |
| 1358 if (EQ (XCAR (tail), property)) | |
| 1359 { | |
| 1360 XCAR (XCDR (tail)) = value; | |
| 1361 return; | |
| 1362 } | |
| 1363 } | |
| 1364 | |
| 1365 *plist = Fcons (property, Fcons (value, *plist)); | |
| 1366 } | |
| 1367 | |
| 1368 int | |
| 1369 internal_remprop (Lisp_Object *plist, Lisp_Object property) | |
| 1370 { | |
| 1371 Lisp_Object tail, prev; | |
| 1372 | |
| 1373 for (tail = *plist, prev = Qnil; | |
| 1374 !NILP (tail); | |
| 1375 tail = XCDR (XCDR (tail))) | |
| 1376 { | |
| 1377 if (EQ (XCAR (tail), property)) | |
| 1378 { | |
| 1379 if (NILP (prev)) | |
| 1380 *plist = XCDR (XCDR (tail)); | |
| 1381 else | |
| 1382 XCDR (XCDR (prev)) = XCDR (XCDR (tail)); | |
| 1383 return 1; | |
| 1384 } | |
| 1385 else | |
| 1386 prev = tail; | |
| 1387 } | |
| 1388 | |
| 1389 return 0; | |
| 1390 } | |
| 1391 | |
| 1392 /* Called on a malformed property list. BADPLACE should be some | |
| 1393 place where truncating will form a good list -- i.e. we shouldn't | |
| 1394 result in a list with an odd length. */ | |
| 1395 | |
| 1396 static Lisp_Object | |
| 578 | 1397 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
| 428 | 1398 { |
| 1399 if (ERRB_EQ (errb, ERROR_ME)) | |
| 1400 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace)); | |
| 1401 else | |
| 1402 { | |
| 1403 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
| 1404 { | |
| 1405 warn_when_safe_lispobj | |
| 1406 (Qlist, Qwarning, | |
| 771 | 1407 list2 (build_msg_string |
| 428 | 1408 ("Malformed property list -- list has been truncated"), |
| 1409 *plist)); | |
| 793 | 1410 /* #### WARNING: This is more dangerous than it seems; perhaps |
| 1411 not a good idea. It also violates the principle of least | |
| 1412 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
| 1413 ERROR_ME and ERROR_ME_NOT don't. */ | |
| 428 | 1414 *badplace = Qnil; |
| 1415 } | |
| 1416 return Qunbound; | |
| 1417 } | |
| 1418 } | |
| 1419 | |
| 1420 /* Called on a circular property list. BADPLACE should be some place | |
| 1421 where truncating will result in an even-length list, as above. | |
| 1422 If doesn't particularly matter where we truncate -- anywhere we | |
| 1423 truncate along the entire list will break the circularity, because | |
| 1424 it will create a terminus and the list currently doesn't have one. | |
| 1425 */ | |
| 1426 | |
| 1427 static Lisp_Object | |
| 578 | 1428 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb) |
| 428 | 1429 { |
| 1430 if (ERRB_EQ (errb, ERROR_ME)) | |
| 1431 return Fsignal (Qcircular_property_list, list1 (*plist)); | |
| 1432 else | |
| 1433 { | |
| 1434 if (ERRB_EQ (errb, ERROR_ME_WARN)) | |
| 1435 { | |
| 1436 warn_when_safe_lispobj | |
| 1437 (Qlist, Qwarning, | |
| 771 | 1438 list2 (build_msg_string |
| 428 | 1439 ("Circular property list -- list has been truncated"), |
| 1440 *plist)); | |
| 793 | 1441 /* #### WARNING: This is more dangerous than it seems; perhaps |
| 1442 not a good idea. It also violates the principle of least | |
| 1443 surprise -- passing in ERROR_ME_WARN causes truncation, but | |
| 1444 ERROR_ME and ERROR_ME_NOT don't. */ | |
| 428 | 1445 *badplace = Qnil; |
| 1446 } | |
| 1447 return Qunbound; | |
| 1448 } | |
| 1449 } | |
| 1450 | |
| 1451 /* Advance the tortoise pointer by two (one iteration of a property-list | |
| 1452 loop) and the hare pointer by four and verify that no malformations | |
| 1453 or circularities exist. If so, return zero and store a value into | |
| 1454 RETVAL that should be returned by the calling function. Otherwise, | |
| 1455 return 1. See external_plist_get(). | |
| 1456 */ | |
| 1457 | |
| 1458 static int | |
| 1459 advance_plist_pointers (Lisp_Object *plist, | |
| 1460 Lisp_Object **tortoise, Lisp_Object **hare, | |
| 578 | 1461 Error_Behavior errb, Lisp_Object *retval) |
| 428 | 1462 { |
| 1463 int i; | |
| 1464 Lisp_Object *tortsave = *tortoise; | |
| 1465 | |
| 1466 /* Note that our "fixing" may be more brutal than necessary, | |
| 1467 but it's the user's own problem, not ours, if they went in and | |
| 1468 manually fucked up a plist. */ | |
| 1469 | |
| 1470 for (i = 0; i < 2; i++) | |
| 1471 { | |
| 1472 /* This is a standard iteration of a defensive-loop-checking | |
| 1473 loop. We just do it twice because we want to advance past | |
| 1474 both the property and its value. | |
| 1475 | |
| 1476 If the pointer indirection is confusing you, remember that | |
| 1477 one level of indirection on the hare and tortoise pointers | |
| 1478 is only due to pass-by-reference for this function. The other | |
| 1479 level is so that the plist can be fixed in place. */ | |
| 1480 | |
| 1481 /* When we reach the end of a well-formed plist, **HARE is | |
| 1482 nil. In that case, we don't do anything at all except | |
| 1483 advance TORTOISE by one. Otherwise, we advance HARE | |
| 1484 by two (making sure it's OK to do so), then advance | |
| 1485 TORTOISE by one (it will always be OK to do so because | |
| 1486 the HARE is always ahead of the TORTOISE and will have | |
| 1487 already verified the path), then make sure TORTOISE and | |
| 1488 HARE don't contain the same non-nil object -- if the | |
| 1489 TORTOISE and the HARE ever meet, then obviously we're | |
| 1490 in a circularity, and if we're in a circularity, then | |
| 1491 the TORTOISE and the HARE can't cross paths without | |
| 1492 meeting, since the HARE only gains one step over the | |
| 1493 TORTOISE per iteration. */ | |
| 1494 | |
| 1495 if (!NILP (**hare)) | |
| 1496 { | |
| 1497 Lisp_Object *haresave = *hare; | |
| 1498 if (!CONSP (**hare)) | |
| 1499 { | |
| 1500 *retval = bad_bad_bunny (plist, haresave, errb); | |
| 1501 return 0; | |
| 1502 } | |
| 1503 *hare = &XCDR (**hare); | |
| 1504 /* In a non-plist, we'd check here for a nil value for | |
| 1505 **HARE, which is OK (it just means the list has an | |
| 1506 odd number of elements). In a plist, it's not OK | |
| 1507 for the list to have an odd number of elements. */ | |
| 1508 if (!CONSP (**hare)) | |
| 1509 { | |
| 1510 *retval = bad_bad_bunny (plist, haresave, errb); | |
| 1511 return 0; | |
| 1512 } | |
| 1513 *hare = &XCDR (**hare); | |
| 1514 } | |
| 1515 | |
| 1516 *tortoise = &XCDR (**tortoise); | |
| 1517 if (!NILP (**hare) && EQ (**tortoise, **hare)) | |
| 1518 { | |
| 1519 *retval = bad_bad_turtle (plist, tortsave, errb); | |
| 1520 return 0; | |
| 1521 } | |
| 1522 } | |
| 1523 | |
| 1524 return 1; | |
| 1525 } | |
| 1526 | |
| 1527 /* Return the value of PROPERTY from PLIST, or Qunbound if | |
| 1528 property is not on the list. | |
| 1529 | |
| 1530 PLIST is a Lisp-accessible property list, meaning that it | |
| 1531 has to be checked for malformations and circularities. | |
| 1532 | |
| 1533 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the | |
| 1534 function will never signal an error; and if ERRB is ERROR_ME_WARN, | |
| 1535 on finding a malformation or a circularity, it issues a warning and | |
| 1536 attempts to silently fix the problem. | |
| 1537 | |
| 1538 A pointer to PLIST is passed in so that PLIST can be successfully | |
| 1539 "fixed" even if the error is at the beginning of the plist. */ | |
| 1540 | |
| 1541 Lisp_Object | |
| 1542 external_plist_get (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 1543 int laxp, Error_Behavior errb) |
| 428 | 1544 { |
| 1545 Lisp_Object *tortoise = plist; | |
| 1546 Lisp_Object *hare = plist; | |
| 1547 | |
| 1548 while (!NILP (*tortoise)) | |
| 1549 { | |
| 1550 Lisp_Object *tortsave = tortoise; | |
| 1551 Lisp_Object retval; | |
| 1552 | |
| 1553 /* We do the standard tortoise/hare march. We isolate the | |
| 1554 grungy stuff to do this in advance_plist_pointers(), though. | |
| 1555 To us, all this function does is advance the tortoise | |
| 1556 pointer by two and the hare pointer by four and make sure | |
| 1557 everything's OK. We first advance the pointers and then | |
| 1558 check if a property matched; this ensures that our | |
| 1559 check for a matching property is safe. */ | |
| 1560 | |
| 1561 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 1562 return retval; | |
| 1563 | |
| 1564 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 1565 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 1566 return XCAR (XCDR (*tortsave)); | |
| 1567 } | |
| 1568 | |
| 1569 return Qunbound; | |
| 1570 } | |
| 1571 | |
| 1572 /* Set PLIST's value for PROPERTY to VALUE, given a possibly | |
| 1573 malformed or circular plist. Analogous to external_plist_get(). */ | |
| 1574 | |
| 1575 void | |
| 1576 external_plist_put (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 1577 Lisp_Object value, int laxp, Error_Behavior errb) |
| 428 | 1578 { |
| 1579 Lisp_Object *tortoise = plist; | |
| 1580 Lisp_Object *hare = plist; | |
| 1581 | |
| 1582 while (!NILP (*tortoise)) | |
| 1583 { | |
| 1584 Lisp_Object *tortsave = tortoise; | |
| 1585 Lisp_Object retval; | |
| 1586 | |
| 1587 /* See above */ | |
| 1588 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 1589 return; | |
| 1590 | |
| 1591 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 1592 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 1593 { | |
| 1594 XCAR (XCDR (*tortsave)) = value; | |
| 1595 return; | |
| 1596 } | |
| 1597 } | |
| 1598 | |
| 1599 *plist = Fcons (property, Fcons (value, *plist)); | |
| 1600 } | |
| 1601 | |
| 1602 int | |
| 1603 external_remprop (Lisp_Object *plist, Lisp_Object property, | |
| 578 | 1604 int laxp, Error_Behavior errb) |
| 428 | 1605 { |
| 1606 Lisp_Object *tortoise = plist; | |
| 1607 Lisp_Object *hare = plist; | |
| 1608 | |
| 1609 while (!NILP (*tortoise)) | |
| 1610 { | |
| 1611 Lisp_Object *tortsave = tortoise; | |
| 1612 Lisp_Object retval; | |
| 1613 | |
| 1614 /* See above */ | |
| 1615 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval)) | |
| 1616 return 0; | |
| 1617 | |
| 1618 if (!laxp ? EQ (XCAR (*tortsave), property) | |
| 1619 : internal_equal (XCAR (*tortsave), property, 0)) | |
| 1620 { | |
| 1621 /* Now you see why it's so convenient to have that level | |
| 1622 of indirection. */ | |
| 1623 *tortsave = XCDR (XCDR (*tortsave)); | |
| 1624 return 1; | |
| 1625 } | |
| 1626 } | |
| 1627 | |
| 1628 return 0; | |
| 1629 } | |
| 1630 | |
| 1631 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /* | |
| 1632 Extract a value from a property list. | |
| 1633 PLIST is a property list, which is a list of the form | |
| 444 | 1634 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...). |
| 1635 PROPERTY is usually a symbol. | |
| 1636 This function returns the value corresponding to the PROPERTY, | |
| 1637 or DEFAULT if PROPERTY is not one of the properties on the list. | |
| 428 | 1638 */ |
| 444 | 1639 (plist, property, default_)) |
| 428 | 1640 { |
| 444 | 1641 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME); |
| 1642 return UNBOUNDP (value) ? default_ : value; | |
| 428 | 1643 } |
| 1644 | |
| 1645 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* | |
| 444 | 1646 Change value in PLIST of PROPERTY to VALUE. |
| 1647 PLIST is a property list, which is a list of the form | |
| 1648 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
| 1649 PROPERTY is usually a symbol and VALUE is any object. | |
| 1650 If PROPERTY is already a property on the list, its value is set to VALUE, | |
| 1651 otherwise the new PROPERTY VALUE pair is added. | |
| 1652 The new plist is returned; use `(setq x (plist-put x property value))' | |
| 1653 to be sure to use the new value. PLIST is modified by side effect. | |
| 428 | 1654 */ |
| 444 | 1655 (plist, property, value)) |
| 428 | 1656 { |
| 444 | 1657 external_plist_put (&plist, property, value, 0, ERROR_ME); |
| 428 | 1658 return plist; |
| 1659 } | |
| 1660 | |
| 1661 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /* | |
| 444 | 1662 Remove from PLIST the property PROPERTY and its value. |
| 1663 PLIST is a property list, which is a list of the form | |
| 1664 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). | |
| 1665 PROPERTY is usually a symbol. | |
| 1666 The new plist is returned; use `(setq x (plist-remprop x property))' | |
| 1667 to be sure to use the new value. PLIST is modified by side effect. | |
| 428 | 1668 */ |
| 444 | 1669 (plist, property)) |
| 428 | 1670 { |
| 444 | 1671 external_remprop (&plist, property, 0, ERROR_ME); |
| 428 | 1672 return plist; |
| 1673 } | |
| 1674 | |
| 1675 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /* | |
| 444 | 1676 Return t if PROPERTY has a value specified in PLIST. |
| 428 | 1677 */ |
| 444 | 1678 (plist, property)) |
| 428 | 1679 { |
| 444 | 1680 Lisp_Object value = Fplist_get (plist, property, Qunbound); |
| 1681 return UNBOUNDP (value) ? Qnil : Qt; | |
| 428 | 1682 } |
| 1683 | |
| 1684 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* | |
| 1685 Given a plist, signal an error if there is anything wrong with it. | |
| 1686 This means that it's a malformed or circular plist. | |
| 1687 */ | |
| 1688 (plist)) | |
| 1689 { | |
| 1690 Lisp_Object *tortoise; | |
| 1691 Lisp_Object *hare; | |
| 1692 | |
| 1693 start_over: | |
| 1694 tortoise = &plist; | |
| 1695 hare = &plist; | |
| 1696 while (!NILP (*tortoise)) | |
| 1697 { | |
| 1698 Lisp_Object retval; | |
| 1699 | |
| 1700 /* See above */ | |
| 1701 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME, | |
| 1702 &retval)) | |
| 1703 goto start_over; | |
| 1704 } | |
| 1705 | |
| 1706 return Qnil; | |
| 1707 } | |
| 1708 | |
| 1709 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* | |
| 1710 Given a plist, return non-nil if its format is correct. | |
| 1711 If it returns nil, `check-valid-plist' will signal an error when given | |
| 442 | 1712 the plist; that means it's a malformed or circular plist. |
| 428 | 1713 */ |
| 1714 (plist)) | |
| 1715 { | |
| 1716 Lisp_Object *tortoise; | |
| 1717 Lisp_Object *hare; | |
| 1718 | |
| 1719 tortoise = &plist; | |
| 1720 hare = &plist; | |
| 1721 while (!NILP (*tortoise)) | |
| 1722 { | |
| 1723 Lisp_Object retval; | |
| 1724 | |
| 1725 /* See above */ | |
| 1726 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT, | |
| 1727 &retval)) | |
| 1728 return Qnil; | |
| 1729 } | |
| 1730 | |
| 1731 return Qt; | |
| 1732 } | |
| 1733 | |
| 1734 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /* | |
| 1735 Destructively remove any duplicate entries from a plist. | |
| 1736 In such cases, the first entry applies. | |
| 1737 | |
| 1738 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 1739 a nil value is removed. This feature is a virus that has infected | |
| 1740 old Lisp implementations, but should not be used except for backward | |
| 1741 compatibility. | |
| 1742 | |
| 1743 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
| 1744 return value may not be EQ to the passed-in value, so make sure to | |
| 1745 `setq' the value back into where it came from. | |
| 1746 */ | |
| 1747 (plist, nil_means_not_present)) | |
| 1748 { | |
| 1749 Lisp_Object head = plist; | |
| 1750 | |
| 1751 Fcheck_valid_plist (plist); | |
| 1752 | |
| 1753 while (!NILP (plist)) | |
| 1754 { | |
| 1755 Lisp_Object prop = Fcar (plist); | |
| 1756 Lisp_Object next = Fcdr (plist); | |
| 1757 | |
| 1758 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
| 1759 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
| 1760 { | |
| 1761 if (EQ (head, plist)) | |
| 1762 head = Fcdr (next); | |
| 1763 plist = Fcdr (next); | |
| 1764 continue; | |
| 1765 } | |
| 1766 /* external_remprop returns 1 if it removed any property. | |
| 1767 We have to loop till it didn't remove anything, in case | |
| 1768 the property occurs many times. */ | |
| 1769 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME)) | |
| 1770 DO_NOTHING; | |
| 1771 plist = Fcdr (next); | |
| 1772 } | |
| 1773 | |
| 1774 return head; | |
| 1775 } | |
| 1776 | |
| 1777 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* | |
| 1778 Extract a value from a lax property list. | |
| 444 | 1779 LAX-PLIST is a lax property list, which is a list of the form |
| 1780 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 1781 properties is done using `equal' instead of `eq'. | |
| 1782 PROPERTY is usually a symbol. | |
| 1783 This function returns the value corresponding to PROPERTY, | |
| 1784 or DEFAULT if PROPERTY is not one of the properties on the list. | |
| 428 | 1785 */ |
| 444 | 1786 (lax_plist, property, default_)) |
| 428 | 1787 { |
| 444 | 1788 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME); |
| 1789 return UNBOUNDP (value) ? default_ : value; | |
| 428 | 1790 } |
| 1791 | |
| 1792 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* | |
| 444 | 1793 Change value in LAX-PLIST of PROPERTY to VALUE. |
| 1794 LAX-PLIST is a lax property list, which is a list of the form | |
| 1795 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 1796 properties is done using `equal' instead of `eq'. | |
| 1797 PROPERTY is usually a symbol and VALUE is any object. | |
| 1798 If PROPERTY is already a property on the list, its value is set to | |
| 1799 VALUE, otherwise the new PROPERTY VALUE pair is added. | |
| 1800 The new plist is returned; use `(setq x (lax-plist-put x property value))' | |
| 1801 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
| 428 | 1802 */ |
| 444 | 1803 (lax_plist, property, value)) |
| 428 | 1804 { |
| 444 | 1805 external_plist_put (&lax_plist, property, value, 1, ERROR_ME); |
| 428 | 1806 return lax_plist; |
| 1807 } | |
| 1808 | |
| 1809 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* | |
| 444 | 1810 Remove from LAX-PLIST the property PROPERTY and its value. |
| 1811 LAX-PLIST is a lax property list, which is a list of the form | |
| 1812 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 1813 properties is done using `equal' instead of `eq'. | |
| 1814 PROPERTY is usually a symbol. | |
| 1815 The new plist is returned; use `(setq x (lax-plist-remprop x property))' | |
| 1816 to be sure to use the new value. LAX-PLIST is modified by side effect. | |
| 428 | 1817 */ |
| 444 | 1818 (lax_plist, property)) |
| 428 | 1819 { |
| 444 | 1820 external_remprop (&lax_plist, property, 1, ERROR_ME); |
| 428 | 1821 return lax_plist; |
| 1822 } | |
| 1823 | |
| 1824 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* | |
| 444 | 1825 Return t if PROPERTY has a value specified in LAX-PLIST. |
| 1826 LAX-PLIST is a lax property list, which is a list of the form | |
| 1827 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between | |
| 1828 properties is done using `equal' instead of `eq'. | |
| 428 | 1829 */ |
| 444 | 1830 (lax_plist, property)) |
| 428 | 1831 { |
| 444 | 1832 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt; |
| 428 | 1833 } |
| 1834 | |
| 1835 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /* | |
| 1836 Destructively remove any duplicate entries from a lax plist. | |
| 1837 In such cases, the first entry applies. | |
| 1838 | |
| 1839 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with | |
| 1840 a nil value is removed. This feature is a virus that has infected | |
| 1841 old Lisp implementations, but should not be used except for backward | |
| 1842 compatibility. | |
| 1843 | |
| 1844 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the | |
| 1845 return value may not be EQ to the passed-in value, so make sure to | |
| 1846 `setq' the value back into where it came from. | |
| 1847 */ | |
| 1848 (lax_plist, nil_means_not_present)) | |
| 1849 { | |
| 1850 Lisp_Object head = lax_plist; | |
| 1851 | |
| 1852 Fcheck_valid_plist (lax_plist); | |
| 1853 | |
| 1854 while (!NILP (lax_plist)) | |
| 1855 { | |
| 1856 Lisp_Object prop = Fcar (lax_plist); | |
| 1857 Lisp_Object next = Fcdr (lax_plist); | |
| 1858 | |
| 1859 CHECK_CONS (next); /* just make doubly sure we catch any errors */ | |
| 1860 if (!NILP (nil_means_not_present) && NILP (Fcar (next))) | |
| 1861 { | |
| 1862 if (EQ (head, lax_plist)) | |
| 1863 head = Fcdr (next); | |
| 1864 lax_plist = Fcdr (next); | |
| 1865 continue; | |
| 1866 } | |
| 1867 /* external_remprop returns 1 if it removed any property. | |
| 1868 We have to loop till it didn't remove anything, in case | |
| 1869 the property occurs many times. */ | |
| 1870 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME)) | |
| 1871 DO_NOTHING; | |
| 1872 lax_plist = Fcdr (next); | |
| 1873 } | |
| 1874 | |
| 1875 return head; | |
| 1876 } | |
| 1877 | |
| 1878 /* In C because the frame props stuff uses it */ | |
| 1879 | |
| 1880 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /* | |
| 1881 Convert association list ALIST into the equivalent property-list form. | |
| 1882 The plist is returned. This converts from | |
| 1883 | |
| 1884 \((a . 1) (b . 2) (c . 3)) | |
| 1885 | |
| 1886 into | |
| 1887 | |
| 1888 \(a 1 b 2 c 3) | |
| 1889 | |
| 1890 The original alist is destroyed in the process of constructing the plist. | |
| 1891 See also `alist-to-plist'. | |
| 1892 */ | |
| 1893 (alist)) | |
| 1894 { | |
| 1895 Lisp_Object head = alist; | |
| 1896 while (!NILP (alist)) | |
| 1897 { | |
| 1898 /* remember the alist element. */ | |
| 1899 Lisp_Object el = Fcar (alist); | |
| 1900 | |
| 1901 Fsetcar (alist, Fcar (el)); | |
| 1902 Fsetcar (el, Fcdr (el)); | |
| 1903 Fsetcdr (el, Fcdr (alist)); | |
| 1904 Fsetcdr (alist, el); | |
| 1905 alist = Fcdr (Fcdr (alist)); | |
| 1906 } | |
| 1907 | |
| 1908 return head; | |
| 1909 } | |
| 1910 | |
| 1911 DEFUN ("get", Fget, 2, 3, 0, /* | |
| 442 | 1912 Return the value of OBJECT's PROPERTY property. |
| 1913 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. | |
| 428 | 1914 If there is no such property, return optional third arg DEFAULT |
| 442 | 1915 \(which defaults to `nil'). OBJECT can be a symbol, string, extent, |
|
5255
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
1916 face, glyph, or process. See also `put', `remprop', `object-plist', and |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
1917 `object-setplist'. |
| 428 | 1918 */ |
| 442 | 1919 (object, property, default_)) |
| 428 | 1920 { |
| 1921 /* Various places in emacs call Fget() and expect it not to quit, | |
| 1922 so don't quit. */ | |
| 442 | 1923 Lisp_Object val; |
| 1924 | |
| 1925 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop) | |
| 1926 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property); | |
| 428 | 1927 else |
| 563 | 1928 invalid_operation ("Object type has no properties", object); |
| 442 | 1929 |
| 1930 return UNBOUNDP (val) ? default_ : val; | |
| 428 | 1931 } |
| 1932 | |
| 1933 DEFUN ("put", Fput, 3, 3, 0, /* | |
| 442 | 1934 Set OBJECT's PROPERTY to VALUE. |
| 1935 It can be subsequently retrieved with `(get OBJECT PROPERTY)'. | |
| 1936 OBJECT can be a symbol, face, extent, or string. | |
| 428 | 1937 For a string, no properties currently have predefined meanings. |
| 1938 For the predefined properties for extents, see `set-extent-property'. | |
| 1939 For the predefined properties for faces, see `set-face-property'. | |
| 1940 See also `get', `remprop', and `object-plist'. | |
| 1941 */ | |
| 442 | 1942 (object, property, value)) |
| 428 | 1943 { |
| 1920 | 1944 /* This function cannot GC */ |
| 428 | 1945 CHECK_LISP_WRITEABLE (object); |
| 1946 | |
| 442 | 1947 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop) |
| 428 | 1948 { |
| 442 | 1949 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop |
| 1950 (object, property, value)) | |
| 563 | 1951 invalid_change ("Can't set property on object", property); |
| 428 | 1952 } |
| 1953 else | |
| 563 | 1954 invalid_change ("Object type has no settable properties", object); |
| 428 | 1955 |
| 1956 return value; | |
| 1957 } | |
| 1958 | |
| 1959 DEFUN ("remprop", Fremprop, 2, 2, 0, /* | |
| 442 | 1960 Remove, from OBJECT's property list, PROPERTY and its corresponding value. |
|
5255
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
1961 OBJECT can be a symbol, string, extent, face, glyph, or process. |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
1962 Return non-nil if the property list was actually modified (i.e. if PROPERTY |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
1963 was present in the property list). See also `get', `put', `object-plist', |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
1964 and `object-setplist'. |
| 428 | 1965 */ |
| 442 | 1966 (object, property)) |
| 428 | 1967 { |
| 442 | 1968 int ret = 0; |
| 1969 | |
| 428 | 1970 CHECK_LISP_WRITEABLE (object); |
| 1971 | |
| 442 | 1972 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop) |
| 428 | 1973 { |
| 442 | 1974 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property); |
| 1975 if (ret == -1) | |
| 563 | 1976 invalid_change ("Can't remove property from object", property); |
| 428 | 1977 } |
| 1978 else | |
| 563 | 1979 invalid_change ("Object type has no removable properties", object); |
| 442 | 1980 |
| 1981 return ret ? Qt : Qnil; | |
| 428 | 1982 } |
| 1983 | |
| 1984 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* | |
| 442 | 1985 Return a property list of OBJECT's properties. |
| 1986 For a symbol, this is equivalent to `symbol-plist'. | |
| 1987 OBJECT can be a symbol, string, extent, face, or glyph. | |
| 1988 Do not modify the returned property list directly; | |
| 1989 this may or may not have the desired effects. Use `put' instead. | |
| 428 | 1990 */ |
| 1991 (object)) | |
| 1992 { | |
| 442 | 1993 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist) |
| 1994 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object); | |
| 428 | 1995 else |
| 563 | 1996 invalid_operation ("Object type has no properties", object); |
| 428 | 1997 |
| 1998 return Qnil; | |
| 1999 } | |
| 2000 | |
|
5255
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2001 DEFUN ("object-setplist", Fobject_setplist, 2, 2, 0, /* |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2002 Set OBJECT's property list to NEWPLIST, and return NEWPLIST. |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2003 For a symbol, this is equivalent to `setplist'. |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2004 |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2005 OBJECT can be a symbol or a process, other objects with visible plists do |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2006 not allow their modification with `object-setplist'. |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2007 */ |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2008 (object, newplist)) |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2009 { |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2010 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->setplist) |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2011 { |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2012 return XRECORD_LHEADER_IMPLEMENTATION (object)->setplist (object, |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2013 newplist); |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2014 } |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2015 |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2016 invalid_operation ("Not possible to set object's plist", object); |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2017 return Qnil; |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2018 } |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2019 |
|
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
2020 |
| 428 | 2021 |
| 853 | 2022 static Lisp_Object |
| 2023 tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2, | |
| 2024 Lisp_Object depth) | |
| 2025 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2026 return make_fixnum (internal_equal (obj1, obj2, XFIXNUM (depth))); |
| 853 | 2027 } |
| 2028 | |
| 2029 int | |
| 2030 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
|
2031 const Ascbyte *warning_string, |
| 853 | 2032 int flags, |
| 2033 struct call_trapping_problems_result *p, | |
| 2034 int retval, | |
| 2035 Lisp_Object obj1, Lisp_Object obj2, | |
| 2036 int depth) | |
| 2037 { | |
| 2038 Lisp_Object glorp = | |
| 2039 va_call_trapping_problems (warning_class, warning_string, | |
| 2040 flags, p, | |
| 2041 (lisp_fn_t) tweaked_internal_equal, | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2042 3, obj1, obj2, make_fixnum (depth)); |
| 853 | 2043 if (UNBOUNDP (glorp)) |
| 2044 return retval; | |
| 2045 else | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2046 return XFIXNUM (glorp); |
| 853 | 2047 } |
| 2048 | |
| 428 | 2049 int |
| 2050 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2051 { | |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
2052 if (depth + lisp_eval_depth > max_lisp_eval_depth) |
| 563 | 2053 stack_overflow ("Stack overflow in equal", Qunbound); |
| 428 | 2054 QUIT; |
| 2055 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) | |
| 2056 return 1; | |
| 2057 /* Note that (equal 20 20.0) should be nil */ | |
| 2058 if (XTYPE (obj1) != XTYPE (obj2)) | |
| 2059 return 0; | |
| 2060 if (LRECORDP (obj1)) | |
| 2061 { | |
| 442 | 2062 const struct lrecord_implementation |
| 428 | 2063 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), |
| 2064 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
| 2065 | |
| 2066 return (imp1 == imp2) && | |
| 2067 /* 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
|
2068 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0)); |
| 428 | 2069 } |
| 2070 | |
| 2071 return 0; | |
| 2072 } | |
| 2073 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2074 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
|
2075 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2076 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
|
2077 ARRAY_STRING, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2078 ARRAY_VECTOR, |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2079 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
|
2080 }; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2081 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2082 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
|
2083 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
|
2084 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2085 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
|
2086 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
|
2087 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
|
2088 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
|
2089 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
|
2090 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
|
2091 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
|
2092 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2093 |
| 801 | 2094 int |
| 2095 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) | |
| 2096 { | |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
2097 if (depth + lisp_eval_depth > max_lisp_eval_depth) |
| 801 | 2098 stack_overflow ("Stack overflow in equalp", Qunbound); |
| 2099 QUIT; | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2100 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2101 /* 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
|
2102 of two equal fixnums or the same object seen twice. */ |
| 801 | 2103 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) |
| 2104 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
|
2105 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2106 /* 2. If both numbers, compare with `='. */ |
| 1983 | 2107 if (NUMBERP (obj1) && NUMBERP (obj2)) |
| 2108 { | |
|
4910
6bc1f3f6cf0d
Make canoncase visible to Lisp; use it with chars in internal_equalp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4906
diff
changeset
|
2109 return (0 == bytecode_arithcompare (obj1, obj2)); |
| 1983 | 2110 } |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2111 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2112 /* 3. If characters, compare case-insensitively. */ |
| 801 | 2113 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
|
2114 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
|
2115 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2116 /* 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
|
2117 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
|
2118 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2119 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
|
2120 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
|
2121 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
|
2122 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
|
2123 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2124 EMACS_INT i; |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2125 EMACS_INT l1 = XFIXNUM (Flength (obj1)); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2126 EMACS_INT l2 = XFIXNUM (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
|
2127 /* 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
|
2128 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
|
2129 return 0; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2130 for (i = 0; i < l1; i++) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2131 if (!internal_equalp (Faref (obj1, make_fixnum (i)), |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2132 Faref (obj2, make_fixnum (i)), depth + 1)) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2133 return 0; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2134 return 1; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2135 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2136 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2137 /* 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
|
2138 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
|
2139 their contents, the equal() method will call internal_equal_0(). */ |
| 801 | 2140 if (XTYPE (obj1) != XTYPE (obj2)) |
| 2141 return 0; | |
| 2142 if (LRECORDP (obj1)) | |
| 2143 { | |
| 2144 const struct lrecord_implementation | |
| 2145 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), | |
| 2146 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); | |
| 2147 | |
| 2148 return (imp1 == imp2) && | |
| 2149 /* 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
|
2150 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1)); |
| 801 | 2151 } |
| 2152 | |
| 2153 return 0; | |
| 2154 } | |
| 2155 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2156 int |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2157 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
|
2158 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2159 if (foldcase) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2160 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
|
2161 else |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2162 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
|
2163 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2164 |
| 428 | 2165 DEFUN ("equal", Fequal, 2, 2, 0, /* |
| 2166 Return t if two Lisp objects have similar structure and contents. | |
| 2167 They must have the same data type. | |
| 2168 Conses are compared by comparing the cars and the cdrs. | |
| 2169 Vectors and strings are compared element by element. | |
| 2170 Numbers are compared by value. Symbols must match exactly. | |
| 2171 */ | |
| 444 | 2172 (object1, object2)) |
| 428 | 2173 { |
| 444 | 2174 return internal_equal (object1, object2, 0) ? Qt : Qnil; |
| 428 | 2175 } |
| 2176 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2177 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
|
2178 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
|
2179 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2180 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
|
2181 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
|
2182 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
|
2183 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2184 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
|
2185 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
|
2186 `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
|
2187 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2188 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
|
2189 `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
|
2190 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
|
2191 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
|
2192 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
|
2193 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
|
2194 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
|
2195 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
|
2196 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2197 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
|
2198 (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
|
2199 `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
|
2200 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
|
2201 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
|
2202 */ |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2203 (object1, object2)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2204 { |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2205 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
|
2206 } |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2207 |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2208 #ifdef SUPPORT_CONFOUNDING_FUNCTIONS |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2209 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2210 /* Note that we may be calling sub-objects that will use |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2211 internal_equal() (instead of internal_old_equal()). Oh well. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2212 We will get an Ebola note if there's any possibility of confusion, |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2213 but that seems unlikely. */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2214 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2215 static int |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2216 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2217 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2218 if (depth + lisp_eval_depth > max_lisp_eval_depth) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2219 stack_overflow ("Stack overflow in equal", Qunbound); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2220 QUIT; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2221 if (HACKEQ_UNSAFE (obj1, obj2)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2222 return 1; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2223 /* Note that (equal 20 20.0) should be nil */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2224 if (XTYPE (obj1) != XTYPE (obj2)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2225 return 0; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2226 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2227 return internal_equal (obj1, obj2, depth); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2228 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2229 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2230 DEFUN ("old-member", Fold_member, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2231 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2232 The value is actually the tail of LIST whose car is ELT. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2233 This function is provided only for byte-code compatibility with v19. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2234 Do not use it. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2235 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2236 (elt, list)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2237 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2238 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2239 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2240 if (internal_old_equal (elt, list_elt, 0)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2241 return tail; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2242 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2243 return Qnil; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2244 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2245 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2246 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2247 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2248 The value is actually the tail of LIST whose car is ELT. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2249 This function is provided only for byte-code compatibility with v19. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2250 Do not use it. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2251 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2252 (elt, list)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2253 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2254 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2255 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2256 if (HACKEQ_UNSAFE (elt, list_elt)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2257 return tail; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2258 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2259 return Qnil; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2260 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2261 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2262 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2263 Return non-nil if KEY is `old-equal' to the car of an element of ALIST. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2264 The value is actually the element of ALIST whose car equals KEY. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2265 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2266 (key, alist)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2267 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2268 /* This function can GC. */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2269 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2270 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2271 if (internal_old_equal (key, elt_car, 0)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2272 return elt; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2273 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2274 return Qnil; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2275 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2276 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2277 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2278 Return non-nil if KEY is `old-eq' to the car of an element of ALIST. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2279 The value is actually the element of ALIST whose car is KEY. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2280 Elements of ALIST that are not conses are ignored. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2281 This function is provided only for byte-code compatibility with v19. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2282 Do not use it. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2283 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2284 (key, alist)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2285 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2286 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2287 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2288 if (HACKEQ_UNSAFE (key, elt_car)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2289 return elt; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2290 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2291 return Qnil; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2292 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2293 |
|
5607
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2294 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2295 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2296 The value is actually the element of ALIST whose cdr is VALUE. |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2297 */ |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2298 (value, alist)) |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2299 { |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2300 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2301 { |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2302 if (HACKEQ_UNSAFE (value, elt_cdr)) |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2303 return elt; |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2304 } |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2305 return Qnil; |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2306 } |
|
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
2307 |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2308 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2309 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2310 The value is actually the element of ALIST whose cdr equals VALUE. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2311 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2312 (value, alist)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2313 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2314 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2315 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2316 if (internal_old_equal (value, elt_cdr, 0)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2317 return elt; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2318 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2319 return Qnil; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2320 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2321 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2322 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2323 Delete by side effect any occurrences of ELT as a member of LIST. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2324 The modified LIST is returned. Comparison is done with `old-equal'. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2325 If the first member of LIST is ELT, there is no way to remove it by side |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2326 effect; therefore, write `(setq foo (old-delete element foo))' to be sure |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2327 of changing the value of `foo'. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2328 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2329 (elt, list)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2330 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2331 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2332 (internal_old_equal (elt, list_elt, 0))); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2333 return list; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2334 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2335 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2336 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2337 Delete by side effect any occurrences of ELT as a member of LIST. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2338 The modified LIST is returned. Comparison is done with `old-eq'. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2339 If the first member of LIST is ELT, there is no way to remove it by side |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2340 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2341 changing the value of `foo'. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2342 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2343 (elt, list)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2344 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2345 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2346 (HACKEQ_UNSAFE (elt, list_elt))); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2347 return list; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2348 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2349 |
| 428 | 2350 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* |
| 2351 Return t if two Lisp objects have similar structure and contents. | |
| 2352 They must have the same data type. | |
| 2353 \(Note, however, that an exception is made for characters and integers; | |
| 2354 this is known as the "char-int confoundance disease." See `eq' and | |
| 2355 `old-eq'.) | |
| 2356 This function is provided only for byte-code compatibility with v19. | |
| 2357 Do not use it. | |
| 2358 */ | |
| 444 | 2359 (object1, object2)) |
| 428 | 2360 { |
| 444 | 2361 return internal_old_equal (object1, object2, 0) ? Qt : Qnil; |
| 428 | 2362 } |
| 2363 | |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2364 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /* |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2365 Return t if the two args are (in most cases) the same Lisp object. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2366 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2367 Special kludge: A character is considered `old-eq' to its equivalent integer |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2368 even though they are not the same object and are in fact of different |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2369 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2370 preserve byte-code compatibility with v19. This kludge is known as the |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2371 \"char-int confoundance disease\" and appears in a number of other |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2372 functions with `old-foo' equivalents. |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2373 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2374 Do not use this function! |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2375 */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2376 (object1, object2)) |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2377 { |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2378 /* #### blasphemy */ |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2379 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil; |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2380 } |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2381 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2382 #endif |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
2383 |
| 428 | 2384 Lisp_Object |
| 2385 nconc2 (Lisp_Object arg1, Lisp_Object arg2) | |
| 2386 { | |
| 2387 Lisp_Object args[2]; | |
| 2388 struct gcpro gcpro1; | |
| 2389 args[0] = arg1; | |
| 2390 args[1] = arg2; | |
| 2391 | |
| 2392 GCPRO1 (args[0]); | |
| 2393 gcpro1.nvars = 2; | |
| 2394 | |
| 2395 RETURN_UNGCPRO (bytecode_nconc2 (args)); | |
| 2396 } | |
| 2397 | |
| 2398 Lisp_Object | |
| 2399 bytecode_nconc2 (Lisp_Object *args) | |
| 2400 { | |
| 2401 retry: | |
| 2402 | |
| 2403 if (CONSP (args[0])) | |
| 2404 { | |
| 2405 /* (setcdr (last args[0]) args[1]) */ | |
| 2406 Lisp_Object tortoise, hare; | |
| 665 | 2407 Elemcount count; |
| 428 | 2408 |
| 2409 for (hare = tortoise = args[0], count = 0; | |
| 2410 CONSP (XCDR (hare)); | |
| 2411 hare = XCDR (hare), count++) | |
| 2412 { | |
| 2413 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 2414 | |
| 2415 if (count & 1) | |
| 2416 tortoise = XCDR (tortoise); | |
| 2417 if (EQ (hare, tortoise)) | |
| 2418 signal_circular_list_error (args[0]); | |
| 2419 } | |
| 2420 XCDR (hare) = args[1]; | |
| 2421 return args[0]; | |
| 2422 } | |
| 2423 else if (NILP (args[0])) | |
| 2424 { | |
| 2425 return args[1]; | |
| 2426 } | |
| 2427 else | |
| 2428 { | |
| 2429 args[0] = wrong_type_argument (args[0], Qlistp); | |
| 2430 goto retry; | |
| 2431 } | |
| 2432 } | |
| 2433 | |
| 2434 DEFUN ("nconc", Fnconc, 0, MANY, 0, /* | |
| 2435 Concatenate any number of lists by altering them. | |
| 2436 Only the last argument is not altered, and need not be a list. | |
| 2437 Also see: `append'. | |
| 2438 If the first argument is nil, there is no way to modify it by side | |
| 2439 effect; therefore, write `(setq foo (nconc foo list))' to be sure of | |
| 2440 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
|
2441 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3842
diff
changeset
|
2442 arguments: (&rest ARGS) |
| 428 | 2443 */ |
| 2444 (int nargs, Lisp_Object *args)) | |
| 2445 { | |
| 2446 int argnum = 0; | |
| 2447 struct gcpro gcpro1; | |
| 2448 | |
| 2449 /* The modus operandi in Emacs is "caller gc-protects args". | |
| 2450 However, nconc (particularly nconc2 ()) is called many times | |
| 2451 in Emacs on freshly created stuff (e.g. you see the idiom | |
| 2452 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those | |
| 2453 callers out by protecting the args ourselves to save them | |
| 2454 a lot of temporary-variable grief. */ | |
| 2455 | |
| 2456 GCPRO1 (args[0]); | |
| 2457 gcpro1.nvars = nargs; | |
| 2458 | |
| 2459 while (argnum < nargs) | |
| 2460 { | |
| 2461 Lisp_Object val; | |
| 2462 retry: | |
| 2463 val = args[argnum]; | |
| 2464 if (CONSP (val)) | |
| 2465 { | |
| 2466 /* `val' is the first cons, which will be our return value. */ | |
| 2467 /* `last_cons' will be the cons cell to mutate. */ | |
| 2468 Lisp_Object last_cons = val; | |
| 2469 Lisp_Object tortoise = val; | |
| 2470 | |
| 2471 for (argnum++; argnum < nargs; argnum++) | |
| 2472 { | |
| 2473 Lisp_Object next = args[argnum]; | |
| 2474 retry_next: | |
| 2475 if (CONSP (next) || argnum == nargs -1) | |
| 2476 { | |
| 2477 /* (setcdr (last val) next) */ | |
| 665 | 2478 Elemcount count; |
| 428 | 2479 |
| 2480 for (count = 0; | |
| 2481 CONSP (XCDR (last_cons)); | |
| 2482 last_cons = XCDR (last_cons), count++) | |
| 2483 { | |
| 2484 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue; | |
| 2485 | |
| 2486 if (count & 1) | |
| 2487 tortoise = XCDR (tortoise); | |
| 2488 if (EQ (last_cons, tortoise)) | |
| 2489 signal_circular_list_error (args[argnum-1]); | |
| 2490 } | |
| 2491 XCDR (last_cons) = next; | |
| 2492 } | |
| 2493 else if (NILP (next)) | |
| 2494 { | |
| 2495 continue; | |
| 2496 } | |
| 2497 else | |
| 2498 { | |
| 2499 next = wrong_type_argument (Qlistp, next); | |
| 2500 goto retry_next; | |
| 2501 } | |
| 2502 } | |
| 2503 RETURN_UNGCPRO (val); | |
| 2504 } | |
| 2505 else if (NILP (val)) | |
| 2506 argnum++; | |
| 2507 else if (argnum == nargs - 1) /* last arg? */ | |
| 2508 RETURN_UNGCPRO (val); | |
| 2509 else | |
| 2510 { | |
| 2511 args[argnum] = wrong_type_argument (Qlistp, val); | |
| 2512 goto retry; | |
| 2513 } | |
| 2514 } | |
| 2515 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ | |
| 2516 } | |
| 2517 | |
| 2518 | |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2519 /* 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
|
2520 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
|
2521 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
|
2522 |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2523 CALLER is a symbol reflecting the Lisp-visible function that was called, |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2524 and any errors thrown because SEQUENCES was modified will reflect it. |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2525 |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2526 If CALLER is Qmapl, return LISTS[0]. Otherwise, return a list of the |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2527 return values from FUNCTION; if caller is Qmapcan, nconc them together. |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2528 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2529 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
|
2530 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
|
2531 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
|
2532 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2533 static Lisp_Object |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2534 maplist (Lisp_Object function, int nlists, Lisp_Object *lists, |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2535 Lisp_Object caller) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2536 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2537 Lisp_Object nconcing[2], accum = Qnil, *args, *tortoises, funcalled; |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2538 Lisp_Object result = EQ (caller, Qmapl) ? lists[0] : Qnil; |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2539 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2540 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
|
2541 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2542 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
|
2543 args[0] = function; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2544 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
|
2545 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2546 args[i] = Qnil; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2547 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2548 |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2549 tortoises = alloca_array (Lisp_Object, nlists); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2550 memcpy (tortoises, lists, nlists * sizeof (Lisp_Object)); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2551 |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2552 if (EQ (caller, Qmapcon)) |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2553 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2554 nconcing[0] = Qnil; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2555 nconcing[1] = Qnil; |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2556 GCPRO4 (args[0], nconcing[0], tortoises[0], result); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2557 gcpro1.nvars = 1; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2558 gcpro2.nvars = 2; |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2559 gcpro3.nvars = nlists; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2560 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2561 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2562 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2563 GCPRO3 (args[0], tortoises[0], result); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2564 gcpro1.nvars = 1; |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2565 gcpro2.nvars = nlists; |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2566 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2567 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2568 while (continuing) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2569 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2570 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
|
2571 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2572 if (CONSP (lists[j])) |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2573 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2574 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
|
2575 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
|
2576 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2577 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
|
2578 { |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2579 continuing = 0; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2580 break; |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2581 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2582 else |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2583 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2584 lists[j] = wrong_type_argument (Qlistp, lists[j]); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2585 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2586 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2587 if (!continuing) break; |
|
4997
8800b5350a13
Move #'some, #'every to C, implementing them with mapcarX.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4996
diff
changeset
|
2588 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args)); |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2589 |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2590 if (EQ (caller, Qmapl)) |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2591 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2592 DO_NOTHING; |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2593 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2594 else if (EQ (caller, Qmapcon)) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2595 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2596 nconcing[1] = funcalled; |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2597 accum = bytecode_nconc2 (nconcing); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2598 if (NILP (result)) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2599 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2600 result = accum; |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2601 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2602 /* Only check a given stretch of result for well-formedness |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2603 once: */ |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2604 nconcing[0] = funcalled; |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2605 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2606 else if (NILP (accum)) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2607 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2608 accum = result = Fcons (funcalled, Qnil); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2609 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2610 else |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2611 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2612 /* Add to the end, avoiding the need to call nreverse |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2613 once we're done: */ |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2614 XSETCDR (accum, Fcons (funcalled, Qnil)); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2615 accum = XCDR (accum); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2616 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2617 |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2618 if (++called_count > CIRCULAR_LIST_SUSPICION_LENGTH) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2619 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2620 if (called_count & 1) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2621 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2622 for (j = 0; j < nlists; ++j) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2623 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2624 tortoises[j] = XCDR (tortoises[j]); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2625 if (EQ (lists[j], tortoises[j])) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2626 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2627 signal_circular_list_error (lists[j]); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2628 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2629 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2630 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2631 else |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2632 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2633 for (j = 0; j < nlists; ++j) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2634 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2635 if (EQ (lists[j], tortoises[j])) |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2636 { |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2637 signal_circular_list_error (lists[j]); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2638 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2639 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2640 } |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2641 } |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2642 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2643 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2644 RETURN_UNGCPRO (result); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2645 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2646 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2647 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
|
2648 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
|
2649 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
|
2650 the elements themselves." |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2651 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2652 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
|
2653 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2654 (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
|
2655 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2656 return maplist (args[0], nargs - 1, args + 1, Qmaplist); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2657 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2658 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2659 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
|
2660 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
|
2661 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2662 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
|
2663 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2664 (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
|
2665 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2666 return maplist (args[0], nargs - 1, args + 1, Qmapl); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2667 } |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2668 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2669 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
|
2670 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
|
2671 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2672 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
|
2673 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
|
2674 |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2675 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
|
2676 */ |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2677 (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
|
2678 { |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
2679 return maplist (args[0], nargs - 1, args + 1, Qmapcon); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
2680 } |
|
5227
fbd1485af104
Move #'reduce to fns.c from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5224
diff
changeset
|
2681 |
| 442 | 2682 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* |
| 2683 Destructively replace the list OLD with NEW. | |
| 2684 This is like (copy-sequence NEW) except that it reuses the | |
| 2685 conses in OLD as much as possible. If OLD and NEW are the same | |
| 2686 length, no consing will take place. | |
| 2687 */ | |
| 3025 | 2688 (old, new_)) |
| 442 | 2689 { |
| 2367 | 2690 Lisp_Object oldtail = old, prevoldtail = Qnil; |
| 2691 | |
| 3025 | 2692 EXTERNAL_LIST_LOOP_2 (elt, new_) |
| 442 | 2693 { |
| 2694 if (!NILP (oldtail)) | |
| 2695 { | |
| 2696 CHECK_CONS (oldtail); | |
| 2367 | 2697 XCAR (oldtail) = elt; |
| 442 | 2698 } |
| 2699 else if (!NILP (prevoldtail)) | |
| 2700 { | |
| 2367 | 2701 XCDR (prevoldtail) = Fcons (elt, Qnil); |
| 442 | 2702 prevoldtail = XCDR (prevoldtail); |
| 2703 } | |
| 2704 else | |
| 2367 | 2705 old = oldtail = Fcons (elt, Qnil); |
| 442 | 2706 |
| 2707 if (!NILP (oldtail)) | |
| 2708 { | |
| 2709 prevoldtail = oldtail; | |
| 2710 oldtail = XCDR (oldtail); | |
| 2711 } | |
| 2712 } | |
| 2713 | |
| 2714 if (!NILP (prevoldtail)) | |
| 2715 XCDR (prevoldtail) = Qnil; | |
| 2716 else | |
| 2717 old = Qnil; | |
| 2718 | |
| 2719 return old; | |
| 2720 } | |
| 2721 | |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
2722 |
| 771 | 2723 Lisp_Object |
| 2367 | 2724 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) |
| 771 | 2725 { |
| 2726 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
|
2727 build_ascstring (ascii_string)), |
| 771 | 2728 Qnil); |
| 2729 } | |
| 2730 | |
| 2731 Lisp_Object | |
| 2367 | 2732 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol) |
| 771 | 2733 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4797
diff
changeset
|
2734 return Fintern (concat2 (build_ascstring (ascii_string), |
| 771 | 2735 Fsymbol_name (symbol)), |
| 2736 Qnil); | |
| 2737 } | |
| 442 | 2738 |
| 428 | 2739 /* #### this function doesn't belong in this file! */ |
| 2740 | |
| 442 | 2741 #ifdef HAVE_GETLOADAVG |
| 2742 #ifdef HAVE_SYS_LOADAVG_H | |
| 2743 #include <sys/loadavg.h> | |
| 2744 #endif | |
| 2745 #else | |
| 2746 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */ | |
| 2747 #endif | |
| 2748 | |
| 428 | 2749 DEFUN ("load-average", Fload_average, 0, 1, 0, /* |
| 2750 Return list of 1 minute, 5 minute and 15 minute load averages. | |
| 2751 Each of the three load averages is multiplied by 100, | |
| 2752 then converted to integer. | |
| 2753 | |
| 2754 When USE-FLOATS is non-nil, floats will be used instead of integers. | |
| 2755 These floats are not multiplied by 100. | |
| 2756 | |
| 2757 If the 5-minute or 15-minute load averages are not available, return a | |
| 2758 shortened list, containing only those averages which are available. | |
| 2759 | |
| 2760 On some systems, this won't work due to permissions on /dev/kmem, | |
| 2761 in which case you can't use this. | |
| 2762 */ | |
| 2763 (use_floats)) | |
| 2764 { | |
| 2765 double load_ave[3]; | |
| 2766 int loads = getloadavg (load_ave, countof (load_ave)); | |
| 2767 Lisp_Object ret = Qnil; | |
| 2768 | |
| 2769 if (loads == -2) | |
| 563 | 2770 signal_error (Qunimplemented, |
| 2771 "load-average not implemented for this operating system", | |
| 2772 Qunbound); | |
| 428 | 2773 else if (loads < 0) |
| 563 | 2774 invalid_operation ("Could not get load-average", lisp_strerror (errno)); |
| 428 | 2775 |
| 2776 while (loads-- > 0) | |
| 2777 { | |
| 2778 Lisp_Object load = (NILP (use_floats) ? | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2779 make_fixnum ((int) (100.0 * load_ave[loads])) |
| 428 | 2780 : make_float (load_ave[loads])); |
| 2781 ret = Fcons (load, ret); | |
| 2782 } | |
| 2783 return ret; | |
| 2784 } | |
| 2785 | |
| 2786 | |
| 2787 Lisp_Object Vfeatures; | |
| 2788 | |
| 2789 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /* | |
| 2790 Return non-nil if feature FEXP is present in this Emacs. | |
| 2791 Use this to conditionalize execution of lisp code based on the | |
| 2792 presence or absence of emacs or environment extensions. | |
| 2793 FEXP can be a symbol, a number, or a list. | |
| 2794 If it is a symbol, that symbol is looked up in the `features' variable, | |
| 2795 and non-nil will be returned if found. | |
| 2796 If it is a number, the function will return non-nil if this Emacs | |
| 2797 has an equal or greater version number than FEXP. | |
| 2798 If it is a list whose car is the symbol `and', it will return | |
| 2799 non-nil if all the features in its cdr are non-nil. | |
| 2800 If it is a list whose car is the symbol `or', it will return non-nil | |
| 2801 if any of the features in its cdr are non-nil. | |
| 2802 If it is a list whose car is the symbol `not', it will return | |
| 2803 non-nil if the feature is not present. | |
| 2804 | |
| 2805 Examples: | |
| 2806 | |
| 2807 (featurep 'xemacs) | |
| 2808 => ; Non-nil on XEmacs. | |
| 2809 | |
| 2810 (featurep '(and xemacs gnus)) | |
| 2811 => ; Non-nil on XEmacs with Gnus loaded. | |
| 2812 | |
| 2813 (featurep '(or tty-frames (and emacs 19.30))) | |
| 2814 => ; Non-nil if this Emacs supports TTY frames. | |
| 2815 | |
| 2816 (featurep '(or (and xemacs 19.15) (and emacs 19.34))) | |
| 2817 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later. | |
| 2818 | |
| 442 | 2819 (featurep '(and xemacs 21.02)) |
| 2820 => ; Non-nil on XEmacs 21.2 and later. | |
| 2821 | |
| 428 | 2822 NOTE: The advanced arguments of this function (anything other than a |
| 2823 symbol) are not yet supported by FSF Emacs. If you feel they are useful | |
| 2824 for supporting multiple Emacs variants, lobby Richard Stallman at | |
| 442 | 2825 <bug-gnu-emacs@gnu.org>. |
| 428 | 2826 */ |
| 2827 (fexp)) | |
| 2828 { | |
| 2829 #ifndef FEATUREP_SYNTAX | |
| 2830 CHECK_SYMBOL (fexp); | |
| 2831 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
| 2832 #else /* FEATUREP_SYNTAX */ | |
| 2833 static double featurep_emacs_version; | |
| 2834 | |
| 2835 /* Brute force translation from Erik Naggum's lisp function. */ | |
| 2836 if (SYMBOLP (fexp)) | |
| 2837 { | |
| 2838 /* Original definition */ | |
| 2839 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt; | |
| 2840 } | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2841 else if (FIXNUMP (fexp) || FLOATP (fexp)) |
| 428 | 2842 { |
| 2843 double d = extract_float (fexp); | |
| 2844 | |
| 2845 if (featurep_emacs_version == 0.0) | |
| 2846 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2847 featurep_emacs_version = XFIXNUM (Vemacs_major_version) + |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
2848 (XFIXNUM (Vemacs_minor_version) / 100.0); |
| 428 | 2849 } |
| 2850 return featurep_emacs_version >= d ? Qt : Qnil; | |
| 2851 } | |
| 2852 else if (CONSP (fexp)) | |
| 2853 { | |
| 2854 Lisp_Object tem = XCAR (fexp); | |
| 2855 if (EQ (tem, Qnot)) | |
| 2856 { | |
| 2857 Lisp_Object negate; | |
| 2858 | |
| 2859 tem = XCDR (fexp); | |
| 2860 negate = Fcar (tem); | |
| 2861 if (!NILP (tem)) | |
| 2862 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil; | |
| 2863 else | |
| 2864 return Fsignal (Qinvalid_read_syntax, list1 (tem)); | |
| 2865 } | |
| 2866 else if (EQ (tem, Qand)) | |
| 2867 { | |
| 2868 tem = XCDR (fexp); | |
| 2869 /* Use Fcar/Fcdr for error-checking. */ | |
| 2870 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem)))) | |
| 2871 { | |
| 2872 tem = Fcdr (tem); | |
| 2873 } | |
| 2874 return NILP (tem) ? Qt : Qnil; | |
| 2875 } | |
| 2876 else if (EQ (tem, Qor)) | |
| 2877 { | |
| 2878 tem = XCDR (fexp); | |
| 2879 /* Use Fcar/Fcdr for error-checking. */ | |
| 2880 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem)))) | |
| 2881 { | |
| 2882 tem = Fcdr (tem); | |
| 2883 } | |
| 2884 return NILP (tem) ? Qnil : Qt; | |
| 2885 } | |
| 2886 else | |
| 2887 { | |
| 2888 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp))); | |
| 2889 } | |
| 2890 } | |
| 2891 else | |
| 2892 { | |
| 2893 return Fsignal (Qinvalid_read_syntax, list1 (fexp)); | |
| 2894 } | |
| 2895 } | |
| 2896 #endif /* FEATUREP_SYNTAX */ | |
| 2897 | |
| 2898 DEFUN ("provide", Fprovide, 1, 1, 0, /* | |
| 2899 Announce that FEATURE is a feature of the current Emacs. | |
| 2900 This function updates the value of the variable `features'. | |
| 2901 */ | |
| 2902 (feature)) | |
| 2903 { | |
| 2904 Lisp_Object tem; | |
| 2905 CHECK_SYMBOL (feature); | |
| 2906 if (!NILP (Vautoload_queue)) | |
| 2907 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue); | |
| 2908 tem = Fmemq (feature, Vfeatures); | |
| 2909 if (NILP (tem)) | |
| 2910 Vfeatures = Fcons (feature, Vfeatures); | |
| 2911 LOADHIST_ATTACH (Fcons (Qprovide, feature)); | |
| 2912 return feature; | |
| 2913 } | |
| 2914 | |
| 1067 | 2915 DEFUN ("require", Frequire, 1, 3, 0, /* |
| 3842 | 2916 Ensure that FEATURE is present in the Lisp environment. |
| 2917 FEATURE is a symbol naming a collection of resources (functions, etc). | |
| 2918 Optional FILENAME is a library from which to load resources; it defaults to | |
| 2919 the print name of FEATURE. | |
| 2920 Optional NOERROR, if non-nil, causes require to return nil rather than signal | |
| 2921 `file-error' if loading the library fails. | |
| 2922 | |
| 2923 If feature FEATURE is present in `features', update `load-history' to reflect | |
| 2924 the require and return FEATURE. Otherwise, try to load it from a library. | |
| 2925 The normal messages at start and end of loading are suppressed. | |
| 2926 If the library is successfully loaded and it calls `(provide FEATURE)', add | |
| 2927 FEATURE to `features', update `load-history' and return FEATURE. | |
| 2928 If the load succeeds but FEATURE is not provided by the library, signal | |
| 2929 `invalid-state'. | |
| 2930 | |
| 2931 The byte-compiler treats top-level calls to `require' specially, by evaluating | |
| 2932 them at compile time (and then compiling them normally). Thus a library may | |
| 2933 request that definitions that should be inlined such as macros and defsubsts | |
| 2934 be loaded into its compilation environment. Achieving this in other contexts | |
| 2935 requires an explicit \(eval-and-compile ...\) block. | |
| 428 | 2936 */ |
| 1067 | 2937 (feature, filename, noerror)) |
| 428 | 2938 { |
| 2939 Lisp_Object tem; | |
| 2940 CHECK_SYMBOL (feature); | |
| 2941 tem = Fmemq (feature, Vfeatures); | |
| 2942 LOADHIST_ATTACH (Fcons (Qrequire, feature)); | |
| 2943 if (!NILP (tem)) | |
| 2944 return feature; | |
| 2945 else | |
| 2946 { | |
| 2947 int speccount = specpdl_depth (); | |
| 2948 | |
| 2949 /* Value saved here is to be restored into Vautoload_queue */ | |
| 2950 record_unwind_protect (un_autoload, Vautoload_queue); | |
| 2951 Vautoload_queue = Qt; | |
| 2952 | |
| 1067 | 2953 tem = call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename, |
| 1261 | 2954 noerror, Qrequire, Qnil); |
| 1067 | 2955 /* If load failed entirely, return nil. */ |
| 2956 if (NILP (tem)) | |
| 2957 return unbind_to_1 (speccount, Qnil); | |
| 428 | 2958 |
| 2959 tem = Fmemq (feature, Vfeatures); | |
| 2960 if (NILP (tem)) | |
| 563 | 2961 invalid_state ("Required feature was not provided", feature); |
| 428 | 2962 |
| 2963 /* Once loading finishes, don't undo it. */ | |
| 2964 Vautoload_queue = Qt; | |
| 771 | 2965 return unbind_to_1 (speccount, feature); |
| 428 | 2966 } |
| 2967 } | |
| 2968 | |
| 2969 /* base64 encode/decode functions. | |
| 2970 | |
| 2971 Originally based on code from GNU recode. Ported to FSF Emacs by | |
| 2972 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and | |
| 2973 subsequently heavily hacked by Hrvoje Niksic. */ | |
| 2974 | |
| 2975 #define MIME_LINE_LENGTH 72 | |
| 2976 | |
| 2977 #define IS_ASCII(Character) \ | |
| 2978 ((Character) < 128) | |
| 2979 #define IS_BASE64(Character) \ | |
| 2980 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) | |
| 2981 | |
| 2982 /* 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
|
2983 static Ascbyte base64_value_to_char[64] = |
| 428 | 2984 { |
| 2985 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */ | |
| 2986 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */ | |
| 2987 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */ | |
| 2988 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */ | |
| 2989 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */ | |
| 2990 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */ | |
| 2991 '8', '9', '+', '/' /* 60-63 */ | |
| 2992 }; | |
| 2993 | |
| 2994 /* Table of base64 values for first 128 characters. */ | |
| 2995 static short base64_char_to_value[128] = | |
| 2996 { | |
| 2997 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */ | |
| 2998 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */ | |
| 2999 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */ | |
| 3000 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */ | |
| 3001 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */ | |
| 3002 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */ | |
| 3003 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */ | |
| 3004 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */ | |
| 3005 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */ | |
| 3006 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */ | |
| 3007 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */ | |
| 3008 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */ | |
| 3009 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */ | |
| 3010 }; | |
| 3011 | |
| 3012 /* The following diagram shows the logical steps by which three octets | |
| 3013 get transformed into four base64 characters. | |
| 3014 | |
| 3015 .--------. .--------. .--------. | |
| 3016 |aaaaaabb| |bbbbcccc| |ccdddddd| | |
| 3017 `--------' `--------' `--------' | |
| 3018 6 2 4 4 2 6 | |
| 3019 .--------+--------+--------+--------. | |
| 3020 |00aaaaaa|00bbbbbb|00cccccc|00dddddd| | |
| 3021 `--------+--------+--------+--------' | |
| 3022 | |
| 3023 .--------+--------+--------+--------. | |
| 3024 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD| | |
| 3025 `--------+--------+--------+--------' | |
| 3026 | |
| 3027 The octets are divided into 6 bit chunks, which are then encoded into | |
| 3028 base64 characters. */ | |
| 3029 | |
|
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
|
3030 static DECLARE_DOESNT_RETURN (base64_conversion_error (const Ascbyte *, |
| 2268 | 3031 Lisp_Object)); |
| 3032 | |
| 575 | 3033 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
|
3034 base64_conversion_error (const Ascbyte *reason, Lisp_Object frob) |
| 563 | 3035 { |
| 3036 signal_error (Qbase64_conversion_error, reason, frob); | |
| 3037 } | |
| 3038 | |
| 3039 #define ADVANCE_INPUT(c, stream) \ | |
| 867 | 3040 ((ec = Lstream_get_ichar (stream)) == -1 ? 0 : \ |
| 563 | 3041 ((ec > 255) ? \ |
| 3042 (base64_conversion_error ("Non-ascii character in base64 input", \ | |
| 3043 make_char (ec)), 0) \ | |
| 867 | 3044 : (c = (Ibyte)ec), 1)) |
| 665 | 3045 |
| 3046 static Bytebpos | |
| 867 | 3047 base64_encode_1 (Lstream *istream, Ibyte *to, int line_break) |
| 428 | 3048 { |
| 3049 EMACS_INT counter = 0; | |
| 867 | 3050 Ibyte *e = to; |
| 3051 Ichar ec; | |
| 428 | 3052 unsigned int value; |
| 3053 | |
| 3054 while (1) | |
| 3055 { | |
| 1204 | 3056 Ibyte c = 0; |
| 428 | 3057 if (!ADVANCE_INPUT (c, istream)) |
| 3058 break; | |
| 3059 | |
| 3060 /* Wrap line every 76 characters. */ | |
| 3061 if (line_break) | |
| 3062 { | |
| 3063 if (counter < MIME_LINE_LENGTH / 4) | |
| 3064 counter++; | |
| 3065 else | |
| 3066 { | |
| 3067 *e++ = '\n'; | |
| 3068 counter = 1; | |
| 3069 } | |
| 3070 } | |
| 3071 | |
| 3072 /* Process first byte of a triplet. */ | |
| 3073 *e++ = base64_value_to_char[0x3f & c >> 2]; | |
| 3074 value = (0x03 & c) << 4; | |
| 3075 | |
| 3076 /* Process second byte of a triplet. */ | |
| 3077 if (!ADVANCE_INPUT (c, istream)) | |
| 3078 { | |
| 3079 *e++ = base64_value_to_char[value]; | |
| 3080 *e++ = '='; | |
| 3081 *e++ = '='; | |
| 3082 break; | |
| 3083 } | |
| 3084 | |
| 3085 *e++ = base64_value_to_char[value | (0x0f & c >> 4)]; | |
| 3086 value = (0x0f & c) << 2; | |
| 3087 | |
| 3088 /* Process third byte of a triplet. */ | |
| 3089 if (!ADVANCE_INPUT (c, istream)) | |
| 3090 { | |
| 3091 *e++ = base64_value_to_char[value]; | |
| 3092 *e++ = '='; | |
| 3093 break; | |
| 3094 } | |
| 3095 | |
| 3096 *e++ = base64_value_to_char[value | (0x03 & c >> 6)]; | |
| 3097 *e++ = base64_value_to_char[0x3f & c]; | |
| 3098 } | |
| 3099 | |
| 3100 return e - to; | |
| 3101 } | |
| 3102 #undef ADVANCE_INPUT | |
| 3103 | |
| 3104 /* Get next character from the stream, except that non-base64 | |
| 3105 characters are ignored. This is in accordance with rfc2045. EC | |
| 867 | 3106 should be an Ichar, so that it can hold -1 as the value for EOF. */ |
| 428 | 3107 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ |
| 867 | 3108 ec = Lstream_get_ichar (stream); \ |
| 428 | 3109 ++streampos; \ |
| 3110 /* IS_BASE64 may not be called with negative arguments so check for \ | |
| 3111 EOF first. */ \ | |
| 3112 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ | |
| 3113 break; \ | |
| 3114 } while (1) | |
| 3115 | |
| 3116 #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
|
3117 pos += set_itext_ichar (pos, (Ichar)((Binbyte)(val))); \ |
| 428 | 3118 ++ccnt; \ |
| 3119 } while (0) | |
| 3120 | |
| 665 | 3121 static Bytebpos |
| 867 | 3122 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr) |
| 428 | 3123 { |
| 3124 Charcount ccnt = 0; | |
| 867 | 3125 Ibyte *e = to; |
| 428 | 3126 EMACS_INT streampos = 0; |
| 3127 | |
| 3128 while (1) | |
| 3129 { | |
| 867 | 3130 Ichar ec; |
| 428 | 3131 unsigned long value; |
| 3132 | |
| 3133 /* Process first byte of a quadruplet. */ | |
| 3134 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3135 if (ec < 0) | |
| 3136 break; | |
| 3137 if (ec == '=') | |
| 563 | 3138 base64_conversion_error ("Illegal `=' character while decoding base64", |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3139 make_fixnum (streampos)); |
| 428 | 3140 value = base64_char_to_value[ec] << 18; |
| 3141 | |
| 3142 /* Process second byte of a quadruplet. */ | |
| 3143 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3144 if (ec < 0) | |
| 563 | 3145 base64_conversion_error ("Premature EOF while decoding base64", |
| 3146 Qunbound); | |
| 428 | 3147 if (ec == '=') |
| 563 | 3148 base64_conversion_error ("Illegal `=' character while decoding base64", |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3149 make_fixnum (streampos)); |
| 428 | 3150 value |= base64_char_to_value[ec] << 12; |
| 3151 STORE_BYTE (e, value >> 16, ccnt); | |
| 3152 | |
| 3153 /* Process third byte of a quadruplet. */ | |
| 3154 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3155 if (ec < 0) | |
| 563 | 3156 base64_conversion_error ("Premature EOF while decoding base64", |
| 3157 Qunbound); | |
| 428 | 3158 |
| 3159 if (ec == '=') | |
| 3160 { | |
| 3161 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3162 if (ec < 0) | |
| 563 | 3163 base64_conversion_error ("Premature EOF while decoding base64", |
| 3164 Qunbound); | |
| 428 | 3165 if (ec != '=') |
| 563 | 3166 base64_conversion_error |
| 3167 ("Padding `=' expected but not found while decoding base64", | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3168 make_fixnum (streampos)); |
| 428 | 3169 continue; |
| 3170 } | |
| 3171 | |
| 3172 value |= base64_char_to_value[ec] << 6; | |
| 3173 STORE_BYTE (e, 0xff & value >> 8, ccnt); | |
| 3174 | |
| 3175 /* Process fourth byte of a quadruplet. */ | |
| 3176 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); | |
| 3177 if (ec < 0) | |
| 563 | 3178 base64_conversion_error ("Premature EOF while decoding base64", |
| 3179 Qunbound); | |
| 428 | 3180 if (ec == '=') |
| 3181 continue; | |
| 3182 | |
| 3183 value |= base64_char_to_value[ec]; | |
| 3184 STORE_BYTE (e, 0xff & value, ccnt); | |
| 3185 } | |
| 3186 | |
| 3187 *ccptr = ccnt; | |
| 3188 return e - to; | |
| 3189 } | |
| 3190 #undef ADVANCE_INPUT | |
| 3191 #undef ADVANCE_INPUT_IGNORE_NONBASE64 | |
| 3192 #undef STORE_BYTE | |
| 3193 | |
| 3194 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* | |
| 444 | 3195 Base64-encode the region between START and END. |
| 428 | 3196 Return the length of the encoded text. |
| 3197 Optional third argument NO-LINE-BREAK means do not break long lines | |
| 3198 into shorter lines. | |
| 3199 */ | |
| 444 | 3200 (start, end, no_line_break)) |
| 428 | 3201 { |
| 867 | 3202 Ibyte *encoded; |
| 665 | 3203 Bytebpos encoded_length; |
| 428 | 3204 Charcount allength, length; |
| 3205 struct buffer *buf = current_buffer; | |
| 665 | 3206 Charbpos begv, zv, old_pt = BUF_PT (buf); |
| 428 | 3207 Lisp_Object input; |
| 851 | 3208 int speccount = specpdl_depth (); |
| 428 | 3209 |
| 444 | 3210 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
| 428 | 3211 barf_if_buffer_read_only (buf, begv, zv); |
| 3212 | |
| 3213 /* We need to allocate enough room for encoding the text. | |
| 3214 We need 33 1/3% more space, plus a newline every 76 | |
| 3215 characters, and then we round up. */ | |
| 3216 length = zv - begv; | |
| 3217 allength = length + length/3 + 1; | |
| 3218 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
| 3219 | |
| 3220 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
| 867 | 3221 /* We needn't multiply allength with MAX_ICHAR_LEN because all the |
| 428 | 3222 base64 characters will be single-byte. */ |
| 867 | 3223 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
| 428 | 3224 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
| 3225 NILP (no_line_break)); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
3226 assert (encoded_length <= allength); |
| 428 | 3227 Lstream_delete (XLSTREAM (input)); |
| 3228 | |
| 3229 /* Now we have encoded the region, so we insert the new contents | |
| 3230 and delete the old. (Insert first in order to preserve markers.) */ | |
| 3231 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); | |
| 851 | 3232 unbind_to (speccount); |
| 428 | 3233 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); |
| 3234 | |
| 3235 /* Simulate FSF Emacs implementation of this function: if point was | |
| 3236 in the region, place it at the beginning. */ | |
| 3237 if (old_pt >= begv && old_pt < zv) | |
| 3238 BUF_SET_PT (buf, begv); | |
| 3239 | |
| 3240 /* We return the length of the encoded text. */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3241 return make_fixnum (encoded_length); |
| 428 | 3242 } |
| 3243 | |
| 3244 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* | |
| 3245 Base64 encode STRING and return the result. | |
| 444 | 3246 Optional argument NO-LINE-BREAK means do not break long lines |
| 3247 into shorter lines. | |
| 428 | 3248 */ |
| 3249 (string, no_line_break)) | |
| 3250 { | |
| 3251 Charcount allength, length; | |
| 665 | 3252 Bytebpos encoded_length; |
| 867 | 3253 Ibyte *encoded; |
| 428 | 3254 Lisp_Object input, result; |
| 3255 int speccount = specpdl_depth(); | |
| 3256 | |
| 3257 CHECK_STRING (string); | |
| 3258 | |
| 826 | 3259 length = string_char_length (string); |
| 428 | 3260 allength = length + length/3 + 1; |
| 3261 allength += allength / MIME_LINE_LENGTH + 1 + 6; | |
| 3262 | |
| 3263 input = make_lisp_string_input_stream (string, 0, -1); | |
| 867 | 3264 encoded = (Ibyte *) MALLOC_OR_ALLOCA (allength); |
| 428 | 3265 encoded_length = base64_encode_1 (XLSTREAM (input), encoded, |
| 3266 NILP (no_line_break)); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
3267 assert (encoded_length <= allength); |
| 428 | 3268 Lstream_delete (XLSTREAM (input)); |
| 3269 result = make_string (encoded, encoded_length); | |
| 851 | 3270 unbind_to (speccount); |
| 428 | 3271 return result; |
| 3272 } | |
| 3273 | |
| 3274 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* | |
| 444 | 3275 Base64-decode the region between START and END. |
| 428 | 3276 Return the length of the decoded text. |
| 3277 If the region can't be decoded, return nil and don't modify the buffer. | |
| 3278 Characters out of the base64 alphabet are ignored. | |
| 3279 */ | |
| 444 | 3280 (start, end)) |
| 428 | 3281 { |
| 3282 struct buffer *buf = current_buffer; | |
| 665 | 3283 Charbpos begv, zv, old_pt = BUF_PT (buf); |
| 867 | 3284 Ibyte *decoded; |
| 665 | 3285 Bytebpos decoded_length; |
| 428 | 3286 Charcount length, cc_decoded_length; |
| 3287 Lisp_Object input; | |
| 3288 int speccount = specpdl_depth(); | |
| 3289 | |
| 444 | 3290 get_buffer_range_char (buf, start, end, &begv, &zv, 0); |
| 428 | 3291 barf_if_buffer_read_only (buf, begv, zv); |
| 3292 | |
| 3293 length = zv - begv; | |
| 3294 | |
| 3295 input = make_lisp_buffer_input_stream (buf, begv, zv, 0); | |
| 3296 /* We need to allocate enough room for decoding the text. */ | |
| 867 | 3297 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
| 428 | 3298 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
|
3299 assert (decoded_length <= length * MAX_ICHAR_LEN); |
| 428 | 3300 Lstream_delete (XLSTREAM (input)); |
| 3301 | |
| 3302 /* Now we have decoded the region, so we insert the new contents | |
| 3303 and delete the old. (Insert first in order to preserve markers.) */ | |
| 3304 BUF_SET_PT (buf, begv); | |
| 3305 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); | |
| 851 | 3306 unbind_to (speccount); |
| 428 | 3307 buffer_delete_range (buf, begv + cc_decoded_length, |
| 3308 zv + cc_decoded_length, 0); | |
| 3309 | |
| 3310 /* Simulate FSF Emacs implementation of this function: if point was | |
| 3311 in the region, place it at the beginning. */ | |
| 3312 if (old_pt >= begv && old_pt < zv) | |
| 3313 BUF_SET_PT (buf, begv); | |
| 3314 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5560
diff
changeset
|
3315 return make_fixnum (cc_decoded_length); |
| 428 | 3316 } |
| 3317 | |
| 3318 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* | |
| 3319 Base64-decode STRING and return the result. | |
| 3320 Characters out of the base64 alphabet are ignored. | |
| 3321 */ | |
| 3322 (string)) | |
| 3323 { | |
| 867 | 3324 Ibyte *decoded; |
| 665 | 3325 Bytebpos decoded_length; |
| 428 | 3326 Charcount length, cc_decoded_length; |
| 3327 Lisp_Object input, result; | |
| 3328 int speccount = specpdl_depth(); | |
| 3329 | |
| 3330 CHECK_STRING (string); | |
| 3331 | |
| 826 | 3332 length = string_char_length (string); |
| 428 | 3333 /* We need to allocate enough room for decoding the text. */ |
| 867 | 3334 decoded = (Ibyte *) MALLOC_OR_ALLOCA (length * MAX_ICHAR_LEN); |
| 428 | 3335 |
| 3336 input = make_lisp_string_input_stream (string, 0, -1); | |
| 3337 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, | |
| 3338 &cc_decoded_length); | |
|
5050
6f2158fa75ed
Fix quick-build, use asserts() in place of ABORT()
Ben Wing <ben@xemacs.org>
parents:
5002
diff
changeset
|
3339 assert (decoded_length <= length * MAX_ICHAR_LEN); |
| 428 | 3340 Lstream_delete (XLSTREAM (input)); |
| 3341 | |
| 3342 result = make_string (decoded, decoded_length); | |
| 851 | 3343 unbind_to (speccount); |
| 428 | 3344 return result; |
| 3345 } | |
| 3346 | |
| 3347 void | |
| 3348 syms_of_fns (void) | |
| 3349 { | |
|
5253
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
3350 DEFSYMBOL (Qmapl); |
|
b6a398dbb403
Fewer algorithmic complexity surprises, nicer errors, mapcarX(), maplist()
Aidan Kehoe <kehoea@parhasard.net>
parents:
5241
diff
changeset
|
3351 DEFSYMBOL (Qmapcon); |
|
5607
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
3352 DEFSYMBOL (Qmaplist); |
| 563 | 3353 |
| 3354 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); | |
| 428 | 3355 |
| 3356 DEFSUBR (Fidentity); | |
| 3357 DEFSUBR (Frandom); | |
| 3358 DEFSUBR (Fsafe_length); | |
|
5273
799742b751c8
Accept circular lists where that is useful in #'mapcar*, #'map* and friends.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5272
diff
changeset
|
3359 DEFSUBR (Flist_length); |
| 428 | 3360 DEFSUBR (Fstring_equal); |
| 801 | 3361 DEFSUBR (Fcompare_strings); |
| 428 | 3362 DEFSUBR (Fstring_lessp); |
| 3363 DEFSUBR (Fstring_modified_tick); | |
| 3364 DEFSUBR (Fappend); | |
| 3365 DEFSUBR (Fconcat); | |
| 3366 DEFSUBR (Fvconcat); | |
| 3367 DEFSUBR (Fbvconcat); | |
| 3368 DEFSUBR (Fcopy_list); | |
| 3369 DEFSUBR (Fcopy_sequence); | |
| 3370 DEFSUBR (Fcopy_alist); | |
| 3371 DEFSUBR (Fnthcdr); | |
| 3372 DEFSUBR (Fnth); | |
| 3373 DEFSUBR (Flast); | |
| 3374 DEFSUBR (Fbutlast); | |
| 3375 DEFSUBR (Fnbutlast); | |
| 3376 DEFSUBR (Fplists_eq); | |
| 3377 DEFSUBR (Fplists_equal); | |
| 3378 DEFSUBR (Flax_plists_eq); | |
| 3379 DEFSUBR (Flax_plists_equal); | |
| 3380 DEFSUBR (Fplist_get); | |
| 3381 DEFSUBR (Fplist_put); | |
| 3382 DEFSUBR (Fplist_remprop); | |
| 3383 DEFSUBR (Fplist_member); | |
| 3384 DEFSUBR (Fcheck_valid_plist); | |
| 3385 DEFSUBR (Fvalid_plist_p); | |
| 3386 DEFSUBR (Fcanonicalize_plist); | |
| 3387 DEFSUBR (Flax_plist_get); | |
| 3388 DEFSUBR (Flax_plist_put); | |
| 3389 DEFSUBR (Flax_plist_remprop); | |
| 3390 DEFSUBR (Flax_plist_member); | |
| 3391 DEFSUBR (Fcanonicalize_lax_plist); | |
| 3392 DEFSUBR (Fdestructive_alist_to_plist); | |
| 3393 DEFSUBR (Fget); | |
| 3394 DEFSUBR (Fput); | |
| 3395 DEFSUBR (Fremprop); | |
| 3396 DEFSUBR (Fobject_plist); | |
|
5255
b5611afbcc76
Support process plists, for greater GNU compatibility.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5253
diff
changeset
|
3397 DEFSUBR (Fobject_setplist); |
| 428 | 3398 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
|
3399 DEFSUBR (Fequalp); |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3400 |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3401 #ifdef SUPPORT_CONFOUNDING_FUNCTIONS |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3402 DEFSUBR (Fold_member); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3403 DEFSUBR (Fold_memq); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3404 DEFSUBR (Fold_assoc); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3405 DEFSUBR (Fold_assq); |
|
5607
1a507c4c6c42
Refactor out sequence-oriented builtins from fns.c to the new sequence.c.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5583
diff
changeset
|
3406 DEFSUBR (Fold_rassq); |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3407 DEFSUBR (Fold_rassoc); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3408 DEFSUBR (Fold_delete); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3409 DEFSUBR (Fold_delq); |
| 428 | 3410 DEFSUBR (Fold_equal); |
|
5374
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3411 DEFSUBR (Fold_eq); |
|
d967d96ca043
Conditionalise the old-* functions and byte codes at compile time.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5360
diff
changeset
|
3412 #endif |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
3413 |
| 428 | 3414 DEFSUBR (Fnconc); |
|
4995
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3415 DEFSUBR (Fmaplist); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3416 DEFSUBR (Fmapl); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3417 DEFSUBR (Fmapcon); |
|
8431b52e43b1
Move the various map* functions to C; add #'map-into.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4797
diff
changeset
|
3418 |
| 442 | 3419 DEFSUBR (Freplace_list); |
|
5327
d1b17a33450b
Move the heavy lifting from cl-seq.el to C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5309
diff
changeset
|
3420 |
| 428 | 3421 DEFSUBR (Fload_average); |
| 3422 DEFSUBR (Ffeaturep); | |
| 3423 DEFSUBR (Frequire); | |
| 3424 DEFSUBR (Fprovide); | |
| 3425 DEFSUBR (Fbase64_encode_region); | |
| 3426 DEFSUBR (Fbase64_encode_string); | |
| 3427 DEFSUBR (Fbase64_decode_region); | |
| 3428 DEFSUBR (Fbase64_decode_string); | |
| 771 | 3429 |
|
5224
35c2b7e9c03f
Add #'substring-no-properties, omitting any extent data.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5191
diff
changeset
|
3430 DEFSUBR (Fsubstring_no_properties); |
| 771 | 3431 DEFSUBR (Fsplit_string_by_char); |
| 3432 } | |
| 3433 | |
| 3434 void | |
| 3435 vars_of_fns (void) | |
| 3436 { | |
| 3437 DEFVAR_LISP ("path-separator", &Vpath_separator /* | |
| 3438 The directory separator in search paths, as a string. | |
| 3439 */ ); | |
| 3440 { | |
|
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
|
3441 Ascbyte c = SEPCHAR; |
| 867 | 3442 Vpath_separator = make_string ((Ibyte *) &c, 1); |
| 771 | 3443 } |
| 428 | 3444 } |
| 3445 | |
| 3446 void | |
| 3447 init_provide_once (void) | |
| 3448 { | |
| 3449 DEFVAR_LISP ("features", &Vfeatures /* | |
| 3450 A list of symbols which are the features of the executing emacs. | |
| 3451 Used by `featurep' and `require', and altered by `provide'. | |
| 3452 */ ); | |
| 3453 Vfeatures = Qnil; | |
| 3454 | |
| 3455 Fprovide (intern ("base64")); | |
| 3456 } |