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