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 ? blv->local_if_set
  2217       : (forwarded && BUFFER_OBJFWDP (valcontents.fwd)))
  2218     {
  2219       tem = Fboundp (variable);
  2220       /* Make sure the symbol has a local value in this particular buffer,
  2221          by setting it to the same value it already has.  */
  2222       Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
  2223       return variable;
  2224     }
  2225   if (!blv)
  2226     {
  2227       blv = make_blv (sym, forwarded, valcontents);
  2228       sym->u.s.redirect = SYMBOL_LOCALIZED;
  2229       SET_SYMBOL_BLV (sym, blv);
  2230     }
  2231 
  2232   /* Make sure this buffer has its own value of symbol.  */
  2233   XSETSYMBOL (variable, sym);   /* Update in case of aliasing.  */
  2234   tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
  2235   if (NILP (tem))
  2236     {
  2237       if (let_shadows_buffer_binding_p (sym))
  2238         {
  2239           AUTO_STRING (format,
  2240                        "Making %s buffer-local while locally let-bound!");
  2241           CALLN (Fmessage, format, SYMBOL_NAME (variable));
  2242         }
  2243 
  2244       if (BUFFERP (blv->where) && current_buffer == XBUFFER (blv->where))
  2245         /* Make sure the current value is permanently recorded, if it's the
  2246            default value.  */
  2247         swap_in_global_binding (sym);
  2248 
  2249       bset_local_var_alist
  2250         (current_buffer,
  2251          Fcons (Fcons (variable, XCDR (blv->defcell)),
  2252                 BVAR (current_buffer, local_var_alist)));
  2253 
  2254       /* If the symbol forwards into a C variable, then load the binding
  2255          for this buffer now, to preserve the invariant that forwarded
  2256          variables must always hold the value corresponding to the
  2257          current buffer (they are swapped eagerly).
  2258          Otherwise, if C code modifies the variable before we load the
  2259          binding in, then that new value would clobber the default binding
  2260          the next time we unload it.  See bug#34318.  */
  2261       if (blv->fwd.fwdptr)
  2262         swap_in_symval_forwarding (sym, blv);
  2263     }
  2264 
  2265   return variable;
  2266 }
  2267 
  2268 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
  2269        1, 1, "vKill Local Variable: ",
  2270        doc: /* Make VARIABLE no longer have a separate value in the current buffer.
  2271 From now on the default value will apply in this buffer.  Return VARIABLE.  */)
  2272   (register Lisp_Object variable)
  2273 {
  2274   register Lisp_Object tem;
  2275   struct Lisp_Buffer_Local_Value *blv;
  2276   struct Lisp_Symbol *sym;
  2277 
  2278   CHECK_SYMBOL (variable);
  2279   sym = XSYMBOL (variable);
  2280 
  2281  start:
  2282   switch (sym->u.s.redirect)
  2283     {
  2284     case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
  2285     case SYMBOL_PLAINVAL: return variable;
  2286     case SYMBOL_FORWARDED:
  2287       {
  2288         lispfwd valcontents = SYMBOL_FWD (sym);
  2289         if (BUFFER_OBJFWDP (valcontents))
  2290           {
  2291             int offset = XBUFFER_OBJFWD (valcontents)->offset;
  2292             int idx = PER_BUFFER_IDX (offset);
  2293 
  2294             if (idx > 0)
  2295               {
  2296                 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
  2297                 set_per_buffer_value (current_buffer, offset,
  2298                                       per_buffer_default (offset));
  2299               }
  2300           }
  2301         return variable;
  2302       }
  2303     case SYMBOL_LOCALIZED:
  2304       blv = SYMBOL_BLV (sym);
  2305       break;
  2306     default: emacs_abort ();
  2307     }
  2308 
  2309   if (sym->u.s.trapped_write == SYMBOL_TRAPPED_WRITE)
  2310     notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ());
  2311 
  2312   /* Get rid of this buffer's alist element, if any.  */
  2313   XSETSYMBOL (variable, sym);   /* Propagate variable indirection.  */
  2314   tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
  2315   if (!NILP (tem))
  2316     bset_local_var_alist
  2317       (current_buffer,
  2318        Fdelq (tem, BVAR (current_buffer, local_var_alist)));
  2319 
  2320   /* If the symbol is set up with the current buffer's binding
  2321      loaded, recompute its value.  We have to do it now, or else
  2322      forwarded objects won't work right.  */
  2323   {
  2324     Lisp_Object buf; XSETBUFFER (buf, current_buffer);
  2325     if (BASE_EQ (buf, blv->where))
  2326       swap_in_global_binding (sym);
  2327   }
  2328 
  2329   return variable;
  2330 }
  2331 
  2332 /* Lisp functions for creating and removing buffer-local variables.  */
  2333 
  2334 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
  2335        1, 2, 0,
  2336        doc: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
  2337 BUFFER defaults to the current buffer.
  2338 
  2339 Also see `buffer-local-boundp'.*/)
  2340   (Lisp_Object variable, Lisp_Object buffer)
  2341 {
  2342   struct buffer *buf = decode_buffer (buffer);
  2343   struct Lisp_Symbol *sym;
  2344 
  2345   CHECK_SYMBOL (variable);
  2346   sym = XSYMBOL (variable);
  2347 
  2348  start:
  2349   switch (sym->u.s.redirect)
  2350     {
  2351     case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
  2352     case SYMBOL_PLAINVAL: return Qnil;
  2353     case SYMBOL_LOCALIZED:
  2354       {
  2355         Lisp_Object tmp;
  2356         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  2357         XSETBUFFER (tmp, buf);
  2358         XSETSYMBOL (variable, sym); /* Update in case of aliasing.  */
  2359 
  2360         if (EQ (blv->where, tmp)) /* The binding is already loaded.  */
  2361           return blv_found (blv) ? Qt : Qnil;
  2362         else
  2363           return NILP (assq_no_quit (variable, BVAR (buf, local_var_alist)))
  2364             ? Qnil
  2365             : Qt;
  2366       }
  2367     case SYMBOL_FORWARDED:
  2368       {
  2369         lispfwd valcontents = SYMBOL_FWD (sym);
  2370         if (BUFFER_OBJFWDP (valcontents))
  2371           {
  2372             int offset = XBUFFER_OBJFWD (valcontents)->offset;
  2373             int idx = PER_BUFFER_IDX (offset);
  2374             if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
  2375               return Qt;
  2376           }
  2377         return Qnil;
  2378       }
  2379     default: emacs_abort ();
  2380     }
  2381 }
  2382 
  2383 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
  2384        1, 2, 0,
  2385        doc: /* Non-nil if VARIABLE is local in buffer BUFFER when set there.
  2386 BUFFER defaults to the current buffer.
  2387 
  2388 More precisely, return non-nil if either VARIABLE already has a local
  2389 value in BUFFER, or if VARIABLE is automatically buffer-local (see
  2390 `make-variable-buffer-local').  */)
  2391   (register Lisp_Object variable, Lisp_Object buffer)
  2392 {
  2393   struct Lisp_Symbol *sym;
  2394 
  2395   CHECK_SYMBOL (variable);
  2396   sym = XSYMBOL (variable);
  2397 
  2398  start:
  2399   switch (sym->u.s.redirect)
  2400     {
  2401     case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
  2402     case SYMBOL_PLAINVAL: return Qnil;
  2403     case SYMBOL_LOCALIZED:
  2404       {
  2405         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
  2406         if (blv->local_if_set)
  2407           return Qt;
  2408         XSETSYMBOL (variable, sym); /* Update in case of aliasing.  */
  2409         return Flocal_variable_p (variable, buffer);
  2410       }
  2411     case SYMBOL_FORWARDED:
  2412       /* All BUFFER_OBJFWD slots become local if they are set.  */
  2413       return (BUFFER_OBJFWDP (SYMBOL_FWD (sym)) ? Qt : Qnil);
  2414     default: emacs_abort ();
  2415     }
  2416 }
  2417 
  2418 DEFUN ("variable-binding-locus", Fvariable_binding_locus, Svariable_binding_locus,
  2419        1, 1, 0,
  2420        doc: /* Return a value indicating where VARIABLE's current binding comes from.
  2421 If the current binding is buffer-local, the value is the current buffer.
  2422 If the current binding is global (the default), the value is nil.  */)
  2423   (register Lisp_Object variable)
  2424 {
  2425   struct Lisp_Symbol *sym;
  2426 
  2427   CHECK_SYMBOL (variable);
  2428   sym = XSYMBOL (variable);
  2429 
  2430   /* Make sure the current binding is actually swapped in.  */
  2431   find_symbol_value (variable);
  2432 
  2433  start:
  2434   switch (sym->u.s.redirect)
  2435     {
  2436     case SYMBOL_VARALIAS: sym = SYMBOL_ALIAS (sym); goto start;
  2437     case SYMBOL_PLAINVAL: return Qnil;
  2438     case SYMBOL_FORWARDED:
  2439       {
  2440         lispfwd valcontents = SYMBOL_FWD (sym);
  2441         if (KBOARD_OBJFWDP (valcontents))
  2442           return Fframe_terminal (selected_frame);
  2443         else if (!BUFFER_OBJFWDP (valcontents))
  2444           return Qnil;
  2445       }
  2446       FALLTHROUGH;
  2447     case SYMBOL_LOCALIZED:
  2448       /* For a local variable, record both the symbol and which
  2449          buffer's or frame's value we are saving.  */
  2450       if (!NILP (Flocal_variable_p (variable, Qnil)))
  2451         return Fcurrent_buffer ();
  2452       else if (sym->u.s.redirect == SYMBOL_LOCALIZED
  2453                && blv_found (SYMBOL_BLV (sym)))
  2454         return SYMBOL_BLV (sym)->where;
  2455       else
  2456         return Qnil;
  2457     default: emacs_abort ();
  2458     }
  2459 }
  2460 
  2461 
  2462 /* Find the function at the end of a chain of symbol function indirections.  */
  2463 
  2464 /* If OBJECT is a symbol, find the end of its function chain and
  2465    return the value found there.  If OBJECT is not a symbol, just
  2466    return it.  */
  2467 Lisp_Object
  2468 indirect_function (Lisp_Object object)
  2469 {
  2470   while (SYMBOLP (object) && !NILP (object))
  2471     object = XSYMBOL (object)->u.s.function;
  2472   return object;
  2473 }
  2474 
  2475 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
  2476        doc: /* Return the function at the end of OBJECT's function chain.
  2477 If OBJECT is not a symbol, just return it.  Otherwise, follow all
  2478 function indirections to find the final function binding and return it.  */)
  2479   (Lisp_Object object, Lisp_Object noerror)
  2480 {
  2481   return indirect_function (object);
  2482 }
  2483 
  2484 /* Extract and set vector and string elements.  */
  2485 
  2486 DEFUN ("aref", Faref, Saref, 2, 2, 0,
  2487        doc: /* Return the element of ARRAY at index IDX.
  2488 ARRAY may be a vector, a string, a char-table, a bool-vector, a record,
  2489 or a byte-code object.  IDX starts at 0.  */)
  2490   (register Lisp_Object array, Lisp_Object idx)
  2491 {
  2492   register EMACS_INT idxval;
  2493 
  2494   CHECK_FIXNUM (idx);
  2495   idxval = XFIXNUM (idx);
  2496   if (STRINGP (array))
  2497     {
  2498       int c;
  2499       ptrdiff_t idxval_byte;
  2500 
  2501       if (idxval < 0 || idxval >= SCHARS (array))
  2502         args_out_of_range (array, idx);
  2503       if (! STRING_MULTIBYTE (array))
  2504         return make_fixnum ((unsigned char) SREF (array, idxval));
  2505       idxval_byte = string_char_to_byte (array, idxval);
  2506 
  2507       c = STRING_CHAR (SDATA (array) + idxval_byte);
  2508       return make_fixnum (c);
  2509     }
  2510   else if (BOOL_VECTOR_P (array))
  2511     {
  2512       if (idxval < 0 || idxval >= bool_vector_size (array))
  2513         args_out_of_range (array, idx);
  2514       return bool_vector_ref (array, idxval);
  2515     }
  2516   else if (CHAR_TABLE_P (array))
  2517     {
  2518       CHECK_CHARACTER (idx);
  2519       return CHAR_TABLE_REF (array, idxval);
  2520     }
  2521   else
  2522     {
  2523       ptrdiff_t size = 0;
  2524       if (VECTORP (array))
  2525         size = ASIZE (array);
  2526       else if (COMPILEDP (array) || RECORDP (array))
  2527         size = PVSIZE (array);
  2528       else
  2529         wrong_type_argument (Qarrayp, array);
  2530 
  2531       if (idxval < 0 || idxval >= size)
  2532         args_out_of_range (array, idx);
  2533       return AREF (array, idxval);
  2534     }
  2535 }
  2536 
  2537 DEFUN ("aset", Faset, Saset, 3, 3, 0,
  2538        doc: /* Store into the element of ARRAY at index IDX the value NEWELT.
  2539 Return NEWELT.  ARRAY may be a vector, a string, a char-table or a
  2540 bool-vector.  IDX starts at 0.  */)
  2541   (register Lisp_Object array, Lisp_Object idx, Lisp_Object newelt)
  2542 {
  2543   register EMACS_INT idxval;
  2544 
  2545   CHECK_FIXNUM (idx);
  2546   idxval = XFIXNUM (idx);
  2547   if (! RECORDP (array))
  2548     CHECK_ARRAY (array, Qarrayp);
  2549 
  2550   if (VECTORP (array))
  2551     {
  2552       CHECK_IMPURE (array, XVECTOR (array));
  2553       if (idxval < 0 || idxval >= ASIZE (array))
  2554         args_out_of_range (array, idx);
  2555       ASET (array, idxval, newelt);
  2556     }
  2557   else if (BOOL_VECTOR_P (array))
  2558     {
  2559       if (idxval < 0 || idxval >= bool_vector_size (array))
  2560         args_out_of_range (array, idx);
  2561       bool_vector_set (array, idxval, !NILP (newelt));
  2562     }
  2563   else if (CHAR_TABLE_P (array))
  2564     {
  2565       CHECK_CHARACTER (idx);
  2566       CHAR_TABLE_SET (array, idxval, newelt);
  2567     }
  2568   else if (RECORDP (array))
  2569     {
  2570       CHECK_IMPURE (array, XVECTOR (array));
  2571       if (idxval < 0 || idxval >= PVSIZE (array))
  2572         args_out_of_range (array, idx);
  2573       ASET (array, idxval, newelt);
  2574     }
  2575   else /* STRINGP */
  2576     {
  2577       CHECK_IMPURE (array, XSTRING (array));
  2578       if (idxval < 0 || idxval >= SCHARS (array))
  2579         args_out_of_range (array, idx);
  2580       CHECK_CHARACTER (newelt);
  2581       int c = XFIXNAT (newelt);
  2582       ptrdiff_t idxval_byte;
  2583       int prev_bytes;
  2584       unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
  2585 
  2586       if (STRING_MULTIBYTE (array))
  2587         {
  2588           idxval_byte = string_char_to_byte (array, idxval);
  2589           p1 = SDATA (array) + idxval_byte;
  2590           prev_bytes = BYTES_BY_CHAR_HEAD (*p1);
  2591         }
  2592       else if (SINGLE_BYTE_CHAR_P (c))
  2593         {
  2594           SSET (array, idxval, c);
  2595           return newelt;
  2596         }
  2597       else
  2598         {
  2599           for (ptrdiff_t i = SBYTES (array) - 1; i >= 0; i--)
  2600             if (!ASCII_CHAR_P (SREF (array, i)))
  2601               args_out_of_range (array, newelt);
  2602           /* ARRAY is an ASCII string.  Convert it to a multibyte string.  */
  2603           STRING_SET_MULTIBYTE (array);
  2604           idxval_byte = idxval;
  2605           p1 = SDATA (array) + idxval_byte;
  2606           prev_bytes = 1;
  2607         }
  2608 
  2609       int new_bytes = CHAR_STRING (c, p0);
  2610       if (prev_bytes != new_bytes)
  2611         p1 = resize_string_data (array, idxval_byte, prev_bytes, new_bytes);
  2612 
  2613       do
  2614         *p1++ = *p0++;
  2615       while (--new_bytes != 0);
  2616     }
  2617 
  2618   return newelt;
  2619 }
  2620 
  2621 /* Arithmetic functions */
  2622 
  2623 static Lisp_Object
  2624 check_integer_coerce_marker (Lisp_Object x)
  2625 {
  2626   if (MARKERP (x))
  2627     return make_fixnum (marker_position (x));
  2628   CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x);
  2629   return x;
  2630 }
  2631 
  2632 static Lisp_Object
  2633 check_number_coerce_marker (Lisp_Object x)
  2634 {
  2635   if (MARKERP (x))
  2636     return make_fixnum (marker_position (x));
  2637   CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x);
  2638   return x;
  2639 }
  2640 
  2641 Lisp_Object
  2642 arithcompare (Lisp_Object num1, Lisp_Object num2,
  2643               enum Arith_Comparison comparison)
  2644 {
  2645   EMACS_INT i1 = 0, i2 = 0;
  2646   bool lt, eq = true, gt;
  2647   bool test;
  2648 
  2649   num1 = check_number_coerce_marker (num1);
  2650   num2 = check_number_coerce_marker (num2);
  2651 
  2652   /* If the comparison is mostly done by comparing two doubles,
  2653      set LT, EQ, and GT to the <, ==, > results of that comparison,
  2654      respectively, taking care to avoid problems if either is a NaN,
  2655      and trying to avoid problems on platforms where variables (in
  2656      violation of the C standard) can contain excess precision.
  2657      Regardless, set I1 and I2 to integers that break ties if the
  2658      two-double comparison is either not done or reports
  2659      equality.  */
  2660 
  2661   if (FLOATP (num1))
  2662     {
  2663       double f1 = XFLOAT_DATA (num1);
  2664       if (FLOATP (num2))
  2665         {
  2666           double f2 = XFLOAT_DATA (num2);
  2667           lt = f1 < f2;
  2668           eq = f1 == f2;
  2669           gt = f1 > f2;
  2670         }
  2671       else if (FIXNUMP (num2))
  2672         {
  2673           /* Compare a float NUM1 to an integer NUM2 by converting the
  2674              integer I2 (i.e., NUM2) to the double F2 (a conversion that
  2675              can round on some platforms, if I2 is large enough), and then
  2676              converting F2 back to the integer I1 (a conversion that is
  2677              always exact), so that I1 exactly equals ((double) NUM2).  If
  2678              floating-point comparison reports a tie, NUM1 = F1 = F2 = I1
  2679              (exactly) so I1 - I2 = NUM1 - NUM2 (exactly), so comparing I1
  2680              to I2 will break the tie correctly.  */
  2681           double f2 = XFIXNUM (num2);
  2682           lt = f1 < f2;
  2683           eq = f1 == f2;
  2684           gt = f1 > f2;
  2685           i1 = f2;
  2686           i2 = XFIXNUM (num2);
  2687         }
  2688       else if (isnan (f1))
  2689         lt = eq = gt = false;
  2690       else
  2691         i2 = mpz_cmp_d (*xbignum_val (num2), f1);
  2692     }
  2693   else if (FIXNUMP (num1))
  2694     {
  2695       if (FLOATP (num2))
  2696         {
  2697           /* Compare an integer NUM1 to a float NUM2.  This is the
  2698              converse of comparing float to integer (see above).  */
  2699           double f1 = XFIXNUM (num1), f2 = XFLOAT_DATA (num2);
  2700           lt = f1 < f2;
  2701           eq = f1 == f2;
  2702           gt = f1 > f2;
  2703           i1 = XFIXNUM (num1);
  2704           i2 = f1;
  2705         }
  2706       else if (FIXNUMP (num2))
  2707         {
  2708           i1 = XFIXNUM (num1);
  2709           i2 = XFIXNUM (num2);
  2710         }
  2711       else
  2712         i2 = mpz_sgn (*xbignum_val (num2));
  2713     }
  2714   else if (FLOATP (num2))
  2715     {
  2716       double f2 = XFLOAT_DATA (num2);
  2717       if (isnan (f2))
  2718         lt = eq = gt = false;
  2719       else
  2720         i1 = mpz_cmp_d (*xbignum_val (num1), f2);
  2721     }
  2722   else if (FIXNUMP (num2))
  2723     i1 = mpz_sgn (*xbignum_val (num1));
  2724   else
  2725     i1 = mpz_cmp (*xbignum_val (num1), *xbignum_val (num2));
  2726 
  2727   if (eq)
  2728     {
  2729       /* The two-double comparison either reported equality, or was not done.
  2730          Break the tie by comparing the integers.  */
  2731       lt = i1 < i2;
  2732       eq = i1 == i2;
  2733       gt = i1 > i2;
  2734     }
  2735 
  2736   switch (comparison)
  2737     {
  2738     case ARITH_EQUAL:
  2739       test = eq;
  2740       break;
  2741 
  2742     case ARITH_NOTEQUAL:
  2743       test = !eq;
  2744       break;
  2745 
  2746     case ARITH_LESS:
  2747       test = lt;
  2748       break;
  2749 
  2750     case ARITH_LESS_OR_EQUAL:
  2751       test = lt | eq;
  2752       break;
  2753 
  2754     case ARITH_GRTR:
  2755       test = gt;
  2756       break;
  2757 
  2758     case ARITH_GRTR_OR_EQUAL:
  2759       test = gt | eq;
  2760       break;
  2761 
  2762     default:
  2763       eassume (false);
  2764     }
  2765 
  2766   return test ? Qt : Qnil;
  2767 }
  2768 
  2769 static Lisp_Object
  2770 arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
  2771                      enum Arith_Comparison comparison)
  2772 {
  2773   for (ptrdiff_t i = 1; i < nargs; i++)
  2774     if (NILP (arithcompare (args[i - 1], args[i], comparison)))
  2775       return Qnil;
  2776   return Qt;
  2777 }
  2778 
  2779 DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
  2780        doc: /* Return t if args, all numbers or markers, are equal.
  2781 usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2782   (ptrdiff_t nargs, Lisp_Object *args)
  2783 {
  2784   return arithcompare_driver (nargs, args, ARITH_EQUAL);
  2785 }
  2786 
  2787 DEFUN ("<", Flss, Slss, 1, MANY, 0,
  2788        doc: /* Return t if each arg (a number or marker), is less than the next arg.
  2789 usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2790   (ptrdiff_t nargs, Lisp_Object *args)
  2791 {
  2792   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2793     return XFIXNUM (args[0]) < XFIXNUM (args[1]) ? Qt : Qnil;
  2794 
  2795   return arithcompare_driver (nargs, args, ARITH_LESS);
  2796 }
  2797 
  2798 DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
  2799        doc: /* Return t if each arg (a number or marker) is greater than the next arg.
  2800 usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2801   (ptrdiff_t nargs, Lisp_Object *args)
  2802 {
  2803   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2804     return XFIXNUM (args[0]) > XFIXNUM (args[1]) ? Qt : Qnil;
  2805 
  2806   return arithcompare_driver (nargs, args, ARITH_GRTR);
  2807 }
  2808 
  2809 DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
  2810        doc: /* Return t if each arg (a number or marker) is less than or equal to the next.
  2811 usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2812   (ptrdiff_t nargs, Lisp_Object *args)
  2813 {
  2814   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2815     return XFIXNUM (args[0]) <= XFIXNUM (args[1]) ? Qt : Qnil;
  2816 
  2817   return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
  2818 }
  2819 
  2820 DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
  2821        doc: /* Return t if each arg (a number or marker) is greater than or equal to the next.
  2822 usage: (>= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  2823   (ptrdiff_t nargs, Lisp_Object *args)
  2824 {
  2825   if (nargs == 2 && FIXNUMP (args[0]) && FIXNUMP (args[1]))
  2826     return XFIXNUM (args[0]) >= XFIXNUM (args[1]) ? Qt : Qnil;
  2827 
  2828   return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
  2829 }
  2830 
  2831 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
  2832        doc: /* Return t if first arg is not equal to second arg.  Both must be numbers or markers.  */)
  2833   (register Lisp_Object num1, Lisp_Object num2)
  2834 {
  2835   return arithcompare (num1, num2, ARITH_NOTEQUAL);
  2836 }
  2837 
  2838 /* Convert the cons-of-integers, integer, or float value C to an
  2839    unsigned value with maximum value MAX, where MAX is one less than a
  2840    power of 2.  Signal an error if C does not have a valid format or
  2841    is out of range.
  2842 
  2843    Although Emacs represents large integers with bignums instead of
  2844    cons-of-integers or floats, for now this function still accepts the
  2845    obsolete forms in case some old Lisp code still generates them.  */
  2846 uintmax_t
  2847 cons_to_unsigned (Lisp_Object c, uintmax_t max)
  2848 {
  2849   bool valid = false;
  2850   uintmax_t val UNINIT;
  2851 
  2852   if (FLOATP (c))
  2853     {
  2854       double d = XFLOAT_DATA (c);
  2855       if (d >= 0 && d < 1.0 + max)
  2856         {
  2857           val = d;
  2858           valid = val == d;
  2859         }
  2860     }
  2861   else
  2862     {
  2863       Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
  2864       valid = INTEGERP (hi) && integer_to_uintmax (hi, &val);
  2865 
  2866       if (valid && CONSP (c))
  2867         {
  2868           uintmax_t top = val;
  2869           Lisp_Object rest = XCDR (c);
  2870           if (top <= UINTMAX_MAX >> 24 >> 16
  2871               && CONSP (rest)
  2872               && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24
  2873               && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16)
  2874             {
  2875               uintmax_t mid = XFIXNAT (XCAR (rest));
  2876               val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest));
  2877             }
  2878           else
  2879             {
  2880               valid = top <= UINTMAX_MAX >> 16;
  2881               if (valid)
  2882                 {
  2883                   if (CONSP (rest))
  2884                     rest = XCAR (rest);
  2885                   valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16;
  2886                   if (valid)
  2887                     val = top << 16 | XFIXNAT (rest);
  2888                 }
  2889             }
  2890         }
  2891     }
  2892 
  2893   if (! (valid && val <= max))
  2894     error ("Not an in-range integer, integral float, or cons of integers");
  2895   return val;
  2896 }
  2897 
  2898 /* Convert the cons-of-integers, integer, or float value C to a signed
  2899    value with extrema MIN and MAX.  MAX should be one less than a
  2900    power of 2, and MIN should be zero or the negative of a power of 2.
  2901    Signal an error if C does not have a valid format or is out of
  2902    range.
  2903 
  2904    Although Emacs represents large integers with bignums instead of
  2905    cons-of-integers or floats, for now this function still accepts the
  2906    obsolete forms in case some old Lisp code still generates them.  */
  2907 intmax_t
  2908 cons_to_signed (Lisp_Object c, intmax_t min, intmax_t max)
  2909 {
  2910   bool valid = false;
  2911   intmax_t val UNINIT;
  2912 
  2913   if (FLOATP (c))
  2914     {
  2915       double d = XFLOAT_DATA (c);
  2916       if (d >= min && d < 1.0 + max)
  2917         {
  2918           val = d;
  2919           valid = val == d;
  2920         }
  2921     }
  2922   else
  2923     {
  2924       Lisp_Object hi = CONSP (c) ? XCAR (c) : c;
  2925       valid = INTEGERP (hi) && integer_to_intmax (hi, &val);
  2926 
  2927       if (valid && CONSP (c))
  2928         {
  2929           intmax_t top = val;
  2930           Lisp_Object rest = XCDR (c);
  2931           if (top >= INTMAX_MIN >> 24 >> 16 && top <= INTMAX_MAX >> 24 >> 16
  2932               && CONSP (rest)
  2933               && FIXNATP (XCAR (rest)) && XFIXNAT (XCAR (rest)) < 1 << 24
  2934               && FIXNATP (XCDR (rest)) && XFIXNAT (XCDR (rest)) < 1 << 16)
  2935             {
  2936               intmax_t mid = XFIXNAT (XCAR (rest));
  2937               val = top << 24 << 16 | mid << 16 | XFIXNAT (XCDR (rest));
  2938             }
  2939           else
  2940             {
  2941               valid = INTMAX_MIN >> 16 <= top && top <= INTMAX_MAX >> 16;
  2942               if (valid)
  2943                 {
  2944                   if (CONSP (rest))
  2945                     rest = XCAR (rest);
  2946                   valid = FIXNATP (rest) && XFIXNAT (rest) < 1 << 16;
  2947                   if (valid)
  2948                     val = top << 16 | XFIXNAT (rest);
  2949                 }
  2950             }
  2951         }
  2952     }
  2953 
  2954   if (! (valid && min <= val && val <= max))
  2955     error ("Not an in-range integer, integral float, or cons of integers");
  2956   return val;
  2957 }
  2958 
  2959 /* Render NUMBER in decimal into BUFFER which ends right before END.
  2960    Return the start of the string; the end is always at END.
  2961    The string is not null-terminated.  */
  2962 char *
  2963 fixnum_to_string (EMACS_INT number, char *buffer, char *end)
  2964 {
  2965   EMACS_INT x = number;
  2966   bool negative = x < 0;
  2967   if (negative)
  2968     x = -x;
  2969   char *p = end;
  2970   do
  2971     {
  2972       eassume (p > buffer && p - 1 < end);
  2973       *--p = '0' + x % 10;
  2974       x /= 10;
  2975     }
  2976   while (x);
  2977   if (negative)
  2978     *--p = '-';
  2979   return p;
  2980 }
  2981 
  2982 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
  2983        doc: /* Return the decimal representation of NUMBER as a string.
  2984 Uses a minus sign if negative.
  2985 NUMBER may be an integer or a floating point number.  */)
  2986   (Lisp_Object number)
  2987 {
  2988   char buffer[max (FLOAT_TO_STRING_BUFSIZE, INT_BUFSIZE_BOUND (EMACS_INT))];
  2989 
  2990   if (FIXNUMP (number))
  2991     {
  2992       char *end = buffer + sizeof buffer;
  2993       char *p = fixnum_to_string (XFIXNUM (number), buffer, end);
  2994       return make_unibyte_string (p, end - p);
  2995     }
  2996 
  2997   if (BIGNUMP (number))
  2998     return bignum_to_string (number, 10);
  2999 
  3000   if (FLOATP (number))
  3001     return make_unibyte_string (buffer,
  3002                                 float_to_string (buffer, XFLOAT_DATA (number)));
  3003 
  3004   wrong_type_argument (Qnumberp, number);
  3005 }
  3006 
  3007 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
  3008        doc: /* Parse STRING as a decimal number and return the number.
  3009 Ignore leading spaces and tabs, and all trailing chars.  Return 0 if
  3010 STRING cannot be parsed as an integer or floating point number.
  3011 
  3012 If BASE, interpret STRING as a number in that base.  If BASE isn't
  3013 present, base 10 is used.  BASE must be between 2 and 16 (inclusive).
  3014 If the base used is not 10, STRING is always parsed as an integer.  */)
  3015   (register Lisp_Object string, Lisp_Object base)
  3016 {
  3017   int b;
  3018 
  3019   CHECK_STRING (string);
  3020 
  3021   if (NILP (base))
  3022     b = 10;
  3023   else
  3024     {
  3025       CHECK_FIXNUM (base);
  3026       if (! (XFIXNUM (base) >= 2 && XFIXNUM (base) <= 16))
  3027         xsignal1 (Qargs_out_of_range, base);
  3028       b = XFIXNUM (base);
  3029     }
  3030 
  3031   char *p = SSDATA (string);
  3032   while (*p == ' ' || *p == '\t')
  3033     p++;
  3034 
  3035   Lisp_Object val = string_to_number (p, b, 0);
  3036   return ((IEEE_FLOATING_POINT ? NILP (val) : !NUMBERP (val))
  3037           ? make_fixnum (0) : val);
  3038 }
  3039 
  3040 enum arithop
  3041   {
  3042     Aadd,
  3043     Asub,
  3044     Amult,
  3045     Adiv,
  3046     Alogand,
  3047     Alogior,
  3048     Alogxor
  3049   };
  3050 static bool
  3051 floating_point_op (enum arithop code)
  3052 {
  3053   return code <= Adiv;
  3054 }
  3055 
  3056 /* Return the result of applying the floating-point operation CODE to
  3057    the NARGS arguments starting at ARGS.  If ARGNUM is positive,
  3058    ARGNUM of the arguments were already consumed, yielding ACCUM.
  3059    0 <= ARGNUM < NARGS, 2 <= NARGS, and NEXT is the value of
  3060    ARGS[ARGSNUM], converted to double.  */
  3061 
  3062 static Lisp_Object
  3063 floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3064                       ptrdiff_t argnum, double accum, double next)
  3065 {
  3066   if (argnum == 0)
  3067     {
  3068       accum = next;
  3069       goto next_arg;
  3070     }
  3071 
  3072   while (true)
  3073     {
  3074       switch (code)
  3075         {
  3076         case Aadd : accum += next; break;
  3077         case Asub : accum -= next; break;
  3078         case Amult: accum *= next; break;
  3079         case Adiv:
  3080           if (! IEEE_FLOATING_POINT && next == 0)
  3081             xsignal0 (Qarith_error);
  3082           accum /= next;
  3083           break;
  3084         default: eassume (false);
  3085         }
  3086 
  3087     next_arg:
  3088       argnum++;
  3089       if (argnum == nargs)
  3090         return make_float (accum);
  3091       next = XFLOATINT (check_number_coerce_marker (args[argnum]));
  3092     }
  3093 }
  3094 
  3095 /* Like floatop_arith_driver, except CODE might not be a floating-point
  3096    operation, and NEXT is a Lisp float rather than a C double.  */
  3097 
  3098 static Lisp_Object
  3099 float_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3100                     ptrdiff_t argnum, double accum, Lisp_Object next)
  3101 {
  3102   if (! floating_point_op (code))
  3103     wrong_type_argument (Qinteger_or_marker_p, next);
  3104   return floatop_arith_driver (code, nargs, args, argnum, accum,
  3105                                XFLOAT_DATA (next));
  3106 }
  3107 
  3108 /* Return the result of applying the arithmetic operation CODE to the
  3109    NARGS arguments starting at ARGS.  If ARGNUM is positive, ARGNUM of
  3110    the arguments were already consumed, yielding IACCUM.  0 <= ARGNUM
  3111    < NARGS, 2 <= NARGS, and VAL is the value of ARGS[ARGSNUM],
  3112    converted to integer.  */
  3113 
  3114 static Lisp_Object
  3115 bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3116                      ptrdiff_t argnum, intmax_t iaccum, Lisp_Object val)
  3117 {
  3118   mpz_t const *accum;
  3119   if (argnum == 0)
  3120     {
  3121       accum = bignum_integer (&mpz[0], val);
  3122       goto next_arg;
  3123     }
  3124   mpz_set_intmax (mpz[0], iaccum);
  3125   accum = &mpz[0];
  3126 
  3127   while (true)
  3128     {
  3129       mpz_t const *next = bignum_integer (&mpz[1], val);
  3130 
  3131       switch (code)
  3132         {
  3133         case Aadd   :       mpz_add (mpz[0], *accum, *next); break;
  3134         case Asub   :       mpz_sub (mpz[0], *accum, *next); break;
  3135         case Amult  : emacs_mpz_mul (mpz[0], *accum, *next); break;
  3136         case Alogand:       mpz_and (mpz[0], *accum, *next); break;
  3137         case Alogior:       mpz_ior (mpz[0], *accum, *next); break;
  3138         case Alogxor:       mpz_xor (mpz[0], *accum, *next); break;
  3139         case Adiv:
  3140           if (mpz_sgn (*next) == 0)
  3141             xsignal0 (Qarith_error);
  3142           mpz_tdiv_q (mpz[0], *accum, *next);
  3143           break;
  3144         default:
  3145           eassume (false);
  3146         }
  3147       accum = &mpz[0];
  3148 
  3149     next_arg:
  3150       argnum++;
  3151       if (argnum == nargs)
  3152         return make_integer_mpz ();
  3153       val = check_number_coerce_marker (args[argnum]);
  3154       if (FLOATP (val))
  3155         return float_arith_driver (code, nargs, args, argnum,
  3156                                    mpz_get_d_rounded (*accum), val);
  3157     }
  3158 }
  3159 
  3160 /* Return the result of applying the arithmetic operation CODE to the
  3161    NARGS arguments starting at ARGS, with the first argument being the
  3162    number VAL.  2 <= NARGS.  Check that the remaining arguments are
  3163    numbers or markers.  */
  3164 
  3165 static Lisp_Object
  3166 arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args,
  3167               Lisp_Object val)
  3168 {
  3169   eassume (2 <= nargs);
  3170 
  3171   ptrdiff_t argnum = 0;
  3172   /* Set ACCUM to VAL's value if it is a fixnum, otherwise to some
  3173      ignored value to avoid using an uninitialized variable later.  */
  3174   intmax_t accum = XFIXNUM_RAW (val);
  3175 
  3176   if (FIXNUMP (val))
  3177     while (true)
  3178       {
  3179         argnum++;
  3180         if (argnum == nargs)
  3181           return make_int (accum);
  3182         val = check_number_coerce_marker (args[argnum]);
  3183 
  3184         /* Set NEXT to the next value if it fits, else exit the loop.  */
  3185         intmax_t next;
  3186         if (! (INTEGERP (val) && integer_to_intmax (val, &next)))
  3187           break;
  3188 
  3189         /* Set ACCUM to the next operation's result if it fits,
  3190            else exit the loop.  */
  3191         bool overflow;
  3192         intmax_t a;
  3193         switch (code)
  3194           {
  3195           case Aadd : overflow = ckd_add (&a, accum, next); break;
  3196           case Amult: overflow = ckd_mul (&a, accum, next); break;
  3197           case Asub : overflow = ckd_sub (&a, accum, next); break;
  3198           case Adiv:
  3199             if (next == 0)
  3200               xsignal0 (Qarith_error);
  3201             /* This cannot overflow, as integer overflow can
  3202                occur only if the dividend is INTMAX_MIN, but
  3203                INTMAX_MIN < MOST_NEGATIVE_FIXNUM <= accum.  */
  3204             accum /= next;
  3205             continue;
  3206           case Alogand: accum &= next; continue;
  3207           case Alogior: accum |= next; continue;
  3208           case Alogxor: accum ^= next; continue;
  3209           default: eassume (false);
  3210           }
  3211         if (overflow)
  3212           break;
  3213         accum = a;
  3214       }
  3215 
  3216   return (FLOATP (val)
  3217           ? float_arith_driver (code, nargs, args, argnum, accum, val)
  3218           : bignum_arith_driver (code, nargs, args, argnum, accum, val));
  3219 }
  3220 
  3221 
  3222 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
  3223        doc: /* Return sum of any number of arguments, which are numbers or markers.
  3224 usage: (+ &rest NUMBERS-OR-MARKERS)  */)
  3225   (ptrdiff_t nargs, Lisp_Object *args)
  3226 {
  3227   if (nargs == 0)
  3228     return make_fixnum (0);
  3229   Lisp_Object a = check_number_coerce_marker (args[0]);
  3230   return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a);
  3231 }
  3232 
  3233 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
  3234        doc: /* Negate number or subtract numbers or markers and return the result.
  3235 With one arg, negates it.  With more than one arg,
  3236 subtracts all but the first from the first.
  3237 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS)  */)
  3238   (ptrdiff_t nargs, Lisp_Object *args)
  3239 {
  3240   if (nargs == 0)
  3241     return make_fixnum (0);
  3242   Lisp_Object a = check_number_coerce_marker (args[0]);
  3243   if (nargs == 1)
  3244     {
  3245       if (FIXNUMP (a))
  3246         return make_int (-XFIXNUM (a));
  3247       if (FLOATP (a))
  3248         return make_float (-XFLOAT_DATA (a));
  3249       mpz_neg (mpz[0], *xbignum_val (a));
  3250       return make_integer_mpz ();
  3251     }
  3252   return arith_driver (Asub, nargs, args, a);
  3253 }
  3254 
  3255 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
  3256        doc: /* Return product of any number of arguments, which are numbers or markers.
  3257 usage: (* &rest NUMBERS-OR-MARKERS)  */)
  3258   (ptrdiff_t nargs, Lisp_Object *args)
  3259 {
  3260   if (nargs == 0)
  3261     return make_fixnum (1);
  3262   Lisp_Object a = check_number_coerce_marker (args[0]);
  3263   return nargs == 1 ? a : arith_driver (Amult, nargs, args, a);
  3264 }
  3265 
  3266 DEFUN ("/", Fquo, Squo, 1, MANY, 0,
  3267        doc: /* Divide number by divisors and return the result.
  3268 With two or more arguments, return first argument divided by the rest.
  3269 With one argument, return 1 divided by the argument.
  3270 The arguments must be numbers or markers.
  3271 usage: (/ NUMBER &rest DIVISORS)  */)
  3272   (ptrdiff_t nargs, Lisp_Object *args)
  3273 {
  3274   Lisp_Object a = check_number_coerce_marker (args[0]);
  3275   if (nargs == 1)
  3276     {
  3277       if (FIXNUMP (a))
  3278         {
  3279           if (XFIXNUM (a) == 0)
  3280             xsignal0 (Qarith_error);
  3281           return make_fixnum (1 / XFIXNUM (a));
  3282         }
  3283       if (FLOATP (a))
  3284         {
  3285           if (! IEEE_FLOATING_POINT && XFLOAT_DATA (a) == 0)
  3286             xsignal0 (Qarith_error);
  3287           return make_float (1 / XFLOAT_DATA (a));
  3288         }
  3289       /* Dividing 1 by any bignum yields 0.  */
  3290       return make_fixnum (0);
  3291     }
  3292 
  3293   /* Do all computation in floating-point if any arg is a float.  */
  3294   for (ptrdiff_t argnum = 2; argnum < nargs; argnum++)
  3295     if (FLOATP (args[argnum]))
  3296       return floatop_arith_driver (Adiv, nargs, args, 0, 0, XFLOATINT (a));
  3297   return arith_driver (Adiv, nargs, args, a);
  3298 }
  3299 
  3300 /* Return NUM % DEN (or NUM mod DEN, if MODULO).  NUM and DEN must be
  3301    integers.  */
  3302 static Lisp_Object
  3303 integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo)
  3304 {
  3305   if (FIXNUMP (den))
  3306     {
  3307       EMACS_INT d = XFIXNUM (den);
  3308       if (d == 0)
  3309         xsignal0 (Qarith_error);
  3310 
  3311       EMACS_INT r;
  3312       bool have_r = false;
  3313       if (FIXNUMP (num))
  3314         {
  3315           r = XFIXNUM (num) % d;
  3316           have_r = true;
  3317         }
  3318       else if (eabs (d) <= ULONG_MAX)
  3319         {
  3320           mpz_t const *n = xbignum_val (num);
  3321           bool neg_n = mpz_sgn (*n) < 0;
  3322           r = mpz_tdiv_ui (*n, eabs (d));
  3323           if (neg_n)
  3324             r = -r;
  3325           have_r = true;
  3326         }
  3327 
  3328       if (have_r)
  3329         {
  3330           /* If MODULO and the remainder has the wrong sign, fix it.  */
  3331           if (modulo && (d < 0 ? r > 0 : r < 0))
  3332             r += d;
  3333 
  3334           return make_fixnum (r);
  3335         }
  3336     }
  3337 
  3338   mpz_t const *d = bignum_integer (&mpz[1], den);
  3339   mpz_t *r = &mpz[0];
  3340   mpz_tdiv_r (*r, *bignum_integer (&mpz[0], num), *d);
  3341 
  3342   if (modulo)
  3343     {
  3344       /* If the remainder has the wrong sign, fix it.  */
  3345       int sgn_r = mpz_sgn (*r);
  3346       if (mpz_sgn (*d) < 0 ? sgn_r > 0 : sgn_r < 0)
  3347         mpz_add (*r, *r, *d);
  3348     }
  3349 
  3350   return make_integer_mpz ();
  3351 }
  3352 
  3353 DEFUN ("%", Frem, Srem, 2, 2, 0,
  3354        doc: /* Return remainder of X divided by Y.
  3355 Both must be integers or markers.  */)
  3356   (Lisp_Object x, Lisp_Object y)
  3357 {
  3358   x = check_integer_coerce_marker (x);
  3359   y = check_integer_coerce_marker (y);
  3360   return integer_remainder (x, y, false);
  3361 }
  3362 
  3363 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
  3364        doc: /* Return X modulo Y.
  3365 The result falls between zero (inclusive) and Y (exclusive).
  3366 Both X and Y must be numbers or markers.  */)
  3367   (Lisp_Object x, Lisp_Object y)
  3368 {
  3369   x = check_number_coerce_marker (x);
  3370   y = check_number_coerce_marker (y);
  3371   if (FLOATP (x) || FLOATP (y))
  3372     return fmod_float (x, y);
  3373   return integer_remainder (x, y, true);
  3374 }
  3375 
  3376 static Lisp_Object
  3377 minmax_driver (ptrdiff_t nargs, Lisp_Object *args,
  3378                enum Arith_Comparison comparison)
  3379 {
  3380   Lisp_Object accum = check_number_coerce_marker (args[0]);
  3381   for (ptrdiff_t argnum = 1; argnum < nargs; argnum++)
  3382     {
  3383       Lisp_Object val = check_number_coerce_marker (args[argnum]);
  3384       if (!NILP (arithcompare (val, accum, comparison)))
  3385         accum = val;
  3386       else if (FLOATP (val) && isnan (XFLOAT_DATA (val)))
  3387         return val;
  3388     }
  3389   return accum;
  3390 }
  3391 
  3392 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
  3393        doc: /* Return largest of all the arguments (which must be numbers or markers).
  3394 The value is always a number; markers are converted to numbers.
  3395 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  3396   (ptrdiff_t nargs, Lisp_Object *args)
  3397 {
  3398   return minmax_driver (nargs, args, ARITH_GRTR);
  3399 }
  3400 
  3401 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
  3402        doc: /* Return smallest of all the arguments (which must be numbers or markers).
  3403 The value is always a number; markers are converted to numbers.
  3404 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
  3405   (ptrdiff_t nargs, Lisp_Object *args)
  3406 {
  3407   return minmax_driver (nargs, args, ARITH_LESS);
  3408 }
  3409 
  3410 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
  3411        doc: /* Return bitwise-and of all the arguments.
  3412 Arguments may be integers, or markers converted to integers.
  3413 usage: (logand &rest INTS-OR-MARKERS)  */)
  3414   (ptrdiff_t nargs, Lisp_Object *args)
  3415 {
  3416   if (nargs == 0)
  3417     return make_fixnum (-1);
  3418   Lisp_Object a = check_integer_coerce_marker (args[0]);
  3419   return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a);
  3420 }
  3421 
  3422 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
  3423        doc: /* Return bitwise-or of all the arguments.
  3424 Arguments may be integers, or markers converted to integers.
  3425 usage: (logior &rest INTS-OR-MARKERS)  */)
  3426   (ptrdiff_t nargs, Lisp_Object *args)
  3427 {
  3428   if (nargs == 0)
  3429     return make_fixnum (0);
  3430   Lisp_Object a = check_integer_coerce_marker (args[0]);
  3431   return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a);
  3432 }
  3433 
  3434 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
  3435        doc: /* Return bitwise-exclusive-or of all the arguments.
  3436 Arguments may be integers, or markers converted to integers.
  3437 usage: (logxor &rest INTS-OR-MARKERS)  */)
  3438   (ptrdiff_t nargs, Lisp_Object *args)
  3439 {
  3440   if (nargs == 0)
  3441     return make_fixnum (0);
  3442   Lisp_Object a = check_integer_coerce_marker (args[0]);
  3443   return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a);
  3444 }
  3445 
  3446 DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0,
  3447        doc: /* Return population count of VALUE.
  3448 This is the number of one bits in the two's complement representation
  3449 of VALUE.  If VALUE is negative, return the number of zero bits in the
  3450 representation.  */)
  3451   (Lisp_Object value)
  3452 {
  3453   CHECK_INTEGER (value);
  3454 
  3455   if (BIGNUMP (value))
  3456     {
  3457       mpz_t const *nonneg = xbignum_val (value);
  3458       if (mpz_sgn (*nonneg) < 0)
  3459         {
  3460           mpz_com (mpz[0], *nonneg);
  3461           nonneg = &mpz[0];
  3462         }
  3463       return make_fixnum (mpz_popcount (*nonneg));
  3464     }
  3465 
  3466   eassume (FIXNUMP (value));
  3467   EMACS_INT v = XFIXNUM (value) < 0 ? -1 - XFIXNUM (value) : XFIXNUM (value);
  3468   return make_fixnum (EMACS_UINT_WIDTH <= UINT_WIDTH
  3469                       ? count_one_bits (v)
  3470                       : EMACS_UINT_WIDTH <= ULONG_WIDTH
  3471                       ? count_one_bits_l (v)
  3472                       : count_one_bits_ll (v));
  3473 }
  3474 
  3475 DEFUN ("ash", Fash, Sash, 2, 2, 0,
  3476        doc: /* Return integer VALUE with its bits shifted left by COUNT bit positions.
  3477 If COUNT is negative, shift VALUE to the right instead.
  3478 VALUE and COUNT must be integers.
  3479 Mathematically, the return value is VALUE multiplied by 2 to the
  3480 power of COUNT, rounded down.  If the result is non-zero, its sign
  3481 is the same as that of VALUE.
  3482 In terms of bits, when COUNT is positive, the function moves
  3483 the bits of VALUE to the left, adding zero bits on the right; when
  3484 COUNT is negative, it moves the bits of VALUE to the right,
  3485 discarding bits.  */)
  3486   (Lisp_Object value, Lisp_Object count)
  3487 {
  3488   CHECK_INTEGER (value);
  3489   CHECK_INTEGER (count);
  3490 
  3491   if (! FIXNUMP (count))
  3492     {
  3493       if (BASE_EQ (value, make_fixnum (0)))
  3494         return value;
  3495       if (mpz_sgn (*xbignum_val (count)) < 0)
  3496         {
  3497           EMACS_INT v = (FIXNUMP (value) ? XFIXNUM (value)
  3498                          : mpz_sgn (*xbignum_val (value)));
  3499           return make_fixnum (v < 0 ? -1 : 0);
  3500         }
  3501       overflow_error ();
  3502     }
  3503 
  3504   if (XFIXNUM (count) <= 0)
  3505     {
  3506       if (XFIXNUM (count) == 0)
  3507         return value;
  3508 
  3509       if ((EMACS_INT) -1 >> 1 == -1 && FIXNUMP (value))
  3510         {
  3511           EMACS_INT shift = -XFIXNUM (count);
  3512           EMACS_INT result
  3513             = (shift < EMACS_INT_WIDTH ? XFIXNUM (value) >> shift
  3514                : XFIXNUM (value) < 0 ? -1 : 0);
  3515           return make_fixnum (result);
  3516         }
  3517     }
  3518 
  3519   mpz_t const *zval = bignum_integer (&mpz[0], value);
  3520   if (XFIXNUM (count) < 0)
  3521     {
  3522       if (TYPE_MAXIMUM (mp_bitcnt_t) < - XFIXNUM (count))
  3523         return make_fixnum (mpz_sgn (*zval) < 0 ? -1 : 0);
  3524       mpz_fdiv_q_2exp (mpz[0], *zval, - XFIXNUM (count));
  3525     }
  3526   else
  3527     emacs_mpz_mul_2exp (mpz[0], *zval, XFIXNUM (count));
  3528   return make_integer_mpz ();
  3529 }
  3530 
  3531 /* Return X ** Y as an integer.  X and Y must be integers, and Y must
  3532    be nonnegative.  */
  3533 
  3534 Lisp_Object
  3535 expt_integer (Lisp_Object x, Lisp_Object y)
  3536 {
  3537   /* Special cases for -1 <= x <= 1, which never overflow.  */
  3538   if (BASE_EQ (x, make_fixnum (1)))
  3539     return x;
  3540   if (BASE_EQ (x, make_fixnum (0)))
  3541     return BASE_EQ (x, y) ? make_fixnum (1) : x;
  3542   if (BASE_EQ (x, make_fixnum (-1)))
  3543     return ((FIXNUMP (y) ? XFIXNUM (y) & 1 : mpz_odd_p (*xbignum_val (y)))
  3544             ? x : make_fixnum (1));
  3545 
  3546   unsigned long exp;
  3547   if (FIXNUMP (y))
  3548     {
  3549       if (ULONG_MAX < XFIXNUM (y))
  3550         overflow_error ();
  3551       exp = XFIXNUM (y);
  3552     }
  3553   else
  3554     {
  3555       if (ULONG_MAX <= MOST_POSITIVE_FIXNUM
  3556           || !mpz_fits_ulong_p (*xbignum_val (y)))
  3557         overflow_error ();
  3558       exp = mpz_get_ui (*xbignum_val (y));
  3559     }
  3560 
  3561   emacs_mpz_pow_ui (mpz[0], *bignum_integer (&mpz[0], x), exp);
  3562   return make_integer_mpz ();
  3563 }
  3564 
  3565 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
  3566        doc: /* Return NUMBER plus one.  NUMBER may be a number or a marker.
  3567 Markers are converted to integers.  */)
  3568   (Lisp_Object number)
  3569 {
  3570   number = check_number_coerce_marker (number);
  3571 
  3572   if (FIXNUMP (number))
  3573     return make_int (XFIXNUM (number) + 1);
  3574   if (FLOATP (number))
  3575     return (make_float (1.0 + XFLOAT_DATA (number)));
  3576   mpz_add_ui (mpz[0], *xbignum_val (number), 1);
  3577   return make_integer_mpz ();
  3578 }
  3579 
  3580 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
  3581        doc: /* Return NUMBER minus one.  NUMBER may be a number or a marker.
  3582 Markers are converted to integers.  */)
  3583   (Lisp_Object number)
  3584 {
  3585   number = check_number_coerce_marker (number);
  3586 
  3587   if (FIXNUMP (number))
  3588     return make_int (XFIXNUM (number) - 1);
  3589   if (FLOATP (number))
  3590     return (make_float (-1.0 + XFLOAT_DATA (number)));
  3591   mpz_sub_ui (mpz[0], *xbignum_val (number), 1);
  3592   return make_integer_mpz ();
  3593 }
  3594 
  3595 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
  3596        doc: /* Return the bitwise complement of NUMBER.  NUMBER must be an integer.  */)
  3597   (register Lisp_Object number)
  3598 {
  3599   CHECK_INTEGER (number);
  3600   if (FIXNUMP (number))
  3601     return make_fixnum (~XFIXNUM (number));
  3602   mpz_com (mpz[0], *xbignum_val (number));
  3603   return make_integer_mpz ();
  3604 }
  3605 
  3606 DEFUN ("byteorder", Fbyteorder, Sbyteorder, 0, 0, 0,
  3607        doc: /* Return the byteorder for the machine.
  3608 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
  3609 lowercase l) for small endian machines.  */
  3610        attributes: const)
  3611   (void)
  3612 {
  3613   unsigned i = 0x04030201;
  3614   int order = *(char *)&i == 1 ? 108 : 66;
  3615 
  3616   return make_fixnum (order);
  3617 }
  3618 
  3619 /* Because we round up the bool vector allocate size to word_size
  3620    units, we can safely read past the "end" of the vector in the
  3621    operations below.  These extra bits are always zero.  */
  3622 
  3623 static bits_word
  3624 bool_vector_spare_mask (EMACS_INT nr_bits)
  3625 {
  3626   return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1;
  3627 }
  3628 
  3629 /* Shift VAL right by the width of an unsigned long long.
  3630    ULLONG_WIDTH must be less than BITS_PER_BITS_WORD.  */
  3631 
  3632 static bits_word
  3633 shift_right_ull (bits_word w)
  3634 {
  3635   /* Pacify bogus GCC warning about shift count exceeding type width.  */
  3636   int shift = ULLONG_WIDTH - BITS_PER_BITS_WORD < 0 ? ULLONG_WIDTH : 0;
  3637   return w >> shift;
  3638 }
  3639 
  3640 /* Return the number of 1 bits in W.  */
  3641 
  3642 static int
  3643 count_one_bits_word (bits_word w)
  3644 {
  3645   if (BITS_WORD_MAX <= UINT_MAX)
  3646     return count_one_bits (w);
  3647   else if (BITS_WORD_MAX <= ULONG_MAX)
  3648     return count_one_bits_l (w);
  3649   else
  3650     {
  3651       int i = 0, count = 0;
  3652       while (count += count_one_bits_ll (w),
  3653              (i += ULLONG_WIDTH) < BITS_PER_BITS_WORD)
  3654         w = shift_right_ull (w);
  3655       return count;
  3656     }
  3657 }
  3658 
  3659 enum bool_vector_op { bool_vector_exclusive_or,
  3660                       bool_vector_union,
  3661                       bool_vector_intersection,
  3662                       bool_vector_set_difference,
  3663                       bool_vector_subsetp };
  3664 
  3665 static Lisp_Object
  3666 bool_vector_binop_driver (Lisp_Object a,
  3667                           Lisp_Object b,
  3668                           Lisp_Object dest,
  3669                           enum bool_vector_op op)
  3670 {
  3671   EMACS_INT nr_bits;
  3672   bits_word *adata, *bdata, *destdata;
  3673   ptrdiff_t i = 0;
  3674   ptrdiff_t nr_words;
  3675 
  3676   CHECK_BOOL_VECTOR (a);
  3677   CHECK_BOOL_VECTOR (b);
  3678 
  3679   nr_bits = bool_vector_size (a);
  3680   if (bool_vector_size (b) != nr_bits)
  3681     wrong_length_argument (a, b, dest);
  3682 
  3683   nr_words = bool_vector_words (nr_bits);
  3684   adata = bool_vector_data (a);
  3685   bdata = bool_vector_data (b);
  3686 
  3687   if (NILP (dest))
  3688     {
  3689       dest = make_uninit_bool_vector (nr_bits);
  3690       destdata = bool_vector_data (dest);
  3691     }
  3692   else
  3693     {
  3694       CHECK_BOOL_VECTOR (dest);
  3695       destdata = bool_vector_data (dest);
  3696       if (bool_vector_size (dest) != nr_bits)
  3697         wrong_length_argument (a, b, dest);
  3698 
  3699       switch (op)
  3700         {
  3701         case bool_vector_exclusive_or:
  3702           for (; i < nr_words; i++)
  3703             if (destdata[i] != (adata[i] ^ bdata[i]))
  3704               goto set_dest;
  3705           break;
  3706 
  3707         case bool_vector_subsetp:
  3708           for (; i < nr_words; i++)
  3709             if (adata[i] &~ bdata[i])
  3710               return Qnil;
  3711           return Qt;
  3712 
  3713         case bool_vector_union:
  3714           for (; i < nr_words; i++)
  3715             if (destdata[i] != (adata[i] | bdata[i]))
  3716               goto set_dest;
  3717           break;
  3718 
  3719         case bool_vector_intersection:
  3720           for (; i < nr_words; i++)
  3721             if (destdata[i] != (adata[i] & bdata[i]))
  3722               goto set_dest;
  3723           break;
  3724 
  3725         case bool_vector_set_difference:
  3726           for (; i < nr_words; i++)
  3727             if (destdata[i] != (adata[i] &~ bdata[i]))
  3728               goto set_dest;
  3729           break;
  3730         }
  3731 
  3732       return Qnil;
  3733     }
  3734 
  3735  set_dest:
  3736   switch (op)
  3737     {
  3738     case bool_vector_exclusive_or:
  3739       for (; i < nr_words; i++)
  3740         destdata[i] = adata[i] ^ bdata[i];
  3741       break;
  3742 
  3743     case bool_vector_union:
  3744       for (; i < nr_words; i++)
  3745         destdata[i] = adata[i] | bdata[i];
  3746       break;
  3747 
  3748     case bool_vector_intersection:
  3749       for (; i < nr_words; i++)
  3750         destdata[i] = adata[i] & bdata[i];
  3751       break;
  3752 
  3753     case bool_vector_set_difference:
  3754       for (; i < nr_words; i++)
  3755         destdata[i] = adata[i] &~ bdata[i];
  3756       break;
  3757 
  3758     default:
  3759       eassume (0);
  3760     }
  3761 
  3762   return dest;
  3763 }
  3764 
  3765 /* PRECONDITION must be true.  Return VALUE.  This odd construction
  3766    works around a bogus GCC diagnostic "shift count >= width of type".  */
  3767 
  3768 static int
  3769 pre_value (bool precondition, int value)
  3770 {
  3771   eassume (precondition);
  3772   return precondition ? value : 0;
  3773 }
  3774 
  3775 /* Compute the number of trailing zero bits in val.  If val is zero,
  3776    return the number of bits in val.  */
  3777 static int
  3778 count_trailing_zero_bits (bits_word val)
  3779 {
  3780   if (BITS_WORD_MAX == UINT_MAX)
  3781     return count_trailing_zeros (val);
  3782   if (BITS_WORD_MAX == ULONG_MAX)
  3783     return count_trailing_zeros_l (val);
  3784   if (BITS_WORD_MAX == ULLONG_MAX)
  3785     return count_trailing_zeros_ll (val);
  3786 
  3787   /* The rest of this code is for the unlikely platform where bits_word differs
  3788      in width from unsigned int, unsigned long, and unsigned long long.  */
  3789   val |= ~ BITS_WORD_MAX;
  3790   if (BITS_WORD_MAX <= UINT_MAX)
  3791     return count_trailing_zeros (val);
  3792   if (BITS_WORD_MAX <= ULONG_MAX)
  3793     return count_trailing_zeros_l (val);
  3794   else
  3795     {
  3796       int count;
  3797       for (count = 0;
  3798            count < BITS_PER_BITS_WORD - ULLONG_WIDTH;
  3799            count += ULLONG_WIDTH)
  3800         {
  3801           if (val & ULLONG_MAX)
  3802             return count + count_trailing_zeros_ll (val);
  3803           val = shift_right_ull (val);
  3804         }
  3805 
  3806       if (BITS_PER_BITS_WORD % ULLONG_WIDTH != 0
  3807           && BITS_WORD_MAX == (bits_word) -1)
  3808         val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX,
  3809                                            BITS_PER_BITS_WORD % ULLONG_WIDTH);
  3810       return count + count_trailing_zeros_ll (val);
  3811     }
  3812 }
  3813 
  3814 static bits_word
  3815 bits_word_to_host_endian (bits_word val)
  3816 {
  3817 #ifndef WORDS_BIGENDIAN
  3818   return val;
  3819 #else
  3820   if (BITS_WORD_MAX >> 31 == 1)
  3821     return bswap_32 (val);
  3822   if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1)
  3823     return bswap_64 (val);
  3824   {
  3825     int i;
  3826     bits_word r = 0;
  3827     for (i = 0; i < sizeof val; i++)
  3828       {
  3829         r = ((r << 1 << (CHAR_BIT - 1))
  3830              | (val & ((1u << 1 << (CHAR_BIT - 1)) - 1)));
  3831         val = val >> 1 >> (CHAR_BIT - 1);
  3832       }
  3833     return r;
  3834   }
  3835 #endif
  3836 }
  3837 
  3838 DEFUN ("bool-vector-exclusive-or", Fbool_vector_exclusive_or,
  3839        Sbool_vector_exclusive_or, 2, 3, 0,
  3840        doc: /* Return A ^ B, bitwise exclusive or.
  3841 If optional third argument C is given, store result into C.
  3842 A, B, and C must be bool vectors of the same length.
  3843 Return the destination vector if it changed or nil otherwise.  */)
  3844   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3845 {
  3846   return bool_vector_binop_driver (a, b, c, bool_vector_exclusive_or);
  3847 }
  3848 
  3849 DEFUN ("bool-vector-union", Fbool_vector_union,
  3850        Sbool_vector_union, 2, 3, 0,
  3851        doc: /* Return A | B, bitwise or.
  3852 If optional third argument C is given, store result into C.
  3853 A, B, and C must be bool vectors of the same length.
  3854 Return the destination vector if it changed or nil otherwise.  */)
  3855   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3856 {
  3857   return bool_vector_binop_driver (a, b, c, bool_vector_union);
  3858 }
  3859 
  3860 DEFUN ("bool-vector-intersection", Fbool_vector_intersection,
  3861        Sbool_vector_intersection, 2, 3, 0,
  3862        doc: /* Return A & B, bitwise and.
  3863 If optional third argument C is given, store result into C.
  3864 A, B, and C must be bool vectors of the same length.
  3865 Return the destination vector if it changed or nil otherwise.  */)
  3866   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3867 {
  3868   return bool_vector_binop_driver (a, b, c, bool_vector_intersection);
  3869 }
  3870 
  3871 DEFUN ("bool-vector-set-difference", Fbool_vector_set_difference,
  3872        Sbool_vector_set_difference, 2, 3, 0,
  3873        doc: /* Return A &~ B, set difference.
  3874 If optional third argument C is given, store result into C.
  3875 A, B, and C must be bool vectors of the same length.
  3876 Return the destination vector if it changed or nil otherwise.  */)
  3877   (Lisp_Object a, Lisp_Object b, Lisp_Object c)
  3878 {
  3879   return bool_vector_binop_driver (a, b, c, bool_vector_set_difference);
  3880 }
  3881 
  3882 DEFUN ("bool-vector-subsetp", Fbool_vector_subsetp,
  3883        Sbool_vector_subsetp, 2, 2, 0,
  3884        doc: /* Return t if every t value in A is also t in B, nil otherwise.
  3885 A and B must be bool vectors of the same length.  */)
  3886   (Lisp_Object a, Lisp_Object b)
  3887 {
  3888   return bool_vector_binop_driver (a, b, b, bool_vector_subsetp);
  3889 }
  3890 
  3891 DEFUN ("bool-vector-not", Fbool_vector_not,
  3892        Sbool_vector_not, 1, 2, 0,
  3893        doc: /* Compute ~A, set complement.
  3894 If optional second argument B is given, store result into B.
  3895 A and B must be bool vectors of the same length.
  3896 Return the destination vector.  */)
  3897   (Lisp_Object a, Lisp_Object b)
  3898 {
  3899   EMACS_INT nr_bits;
  3900   bits_word *bdata, *adata;
  3901   ptrdiff_t i;
  3902 
  3903   CHECK_BOOL_VECTOR (a);
  3904   nr_bits = bool_vector_size (a);
  3905 
  3906   if (NILP (b))
  3907     b = make_uninit_bool_vector (nr_bits);
  3908   else
  3909     {
  3910       CHECK_BOOL_VECTOR (b);
  3911       if (bool_vector_size (b) != nr_bits)
  3912         wrong_length_argument (a, b, Qnil);
  3913     }
  3914 
  3915   bdata = bool_vector_data (b);
  3916   adata = bool_vector_data (a);
  3917 
  3918   for (i = 0; i < nr_bits / BITS_PER_BITS_WORD; i++)
  3919     bdata[i] = BITS_WORD_MAX & ~adata[i];
  3920 
  3921   if (nr_bits % BITS_PER_BITS_WORD)
  3922     {
  3923       bits_word mword = bits_word_to_host_endian (adata[i]);
  3924       mword = ~mword;
  3925       mword &= bool_vector_spare_mask (nr_bits);
  3926       bdata[i] = bits_word_to_host_endian (mword);
  3927     }
  3928 
  3929   return b;
  3930 }
  3931 
  3932 DEFUN ("bool-vector-count-population", Fbool_vector_count_population,
  3933        Sbool_vector_count_population, 1, 1, 0,
  3934        doc: /* Count how many elements in A are t.
  3935 A is a bool vector.  To count A's nil elements, subtract the return
  3936 value from A's length.  */)
  3937   (Lisp_Object a)
  3938 {
  3939   EMACS_INT count;
  3940   EMACS_INT nr_bits;
  3941   bits_word *adata;
  3942   ptrdiff_t i, nwords;
  3943 
  3944   CHECK_BOOL_VECTOR (a);
  3945 
  3946   nr_bits = bool_vector_size (a);
  3947   nwords = bool_vector_words (nr_bits);
  3948   count = 0;
  3949   adata = bool_vector_data (a);
  3950 
  3951   for (i = 0; i < nwords; i++)
  3952     count += count_one_bits_word (adata[i]);
  3953 
  3954   return make_fixnum (count);
  3955 }
  3956 
  3957 DEFUN ("bool-vector-count-consecutive", Fbool_vector_count_consecutive,
  3958        Sbool_vector_count_consecutive, 3, 3, 0,
  3959        doc: /* Count how many consecutive elements in A equal B starting at I.
  3960 A is a bool vector, B is t or nil, and I is an index into A.  */)
  3961   (Lisp_Object a, Lisp_Object b, Lisp_Object i)
  3962 {
  3963   EMACS_INT count;
  3964   EMACS_INT nr_bits;
  3965   int offset;
  3966   bits_word *adata;
  3967   bits_word twiddle;
  3968   bits_word mword; /* Machine word.  */
  3969   ptrdiff_t pos, pos0;
  3970   ptrdiff_t nr_words;
  3971 
  3972   CHECK_BOOL_VECTOR (a);
  3973   CHECK_FIXNAT (i);
  3974 
  3975   nr_bits = bool_vector_size (a);
  3976   if (XFIXNAT (i) > nr_bits) /* Allow one past the end for convenience */
  3977     args_out_of_range (a, i);
  3978 
  3979   adata = bool_vector_data (a);
  3980   nr_words = bool_vector_words (nr_bits);
  3981   pos = XFIXNAT (i) / BITS_PER_BITS_WORD;
  3982   offset = XFIXNAT (i) % BITS_PER_BITS_WORD;
  3983   count = 0;
  3984 
  3985   /* By XORing with twiddle, we transform the problem of "count
  3986      consecutive equal values" into "count the zero bits".  The latter
  3987      operation usually has hardware support.  */
  3988   twiddle = NILP (b) ? 0 : BITS_WORD_MAX;
  3989 
  3990   /* Scan the remainder of the mword at the current offset.  */
  3991   if (pos < nr_words && offset != 0)
  3992     {
  3993       mword = bits_word_to_host_endian (adata[pos]);
  3994       mword ^= twiddle;
  3995       mword >>= offset;
  3996 
  3997       /* Do not count the pad bits.  */
  3998       mword |= (bits_word) 1 << (BITS_PER_BITS_WORD - offset);
  3999 
  4000       count = count_trailing_zero_bits (mword);
  4001       pos++;
  4002       if (count + offset < BITS_PER_BITS_WORD)
  4003         return make_fixnum (count);
  4004     }
  4005 
  4006   /* Scan whole words until we either reach the end of the vector or
  4007      find an mword that doesn't completely match.  twiddle is
  4008      endian-independent.  */
  4009   pos0 = pos;
  4010   while (pos < nr_words && adata[pos] == twiddle)
  4011     pos++;
  4012   count += (pos - pos0) * BITS_PER_BITS_WORD;
  4013 
  4014   if (pos < nr_words)
  4015     {
  4016       /* If we stopped because of a mismatch, see how many bits match
  4017          in the current mword.  */
  4018       mword = bits_word_to_host_endian (adata[pos]);
  4019       mword ^= twiddle;
  4020       count += count_trailing_zero_bits (mword);
  4021     }
  4022   else if (nr_bits % BITS_PER_BITS_WORD != 0)
  4023     {
  4024       /* If we hit the end, we might have overshot our count.  Reduce
  4025          the total by the number of spare bits at the end of the
  4026          vector.  */
  4027       count -= BITS_PER_BITS_WORD - nr_bits % BITS_PER_BITS_WORD;
  4028     }
  4029 
  4030   return make_fixnum (count);
  4031 }
  4032 
  4033 
  4034 void
  4035 syms_of_data (void)
  4036 {
  4037   Lisp_Object error_tail, arith_tail, recursion_tail;
  4038 
  4039   DEFSYM (Qquote, "quote");
  4040   DEFSYM (Qlambda, "lambda");
  4041   DEFSYM (Qerror_conditions, "error-conditions");
  4042   DEFSYM (Qerror_message, "error-message");
  4043   DEFSYM (Qtop_level, "top-level");
  4044 
  4045   DEFSYM (Qerror, "error");
  4046   DEFSYM (Quser_error, "user-error");
  4047   DEFSYM (Qquit, "quit");
  4048   DEFSYM (Qminibuffer_quit, "minibuffer-quit");
  4049   DEFSYM (Qwrong_length_argument, "wrong-length-argument");
  4050   DEFSYM (Qwrong_type_argument, "wrong-type-argument");
  4051   DEFSYM (Qargs_out_of_range, "args-out-of-range");
  4052   DEFSYM (Qvoid_function, "void-function");
  4053   DEFSYM (Qcyclic_function_indirection, "cyclic-function-indirection");
  4054   DEFSYM (Qcyclic_variable_indirection, "cyclic-variable-indirection");
  4055   DEFSYM (Qvoid_variable, "void-variable");
  4056   DEFSYM (Qsetting_constant, "setting-constant");
  4057   DEFSYM (Qtrapping_constant, "trapping-constant");
  4058   DEFSYM (Qinvalid_read_syntax, "invalid-read-syntax");
  4059 
  4060   DEFSYM (Qinvalid_function, "invalid-function");
  4061   DEFSYM (Qwrong_number_of_arguments, "wrong-number-of-arguments");
  4062   DEFSYM (Qno_catch, "no-catch");
  4063   DEFSYM (Qend_of_file, "end-of-file");
  4064   DEFSYM (Qarith_error, "arith-error");
  4065   DEFSYM (Qbeginning_of_buffer, "beginning-of-buffer");
  4066   DEFSYM (Qend_of_buffer, "end-of-buffer");
  4067   DEFSYM (Qbuffer_read_only, "buffer-read-only");
  4068   DEFSYM (Qtext_read_only, "text-read-only");
  4069   DEFSYM (Qmark_inactive, "mark-inactive");
  4070   DEFSYM (Qinhibited_interaction, "inhibited-interaction");
  4071 
  4072   DEFSYM (Qrecursion_error, "recursion-error");
  4073   DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
  4074   DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting");
  4075 
  4076   DEFSYM (Qlistp, "listp");
  4077   DEFSYM (Qconsp, "consp");
  4078   DEFSYM (Qbare_symbol_p, "bare-symbol-p");
  4079   DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
  4080   DEFSYM (Qsymbolp, "symbolp");
  4081   DEFSYM (Qfixnump, "fixnump");
  4082   DEFSYM (Qintegerp, "integerp");
  4083   DEFSYM (Qbooleanp, "booleanp");
  4084   DEFSYM (Qnatnump, "natnump");
  4085   DEFSYM (Qwholenump, "wholenump");
  4086   DEFSYM (Qstringp, "stringp");
  4087   DEFSYM (Qarrayp, "arrayp");
  4088   DEFSYM (Qsequencep, "sequencep");
  4089   DEFSYM (Qbufferp, "bufferp");
  4090   DEFSYM (Qvectorp, "vectorp");
  4091   DEFSYM (Qrecordp, "recordp");
  4092   DEFSYM (Qbool_vector_p, "bool-vector-p");
  4093   DEFSYM (Qchar_or_string_p, "char-or-string-p");
  4094   DEFSYM (Qmarkerp, "markerp");
  4095   DEFSYM (Quser_ptrp, "user-ptrp");
  4096   DEFSYM (Qbuffer_or_string_p, "buffer-or-string-p");
  4097   DEFSYM (Qinteger_or_marker_p, "integer-or-marker-p");
  4098   DEFSYM (Qfboundp, "fboundp");
  4099 
  4100   DEFSYM (Qfloatp, "floatp");
  4101   DEFSYM (Qnumberp, "numberp");
  4102   DEFSYM (Qnumber_or_marker_p, "number-or-marker-p");
  4103 
  4104   DEFSYM (Qchar_table_p, "char-table-p");
  4105   DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
  4106   DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p");
  4107   DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form");
  4108 
  4109   DEFSYM (Qsubrp, "subrp");
  4110   DEFSYM (Qunevalled, "unevalled");
  4111   DEFSYM (Qmany, "many");
  4112 
  4113   DEFSYM (Qcar, "car");
  4114   DEFSYM (Qcdr, "cdr");
  4115   DEFSYM (Qnth, "nth");
  4116   DEFSYM (Qelt, "elt");
  4117   DEFSYM (Qsetcar, "setcar");
  4118   DEFSYM (Qsetcdr, "setcdr");
  4119   DEFSYM (Qaref, "aref");
  4120   DEFSYM (Qaset, "aset");
  4121 
  4122   error_tail = pure_cons (Qerror, Qnil);
  4123 
  4124   /* ERROR is used as a signaler for random errors for which nothing else is
  4125      right.  */
  4126 
  4127   Fput (Qerror, Qerror_conditions,
  4128         error_tail);
  4129   Fput (Qerror, Qerror_message,
  4130         build_pure_c_string ("error"));
  4131 
  4132 #define PUT_ERROR(sym, tail, msg)                       \
  4133   Fput (sym, Qerror_conditions, pure_cons (sym, tail)); \
  4134   Fput (sym, Qerror_message, build_pure_c_string (msg))
  4135 
  4136   PUT_ERROR (Qquit, Qnil, "Quit");
  4137   PUT_ERROR (Qminibuffer_quit, pure_cons (Qquit, Qnil), "Quit");
  4138 
  4139   PUT_ERROR (Quser_error, error_tail, "");
  4140   PUT_ERROR (Qwrong_length_argument, error_tail, "Wrong length argument");
  4141   PUT_ERROR (Qwrong_type_argument, error_tail, "Wrong type argument");
  4142   PUT_ERROR (Qargs_out_of_range, error_tail, "Args out of range");
  4143   PUT_ERROR (Qvoid_function, error_tail,
  4144              "Symbol's function definition is void");
  4145   PUT_ERROR (Qcyclic_function_indirection, error_tail,
  4146              "Symbol's chain of function indirections contains a loop");
  4147   PUT_ERROR (Qcyclic_variable_indirection, error_tail,
  4148              "Symbol's chain of variable indirections contains a loop");
  4149   DEFSYM (Qcircular_list, "circular-list");
  4150   PUT_ERROR (Qcircular_list, error_tail, "List contains a loop");
  4151   PUT_ERROR (Qvoid_variable, error_tail, "Symbol's value as variable is void");
  4152   PUT_ERROR (Qsetting_constant, error_tail,
  4153              "Attempt to set a constant symbol");
  4154   PUT_ERROR (Qtrapping_constant, error_tail,
  4155              "Attempt to trap writes to a constant symbol");
  4156   PUT_ERROR (Qinvalid_read_syntax, error_tail, "Invalid read syntax");
  4157   PUT_ERROR (Qinvalid_function, error_tail, "Invalid function");
  4158   PUT_ERROR (Qwrong_number_of_arguments, error_tail,
  4159              "Wrong number of arguments");
  4160   PUT_ERROR (Qno_catch, error_tail, "No catch for tag");
  4161   PUT_ERROR (Qend_of_file, error_tail, "End of file during parsing");
  4162 
  4163   arith_tail = pure_cons (Qarith_error, error_tail);
  4164   Fput (Qarith_error, Qerror_conditions, arith_tail);
  4165   Fput (Qarith_error, Qerror_message, build_pure_c_string ("Arithmetic error"));
  4166 
  4167   PUT_ERROR (Qbeginning_of_buffer, error_tail, "Beginning of buffer");
  4168   PUT_ERROR (Qend_of_buffer, error_tail, "End of buffer");
  4169   PUT_ERROR (Qbuffer_read_only, error_tail, "Buffer is read-only");
  4170   PUT_ERROR (Qtext_read_only, pure_cons (Qbuffer_read_only, error_tail),
  4171              "Text is read-only");
  4172   PUT_ERROR (Qinhibited_interaction, error_tail,
  4173              "User interaction while inhibited");
  4174 
  4175   DEFSYM (Qrange_error, "range-error");
  4176   DEFSYM (Qdomain_error, "domain-error");
  4177   DEFSYM (Qsingularity_error, "singularity-error");
  4178   DEFSYM (Qoverflow_error, "overflow-error");
  4179   DEFSYM (Qunderflow_error, "underflow-error");
  4180 
  4181   PUT_ERROR (Qdomain_error, arith_tail, "Arithmetic domain error");
  4182 
  4183   PUT_ERROR (Qrange_error, arith_tail, "Arithmetic range error");
  4184 
  4185   PUT_ERROR (Qsingularity_error, Fcons (Qdomain_error, arith_tail),
  4186              "Arithmetic singularity error");
  4187 
  4188   PUT_ERROR (Qoverflow_error, Fcons (Qrange_error, arith_tail),
  4189              "Arithmetic overflow error");
  4190   PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail),
  4191              "Arithmetic underflow error");
  4192 
  4193   recursion_tail = pure_cons (Qrecursion_error, error_tail);
  4194   Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
  4195   Fput (Qrecursion_error, Qerror_message, build_pure_c_string
  4196         ("Excessive recursive calling error"));
  4197 
  4198   PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
  4199              "Lisp nesting exceeds `max-lisp-eval-depth'");
  4200   /* Error obsolete (from 29.1), kept for compatibility.  */
  4201   PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
  4202              "Variable binding depth exceeds max-specpdl-size");
  4203 
  4204   /* Types that type-of returns.  */
  4205   DEFSYM (Qinteger, "integer");
  4206   DEFSYM (Qsymbol, "symbol");
  4207   DEFSYM (Qstring, "string");
  4208   DEFSYM (Qcons, "cons");
  4209   DEFSYM (Qmarker, "marker");
  4210   DEFSYM (Qsymbol_with_pos, "symbol-with-pos");
  4211   DEFSYM (Qoverlay, "overlay");
  4212   DEFSYM (Qfinalizer, "finalizer");
  4213   DEFSYM (Qmodule_function, "module-function");
  4214   DEFSYM (Qnative_comp_unit, "native-comp-unit");
  4215   DEFSYM (Quser_ptr, "user-ptr");
  4216   DEFSYM (Qfloat, "float");
  4217   DEFSYM (Qwindow_configuration, "window-configuration");
  4218   DEFSYM (Qprocess, "process");
  4219   DEFSYM (Qwindow, "window");
  4220   DEFSYM (Qsubr, "subr");
  4221   DEFSYM (Qcompiled_function, "compiled-function");
  4222   DEFSYM (Qbuffer, "buffer");
  4223   DEFSYM (Qframe, "frame");
  4224   DEFSYM (Qvector, "vector");
  4225   DEFSYM (Qrecord, "record");
  4226   DEFSYM (Qchar_table, "char-table");
  4227   DEFSYM (Qsub_char_table, "sub-char-table");
  4228   DEFSYM (Qbool_vector, "bool-vector");
  4229   DEFSYM (Qhash_table, "hash-table");
  4230   DEFSYM (Qthread, "thread");
  4231   DEFSYM (Qmutex, "mutex");
  4232   DEFSYM (Qcondition_variable, "condition-variable");
  4233   DEFSYM (Qfont_spec, "font-spec");
  4234   DEFSYM (Qfont_entity, "font-entity");
  4235   DEFSYM (Qfont_object, "font-object");
  4236   DEFSYM (Qterminal, "terminal");
  4237   DEFSYM (Qxwidget, "xwidget");
  4238   DEFSYM (Qxwidget_view, "xwidget-view");
  4239   DEFSYM (Qtreesit_parser, "treesit-parser");
  4240   DEFSYM (Qtreesit_node, "treesit-node");
  4241   DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query");
  4242 
  4243   DEFSYM (Qdefun, "defun");
  4244 
  4245   DEFSYM (Qinteractive_form, "interactive-form");
  4246   DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
  4247   DEFSYM (Qfunction_history, "function-history");
  4248 
  4249   DEFSYM (Qbyte_code_function_p, "byte-code-function-p");
  4250 
  4251   defsubr (&Sindirect_variable);
  4252   defsubr (&Sinteractive_form);
  4253   defsubr (&Scommand_modes);
  4254   defsubr (&Seq);
  4255   defsubr (&Snull);
  4256   defsubr (&Stype_of);
  4257   defsubr (&Slistp);
  4258   defsubr (&Snlistp);
  4259   defsubr (&Sconsp);
  4260   defsubr (&Satom);
  4261   defsubr (&Sintegerp);
  4262   defsubr (&Sinteger_or_marker_p);
  4263   defsubr (&Snumberp);
  4264   defsubr (&Snumber_or_marker_p);
  4265   defsubr (&Sfloatp);
  4266   defsubr (&Snatnump);
  4267   defsubr (&Sbare_symbol_p);
  4268   defsubr (&Ssymbol_with_pos_p);
  4269   defsubr (&Ssymbolp);
  4270   defsubr (&Skeywordp);
  4271   defsubr (&Sstringp);
  4272   defsubr (&Smultibyte_string_p);
  4273   defsubr (&Svectorp);
  4274   defsubr (&Srecordp);
  4275   defsubr (&Schar_table_p);
  4276   defsubr (&Svector_or_char_table_p);
  4277   defsubr (&Sbool_vector_p);
  4278   defsubr (&Sarrayp);
  4279   defsubr (&Ssequencep);
  4280   defsubr (&Sbufferp);
  4281   defsubr (&Smarkerp);
  4282   defsubr (&Ssubrp);
  4283   defsubr (&Sbyte_code_function_p);
  4284   defsubr (&Smodule_function_p);
  4285   defsubr (&Schar_or_string_p);
  4286   defsubr (&Sthreadp);
  4287   defsubr (&Smutexp);
  4288   defsubr (&Scondition_variable_p);
  4289   defsubr (&Scar);
  4290   defsubr (&Scdr);
  4291   defsubr (&Scar_safe);
  4292   defsubr (&Scdr_safe);
  4293   defsubr (&Ssetcar);
  4294   defsubr (&Ssetcdr);
  4295   defsubr (&Ssymbol_function);
  4296   defsubr (&Sindirect_function);
  4297   defsubr (&Ssymbol_plist);
  4298   defsubr (&Ssymbol_name);
  4299   defsubr (&Sbare_symbol);
  4300   defsubr (&Ssymbol_with_pos_pos);
  4301   defsubr (&Sremove_pos_from_symbol);
  4302   defsubr (&Sposition_symbol);
  4303   defsubr (&Smakunbound);
  4304   defsubr (&Sfmakunbound);
  4305   defsubr (&Sboundp);
  4306   defsubr (&Sfboundp);
  4307   defsubr (&Sfset);
  4308   defsubr (&Sdefalias);
  4309   defsubr (&Ssetplist);
  4310   defsubr (&Ssymbol_value);
  4311   defsubr (&Sset);
  4312   defsubr (&Sdefault_boundp);
  4313   defsubr (&Sdefault_value);
  4314   defsubr (&Sset_default);
  4315   defsubr (&Smake_variable_buffer_local);
  4316   defsubr (&Smake_local_variable);
  4317   defsubr (&Skill_local_variable);
  4318   defsubr (&Slocal_variable_p);
  4319   defsubr (&Slocal_variable_if_set_p);
  4320   defsubr (&Svariable_binding_locus);
  4321   defsubr (&Saref);
  4322   defsubr (&Saset);
  4323   defsubr (&Snumber_to_string);
  4324   defsubr (&Sstring_to_number);
  4325   defsubr (&Seqlsign);
  4326   defsubr (&Slss);
  4327   defsubr (&Sgtr);
  4328   defsubr (&Sleq);
  4329   defsubr (&Sgeq);
  4330   defsubr (&Sneq);
  4331   defsubr (&Splus);
  4332   defsubr (&Sminus);
  4333   defsubr (&Stimes);
  4334   defsubr (&Squo);
  4335   defsubr (&Srem);
  4336   defsubr (&Smod);
  4337   defsubr (&Smax);
  4338   defsubr (&Smin);
  4339   defsubr (&Slogand);
  4340   defsubr (&Slogior);
  4341   defsubr (&Slogxor);
  4342   defsubr (&Slogcount);
  4343   defsubr (&Sash);
  4344   defsubr (&Sadd1);
  4345   defsubr (&Ssub1);
  4346   defsubr (&Slognot);
  4347   defsubr (&Sbyteorder);
  4348   defsubr (&Ssubr_arity);
  4349   defsubr (&Ssubr_name);
  4350   defsubr (&Ssubr_native_elisp_p);
  4351   defsubr (&Ssubr_native_lambda_list);
  4352   defsubr (&Ssubr_type);
  4353 #ifdef HAVE_NATIVE_COMP
  4354   defsubr (&Ssubr_native_comp_unit);
  4355   defsubr (&Snative_comp_unit_file);
  4356   defsubr (&Snative_comp_unit_set_file);
  4357 #endif
  4358 #ifdef HAVE_MODULES
  4359   defsubr (&Suser_ptrp);
  4360 #endif
  4361 
  4362   defsubr (&Sbool_vector_exclusive_or);
  4363   defsubr (&Sbool_vector_union);
  4364   defsubr (&Sbool_vector_intersection);
  4365   defsubr (&Sbool_vector_set_difference);
  4366   defsubr (&Sbool_vector_not);
  4367   defsubr (&Sbool_vector_subsetp);
  4368   defsubr (&Sbool_vector_count_consecutive);
  4369   defsubr (&Sbool_vector_count_population);
  4370 
  4371   set_symbol_function (Qwholenump, XSYMBOL (Qnatnump)->u.s.function);
  4372 
  4373   DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum,
  4374                doc: /* The greatest integer that is represented efficiently.
  4375 This variable cannot be set; trying to do so will signal an error.  */);
  4376   Vmost_positive_fixnum = make_fixnum (MOST_POSITIVE_FIXNUM);
  4377   make_symbol_constant (intern_c_string ("most-positive-fixnum"));
  4378 
  4379   DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum,
  4380                doc: /* The least integer that is represented efficiently.
  4381 This variable cannot be set; trying to do so will signal an error.  */);
  4382   Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM);
  4383   make_symbol_constant (intern_c_string ("most-negative-fixnum"));
  4384 
  4385   DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled");
  4386   DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled,
  4387                doc: /* Non-nil when "symbols with position" can be used as symbols.
  4388 Bind this to non-nil in applications such as the byte compiler.  */);
  4389   symbols_with_pos_enabled = false;
  4390 
  4391   DEFSYM (Qwatchers, "watchers");
  4392   DEFSYM (Qmakunbound, "makunbound");
  4393   DEFSYM (Qunlet, "unlet");
  4394   DEFSYM (Qset, "set");
  4395   DEFSYM (Qset_default, "set-default");
  4396   DEFSYM (Qcommand_modes, "command-modes");
  4397   defsubr (&Sadd_variable_watcher);
  4398   defsubr (&Sremove_variable_watcher);
  4399   defsubr (&Sget_variable_watchers);
  4400 }