root/src/data.c

DEFINITIONS

1. BOOLFWDP
2. INTFWDP
3. KBOARD_OBJFWDP
4. OBJFWDP
5. XBOOLFWD
6. XKBOARD_OBJFWD
7. XFIXNUMFWD
8. XOBJFWD
9. set_blv_found
10. blv_value
11. set_blv_value
12. set_blv_where
13. set_blv_defcell
14. set_blv_valcell
15. wrong_length_argument
16. wrong_type_argument
17. pure_write_error
18. args_out_of_range
19. args_out_of_range_3
20. circular_list
21. DEFUN
22. DEFUN
23. DEFUN
24. DEFUN
25. DEFUN
26. DEFUN
27. DEFUN
28. DEFUN
29. DEFUN
30. DEFUN
31. DEFUN
32. DEFUN
33. DEFUN
34. DEFUN
35. DEFUN
36. DEFUN
37. DEFUN
38. DEFUN
39. DEFUN
40. DEFUN
41. DEFUN
42. DEFUN
43. DEFUN
44. DEFUN
45. DEFUN
46. DEFUN
47. DEFUN
48. DEFUN
49. DEFUN
50. DEFUN
51. DEFUN
52. DEFUN
53. DEFUN
54. DEFUN
55. DEFUN
56. DEFUN
57. DEFUN
58. DEFUN
59. DEFUN
60. DEFUN
61. DEFUN
62. DEFUN
63. DEFUN
64. DEFUN
65. DEFUN
66. DEFUN
67. DEFUN
68. DEFUN
69. DEFUN
70. add_to_function_history
71. defalias
72. DEFUN
73. DEFUN
74. DEFUN
75. DEFUN
76. DEFUN
77. DEFUN
78. DEFUN
79. DEFUN
80. DEFUN
81. DEFUN
82. do_symval_forwarding
83. wrong_choice
84. wrong_range
85. store_symval_forwarding
86. swap_in_global_binding
87. swap_in_symval_forwarding
88. find_symbol_value
89. DEFUN
90. set_internal
91. set_symbol_trapped_write
92. restore_symbol_trapped_write
93. harmonize_variable_watchers
94. DEFUN
95. notify_variable_watchers
96. default_value
97. DEFUN
98. DEFUN
99. set_default_internal
100. make_blv
101. DEFUN
102. DEFUN
103. DEFUN
104. DEFUN
105. indirect_function
106. check_integer_coerce_marker
107. check_number_coerce_marker
108. arithcompare
109. arithcompare_driver
110. cons_to_unsigned
111. cons_to_signed
112. fixnum_to_string
113. DEFUN
114. floating_point_op
115. floatop_arith_driver
116. float_arith_driver
117. bignum_arith_driver
118. arith_driver
119. integer_remainder
120. minmax_driver
121. DEFUN
122. expt_integer
123. DEFUN
124. DEFUN
125. DEFUN
126. DEFUN
127. bool_vector_spare_mask
128. shift_right_ull
129. count_one_bits_word
130. bool_vector_binop_driver
131. pre_value
132. count_trailing_zero_bits
133. bits_word_to_host_endian
134. DEFUN
135. syms_of_data

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