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