* frame.c (x_set_frame_parameters): Don't read uninitialized storage.
[bpt/emacs.git] / src / data.c
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2014 Free Software
3 Foundation, Inc.
4
5 This file is part of GNU Emacs.
6
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
19
20
21 #include <config.h>
22 #include <stdio.h>
23
24 #include <byteswap.h>
25 #include <count-one-bits.h>
26 #include <count-trailing-zeros.h>
27 #include <intprops.h>
28
29 #include "lisp.h"
30 #include "puresize.h"
31 #include "character.h"
32 #include "buffer.h"
33 #include "keyboard.h"
34 #include "frame.h"
35 #include "syssignal.h"
36 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
37 #include "font.h"
38 #include "keymap.h"
39
40 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
41 static Lisp_Object Qsubr;
42 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
43 Lisp_Object Qerror, Quser_error, Qquit, Qargs_out_of_range;
44 static Lisp_Object Qwrong_length_argument;
45 static Lisp_Object Qwrong_type_argument;
46 Lisp_Object Qvoid_variable, Qvoid_function;
47 static Lisp_Object Qcyclic_function_indirection;
48 static Lisp_Object Qcyclic_variable_indirection;
49 Lisp_Object Qcircular_list;
50 static Lisp_Object Qsetting_constant;
51 Lisp_Object Qinvalid_read_syntax;
52 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
53 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
54 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
55 Lisp_Object Qtext_read_only;
56
57 Lisp_Object Qintegerp, Qwholenump, Qsymbolp, Qlistp, Qconsp;
58 static Lisp_Object Qnatnump;
59 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
60 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
61 Lisp_Object Qbool_vector_p;
62 Lisp_Object Qbuffer_or_string_p;
63 static Lisp_Object Qkeywordp, Qboundp;
64 Lisp_Object Qfboundp;
65 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
66
67 Lisp_Object Qcdr;
68 static Lisp_Object Qad_advice_info, Qad_activate_internal;
69
70 static Lisp_Object Qdomain_error, Qsingularity_error, Qunderflow_error;
71 Lisp_Object Qrange_error, Qoverflow_error;
72
73 Lisp_Object Qfloatp;
74 Lisp_Object Qnumberp, Qnumber_or_marker_p;
75
76 Lisp_Object Qinteger, Qsymbol;
77 static Lisp_Object Qcons, Qfloat, Qmisc, Qstring, Qvector;
78 Lisp_Object Qwindow;
79 static Lisp_Object Qoverlay, Qwindow_configuration;
80 static Lisp_Object Qprocess, Qmarker;
81 static Lisp_Object Qcompiled_function, Qframe;
82 Lisp_Object Qbuffer;
83 static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
84 static Lisp_Object Qsubrp;
85 static Lisp_Object Qmany, Qunevalled;
86 Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
87 static Lisp_Object Qdefun;
88
89 Lisp_Object Qinteractive_form;
90 static Lisp_Object Qdefalias_fset_function;
91
92 static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
93
94 static bool
95 BOOLFWDP (union Lisp_Fwd *a)
96 {
97 return XFWDTYPE (a) == Lisp_Fwd_Bool;
98 }
99 static bool
100 INTFWDP (union Lisp_Fwd *a)
101 {
102 return XFWDTYPE (a) == Lisp_Fwd_Int;
103 }
104 static bool
105 KBOARD_OBJFWDP (union Lisp_Fwd *a)
106 {
107 return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj;
108 }
109 static bool
110 OBJFWDP (union Lisp_Fwd *a)
111 {
112 return XFWDTYPE (a) == Lisp_Fwd_Obj;
113 }
114
115 static struct Lisp_Boolfwd *
116 XBOOLFWD (union Lisp_Fwd *a)
117 {
118 eassert (BOOLFWDP (a));
119 return &a->u_boolfwd;
120 }
121 static struct Lisp_Kboard_Objfwd *
122 XKBOARD_OBJFWD (union Lisp_Fwd *a)
123 {
124 eassert (KBOARD_OBJFWDP (a));
125 return &a->u_kboard_objfwd;
126 }
127 static struct Lisp_Intfwd *
128 XINTFWD (union Lisp_Fwd *a)
129 {
130 eassert (INTFWDP (a));
131 return &a->u_intfwd;
132 }
133 static struct Lisp_Objfwd *
134 XOBJFWD (union Lisp_Fwd *a)
135 {
136 eassert (OBJFWDP (a));
137 return &a->u_objfwd;
138 }
139
140 static void
141 CHECK_SUBR (Lisp_Object x)
142 {
143 CHECK_TYPE (SUBRP (x), Qsubrp, x);
144 }
145
146 static void
147 set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
148 {
149 eassert (found == !EQ (blv->defcell, blv->valcell));
150 blv->found = found;
151 }
152
153 static Lisp_Object
154 blv_value (struct Lisp_Buffer_Local_Value *blv)
155 {
156 return XCDR (blv->valcell);
157 }
158
159 static void
160 set_blv_value (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
161 {
162 XSETCDR (blv->valcell, val);
163 }
164
165 static void
166 set_blv_where (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
167 {
168 blv->where = val;
169 }
170
171 static void
172 set_blv_defcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
173 {
174 blv->defcell = val;
175 }
176
177 static void
178 set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
179 {
180 blv->valcell = val;
181 }
182
183 static _Noreturn void
184 wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
185 {
186 Lisp_Object size1 = make_number (bool_vector_size (a1));
187 Lisp_Object size2 = make_number (bool_vector_size (a2));
188 if (NILP (a3))
189 xsignal2 (Qwrong_length_argument, size1, size2);
190 else
191 xsignal3 (Qwrong_length_argument, size1, size2,
192 make_number (bool_vector_size (a3)));
193 }
194
195 Lisp_Object
196 wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
197 {
198 /* If VALUE is not even a valid Lisp object, we'd want to abort here
199 where we can get a backtrace showing where it came from. We used
200 to try and do that by checking the tagbits, but nowadays all
201 tagbits are potentially valid. */
202 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
203 * emacs_abort (); */
204
205 xsignal2 (Qwrong_type_argument, predicate, value);
206 }
207
208 void
209 pure_write_error (Lisp_Object obj)
210 {
211 xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
212 }
213
214 void
215 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
216 {
217 xsignal2 (Qargs_out_of_range, a1, a2);
218 }
219
220 void
221 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
222 {
223 xsignal3 (Qargs_out_of_range, a1, a2, a3);
224 }
225
226 \f
227 /* Data type predicates. */
228
229 DEFUN ("eq", Feq, Seq, 2, 2, 0,
230 doc: /* Return t if the two args are the same Lisp object. */)
231 (Lisp_Object obj1, Lisp_Object obj2)
232 {
233 if (EQ (obj1, obj2))
234 return Qt;
235 return Qnil;
236 }
237
238 DEFUN ("null", Fnull, Snull, 1, 1, 0,
239 doc: /* Return t if OBJECT is nil. */)
240 (Lisp_Object object)
241 {
242 if (NILP (object))
243 return Qt;
244 return Qnil;
245 }
246
247 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
248 doc: /* Return a symbol representing the type of OBJECT.
249 The symbol returned names the object's basic type;
250 for example, (type-of 1) returns `integer'. */)
251 (Lisp_Object object)
252 {
253 switch (XTYPE (object))
254 {
255 case_Lisp_Int:
256 return Qinteger;
257
258 case Lisp_Symbol:
259 return Qsymbol;
260
261 case Lisp_String:
262 return Qstring;
263
264 case Lisp_Cons:
265 return Qcons;
266
267 case Lisp_Misc:
268 switch (XMISCTYPE (object))
269 {
270 case Lisp_Misc_Marker:
271 return Qmarker;
272 case Lisp_Misc_Overlay:
273 return Qoverlay;
274 case Lisp_Misc_Float:
275 return Qfloat;
276 }
277 emacs_abort ();
278
279 case Lisp_Vectorlike:
280 if (WINDOW_CONFIGURATIONP (object))
281 return Qwindow_configuration;
282 if (PROCESSP (object))
283 return Qprocess;
284 if (WINDOWP (object))
285 return Qwindow;
286 if (SUBRP (object))
287 return Qsubr;
288 if (COMPILEDP (object))
289 return Qcompiled_function;
290 if (BUFFERP (object))
291 return Qbuffer;
292 if (CHAR_TABLE_P (object))
293 return Qchar_table;
294 if (BOOL_VECTOR_P (object))
295 return Qbool_vector;
296 if (FRAMEP (object))
297 return Qframe;
298 if (HASH_TABLE_P (object))
299 return Qhash_table;
300 if (FONT_SPEC_P (object))
301 return Qfont_spec;
302 if (FONT_ENTITY_P (object))
303 return Qfont_entity;
304 if (FONT_OBJECT_P (object))
305 return Qfont_object;
306 return Qvector;
307
308 case Lisp_Float:
309 return Qfloat;
310
311 default:
312 emacs_abort ();
313 }
314 }
315
316 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
317 doc: /* Return t if OBJECT is a cons cell. */)
318 (Lisp_Object object)
319 {
320 if (CONSP (object))
321 return Qt;
322 return Qnil;
323 }
324
325 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
326 doc: /* Return t if OBJECT is not a cons cell. This includes nil. */)
327 (Lisp_Object object)
328 {
329 if (CONSP (object))
330 return Qnil;
331 return Qt;
332 }
333
334 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
335 doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
336 Otherwise, return nil. */)
337 (Lisp_Object object)
338 {
339 if (CONSP (object) || NILP (object))
340 return Qt;
341 return Qnil;
342 }
343
344 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
345 doc: /* Return t if OBJECT is not a list. Lists include nil. */)
346 (Lisp_Object object)
347 {
348 if (CONSP (object) || NILP (object))
349 return Qnil;
350 return Qt;
351 }
352 \f
353 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
354 doc: /* Return t if OBJECT is a symbol. */)
355 (Lisp_Object object)
356 {
357 if (SYMBOLP (object))
358 return Qt;
359 return Qnil;
360 }
361
362 /* Define this in C to avoid unnecessarily consing up the symbol
363 name. */
364 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
365 doc: /* Return t if OBJECT is a keyword.
366 This means that it is a symbol with a print name beginning with `:'
367 interned in the initial obarray. */)
368 (Lisp_Object object)
369 {
370 if (SYMBOLP (object)
371 && SREF (SYMBOL_NAME (object), 0) == ':'
372 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
373 return Qt;
374 return Qnil;
375 }
376
377 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
378 doc: /* Return t if OBJECT is a vector. */)
379 (Lisp_Object object)
380 {
381 if (VECTORP (object))
382 return Qt;
383 return Qnil;
384 }
385
386 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
387 doc: /* Return t if OBJECT is a string. */)
388 (Lisp_Object object)
389 {
390 if (STRINGP (object))
391 return Qt;
392 return Qnil;
393 }
394
395 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
396 1, 1, 0,
397 doc: /* Return t if OBJECT is a multibyte string.
398 Return nil if OBJECT is either a unibyte string, or not a string. */)
399 (Lisp_Object object)
400 {
401 if (STRINGP (object) && STRING_MULTIBYTE (object))
402 return Qt;
403 return Qnil;
404 }
405
406 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
407 doc: /* Return t if OBJECT is a char-table. */)
408 (Lisp_Object object)
409 {
410 if (CHAR_TABLE_P (object))
411 return Qt;
412 return Qnil;
413 }
414
415 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
416 Svector_or_char_table_p, 1, 1, 0,
417 doc: /* Return t if OBJECT is a char-table or vector. */)
418 (Lisp_Object object)
419 {
420 if (VECTORP (object) || CHAR_TABLE_P (object))
421 return Qt;
422 return Qnil;
423 }
424
425 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
426 doc: /* Return t if OBJECT is a bool-vector. */)
427 (Lisp_Object object)
428 {
429 if (BOOL_VECTOR_P (object))
430 return Qt;
431 return Qnil;
432 }
433
434 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
435 doc: /* Return t if OBJECT is an array (string or vector). */)
436 (Lisp_Object object)
437 {
438 if (ARRAYP (object))
439 return Qt;
440 return Qnil;
441 }
442
443 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
444 doc: /* Return t if OBJECT is a sequence (list or array). */)
445 (register Lisp_Object object)
446 {
447 if (CONSP (object) || NILP (object) || ARRAYP (object))
448 return Qt;
449 return Qnil;
450 }
451
452 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
453 doc: /* Return t if OBJECT is an editor buffer. */)
454 (Lisp_Object object)
455 {
456 if (BUFFERP (object))
457 return Qt;
458 return Qnil;
459 }
460
461 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
462 doc: /* Return t if OBJECT is a marker (editor pointer). */)
463 (Lisp_Object object)
464 {
465 if (MARKERP (object))
466 return Qt;
467 return Qnil;
468 }
469
470 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
471 doc: /* Return t if OBJECT is a built-in function. */)
472 (Lisp_Object object)
473 {
474 if (SUBRP (object))
475 return Qt;
476 return Qnil;
477 }
478
479 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
480 1, 1, 0,
481 doc: /* Return t if OBJECT is a byte-compiled function object. */)
482 (Lisp_Object object)
483 {
484 if (COMPILEDP (object))
485 return Qt;
486 return Qnil;
487 }
488
489 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
490 doc: /* Return t if OBJECT is a character or a string. */)
491 (register Lisp_Object object)
492 {
493 if (CHARACTERP (object) || STRINGP (object))
494 return Qt;
495 return Qnil;
496 }
497 \f
498 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
499 doc: /* Return t if OBJECT is an integer. */)
500 (Lisp_Object object)
501 {
502 if (INTEGERP (object))
503 return Qt;
504 return Qnil;
505 }
506
507 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
508 doc: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
509 (register Lisp_Object object)
510 {
511 if (MARKERP (object) || INTEGERP (object))
512 return Qt;
513 return Qnil;
514 }
515
516 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
517 doc: /* Return t if OBJECT is a nonnegative integer. */)
518 (Lisp_Object object)
519 {
520 if (NATNUMP (object))
521 return Qt;
522 return Qnil;
523 }
524
525 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
526 doc: /* Return t if OBJECT is a number (floating point or integer). */)
527 (Lisp_Object object)
528 {
529 if (NUMBERP (object))
530 return Qt;
531 else
532 return Qnil;
533 }
534
535 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
536 Snumber_or_marker_p, 1, 1, 0,
537 doc: /* Return t if OBJECT is a number or a marker. */)
538 (Lisp_Object object)
539 {
540 if (NUMBERP (object) || MARKERP (object))
541 return Qt;
542 return Qnil;
543 }
544
545 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
546 doc: /* Return t if OBJECT is a floating point number. */)
547 (Lisp_Object object)
548 {
549 if (FLOATP (object))
550 return Qt;
551 return Qnil;
552 }
553
554 \f
555 /* Extract and set components of lists. */
556
557 DEFUN ("car", Fcar, Scar, 1, 1, 0,
558 doc: /* Return the car of LIST. If arg is nil, return nil.
559 Error if arg is not nil and not a cons cell. See also `car-safe'.
560
561 See Info node `(elisp)Cons Cells' for a discussion of related basic
562 Lisp concepts such as car, cdr, cons cell and list. */)
563 (register Lisp_Object list)
564 {
565 return CAR (list);
566 }
567
568 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
569 doc: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
570 (Lisp_Object object)
571 {
572 return CAR_SAFE (object);
573 }
574
575 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
576 doc: /* Return the cdr of LIST. If arg is nil, return nil.
577 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
578
579 See Info node `(elisp)Cons Cells' for a discussion of related basic
580 Lisp concepts such as cdr, car, cons cell and list. */)
581 (register Lisp_Object list)
582 {
583 return CDR (list);
584 }
585
586 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
587 doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
588 (Lisp_Object object)
589 {
590 return CDR_SAFE (object);
591 }
592
593 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
594 doc: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
595 (register Lisp_Object cell, Lisp_Object newcar)
596 {
597 CHECK_CONS (cell);
598 CHECK_IMPURE (cell);
599 XSETCAR (cell, newcar);
600 return newcar;
601 }
602
603 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
604 doc: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
605 (register Lisp_Object cell, Lisp_Object newcdr)
606 {
607 CHECK_CONS (cell);
608 CHECK_IMPURE (cell);
609 XSETCDR (cell, newcdr);
610 return newcdr;
611 }
612 \f
613 /* Extract and set components of symbols. */
614
615 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
616 doc: /* Return t if SYMBOL's value is not void.
617 Note that if `lexical-binding' is in effect, this refers to the
618 global value outside of any lexical scope. */)
619 (register Lisp_Object symbol)
620 {
621 Lisp_Object valcontents;
622 struct Lisp_Symbol *sym;
623 CHECK_SYMBOL (symbol);
624 sym = XSYMBOL (symbol);
625
626 start:
627 switch (sym->redirect)
628 {
629 case SYMBOL_PLAINVAL: valcontents = SYMBOL_VAL (sym); break;
630 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
631 case SYMBOL_LOCALIZED:
632 {
633 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
634 if (blv->fwd)
635 /* In set_internal, we un-forward vars when their value is
636 set to Qunbound. */
637 return Qt;
638 else
639 {
640 swap_in_symval_forwarding (sym, blv);
641 valcontents = blv_value (blv);
642 }
643 break;
644 }
645 case SYMBOL_FORWARDED:
646 /* In set_internal, we un-forward vars when their value is
647 set to Qunbound. */
648 return Qt;
649 default: emacs_abort ();
650 }
651
652 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
653 }
654
655 /* FIXME: Make it an alias for function-symbol! */
656 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
657 doc: /* Return t if SYMBOL's function definition is not void. */)
658 (register Lisp_Object symbol)
659 {
660 CHECK_SYMBOL (symbol);
661 return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt;
662 }
663
664 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
665 doc: /* Make SYMBOL's value be void.
666 Return SYMBOL. */)
667 (register Lisp_Object symbol)
668 {
669 CHECK_SYMBOL (symbol);
670 if (SYMBOL_CONSTANT_P (symbol))
671 xsignal1 (Qsetting_constant, symbol);
672 Fset (symbol, Qunbound);
673 return symbol;
674 }
675
676 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
677 doc: /* Make SYMBOL's function definition be nil.
678 Return SYMBOL. */)
679 (register Lisp_Object symbol)
680 {
681 CHECK_SYMBOL (symbol);
682 if (NILP (symbol) || EQ (symbol, Qt))
683 xsignal1 (Qsetting_constant, symbol);
684 set_symbol_function (symbol, Qnil);
685 return symbol;
686 }
687
688 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
689 doc: /* Return SYMBOL's function definition, or nil if that is void. */)
690 (register Lisp_Object symbol)
691 {
692 CHECK_SYMBOL (symbol);
693 return XSYMBOL (symbol)->function;
694 }
695
696 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
697 doc: /* Return SYMBOL's property list. */)
698 (register Lisp_Object symbol)
699 {
700 CHECK_SYMBOL (symbol);
701 return XSYMBOL (symbol)->plist;
702 }
703
704 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
705 doc: /* Return SYMBOL's name, a string. */)
706 (register Lisp_Object symbol)
707 {
708 register Lisp_Object name;
709
710 CHECK_SYMBOL (symbol);
711 name = SYMBOL_NAME (symbol);
712 return name;
713 }
714
715 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
716 doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
717 (register Lisp_Object symbol, Lisp_Object definition)
718 {
719 register Lisp_Object function;
720 CHECK_SYMBOL (symbol);
721
722 function = XSYMBOL (symbol)->function;
723
724 if (!NILP (Vautoload_queue) && !NILP (function))
725 Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);
726
727 if (AUTOLOADP (function))
728 Fput (symbol, Qautoload, XCDR (function));
729
730 set_symbol_function (symbol, definition);
731
732 return definition;
733 }
734
735 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
736 doc: /* Set SYMBOL's function definition to DEFINITION.
737 Associates the function with the current load file, if any.
738 The optional third argument DOCSTRING specifies the documentation string
739 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
740 determined by DEFINITION.
741
742 Internally, this normally uses `fset', but if SYMBOL has a
743 `defalias-fset-function' property, the associated value is used instead.
744
745 The return value is undefined. */)
746 (register Lisp_Object symbol, Lisp_Object definition, Lisp_Object docstring)
747 {
748 CHECK_SYMBOL (symbol);
749 if (!NILP (Vpurify_flag)
750 /* If `definition' is a keymap, immutable (and copying) is wrong. */
751 && !KEYMAPP (definition))
752 definition = Fpurecopy (definition);
753
754 {
755 bool autoload = AUTOLOADP (definition);
756 if (NILP (Vpurify_flag) || !autoload)
757 { /* Only add autoload entries after dumping, because the ones before are
758 not useful and else we get loads of them from the loaddefs.el. */
759
760 if (AUTOLOADP (XSYMBOL (symbol)->function))
761 /* Remember that the function was already an autoload. */
762 LOADHIST_ATTACH (Fcons (Qt, symbol));
763 LOADHIST_ATTACH (Fcons (autoload ? Qautoload : Qdefun, symbol));
764 }
765 }
766
767 { /* Handle automatic advice activation. */
768 Lisp_Object hook = Fget (symbol, Qdefalias_fset_function);
769 if (!NILP (hook))
770 call2 (hook, symbol, definition);
771 else
772 Ffset (symbol, definition);
773 }
774
775 if (!NILP (docstring))
776 Fput (symbol, Qfunction_documentation, docstring);
777 /* We used to return `definition', but now that `defun' and `defmacro' expand
778 to a call to `defalias', we return `symbol' for backward compatibility
779 (bug#11686). */
780 return symbol;
781 }
782
783 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
784 doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
785 (register Lisp_Object symbol, Lisp_Object newplist)
786 {
787 CHECK_SYMBOL (symbol);
788 set_symbol_plist (symbol, newplist);
789 return newplist;
790 }
791
792 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
793 doc: /* Return minimum and maximum number of args allowed for SUBR.
794 SUBR must be a built-in function.
795 The returned value is a pair (MIN . MAX). MIN is the minimum number
796 of args. MAX is the maximum number or the symbol `many', for a
797 function with `&rest' args, or `unevalled' for a special form. */)
798 (Lisp_Object subr)
799 {
800 short minargs, maxargs;
801 CHECK_SUBR (subr);
802 minargs = XSUBR (subr)->min_args;
803 maxargs = XSUBR (subr)->max_args;
804 return Fcons (make_number (minargs),
805 maxargs == MANY ? Qmany
806 : maxargs == UNEVALLED ? Qunevalled
807 : make_number (maxargs));
808 }
809
810 DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
811 doc: /* Return name of subroutine SUBR.
812 SUBR must be a built-in function. */)
813 (Lisp_Object subr)
814 {
815 const char *name;
816 CHECK_SUBR (subr);
817 name = XSUBR (subr)->symbol_name;
818 return build_string (name);
819 }
820
821 DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
822 doc: /* Return the interactive form of CMD or nil if none.
823 If CMD is not a command, the return value is nil.
824 Value, if non-nil, is a list \(interactive SPEC). */)
825 (Lisp_Object cmd)
826 {
827 Lisp_Object fun = indirect_function (cmd); /* Check cycles. */
828
829 if (NILP (fun))
830 return Qnil;
831
832 /* Use an `interactive-form' property if present, analogous to the
833 function-documentation property. */
834 fun = cmd;
835 while (SYMBOLP (fun))
836 {
837 Lisp_Object tmp = Fget (fun, Qinteractive_form);
838 if (!NILP (tmp))
839 return tmp;
840 else
841 fun = Fsymbol_function (fun);
842 }
843
844 if (SUBRP (fun))
845 {
846 const char *spec = XSUBR (fun)->intspec;
847 if (spec)
848 return list2 (Qinteractive,
849 (*spec != '(') ? build_string (spec) :
850 Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
851 }
852 else if (COMPILEDP (fun))
853 {
854 if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
855 return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
856 }
857 else if (AUTOLOADP (fun))
858 return Finteractive_form (Fautoload_do_load (fun, cmd, Qnil));
859 else if (CONSP (fun))
860 {
861 Lisp_Object funcar = XCAR (fun);
862 if (EQ (funcar, Qclosure))
863 return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))));
864 else if (EQ (funcar, Qlambda))
865 return Fassq (Qinteractive, Fcdr (XCDR (fun)));
866 }
867 return Qnil;
868 }
869
870 \f
871 /***********************************************************************
872 Getting and Setting Values of Symbols
873 ***********************************************************************/
874
875 /* Return the symbol holding SYMBOL's value. Signal
876 `cyclic-variable-indirection' if SYMBOL's chain of variable
877 indirections contains a loop. */
878
879 struct Lisp_Symbol *
880 indirect_variable (struct Lisp_Symbol *symbol)
881 {
882 struct Lisp_Symbol *tortoise, *hare;
883
884 hare = tortoise = symbol;
885
886 while (hare->redirect == SYMBOL_VARALIAS)
887 {
888 hare = SYMBOL_ALIAS (hare);
889 if (hare->redirect != SYMBOL_VARALIAS)
890 break;
891
892 hare = SYMBOL_ALIAS (hare);
893 tortoise = SYMBOL_ALIAS (tortoise);
894
895 if (hare == tortoise)
896 {
897 Lisp_Object tem;
898 XSETSYMBOL (tem, symbol);
899 xsignal1 (Qcyclic_variable_indirection, tem);
900 }
901 }
902
903 return hare;
904 }
905
906
907 DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
908 doc: /* Return the variable at the end of OBJECT's variable chain.
909 If OBJECT is a symbol, follow its variable indirections (if any), and
910 return the variable at the end of the chain of aliases. See Info node
911 `(elisp)Variable Aliases'.
912
913 If OBJECT is not a symbol, just return it. If there is a loop in the
914 chain of aliases, signal a `cyclic-variable-indirection' error. */)
915 (Lisp_Object object)
916 {
917 if (SYMBOLP (object))
918 {
919 struct Lisp_Symbol *sym = indirect_variable (XSYMBOL (object));
920 XSETSYMBOL (object, sym);
921 }
922 return object;
923 }
924
925
926 /* Given the raw contents of a symbol value cell,
927 return the Lisp value of the symbol.
928 This does not handle buffer-local variables; use
929 swap_in_symval_forwarding for that. */
930
931 Lisp_Object
932 do_symval_forwarding (register union Lisp_Fwd *valcontents)
933 {
934 register Lisp_Object val;
935 switch (XFWDTYPE (valcontents))
936 {
937 case Lisp_Fwd_Int:
938 XSETINT (val, *XINTFWD (valcontents)->intvar);
939 return val;
940
941 case Lisp_Fwd_Bool:
942 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
943
944 case Lisp_Fwd_Obj:
945 return *XOBJFWD (valcontents)->objvar;
946
947 case Lisp_Fwd_Buffer_Obj:
948 return per_buffer_value (current_buffer,
949 XBUFFER_OBJFWD (valcontents)->offset);
950
951 case Lisp_Fwd_Kboard_Obj:
952 /* We used to simply use current_kboard here, but from Lisp
953 code, its value is often unexpected. It seems nicer to
954 allow constructions like this to work as intuitively expected:
955
956 (with-selected-frame frame
957 (define-key local-function-map "\eOP" [f1]))
958
959 On the other hand, this affects the semantics of
960 last-command and real-last-command, and people may rely on
961 that. I took a quick look at the Lisp codebase, and I
962 don't think anything will break. --lorentey */
963 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
964 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
965 default: emacs_abort ();
966 }
967 }
968
969 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
970 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
971 buffer-independent contents of the value cell: forwarded just one
972 step past the buffer-localness.
973
974 BUF non-zero means set the value in buffer BUF instead of the
975 current buffer. This only plays a role for per-buffer variables. */
976
977 static void
978 store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newval, struct buffer *buf)
979 {
980 switch (XFWDTYPE (valcontents))
981 {
982 case Lisp_Fwd_Int:
983 CHECK_NUMBER (newval);
984 *XINTFWD (valcontents)->intvar = XINT (newval);
985 break;
986
987 case Lisp_Fwd_Bool:
988 *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
989 break;
990
991 case Lisp_Fwd_Obj:
992 *XOBJFWD (valcontents)->objvar = newval;
993
994 /* If this variable is a default for something stored
995 in the buffer itself, such as default-fill-column,
996 find the buffers that don't have local values for it
997 and update them. */
998 if (XOBJFWD (valcontents)->objvar > (Lisp_Object *) &buffer_defaults
999 && XOBJFWD (valcontents)->objvar < (Lisp_Object *) (&buffer_defaults + 1))
1000 {
1001 int offset = ((char *) XOBJFWD (valcontents)->objvar
1002 - (char *) &buffer_defaults);
1003 int idx = PER_BUFFER_IDX (offset);
1004
1005 Lisp_Object tail, buf;
1006
1007 if (idx <= 0)
1008 break;
1009
1010 FOR_EACH_LIVE_BUFFER (tail, buf)
1011 {
1012 struct buffer *b = XBUFFER (buf);
1013
1014 if (! PER_BUFFER_VALUE_P (b, idx))
1015 set_per_buffer_value (b, offset, newval);
1016 }
1017 }
1018 break;
1019
1020 case Lisp_Fwd_Buffer_Obj:
1021 {
1022 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1023 Lisp_Object predicate = XBUFFER_OBJFWD (valcontents)->predicate;
1024
1025 if (!NILP (predicate) && !NILP (newval)
1026 && NILP (call1 (predicate, newval)))
1027 wrong_type_argument (predicate, newval);
1028
1029 if (buf == NULL)
1030 buf = current_buffer;
1031 set_per_buffer_value (buf, offset, newval);
1032 }
1033 break;
1034
1035 case Lisp_Fwd_Kboard_Obj:
1036 {
1037 char *base = (char *) FRAME_KBOARD (SELECTED_FRAME ());
1038 char *p = base + XKBOARD_OBJFWD (valcontents)->offset;
1039 *(Lisp_Object *) p = newval;
1040 }
1041 break;
1042
1043 default:
1044 emacs_abort (); /* goto def; */
1045 }
1046 }
1047
1048 /* Set up SYMBOL to refer to its global binding. This makes it safe
1049 to alter the status of other bindings. BEWARE: this may be called
1050 during the mark phase of GC, where we assume that Lisp_Object slots
1051 of BLV are marked after this function has changed them. */
1052
1053 void
1054 swap_in_global_binding (struct Lisp_Symbol *symbol)
1055 {
1056 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (symbol);
1057
1058 /* Unload the previously loaded binding. */
1059 if (blv->fwd)
1060 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1061
1062 /* Select the global binding in the symbol. */
1063 set_blv_valcell (blv, blv->defcell);
1064 if (blv->fwd)
1065 store_symval_forwarding (blv->fwd, XCDR (blv->defcell), NULL);
1066
1067 /* Indicate that the global binding is set up now. */
1068 set_blv_where (blv, Qnil);
1069 set_blv_found (blv, 0);
1070 }
1071
1072 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
1073 VALCONTENTS is the contents of its value cell,
1074 which points to a struct Lisp_Buffer_Local_Value.
1075
1076 Return the value forwarded one step past the buffer-local stage.
1077 This could be another forwarding pointer. */
1078
1079 static void
1080 swap_in_symval_forwarding (struct Lisp_Symbol *symbol, struct Lisp_Buffer_Local_Value *blv)
1081 {
1082 register Lisp_Object tem1;
1083
1084 eassert (blv == SYMBOL_BLV (symbol));
1085
1086 tem1 = blv->where;
1087
1088 if (NILP (tem1)
1089 || (blv->frame_local
1090 ? !EQ (selected_frame, tem1)
1091 : current_buffer != XBUFFER (tem1)))
1092 {
1093
1094 /* Unload the previously loaded binding. */
1095 tem1 = blv->valcell;
1096 if (blv->fwd)
1097 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1098 /* Choose the new binding. */
1099 {
1100 Lisp_Object var;
1101 XSETSYMBOL (var, symbol);
1102 if (blv->frame_local)
1103 {
1104 tem1 = assq_no_quit (var, XFRAME (selected_frame)->param_alist);
1105 set_blv_where (blv, selected_frame);
1106 }
1107 else
1108 {
1109 tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
1110 set_blv_where (blv, Fcurrent_buffer ());
1111 }
1112 }
1113 if (!(blv->found = !NILP (tem1)))
1114 tem1 = blv->defcell;
1115
1116 /* Load the new binding. */
1117 set_blv_valcell (blv, tem1);
1118 if (blv->fwd)
1119 store_symval_forwarding (blv->fwd, blv_value (blv), NULL);
1120 }
1121 }
1122 \f
1123 /* Find the value of a symbol, returning Qunbound if it's not bound.
1124 This is helpful for code which just wants to get a variable's value
1125 if it has one, without signaling an error.
1126 Note that it must not be possible to quit
1127 within this function. Great care is required for this. */
1128
1129 Lisp_Object
1130 find_symbol_value (Lisp_Object symbol)
1131 {
1132 struct Lisp_Symbol *sym;
1133
1134 CHECK_SYMBOL (symbol);
1135 sym = XSYMBOL (symbol);
1136
1137 start:
1138 switch (sym->redirect)
1139 {
1140 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1141 case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1142 case SYMBOL_LOCALIZED:
1143 {
1144 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1145 swap_in_symval_forwarding (sym, blv);
1146 return blv->fwd ? do_symval_forwarding (blv->fwd) : blv_value (blv);
1147 }
1148 /* FALLTHROUGH */
1149 case SYMBOL_FORWARDED:
1150 return do_symval_forwarding (SYMBOL_FWD (sym));
1151 default: emacs_abort ();
1152 }
1153 }
1154
1155 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
1156 doc: /* Return SYMBOL's value. Error if that is void.
1157 Note that if `lexical-binding' is in effect, this returns the
1158 global value outside of any lexical scope. */)
1159 (Lisp_Object symbol)
1160 {
1161 Lisp_Object val;
1162
1163 val = find_symbol_value (symbol);
1164 if (!EQ (val, Qunbound))
1165 return val;
1166
1167 xsignal1 (Qvoid_variable, symbol);
1168 }
1169
1170 DEFUN ("set", Fset, Sset, 2, 2, 0,
1171 doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1172 (register Lisp_Object symbol, Lisp_Object newval)
1173 {
1174 set_internal (symbol, newval, Qnil, 0);
1175 return newval;
1176 }
1177
1178 /* Store the value NEWVAL into SYMBOL.
1179 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1180 (nil stands for the current buffer/frame).
1181
1182 If BINDFLAG is false, then if this symbol is supposed to become
1183 local in every buffer where it is set, then we make it local.
1184 If BINDFLAG is true, we don't do that. */
1185
1186 void
1187 set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where,
1188 bool bindflag)
1189 {
1190 bool voide = EQ (newval, Qunbound);
1191 struct Lisp_Symbol *sym;
1192 Lisp_Object tem1;
1193
1194 /* If restoring in a dead buffer, do nothing. */
1195 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1196 return; */
1197
1198 CHECK_SYMBOL (symbol);
1199 if (SYMBOL_CONSTANT_P (symbol))
1200 {
1201 if (NILP (Fkeywordp (symbol))
1202 || !EQ (newval, Fsymbol_value (symbol)))
1203 xsignal1 (Qsetting_constant, symbol);
1204 else
1205 /* Allow setting keywords to their own value. */
1206 return;
1207 }
1208
1209 sym = XSYMBOL (symbol);
1210
1211 start:
1212 switch (sym->redirect)
1213 {
1214 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1215 case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return;
1216 case SYMBOL_LOCALIZED:
1217 {
1218 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1219 if (NILP (where))
1220 {
1221 if (blv->frame_local)
1222 where = selected_frame;
1223 else
1224 XSETBUFFER (where, current_buffer);
1225 }
1226 /* If the current buffer is not the buffer whose binding is
1227 loaded, or if there may be frame-local bindings and the frame
1228 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1229 the default binding is loaded, the loaded binding may be the
1230 wrong one. */
1231 if (!EQ (blv->where, where)
1232 /* Also unload a global binding (if the var is local_if_set). */
1233 || (EQ (blv->valcell, blv->defcell)))
1234 {
1235 /* The currently loaded binding is not necessarily valid.
1236 We need to unload it, and choose a new binding. */
1237
1238 /* Write out `realvalue' to the old loaded binding. */
1239 if (blv->fwd)
1240 set_blv_value (blv, do_symval_forwarding (blv->fwd));
1241
1242 /* Find the new binding. */
1243 XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */
1244 tem1 = Fassq (symbol,
1245 (blv->frame_local
1246 ? XFRAME (where)->param_alist
1247 : BVAR (XBUFFER (where), local_var_alist)));
1248 set_blv_where (blv, where);
1249 blv->found = 1;
1250
1251 if (NILP (tem1))
1252 {
1253 /* This buffer still sees the default value. */
1254
1255 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1256 or if this is `let' rather than `set',
1257 make CURRENT-ALIST-ELEMENT point to itself,
1258 indicating that we're seeing the default value.
1259 Likewise if the variable has been let-bound
1260 in the current buffer. */
1261 if (bindflag || !blv->local_if_set
1262 || let_shadows_buffer_binding_p (sym))
1263 {
1264 blv->found = 0;
1265 tem1 = blv->defcell;
1266 }
1267 /* If it's a local_if_set, being set not bound,
1268 and we're not within a let that was made for this buffer,
1269 create a new buffer-local binding for the variable.
1270 That means, give this buffer a new assoc for a local value
1271 and load that binding. */
1272 else
1273 {
1274 /* local_if_set is only supported for buffer-local
1275 bindings, not for frame-local bindings. */
1276 eassert (!blv->frame_local);
1277 tem1 = Fcons (symbol, XCDR (blv->defcell));
1278 bset_local_var_alist
1279 (XBUFFER (where),
1280 Fcons (tem1, BVAR (XBUFFER (where), local_var_alist)));
1281 }
1282 }
1283
1284 /* Record which binding is now loaded. */
1285 set_blv_valcell (blv, tem1);
1286 }
1287
1288 /* Store the new value in the cons cell. */
1289 set_blv_value (blv, newval);
1290
1291 if (blv->fwd)
1292 {
1293 if (voide)
1294 /* If storing void (making the symbol void), forward only through
1295 buffer-local indicator, not through Lisp_Objfwd, etc. */
1296 blv->fwd = NULL;
1297 else
1298 store_symval_forwarding (blv->fwd, newval,
1299 BUFFERP (where)
1300 ? XBUFFER (where) : current_buffer);
1301 }
1302 break;
1303 }
1304 case SYMBOL_FORWARDED:
1305 {
1306 struct buffer *buf
1307 = BUFFERP (where) ? XBUFFER (where) : current_buffer;
1308 union Lisp_Fwd *innercontents = SYMBOL_FWD (sym);
1309 if (BUFFER_OBJFWDP (innercontents))
1310 {
1311 int offset = XBUFFER_OBJFWD (innercontents)->offset;
1312 int idx = PER_BUFFER_IDX (offset);
1313 if (idx > 0
1314 && !bindflag
1315 && !let_shadows_buffer_binding_p (sym))
1316 SET_PER_BUFFER_VALUE_P (buf, idx, 1);
1317 }
1318
1319 if (voide)
1320 { /* If storing void (making the symbol void), forward only through
1321 buffer-local indicator, not through Lisp_Objfwd, etc. */
1322 sym->redirect = SYMBOL_PLAINVAL;
1323 SET_SYMBOL_VAL (sym, newval);
1324 }
1325 else
1326 store_symval_forwarding (/* sym, */ innercontents, newval, buf);
1327 break;
1328 }
1329 default: emacs_abort ();
1330 }
1331 return;
1332 }
1333 \f
1334 /* Access or set a buffer-local symbol's default value. */
1335
1336 /* Return the default value of SYMBOL, but don't check for voidness.
1337 Return Qunbound if it is void. */
1338
1339 static Lisp_Object
1340 default_value (Lisp_Object symbol)
1341 {
1342 struct Lisp_Symbol *sym;
1343
1344 CHECK_SYMBOL (symbol);
1345 sym = XSYMBOL (symbol);
1346
1347 start:
1348 switch (sym->redirect)
1349 {
1350 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1351 case SYMBOL_PLAINVAL: return SYMBOL_VAL (sym);
1352 case SYMBOL_LOCALIZED:
1353 {
1354 /* If var is set up for a buffer that lacks a local value for it,
1355 the current value is nominally the default value.
1356 But the `realvalue' slot may be more up to date, since
1357 ordinary setq stores just that slot. So use that. */
1358 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1359 if (blv->fwd && EQ (blv->valcell, blv->defcell))
1360 return do_symval_forwarding (blv->fwd);
1361 else
1362 return XCDR (blv->defcell);
1363 }
1364 case SYMBOL_FORWARDED:
1365 {
1366 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1367
1368 /* For a built-in buffer-local variable, get the default value
1369 rather than letting do_symval_forwarding get the current value. */
1370 if (BUFFER_OBJFWDP (valcontents))
1371 {
1372 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1373 if (PER_BUFFER_IDX (offset) != 0)
1374 return per_buffer_default (offset);
1375 }
1376
1377 /* For other variables, get the current value. */
1378 return do_symval_forwarding (valcontents);
1379 }
1380 default: emacs_abort ();
1381 }
1382 }
1383
1384 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1385 doc: /* Return t if SYMBOL has a non-void default value.
1386 This is the value that is seen in buffers that do not have their own values
1387 for this variable. */)
1388 (Lisp_Object symbol)
1389 {
1390 register Lisp_Object value;
1391
1392 value = default_value (symbol);
1393 return (EQ (value, Qunbound) ? Qnil : Qt);
1394 }
1395
1396 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1397 doc: /* Return SYMBOL's default value.
1398 This is the value that is seen in buffers that do not have their own values
1399 for this variable. The default value is meaningful for variables with
1400 local bindings in certain buffers. */)
1401 (Lisp_Object symbol)
1402 {
1403 Lisp_Object value = default_value (symbol);
1404 if (!EQ (value, Qunbound))
1405 return value;
1406
1407 xsignal1 (Qvoid_variable, symbol);
1408 }
1409
1410 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1411 doc: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1412 The default value is seen in buffers that do not have their own values
1413 for this variable. */)
1414 (Lisp_Object symbol, Lisp_Object value)
1415 {
1416 struct Lisp_Symbol *sym;
1417
1418 CHECK_SYMBOL (symbol);
1419 if (SYMBOL_CONSTANT_P (symbol))
1420 {
1421 if (NILP (Fkeywordp (symbol))
1422 || !EQ (value, Fdefault_value (symbol)))
1423 xsignal1 (Qsetting_constant, symbol);
1424 else
1425 /* Allow setting keywords to their own value. */
1426 return value;
1427 }
1428 sym = XSYMBOL (symbol);
1429
1430 start:
1431 switch (sym->redirect)
1432 {
1433 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1434 case SYMBOL_PLAINVAL: return Fset (symbol, value);
1435 case SYMBOL_LOCALIZED:
1436 {
1437 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1438
1439 /* Store new value into the DEFAULT-VALUE slot. */
1440 XSETCDR (blv->defcell, value);
1441
1442 /* If the default binding is now loaded, set the REALVALUE slot too. */
1443 if (blv->fwd && EQ (blv->defcell, blv->valcell))
1444 store_symval_forwarding (blv->fwd, value, NULL);
1445 return value;
1446 }
1447 case SYMBOL_FORWARDED:
1448 {
1449 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1450
1451 /* Handle variables like case-fold-search that have special slots
1452 in the buffer.
1453 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1454 if (BUFFER_OBJFWDP (valcontents))
1455 {
1456 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1457 int idx = PER_BUFFER_IDX (offset);
1458
1459 set_per_buffer_default (offset, value);
1460
1461 /* If this variable is not always local in all buffers,
1462 set it in the buffers that don't nominally have a local value. */
1463 if (idx > 0)
1464 {
1465 struct buffer *b;
1466
1467 FOR_EACH_BUFFER (b)
1468 if (!PER_BUFFER_VALUE_P (b, idx))
1469 set_per_buffer_value (b, offset, value);
1470 }
1471 return value;
1472 }
1473 else
1474 return Fset (symbol, value);
1475 }
1476 default: emacs_abort ();
1477 }
1478 }
1479
1480 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 0, UNEVALLED, 0,
1481 doc: /* Set the default value of variable VAR to VALUE.
1482 VAR, the variable name, is literal (not evaluated);
1483 VALUE is an expression: it is evaluated and its value returned.
1484 The default value of a variable is seen in buffers
1485 that do not have their own values for the variable.
1486
1487 More generally, you can use multiple variables and values, as in
1488 (setq-default VAR VALUE VAR VALUE...)
1489 This sets each VAR's default value to the corresponding VALUE.
1490 The VALUE for the Nth VAR can refer to the new default values
1491 of previous VARs.
1492 usage: (setq-default [VAR VALUE]...) */)
1493 (Lisp_Object args)
1494 {
1495 Lisp_Object args_left, symbol, val;
1496 struct gcpro gcpro1;
1497
1498 args_left = val = args;
1499 GCPRO1 (args);
1500
1501 while (CONSP (args_left))
1502 {
1503 val = eval_sub (Fcar (XCDR (args_left)));
1504 symbol = XCAR (args_left);
1505 Fset_default (symbol, val);
1506 args_left = Fcdr (XCDR (args_left));
1507 }
1508
1509 UNGCPRO;
1510 return val;
1511 }
1512 \f
1513 /* Lisp functions for creating and removing buffer-local variables. */
1514
1515 union Lisp_Val_Fwd
1516 {
1517 Lisp_Object value;
1518 union Lisp_Fwd *fwd;
1519 };
1520
1521 static struct Lisp_Buffer_Local_Value *
1522 make_blv (struct Lisp_Symbol *sym, bool forwarded,
1523 union Lisp_Val_Fwd valcontents)
1524 {
1525 struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
1526 Lisp_Object symbol;
1527 Lisp_Object tem;
1528
1529 XSETSYMBOL (symbol, sym);
1530 tem = Fcons (symbol, (forwarded
1531 ? do_symval_forwarding (valcontents.fwd)
1532 : valcontents.value));
1533
1534 /* Buffer_Local_Values cannot have as realval a buffer-local
1535 or keyboard-local forwarding. */
1536 eassert (!(forwarded && BUFFER_OBJFWDP (valcontents.fwd)));
1537 eassert (!(forwarded && KBOARD_OBJFWDP (valcontents.fwd)));
1538 blv->fwd = forwarded ? valcontents.fwd : NULL;
1539 set_blv_where (blv, Qnil);
1540 blv->frame_local = 0;
1541 blv->local_if_set = 0;
1542 set_blv_defcell (blv, tem);
1543 set_blv_valcell (blv, tem);
1544 set_blv_found (blv, 0);
1545 return blv;
1546 }
1547
1548 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local,
1549 Smake_variable_buffer_local, 1, 1, "vMake Variable Buffer Local: ",
1550 doc: /* Make VARIABLE become buffer-local whenever it is set.
1551 At any time, the value for the current buffer is in effect,
1552 unless the variable has never been set in this buffer,
1553 in which case the default value is in effect.
1554 Note that binding the variable with `let', or setting it while
1555 a `let'-style binding made in this buffer is in effect,
1556 does not make the variable buffer-local. Return VARIABLE.
1557
1558 This globally affects all uses of this variable, so it belongs together with
1559 the variable declaration, rather than with its uses (if you just want to make
1560 a variable local to the current buffer for one particular use, use
1561 `make-local-variable'). Buffer-local bindings are normally cleared
1562 while setting up a new major mode, unless they have a `permanent-local'
1563 property.
1564
1565 The function `default-value' gets the default value and `set-default' sets it. */)
1566 (register Lisp_Object variable)
1567 {
1568 struct Lisp_Symbol *sym;
1569 struct Lisp_Buffer_Local_Value *blv = NULL;
1570 union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
1571 bool forwarded IF_LINT (= 0);
1572
1573 CHECK_SYMBOL (variable);
1574 sym = XSYMBOL (variable);
1575
1576 start:
1577 switch (sym->redirect)
1578 {
1579 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1580 case SYMBOL_PLAINVAL:
1581 forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1582 if (EQ (valcontents.value, Qunbound))
1583 valcontents.value = Qnil;
1584 break;
1585 case SYMBOL_LOCALIZED:
1586 blv = SYMBOL_BLV (sym);
1587 if (blv->frame_local)
1588 error ("Symbol %s may not be buffer-local",
1589 SDATA (SYMBOL_NAME (variable)));
1590 break;
1591 case SYMBOL_FORWARDED:
1592 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1593 if (KBOARD_OBJFWDP (valcontents.fwd))
1594 error ("Symbol %s may not be buffer-local",
1595 SDATA (SYMBOL_NAME (variable)));
1596 else if (BUFFER_OBJFWDP (valcontents.fwd))
1597 return variable;
1598 break;
1599 default: emacs_abort ();
1600 }
1601
1602 if (sym->constant)
1603 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable)));
1604
1605 if (!blv)
1606 {
1607 blv = make_blv (sym, forwarded, valcontents);
1608 sym->redirect = SYMBOL_LOCALIZED;
1609 SET_SYMBOL_BLV (sym, blv);
1610 {
1611 Lisp_Object symbol;
1612 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1613 if (let_shadows_global_binding_p (symbol))
1614 message ("Making %s buffer-local while let-bound!",
1615 SDATA (SYMBOL_NAME (variable)));
1616 }
1617 }
1618
1619 blv->local_if_set = 1;
1620 return variable;
1621 }
1622
1623 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1624 1, 1, "vMake Local Variable: ",
1625 doc: /* Make VARIABLE have a separate value in the current buffer.
1626 Other buffers will continue to share a common default value.
1627 \(The buffer-local value of VARIABLE starts out as the same value
1628 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1629 Return VARIABLE.
1630
1631 If the variable is already arranged to become local when set,
1632 this function causes a local value to exist for this buffer,
1633 just as setting the variable would do.
1634
1635 This function returns VARIABLE, and therefore
1636 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1637 works.
1638
1639 See also `make-variable-buffer-local'.
1640
1641 Do not use `make-local-variable' to make a hook variable buffer-local.
1642 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1643 (Lisp_Object variable)
1644 {
1645 Lisp_Object tem;
1646 bool forwarded IF_LINT (= 0);
1647 union Lisp_Val_Fwd valcontents IF_LINT (= {LISP_INITIALLY_ZERO});
1648 struct Lisp_Symbol *sym;
1649 struct Lisp_Buffer_Local_Value *blv = NULL;
1650
1651 CHECK_SYMBOL (variable);
1652 sym = XSYMBOL (variable);
1653
1654 start:
1655 switch (sym->redirect)
1656 {
1657 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1658 case SYMBOL_PLAINVAL:
1659 forwarded = 0; valcontents.value = SYMBOL_VAL (sym); break;
1660 case SYMBOL_LOCALIZED:
1661 blv = SYMBOL_BLV (sym);
1662 if (blv->frame_local)
1663 error ("Symbol %s may not be buffer-local",
1664 SDATA (SYMBOL_NAME (variable)));
1665 break;
1666 case SYMBOL_FORWARDED:
1667 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1668 if (KBOARD_OBJFWDP (valcontents.fwd))
1669 error ("Symbol %s may not be buffer-local",
1670 SDATA (SYMBOL_NAME (variable)));
1671 break;
1672 default: emacs_abort ();
1673 }
1674
1675 if (sym->constant)
1676 error ("Symbol %s may not be buffer-local",
1677 SDATA (SYMBOL_NAME (variable)));
1678
1679 if (blv ? blv->local_if_set
1680 : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
1681 {
1682 tem = Fboundp (variable);
1683 /* Make sure the symbol has a local value in this particular buffer,
1684 by setting it to the same value it already has. */
1685 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1686 return variable;
1687 }
1688 if (!blv)
1689 {
1690 blv = make_blv (sym, forwarded, valcontents);
1691 sym->redirect = SYMBOL_LOCALIZED;
1692 SET_SYMBOL_BLV (sym, blv);
1693 {
1694 Lisp_Object symbol;
1695 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1696 if (let_shadows_global_binding_p (symbol))
1697 message ("Making %s local to %s while let-bound!",
1698 SDATA (SYMBOL_NAME (variable)),
1699 SDATA (BVAR (current_buffer, name)));
1700 }
1701 }
1702
1703 /* Make sure this buffer has its own value of symbol. */
1704 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1705 tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
1706 if (NILP (tem))
1707 {
1708 if (let_shadows_buffer_binding_p (sym))
1709 message ("Making %s buffer-local while locally let-bound!",
1710 SDATA (SYMBOL_NAME (variable)));
1711
1712 /* Swap out any local binding for some other buffer, and make
1713 sure the current value is permanently recorded, if it's the
1714 default value. */
1715 find_symbol_value (variable);
1716
1717 bset_local_var_alist
1718 (current_buffer,
1719 Fcons (Fcons (variable, XCDR (blv->defcell)),
1720 BVAR (current_buffer, local_var_alist)));
1721
1722 /* Make sure symbol does not think it is set up for this buffer;
1723 force it to look once again for this buffer's value. */
1724 if (current_buffer == XBUFFER (blv->where))
1725 set_blv_where (blv, Qnil);
1726 set_blv_found (blv, 0);
1727 }
1728
1729 /* If the symbol forwards into a C variable, then load the binding
1730 for this buffer now. If C code modifies the variable before we
1731 load the binding in, then that new value will clobber the default
1732 binding the next time we unload it. */
1733 if (blv->fwd)
1734 swap_in_symval_forwarding (sym, blv);
1735
1736 return variable;
1737 }
1738
1739 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1740 1, 1, "vKill Local Variable: ",
1741 doc: /* Make VARIABLE no longer have a separate value in the current buffer.
1742 From now on the default value will apply in this buffer. Return VARIABLE. */)
1743 (register Lisp_Object variable)
1744 {
1745 register Lisp_Object tem;
1746 struct Lisp_Buffer_Local_Value *blv;
1747 struct Lisp_Symbol *sym;
1748
1749 CHECK_SYMBOL (variable);
1750 sym = XSYMBOL (variable);
1751
1752 start:
1753 switch (sym->redirect)
1754 {
1755 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1756 case SYMBOL_PLAINVAL: return variable;
1757 case SYMBOL_FORWARDED:
1758 {
1759 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1760 if (BUFFER_OBJFWDP (valcontents))
1761 {
1762 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1763 int idx = PER_BUFFER_IDX (offset);
1764
1765 if (idx > 0)
1766 {
1767 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
1768 set_per_buffer_value (current_buffer, offset,
1769 per_buffer_default (offset));
1770 }
1771 }
1772 return variable;
1773 }
1774 case SYMBOL_LOCALIZED:
1775 blv = SYMBOL_BLV (sym);
1776 if (blv->frame_local)
1777 return variable;
1778 break;
1779 default: emacs_abort ();
1780 }
1781
1782 /* Get rid of this buffer's alist element, if any. */
1783 XSETSYMBOL (variable, sym); /* Propagate variable indirection. */
1784 tem = Fassq (variable, BVAR (current_buffer, local_var_alist));
1785 if (!NILP (tem))
1786 bset_local_var_alist
1787 (current_buffer,
1788 Fdelq (tem, BVAR (current_buffer, local_var_alist)));
1789
1790 /* If the symbol is set up with the current buffer's binding
1791 loaded, recompute its value. We have to do it now, or else
1792 forwarded objects won't work right. */
1793 {
1794 Lisp_Object buf; XSETBUFFER (buf, current_buffer);
1795 if (EQ (buf, blv->where))
1796 {
1797 set_blv_where (blv, Qnil);
1798 blv->found = 0;
1799 find_symbol_value (variable);
1800 }
1801 }
1802
1803 return variable;
1804 }
1805
1806 /* Lisp functions for creating and removing buffer-local variables. */
1807
1808 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1809 when/if this is removed. */
1810
1811 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1812 1, 1, "vMake Variable Frame Local: ",
1813 doc: /* Enable VARIABLE to have frame-local bindings.
1814 This does not create any frame-local bindings for VARIABLE,
1815 it just makes them possible.
1816
1817 A frame-local binding is actually a frame parameter value.
1818 If a frame F has a value for the frame parameter named VARIABLE,
1819 that also acts as a frame-local binding for VARIABLE in F--
1820 provided this function has been called to enable VARIABLE
1821 to have frame-local bindings at all.
1822
1823 The only way to create a frame-local binding for VARIABLE in a frame
1824 is to set the VARIABLE frame parameter of that frame. See
1825 `modify-frame-parameters' for how to set frame parameters.
1826
1827 Note that since Emacs 23.1, variables cannot be both buffer-local and
1828 frame-local any more (buffer-local bindings used to take precedence over
1829 frame-local bindings). */)
1830 (Lisp_Object variable)
1831 {
1832 bool forwarded;
1833 union Lisp_Val_Fwd valcontents;
1834 struct Lisp_Symbol *sym;
1835 struct Lisp_Buffer_Local_Value *blv = NULL;
1836
1837 CHECK_SYMBOL (variable);
1838 sym = XSYMBOL (variable);
1839
1840 start:
1841 switch (sym->redirect)
1842 {
1843 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1844 case SYMBOL_PLAINVAL:
1845 forwarded = 0; valcontents.value = SYMBOL_VAL (sym);
1846 if (EQ (valcontents.value, Qunbound))
1847 valcontents.value = Qnil;
1848 break;
1849 case SYMBOL_LOCALIZED:
1850 if (SYMBOL_BLV (sym)->frame_local)
1851 return variable;
1852 else
1853 error ("Symbol %s may not be frame-local",
1854 SDATA (SYMBOL_NAME (variable)));
1855 case SYMBOL_FORWARDED:
1856 forwarded = 1; valcontents.fwd = SYMBOL_FWD (sym);
1857 if (KBOARD_OBJFWDP (valcontents.fwd) || BUFFER_OBJFWDP (valcontents.fwd))
1858 error ("Symbol %s may not be frame-local",
1859 SDATA (SYMBOL_NAME (variable)));
1860 break;
1861 default: emacs_abort ();
1862 }
1863
1864 if (sym->constant)
1865 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable)));
1866
1867 blv = make_blv (sym, forwarded, valcontents);
1868 blv->frame_local = 1;
1869 sym->redirect = SYMBOL_LOCALIZED;
1870 SET_SYMBOL_BLV (sym, blv);
1871 {
1872 Lisp_Object symbol;
1873 XSETSYMBOL (symbol, sym); /* In case `variable' is aliased. */
1874 if (let_shadows_global_binding_p (symbol))
1875 message ("Making %s frame-local while let-bound!",
1876 SDATA (SYMBOL_NAME (variable)));
1877 }
1878 return variable;
1879 }
1880
1881 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1882 1, 2, 0,
1883 doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1884 BUFFER defaults to the current buffer. */)
1885 (register Lisp_Object variable, Lisp_Object buffer)
1886 {
1887 register struct buffer *buf;
1888 struct Lisp_Symbol *sym;
1889
1890 if (NILP (buffer))
1891 buf = current_buffer;
1892 else
1893 {
1894 CHECK_BUFFER (buffer);
1895 buf = XBUFFER (buffer);
1896 }
1897
1898 CHECK_SYMBOL (variable);
1899 sym = XSYMBOL (variable);
1900
1901 start:
1902 switch (sym->redirect)
1903 {
1904 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1905 case SYMBOL_PLAINVAL: return Qnil;
1906 case SYMBOL_LOCALIZED:
1907 {
1908 Lisp_Object tail, elt, tmp;
1909 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1910 XSETBUFFER (tmp, buf);
1911 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1912
1913 if (EQ (blv->where, tmp)) /* The binding is already loaded. */
1914 return blv_found (blv) ? Qt : Qnil;
1915 else
1916 for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
1917 {
1918 elt = XCAR (tail);
1919 if (EQ (variable, XCAR (elt)))
1920 {
1921 eassert (!blv->frame_local);
1922 return Qt;
1923 }
1924 }
1925 return Qnil;
1926 }
1927 case SYMBOL_FORWARDED:
1928 {
1929 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
1930 if (BUFFER_OBJFWDP (valcontents))
1931 {
1932 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1933 int idx = PER_BUFFER_IDX (offset);
1934 if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1935 return Qt;
1936 }
1937 return Qnil;
1938 }
1939 default: emacs_abort ();
1940 }
1941 }
1942
1943 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1944 1, 2, 0,
1945 doc: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
1946 BUFFER defaults to the current buffer.
1947
1948 More precisely, return non-nil if either VARIABLE already has a local
1949 value in BUFFER, or if VARIABLE is automatically buffer-local (see
1950 `make-variable-buffer-local'). */)
1951 (register Lisp_Object variable, Lisp_Object buffer)
1952 {
1953 struct Lisp_Symbol *sym;
1954
1955 CHECK_SYMBOL (variable);
1956 sym = XSYMBOL (variable);
1957
1958 start:
1959 switch (sym->redirect)
1960 {
1961 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1962 case SYMBOL_PLAINVAL: return Qnil;
1963 case SYMBOL_LOCALIZED:
1964 {
1965 struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
1966 if (blv->local_if_set)
1967 return Qt;
1968 XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
1969 return Flocal_variable_p (variable, buffer);
1970 }
1971 case SYMBOL_FORWARDED:
1972 /* All BUFFER_OBJFWD slots become local if they are set. */
1973 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
1974 default: emacs_abort ();
1975 }
1976 }
1977
1978 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
1979 1, 1, 0,
1980 doc: /* Return a value indicating where VARIABLE's current binding comes from.
1981 If the current binding is buffer-local, the value is the current buffer.
1982 If the current binding is frame-local, the value is the selected frame.
1983 If the current binding is global (the default), the value is nil. */)
1984 (register Lisp_Object variable)
1985 {
1986 struct Lisp_Symbol *sym;
1987
1988 CHECK_SYMBOL (variable);
1989 sym = XSYMBOL (variable);
1990
1991 /* Make sure the current binding is actually swapped in. */
1992 find_symbol_value (variable);
1993
1994 start:
1995 switch (sym->redirect)
1996 {
1997 case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start;
1998 case SYMBOL_PLAINVAL: return Qnil;
1999 case SYMBOL_FORWARDED:
2000 {
2001 union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
2002 if (KBOARD_OBJFWDP (valcontents))
2003 return Fframe_terminal (selected_frame);
2004 else if (!BUFFER_OBJFWDP (valcontents))
2005 return Qnil;
2006 }
2007 /* FALLTHROUGH */
2008 case SYMBOL_LOCALIZED:
2009 /* For a local variable, record both the symbol and which
2010 buffer's or frame's value we are saving. */
2011 if (!NILP (Flocal_variable_p (variable, Qnil)))
2012 return Fcurrent_buffer ();
2013 else if (sym->redirect == SYMBOL_LOCALIZED
2014 && blv_found (SYMBOL_BLV (sym)))
2015 return SYMBOL_BLV (sym)->where;
2016 else
2017 return Qnil;
2018 default: emacs_abort ();
2019 }
2020 }
2021
2022 /* This code is disabled now that we use the selected frame to return
2023 keyboard-local-values. */
2024 #if 0
2025 extern struct terminal *get_terminal (Lisp_Object display, int);
2026
2027 DEFUN ("terminal-local-value", Fterminal_local_value,
2028 Sterminal_local_value, 2, 2, 0,
2029 doc: /* Return the terminal-local value of SYMBOL on TERMINAL.
2030 If SYMBOL is not a terminal-local variable, then return its normal
2031 value, like `symbol-value'.
2032
2033 TERMINAL may be a terminal object, a frame, or nil (meaning the
2034 selected frame's terminal device). */)
2035 (Lisp_Object symbol, Lisp_Object terminal)
2036 {
2037 Lisp_Object result;
2038 struct terminal *t = get_terminal (terminal, 1);
2039 push_kboard (t->kboard);
2040 result = Fsymbol_value (symbol);
2041 pop_kboard ();
2042 return result;
2043 }
2044
2045 DEFUN ("set-terminal-local-value", Fset_terminal_local_value,
2046 Sset_terminal_local_value, 3, 3, 0,
2047 doc: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
2048 If VARIABLE is not a terminal-local variable, then set its normal
2049 binding, like `set'.
2050
2051 TERMINAL may be a terminal object, a frame, or nil (meaning the
2052 selected frame's terminal device). */)
2053 (Lisp_Object symbol, Lisp_Object terminal, Lisp_Object value)
2054 {
2055 Lisp_Object result;
2056 struct terminal *t = get_terminal (terminal, 1);
2057 push_kboard (d->kboard);
2058 result = Fset (symbol, value);
2059 pop_kboard ();
2060 return result;
2061 }
2062 #endif
2063 \f
2064 /* Find the function at the end of a chain of symbol function indirections. */
2065
2066 /* If OBJECT is a symbol, find the end of its function chain and
2067 return the value found there. If OBJECT is not a symbol, just
2068 return it. If there is a cycle in the function chain, signal a
2069 cyclic-function-indirection error.
2070
2071 This is like Findirect_function, except that it doesn't signal an
2072 error if the chain ends up unbound. */
2073 Lisp_Object
2074 indirect_function (register Lisp_Object object)
2075 {
2076 Lisp_Object tortoise, hare;
2077
2078 hare = tortoise = object;
2079
2080 for (;;)
2081 {
2082 if (!SYMBOLP (hare) || NILP (hare))
2083 break;
2084 hare = XSYMBOL (hare)->function;
2085 if (!SYMBOLP (hare) || NILP (hare))
2086 break;
2087 hare = XSYMBOL (hare)->function;
2088
2089 tortoise = XSYMBOL (tortoise)->function;
2090
2091 if (EQ (hare, tortoise))
2092 xsignal1 (Qcyclic_function_indirection, object);
2093 }
2094
2095 return hare;
2096 }
2097
2098 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
2099 doc: /* Return the function at the end of OBJECT's function chain.
2100 If OBJECT is not a symbol, just return it. Otherwise, follow all
2101 function indirections to find the final function binding and return it.
2102 If the final symbol in the chain is unbound, signal a void-function error.
2103 Optional arg NOERROR non-nil means to return nil instead of signaling.
2104 Signal a cyclic-function-indirection error if there is a loop in the
2105 function chain of symbols. */)
2106 (register Lisp_Object object, Lisp_Object noerror)
2107 {
2108 Lisp_Object result;
2109
2110 /* Optimize for no indirection. */
2111 result = object;
2112 if (SYMBOLP (result) && !NILP (result)
2113 && (result = XSYMBOL (result)->function, SYMBOLP (result)))
2114 result = indirect_function (result);
2115 if (!NILP (result))
2116 return result;
2117
2118 if (NILP (noerror))
2119 xsignal1 (Qvoid_function, object);
2120
2121 return Qnil;
2122 }
2123 \f
2124 /* Extract and set vector and string elements. */
2125
2126 DEFUN ("aref", Faref, Saref, 2, 2, 0,
2127 doc: /* Return the element of ARRAY at index IDX.
2128 ARRAY may be a vector, a string, a char-table, a bool-vector,
2129 or a byte-code object. IDX starts at 0. */)
2130 (register Lisp_Object array, Lisp_Object idx)
2131 {
2132 register EMACS_INT idxval;
2133
2134 CHECK_NUMBER (idx);
2135 idxval = XINT (idx);
2136 if (STRINGP (array))
2137 {
2138 int c;
2139 ptrdiff_t idxval_byte;
2140
2141 if (idxval < 0 || idxval >= SCHARS (array))
2142 args_out_of_range (array, idx);
2143 if (! STRING_MULTIBYTE (array))
2144 return make_number ((unsigned char) SREF (array, idxval));
2145 idxval_byte = string_char_to_byte (array, idxval);
2146
2147 c = STRING_CHAR (SDATA (array) + idxval_byte);
2148 return make_number (c);
2149 }
2150 else if (BOOL_VECTOR_P (array))
2151 {
2152 if (idxval < 0 || idxval >= bool_vector_size (array))
2153 args_out_of_range (array, idx);
2154 return bool_vector_ref (array, idxval);
2155 }
2156 else if (CHAR_TABLE_P (array))
2157 {
2158 CHECK_CHARACTER (idx);
2159 return CHAR_TABLE_REF (array, idxval);
2160 }
2161 else
2162 {
2163 ptrdiff_t size = 0;
2164 if (VECTORP (array))
2165 size = ASIZE (array);
2166 else if (COMPILEDP (array))
2167 size = ASIZE (array) & PSEUDOVECTOR_SIZE_MASK;
2168 else
2169 wrong_type_argument (Qarrayp, array);
2170
2171 if (idxval < 0 || idxval >= size)
2172 args_out_of_range (array, idx);
2173 return AREF (array, idxval);
2174 }
2175 }
2176
2177 DEFUN ("aset", Faset, Saset, 3, 3, 0,
2178 doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
2179 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2180 bool-vector. IDX starts at 0. */)
2181 (register Lisp_Object array, Lisp_Object idx, Lisp_Object newelt)
2182 {
2183 register EMACS_INT idxval;
2184
2185 CHECK_NUMBER (idx);
2186 idxval = XINT (idx);
2187 CHECK_ARRAY (array, Qarrayp);
2188 CHECK_IMPURE (array);
2189
2190 if (VECTORP (array))
2191 {
2192 if (idxval < 0 || idxval >= ASIZE (array))
2193 args_out_of_range (array, idx);
2194 ASET (array, idxval, newelt);
2195 }
2196 else if (BOOL_VECTOR_P (array))
2197 {
2198 if (idxval < 0 || idxval >= bool_vector_size (array))
2199 args_out_of_range (array, idx);
2200 bool_vector_set (array, idxval, !NILP (newelt));
2201 }
2202 else if (CHAR_TABLE_P (array))
2203 {
2204 CHECK_CHARACTER (idx);
2205 CHAR_TABLE_SET (array, idxval, newelt);
2206 }
2207 else
2208 {
2209 int c;
2210
2211 if (idxval < 0 || idxval >= SCHARS (array))
2212 args_out_of_range (array, idx);
2213 CHECK_CHARACTER (newelt);
2214 c = XFASTINT (newelt);
2215
2216 if (STRING_MULTIBYTE (array))
2217 {
2218 ptrdiff_t idxval_byte, nbytes;
2219 int prev_bytes, new_bytes;
2220 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
2221
2222 nbytes = SBYTES (array);
2223 idxval_byte = string_char_to_byte (array, idxval);
2224 p1 = SDATA (array) + idxval_byte;
2225 prev_bytes = BYTES_BY_CHAR_HEAD (*p1);
2226 new_bytes = CHAR_STRING (c, p0);
2227 if (prev_bytes != new_bytes)
2228 {
2229 /* We must relocate the string data. */
2230 ptrdiff_t nchars = SCHARS (array);
2231 USE_SAFE_ALLOCA;
2232 unsigned char *str = SAFE_ALLOCA (nbytes);
2233
2234 memcpy (str, SDATA (array), nbytes);
2235 allocate_string_data (XSTRING (array), nchars,
2236 nbytes + new_bytes - prev_bytes);
2237 memcpy (SDATA (array), str, idxval_byte);
2238 p1 = SDATA (array) + idxval_byte;
2239 memcpy (p1 + new_bytes, str + idxval_byte + prev_bytes,
2240 nbytes - (idxval_byte + prev_bytes));
2241 SAFE_FREE ();
2242 clear_string_char_byte_cache ();
2243 }
2244 while (new_bytes--)
2245 *p1++ = *p0++;
2246 }
2247 else
2248 {
2249 if (! SINGLE_BYTE_CHAR_P (c))
2250 {
2251 int i;
2252
2253 for (i = SBYTES (array) - 1; i >= 0; i--)
2254 if (SREF (array, i) >= 0x80)
2255 args_out_of_range (array, newelt);
2256 /* ARRAY is an ASCII string. Convert it to a multibyte
2257 string, and try `aset' again. */
2258 STRING_SET_MULTIBYTE (array);
2259 return Faset (array, idx, newelt);
2260 }
2261 SSET (array, idxval, c);
2262 }
2263 }
2264
2265 return newelt;
2266 }
2267 \f
2268 /* Arithmetic functions */
2269
2270 Lisp_Object
2271 arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison)
2272 {
2273 double f1 = 0, f2 = 0;
2274 bool floatp = 0;
2275
2276 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1);
2277 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2);
2278
2279 if (FLOATP (num1) || FLOATP (num2))
2280 {
2281 floatp = 1;
2282 f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
2283 f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
2284 }
2285
2286 switch (comparison)
2287 {
2288 case ARITH_EQUAL:
2289 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
2290 return Qt;
2291 return Qnil;
2292
2293 case ARITH_NOTEQUAL:
2294 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
2295 return Qt;
2296 return Qnil;
2297
2298 case ARITH_LESS:
2299 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
2300 return Qt;
2301 return Qnil;
2302
2303 case ARITH_LESS_OR_EQUAL:
2304 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
2305 return Qt;
2306 return Qnil;
2307
2308 case ARITH_GRTR:
2309 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
2310 return Qt;
2311 return Qnil;
2312
2313 case ARITH_GRTR_OR_EQUAL:
2314 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
2315 return Qt;
2316 return Qnil;
2317
2318 default:
2319 emacs_abort ();
2320 }
2321 }
2322
2323 static Lisp_Object
2324 arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
2325 enum Arith_Comparison comparison)
2326 {
2327 ptrdiff_t argnum;
2328 for (argnum = 1; argnum < nargs; ++argnum)
2329 {
2330 if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison)))
2331 return Qnil;
2332 }
2333 return Qt;
2334 }
2335
2336 DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
2337 doc: /* Return t if args, all numbers or markers, are equal.
2338 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2339 (ptrdiff_t nargs, Lisp_Object *args)
2340 {
2341 return arithcompare_driver (nargs, args, ARITH_EQUAL);
2342 }
2343
2344 DEFUN ("<", Flss, Slss, 1, MANY, 0,
2345 doc: /* Return t if each arg is less than the next arg. All must be numbers or markers.
2346 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2347 (ptrdiff_t nargs, Lisp_Object *args)
2348 {
2349 return arithcompare_driver (nargs, args, ARITH_LESS);
2350 }
2351
2352 DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
2353 doc: /* Return t if each arg is greater than the next arg. All must be numbers or markers.
2354 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2355 (ptrdiff_t nargs, Lisp_Object *args)
2356 {
2357 return arithcompare_driver (nargs, args, ARITH_GRTR);
2358 }
2359
2360 DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
2361 doc: /* Return t if each arg is less than or equal to the next arg.
2362 All must be numbers or markers.
2363 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2364 (ptrdiff_t nargs, Lisp_Object *args)
2365 {
2366 return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
2367 }
2368
2369 DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
2370 doc: /* Return t if each arg is greater than or equal to the next arg.
2371 All must be numbers or markers.
2372 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2373 (ptrdiff_t nargs, Lisp_Object *args)
2374 {
2375 return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
2376 }
2377
2378 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
2379 doc: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2380 (register Lisp_Object num1, Lisp_Object num2)
2381 {
2382 return arithcompare (num1, num2, ARITH_NOTEQUAL);
2383 }
2384
2385 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,
2386 doc: /* Return t if NUMBER is zero. */)
2387 (register Lisp_Object number)
2388 {
2389 CHECK_NUMBER_OR_FLOAT (number);
2390
2391 if (FLOATP (number))
2392 {
2393 if (XFLOAT_DATA (number) == 0.0)
2394 return Qt;
2395 return Qnil;
2396 }
2397
2398 if (!XINT (number))
2399 return Qt;
2400 return Qnil;
2401 }
2402 \f
2403 /* Convert the cons-of-integers, integer, or float value C to an
2404 unsigned value with maximum value MAX. Signal an error if C does not
2405 have a valid format or is out of range. */
2406 uintmax_t
2407 cons_to_unsigned (Lisp_Object c, uintmax_t max)
2408 {
2409 bool valid = 0;
2410 uintmax_t val IF_LINT (= 0);
2411 if (INTEGERP (c))
2412 {
2413 valid = 0 <= XINT (c);
2414 val = XINT (c);
2415 }
2416 else if (FLOATP (c))
2417 {
2418 double d = XFLOAT_DATA (c);
2419 if (0 <= d
2420 && d < (max == UINTMAX_MAX ? (double) UINTMAX_MAX + 1 : max + 1))
2421 {
2422 val = d;
2423 valid = 1;
2424 }
2425 }
2426 else if (CONSP (c) && NATNUMP (XCAR (c)))
2427 {
2428 uintmax_t top = XFASTINT (XCAR (c));
2429 Lisp_Object rest = XCDR (c);
2430 if (top <= UINTMAX_MAX >> 24 >> 16
2431 && CONSP (rest)
2432 && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24
2433 && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16)
2434 {
2435 uintmax_t mid = XFASTINT (XCAR (rest));
2436 val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest));
2437 valid = 1;
2438 }
2439 else if (top <= UINTMAX_MAX >> 16)
2440 {
2441 if (CONSP (rest))
2442 rest = XCAR (rest);
2443 if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16)
2444 {
2445 val = top << 16 | XFASTINT (rest);
2446 valid = 1;
2447 }
2448 }
2449 }
2450
2451 if (! (valid && val <= max))
2452 error ("Not an in-range integer, float, or cons of integers");
2453 return val;
2454 }
2455
2456 /* Convert the cons-of-integers, integer, or float value C to a signed
2457 value with extrema MIN and MAX. Signal an error if C does not have
2458 a valid format or is out of range. */
2459 intmax_t
2460 cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
2461 {
2462 bool valid = 0;
2463 intmax_t val IF_LINT (= 0);
2464 if (INTEGERP (c))
2465 {
2466 val = XINT (c);
2467 valid = 1;
2468 }
2469 else if (FLOATP (c))
2470 {
2471 double d = XFLOAT_DATA (c);
2472 if (min <= d
2473 && d < (max == INTMAX_MAX ? (double) INTMAX_MAX + 1 : max + 1))
2474 {
2475 val = d;
2476 valid = 1;
2477 }
2478 }
2479 else if (CONSP (c) && INTEGERP (XCAR (c)))
2480 {
2481 intmax_t top = XINT (XCAR (c));
2482 Lisp_Object rest = XCDR (c);
2483 if (INTMAX_MIN >> 24 >> 16 <= top && top <= INTMAX_MAX >> 24 >> 16
2484 && CONSP (rest)
2485 && NATNUMP (XCAR (rest)) && XFASTINT (XCAR (rest)) < 1 << 24
2486 && NATNUMP (XCDR (rest)) && XFASTINT (XCDR (rest)) < 1 << 16)
2487 {
2488 intmax_t mid = XFASTINT (XCAR (rest));
2489 val = top << 24 << 16 | mid << 16 | XFASTINT (XCDR (rest));
2490 valid = 1;
2491 }
2492 else if (INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16)
2493 {
2494 if (CONSP (rest))
2495 rest = XCAR (rest);
2496 if (NATNUMP (rest) && XFASTINT (rest) < 1 << 16)
2497 {
2498 val = top << 16 | XFASTINT (rest);
2499 valid = 1;
2500 }
2501 }
2502 }
2503
2504 if (! (valid && min <= val && val <= max))
2505 error ("Not an in-range integer, float, or cons of integers");
2506 return val;
2507 }
2508 \f
2509 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
2510 doc: /* Return the decimal representation of NUMBER as a string.
2511 Uses a minus sign if negative.
2512 NUMBER may be an integer or a floating point number. */)
2513 (Lisp_Object number)
2514 {
2515 char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
2516 int len;
2517
2518 CHECK_NUMBER_OR_FLOAT (number);
2519
2520 if (FLOATP (number))
2521 len = float_to_string (buffer, XFLOAT_DATA (number));
2522 else
2523 len = sprintf (buffer, "%"pI"d", XINT (number));
2524
2525 return make_unibyte_string (buffer, len);
2526 }
2527
2528 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
2529 doc: /* Parse STRING as a decimal number and return the number.
2530 Ignore leading spaces and tabs, and all trailing chars. Return 0 if
2531 STRING cannot be parsed as an integer or floating point number.
2532
2533 If BASE, interpret STRING as a number in that base. If BASE isn't
2534 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2535 If the base used is not 10, STRING is always parsed as an integer. */)
2536 (register Lisp_Object string, Lisp_Object base)
2537 {
2538 register char *p;
2539 register int b;
2540 Lisp_Object val;
2541
2542 CHECK_STRING (string);
2543
2544 if (NILP (base))
2545 b = 10;
2546 else
2547 {
2548 CHECK_NUMBER (base);
2549 if (! (2 <= XINT (base) && XINT (base) <= 16))
2550 xsignal1 (Qargs_out_of_range, base);
2551 b = XINT (base);
2552 }
2553
2554 p = SSDATA (string);
2555 while (*p == ' ' || *p == '\t')
2556 p++;
2557
2558 val = string_to_number (p, b, 1);
2559 return NILP (val) ? make_number (0) : val;
2560 }
2561 \f
2562 enum arithop
2563 {
2564 Aadd,
2565 Asub,
2566 Amult,
2567 Adiv,
2568 Alogand,
2569 Alogior,
2570 Alogxor,
2571 Amax,
2572 Amin
2573 };
2574
2575 static Lisp_Object float_arith_driver (double, ptrdiff_t, enum arithop,
2576 ptrdiff_t, Lisp_Object *);
2577 static Lisp_Object
2578 arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args)
2579 {
2580 Lisp_Object val;
2581 ptrdiff_t argnum, ok_args;
2582 EMACS_INT accum = 0;
2583 EMACS_INT next, ok_accum;
2584 bool overflow = 0;
2585
2586 switch (code)
2587 {
2588 case Alogior:
2589 case Alogxor:
2590 case Aadd:
2591 case Asub:
2592 accum = 0;
2593 break;
2594 case Amult:
2595 accum = 1;
2596 break;
2597 case Alogand:
2598 accum = -1;
2599 break;
2600 default:
2601 break;
2602 }
2603
2604 for (argnum = 0; argnum < nargs; argnum++)
2605 {
2606 if (! overflow)
2607 {
2608 ok_args = argnum;
2609 ok_accum = accum;
2610 }
2611
2612 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2613 val = args[argnum];
2614 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2615
2616 if (FLOATP (val))
2617 return float_arith_driver (ok_accum, ok_args, code,
2618 nargs, args);
2619 args[argnum] = val;
2620 next = XINT (args[argnum]);
2621 switch (code)
2622 {
2623 case Aadd:
2624 if (INT_ADD_OVERFLOW (accum, next))
2625 {
2626 overflow = 1;
2627 accum &= INTMASK;
2628 }
2629 accum += next;
2630 break;
2631 case Asub:
2632 if (INT_SUBTRACT_OVERFLOW (accum, next))
2633 {
2634 overflow = 1;
2635 accum &= INTMASK;
2636 }
2637 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2638 break;
2639 case Amult:
2640 if (INT_MULTIPLY_OVERFLOW (accum, next))
2641 {
2642 EMACS_UINT a = accum, b = next, ab = a * b;
2643 overflow = 1;
2644 accum = ab & INTMASK;
2645 }
2646 else
2647 accum *= next;
2648 break;
2649 case Adiv:
2650 if (!argnum)
2651 accum = next;
2652 else
2653 {
2654 if (next == 0)
2655 xsignal0 (Qarith_error);
2656 accum /= next;
2657 }
2658 break;
2659 case Alogand:
2660 accum &= next;
2661 break;
2662 case Alogior:
2663 accum |= next;
2664 break;
2665 case Alogxor:
2666 accum ^= next;
2667 break;
2668 case Amax:
2669 if (!argnum || next > accum)
2670 accum = next;
2671 break;
2672 case Amin:
2673 if (!argnum || next < accum)
2674 accum = next;
2675 break;
2676 }
2677 }
2678
2679 XSETINT (val, accum);
2680 return val;
2681 }
2682
2683 #undef isnan
2684 #define isnan(x) ((x) != (x))
2685
2686 static Lisp_Object
2687 float_arith_driver (double accum, ptrdiff_t argnum, enum arithop code,
2688 ptrdiff_t nargs, Lisp_Object *args)
2689 {
2690 register Lisp_Object val;
2691 double next;
2692
2693 for (; argnum < nargs; argnum++)
2694 {
2695 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2696 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val);
2697
2698 if (FLOATP (val))
2699 {
2700 next = XFLOAT_DATA (val);
2701 }
2702 else
2703 {
2704 args[argnum] = val; /* runs into a compiler bug. */
2705 next = XINT (args[argnum]);
2706 }
2707 switch (code)
2708 {
2709 case Aadd:
2710 accum += next;
2711 break;
2712 case Asub:
2713 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2714 break;
2715 case Amult:
2716 accum *= next;
2717 break;
2718 case Adiv:
2719 if (!argnum)
2720 accum = next;
2721 else
2722 {
2723 if (! IEEE_FLOATING_POINT && next == 0)
2724 xsignal0 (Qarith_error);
2725 accum /= next;
2726 }
2727 break;
2728 case Alogand:
2729 case Alogior:
2730 case Alogxor:
2731 return wrong_type_argument (Qinteger_or_marker_p, val);
2732 case Amax:
2733 if (!argnum || isnan (next) || next > accum)
2734 accum = next;
2735 break;
2736 case Amin:
2737 if (!argnum || isnan (next) || next < accum)
2738 accum = next;
2739 break;
2740 }
2741 }
2742
2743 return make_float (accum);
2744 }
2745
2746
2747 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2748 doc: /* Return sum of any number of arguments, which are numbers or markers.
2749 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2750 (ptrdiff_t nargs, Lisp_Object *args)
2751 {
2752 return arith_driver (Aadd, nargs, args);
2753 }
2754
2755 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2756 doc: /* Negate number or subtract numbers or markers and return the result.
2757 With one arg, negates it. With more than one arg,
2758 subtracts all but the first from the first.
2759 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2760 (ptrdiff_t nargs, Lisp_Object *args)
2761 {
2762 return arith_driver (Asub, nargs, args);
2763 }
2764
2765 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2766 doc: /* Return product of any number of arguments, which are numbers or markers.
2767 usage: (* &rest NUMBERS-OR-MARKERS) */)
2768 (ptrdiff_t nargs, Lisp_Object *args)
2769 {
2770 return arith_driver (Amult, nargs, args);
2771 }
2772
2773 DEFUN ("/", Fquo, Squo, 1, MANY, 0,
2774 doc: /* Return first argument divided by all the remaining arguments.
2775 The arguments must be numbers or markers.
2776 usage: (/ DIVIDEND &rest DIVISORS) */)
2777 (ptrdiff_t nargs, Lisp_Object *args)
2778 {
2779 ptrdiff_t argnum;
2780 for (argnum = 2; argnum < nargs; argnum++)
2781 if (FLOATP (args[argnum]))
2782 return float_arith_driver (0, 0, Adiv, nargs, args);
2783 return arith_driver (Adiv, nargs, args);
2784 }
2785
2786 DEFUN ("%", Frem, Srem, 2, 2, 0,
2787 doc: /* Return remainder of X divided by Y.
2788 Both must be integers or markers. */)
2789 (register Lisp_Object x, Lisp_Object y)
2790 {
2791 Lisp_Object val;
2792
2793 CHECK_NUMBER_COERCE_MARKER (x);
2794 CHECK_NUMBER_COERCE_MARKER (y);
2795
2796 if (XINT (y) == 0)
2797 xsignal0 (Qarith_error);
2798
2799 XSETINT (val, XINT (x) % XINT (y));
2800 return val;
2801 }
2802
2803 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2804 doc: /* Return X modulo Y.
2805 The result falls between zero (inclusive) and Y (exclusive).
2806 Both X and Y must be numbers or markers. */)
2807 (register Lisp_Object x, Lisp_Object y)
2808 {
2809 Lisp_Object val;
2810 EMACS_INT i1, i2;
2811
2812 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x);
2813 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y);
2814
2815 if (FLOATP (x) || FLOATP (y))
2816 return fmod_float (x, y);
2817
2818 i1 = XINT (x);
2819 i2 = XINT (y);
2820
2821 if (i2 == 0)
2822 xsignal0 (Qarith_error);
2823
2824 i1 %= i2;
2825
2826 /* If the "remainder" comes out with the wrong sign, fix it. */
2827 if (i2 < 0 ? i1 > 0 : i1 < 0)
2828 i1 += i2;
2829
2830 XSETINT (val, i1);
2831 return val;
2832 }
2833
2834 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2835 doc: /* Return largest of all the arguments (which must be numbers or markers).
2836 The value is always a number; markers are converted to numbers.
2837 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2838 (ptrdiff_t nargs, Lisp_Object *args)
2839 {
2840 return arith_driver (Amax, nargs, args);
2841 }
2842
2843 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2844 doc: /* Return smallest of all the arguments (which must be numbers or markers).
2845 The value is always a number; markers are converted to numbers.
2846 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2847 (ptrdiff_t nargs, Lisp_Object *args)
2848 {
2849 return arith_driver (Amin, nargs, args);
2850 }
2851
2852 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2853 doc: /* Return bitwise-and of all the arguments.
2854 Arguments may be integers, or markers converted to integers.
2855 usage: (logand &rest INTS-OR-MARKERS) */)
2856 (ptrdiff_t nargs, Lisp_Object *args)
2857 {
2858 return arith_driver (Alogand, nargs, args);
2859 }
2860
2861 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2862 doc: /* Return bitwise-or of all the arguments.
2863 Arguments may be integers, or markers converted to integers.
2864 usage: (logior &rest INTS-OR-MARKERS) */)
2865 (ptrdiff_t nargs, Lisp_Object *args)
2866 {
2867 return arith_driver (Alogior, nargs, args);
2868 }
2869
2870 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2871 doc: /* Return bitwise-exclusive-or of all the arguments.
2872 Arguments may be integers, or markers converted to integers.
2873 usage: (logxor &rest INTS-OR-MARKERS) */)
2874 (ptrdiff_t nargs, Lisp_Object *args)
2875 {
2876 return arith_driver (Alogxor, nargs, args);
2877 }
2878
2879 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2880 doc: /* Return VALUE with its bits shifted left by COUNT.
2881 If COUNT is negative, shifting is actually to the right.
2882 In this case, the sign bit is duplicated. */)
2883 (register Lisp_Object value, Lisp_Object count)
2884 {
2885 register Lisp_Object val;
2886
2887 CHECK_NUMBER (value);
2888 CHECK_NUMBER (count);
2889
2890 if (XINT (count) >= BITS_PER_EMACS_INT)
2891 XSETINT (val, 0);
2892 else if (XINT (count) > 0)
2893 XSETINT (val, XINT (value) << XFASTINT (count));
2894 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2895 XSETINT (val, XINT (value) < 0 ? -1 : 0);
2896 else
2897 XSETINT (val, XINT (value) >> -XINT (count));
2898 return val;
2899 }
2900
2901 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2902 doc: /* Return VALUE with its bits shifted left by COUNT.
2903 If COUNT is negative, shifting is actually to the right.
2904 In this case, zeros are shifted in on the left. */)
2905 (register Lisp_Object value, Lisp_Object count)
2906 {
2907 register Lisp_Object val;
2908
2909 CHECK_NUMBER (value);
2910 CHECK_NUMBER (count);
2911
2912 if (XINT (count) >= BITS_PER_EMACS_INT)
2913 XSETINT (val, 0);
2914 else if (XINT (count) > 0)
2915 XSETINT (val, XUINT (value) << XFASTINT (count));
2916 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2917 XSETINT (val, 0);
2918 else
2919 XSETINT (val, XUINT (value) >> -XINT (count));
2920 return val;
2921 }
2922
2923 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2924 doc: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2925 Markers are converted to integers. */)
2926 (register Lisp_Object number)
2927 {
2928 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2929
2930 if (FLOATP (number))
2931 return (make_float (1.0 + XFLOAT_DATA (number)));
2932
2933 XSETINT (number, XINT (number) + 1);
2934 return number;
2935 }
2936
2937 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2938 doc: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2939 Markers are converted to integers. */)
2940 (register Lisp_Object number)
2941 {
2942 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number);
2943
2944 if (FLOATP (number))
2945 return (make_float (-1.0 + XFLOAT_DATA (number)));
2946
2947 XSETINT (number, XINT (number) - 1);
2948 return number;
2949 }
2950
2951 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2952 doc: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2953 (register Lisp_Object number)
2954 {
2955 CHECK_NUMBER (number);
2956 XSETINT (number, ~XINT (number));
2957 return number;
2958 }
2959
2960 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
2961 doc: /* Return the byteorder for the machine.
2962 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2963 lowercase l) for small endian machines. */)
2964 (void)
2965 {
2966 unsigned i = 0x04030201;
2967 int order = *(char *)&i == 1 ? 108 : 66;
2968
2969 return make_number (order);
2970 }
2971
2972 /* Because we round up the bool vector allocate size to word_size
2973 units, we can safely read past the "end" of the vector in the
2974 operations below. These extra bits are always zero. */
2975
2976 static bits_word
2977 bool_vector_spare_mask (EMACS_INT nr_bits)
2978 {
2979 return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
2980 }
2981
2982 /* Info about unsigned long long, falling back on unsigned long
2983 if unsigned long long is not available. */
2984
2985 #if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_MAX
2986 enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long long) };
2987 # define ULL_MAX ULLONG_MAX
2988 #else
2989 enum { BITS_PER_ULL = CHAR_BIT * sizeof (unsigned long) };
2990 # define ULL_MAX ULONG_MAX
2991 # define count_one_bits_ll count_one_bits_l
2992 # define count_trailing_zeros_ll count_trailing_zeros_l
2993 #endif
2994
2995 /* Shift VAL right by the width of an unsigned long long.
2996 BITS_PER_ULL must be less than BITS_PER_BITS_WORD. */
2997
2998 static bits_word
2999 shift_right_ull (bits_word w)
3000 {
3001 /* Pacify bogus GCC warning about shift count exceeding type width. */
3002 int shift = BITS_PER_ULL - BITS_PER_BITS_WORD < 0 ? BITS_PER_ULL : 0;
3003 return w >> shift;
3004 }
3005
3006 /* Return the number of 1 bits in W. */
3007
3008 static int
3009 count_one_bits_word (bits_word w)
3010 {
3011 if (BITS_WORD_MAX <= UINT_MAX)
3012 return count_one_bits (w);
3013 else if (BITS_WORD_MAX <= ULONG_MAX)
3014 return count_one_bits_l (w);
3015 else
3016 {
3017 int i = 0, count = 0;
3018 while (count += count_one_bits_ll (w),
3019 (i += BITS_PER_ULL) < BITS_PER_BITS_WORD)
3020 w = shift_right_ull (w);
3021 return count;
3022 }
3023 }
3024
3025 enum bool_vector_op { bool_vector_exclusive_or,
3026 bool_vector_union,
3027 bool_vector_intersection,
3028 bool_vector_set_difference,
3029 bool_vector_subsetp };
3030
3031 static Lisp_Object
3032 bool_vector_binop_driver (Lisp_Object a,
3033 Lisp_Object b,
3034 Lisp_Object dest,
3035 enum bool_vector_op op)
3036 {
3037 EMACS_INT nr_bits;
3038 bits_word *adata, *bdata, *destdata;
3039 ptrdiff_t i = 0;
3040 ptrdiff_t nr_words;
3041
3042 CHECK_BOOL_VECTOR (a);
3043 CHECK_BOOL_VECTOR (b);
3044
3045 nr_bits = bool_vector_size (a);
3046 if (bool_vector_size (b) != nr_bits)
3047 wrong_length_argument (a, b, dest);
3048
3049 nr_words = bool_vector_words (nr_bits);
3050 adata = bool_vector_data (a);
3051 bdata = bool_vector_data (b);
3052
3053 if (NILP (dest))
3054 {
3055 dest = make_uninit_bool_vector (nr_bits);
3056 destdata = bool_vector_data (dest);
3057 }
3058 else
3059 {
3060 CHECK_BOOL_VECTOR (dest);
3061 destdata = bool_vector_data (dest);
3062 if (bool_vector_size (dest) != nr_bits)
3063 wrong_length_argument (a, b, dest);
3064
3065 switch (op)
3066 {
3067 case bool_vector_exclusive_or:
3068 for (; i < nr_words; i++)
3069 if (destdata[i] != (adata[i] ^ bdata[i]))
3070 goto set_dest;
3071 break;
3072
3073 case bool_vector_subsetp:
3074 for (; i < nr_words; i++)
3075 if (adata[i] &~ bdata[i])
3076 return Qnil;
3077 return Qt;
3078
3079 case bool_vector_union:
3080 for (; i < nr_words; i++)
3081 if (destdata[i] != (adata[i] | bdata[i]))
3082 goto set_dest;
3083 break;
3084
3085 case bool_vector_intersection:
3086 for (; i < nr_words; i++)
3087 if (destdata[i] != (adata[i] & bdata[i]))
3088 goto set_dest;
3089 break;
3090
3091 case bool_vector_set_difference:
3092 for (; i < nr_words; i++)
3093 if (destdata[i] != (adata[i] &~ bdata[i]))
3094 goto set_dest;
3095 break;
3096 }
3097
3098 return Qnil;
3099 }
3100
3101 set_dest:
3102 switch (op)
3103 {
3104 case bool_vector_exclusive_or:
3105 for (; i < nr_words; i++)
3106 destdata[i] = adata[i] ^ bdata[i];
3107 break;
3108
3109 case bool_vector_union:
3110 for (; i < nr_words; i++)
3111 destdata[i] = adata[i] | bdata[i];
3112 break;
3113
3114 case bool_vector_intersection:
3115 for (; i < nr_words; i++)
3116 destdata[i] = adata[i] & bdata[i];
3117 break;
3118
3119 case bool_vector_set_difference:
3120 for (; i < nr_words; i++)
3121 destdata[i] = adata[i] &~ bdata[i];
3122 break;
3123
3124 default:
3125 eassume (0);
3126 }
3127
3128 return dest;
3129 }
3130
3131 /* PRECONDITION must be true. Return VALUE. This odd construction
3132 works around a bogus GCC diagnostic "shift count >= width of type". */
3133
3134 static int
3135 pre_value (bool precondition, int value)
3136 {
3137 eassume (precondition);
3138 return precondition ? value : 0;
3139 }
3140
3141 /* Compute the number of trailing zero bits in val. If val is zero,
3142 return the number of bits in val. */
3143 static int
3144 count_trailing_zero_bits (bits_word val)
3145 {
3146 if (BITS_WORD_MAX == UINT_MAX)
3147 return count_trailing_zeros (val);
3148 if (BITS_WORD_MAX == ULONG_MAX)
3149 return count_trailing_zeros_l (val);
3150 if (BITS_WORD_MAX == ULL_MAX)
3151 return count_trailing_zeros_ll (val);
3152
3153 /* The rest of this code is for the unlikely platform where bits_word differs
3154 in width from unsigned int, unsigned long, and unsigned long long. */
3155 val |= ~ BITS_WORD_MAX;
3156 if (BITS_WORD_MAX <= UINT_MAX)
3157 return count_trailing_zeros (val);
3158 if (BITS_WORD_MAX <= ULONG_MAX)
3159 return count_trailing_zeros_l (val);
3160 else
3161 {
3162 int count;
3163 for (count = 0;
3164 count < BITS_PER_BITS_WORD - BITS_PER_ULL;
3165 count += BITS_PER_ULL)
3166 {
3167 if (val & ULL_MAX)
3168 return count + count_trailing_zeros_ll (val);
3169 val = shift_right_ull (val);
3170 }
3171
3172 if (BITS_PER_BITS_WORD % BITS_PER_ULL != 0
3173 && BITS_WORD_MAX == (bits_word) -1)
3174 val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX,
3175 BITS_PER_BITS_WORD % BITS_PER_ULL);
3176 return count + count_trailing_zeros_ll (val);
3177 }
3178 }
3179
3180 static bits_word
3181 bits_word_to_host_endian (bits_word val)
3182 {
3183 #ifndef WORDS_BIGENDIAN
3184 return val;
3185 #else
3186 if (BITS_WORD_MAX >> 31 == 1)
3187 return bswap_32 (val);
3188 # if HAVE_UNSIGNED_LONG_LONG
3189 if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
3190 return bswap_64 (val);
3191 # endif
3192 {
3193 int i;
3194 bits_word r = 0;
3195 for (i = 0; i < sizeof val; i++)
3196 {
3197 r = ((r << 1 << (CHAR_BIT - 1))
3198 | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
3199 val = val >> 1 >> (CHAR_BIT - 1);
3200 }
3201 return r;
3202 }
3203 #endif
3204 }
3205
3206 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
3207 Sbool_vector_exclusive_or, 2, 3, 0,
3208 doc: /* Return A ^ B, bitwise exclusive or.
3209 If optional third argument C is given, store result into C.
3210 A, B, and C must be bool vectors of the same length.
3211 Return the destination vector if it changed or nil otherwise. */)
3212 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3213 {
3214 return bool_vector_binop_driver (a, b, c, bool_vector_exclusive_or);
3215 }
3216
3217 DEFUN ("bool-vector-union", Fbool_vector_union,
3218 Sbool_vector_union, 2, 3, 0,
3219 doc: /* Return A | B, bitwise or.
3220 If optional third argument C is given, store result into C.
3221 A, B, and C must be bool vectors of the same length.
3222 Return the destination vector if it changed or nil otherwise. */)
3223 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3224 {
3225 return bool_vector_binop_driver (a, b, c, bool_vector_union);
3226 }
3227
3228 DEFUN ("bool-vector-intersection", Fbool_vector_intersection,
3229 Sbool_vector_intersection, 2, 3, 0,
3230 doc: /* Return A & B, bitwise and.
3231 If optional third argument C is given, store result into C.
3232 A, B, and C must be bool vectors of the same length.
3233 Return the destination vector if it changed or nil otherwise. */)
3234 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3235 {
3236 return bool_vector_binop_driver (a, b, c, bool_vector_intersection);
3237 }
3238
3239 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference,
3240 Sbool_vector_set_difference, 2, 3, 0,
3241 doc: /* Return A &~ B, set difference.
3242 If optional third argument C is given, store result into C.
3243 A, B, and C must be bool vectors of the same length.
3244 Return the destination vector if it changed or nil otherwise. */)
3245 (Lisp_Object a, Lisp_Object b, Lisp_Object c)
3246 {
3247 return bool_vector_binop_driver (a, b, c, bool_vector_set_difference);
3248 }
3249
3250 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp,
3251 Sbool_vector_subsetp, 2, 2, 0,
3252 doc: /* Return t if every t value in A is also t in B, nil otherwise.
3253 A and B must be bool vectors of the same length. */)
3254 (Lisp_Object a, Lisp_Object b)
3255 {
3256 return bool_vector_binop_driver (a, b, b, bool_vector_subsetp);
3257 }
3258
3259 DEFUN ("bool-vector-not", Fbool_vector_not,
3260 Sbool_vector_not, 1, 2, 0,
3261 doc: /* Compute ~A, set complement.
3262 If optional second argument B is given, store result into B.
3263 A and B must be bool vectors of the same length.
3264 Return the destination vector. */)
3265 (Lisp_Object a, Lisp_Object b)
3266 {
3267 EMACS_INT nr_bits;
3268 bits_word *bdata, *adata;
3269 ptrdiff_t i;
3270
3271 CHECK_BOOL_VECTOR (a);
3272 nr_bits = bool_vector_size (a);
3273
3274 if (NILP (b))
3275 b = make_uninit_bool_vector (nr_bits);
3276 else
3277 {
3278 CHECK_BOOL_VECTOR (b);
3279 if (bool_vector_size (b) != nr_bits)
3280 wrong_length_argument (a, b, Qnil);
3281 }
3282
3283 bdata = bool_vector_data (b);
3284 adata = bool_vector_data (a);
3285
3286 for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
3287 bdata[i] = BITS_WORD_MAX & ~adata[i];
3288
3289 if (nr_bits % BITS_PER_BITS_WORD)
3290 {
3291 bits_word mword = bits_word_to_host_endian (adata[i]);
3292 mword = ~mword;
3293 mword &= bool_vector_spare_mask (nr_bits);
3294 bdata[i] = bits_word_to_host_endian (mword);
3295 }
3296
3297 return b;
3298 }
3299
3300 DEFUN ("bool-vector-count-population", Fbool_vector_count_population,
3301 Sbool_vector_count_population, 1, 1, 0,
3302 doc: /* Count how many elements in A are t.
3303 A is a bool vector. To count A's nil elements, subtract the return
3304 value from A's length. */)
3305 (Lisp_Object a)
3306 {
3307 EMACS_INT count;
3308 EMACS_INT nr_bits;
3309 bits_word *adata;
3310 ptrdiff_t i, nwords;
3311
3312 CHECK_BOOL_VECTOR (a);
3313
3314 nr_bits = bool_vector_size (a);
3315 nwords = bool_vector_words (nr_bits);
3316 count = 0;
3317 adata = bool_vector_data (a);
3318
3319 for (i = 0; i < nwords; i++)
3320 count += count_one_bits_word (adata[i]);
3321
3322 return make_number (count);
3323 }
3324
3325 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
3326 Sbool_vector_count_consecutive, 3, 3, 0,
3327 doc: /* Count how many consecutive elements in A equal B starting at I.
3328 A is a bool vector, B is t or nil, and I is an index into A. */)
3329 (Lisp_Object a, Lisp_Object b, Lisp_Object i)
3330 {
3331 EMACS_INT count;
3332 EMACS_INT nr_bits;
3333 int offset;
3334 bits_word *adata;
3335 bits_word twiddle;
3336 bits_word mword; /* Machine word. */
3337 ptrdiff_t pos, pos0;
3338 ptrdiff_t nr_words;
3339
3340 CHECK_BOOL_VECTOR (a);
3341 CHECK_NATNUM (i);
3342
3343 nr_bits = bool_vector_size (a);
3344 if (XFASTINT (i) > nr_bits) /* Allow one past the end for convenience */
3345 args_out_of_range (a, i);
3346
3347 adata = bool_vector_data (a);
3348 nr_words = bool_vector_words (nr_bits);
3349 pos = XFASTINT (i) / BITS_PER_BITS_WORD;
3350 offset = XFASTINT (i) % BITS_PER_BITS_WORD;
3351 count = 0;
3352
3353 /* By XORing with twiddle, we transform the problem of "count
3354 consecutive equal values" into "count the zero bits". The latter
3355 operation usually has hardware support. */
3356 twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
3357
3358 /* Scan the remainder of the mword at the current offset. */
3359 if (pos < nr_words && offset != 0)
3360 {
3361 mword = bits_word_to_host_endian (adata[pos]);
3362 mword ^= twiddle;
3363 mword >>= offset;
3364
3365 /* Do not count the pad bits. */
3366 mword |= (bits_word) 1 << (BITS_PER_BITS_WORD - offset);
3367
3368 count = count_trailing_zero_bits (mword);
3369 pos++;
3370 if (count + offset < BITS_PER_BITS_WORD)
3371 return make_number (count);
3372 }
3373
3374 /* Scan whole words until we either reach the end of the vector or
3375 find an mword that doesn't completely match. twiddle is
3376 endian-independent. */
3377 pos0 = pos;
3378 while (pos < nr_words && adata[pos] == twiddle)
3379 pos++;
3380 count += (pos - pos0) * BITS_PER_BITS_WORD;
3381
3382 if (pos < nr_words)
3383 {
3384 /* If we stopped because of a mismatch, see how many bits match
3385 in the current mword. */
3386 mword = bits_word_to_host_endian (adata[pos]);
3387 mword ^= twiddle;
3388 count += count_trailing_zero_bits (mword);
3389 }
3390 else if (nr_bits % BITS_PER_BITS_WORD != 0)
3391 {
3392 /* If we hit the end, we might have overshot our count. Reduce
3393 the total by the number of spare bits at the end of the
3394 vector. */
3395 count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
3396 }
3397
3398 return make_number (count);
3399 }
3400
3401 \f
3402 void
3403 syms_of_data (void)
3404 {
3405 Lisp_Object error_tail, arith_tail;
3406
3407 DEFSYM (Qquote, "quote");
3408 DEFSYM (Qlambda, "lambda");
3409 DEFSYM (Qsubr, "subr");
3410 DEFSYM (Qerror_conditions, "error-conditions");
3411 DEFSYM (Qerror_message, "error-message");
3412 DEFSYM (Qtop_level, "top-level");
3413
3414 DEFSYM (Qerror, "error");
3415 DEFSYM (Quser_error, "user-error");
3416 DEFSYM (Qquit, "quit");
3417 DEFSYM (Qwrong_length_argument, "wrong-length-argument");
3418 DEFSYM (Qwrong_type_argument, "wrong-type-argument");
3419 DEFSYM (Qargs_out_of_range, "args-out-of-range");
3420 DEFSYM (Qvoid_function, "void-function");
3421 DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
3422 DEFSYM (Qcyclic_variable_indirection, "cyclic-variable-indirection");
3423 DEFSYM (Qvoid_variable, "void-variable");
3424 DEFSYM (Qsetting_constant, "setting-constant");
3425 DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax");
3426
3427 DEFSYM (Qinvalid_function, "invalid-function");
3428 DEFSYM (Qwrong_number_of_arguments, "wrong-number-of-arguments");
3429 DEFSYM (Qno_catch, "no-catch");
3430 DEFSYM (Qend_of_file, "end-of-file");
3431 DEFSYM (Qarith_error, "arith-error");
3432 DEFSYM (Qbeginning_of_buffer, "beginning-of-buffer");
3433 DEFSYM (Qend_of_buffer, "end-of-buffer");
3434 DEFSYM (Qbuffer_read_only, "buffer-read-only");
3435 DEFSYM (Qtext_read_only, "text-read-only");
3436 DEFSYM (Qmark_inactive, "mark-inactive");
3437
3438 DEFSYM (Qlistp, "listp");
3439 DEFSYM (Qconsp, "consp");
3440 DEFSYM (Qsymbolp, "symbolp");
3441 DEFSYM (Qkeywordp, "keywordp");
3442 DEFSYM (Qintegerp, "integerp");
3443 DEFSYM (Qnatnump, "natnump");
3444 DEFSYM (Qwholenump, "wholenump");
3445 DEFSYM (Qstringp, "stringp");
3446 DEFSYM (Qarrayp, "arrayp");
3447 DEFSYM (Qsequencep, "sequencep");
3448 DEFSYM (Qbufferp, "bufferp");
3449 DEFSYM (Qvectorp, "vectorp");
3450 DEFSYM (Qbool_vector_p, "bool-vector-p");
3451 DEFSYM (Qchar_or_string_p, "char-or-string-p");
3452 DEFSYM (Qmarkerp, "markerp");
3453 DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
3454 DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
3455 DEFSYM (Qboundp, "boundp");
3456 DEFSYM (Qfboundp, "fboundp");
3457
3458 DEFSYM (Qfloatp, "floatp");
3459 DEFSYM (Qnumberp, "numberp");
3460 DEFSYM (Qnumber_or_marker_p, "number-or-marker-p");
3461
3462 DEFSYM (Qchar_table_p, "char-table-p");
3463 DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
3464
3465 DEFSYM (Qsubrp, "subrp");
3466 DEFSYM (Qunevalled, "unevalled");
3467 DEFSYM (Qmany, "many");
3468
3469 DEFSYM (Qcdr, "cdr");
3470
3471 /* Handle automatic advice activation. */
3472 DEFSYM (Qad_advice_info, "ad-advice-info");
3473 DEFSYM (Qad_activate_internal, "ad-activate-internal");
3474
3475 error_tail = pure_cons (Qerror, Qnil);
3476
3477 /* ERROR is used as a signaler for random errors for which nothing else is
3478 right. */
3479
3480 Fput (Qerror, Qerror_conditions,
3481 error_tail);
3482 Fput (Qerror, Qerror_message,
3483 build_pure_c_string ("error"));
3484
3485 #define PUT_ERROR(sym, tail, msg) \
3486 Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
3487 Fput (sym, Qerror_message, build_pure_c_string (msg))
3488
3489 PUT_ERROR (Qquit, Qnil, "Quit");
3490
3491 PUT_ERROR (Quser_error, error_tail, "");
3492 PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
3493 PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
3494 PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
3495 PUT_ERROR (Qvoid_function, error_tail,
3496 "Symbol's function definition is void");
3497 PUT_ERROR (Qcyclic_function_indirection, error_tail,
3498 "Symbol's chain of function indirections contains a loop");
3499 PUT_ERROR (Qcyclic_variable_indirection, error_tail,
3500 "Symbol's chain of variable indirections contains a loop");
3501 DEFSYM (Qcircular_list, "circular-list");
3502 PUT_ERROR (Qcircular_list, error_tail, "List contains a loop");
3503 PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void");
3504 PUT_ERROR (Qsetting_constant, error_tail,
3505 "Attempt to set a constant symbol");
3506 PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax");
3507 PUT_ERROR (Qinvalid_function, error_tail, "Invalid function");
3508 PUT_ERROR (Qwrong_number_of_arguments, error_tail,
3509 "Wrong number of arguments");
3510 PUT_ERROR (Qno_catch, error_tail, "No catch for tag");
3511 PUT_ERROR (Qend_of_file, error_tail, "End of file during parsing");
3512
3513 arith_tail = pure_cons (Qarith_error, error_tail);
3514 Fput (Qarith_error, Qerror_conditions, arith_tail);
3515 Fput (Qarith_error, Qerror_message, build_pure_c_string ("Arithmetic error"));
3516
3517 PUT_ERROR (Qbeginning_of_buffer, error_tail, "Beginning of buffer");
3518 PUT_ERROR (Qend_of_buffer, error_tail, "End of buffer");
3519 PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only");
3520 PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail),
3521 "Text is read-only");
3522
3523 DEFSYM (Qrange_error, "range-error");
3524 DEFSYM (Qdomain_error, "domain-error");
3525 DEFSYM (Qsingularity_error, "singularity-error");
3526 DEFSYM (Qoverflow_error, "overflow-error");
3527 DEFSYM (Qunderflow_error, "underflow-error");
3528
3529 PUT_ERROR (Qdomain_error, arith_tail, "Arithmetic domain error");
3530
3531 PUT_ERROR (Qrange_error, arith_tail, "Arithmetic range error");
3532
3533 PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail),
3534 "Arithmetic singularity error");
3535
3536 PUT_ERROR (Qoverflow_error, Fcons (Qdomain_error, arith_tail),
3537 "Arithmetic overflow error");
3538 PUT_ERROR (Qunderflow_error, Fcons (Qdomain_error, arith_tail),
3539 "Arithmetic underflow error");
3540
3541 staticpro (&Qnil);
3542 staticpro (&Qt);
3543 staticpro (&Qunbound);
3544
3545 /* Types that type-of returns. */
3546 DEFSYM (Qinteger, "integer");
3547 DEFSYM (Qsymbol, "symbol");
3548 DEFSYM (Qstring, "string");
3549 DEFSYM (Qcons, "cons");
3550 DEFSYM (Qmarker, "marker");
3551 DEFSYM (Qoverlay, "overlay");
3552 DEFSYM (Qfloat, "float");
3553 DEFSYM (Qwindow_configuration, "window-configuration");
3554 DEFSYM (Qprocess, "process");
3555 DEFSYM (Qwindow, "window");
3556 DEFSYM (Qcompiled_function, "compiled-function");
3557 DEFSYM (Qbuffer, "buffer");
3558 DEFSYM (Qframe, "frame");
3559 DEFSYM (Qvector, "vector");
3560 DEFSYM (Qchar_table, "char-table");
3561 DEFSYM (Qbool_vector, "bool-vector");
3562 DEFSYM (Qhash_table, "hash-table");
3563 DEFSYM (Qmisc, "misc");
3564
3565 DEFSYM (Qdefun, "defun");
3566
3567 DEFSYM (Qfont_spec, "font-spec");
3568 DEFSYM (Qfont_entity, "font-entity");
3569 DEFSYM (Qfont_object, "font-object");
3570
3571 DEFSYM (Qinteractive_form, "interactive-form");
3572 DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
3573
3574 defsubr (&Sindirect_variable);
3575 defsubr (&Sinteractive_form);
3576 defsubr (&Seq);
3577 defsubr (&Snull);
3578 defsubr (&Stype_of);
3579 defsubr (&Slistp);
3580 defsubr (&Snlistp);
3581 defsubr (&Sconsp);
3582 defsubr (&Satom);
3583 defsubr (&Sintegerp);
3584 defsubr (&Sinteger_or_marker_p);
3585 defsubr (&Snumberp);
3586 defsubr (&Snumber_or_marker_p);
3587 defsubr (&Sfloatp);
3588 defsubr (&Snatnump);
3589 defsubr (&Ssymbolp);
3590 defsubr (&Skeywordp);
3591 defsubr (&Sstringp);
3592 defsubr (&Smultibyte_string_p);
3593 defsubr (&Svectorp);
3594 defsubr (&Schar_table_p);
3595 defsubr (&Svector_or_char_table_p);
3596 defsubr (&Sbool_vector_p);
3597 defsubr (&Sarrayp);
3598 defsubr (&Ssequencep);
3599 defsubr (&Sbufferp);
3600 defsubr (&Smarkerp);
3601 defsubr (&Ssubrp);
3602 defsubr (&Sbyte_code_function_p);
3603 defsubr (&Schar_or_string_p);
3604 defsubr (&Scar);
3605 defsubr (&Scdr);
3606 defsubr (&Scar_safe);
3607 defsubr (&Scdr_safe);
3608 defsubr (&Ssetcar);
3609 defsubr (&Ssetcdr);
3610 defsubr (&Ssymbol_function);
3611 defsubr (&Sindirect_function);
3612 defsubr (&Ssymbol_plist);
3613 defsubr (&Ssymbol_name);
3614 defsubr (&Smakunbound);
3615 defsubr (&Sfmakunbound);
3616 defsubr (&Sboundp);
3617 defsubr (&Sfboundp);
3618 defsubr (&Sfset);
3619 defsubr (&Sdefalias);
3620 defsubr (&Ssetplist);
3621 defsubr (&Ssymbol_value);
3622 defsubr (&Sset);
3623 defsubr (&Sdefault_boundp);
3624 defsubr (&Sdefault_value);
3625 defsubr (&Sset_default);
3626 defsubr (&Ssetq_default);
3627 defsubr (&Smake_variable_buffer_local);
3628 defsubr (&Smake_local_variable);
3629 defsubr (&Skill_local_variable);
3630 defsubr (&Smake_variable_frame_local);
3631 defsubr (&Slocal_variable_p);
3632 defsubr (&Slocal_variable_if_set_p);
3633 defsubr (&Svariable_binding_locus);
3634 #if 0 /* XXX Remove this. --lorentey */
3635 defsubr (&Sterminal_local_value);
3636 defsubr (&Sset_terminal_local_value);
3637 #endif
3638 defsubr (&Saref);
3639 defsubr (&Saset);
3640 defsubr (&Snumber_to_string);
3641 defsubr (&Sstring_to_number);
3642 defsubr (&Seqlsign);
3643 defsubr (&Slss);
3644 defsubr (&Sgtr);
3645 defsubr (&Sleq);
3646 defsubr (&Sgeq);
3647 defsubr (&Sneq);
3648 defsubr (&Szerop);
3649 defsubr (&Splus);
3650 defsubr (&Sminus);
3651 defsubr (&Stimes);
3652 defsubr (&Squo);
3653 defsubr (&Srem);
3654 defsubr (&Smod);
3655 defsubr (&Smax);
3656 defsubr (&Smin);
3657 defsubr (&Slogand);
3658 defsubr (&Slogior);
3659 defsubr (&Slogxor);
3660 defsubr (&Slsh);
3661 defsubr (&Sash);
3662 defsubr (&Sadd1);
3663 defsubr (&Ssub1);
3664 defsubr (&Slognot);
3665 defsubr (&Sbyteorder);
3666 defsubr (&Ssubr_arity);
3667 defsubr (&Ssubr_name);
3668
3669 defsubr (&Sbool_vector_exclusive_or);
3670 defsubr (&Sbool_vector_union);
3671 defsubr (&Sbool_vector_intersection);
3672 defsubr (&Sbool_vector_set_difference);
3673 defsubr (&Sbool_vector_not);
3674 defsubr (&Sbool_vector_subsetp);
3675 defsubr (&Sbool_vector_count_consecutive);
3676 defsubr (&Sbool_vector_count_population);
3677
3678 set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->function);
3679
3680 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
3681 doc: /* The largest value that is representable in a Lisp integer. */);
3682 Vmost_positive_fixnum = make_number (MOST_POSITIVE_FIXNUM);
3683 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant = 1;
3684
3685 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum,
3686 doc: /* The smallest value that is representable in a Lisp integer. */);
3687 Vmost_negative_fixnum = make_number (MOST_NEGATIVE_FIXNUM);
3688 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant = 1;
3689 }