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