annotate src/fns.c @ 853:2b6fa2618f76

[xemacs-hg @ 2002-05-28 08:44:22 by ben] merge my stderr-proc ws make-docfile.c: Fix places where we forget to check for EOF. code-init.el: Don't use CRLF conversion by default on process output. CMD.EXE and friends work both ways but Cygwin programs don't like the CRs. code-process.el, multicast.el, process.el: Removed. Improvements to call-process-internal: -- allows a buffer to be specified for input and stderr output -- use it on all systems -- implement C-g as documented -- clean up and comment call-process-region uses new call-process facilities; no temp file. remove duplicate funs in process.el. comment exactly how coding systems work and fix various problems. open-multicast-group now does similar coding-system frobbing to open-network-stream. dumped-lisp.el, faces.el, msw-faces.el: Fix some hidden errors due to code not being defined at the right time. xemacs.mak: Add -DSTRICT. ================================================================ ALLOW SEPARATION OF STDOUT AND STDERR IN PROCESSES ================================================================ Standard output and standard error can be processed separately in a process. Each can have its own buffer, its own mark in that buffer, and its filter function. You can specify a separate buffer for stderr in `start-process' to get things started, or use the new primitives: set-process-stderr-buffer process-stderr-buffer process-stderr-mark set-process-stderr-filter process-stderr-filter Also, process-send-region takes a 4th optional arg, a buffer. Currently always uses a pipe() under Unix to read the error output. (#### Would a PTY be better?) sysdep.h, sysproc.h, unexfreebsd.c, unexsunos4.c, nt.c, emacs.c, callproc.c, symsinit.h, sysdep.c, Makefile.in.in, process-unix.c: Delete callproc.c. Move child_setup() to process-unix.c. wait_for_termination() now only needed on a few really old systems. console-msw.h, event-Xt.c, event-msw.c, event-stream.c, event-tty.c, event-unixoid.c, events.h, process-nt.c, process-unix.c, process.c, process.h, procimpl.h: Rewrite the process methods to handle a separate channel for error input. Create Lstreams for reading in the error channel. Many process methods need change. In general the changes are fairly clear as they involve duplicating what's used for reading the normal stdout and changing for stderr -- although tedious, as such changes are required throughout the entire process code. Rewrote the code that reads process output to do two loops, one for stdout and one for stderr. gpmevent.c, tooltalk.c: set_process_filter takes an argument for stderr. ================================================================ NEW ERROR-TRAPPING MECHANISM ================================================================ Totally rewrite error trapping code to be unified and support more features. Basic function is call_trapping_problems(), which lets you specify, by means of flags, what sorts of problems you want trapped. these can include -- quit -- errors -- throws past the function -- creation of "display objects" (e.g. buffers) -- deletion of already-existing "display objects" (e.g. buffers) -- modification of already-existing buffers -- entering the debugger -- gc -- errors->warnings (ala suspended errors) etc. All other error funs rewritten in terms of this one. Various older mechanisms removed or rewritten. window.c, insdel.c, console.c, buffer.c, device.c, frame.c: When creating a display object, added call to note_object_created(), for use with trapping_problems mechanism. When deleting, call check_allowed_operation() and note_object deleted(). The trapping-problems code records the objects created since the call-trapping-problems began. Those objects can be deleted, but none others (i.e. previously existing ones). bytecode.c, cmdloop.c: internal_catch takes another arg. eval.c: Add long comments describing the "five lists" used to maintain state (backtrace, gcpro, specbind, etc.) in the Lisp engine. backtrace.h, eval.c: Implement trapping-problems mechanism, eliminate old mechanisms or redo in terms of new one. frame.c, gutter.c: Flush out the concept of "critical display section", defined by the in_display() var. Use an internal_bind() to get it reset, rather than just doing it at end, because there may be a non-local exit. event-msw.c, event-stream.c, console-msw.h, device.c, dialog-msw.c, frame.c, frame.h, intl.c, toolbar.c, menubar-msw.c, redisplay.c, alloc.c, menubar-x.c: Make use of new trapping-errors stuff and rewrite code based on old mechanisms. glyphs-widget.c, redisplay.h: Protect calling Lisp in redisplay. insdel.c: Protect hooks against deleting existing buffers. frame-msw.c: Use EQ, not EQUAL in hash tables whose keys are just numbers. Otherwise we run into stickiness in redisplay because internal_equal() can QUIT. ================================================================ SIGNAL, C-G CHANGES ================================================================ Here we change the way that C-g interacts with event reading. The idea is that a C-g occurring while we're reading a user event should be read as C-g, but elsewhere should be a QUIT. The former code did all sorts of bizarreness -- requiring that no QUIT occurs anywhere in event-reading code (impossible to enforce given the stuff called or Lisp code invoked), and having some weird system involving enqueue/dequeue of a C-g and interaction with Vquit_flag -- and it didn't work. Now, we simply enclose all code where we want C-g read as an event with {begin/end}_dont_check_for_quit(). This completely turns off the mechanism that checks (and may remove or alter) C-g in the read-ahead queues, so we just get the C-g normal. Signal.c documents this very carefully. cmdloop.c: Correct use of dont_check_for_quit to new scheme, remove old out-of-date comments. event-stream.c: Fix C-g handling to actually work. device-x.c: Disable quit checking when err out. signal.c: Cleanup. Add large descriptive comment. process-unix.c, process-nt.c, sysdep.c: Use QUIT instead of REALLY_QUIT. It's not necessary to use REALLY_QUIT and just confuses the issue. lisp.h: Comment quit handlers. ================================================================ CONS CHANGES ================================================================ free_cons() now takes a Lisp_Object not the result of XCONS(). car and cdr have been renamed so that they don't get used directly; go through XCAR(), XCDR() instead. alloc.c, dired.c, editfns.c, emodules.c, fns.c, glyphs-msw.c, glyphs-x.c, glyphs.c, keymap.c, minibuf.c, search.c, eval.c, lread.c, lisp.h: Correct free_cons calling convention: now takes Lisp_Object, not Lisp_Cons chartab.c: Eliminate direct use of ->car, ->cdr, should be black box. callint.c: Rewrote using EXTERNAL_LIST_LOOP to avoid use of Lisp_Cons. ================================================================ USE INTERNAL-BIND-* ================================================================ eval.c: Cleanups of these funs. alloc.c, fileio.c, undo.c, specifier.c, text.c, profile.c, lread.c, redisplay.c, menubar-x.c, macros.c: Rewrote to use internal_bind_int() and internal_bind_lisp_object() in place of whatever varied and cumbersome mechanisms were formerly there. ================================================================ SPECBIND SANITY ================================================================ backtrace.h: - Improved comments backtrace.h, bytecode.c, eval.c: Add new mechanism check_specbind_stack_sanity() for sanity checking code each time the catchlist or specbind stack change. Removed older prototype of same mechanism. ================================================================ MISC ================================================================ lisp.h, insdel.c, window.c, device.c, console.c, buffer.c: Fleshed out authorship. device-msw.c: Correct bad Unicode-ization. print.c: Be more careful when not initialized or in fatal error handling. search.c: Eliminate running_asynch_code, an FSF holdover. alloc.c: Added comments about gc-cons-threshold. dialog-x.c: Use begin_gc_forbidden() around code to build up a widget value tree, like in menubar-x.c. gui.c: Use Qunbound not Qnil as the default for gethash. lisp-disunion.h, lisp-union.h: Added warnings on use of VOID_TO_LISP(). lisp.h: Use ERROR_CHECK_STRUCTURES to turn on ERROR_CHECK_TRAPPING_PROBLEMS and ERROR_CHECK_TYPECHECK lisp.h: Add assert_with_message. lisp.h: Add macros for gcproing entire arrays. (You could do this before but it required manual twiddling the gcpro structure.) lisp.h: Add prototypes for new functions defined elsewhere.
author ben
date Tue, 28 May 2002 08:45:36 +0000
parents e7ee5f8bde58
children 804517e16990
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Random utility Lisp functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3 Copyright (C) 1995, 1996, 2000, 2001, 2002 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22 /* Synched up with: Mule 2.0, FSF 19.30. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 /* This file has been Mule-ized. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 /* Note: FSF 19.30 has bool vectors. We have bit vectors. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 /* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 /* Note on some machines this defines `vector' as a typedef,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 so make sure we don't use that name in this file. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
34 #undef vector
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35 #define vector *****
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
38
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
39 #include "sysfile.h"
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
40 #include "sysproc.h" /* for qxe_getpid() */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
41
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
42 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
43 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
44 #include "device.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
45 #include "events.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 #include "extents.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 #include "frame.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
48 #include "systime.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
49 #include "insdel.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
50 #include "lstream.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
51 #include "opaque.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
52
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
53 /* NOTE: This symbol is also used in lread.c */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 #define FEATUREP_SYNTAX
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
56 Lisp_Object Qstring_lessp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 Lisp_Object Qidentity;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
59 Lisp_Object Qbase64_conversion_error;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
60
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
61 Lisp_Object Vpath_separator;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
62
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
64 Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
65
780
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
66 int require_prints_loading_message;
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
67
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69 mark_bit_vector (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
72 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
77 Elemcount i;
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
78 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
79 Elemcount len = bit_vector_length (v);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
80 Elemcount last = len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
81
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
82 if (INTP (Vprint_length))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
83 last = min (len, XINT (Vprint_length));
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
84 write_c_string (printcharfun, "#*");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 for (i = 0; i < last; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
86 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 if (bit_vector_bit (v, i))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
88 write_c_string (printcharfun, "1");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 else
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
90 write_c_string (printcharfun, "0");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93 if (last != len)
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
94 write_c_string (printcharfun, "...");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
100 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
101 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 !memcmp (v1->bits, v2->bits,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 sizeof (long)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
109 static Hashcode
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 bit_vector_hash (Lisp_Object obj, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
112 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 return HASH2 (bit_vector_length (v),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 memory_hash (v->bits,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
115 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 sizeof (long)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
119 static Bytecount
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
120 size_bit_vector (const void *lheader)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
121 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
122 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 454
diff changeset
123 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits,
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
124 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
125 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
126
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 static const struct lrecord_description bit_vector_description[] = {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
128 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
133 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
134 mark_bit_vector, print_bit_vector, 0,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
135 bit_vector_equal, bit_vector_hash,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
136 bit_vector_description, size_bit_vector,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
137 Lisp_Bit_Vector);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 DEFUN ("identity", Fidentity, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
140 Return the argument unchanged.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
141 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 return arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
147 DEFUN ("random", Frandom, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 Return a pseudo-random number.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149 All integers representable in Lisp are equally likely.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 On most systems, this is 28 bits' worth.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 With positive integer argument N, return random number in interval [0,N).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 With argument t, set the random number seed from the current time and pid.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
153 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 (limit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 EMACS_INT val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 unsigned long denominator;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 if (EQ (limit, Qt))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
160 seed_random (qxe_getpid () + time (NULL));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 if (NATNUMP (limit) && !ZEROP (limit))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 /* Try to take our random number from the higher bits of VAL,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 not the lower, since (says Gentzel) the low bits of `random'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165 are less random than the higher ones. We do this by using the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 quotient rather than the remainder. At the high end of the RNG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167 it's possible to get a quotient larger than limit; discarding
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 these values eliminates the bias that would otherwise appear
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 when using a large limit. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 denominator = ((unsigned long)1 << VALBITS) / XINT (limit);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 val = get_random () / denominator;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 while (val >= XINT (limit));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 val = get_random ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 return make_int (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 /* Random data-structure functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 /* #### Delete this shit */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
186
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 /* Charcount is a misnomer here as we might be dealing with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
188 length of a vector or list, but emphasizes that we're not dealing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 with Bytecounts in strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190 static Charcount
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 length_with_bytecode_hack (Lisp_Object seq)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193 if (!COMPILED_FUNCTIONP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 return XINT (Flength (seq));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
197 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200 f->flags.domainp ? COMPILED_DOMAIN :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 COMPILED_DOC_STRING)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
203 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
206 #endif /* LOSING_BYTECODE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208 void
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
209 check_losing_bytecode (const char *function, Lisp_Object seq)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 if (COMPILED_FUNCTIONP (seq))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
212 signal_ferror_with_frob
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
213 (Qinvalid_argument, seq,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 "As of 20.3, `%s' no longer works with compiled-function objects",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 DEFUN ("length", Flength, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 Return the length of vector, bit vector, list or string SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224 if (STRINGP (sequence))
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
225 return make_int (string_char_length (sequence));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 else if (CONSP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
228 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 GET_EXTERNAL_LIST_LENGTH (sequence, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 return make_int (len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232 else if (VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 return make_int (XVECTOR_LENGTH (sequence));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 else if (NILP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 return Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 else if (BIT_VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 return make_int (bit_vector_length (XBIT_VECTOR (sequence)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240 check_losing_bytecode ("length", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 DEFUN ("safe-length", Fsafe_length, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 Return the length of a list, but avoid error or infinite loop.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248 This function never gets an error. If LIST is not really a list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 it returns 0. If LIST is circular, it returns a finite value
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
250 which is at least the number of distinct elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 Lisp_Object hare, tortoise;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
255 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 for (hare = tortoise = list, len = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 hare = XCDR (hare), len++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 if (len & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 return make_int (len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 /*** string functions. ***/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 Return t if two strings have identical contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272 Case is significant. Text properties are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 \(Under XEmacs, `equal' also ignores text properties and extents in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 `equal' is the same as in XEmacs, in that respect.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 Symbols are also allowed; their print names are used instead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
278 (string1, string2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280 Bytecount len;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
281 Lisp_Object p1, p2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
283 if (SYMBOLP (string1))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
284 p1 = XSYMBOL (string1)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
287 CHECK_STRING (string1);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
288 p1 = string1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
291 if (SYMBOLP (string2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
292 p2 = XSYMBOL (string2)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
295 CHECK_STRING (string2);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
296 p2 = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
299 return (((len = XSTRING_LENGTH (p1)) == XSTRING_LENGTH (p2)) &&
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
300 !memcmp (XSTRING_DATA (p1), XSTRING_DATA (p2), len)) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
303 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /*
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
304 Compare the contents of two strings, maybe ignoring case.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
305 In string STR1, skip the first START1 characters and stop at END1.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
306 In string STR2, skip the first START2 characters and stop at END2.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
307 END1 and END2 default to the full lengths of the respective strings.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
308
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
309 Case is significant in this comparison if IGNORE-CASE is nil.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
310
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
311 The value is t if the strings (or specified portions) match.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
312 If string STR1 is less, the value is a negative number N;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
313 - 1 - N is the number of characters that match at the beginning.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
314 If string STR1 is greater, the value is a positive number N;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
315 N - 1 is the number of characters that match at the beginning.
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
316 */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
317 (str1, start1, end1, str2, start2, end2, ignore_case))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
318 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
319 Charcount ccstart1, ccend1, ccstart2, ccend2;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
320 Bytecount bstart1, blen1, bstart2, blen2;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
321 Charcount matching;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
322 int res;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
323
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
324 CHECK_STRING (str1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
325 CHECK_STRING (str2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
326 get_string_range_char (str1, start1, end1, &ccstart1, &ccend1,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
327 GB_HISTORICAL_STRING_BEHAVIOR);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
328 get_string_range_char (str2, start2, end2, &ccstart2, &ccend2,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
329 GB_HISTORICAL_STRING_BEHAVIOR);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
330
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
331 bstart1 = string_index_char_to_byte (str1, ccstart1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
332 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
333 bstart2 = string_index_char_to_byte (str2, ccstart2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
334 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
335
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
336 res = ((NILP (ignore_case) ? qxetextcmp_matching : qxetextcasecmp_matching)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
337 (XSTRING_DATA (str1) + bstart1, blen1,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
338 XSTRING_DATA (str2) + bstart2, blen2,
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
339 &matching));
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
340
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
341 if (!res)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
342 return Qt;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
343 else if (res > 0)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
344 return make_int (1 + matching);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
345 else
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
346 return make_int (-1 - matching);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
347 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
348
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 DEFUN ("string-lessp", Fstring_lessp, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 Return t if first arg string is less than second in lexicographic order.
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
351 Comparison is simply done on a character-by-character basis using the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
352 numeric value of a character. (Note that this may not produce
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
353 particularly meaningful results under Mule if characters from
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
354 different charsets are being compared.)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 Symbols are also allowed; their print names are used instead.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
358 Currently we don't do proper language-specific collation or handle
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
359 multiple character sets. This may be changed when Unicode support
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
360 is implemented.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
361 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
362 (string1, string2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
364 Lisp_Object p1, p2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 Charcount end, len2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
367
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
368 if (SYMBOLP (string1))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
369 p1 = XSYMBOL (string1)->name;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
370 else
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
371 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
372 CHECK_STRING (string1);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
373 p1 = string1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
376 if (SYMBOLP (string2))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
377 p2 = XSYMBOL (string2)->name;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
380 CHECK_STRING (string2);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
381 p2 = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
384 end = string_char_length (p1);
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
385 len2 = string_char_length (p2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 if (end > len2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 end = len2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
390 Intbyte *ptr1 = XSTRING_DATA (p1);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
391 Intbyte *ptr2 = XSTRING_DATA (p2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 /* #### It is not really necessary to do this: We could compare
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 byte-by-byte and still get a reasonable comparison, since this
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 would compare characters with a charset in the same way. With
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 a little rearrangement of the leading bytes, we could make most
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397 inter-charset comparisons work out the same, too; even if some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 don't, this is not a big deal because inter-charset comparisons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
399 aren't really well-defined anyway. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 for (i = 0; i < end; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 INC_CHARPTR (ptr1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 INC_CHARPTR (ptr2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 won't work right in I18N2 case */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 return end < len2 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
413 DEFUN ("string-modified-tick", Fstring_modified_tick, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 Return STRING's tick counter, incremented for each change to the string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
415 Each string has a tick counter which is incremented each time the contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
416 of the string are changed (e.g. with `aset'). It wraps around occasionally.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418 (string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
420 CHECK_STRING (string);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
421 if (CONSP (XSTRING_PLIST (string)) && INTP (XCAR (XSTRING_PLIST (string))))
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
422 return XCAR (XSTRING_PLIST (string));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 return Qzero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 bump_string_modiff (Lisp_Object str)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
430 Lisp_Object *ptr = &XSTRING_PLIST (str);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433 /* #### remove the `string-translatable' property from the string,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 if there is one. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 /* skip over extent info if it's there */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 ptr = &XCDR (*ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
440 XCAR (*ptr) = make_int (1+XINT (XCAR (*ptr)));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442 *ptr = Fcons (make_int (1), *ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 enum concat_target_type { c_cons, c_string, c_vector, c_bit_vector };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 static Lisp_Object concat (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 enum concat_target_type target_type,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 int last_special);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
452 concat2 (Lisp_Object string1, Lisp_Object string2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 Lisp_Object args[2];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
455 args[0] = string1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
456 args[1] = string2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 return concat (2, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
461 concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
463 Lisp_Object args[3];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
464 args[0] = string1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
465 args[1] = string2;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
466 args[2] = string3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
467 return concat (3, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
468 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
469
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
470 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
471 vconcat2 (Lisp_Object vec1, Lisp_Object vec2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
472 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 Lisp_Object args[2];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
474 args[0] = vec1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
475 args[1] = vec2;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 return concat (2, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
480 vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 Lisp_Object args[3];
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
483 args[0] = vec1;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
484 args[1] = vec2;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
485 args[2] = vec3;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 return concat (3, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489 DEFUN ("append", Fappend, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 Concatenate all the arguments and make the result a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 The result is a list whose elements are the elements of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 Each argument may be a list, vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 The last argument is not copied, just used as the tail of the new list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 Also see: `nconc'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 return concat (nargs, args, c_cons, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 DEFUN ("concat", Fconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 Concatenate all the arguments and make the result a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 The result is a string whose elements are the elements of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 Each argument may be a string or a list or vector of characters.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 As of XEmacs 21.0, this function does NOT accept individual integers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 as arguments. Old code that relies on, for example, (concat "foo" 50)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 returning "foo50" will fail. To fix such code, either apply
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 `int-to-string' to the integer argument, or use `format'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
511 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
512 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
513 return concat (nargs, args, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
514 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
515
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
516 DEFUN ("vconcat", Fvconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
517 Concatenate all the arguments and make the result a vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
518 The result is a vector whose elements are the elements of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
519 Each argument may be a list, vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
520 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
521 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
522 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
523 return concat (nargs, args, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
524 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
525
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
526 DEFUN ("bvconcat", Fbvconcat, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
527 Concatenate all the arguments and make the result a bit vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
528 The result is a bit vector whose elements are the elements of all the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
529 arguments. Each argument may be a list, vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
530 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
531 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
532 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
533 return concat (nargs, args, c_bit_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 /* Copy a (possibly dotted) list. LIST must be a cons.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 Can't use concat (1, &alist, c_cons, 0) - doesn't handle dotted lists. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 copy_list (Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 Lisp_Object last = list_copy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543 Lisp_Object hare, tortoise;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
544 Elemcount len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 for (tortoise = hare = XCDR (list), len = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 CONSP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 hare = XCDR (hare), len++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
549 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
550 XCDR (last) = Fcons (XCAR (hare), XCDR (hare));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
551 last = XCDR (last);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
553 if (len < CIRCULAR_LIST_SUSPICION_LENGTH)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555 if (len & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 if (EQ (tortoise, hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 signal_circular_list_error (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 return list_copy;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 DEFUN ("copy-list", Fcopy_list, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 Return a copy of list LIST, which may be a dotted list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 The elements of LIST are not copied; they are shared
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 with the original.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 again:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 if (NILP (list)) return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 if (CONSP (list)) return copy_list (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 list = wrong_type_argument (Qlistp, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 goto again;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 DEFUN ("copy-sequence", Fcopy_sequence, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 Return a copy of list, vector, bit vector or string SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 The elements of a list or vector are not copied; they are shared
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582 with the original. SEQUENCE may be a dotted list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 again:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 if (NILP (sequence)) return sequence;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 if (CONSP (sequence)) return copy_list (sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 if (STRINGP (sequence)) return concat (1, &sequence, c_string, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 if (VECTORP (sequence)) return concat (1, &sequence, c_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 if (BIT_VECTORP (sequence)) return concat (1, &sequence, c_bit_vector, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 check_losing_bytecode ("copy-sequence", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 goto again;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598 struct merge_string_extents_struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 Lisp_Object string;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601 Bytecount entry_offset;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 Bytecount entry_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 concat (int nargs, Lisp_Object *args,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 enum concat_target_type target_type,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 int last_special)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 Lisp_Object tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 int toindex;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 int argnum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 Lisp_Object last_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 Lisp_Object prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 struct merge_string_extents_struct *args_mse = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
617 Intbyte *string_result = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
618 Intbyte *string_result_ptr = 0;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 struct gcpro gcpro1;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
620 int sdep = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 /* The modus operandi in Emacs is "caller gc-protects args".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 However, concat is called many times in Emacs on freshly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 created stuff. So we help those callers out by protecting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 the args ourselves to save them a lot of temporary-variable
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626 grief. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 gcpro1.nvars = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 #ifdef I18N3
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 /* #### if the result is a string and any of the strings have a string
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 for the `string-translatable' property, then concat should also
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 concat the args but use the `string-translatable' strings, and store
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 the result in the returned string's `string-translatable' property. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 if (target_type == c_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 args_mse = alloca_array (struct merge_string_extents_struct, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 /* In append, the last arg isn't treated like the others */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 if (last_special && nargs > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643 nargs--;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 last_tail = args[nargs];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 last_tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 /* Check and coerce the arguments. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 Lisp_Object seq = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
653 if (LISTP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
655 else if (VECTORP (seq) || STRINGP (seq) || BIT_VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
657 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
658 else if (COMPILED_FUNCTIONP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659 /* Urk! We allow this, for "compatibility"... */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
660 ;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 #if 0 /* removed for XEmacs 21 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663 else if (INTP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 /* This is too revolting to think about but maintains
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
665 compatibility with FSF (and lots and lots of old code). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 args[argnum] = Fnumber_to_string (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
667 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
669 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
670 check_losing_bytecode ("concat", seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671 args[argnum] = wrong_type_argument (Qsequencep, seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
672 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 if (args_mse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677 args_mse[argnum].string = seq;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 args_mse[argnum].string = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
683 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
684 /* Charcount is a misnomer here as we might be dealing with the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
685 length of a vector or list, but emphasizes that we're not dealing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 with Bytecounts in strings */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
687 Charcount total_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692 Charcount thislen = length_with_bytecode_hack (args[argnum]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 Charcount thislen = XINT (Flength (args[argnum]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 total_length += thislen;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 switch (target_type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 case c_cons:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 if (total_length == 0)
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
703 {
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
704 unbind_to (sdep);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
705 /* In append, if all but last arg are nil, return last arg */
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
706 RETURN_UNGCPRO (last_tail);
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
707 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 val = Fmake_list (make_int (total_length), Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710 case c_vector:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 val = make_vector (total_length, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 case c_bit_vector:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 val = make_bit_vector (total_length, Qzero);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 case c_string:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 /* We don't make the string yet because we don't know the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 actual number of bytes. This loop was formerly written
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 to call Fmake_string() here and then call set_string_char()
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 for each char. This seems logical enough but is waaaaaaaay
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 slow -- set_string_char() has to scan the whole string up
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 to the place where the substitution is called for in order
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 to find the place to change, and may have to do some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724 realloc()ing in order to make the char fit properly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 O(N^2) yuckage. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726 val = Qnil;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
727 string_result =
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
728 (Intbyte *) MALLOC_OR_ALLOCA (total_length * MAX_EMCHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 string_result_ptr = string_result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 default:
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
732 val = Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 if (CONSP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 tail = val, toindex = -1; /* -1 in toindex is flag we are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 making a list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 toindex = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744 prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 Charcount thisleni = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 Charcount thisindex = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 Lisp_Object seq = args[argnum];
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
751 Intbyte *string_source_ptr = 0;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
752 Intbyte *string_prev_result_ptr = string_result_ptr;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
754 if (!CONSP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
755 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 thisleni = length_with_bytecode_hack (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 thisleni = XINT (Flength (seq));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
760 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
761 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 string_source_ptr = XSTRING_DATA (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 Lisp_Object elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 /* We've come to the end of this arg, so exit. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 if (NILP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 /* Fetch next element of `seq' arg into `elt' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 if (CONSP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776 elt = XCAR (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 seq = XCDR (seq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
779 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781 if (thisindex >= thisleni)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 if (STRINGP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 elt = make_char (charptr_emchar (string_source_ptr));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 INC_CHARPTR (string_source_ptr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789 else if (VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 elt = XVECTOR_DATA (seq)[thisindex];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791 else if (BIT_VECTORP (seq))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 elt = make_int (bit_vector_bit (XBIT_VECTOR (seq),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 thisindex));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 elt = Felt (seq, make_int (thisindex));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 thisindex++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799 /* Store into result */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 if (toindex < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
802 /* toindex negative means we are making a list */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 XCAR (tail) = elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 else if (VECTORP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 XVECTOR_DATA (val)[toindex++] = elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 else if (BIT_VECTORP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
810 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
811 CHECK_BIT (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 set_bit_vector_bit (XBIT_VECTOR (val), toindex++, XINT (elt));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 CHECK_CHAR_COERCE_INT (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 string_result_ptr += set_charptr_emchar (string_result_ptr,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
818 XCHAR (elt));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
819 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 if (args_mse)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 args_mse[argnum].entry_offset =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 string_prev_result_ptr - string_result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 args_mse[argnum].entry_length =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 string_result_ptr - string_prev_result_ptr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 /* Now we finally make the string. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 if (target_type == c_string)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
832 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 val = make_string (string_result, string_result_ptr - string_result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834 for (argnum = 0; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 if (STRINGP (args_mse[argnum].string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 copy_string_extents (val, args_mse[argnum].string,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 args_mse[argnum].entry_offset, 0,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
839 args_mse[argnum].entry_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 if (!NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 XCDR (prev) = last_tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
846 unbind_to (sdep);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 DEFUN ("copy-alist", Fcopy_alist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 Return a copy of ALIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 This is an alist which represents the same mapping from objects to objects,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 but does not share the alist structure with ALIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 The objects mapped (cars and cdrs of elements of the alist)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 are shared, however.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 Elements of ALIST that are not conses are also shared.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 if (NILP (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 return alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 CHECK_CONS (alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 alist = concat (1, &alist, c_cons, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 for (tail = alist; CONSP (tail); tail = XCDR (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 Lisp_Object car = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 if (CONSP (car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 XCAR (tail) = Fcons (XCAR (car), XCDR (car));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 return alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 DEFUN ("copy-tree", Fcopy_tree, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 Return a copy of a list and substructures.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 The argument is copied, and any lists contained within it are copied
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
880 recursively. Circularities and shared substructures are not preserved.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881 Second arg VECP causes vectors to be copied, too. Strings and bit vectors
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 are not copied.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 (arg, vecp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 {
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
886 return safe_copy_tree (arg, vecp, 0);
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
887 }
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
888
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
889 Lisp_Object
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
890 safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth)
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
891 {
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
892 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
893 stack_overflow ("Stack overflow in copy-tree", arg);
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
894
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895 if (CONSP (arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
896 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
897 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
898 rest = arg = Fcopy_sequence (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
899 while (CONSP (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
900 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
901 Lisp_Object elt = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
902 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
903 if (CONSP (elt) || VECTORP (elt))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
904 XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
905 if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
906 XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
907 rest = XCDR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
908 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
909 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
910 else if (VECTORP (arg) && ! NILP (vecp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
911 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
912 int i = XVECTOR_LENGTH (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
913 int j;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
914 arg = Fcopy_sequence (arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
915 for (j = 0; j < i; j++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
916 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
917 Lisp_Object elt = XVECTOR_DATA (arg) [j];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
918 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
919 if (CONSP (elt) || VECTORP (elt))
454
d7a9135ec789 Import from CVS: tag r21-2-42
cvs
parents: 444
diff changeset
920 XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
921 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
922 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
923 return arg;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
924 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
925
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
926 DEFUN ("substring", Fsubstring, 2, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
927 Return the substring of STRING starting at START and ending before END.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
928 END may be nil or omitted; then the substring runs to the end of STRING.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
929 If START or END is negative, it counts from the end.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
930 Relevant parts of the string-extent-data are copied to the new string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
931 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
932 (string, start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
933 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
934 Charcount ccstart, ccend;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
935 Bytecount bstart, blen;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
936 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
937
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
938 CHECK_STRING (string);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
939 CHECK_INT (start);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
940 get_string_range_char (string, start, end, &ccstart, &ccend,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
941 GB_HISTORICAL_STRING_BEHAVIOR);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
942 bstart = string_index_char_to_byte (string, ccstart);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
943 blen = string_offset_char_to_byte_len (string, bstart, ccend - ccstart);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
944 val = make_string (XSTRING_DATA (string) + bstart, blen);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
945 /* Copy any applicable extent information into the new string. */
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
946 copy_string_extents (val, string, 0, bstart, blen);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
947 return val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
948 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
949
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
950 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
951 Return the subsequence of SEQUENCE starting at START and ending before END.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
952 END may be omitted; then the subsequence runs to the end of SEQUENCE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
953 If START or END is negative, it counts from the end.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
954 The returned subsequence is always of the same type as SEQUENCE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
955 If SEQUENCE is a string, relevant parts of the string-extent-data
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
956 are copied to the new string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
958 (sequence, start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
960 EMACS_INT len, s, e;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
961
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
962 if (STRINGP (sequence))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
963 return Fsubstring (sequence, start, end);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
964
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
965 len = XINT (Flength (sequence));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
966
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
967 CHECK_INT (start);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
968 s = XINT (start);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
969 if (s < 0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
970 s = len + s;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
971
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
972 if (NILP (end))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
973 e = len;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
976 CHECK_INT (end);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
977 e = XINT (end);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
978 if (e < 0)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
979 e = len + e;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
982 if (!(0 <= s && s <= e && e <= len))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
983 args_out_of_range_3 (sequence, make_int (s), make_int (e));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
984
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
985 if (VECTORP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
987 Lisp_Object result = make_vector (e - s, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 EMACS_INT i;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
989 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 Lisp_Object *out_elts = XVECTOR_DATA (result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
992 for (i = s; i < e; i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
993 out_elts[i - s] = in_elts[i];
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
996 else if (LISTP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 Lisp_Object result = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 EMACS_INT i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1001 sequence = Fnthcdr (make_int (s), sequence);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1002
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1003 for (i = s; i < e; i++)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1005 result = Fcons (Fcar (sequence), result);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1006 sequence = Fcdr (sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 return Fnreverse (result);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 }
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1011 else if (BIT_VECTORP (sequence))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1012 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1013 Lisp_Object result = make_bit_vector (e - s, Qzero);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1014 EMACS_INT i;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1015
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1016 for (i = s; i < e; i++)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1017 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1018 bit_vector_bit (XBIT_VECTOR (sequence), i));
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1019 return result;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1020 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1021 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1022 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1023 abort (); /* unreachable, since Flength (sequence) did not get
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1024 an error */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1025 return Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
1026 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1027 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1028
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1029 /* Split STRING into a list of substrings. The substrings are the
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1030 parts of original STRING separated by SEPCHAR. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1031 static Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1032 split_string_by_emchar_1 (const Intbyte *string, Bytecount size,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1033 Emchar sepchar)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1034 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1035 Lisp_Object result = Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1036 const Intbyte *end = string + size;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1037
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1038 while (1)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1039 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1040 const Intbyte *p = string;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1041 while (p < end)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1042 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1043 if (charptr_emchar (p) == sepchar)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1044 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1045 INC_CHARPTR (p);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1046 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1047 result = Fcons (make_string (string, p - string), result);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1048 if (p < end)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1049 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1050 string = p;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1051 INC_CHARPTR (string); /* skip sepchar */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1052 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1053 else
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1054 break;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1055 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1056 return Fnreverse (result);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1057 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1058
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1059 /* The same as the above, except PATH is an external C string (it is
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1060 converted using Qfile_name), and sepchar is hardcoded to SEPCHAR
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1061 (':' or whatever). */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1062 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1063 split_external_path (const Extbyte *path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1064 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1065 Bytecount newlen;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1066 Intbyte *newpath;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1067 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1068 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1069
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1070 TO_INTERNAL_FORMAT (C_STRING, path, ALLOCA, (newpath, newlen), Qfile_name);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1071
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1072 /* #### Does this make sense? It certainly does for
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1073 split_env_path(), but it looks dubious here. Does any code
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1074 depend on split_external_path("") returning nil instead of an empty
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1075 string? */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1076 if (!newlen)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1077 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1078
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1079 return split_string_by_emchar_1 (newpath, newlen, SEPCHAR);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1080 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1081
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1082 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1083 split_env_path (const CIntbyte *evarname, const Intbyte *default_)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1084 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1085 const Intbyte *path = 0;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1086 if (evarname)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1087 path = egetenv (evarname);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1088 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1089 path = default_;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1090 if (!path)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1091 return Qnil;
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1092 return split_string_by_emchar_1 (path, qxestrlen (path), SEPCHAR);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1093 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1094
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1095 /* Ben thinks this function should not exist or be exported to Lisp.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1096 We use it to define split-path-string in subr.el (not!). */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1097
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1098 DEFUN ("split-string-by-char", Fsplit_string_by_char, 1, 2, 0, /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1099 Split STRING into a list of substrings originally separated by SEPCHAR.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1100 */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1101 (string, sepchar))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1102 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1103 CHECK_STRING (string);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1104 CHECK_CHAR (sepchar);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1105 return split_string_by_emchar_1 (XSTRING_DATA (string),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1106 XSTRING_LENGTH (string),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1107 XCHAR (sepchar));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1108 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1109
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1110 /* #### This was supposed to be in subr.el, but is used VERY early in
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1111 the bootstrap process, so it goes here. Damn. */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1112
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1113 DEFUN ("split-path", Fsplit_path, 1, 1, 0, /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1114 Explode a search path into a list of strings.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1115 The path components are separated with the characters specified
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1116 with `path-separator'.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1117 */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1118 (path))
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1119 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1120 CHECK_STRING (path);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1121
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1122 while (!STRINGP (Vpath_separator)
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
1123 || (string_char_length (Vpath_separator) != 1))
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1124 Vpath_separator = signal_continuable_error
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1125 (Qinvalid_state,
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1126 "`path-separator' should be set to a single-character string",
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1127 Vpath_separator);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1128
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1129 return (split_string_by_emchar_1
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1130 (XSTRING_DATA (path), XSTRING_LENGTH (path),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1131 charptr_emchar (XSTRING_DATA (Vpath_separator))));
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1132 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1133
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 Take cdr N times on LIST, and return the result.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 (n, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 578
diff changeset
1140 REGISTER EMACS_INT i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 for (i = XINT (n); i; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 if (CONSP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 else if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 tail = wrong_type_argument (Qlistp, tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 i++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 DEFUN ("nth", Fnth, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159 Return the Nth element of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160 N counts from zero. If LIST is not that long, nil is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1162 (n, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1164 return Fcar (Fnthcdr (n, list));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1165 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1167 DEFUN ("elt", Felt, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 Return element of SEQUENCE at index N.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1169 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1170 (sequence, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1171 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1172 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1173 CHECK_INT_COERCE_CHAR (n); /* yuck! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174 if (LISTP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1175 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 Lisp_Object tem = Fnthcdr (n, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 /* #### Utterly, completely, fucking disgusting.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178 * #### The whole point of "elt" is that it operates on
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1179 * #### sequences, and does error- (bounds-) checking.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 if (CONSP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1182 return XCAR (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1183 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1184 #if 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1185 /* This is The Way It Has Always Been. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1186 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1187 #else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1188 /* This is The Way Mly and Cltl2 say It Should Be. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1189 args_out_of_range (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1190 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1191 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1192 else if (STRINGP (sequence) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1193 VECTORP (sequence) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1194 BIT_VECTORP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1195 return Faref (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1196 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1197 else if (COMPILED_FUNCTIONP (sequence))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1198 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1199 EMACS_INT idx = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1200 if (idx < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1201 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1202 lose:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1203 args_out_of_range (sequence, n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1204 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1205 /* Utter perversity */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1206 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1207 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1208 switch (idx)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1210 case COMPILED_ARGLIST:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1211 return compiled_function_arglist (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1212 case COMPILED_INSTRUCTIONS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1213 return compiled_function_instructions (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1214 case COMPILED_CONSTANTS:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1215 return compiled_function_constants (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 case COMPILED_STACK_DEPTH:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217 return compiled_function_stack_depth (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1218 case COMPILED_DOC_STRING:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 return compiled_function_documentation (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 case COMPILED_DOMAIN:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 return compiled_function_domain (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 case COMPILED_INTERACTIVE:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 if (f->flags.interactivep)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 return compiled_function_interactive (f);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 /* if we return nil, can't tell interactive with no args
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 from noninteractive. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227 goto lose;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 goto lose;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1230 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1233 #endif /* LOSING_BYTECODE */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1235 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 check_losing_bytecode ("elt", sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237 sequence = wrong_type_argument (Qsequencep, sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1238 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1239 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 DEFUN ("last", Flast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 Return the tail of list LIST, of length N (default 1).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1244 LIST may be a dotted list, but not a circular list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 Optional argument N must be a non-negative integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246 If N is zero, then the atom that terminates the list is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 If N is greater than the length of LIST, then LIST itself is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 EMACS_INT int_n, count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 Lisp_Object retval, tortoise, hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1258 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264 for (retval = tortoise = hare = list, count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1265 CONSP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1266 hare = XCDR (hare),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1267 (int_n-- <= 0 ? ((void) (retval = XCDR (retval))) : (void)0),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1268 count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1269 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1270 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1271
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1272 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1273 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1274 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1275 signal_circular_list_error (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1276 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1278 return retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1279 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1280
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1281 DEFUN ("nbutlast", Fnbutlast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1282 Modify LIST to remove the last N (default 1) elements.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1283 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1284 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1285 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1286 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1287 EMACS_INT int_n;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1289 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1291 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1292 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1293 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1294 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1295 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1296 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1297 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1299 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1300 Lisp_Object last_cons = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1301
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1302 EXTERNAL_LIST_LOOP_1 (list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1303 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1304 if (int_n-- < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1305 last_cons = XCDR (last_cons);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 if (int_n >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 XCDR (last_cons) = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 DEFUN ("butlast", Fbutlast, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 Return a copy of LIST with the last N (default 1) elements removed.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 If LIST has N or fewer elements, nil is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1319 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 (list, n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1322 EMACS_INT int_n;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 CHECK_LIST (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 if (NILP (n))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 int_n = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 CHECK_NATNUM (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1331 int_n = XINT (n);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 Lisp_Object retval = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1338 EXTERNAL_LIST_LOOP_1 (list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340 if (--int_n < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 retval = Fcons (XCAR (tail), retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 return Fnreverse (retval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1348 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1349 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1350
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1351 DEFUN ("member", Fmember, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1352 Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1353 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1354 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1355 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1356 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1357 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1358 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1359 if (internal_equal (elt, list_elt, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1360 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1361 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1362 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1363 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1365 DEFUN ("old-member", Fold_member, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1366 Return non-nil if ELT is an element of LIST. Comparison done with `old-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1367 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1368 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1369 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1370 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1371 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1372 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1373 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1374 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1375 if (internal_old_equal (elt, list_elt, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1376 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1377 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1378 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1379 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1380
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1381 DEFUN ("memq", Fmemq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1382 Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1383 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1384 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1385 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1386 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1387 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1388 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1389 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1390 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 DEFUN ("old-memq", Fold_memq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396 Return non-nil if ELT is an element of LIST. Comparison done with `old-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 The value is actually the tail of LIST whose car is ELT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 EXTERNAL_LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 if (HACKEQ_UNSAFE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412 memq_no_quit (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 LIST_LOOP_3 (list_elt, list, tail)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 if (EQ_WITH_EBOLA_NOTICE (elt, list_elt))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 return tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1420 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1421
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1422 DEFUN ("assoc", Fassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1423 Return non-nil if KEY is `equal' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1424 The value is actually the element of ALIST whose car equals KEY.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1425 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1426 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1427 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1428 /* This function can GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1429 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1430 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1431 if (internal_equal (key, elt_car, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1432 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1433 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1434 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1435 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1436
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1437 DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1438 Return non-nil if KEY is `old-equal' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1439 The value is actually the element of ALIST whose car equals KEY.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1440 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1441 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1442 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1443 /* This function can GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1444 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1445 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1446 if (internal_old_equal (key, elt_car, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1447 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1448 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1449 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1450 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1451
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1452 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1453 assoc_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1454 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1455 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1456 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1457 return unbind_to_1 (speccount, Fassoc (key, alist));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1458 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1460 DEFUN ("assq", Fassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1461 Return non-nil if KEY is `eq' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1462 The value is actually the element of ALIST whose car is KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1463 Elements of ALIST that are not conses are ignored.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1464 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1465 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1466 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1467 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1468 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1469 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1470 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1471 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1472 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1473 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1474
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1475 DEFUN ("old-assq", Fold_assq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1476 Return non-nil if KEY is `old-eq' to the car of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1477 The value is actually the element of ALIST whose car is KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1478 Elements of ALIST that are not conses are ignored.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1479 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1480 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1481 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1482 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1483 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1484 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1485 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1486 if (HACKEQ_UNSAFE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1487 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1488 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1489 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1490 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1491
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1492 /* Like Fassq but never report an error and do not allow quits.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1493 Use only on lists known never to be circular. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1494
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1495 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1496 assq_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1497 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1498 /* This cannot GC. */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1499 LIST_LOOP_2 (elt, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1500 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 Lisp_Object elt_car = XCAR (elt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 if (EQ_WITH_EBOLA_NOTICE (key, elt_car))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 DEFUN ("rassoc", Frassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1509 Return non-nil if VALUE is `equal' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1510 The value is actually the element of ALIST whose cdr equals VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1512 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1514 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1516 if (internal_equal (value, elt_cdr, 0))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1523 Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1524 The value is actually the element of ALIST whose cdr equals VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1526 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1528 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1530 if (internal_old_equal (value, elt_cdr, 0))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1533 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 DEFUN ("rassq", Frassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1537 Return non-nil if VALUE is `eq' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1538 The value is actually the element of ALIST whose cdr is VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1540 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1542 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1543 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1544 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1545 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1546 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1547 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1548 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1549
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1550 DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1551 Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1552 The value is actually the element of ALIST whose cdr is VALUE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1553 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1554 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1555 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1556 EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1557 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1558 if (HACKEQ_UNSAFE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1559 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1560 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1561 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1562 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1563
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1564 /* Like Frassq, but caller must ensure that ALIST is properly
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1565 nil-terminated and ebola-free. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1566 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1567 rassq_no_quit (Lisp_Object value, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1568 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1569 LIST_LOOP_2 (elt, alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1570 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1571 Lisp_Object elt_cdr = XCDR (elt);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1572 if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1573 return elt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1574 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1575 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1576 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1578
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1579 DEFUN ("delete", Fdelete, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1580 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1581 The modified LIST is returned. Comparison is done with `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1582 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 effect; therefore, write `(setq foo (delete element foo))' to be sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 of changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585 Also see: `remove'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590 (internal_equal (elt, list_elt, 0)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 DEFUN ("old-delete", Fold_delete, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 The modified LIST is returned. Comparison is done with `old-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 effect; therefore, write `(setq foo (old-delete element foo))' to be sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 of changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1602 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604 (internal_old_equal (elt, list_elt, 0)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1605 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1606 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1607
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1608 DEFUN ("delq", Fdelq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1609 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1610 The modified LIST is returned. Comparison is done with `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1611 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1612 effect; therefore, write `(setq foo (delq element foo))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1613 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1614 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1615 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1616 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1617 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1618 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1619 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1620 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1621
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1622 DEFUN ("old-delq", Fold_delq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1623 Delete by side effect any occurrences of ELT as a member of LIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1624 The modified LIST is returned. Comparison is done with `old-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1625 If the first member of LIST is ELT, there is no way to remove it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1626 effect; therefore, write `(setq foo (old-delq element foo))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1627 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1628 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1629 (elt, list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1630 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1631 EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1632 (HACKEQ_UNSAFE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1633 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1634 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1635
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1636 /* Like Fdelq, but caller must ensure that LIST is properly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1637 nil-terminated and ebola-free. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1638
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1639 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1640 delq_no_quit (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1641 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1642 LIST_LOOP_DELETE_IF (list_elt, list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1643 (EQ_WITH_EBOLA_NOTICE (elt, list_elt)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1644 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1645 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1646
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1647 /* Be VERY careful with this. This is like delq_no_quit() but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1648 also calls free_cons() on the removed conses. You must be SURE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1649 that no pointers to the freed conses remain around (e.g.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1650 someone else is pointing to part of the list). This function
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1651 is useful on internal lists that are used frequently and where
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1652 the actual list doesn't escape beyond known code bounds. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1653
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1654 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1655 delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1656 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1657 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1658 REGISTER Lisp_Object prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1659
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1660 while (!NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1661 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1662 REGISTER Lisp_Object tem = XCAR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1663 if (EQ (elt, tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1664 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1665 Lisp_Object cons_to_free = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1666 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1667 list = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1668 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1669 XCDR (prev) = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1670 tail = XCDR (tail);
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1671 free_cons (cons_to_free);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1672 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1673 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 tail = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1682 DEFUN ("remassoc", Fremassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1683 Delete by side effect any elements of ALIST whose car is `equal' to KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1684 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1685 that is `equal' to KEY, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1686 therefore, write `(setq foo (remassoc key foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1687 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1688 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1689 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1690 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1691 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1692 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1693 internal_equal (key, XCAR (elt), 0)));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1694 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1695 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1696
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1697 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1698 remassoc_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1699 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1700 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1701 specbind (Qinhibit_quit, Qt);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1702 return unbind_to_1 (speccount, Fremassoc (key, alist));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1703 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1704
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1705 DEFUN ("remassq", Fremassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1706 Delete by side effect any elements of ALIST whose car is `eq' to KEY.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1707 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1708 that is `eq' to KEY, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1709 therefore, write `(setq foo (remassq key foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1710 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1711 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1712 (key, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1713 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1714 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1715 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1716 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1717 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1718 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1719
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1720 /* no quit, no errors; be careful */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1721
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1722 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1723 remassq_no_quit (Lisp_Object key, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1724 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1725 LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1726 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1727 EQ_WITH_EBOLA_NOTICE (key, XCAR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1728 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1729 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1730
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1731 DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1732 Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1733 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1734 that is `equal' to VALUE, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1735 therefore, write `(setq foo (remrassoc value foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1736 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1737 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1738 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1739 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1740 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 internal_equal (value, XCDR (elt), 0)));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1743 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 DEFUN ("remrassq", Fremrassq, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1747 Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1748 The modified ALIST is returned. If the first member of ALIST has a car
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749 that is `eq' to VALUE, there is no way to remove it by side effect;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 therefore, write `(setq foo (remrassq value foo))' to be sure of changing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751 the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1752 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1753 (value, alist))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1754 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1755 EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1758 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 /* Like Fremrassq, fast and unsafe; be careful */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 Lisp_Object
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1763 remrassq_no_quit (Lisp_Object value, Lisp_Object alist)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1765 LIST_LOOP_DELETE_IF (elt, alist,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766 (CONSP (elt) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 EQ_WITH_EBOLA_NOTICE (value, XCDR (elt))));
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1768 return alist;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1770
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771 DEFUN ("nreverse", Fnreverse, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 Reverse LIST by destructively modifying cdr pointers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 Return the beginning of the reversed list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774 Also see: `reverse'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 struct gcpro gcpro1, gcpro2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 REGISTER Lisp_Object prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780 REGISTER Lisp_Object tail = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 /* We gcpro our args; see `nconc' */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 GCPRO2 (prev, tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 while (!NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1785 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786 REGISTER Lisp_Object next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 CONCHECK_CONS (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788 next = XCDR (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1789 XCDR (tail) = prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791 tail = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1794 return prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 DEFUN ("reverse", Freverse, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 Reverse LIST, copying. Return the beginning of the reversed list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799 See also the function `nreverse', which is used more often.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1800 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1801 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1802 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1803 Lisp_Object reversed_list = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1804 EXTERNAL_LIST_LOOP_2 (elt, list)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1805 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1806 reversed_list = Fcons (elt, reversed_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1807 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1808 return reversed_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1809 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1810
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1811 static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1812 Lisp_Object lisp_arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1813 int (*pred_fn) (Lisp_Object, Lisp_Object,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1814 Lisp_Object lisp_arg));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1815
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1816 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1817 list_sort (Lisp_Object list,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1818 Lisp_Object lisp_arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1819 int (*pred_fn) (Lisp_Object, Lisp_Object,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1820 Lisp_Object lisp_arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1821 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1822 struct gcpro gcpro1, gcpro2, gcpro3;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1823 Lisp_Object back, tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1824 Lisp_Object front = list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1825 Lisp_Object len = Flength (list);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1826
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1827 if (XINT (len) < 2)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1828 return list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1829
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1830 len = make_int (XINT (len) / 2 - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1831 tem = Fnthcdr (len, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1832 back = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1833 Fsetcdr (tem, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1834
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1835 GCPRO3 (front, back, lisp_arg);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1836 front = list_sort (front, lisp_arg, pred_fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1837 back = list_sort (back, lisp_arg, pred_fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1838 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1839 return list_merge (front, back, lisp_arg, pred_fn);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1840 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1841
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1843 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1844 merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1845 Lisp_Object pred)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 Lisp_Object tmp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 /* prevents the GC from happening in call2 */
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1850 /* Emacs' GC doesn't actually relocate pointers, so this probably
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
1851 isn't strictly necessary */
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1852 int speccount = begin_gc_forbidden ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 tmp = call2 (pred, obj1, obj2);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
1854 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 if (NILP (tmp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 return -1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 DEFUN ("sort", Fsort, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 Sort LIST, stably, comparing elements using PREDICATE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 Returns the sorted list. LIST is modified by side effects.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 PREDICATE is called with two elements of LIST, and should return T
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 if the first element is "less" than the second.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1868 (list, predicate))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1870 return list_sort (list, predicate, merge_pred_function);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874 merge (Lisp_Object org_l1, Lisp_Object org_l2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 Lisp_Object pred)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 return list_merge (org_l1, org_l2, pred, merge_pred_function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 Lisp_Object lisp_arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1884 int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886 Lisp_Object value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 Lisp_Object l1, l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 l1 = org_l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 l2 = org_l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 tail = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1895 value = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1896
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1897 /* It is sufficient to protect org_l1 and org_l2.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1898 When l1 and l2 are updated, we copy the new values
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1899 back into the org_ vars. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1900
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1901 GCPRO4 (org_l1, org_l2, lisp_arg, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1902
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1903 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1904 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1905 if (NILP (l1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1906 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1907 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1908 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1909 return l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1910 Fsetcdr (tail, l2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1911 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1912 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1913 if (NILP (l2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1914 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1915 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1916 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1917 return l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1918 Fsetcdr (tail, l1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1919 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1920 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1921
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1922 if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1923 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1924 tem = l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1925 l1 = Fcdr (l1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1926 org_l1 = l1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1927 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1928 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1929 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1930 tem = l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1931 l2 = Fcdr (l2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1932 org_l2 = l2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1933 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1934 if (NILP (tail))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1935 value = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1936 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1937 Fsetcdr (tail, tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1938 tail = tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1939 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1940 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 /* property-list functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 /* For properties of text, we need to do order-insensitive comparison of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 plists. That is, we need to compare two plists such that they are the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 same if they have the same set of keys, and equivalent values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 So (a 1 b 2) would be equal to (b 2 a 1).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 LAXP means use `equal' for comparisons.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 int laxp, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 {
438
84b14dcb0985 Import from CVS: tag r21-2-27
cvs
parents: 434
diff changeset
1959 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 int la, lb, m, i, fill;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 Lisp_Object *keys, *vals;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 char *flags;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 if (NILP (a) && NILP (b))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 Fcheck_valid_plist (a);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969 Fcheck_valid_plist (b);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971 la = XINT (Flength (a));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 lb = XINT (Flength (b));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 m = (la > lb ? la : lb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 fill = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 keys = alloca_array (Lisp_Object, m);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 vals = alloca_array (Lisp_Object, m);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 flags = alloca_array (char, m);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1979 /* First extract the pairs from A. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 Lisp_Object k = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 Lisp_Object v = XCAR (XCDR (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 /* Maybe be Ebolified. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 if (nil_means_not_present && NILP (v)) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 keys [fill] = k;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1987 vals [fill] = v;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1988 flags[fill] = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1989 fill++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1990 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1991 /* Now iterate over B, and stop if we find something that's not in A,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1992 or that doesn't match. As we match, mark them. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1993 for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1994 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1995 Lisp_Object k = XCAR (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1996 Lisp_Object v = XCAR (XCDR (rest));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1997 /* Maybe be Ebolified. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1998 if (nil_means_not_present && NILP (v)) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1999 for (i = 0; i < fill; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2000 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2001 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2002 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2003 if (eqp
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2004 /* We narrowly escaped being Ebolified here. */
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2005 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2006 : !internal_equal (v, vals [i], depth))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2007 /* a property in B has a different value than in A */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2008 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2009 flags [i] = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2010 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2011 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2012 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2013 if (i == fill)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2014 /* there are some properties in B that are not in A */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2015 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2016 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2017 /* Now check to see that all the properties in A were also in B */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2018 for (i = 0; i < fill; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2019 if (flags [i] == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2020 goto MISMATCH;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2021
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 /* Ok. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 MISMATCH:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2029 DEFUN ("plists-eq", Fplists_eq, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 Return non-nil if property lists A and B are `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031 A property list is an alternating list of keywords and values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 This function does order-insensitive comparisons of the property lists:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 Comparison between values is done using `eq'. See also `plists-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2038 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2039 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2040 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2041 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2042 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2043 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2044 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2045
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2046 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2047 Return non-nil if property lists A and B are `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2048 A property list is an alternating list of keywords and values. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2049 function does order-insensitive comparisons of the property lists: For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2050 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2051 Comparison between values is done using `equal'. See also `plists-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2052 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2053 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2054 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2055 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2056 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2057 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2058 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2059 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2060 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2061 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2062
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2063
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2064 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2065 Return non-nil if lax property lists A and B are `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2066 A property list is an alternating list of keywords and values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2067 This function does order-insensitive comparisons of the property lists:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2068 For example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2069 Comparison between values is done using `eq'. See also `plists-equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2070 A lax property list is like a regular one except that comparisons between
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2071 keywords is done using `equal' instead of `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2079 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 Return non-nil if lax property lists A and B are `equal'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085 A property list is an alternating list of keywords and values. This
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 function does order-insensitive comparisons of the property lists: For
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 example, the property lists '(a 1 b 2) and '(b 2 a 1) are equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2088 Comparison between values is done using `equal'. See also `plists-eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2089 A lax property list is like a regular one except that comparisons between
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2090 keywords is done using `equal' instead of `eq'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2091 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2092 a nil value is ignored. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2093 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2094 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2095 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2096 (a, b, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2097 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2098 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2099 ? Qnil : Qt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2100 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2101
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2102 /* Return the value associated with key PROPERTY in property list PLIST.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2103 Return nil if key not found. This function is used for internal
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2104 property lists that cannot be directly manipulated by the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2105 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2107 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2108 internal_plist_get (Lisp_Object plist, Lisp_Object property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2109 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2110 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2112 for (tail = plist; !NILP (tail); tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2113 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2114 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2115 return XCAR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2118 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2119 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2120
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2121 /* Set PLIST's value for PROPERTY to VALUE. Analogous to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2122 internal_plist_get(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2124 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125 internal_plist_put (Lisp_Object *plist, Lisp_Object property,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2126 Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2128 Lisp_Object tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2130 for (tail = *plist; !NILP (tail); tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2133 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2134 XCAR (XCDR (tail)) = value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2136 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2137 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2138
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2139 *plist = Fcons (property, Fcons (value, *plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2140 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2141
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2142 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2143 internal_remprop (Lisp_Object *plist, Lisp_Object property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145 Lisp_Object tail, prev;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147 for (tail = *plist, prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148 !NILP (tail);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2149 tail = XCDR (XCDR (tail)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2150 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2151 if (EQ (XCAR (tail), property))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2152 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2153 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2154 *plist = XCDR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2155 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2156 XCDR (XCDR (prev)) = XCDR (XCDR (tail));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2157 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2158 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2159 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2160 prev = tail;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2161 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2163 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2164 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2165
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2166 /* Called on a malformed property list. BADPLACE should be some
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2167 place where truncating will form a good list -- i.e. we shouldn't
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2168 result in a list with an odd length. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2169
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2170 static Lisp_Object
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2171 bad_bad_bunny (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2172 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2173 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2174 return Fsignal (Qmalformed_property_list, list2 (*plist, *badplace));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2175 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2176 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2177 if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 (Qlist, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2181 list2 (build_msg_string
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 ("Malformed property list -- list has been truncated"),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183 *plist));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2184 /* #### WARNING: This is more dangerous than it seems; perhaps
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2185 not a good idea. It also violates the principle of least
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2186 surprise -- passing in ERROR_ME_WARN causes truncation, but
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2187 ERROR_ME and ERROR_ME_NOT don't. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188 *badplace = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194 /* Called on a circular property list. BADPLACE should be some place
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 where truncating will result in an even-length list, as above.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 If doesn't particularly matter where we truncate -- anywhere we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197 truncate along the entire list will break the circularity, because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198 it will create a terminus and the list currently doesn't have one.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2201 static Lisp_Object
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2202 bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2203 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204 if (ERRB_EQ (errb, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2205 return Fsignal (Qcircular_property_list, list1 (*plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2206 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2207 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2208 if (ERRB_EQ (errb, ERROR_ME_WARN))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2209 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2210 warn_when_safe_lispobj
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2211 (Qlist, Qwarning,
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2212 list2 (build_msg_string
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2213 ("Circular property list -- list has been truncated"),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2214 *plist));
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2215 /* #### WARNING: This is more dangerous than it seems; perhaps
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2216 not a good idea. It also violates the principle of least
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2217 surprise -- passing in ERROR_ME_WARN causes truncation, but
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2218 ERROR_ME and ERROR_ME_NOT don't. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2219 *badplace = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2220 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2221 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2222 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2223 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2224
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2225 /* Advance the tortoise pointer by two (one iteration of a property-list
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2226 loop) and the hare pointer by four and verify that no malformations
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2227 or circularities exist. If so, return zero and store a value into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2228 RETVAL that should be returned by the calling function. Otherwise,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2229 return 1. See external_plist_get().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2230 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2231
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2232 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2233 advance_plist_pointers (Lisp_Object *plist,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2234 Lisp_Object **tortoise, Lisp_Object **hare,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2235 Error_Behavior errb, Lisp_Object *retval)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2236 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2237 int i;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2238 Lisp_Object *tortsave = *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2239
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2240 /* Note that our "fixing" may be more brutal than necessary,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2241 but it's the user's own problem, not ours, if they went in and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2242 manually fucked up a plist. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2244 for (i = 0; i < 2; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2245 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2246 /* This is a standard iteration of a defensive-loop-checking
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2247 loop. We just do it twice because we want to advance past
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2248 both the property and its value.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2249
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2250 If the pointer indirection is confusing you, remember that
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2251 one level of indirection on the hare and tortoise pointers
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2252 is only due to pass-by-reference for this function. The other
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2253 level is so that the plist can be fixed in place. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2254
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2255 /* When we reach the end of a well-formed plist, **HARE is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2256 nil. In that case, we don't do anything at all except
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2257 advance TORTOISE by one. Otherwise, we advance HARE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2258 by two (making sure it's OK to do so), then advance
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2259 TORTOISE by one (it will always be OK to do so because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2260 the HARE is always ahead of the TORTOISE and will have
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2261 already verified the path), then make sure TORTOISE and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2262 HARE don't contain the same non-nil object -- if the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 TORTOISE and the HARE ever meet, then obviously we're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264 in a circularity, and if we're in a circularity, then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 the TORTOISE and the HARE can't cross paths without
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266 meeting, since the HARE only gains one step over the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 TORTOISE per iteration. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 if (!NILP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 Lisp_Object *haresave = *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272 if (!CONSP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2273 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2274 *retval = bad_bad_bunny (plist, haresave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277 *hare = &XCDR (**hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278 /* In a non-plist, we'd check here for a nil value for
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 **HARE, which is OK (it just means the list has an
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2280 odd number of elements). In a plist, it's not OK
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 for the list to have an odd number of elements. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282 if (!CONSP (**hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284 *retval = bad_bad_bunny (plist, haresave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287 *hare = &XCDR (**hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2289
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2290 *tortoise = &XCDR (**tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2291 if (!NILP (**hare) && EQ (**tortoise, **hare))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2293 *retval = bad_bad_turtle (plist, tortsave, errb);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2295 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2297
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301 /* Return the value of PROPERTY from PLIST, or Qunbound if
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 property is not on the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2304 PLIST is a Lisp-accessible property list, meaning that it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2305 has to be checked for malformations and circularities.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 If ERRB is ERROR_ME, an error will be signalled. Otherwise, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308 function will never signal an error; and if ERRB is ERROR_ME_WARN,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 on finding a malformation or a circularity, it issues a warning and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 attempts to silently fix the problem.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 A pointer to PLIST is passed in so that PLIST can be successfully
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 "fixed" even if the error is at the beginning of the plist. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316 external_plist_get (Lisp_Object *plist, Lisp_Object property,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2317 int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2324 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2325 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2326
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2327 /* We do the standard tortoise/hare march. We isolate the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2328 grungy stuff to do this in advance_plist_pointers(), though.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2329 To us, all this function does is advance the tortoise
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2330 pointer by two and the hare pointer by four and make sure
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2331 everything's OK. We first advance the pointers and then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2332 check if a property matched; this ensures that our
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2333 check for a matching property is safe. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2334
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2335 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2336 return retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2337
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2338 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2339 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2340 return XCAR (XCDR (*tortsave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2341 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2342
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2343 return Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2344 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2345
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2346 /* Set PLIST's value for PROPERTY to VALUE, given a possibly
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2347 malformed or circular plist. Analogous to external_plist_get(). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2348
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2349 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2350 external_plist_put (Lisp_Object *plist, Lisp_Object property,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2351 Lisp_Object value, int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2352 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2353 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2354 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2355
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2356 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2357 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2358 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2361 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2362 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2363 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2364
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2367 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368 XCAR (XCDR (*tortsave)) = value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2369 return;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2371 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2372
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2373 *plist = Fcons (property, Fcons (value, *plist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2375
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2376 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2377 external_remprop (Lisp_Object *plist, Lisp_Object property,
578
190b164ddcac [xemacs-hg @ 2001-05-25 11:26:50 by ben]
ben
parents: 575
diff changeset
2378 int laxp, Error_Behavior errb)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2379 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2380 Lisp_Object *tortoise = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2381 Lisp_Object *hare = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2382
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2383 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2384 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2385 Lisp_Object *tortsave = tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2386 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2387
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2388 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2389 if (!advance_plist_pointers (plist, &tortoise, &hare, errb, &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2390 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2391
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2392 if (!laxp ? EQ (XCAR (*tortsave), property)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2393 : internal_equal (XCAR (*tortsave), property, 0))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2394 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2395 /* Now you see why it's so convenient to have that level
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2396 of indirection. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2397 *tortsave = XCDR (XCDR (*tortsave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2398 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2399 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2400 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2401
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2402 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2403 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2404
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2405 DEFUN ("plist-get", Fplist_get, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406 Extract a value from a property list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 PLIST is a property list, which is a list of the form
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2408 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2409 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2410 This function returns the value corresponding to the PROPERTY,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2411 or DEFAULT if PROPERTY is not one of the properties on the list.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2412 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2413 (plist, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2415 Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2416 return UNBOUNDP (value) ? default_ : value;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2419 DEFUN ("plist-put", Fplist_put, 3, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2420 Change value in PLIST of PROPERTY to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2421 PLIST is a property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2422 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2423 PROPERTY is usually a symbol and VALUE is any object.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2424 If PROPERTY is already a property on the list, its value is set to VALUE,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2425 otherwise the new PROPERTY VALUE pair is added.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2426 The new plist is returned; use `(setq x (plist-put x property value))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2427 to be sure to use the new value. PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2428 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2429 (plist, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2430 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2431 external_plist_put (&plist, property, value, 0, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2432 return plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2433 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2434
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2435 DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2436 Remove from PLIST the property PROPERTY and its value.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2437 PLIST is a property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2438 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...).
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2439 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2440 The new plist is returned; use `(setq x (plist-remprop x property))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2441 to be sure to use the new value. PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2442 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2443 (plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2444 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2445 external_remprop (&plist, property, 0, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2446 return plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2447 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2448
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2449 DEFUN ("plist-member", Fplist_member, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2450 Return t if PROPERTY has a value specified in PLIST.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2451 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2452 (plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2454 Lisp_Object value = Fplist_get (plist, property, Qunbound);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2455 return UNBOUNDP (value) ? Qnil : Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2457
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2458 DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2459 Given a plist, signal an error if there is anything wrong with it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2460 This means that it's a malformed or circular plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2461 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462 (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464 Lisp_Object *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 Lisp_Object *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 start_over:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468 tortoise = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 hare = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476 &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477 goto start_over;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2481 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2483 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2484 Given a plist, return non-nil if its format is correct.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2485 If it returns nil, `check-valid-plist' will signal an error when given
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2486 the plist; that means it's a malformed or circular plist.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488 (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2489 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2490 Lisp_Object *tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2491 Lisp_Object *hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2492
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2493 tortoise = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2494 hare = &plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495 while (!NILP (*tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497 Lisp_Object retval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2498
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 /* See above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 if (!advance_plist_pointers (&plist, &tortoise, &hare, ERROR_ME_NOT,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 &retval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2503 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505 return Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 DEFUN ("canonicalize-plist", Fcanonicalize_plist, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 Destructively remove any duplicate entries from a plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 In such cases, the first entry applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513 a nil value is removed. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2516
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2518 return value may not be EQ to the passed-in value, so make sure to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519 `setq' the value back into where it came from.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521 (plist, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2522 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2523 Lisp_Object head = plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2524
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2525 Fcheck_valid_plist (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2526
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 while (!NILP (plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2528 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529 Lisp_Object prop = Fcar (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2530 Lisp_Object next = Fcdr (plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2531
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2532 CHECK_CONS (next); /* just make doubly sure we catch any errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2533 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2534 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2535 if (EQ (head, plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536 head = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2538 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2540 /* external_remprop returns 1 if it removed any property.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2541 We have to loop till it didn't remove anything, in case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2542 the property occurs many times. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 while (external_remprop (&XCDR (next), prop, 0, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2544 DO_NOTHING;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2545 plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551 DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2552 Extract a value from a lax property list.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2553 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2554 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2555 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2556 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2557 This function returns the value corresponding to PROPERTY,
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2558 or DEFAULT if PROPERTY is not one of the properties on the list.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2559 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2560 (lax_plist, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2561 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2562 Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2563 return UNBOUNDP (value) ? default_ : value;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2564 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2567 Change value in LAX-PLIST of PROPERTY to VALUE.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2568 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2569 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2570 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2571 PROPERTY is usually a symbol and VALUE is any object.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2572 If PROPERTY is already a property on the list, its value is set to
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2573 VALUE, otherwise the new PROPERTY VALUE pair is added.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2574 The new plist is returned; use `(setq x (lax-plist-put x property value))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2575 to be sure to use the new value. LAX-PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2577 (lax_plist, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2579 external_plist_put (&lax_plist, property, value, 1, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580 return lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2581 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2584 Remove from LAX-PLIST the property PROPERTY and its value.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2585 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2586 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2587 properties is done using `equal' instead of `eq'.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2588 PROPERTY is usually a symbol.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2589 The new plist is returned; use `(setq x (lax-plist-remprop x property))'
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2590 to be sure to use the new value. LAX-PLIST is modified by side effect.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2592 (lax_plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2593 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2594 external_remprop (&lax_plist, property, 1, ERROR_ME);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 return lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2596 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2599 Return t if PROPERTY has a value specified in LAX-PLIST.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2600 LAX-PLIST is a lax property list, which is a list of the form
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2601 \(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2602 properties is done using `equal' instead of `eq'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2604 (lax_plist, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2605 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2606 return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 Destructively remove any duplicate entries from a lax plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611 In such cases, the first entry applies.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613 If optional arg NIL-MEANS-NOT-PRESENT is non-nil, then a property with
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2614 a nil value is removed. This feature is a virus that has infected
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615 old Lisp implementations, but should not be used except for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616 compatibility.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 return value may not be EQ to the passed-in value, so make sure to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2620 `setq' the value back into where it came from.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2621 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 (lax_plist, nil_means_not_present))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2624 Lisp_Object head = lax_plist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2626 Fcheck_valid_plist (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 while (!NILP (lax_plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630 Lisp_Object prop = Fcar (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2631 Lisp_Object next = Fcdr (lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633 CHECK_CONS (next); /* just make doubly sure we catch any errors */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 if (!NILP (nil_means_not_present) && NILP (Fcar (next)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2635 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636 if (EQ (head, lax_plist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2637 head = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 lax_plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2640 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2641 /* external_remprop returns 1 if it removed any property.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2642 We have to loop till it didn't remove anything, in case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2643 the property occurs many times. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644 while (external_remprop (&XCDR (next), prop, 1, ERROR_ME))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645 DO_NOTHING;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646 lax_plist = Fcdr (next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2650 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2651
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2652 /* In C because the frame props stuff uses it */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2653
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2654 DEFUN ("destructive-alist-to-plist", Fdestructive_alist_to_plist, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2655 Convert association list ALIST into the equivalent property-list form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2656 The plist is returned. This converts from
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2657
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2658 \((a . 1) (b . 2) (c . 3))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2659
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2660 into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2661
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2662 \(a 1 b 2 c 3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2664 The original alist is destroyed in the process of constructing the plist.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2665 See also `alist-to-plist'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2666 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 Lisp_Object head = alist;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670 while (!NILP (alist))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 /* remember the alist element. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2673 Lisp_Object el = Fcar (alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2674
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2675 Fsetcar (alist, Fcar (el));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 Fsetcar (el, Fcdr (el));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2677 Fsetcdr (el, Fcdr (alist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678 Fsetcdr (alist, el);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2679 alist = Fcdr (Fcdr (alist));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2681
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2682 return head;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2683 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2684
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2685 DEFUN ("get", Fget, 2, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2686 Return the value of OBJECT's PROPERTY property.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2687 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2688 If there is no such property, return optional third arg DEFAULT
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2689 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2690 face, or glyph. See also `put', `remprop', and `object-plist'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2691 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2692 (object, property, default_))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2694 /* Various places in emacs call Fget() and expect it not to quit,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 so don't quit. */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2696 Lisp_Object val;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2697
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2698 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2699 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2701 invalid_operation ("Object type has no properties", object);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2702
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2703 return UNBOUNDP (val) ? default_ : val;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2704 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2705
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706 DEFUN ("put", Fput, 3, 3, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2707 Set OBJECT's PROPERTY to VALUE.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2708 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2709 OBJECT can be a symbol, face, extent, or string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 For a string, no properties currently have predefined meanings.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 For the predefined properties for extents, see `set-extent-property'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712 For the predefined properties for faces, see `set-face-property'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713 See also `get', `remprop', and `object-plist'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2714 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2715 (object, property, value))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2716 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2717 CHECK_LISP_WRITEABLE (object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2719 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2720 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2721 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2722 (object, property, value))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2723 invalid_change ("Can't set property on object", property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2724 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2726 invalid_change ("Object type has no settable properties", object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2727
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2728 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2729 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2731 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2732 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2733 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2734 if the property list was actually modified (i.e. if PROPERTY was present
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2735 in the property list). See also `get', `put', and `object-plist'.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2736 */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2737 (object, property))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2739 int ret = 0;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2740
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741 CHECK_LISP_WRITEABLE (object);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2743 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2745 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2746 if (ret == -1)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2747 invalid_change ("Can't remove property from object", property);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2750 invalid_change ("Object type has no removable properties", object);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2751
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2752 return ret ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2753 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2755 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2756 Return a property list of OBJECT's properties.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2757 For a symbol, this is equivalent to `symbol-plist'.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2758 OBJECT can be a symbol, string, extent, face, or glyph.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2759 Do not modify the returned property list directly;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2760 this may or may not have the desired effects. Use `put' instead.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2761 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2762 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2763 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2764 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2765 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2766 else
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2767 invalid_operation ("Object type has no properties", object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772
853
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2773 static Lisp_Object
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2774 tweaked_internal_equal (Lisp_Object obj1, Lisp_Object obj2,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2775 Lisp_Object depth)
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2776 {
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2777 return make_int (internal_equal (obj1, obj2, XINT (depth)));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2778 }
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2779
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2780 int
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2781 internal_equal_trapping_problems (Lisp_Object warning_class,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2782 const char *warning_string,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2783 int flags,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2784 struct call_trapping_problems_result *p,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2785 int retval,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2786 Lisp_Object obj1, Lisp_Object obj2,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2787 int depth)
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2788 {
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2789 Lisp_Object glorp =
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2790 va_call_trapping_problems (warning_class, warning_string,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2791 flags, p,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2792 (lisp_fn_t) tweaked_internal_equal,
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2793 3, obj1, obj2, make_int (depth));
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2794 if (UNBOUNDP (glorp))
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2795 return retval;
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2796 else
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2797 return XINT (glorp);
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2798 }
2b6fa2618f76 [xemacs-hg @ 2002-05-28 08:44:22 by ben]
ben
parents: 851
diff changeset
2799
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2800 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2801 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2803 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2804 stack_overflow ("Stack overflow in equal", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2805 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2806 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2807 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2808 /* Note that (equal 20 20.0) should be nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 if (XTYPE (obj1) != XTYPE (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2810 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2811 if (LRECORDP (obj1))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2812 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2813 const struct lrecord_implementation
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2815 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2817 return (imp1 == imp2) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2818 /* EQ-ness of the objects was noticed above */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2819 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2825 int
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2826 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2827 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2828 if (depth > 200)
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2829 stack_overflow ("Stack overflow in equalp", Qunbound);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2830 QUIT;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2831 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2832 return 1;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2833 if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2)))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2834 return extract_float (obj1) == extract_float (obj2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2835 if (CHARP (obj1) && CHARP (obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2836 return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2));
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2837 if (XTYPE (obj1) != XTYPE (obj2))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2838 return 0;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2839 if (LRECORDP (obj1))
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2840 {
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2841 const struct lrecord_implementation
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2842 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2843 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2844
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2845 /* #### not yet implemented properly, needs another flag to specify
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2846 equalp-ness */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2847 return (imp1 == imp2) &&
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2848 /* EQ-ness of the objects was noticed above */
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2849 (imp1->equal && (imp1->equal) (obj1, obj2, depth));
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2850 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2851
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2852 return 0;
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2853 }
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
2854
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855 /* Note that we may be calling sub-objects that will use
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 internal_equal() (instead of internal_old_equal()). Oh well.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857 We will get an Ebola note if there's any possibility of confusion,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858 but that seems unlikely. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 if (depth > 200)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
2864 stack_overflow ("Stack overflow in equal", Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2865 QUIT;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 if (HACKEQ_UNSAFE (obj1, obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867 return 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868 /* Note that (equal 20 20.0) should be nil */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2869 if (XTYPE (obj1) != XTYPE (obj2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2870 return 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 return internal_equal (obj1, obj2, depth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 DEFUN ("equal", Fequal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876 Return t if two Lisp objects have similar structure and contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 They must have the same data type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878 Conses are compared by comparing the cars and the cdrs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879 Vectors and strings are compared element by element.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 Numbers are compared by value. Symbols must match exactly.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2882 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2884 return internal_equal (object1, object2, 0) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888 Return t if two Lisp objects have similar structure and contents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889 They must have the same data type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890 \(Note, however, that an exception is made for characters and integers;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 this is known as the "char-int confoundance disease." See `eq' and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 `old-eq'.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 This function is provided only for byte-code compatibility with v19.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 Do not use it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2896 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2898 return internal_old_equal (object1, object2, 0) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2899 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2903 Destructively modify ARRAY by replacing each element with ITEM.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904 ARRAY is a vector, bit vector, or string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2906 (array, item))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2907 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2908 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2909 if (STRINGP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2910 {
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2911 Bytecount old_bytecount = XSTRING_LENGTH (array);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2912 Bytecount new_bytecount;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2913 Bytecount item_bytecount;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2914 Intbyte item_buf[MAX_EMCHAR_LEN];
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2915 Intbyte *p;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2916 Intbyte *end;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2917
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2918 CHECK_CHAR_COERCE_INT (item);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2919 CHECK_LISP_WRITEABLE (array);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2920
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2921 sledgehammer_check_ascii_begin (array);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2922 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
2923 new_bytecount = item_bytecount * (Bytecount) string_char_length (array);
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2924
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2925 resize_string (array, -1, new_bytecount - old_bytecount);
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2926
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2927 for (p = XSTRING_DATA (array), end = p + new_bytecount;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2928 p < end;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2929 p += item_bytecount)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2930 memcpy (p, item_buf, item_bytecount);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2931 *p = '\0';
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
2932
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2933 XSET_STRING_ASCII_BEGIN (array,
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2934 item_bytecount == 1 ?
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2935 min (new_bytecount, MAX_STRING_ASCII_BEGIN) :
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 780
diff changeset
2936 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2937 bump_string_modiff (array);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
2938 sledgehammer_check_ascii_begin (array);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2939 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2940 else if (VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2941 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2942 Lisp_Object *p = XVECTOR_DATA (array);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2943 Elemcount len = XVECTOR_LENGTH (array);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2944 CHECK_LISP_WRITEABLE (array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2945 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2946 *p++ = item;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2947 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2948 else if (BIT_VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2949 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
2950 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2951 Elemcount len = bit_vector_length (v);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2952 int bit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2953 CHECK_BIT (item);
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2954 bit = XINT (item);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2955 CHECK_LISP_WRITEABLE (array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2956 while (len--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2957 set_bit_vector_bit (v, len, bit);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2958 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2959 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2960 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2961 array = wrong_type_argument (Qarrayp, array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2962 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2963 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2964 return array;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2965 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2966
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2967 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2968 nconc2 (Lisp_Object arg1, Lisp_Object arg2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2969 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2970 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2971 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2972 args[0] = arg1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2973 args[1] = arg2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2974
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2975 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2976 gcpro1.nvars = 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2977
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2978 RETURN_UNGCPRO (bytecode_nconc2 (args));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2979 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2980
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2981 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2982 bytecode_nconc2 (Lisp_Object *args)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2983 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2984 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2985
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2986 if (CONSP (args[0]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2987 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2988 /* (setcdr (last args[0]) args[1]) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2989 Lisp_Object tortoise, hare;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2990 Elemcount count;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2991
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2992 for (hare = tortoise = args[0], count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2993 CONSP (XCDR (hare));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2994 hare = XCDR (hare), count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2995 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2996 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2997
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2998 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2999 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3000 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3001 signal_circular_list_error (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3002 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3003 XCDR (hare) = args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3004 return args[0];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3005 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3006 else if (NILP (args[0]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3007 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3008 return args[1];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3009 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3010 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3011 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3012 args[0] = wrong_type_argument (args[0], Qlistp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3013 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3014 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3015 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3016
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3017 DEFUN ("nconc", Fnconc, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3018 Concatenate any number of lists by altering them.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3019 Only the last argument is not altered, and need not be a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3020 Also see: `append'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3021 If the first argument is nil, there is no way to modify it by side
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3022 effect; therefore, write `(setq foo (nconc foo list))' to be sure of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3023 changing the value of `foo'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3024 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3025 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3026 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3027 int argnum = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3028 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3029
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3030 /* The modus operandi in Emacs is "caller gc-protects args".
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3031 However, nconc (particularly nconc2 ()) is called many times
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3032 in Emacs on freshly created stuff (e.g. you see the idiom
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3033 nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3034 callers out by protecting the args ourselves to save them
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3035 a lot of temporary-variable grief. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3036
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3037 GCPRO1 (args[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3038 gcpro1.nvars = nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3039
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3040 while (argnum < nargs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3041 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3042 Lisp_Object val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3043 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3044 val = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3045 if (CONSP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3046 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3047 /* `val' is the first cons, which will be our return value. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3048 /* `last_cons' will be the cons cell to mutate. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3049 Lisp_Object last_cons = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3050 Lisp_Object tortoise = val;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3051
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3052 for (argnum++; argnum < nargs; argnum++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3053 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3054 Lisp_Object next = args[argnum];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3055 retry_next:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3056 if (CONSP (next) || argnum == nargs -1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3057 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3058 /* (setcdr (last val) next) */
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3059 Elemcount count;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3060
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3061 for (count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3062 CONSP (XCDR (last_cons));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3063 last_cons = XCDR (last_cons), count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3064 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3065 if (count < CIRCULAR_LIST_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3066
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3067 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3068 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3069 if (EQ (last_cons, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3070 signal_circular_list_error (args[argnum-1]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3071 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3072 XCDR (last_cons) = next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3073 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3074 else if (NILP (next))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3075 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3076 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3077 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3078 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3079 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3080 next = wrong_type_argument (Qlistp, next);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3081 goto retry_next;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3082 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3083 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3084 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3085 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3086 else if (NILP (val))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3087 argnum++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3088 else if (argnum == nargs - 1) /* last arg? */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3089 RETURN_UNGCPRO (val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3090 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3091 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3092 args[argnum] = wrong_type_argument (Qlistp, val);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3093 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3094 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3095 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3096 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3097 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3098
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3099
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3100 /* This is the guts of several mapping functions.
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3101 Apply FUNCTION to each element of SEQUENCE, one by one,
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3102 storing the results into elements of VALS, a C vector of Lisp_Objects.
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3103 LENI is the length of VALS, which should also be the length of SEQUENCE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3104
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3105 If VALS is a null pointer, do not accumulate the results. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3106
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3107 static void
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3108 mapcar1 (Elemcount leni, Lisp_Object *vals,
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3109 Lisp_Object function, Lisp_Object sequence)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3110 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3111 Lisp_Object result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3112 Lisp_Object args[2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3113 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3114
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3115 if (vals)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3116 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3117 GCPRO1 (vals[0]);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3118 gcpro1.nvars = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3119 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3120
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3121 args[0] = function;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3122
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3123 if (LISTP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3124 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3125 /* A devious `function' could either:
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3126 - insert garbage into the list in front of us, causing XCDR to crash
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3127 - amputate the list behind us using (setcdr), causing the remaining
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3128 elts to lose their GCPRO status.
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3129
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3130 if (vals != 0) we avoid this by copying the elts into the
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3131 `vals' array. By a stroke of luck, `vals' is exactly large
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3132 enough to hold the elts left to be traversed as well as the
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3133 results computed so far.
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3134
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3135 if (vals == 0) we don't have any free space available and
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3136 don't want to eat up any more stack with ALLOCA ().
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3137 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3138
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3139 if (vals)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3140 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3141 Lisp_Object *val = vals;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3142 Elemcount i;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3143
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3144 LIST_LOOP_2 (elt, sequence)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3145 *val++ = elt;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3146
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3147 gcpro1.nvars = leni;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3148
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3149 for (i = 0; i < leni; i++)
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3150 {
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3151 args[1] = vals[i];
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3152 vals[i] = Ffuncall (2, args);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3153 }
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3154 }
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3155 else
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3156 {
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3157 Lisp_Object elt, tail;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3158 EMACS_INT len_unused;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3159 struct gcpro ngcpro1;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3160
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3161 NGCPRO1 (tail);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3162
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3163 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3164 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3165 {
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3166 args[1] = elt;
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3167 Ffuncall (2, args);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3168 }
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3169 }
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3170
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3171 NUNGCPRO;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3172 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3173 }
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3174 else if (VECTORP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3175 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3176 Lisp_Object *objs = XVECTOR_DATA (sequence);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3177 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3178 for (i = 0; i < leni; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3179 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3180 args[1] = *objs++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3181 result = Ffuncall (2, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3182 if (vals) vals[gcpro1.nvars++] = result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3183 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3184 }
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3185 else if (STRINGP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3186 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3187 /* The string data of `sequence' might be relocated during GC. */
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3188 Bytecount slen = XSTRING_LENGTH (sequence);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3189 Intbyte *p = alloca_array (Intbyte, slen);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3190 Intbyte *end = p + slen;
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3191
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3192 memcpy (p, XSTRING_DATA (sequence), slen);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3193
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3194 while (p < end)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3195 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3196 args[1] = make_char (charptr_emchar (p));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3197 INC_CHARPTR (p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3198 result = Ffuncall (2, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3199 if (vals) vals[gcpro1.nvars++] = result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3200 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3201 }
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3202 else if (BIT_VECTORP (sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3203 {
440
8de8e3f6228a Import from CVS: tag r21-2-28
cvs
parents: 438
diff changeset
3204 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3205 Elemcount i;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3206 for (i = 0; i < leni; i++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3207 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3208 args[1] = make_int (bit_vector_bit (v, i));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3209 result = Ffuncall (2, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3210 if (vals) vals[gcpro1.nvars++] = result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3211 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3212 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3213 else
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3214 abort (); /* unreachable, since Flength (sequence) did not get an error */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3215
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3216 if (vals)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3217 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3218 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3219
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3220 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
751
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3221 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3222 Between each pair of results, insert SEPARATOR.
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3223
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3224 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3225 results in spaces between the values returned by FUNCTION. SEQUENCE itself
358bd84dc7ff [xemacs-hg @ 2002-02-13 12:55:38 by stephent]
stephent
parents: 665
diff changeset
3226 may be a list, a vector, a bit vector, or a string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3227 */
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3228 (function, sequence, separator))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3229 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3230 EMACS_INT len = XINT (Flength (sequence));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3231 Lisp_Object *args;
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3232 EMACS_INT i;
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3233 EMACS_INT nargs = len + len - 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3234
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3235 if (len == 0) return build_string ("");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3236
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3237 args = alloca_array (Lisp_Object, nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3238
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3239 mapcar1 (len, args, function, sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3241 for (i = len - 1; i >= 0; i--)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3242 args[i + i] = args[i];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3243
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3244 for (i = 1; i < nargs; i += 2)
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3245 args[i] = separator;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3246
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3247 return Fconcat (nargs, args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3248 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3249
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3250 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3251 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3252 The result is a list of the same length as SEQUENCE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3253 SEQUENCE may be a list, a vector, a bit vector, or a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3254 */
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3255 (function, sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3256 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3257 Elemcount len = XINT (Flength (sequence));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3258 Lisp_Object *args = alloca_array (Lisp_Object, len);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3259
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3260 mapcar1 (len, args, function, sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3261
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 578
diff changeset
3262 return Flist ((int) len, args);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3265 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3266 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3267 The result is a vector of the same length as SEQUENCE.
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3268 SEQUENCE may be a list, a vector, a bit vector, or a string.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3269 */
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3270 (function, sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3271 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3272 Elemcount len = XINT (Flength (sequence));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3273 Lisp_Object result = make_vector (len, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3274 struct gcpro gcpro1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3275
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3276 GCPRO1 (result);
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3277 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278 UNGCPRO;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284 Apply FUNCTION to each element of SEQUENCE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285 SEQUENCE may be a list, a vector, a bit vector, or a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 This function is like `mapcar' but does not accumulate the results,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3287 which is more efficient if you do not use the results.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3289 The difference between this and `mapc' is that `mapc' supports all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290 the spiffy Common Lisp arguments. You should normally use `mapc'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 */
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3292 (function, sequence))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 {
434
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3294 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3295
9d177e8d4150 Import from CVS: tag r21-2-25
cvs
parents: 428
diff changeset
3296 return sequence;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3300 /* Extra random functions */
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3301
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3302 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3303 Destructively replace the list OLD with NEW.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3304 This is like (copy-sequence NEW) except that it reuses the
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3305 conses in OLD as much as possible. If OLD and NEW are the same
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3306 length, no consing will take place.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3307 */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3308 (old, new))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3309 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3310 Lisp_Object tail, oldtail = old, prevoldtail = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3311
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3312 EXTERNAL_LIST_LOOP (tail, new)
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3313 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3314 if (!NILP (oldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3315 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3316 CHECK_CONS (oldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3317 XCAR (oldtail) = XCAR (tail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3318 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3319 else if (!NILP (prevoldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3320 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3321 XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3322 prevoldtail = XCDR (prevoldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3323 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3324 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3325 old = oldtail = Fcons (XCAR (tail), Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3326
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3327 if (!NILP (oldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3328 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3329 prevoldtail = oldtail;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3330 oldtail = XCDR (oldtail);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3331 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3332 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3333
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3334 if (!NILP (prevoldtail))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3335 XCDR (prevoldtail) = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3336 else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3337 old = Qnil;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3338
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3339 return old;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3340 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3341
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3342 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3343 add_suffix_to_symbol (Lisp_Object symbol, const Char_ASCII *ascii_string)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3344 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3345 return Fintern (concat2 (Fsymbol_name (symbol),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3346 build_string (ascii_string)),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3347 Qnil);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3348 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3349
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3350 Lisp_Object
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3351 add_prefix_to_symbol (const Char_ASCII *ascii_string, Lisp_Object symbol)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3352 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3353 return Fintern (concat2 (build_string (ascii_string),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3354 Fsymbol_name (symbol)),
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3355 Qnil);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3356 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3357
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3358
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3359 /* #### this function doesn't belong in this file! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3360
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3361 #ifdef HAVE_GETLOADAVG
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3362 #ifdef HAVE_SYS_LOADAVG_H
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3363 #include <sys/loadavg.h>
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3364 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3365 #else
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3366 int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3367 #endif
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3368
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3369 DEFUN ("load-average", Fload_average, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3370 Return list of 1 minute, 5 minute and 15 minute load averages.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3371 Each of the three load averages is multiplied by 100,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3372 then converted to integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3374 When USE-FLOATS is non-nil, floats will be used instead of integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3375 These floats are not multiplied by 100.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3376
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3377 If the 5-minute or 15-minute load averages are not available, return a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3378 shortened list, containing only those averages which are available.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 On some systems, this won't work due to permissions on /dev/kmem,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381 in which case you can't use this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3383 (use_floats))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3384 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3385 double load_ave[3];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3386 int loads = getloadavg (load_ave, countof (load_ave));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3387 Lisp_Object ret = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3388
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3389 if (loads == -2)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3390 signal_error (Qunimplemented,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3391 "load-average not implemented for this operating system",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3392 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3393 else if (loads < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3394 invalid_operation ("Could not get load-average", lisp_strerror (errno));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3395
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3396 while (loads-- > 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3397 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3398 Lisp_Object load = (NILP (use_floats) ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3399 make_int ((int) (100.0 * load_ave[loads]))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3400 : make_float (load_ave[loads]));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3401 ret = Fcons (load, ret);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3402 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3403 return ret;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3404 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3405
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3406
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3407 Lisp_Object Vfeatures;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3409 DEFUN ("featurep", Ffeaturep, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3410 Return non-nil if feature FEXP is present in this Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3411 Use this to conditionalize execution of lisp code based on the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3412 presence or absence of emacs or environment extensions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3413 FEXP can be a symbol, a number, or a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3414 If it is a symbol, that symbol is looked up in the `features' variable,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3415 and non-nil will be returned if found.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416 If it is a number, the function will return non-nil if this Emacs
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417 has an equal or greater version number than FEXP.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418 If it is a list whose car is the symbol `and', it will return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3419 non-nil if all the features in its cdr are non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3420 If it is a list whose car is the symbol `or', it will return non-nil
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3421 if any of the features in its cdr are non-nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 If it is a list whose car is the symbol `not', it will return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423 non-nil if the feature is not present.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 Examples:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3426
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3427 (featurep 'xemacs)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 => ; Non-nil on XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 (featurep '(and xemacs gnus))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431 => ; Non-nil on XEmacs with Gnus loaded.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 (featurep '(or tty-frames (and emacs 19.30)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3434 => ; Non-nil if this Emacs supports TTY frames.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 (featurep '(or (and xemacs 19.15) (and emacs 19.34)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3437 => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3438
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3439 (featurep '(and xemacs 21.02))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3440 => ; Non-nil on XEmacs 21.2 and later.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3441
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 NOTE: The advanced arguments of this function (anything other than a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 symbol) are not yet supported by FSF Emacs. If you feel they are useful
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 for supporting multiple Emacs variants, lobby Richard Stallman at
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3445 <bug-gnu-emacs@gnu.org>.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3449 #ifndef FEATUREP_SYNTAX
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3450 CHECK_SYMBOL (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 #else /* FEATUREP_SYNTAX */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 static double featurep_emacs_version;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 /* Brute force translation from Erik Naggum's lisp function. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 if (SYMBOLP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 /* Original definition */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 return NILP (Fmemq (fexp, Vfeatures)) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 else if (INTP (fexp) || FLOATP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 double d = extract_float (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3465 if (featurep_emacs_version == 0.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3466 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 featurep_emacs_version = XINT (Vemacs_major_version) +
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 (XINT (Vemacs_minor_version) / 100.0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 return featurep_emacs_version >= d ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 else if (CONSP (fexp))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474 Lisp_Object tem = XCAR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 if (EQ (tem, Qnot))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477 Lisp_Object negate;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3479 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480 negate = Fcar (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 if (!NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 return NILP (call1 (Qfeaturep, negate)) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 return Fsignal (Qinvalid_read_syntax, list1 (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486 else if (EQ (tem, Qand))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489 /* Use Fcar/Fcdr for error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 while (!NILP (tem) && !NILP (call1 (Qfeaturep, Fcar (tem))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 tem = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 return NILP (tem) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 else if (EQ (tem, Qor))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3498 tem = XCDR (fexp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499 /* Use Fcar/Fcdr for error-checking. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500 while (!NILP (tem) && NILP (call1 (Qfeaturep, Fcar (tem))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3501 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502 tem = Fcdr (tem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 return NILP (tem) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3506 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3507 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3508 return Fsignal (Qinvalid_read_syntax, list1 (XCDR (fexp)));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3509 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3510 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3511 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3512 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513 return Fsignal (Qinvalid_read_syntax, list1 (fexp));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3514 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3515 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3516 #endif /* FEATUREP_SYNTAX */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3517
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3518 DEFUN ("provide", Fprovide, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3519 Announce that FEATURE is a feature of the current Emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3520 This function updates the value of the variable `features'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3521 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3522 (feature))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3523 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3524 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3525 CHECK_SYMBOL (feature);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3526 if (!NILP (Vautoload_queue))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3527 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3528 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3529 if (NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3530 Vfeatures = Fcons (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3531 LOADHIST_ATTACH (Fcons (Qprovide, feature));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3532 return feature;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3533 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3534
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3535 DEFUN ("require", Frequire, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3536 If feature FEATURE is not loaded, load it from FILENAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3537 If FEATURE is not a member of the list `features', then the feature
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3538 is not loaded; so load the file FILENAME.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3539 If FILENAME is omitted, the printname of FEATURE is used as the file name.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3540 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3541 (feature, filename))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3542 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3543 Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3544 CHECK_SYMBOL (feature);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3545 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3546 LOADHIST_ATTACH (Fcons (Qrequire, feature));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3547 if (!NILP (tem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3548 return feature;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3549 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3550 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3551 int speccount = specpdl_depth ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3552
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3553 /* Value saved here is to be restored into Vautoload_queue */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3554 record_unwind_protect (un_autoload, Vautoload_queue);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3555 Vautoload_queue = Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3556
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3557 call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename,
780
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
3558 Qnil, require_prints_loading_message ? Qrequire : Qt, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3559
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3560 tem = Fmemq (feature, Vfeatures);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3561 if (NILP (tem))
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3562 invalid_state ("Required feature was not provided", feature);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3564 /* Once loading finishes, don't undo it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3565 Vautoload_queue = Qt;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
3566 return unbind_to_1 (speccount, feature);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3567 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3568 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3569
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3570 /* base64 encode/decode functions.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3571
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3572 Originally based on code from GNU recode. Ported to FSF Emacs by
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3573 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3574 subsequently heavily hacked by Hrvoje Niksic. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3575
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3576 #define MIME_LINE_LENGTH 72
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3577
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3578 #define IS_ASCII(Character) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3579 ((Character) < 128)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3580 #define IS_BASE64(Character) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3581 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3583 /* Table of characters coding the 64 values. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3584 static char base64_value_to_char[64] =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3585 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3586 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3587 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3588 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3589 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3590 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3591 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3592 '8', '9', '+', '/' /* 60-63 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3593 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3595 /* Table of base64 values for first 128 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3596 static short base64_char_to_value[128] =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3597 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3598 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3599 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3600 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3601 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3602 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3603 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3604 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3605 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3606 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3607 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3608 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3609 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3610 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3611 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3612
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3613 /* The following diagram shows the logical steps by which three octets
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3614 get transformed into four base64 characters.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3615
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3616 .--------. .--------. .--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3617 |aaaaaabb| |bbbbcccc| |ccdddddd|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3618 `--------' `--------' `--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3619 6 2 4 4 2 6
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3620 .--------+--------+--------+--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3621 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3622 `--------+--------+--------+--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3623
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3624 .--------+--------+--------+--------.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3625 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3626 `--------+--------+--------+--------'
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3627
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3628 The octets are divided into 6 bit chunks, which are then encoded into
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3629 base64 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3630
575
d5e8f5ad5043 [xemacs-hg @ 2001-05-25 04:22:31 by martinb]
martinb
parents: 563
diff changeset
3631 static DOESNT_RETURN
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3632 base64_conversion_error (const char *reason, Lisp_Object frob)
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3633 {
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3634 signal_error (Qbase64_conversion_error, reason, frob);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3635 }
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3636
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3637 #define ADVANCE_INPUT(c, stream) \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3638 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3639 ((ec > 255) ? \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3640 (base64_conversion_error ("Non-ascii character in base64 input", \
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3641 make_char (ec)), 0) \
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3642 : (c = (Intbyte)ec), 1))
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3643
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3644 static Bytebpos
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3645 base64_encode_1 (Lstream *istream, Intbyte *to, int line_break)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3646 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3647 EMACS_INT counter = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3648 Intbyte *e = to;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3649 Emchar ec;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3650 unsigned int value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3651
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3652 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3653 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3654 Intbyte c;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3655 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3656 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3657
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3658 /* Wrap line every 76 characters. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3659 if (line_break)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3660 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3661 if (counter < MIME_LINE_LENGTH / 4)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3662 counter++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3663 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3664 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3665 *e++ = '\n';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3666 counter = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3667 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3668 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3669
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3670 /* Process first byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3671 *e++ = base64_value_to_char[0x3f & c >> 2];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3672 value = (0x03 & c) << 4;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3673
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3674 /* Process second byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3675 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3676 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3677 *e++ = base64_value_to_char[value];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3678 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3679 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3680 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3681 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3682
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3683 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3684 value = (0x0f & c) << 2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3685
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3686 /* Process third byte of a triplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3687 if (!ADVANCE_INPUT (c, istream))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3688 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3689 *e++ = base64_value_to_char[value];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3690 *e++ = '=';
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3691 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3692 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3693
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3694 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3695 *e++ = base64_value_to_char[0x3f & c];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3696 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3697
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3698 return e - to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3699 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3700 #undef ADVANCE_INPUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3701
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3702 /* Get next character from the stream, except that non-base64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3703 characters are ignored. This is in accordance with rfc2045. EC
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3704 should be an Emchar, so that it can hold -1 as the value for EOF. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3705 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3706 ec = Lstream_get_emchar (stream); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3707 ++streampos; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3708 /* IS_BASE64 may not be called with negative arguments so check for \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3709 EOF first. */ \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3710 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3711 break; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3712 } while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3713
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3714 #define STORE_BYTE(pos, val, ccnt) do { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3715 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3716 ++ccnt; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3717 } while (0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3718
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3719 static Bytebpos
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3720 base64_decode_1 (Lstream *istream, Intbyte *to, Charcount *ccptr)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3721 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3722 Charcount ccnt = 0;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3723 Intbyte *e = to;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3724 EMACS_INT streampos = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3725
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3726 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3727 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3728 Emchar ec;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3729 unsigned long value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3730
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3731 /* Process first byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3732 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3733 if (ec < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3734 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3735 if (ec == '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3736 base64_conversion_error ("Illegal `=' character while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3737 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3738 value = base64_char_to_value[ec] << 18;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3739
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3740 /* Process second byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3741 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3742 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3743 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3744 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3745 if (ec == '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3746 base64_conversion_error ("Illegal `=' character while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3747 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3748 value |= base64_char_to_value[ec] << 12;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3749 STORE_BYTE (e, value >> 16, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3750
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3751 /* Process third byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3752 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3753 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3754 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3755 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3756
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3757 if (ec == '=')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3758 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3759 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3760 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3761 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3762 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3763 if (ec != '=')
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3764 base64_conversion_error
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3765 ("Padding `=' expected but not found while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3766 make_int (streampos));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3767 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3768 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3769
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3770 value |= base64_char_to_value[ec] << 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3771 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3772
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3773 /* Process fourth byte of a quadruplet. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3774 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3775 if (ec < 0)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3776 base64_conversion_error ("Premature EOF while decoding base64",
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3777 Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3778 if (ec == '=')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3779 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3780
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3781 value |= base64_char_to_value[ec];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3782 STORE_BYTE (e, 0xff & value, ccnt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3783 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3784
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3785 *ccptr = ccnt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3786 return e - to;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3787 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3788 #undef ADVANCE_INPUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3789 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3790 #undef STORE_BYTE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3792 DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3793 Base64-encode the region between START and END.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3794 Return the length of the encoded text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3795 Optional third argument NO-LINE-BREAK means do not break long lines
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3796 into shorter lines.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3797 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3798 (start, end, no_line_break))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3799 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3800 Intbyte *encoded;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3801 Bytebpos encoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3802 Charcount allength, length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3803 struct buffer *buf = current_buffer;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3804 Charbpos begv, zv, old_pt = BUF_PT (buf);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3805 Lisp_Object input;
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3806 int speccount = specpdl_depth ();
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3807
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3808 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3809 barf_if_buffer_read_only (buf, begv, zv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3810
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3811 /* We need to allocate enough room for encoding the text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3812 We need 33 1/3% more space, plus a newline every 76
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3813 characters, and then we round up. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3814 length = zv - begv;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3815 allength = length + length/3 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3816 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3817
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3818 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3819 /* We needn't multiply allength with MAX_EMCHAR_LEN because all the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3820 base64 characters will be single-byte. */
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3821 encoded = (Intbyte *) MALLOC_OR_ALLOCA (allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3822 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3823 NILP (no_line_break));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3824 if (encoded_length > allength)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3825 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3826 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3827
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3828 /* Now we have encoded the region, so we insert the new contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3829 and delete the old. (Insert first in order to preserve markers.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3830 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3831 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3832 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3833
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3834 /* Simulate FSF Emacs implementation of this function: if point was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3835 in the region, place it at the beginning. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3836 if (old_pt >= begv && old_pt < zv)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3837 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3838
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3839 /* We return the length of the encoded text. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3840 return make_int (encoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3841 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3842
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3843 DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3844 Base64 encode STRING and return the result.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3845 Optional argument NO-LINE-BREAK means do not break long lines
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3846 into shorter lines.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3847 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3848 (string, no_line_break))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3849 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3850 Charcount allength, length;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3851 Bytebpos encoded_length;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3852 Intbyte *encoded;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3853 Lisp_Object input, result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3854 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3855
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3856 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3857
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3858 length = string_char_length (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3859 allength = length + length/3 + 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3860 allength += allength / MIME_LINE_LENGTH + 1 + 6;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3861
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3862 input = make_lisp_string_input_stream (string, 0, -1);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3863 encoded = (Intbyte *) MALLOC_OR_ALLOCA (allength);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3864 encoded_length = base64_encode_1 (XLSTREAM (input), encoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3865 NILP (no_line_break));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3866 if (encoded_length > allength)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3867 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3868 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3869 result = make_string (encoded, encoded_length);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3870 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3871 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3872 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3873
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3874 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3875 Base64-decode the region between START and END.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3876 Return the length of the decoded text.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3877 If the region can't be decoded, return nil and don't modify the buffer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3878 Characters out of the base64 alphabet are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3879 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3880 (start, end))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3881 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3882 struct buffer *buf = current_buffer;
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3883 Charbpos begv, zv, old_pt = BUF_PT (buf);
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3884 Intbyte *decoded;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3885 Bytebpos decoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3886 Charcount length, cc_decoded_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3887 Lisp_Object input;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3888 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3889
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
3890 get_buffer_range_char (buf, start, end, &begv, &zv, 0);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3891 barf_if_buffer_read_only (buf, begv, zv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3892
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3893 length = zv - begv;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3894
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3895 input = make_lisp_buffer_input_stream (buf, begv, zv, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3896 /* We need to allocate enough room for decoding the text. */
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3897 decoded = (Intbyte *) MALLOC_OR_ALLOCA (length * MAX_EMCHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3898 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3899 if (decoded_length > length * MAX_EMCHAR_LEN)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3900 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3901 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3902
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3903 /* Now we have decoded the region, so we insert the new contents
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3904 and delete the old. (Insert first in order to preserve markers.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3905 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3906 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3907 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3908 buffer_delete_range (buf, begv + cc_decoded_length,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3909 zv + cc_decoded_length, 0);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3910
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3911 /* Simulate FSF Emacs implementation of this function: if point was
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3912 in the region, place it at the beginning. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3913 if (old_pt >= begv && old_pt < zv)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3914 BUF_SET_PT (buf, begv);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3915
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3916 return make_int (cc_decoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3917 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3918
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3919 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3920 Base64-decode STRING and return the result.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3921 Characters out of the base64 alphabet are ignored.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3922 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3923 (string))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3924 {
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3925 Intbyte *decoded;
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
3926 Bytebpos decoded_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3927 Charcount length, cc_decoded_length;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3928 Lisp_Object input, result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3929 int speccount = specpdl_depth();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3930
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3931 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3932
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 814
diff changeset
3933 length = string_char_length (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3934 /* We need to allocate enough room for decoding the text. */
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3935 decoded = (Intbyte *) MALLOC_OR_ALLOCA (length * MAX_EMCHAR_LEN);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3936
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3937 input = make_lisp_string_input_stream (string, 0, -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3938 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3939 &cc_decoded_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3940 if (decoded_length > length * MAX_EMCHAR_LEN)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3941 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3942 Lstream_delete (XLSTREAM (input));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3943
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3944 result = make_string (decoded, decoded_length);
851
e7ee5f8bde58 [xemacs-hg @ 2002-05-23 11:46:08 by ben]
ben
parents: 826
diff changeset
3945 unbind_to (speccount);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3946 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3947 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3948
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3949 Lisp_Object Qyes_or_no_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3950
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3951 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3952 syms_of_fns (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3953 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3954 INIT_LRECORD_IMPLEMENTATION (bit_vector);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3955
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3956 DEFSYMBOL (Qstring_lessp);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3957 DEFSYMBOL (Qidentity);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3958 DEFSYMBOL (Qyes_or_no_p);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3959
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 456
diff changeset
3960 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3961
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3962 DEFSUBR (Fidentity);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3963 DEFSUBR (Frandom);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3964 DEFSUBR (Flength);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3965 DEFSUBR (Fsafe_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3966 DEFSUBR (Fstring_equal);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 793
diff changeset
3967 DEFSUBR (Fcompare_strings);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3968 DEFSUBR (Fstring_lessp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3969 DEFSUBR (Fstring_modified_tick);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3970 DEFSUBR (Fappend);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3971 DEFSUBR (Fconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3972 DEFSUBR (Fvconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3973 DEFSUBR (Fbvconcat);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3974 DEFSUBR (Fcopy_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3975 DEFSUBR (Fcopy_sequence);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3976 DEFSUBR (Fcopy_alist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3977 DEFSUBR (Fcopy_tree);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3978 DEFSUBR (Fsubstring);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3979 DEFSUBR (Fsubseq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3980 DEFSUBR (Fnthcdr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3981 DEFSUBR (Fnth);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3982 DEFSUBR (Felt);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3983 DEFSUBR (Flast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3984 DEFSUBR (Fbutlast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3985 DEFSUBR (Fnbutlast);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3986 DEFSUBR (Fmember);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3987 DEFSUBR (Fold_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3988 DEFSUBR (Fmemq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3989 DEFSUBR (Fold_memq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3990 DEFSUBR (Fassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3991 DEFSUBR (Fold_assoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3992 DEFSUBR (Fassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3993 DEFSUBR (Fold_assq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3994 DEFSUBR (Frassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3995 DEFSUBR (Fold_rassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3996 DEFSUBR (Frassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3997 DEFSUBR (Fold_rassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3998 DEFSUBR (Fdelete);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3999 DEFSUBR (Fold_delete);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4000 DEFSUBR (Fdelq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4001 DEFSUBR (Fold_delq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4002 DEFSUBR (Fremassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4003 DEFSUBR (Fremassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4004 DEFSUBR (Fremrassoc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4005 DEFSUBR (Fremrassq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4006 DEFSUBR (Fnreverse);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4007 DEFSUBR (Freverse);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4008 DEFSUBR (Fsort);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4009 DEFSUBR (Fplists_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4010 DEFSUBR (Fplists_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4011 DEFSUBR (Flax_plists_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4012 DEFSUBR (Flax_plists_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4013 DEFSUBR (Fplist_get);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4014 DEFSUBR (Fplist_put);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4015 DEFSUBR (Fplist_remprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4016 DEFSUBR (Fplist_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4017 DEFSUBR (Fcheck_valid_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4018 DEFSUBR (Fvalid_plist_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4019 DEFSUBR (Fcanonicalize_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4020 DEFSUBR (Flax_plist_get);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4021 DEFSUBR (Flax_plist_put);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4022 DEFSUBR (Flax_plist_remprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4023 DEFSUBR (Flax_plist_member);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4024 DEFSUBR (Fcanonicalize_lax_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4025 DEFSUBR (Fdestructive_alist_to_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4026 DEFSUBR (Fget);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4027 DEFSUBR (Fput);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4028 DEFSUBR (Fremprop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4029 DEFSUBR (Fobject_plist);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4030 DEFSUBR (Fequal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4031 DEFSUBR (Fold_equal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4032 DEFSUBR (Ffillarray);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4033 DEFSUBR (Fnconc);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4034 DEFSUBR (Fmapcar);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4035 DEFSUBR (Fmapvector);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4036 DEFSUBR (Fmapc_internal);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4037 DEFSUBR (Fmapconcat);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
4038 DEFSUBR (Freplace_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4039 DEFSUBR (Fload_average);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4040 DEFSUBR (Ffeaturep);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4041 DEFSUBR (Frequire);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4042 DEFSUBR (Fprovide);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4043 DEFSUBR (Fbase64_encode_region);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4044 DEFSUBR (Fbase64_encode_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4045 DEFSUBR (Fbase64_decode_region);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4046 DEFSUBR (Fbase64_decode_string);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4047
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4048 DEFSUBR (Fsplit_string_by_char);
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4049 DEFSUBR (Fsplit_path); /* #### */
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4050 }
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4051
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4052 void
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4053 vars_of_fns (void)
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4054 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4055 DEFVAR_LISP ("path-separator", &Vpath_separator /*
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4056 The directory separator in search paths, as a string.
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4057 */ );
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4058 {
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4059 char c = SEPCHAR;
780
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
4060 Vpath_separator = make_string ((Intbyte *) &c, 1);
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 751
diff changeset
4061 }
780
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
4062
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
4063 DEFVAR_BOOL ("require-prints-loading-message",
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
4064 &require_prints_loading_message /*
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
4065 If non-nil, every time a file is loaded by `require' a message is printed.
578cb2932d72 [xemacs-hg @ 2002-03-18 10:07:30 by ben]
ben
parents: 771
diff changeset
4066 */ );
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4067 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4068
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4069 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4070 init_provide_once (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4071 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4072 DEFVAR_LISP ("features", &Vfeatures /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4073 A list of symbols which are the features of the executing emacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4074 Used by `featurep' and `require', and altered by `provide'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4075 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4076 Vfeatures = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4077
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4078 Fprovide (intern ("base64"));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
4079 }