(Vpreloaded_file_list): New variable.
[emacs.git] / src / data.c
blobf2dd58344d9316e2555574754f369ab9973de5ad
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985, 86, 88, 93, 94, 95 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
22 #include <signal.h>
24 #include <config.h>
26 /* Put this before lisp.h so that lisp.h can define DBL_DIG if not defined. */
27 #ifdef LISP_FLOAT_TYPE
28 #ifdef STDC_HEADERS
29 #include <float.h>
30 #endif
31 #endif
33 #include "lisp.h"
34 #include "puresize.h"
35 #include "charset.h"
37 #ifndef standalone
38 #include "buffer.h"
39 #include "keyboard.h"
40 #endif
42 #include "syssignal.h"
44 #ifdef LISP_FLOAT_TYPE
46 #ifdef STDC_HEADERS
47 #include <stdlib.h>
48 #endif
50 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
51 #ifndef IEEE_FLOATING_POINT
52 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
53 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
54 #define IEEE_FLOATING_POINT 1
55 #else
56 #define IEEE_FLOATING_POINT 0
57 #endif
58 #endif
60 /* Work around a problem that happens because math.h on hpux 7
61 defines two static variables--which, in Emacs, are not really static,
62 because `static' is defined as nothing. The problem is that they are
63 here, in floatfns.c, and in lread.c.
64 These macros prevent the name conflict. */
65 #if defined (HPUX) && !defined (HPUX8)
66 #define _MAXLDBL data_c_maxldbl
67 #define _NMAXLDBL data_c_nmaxldbl
68 #endif
70 #include <math.h>
71 #endif /* LISP_FLOAT_TYPE */
73 #if !defined (atof)
74 extern double atof ();
75 #endif /* !atof */
77 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
78 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
79 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
80 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
81 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
82 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
83 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
84 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
85 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
86 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
87 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
88 Lisp_Object Qbuffer_or_string_p;
89 Lisp_Object Qboundp, Qfboundp;
90 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
92 Lisp_Object Qcdr;
93 Lisp_Object Qad_advice_info, Qad_activate;
95 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
96 Lisp_Object Qoverflow_error, Qunderflow_error;
98 #ifdef LISP_FLOAT_TYPE
99 Lisp_Object Qfloatp;
100 Lisp_Object Qnumberp, Qnumber_or_marker_p;
101 #endif
103 static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
104 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
105 Lisp_Object Qprocess;
106 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
107 static Lisp_Object Qchar_table, Qbool_vector;
109 static Lisp_Object swap_in_symval_forwarding ();
111 Lisp_Object set_internal ();
113 Lisp_Object
114 wrong_type_argument (predicate, value)
115 register Lisp_Object predicate, value;
117 register Lisp_Object tem;
120 if (!EQ (Vmocklisp_arguments, Qt))
122 if (STRINGP (value) &&
123 (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
124 return Fstring_to_number (value, Qnil);
125 if (INTEGERP (value) && EQ (predicate, Qstringp))
126 return Fnumber_to_string (value);
129 /* If VALUE is not even a valid Lisp object, abort here
130 where we can get a backtrace showing where it came from. */
131 if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
132 abort ();
134 value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
135 tem = call1 (predicate, value);
137 while (NILP (tem));
138 return value;
141 pure_write_error ()
143 error ("Attempt to modify read-only object");
146 void
147 args_out_of_range (a1, a2)
148 Lisp_Object a1, a2;
150 while (1)
151 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
154 void
155 args_out_of_range_3 (a1, a2, a3)
156 Lisp_Object a1, a2, a3;
158 while (1)
159 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
162 /* On some machines, XINT needs a temporary location.
163 Here it is, in case it is needed. */
165 int sign_extend_temp;
167 /* On a few machines, XINT can only be done by calling this. */
170 sign_extend_lisp_int (num)
171 EMACS_INT num;
173 if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
174 return num | (((EMACS_INT) (-1)) << VALBITS);
175 else
176 return num & ((((EMACS_INT) 1) << VALBITS) - 1);
179 /* Data type predicates */
181 DEFUN ("eq", Feq, Seq, 2, 2, 0,
182 "T if the two args are the same Lisp object.")
183 (obj1, obj2)
184 Lisp_Object obj1, obj2;
186 if (EQ (obj1, obj2))
187 return Qt;
188 return Qnil;
191 DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
192 (object)
193 Lisp_Object object;
195 if (NILP (object))
196 return Qt;
197 return Qnil;
200 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
201 "Return a symbol representing the type of OBJECT.\n\
202 The symbol returned names the object's basic type;\n\
203 for example, (type-of 1) returns `integer'.")
204 (object)
205 Lisp_Object object;
207 switch (XGCTYPE (object))
209 case Lisp_Int:
210 return Qinteger;
212 case Lisp_Symbol:
213 return Qsymbol;
215 case Lisp_String:
216 return Qstring;
218 case Lisp_Cons:
219 return Qcons;
221 case Lisp_Misc:
222 switch (XMISCTYPE (object))
224 case Lisp_Misc_Marker:
225 return Qmarker;
226 case Lisp_Misc_Overlay:
227 return Qoverlay;
228 case Lisp_Misc_Float:
229 return Qfloat;
231 abort ();
233 case Lisp_Vectorlike:
234 if (GC_WINDOW_CONFIGURATIONP (object))
235 return Qwindow_configuration;
236 if (GC_PROCESSP (object))
237 return Qprocess;
238 if (GC_WINDOWP (object))
239 return Qwindow;
240 if (GC_SUBRP (object))
241 return Qsubr;
242 if (GC_COMPILEDP (object))
243 return Qcompiled_function;
244 if (GC_BUFFERP (object))
245 return Qbuffer;
246 if (GC_CHAR_TABLE_P (object))
247 return Qchar_table;
248 if (GC_BOOL_VECTOR_P (object))
249 return Qbool_vector;
250 if (GC_FRAMEP (object))
251 return Qframe;
252 return Qvector;
254 #ifdef LISP_FLOAT_TYPE
255 case Lisp_Float:
256 return Qfloat;
257 #endif
259 default:
260 abort ();
264 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
265 (object)
266 Lisp_Object object;
268 if (CONSP (object))
269 return Qt;
270 return Qnil;
273 DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell. This includes nil.")
274 (object)
275 Lisp_Object object;
277 if (CONSP (object))
278 return Qnil;
279 return Qt;
282 DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list. This includes nil.")
283 (object)
284 Lisp_Object object;
286 if (CONSP (object) || NILP (object))
287 return Qt;
288 return Qnil;
291 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list. Lists include nil.")
292 (object)
293 Lisp_Object object;
295 if (CONSP (object) || NILP (object))
296 return Qnil;
297 return Qt;
300 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
301 (object)
302 Lisp_Object object;
304 if (SYMBOLP (object))
305 return Qt;
306 return Qnil;
309 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
310 (object)
311 Lisp_Object object;
313 if (VECTORP (object))
314 return Qt;
315 return Qnil;
318 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
319 (object)
320 Lisp_Object object;
322 if (STRINGP (object))
323 return Qt;
324 return Qnil;
327 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0, "T if OBJECT is a char-table.")
328 (object)
329 Lisp_Object object;
331 if (CHAR_TABLE_P (object))
332 return Qt;
333 return Qnil;
336 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
337 Svector_or_char_table_p, 1, 1, 0,
338 "T if OBJECT is a char-table or vector.")
339 (object)
340 Lisp_Object object;
342 if (VECTORP (object) || CHAR_TABLE_P (object))
343 return Qt;
344 return Qnil;
347 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "T if OBJECT is a bool-vector.")
348 (object)
349 Lisp_Object object;
351 if (BOOL_VECTOR_P (object))
352 return Qt;
353 return Qnil;
356 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "T if OBJECT is an array (string or vector).")
357 (object)
358 Lisp_Object object;
360 if (VECTORP (object) || STRINGP (object)
361 || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
362 return Qt;
363 return Qnil;
366 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
367 "T if OBJECT is a sequence (list or array).")
368 (object)
369 register Lisp_Object object;
371 if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
372 || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
373 return Qt;
374 return Qnil;
377 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "T if OBJECT is an editor buffer.")
378 (object)
379 Lisp_Object object;
381 if (BUFFERP (object))
382 return Qt;
383 return Qnil;
386 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "T if OBJECT is a marker (editor pointer).")
387 (object)
388 Lisp_Object object;
390 if (MARKERP (object))
391 return Qt;
392 return Qnil;
395 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
396 (object)
397 Lisp_Object object;
399 if (SUBRP (object))
400 return Qt;
401 return Qnil;
404 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
405 1, 1, 0, "T if OBJECT is a byte-compiled function object.")
406 (object)
407 Lisp_Object object;
409 if (COMPILEDP (object))
410 return Qt;
411 return Qnil;
414 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
415 "T if OBJECT is a character (an integer) or a string.")
416 (object)
417 register Lisp_Object object;
419 if (INTEGERP (object) || STRINGP (object))
420 return Qt;
421 return Qnil;
424 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "T if OBJECT is an integer.")
425 (object)
426 Lisp_Object object;
428 if (INTEGERP (object))
429 return Qt;
430 return Qnil;
433 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
434 "T if OBJECT is an integer or a marker (editor pointer).")
435 (object)
436 register Lisp_Object object;
438 if (MARKERP (object) || INTEGERP (object))
439 return Qt;
440 return Qnil;
443 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
444 "T if OBJECT is a nonnegative integer.")
445 (object)
446 Lisp_Object object;
448 if (NATNUMP (object))
449 return Qt;
450 return Qnil;
453 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
454 "T if OBJECT is a number (floating point or integer).")
455 (object)
456 Lisp_Object object;
458 if (NUMBERP (object))
459 return Qt;
460 else
461 return Qnil;
464 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
465 Snumber_or_marker_p, 1, 1, 0,
466 "T if OBJECT is a number or a marker.")
467 (object)
468 Lisp_Object object;
470 if (NUMBERP (object) || MARKERP (object))
471 return Qt;
472 return Qnil;
475 #ifdef LISP_FLOAT_TYPE
476 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
477 "T if OBJECT is a floating point number.")
478 (object)
479 Lisp_Object object;
481 if (FLOATP (object))
482 return Qt;
483 return Qnil;
485 #endif /* LISP_FLOAT_TYPE */
487 /* Extract and set components of lists */
489 DEFUN ("car", Fcar, Scar, 1, 1, 0,
490 "Return the car of LIST. If arg is nil, return nil.\n\
491 Error if arg is not nil and not a cons cell. See also `car-safe'.")
492 (list)
493 register Lisp_Object list;
495 while (1)
497 if (CONSP (list))
498 return XCONS (list)->car;
499 else if (EQ (list, Qnil))
500 return Qnil;
501 else
502 list = wrong_type_argument (Qlistp, list);
506 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
507 "Return the car of OBJECT if it is a cons cell, or else nil.")
508 (object)
509 Lisp_Object object;
511 if (CONSP (object))
512 return XCONS (object)->car;
513 else
514 return Qnil;
517 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
518 "Return the cdr of LIST. If arg is nil, return nil.\n\
519 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
521 (list)
522 register Lisp_Object list;
524 while (1)
526 if (CONSP (list))
527 return XCONS (list)->cdr;
528 else if (EQ (list, Qnil))
529 return Qnil;
530 else
531 list = wrong_type_argument (Qlistp, list);
535 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
536 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
537 (object)
538 Lisp_Object object;
540 if (CONSP (object))
541 return XCONS (object)->cdr;
542 else
543 return Qnil;
546 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
547 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
548 (cell, newcar)
549 register Lisp_Object cell, newcar;
551 if (!CONSP (cell))
552 cell = wrong_type_argument (Qconsp, cell);
554 CHECK_IMPURE (cell);
555 XCONS (cell)->car = newcar;
556 return newcar;
559 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
560 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
561 (cell, newcdr)
562 register Lisp_Object cell, newcdr;
564 if (!CONSP (cell))
565 cell = wrong_type_argument (Qconsp, cell);
567 CHECK_IMPURE (cell);
568 XCONS (cell)->cdr = newcdr;
569 return newcdr;
572 /* Extract and set components of symbols */
574 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "T if SYMBOL's value is not void.")
575 (symbol)
576 register Lisp_Object symbol;
578 Lisp_Object valcontents;
579 CHECK_SYMBOL (symbol, 0);
581 valcontents = XSYMBOL (symbol)->value;
583 if (BUFFER_LOCAL_VALUEP (valcontents)
584 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
585 valcontents = swap_in_symval_forwarding (symbol, valcontents);
587 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
590 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "T if SYMBOL's function definition is not void.")
591 (symbol)
592 register Lisp_Object symbol;
594 CHECK_SYMBOL (symbol, 0);
595 return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
598 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
599 (symbol)
600 register Lisp_Object symbol;
602 CHECK_SYMBOL (symbol, 0);
603 if (NILP (symbol) || EQ (symbol, Qt))
604 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
605 Fset (symbol, Qunbound);
606 return symbol;
609 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
610 (symbol)
611 register Lisp_Object symbol;
613 CHECK_SYMBOL (symbol, 0);
614 if (NILP (symbol) || EQ (symbol, Qt))
615 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
616 XSYMBOL (symbol)->function = Qunbound;
617 return symbol;
620 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
621 "Return SYMBOL's function definition. Error if that is void.")
622 (symbol)
623 register Lisp_Object symbol;
625 CHECK_SYMBOL (symbol, 0);
626 if (EQ (XSYMBOL (symbol)->function, Qunbound))
627 return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
628 return XSYMBOL (symbol)->function;
631 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
632 (symbol)
633 register Lisp_Object symbol;
635 CHECK_SYMBOL (symbol, 0);
636 return XSYMBOL (symbol)->plist;
639 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
640 (symbol)
641 register Lisp_Object symbol;
643 register Lisp_Object name;
645 CHECK_SYMBOL (symbol, 0);
646 XSETSTRING (name, XSYMBOL (symbol)->name);
647 return name;
650 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
651 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
652 (symbol, definition)
653 register Lisp_Object symbol, definition;
655 CHECK_SYMBOL (symbol, 0);
656 if (NILP (symbol) || EQ (symbol, Qt))
657 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
658 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
659 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
660 Vautoload_queue);
661 XSYMBOL (symbol)->function = definition;
662 /* Handle automatic advice activation */
663 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
665 call2 (Qad_activate, symbol, Qnil);
666 definition = XSYMBOL (symbol)->function;
668 return definition;
671 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
672 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
673 Associates the function with the current load file, if any.")
674 (symbol, definition)
675 register Lisp_Object symbol, definition;
677 CHECK_SYMBOL (symbol, 0);
678 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
679 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
680 Vautoload_queue);
681 XSYMBOL (symbol)->function = definition;
682 /* Handle automatic advice activation */
683 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
685 call2 (Qad_activate, symbol, Qnil);
686 definition = XSYMBOL (symbol)->function;
688 LOADHIST_ATTACH (symbol);
689 return definition;
692 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
693 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
694 (symbol, newplist)
695 register Lisp_Object symbol, newplist;
697 CHECK_SYMBOL (symbol, 0);
698 XSYMBOL (symbol)->plist = newplist;
699 return newplist;
703 /* Getting and setting values of symbols */
705 /* Given the raw contents of a symbol value cell,
706 return the Lisp value of the symbol.
707 This does not handle buffer-local variables; use
708 swap_in_symval_forwarding for that. */
710 Lisp_Object
711 do_symval_forwarding (valcontents)
712 register Lisp_Object valcontents;
714 register Lisp_Object val;
715 int offset;
716 if (MISCP (valcontents))
717 switch (XMISCTYPE (valcontents))
719 case Lisp_Misc_Intfwd:
720 XSETINT (val, *XINTFWD (valcontents)->intvar);
721 return val;
723 case Lisp_Misc_Boolfwd:
724 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
726 case Lisp_Misc_Objfwd:
727 return *XOBJFWD (valcontents)->objvar;
729 case Lisp_Misc_Buffer_Objfwd:
730 offset = XBUFFER_OBJFWD (valcontents)->offset;
731 return *(Lisp_Object *)(offset + (char *)current_buffer);
733 case Lisp_Misc_Kboard_Objfwd:
734 offset = XKBOARD_OBJFWD (valcontents)->offset;
735 return *(Lisp_Object *)(offset + (char *)current_kboard);
737 return valcontents;
740 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
741 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
742 buffer-independent contents of the value cell: forwarded just one
743 step past the buffer-localness. */
745 void
746 store_symval_forwarding (symbol, valcontents, newval)
747 Lisp_Object symbol;
748 register Lisp_Object valcontents, newval;
750 switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
752 case Lisp_Misc:
753 switch (XMISCTYPE (valcontents))
755 case Lisp_Misc_Intfwd:
756 CHECK_NUMBER (newval, 1);
757 *XINTFWD (valcontents)->intvar = XINT (newval);
758 if (*XINTFWD (valcontents)->intvar != XINT (newval))
759 error ("Value out of range for variable `%s'",
760 XSYMBOL (symbol)->name->data);
761 break;
763 case Lisp_Misc_Boolfwd:
764 *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
765 break;
767 case Lisp_Misc_Objfwd:
768 *XOBJFWD (valcontents)->objvar = newval;
769 break;
771 case Lisp_Misc_Buffer_Objfwd:
773 int offset = XBUFFER_OBJFWD (valcontents)->offset;
774 Lisp_Object type;
776 type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
777 if (! NILP (type) && ! NILP (newval)
778 && XTYPE (newval) != XINT (type))
779 buffer_slot_type_mismatch (offset);
781 *(Lisp_Object *)(offset + (char *)current_buffer) = newval;
783 break;
785 case Lisp_Misc_Kboard_Objfwd:
786 (*(Lisp_Object *)((char *)current_kboard
787 + XKBOARD_OBJFWD (valcontents)->offset))
788 = newval;
789 break;
791 default:
792 goto def;
794 break;
796 default:
797 def:
798 valcontents = XSYMBOL (symbol)->value;
799 if (BUFFER_LOCAL_VALUEP (valcontents)
800 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
801 XBUFFER_LOCAL_VALUE (valcontents)->car = newval;
802 else
803 XSYMBOL (symbol)->value = newval;
807 /* Set up the buffer-local symbol SYMBOL for validity in the current
808 buffer. VALCONTENTS is the contents of its value cell.
809 Return the value forwarded one step past the buffer-local indicator. */
811 static Lisp_Object
812 swap_in_symval_forwarding (symbol, valcontents)
813 Lisp_Object symbol, valcontents;
815 /* valcontents is a pointer to a struct resembling the cons
816 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
818 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
819 local_var_alist, that being the element whose car is this
820 variable. Or it can be a pointer to the
821 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
822 an element in its alist for this variable.
824 If the current buffer is not BUFFER, we store the current
825 REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
826 appropriate alist element for the buffer now current and set up
827 CURRENT-ALIST-ELEMENT. Then we set REALVALUE out of that
828 element, and store into BUFFER.
830 Note that REALVALUE can be a forwarding pointer. */
832 register Lisp_Object tem1;
833 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
835 if (NILP (tem1) || current_buffer != XBUFFER (tem1))
837 tem1 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
838 Fsetcdr (tem1,
839 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
840 tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
841 if (NILP (tem1))
842 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
843 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car = tem1;
844 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
845 current_buffer);
846 store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
847 Fcdr (tem1));
849 return XBUFFER_LOCAL_VALUE (valcontents)->car;
852 /* Find the value of a symbol, returning Qunbound if it's not bound.
853 This is helpful for code which just wants to get a variable's value
854 if it has one, without signaling an error.
855 Note that it must not be possible to quit
856 within this function. Great care is required for this. */
858 Lisp_Object
859 find_symbol_value (symbol)
860 Lisp_Object symbol;
862 register Lisp_Object valcontents, tem1;
863 register Lisp_Object val;
864 CHECK_SYMBOL (symbol, 0);
865 valcontents = XSYMBOL (symbol)->value;
867 if (BUFFER_LOCAL_VALUEP (valcontents)
868 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
869 valcontents = swap_in_symval_forwarding (symbol, valcontents);
871 if (MISCP (valcontents))
873 switch (XMISCTYPE (valcontents))
875 case Lisp_Misc_Intfwd:
876 XSETINT (val, *XINTFWD (valcontents)->intvar);
877 return val;
879 case Lisp_Misc_Boolfwd:
880 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
882 case Lisp_Misc_Objfwd:
883 return *XOBJFWD (valcontents)->objvar;
885 case Lisp_Misc_Buffer_Objfwd:
886 return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
887 + (char *)current_buffer);
889 case Lisp_Misc_Kboard_Objfwd:
890 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
891 + (char *)current_kboard);
895 return valcontents;
898 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
899 "Return SYMBOL's value. Error if that is void.")
900 (symbol)
901 Lisp_Object symbol;
903 Lisp_Object val;
905 val = find_symbol_value (symbol);
906 if (EQ (val, Qunbound))
907 return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
908 else
909 return val;
912 DEFUN ("set", Fset, Sset, 2, 2, 0,
913 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
914 (symbol, newval)
915 register Lisp_Object symbol, newval;
917 return set_internal (symbol, newval, 0);
920 /* Stpre the value NEWVAL into SYMBOL.
921 If BINDFLAG is zero, then if this symbol is supposed to become
922 local in every buffer where it is set, then we make it local.
923 If BINDFLAG is nonzero, we don't do that. */
925 Lisp_Object
926 set_internal (symbol, newval, bindflag)
927 register Lisp_Object symbol, newval;
928 int bindflag;
930 int voide = EQ (newval, Qunbound);
932 register Lisp_Object valcontents, tem1, current_alist_element;
934 CHECK_SYMBOL (symbol, 0);
935 if (NILP (symbol) || EQ (symbol, Qt))
936 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
937 valcontents = XSYMBOL (symbol)->value;
939 if (BUFFER_OBJFWDP (valcontents))
941 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
942 register int mask = XINT (*((Lisp_Object *)
943 (idx + (char *)&buffer_local_flags)));
944 if (mask > 0)
945 current_buffer->local_var_flags |= mask;
948 else if (BUFFER_LOCAL_VALUEP (valcontents)
949 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
951 /* valcontents is actually a pointer to a struct resembling a cons,
952 with contents something like:
953 (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE).
955 BUFFER is the last buffer for which this symbol's value was
956 made up to date.
958 CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
959 local_var_alist, that being the element whose car is this
960 variable. Or it can be a pointer to the
961 (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not
962 have an element in its alist for this variable (that is, if
963 BUFFER sees the default value of this variable).
965 If we want to examine or set the value and BUFFER is current,
966 we just examine or set REALVALUE. If BUFFER is not current, we
967 store the current REALVALUE value into CURRENT-ALIST-ELEMENT,
968 then find the appropriate alist element for the buffer now
969 current and set up CURRENT-ALIST-ELEMENT. Then we set
970 REALVALUE out of that element, and store into BUFFER.
972 If we are setting the variable and the current buffer does
973 not have an alist entry for this variable, an alist entry is
974 created.
976 Note that REALVALUE can be a forwarding pointer. Each time
977 it is examined or set, forwarding must be done. */
979 /* What value are we caching right now? */
980 current_alist_element =
981 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
983 /* If the current buffer is not the buffer whose binding is
984 currently cached, or if it's a Lisp_Buffer_Local_Value and
985 we're looking at the default value, the cache is invalid; we
986 need to write it out, and find the new CURRENT-ALIST-ELEMENT. */
987 if ((current_buffer
988 != XBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car))
989 || (BUFFER_LOCAL_VALUEP (valcontents)
990 && EQ (XCONS (current_alist_element)->car,
991 current_alist_element)))
993 /* Write out the cached value for the old buffer; copy it
994 back to its alist element. This works if the current
995 buffer only sees the default value, too. */
996 Fsetcdr (current_alist_element,
997 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car));
999 /* Find the new value for CURRENT-ALIST-ELEMENT. */
1000 tem1 = Fassq (symbol, current_buffer->local_var_alist);
1001 if (NILP (tem1))
1003 /* This buffer still sees the default value. */
1005 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1006 or if this is `let' rather than `set',
1007 make CURRENT-ALIST-ELEMENT point to itself,
1008 indicating that we're seeing the default value. */
1009 if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1010 tem1 = XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr;
1012 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1013 give this buffer a new assoc for a local value and set
1014 CURRENT-ALIST-ELEMENT to point to that. */
1015 else
1017 tem1 = Fcons (symbol, Fcdr (current_alist_element));
1018 current_buffer->local_var_alist =
1019 Fcons (tem1, current_buffer->local_var_alist);
1022 /* Cache the new buffer's assoc in CURRENT-ALIST-ELEMENT. */
1023 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car
1024 = tem1;
1026 /* Set BUFFER, now that CURRENT-ALIST-ELEMENT is accurate. */
1027 XSETBUFFER (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car,
1028 current_buffer);
1030 valcontents = XBUFFER_LOCAL_VALUE (valcontents)->car;
1033 /* If storing void (making the symbol void), forward only through
1034 buffer-local indicator, not through Lisp_Objfwd, etc. */
1035 if (voide)
1036 store_symval_forwarding (symbol, Qnil, newval);
1037 else
1038 store_symval_forwarding (symbol, valcontents, newval);
1040 return newval;
1043 /* Access or set a buffer-local symbol's default value. */
1045 /* Return the default value of SYMBOL, but don't check for voidness.
1046 Return Qunbound if it is void. */
1048 Lisp_Object
1049 default_value (symbol)
1050 Lisp_Object symbol;
1052 register Lisp_Object valcontents;
1054 CHECK_SYMBOL (symbol, 0);
1055 valcontents = XSYMBOL (symbol)->value;
1057 /* For a built-in buffer-local variable, get the default value
1058 rather than letting do_symval_forwarding get the current value. */
1059 if (BUFFER_OBJFWDP (valcontents))
1061 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1063 if (XINT (*(Lisp_Object *) (idx + (char *) &buffer_local_flags)) != 0)
1064 return *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1067 /* Handle user-created local variables. */
1068 if (BUFFER_LOCAL_VALUEP (valcontents)
1069 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1071 /* If var is set up for a buffer that lacks a local value for it,
1072 the current value is nominally the default value.
1073 But the current value slot may be more up to date, since
1074 ordinary setq stores just that slot. So use that. */
1075 Lisp_Object current_alist_element, alist_element_car;
1076 current_alist_element
1077 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
1078 alist_element_car = XCONS (current_alist_element)->car;
1079 if (EQ (alist_element_car, current_alist_element))
1080 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->car);
1081 else
1082 return XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr;
1084 /* For other variables, get the current value. */
1085 return do_symval_forwarding (valcontents);
1088 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1089 "Return T if SYMBOL has a non-void default value.\n\
1090 This is the value that is seen in buffers that do not have their own values\n\
1091 for this variable.")
1092 (symbol)
1093 Lisp_Object symbol;
1095 register Lisp_Object value;
1097 value = default_value (symbol);
1098 return (EQ (value, Qunbound) ? Qnil : Qt);
1101 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1102 "Return SYMBOL's default value.\n\
1103 This is the value that is seen in buffers that do not have their own values\n\
1104 for this variable. The default value is meaningful for variables with\n\
1105 local bindings in certain buffers.")
1106 (symbol)
1107 Lisp_Object symbol;
1109 register Lisp_Object value;
1111 value = default_value (symbol);
1112 if (EQ (value, Qunbound))
1113 return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
1114 return value;
1117 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1118 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1119 The default value is seen in buffers that do not have their own values\n\
1120 for this variable.")
1121 (symbol, value)
1122 Lisp_Object symbol, value;
1124 register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
1126 CHECK_SYMBOL (symbol, 0);
1127 valcontents = XSYMBOL (symbol)->value;
1129 /* Handle variables like case-fold-search that have special slots
1130 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1131 variables. */
1132 if (BUFFER_OBJFWDP (valcontents))
1134 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1135 register struct buffer *b;
1136 register int mask = XINT (*((Lisp_Object *)
1137 (idx + (char *)&buffer_local_flags)));
1139 if (mask > 0)
1141 *(Lisp_Object *)(idx + (char *) &buffer_defaults) = value;
1142 for (b = all_buffers; b; b = b->next)
1143 if (!(b->local_var_flags & mask))
1144 *(Lisp_Object *)(idx + (char *) b) = value;
1146 return value;
1149 if (!BUFFER_LOCAL_VALUEP (valcontents)
1150 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1151 return Fset (symbol, value);
1153 /* Store new value into the DEFAULT-VALUE slot */
1154 XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->cdr = value;
1156 /* If that slot is current, we must set the REALVALUE slot too */
1157 current_alist_element
1158 = XCONS (XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->cdr)->car;
1159 alist_element_buffer = Fcar (current_alist_element);
1160 if (EQ (alist_element_buffer, current_alist_element))
1161 store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->car,
1162 value);
1164 return value;
1167 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
1168 "Set the default value of variable VAR to VALUE.\n\
1169 VAR, the variable name, is literal (not evaluated);\n\
1170 VALUE is an expression and it is evaluated.\n\
1171 The default value of a variable is seen in buffers\n\
1172 that do not have their own values for the variable.\n\
1174 More generally, you can use multiple variables and values, as in\n\
1175 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1176 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1177 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1178 of previous SYMs.")
1179 (args)
1180 Lisp_Object args;
1182 register Lisp_Object args_left;
1183 register Lisp_Object val, symbol;
1184 struct gcpro gcpro1;
1186 if (NILP (args))
1187 return Qnil;
1189 args_left = args;
1190 GCPRO1 (args);
1194 val = Feval (Fcar (Fcdr (args_left)));
1195 symbol = Fcar (args_left);
1196 Fset_default (symbol, val);
1197 args_left = Fcdr (Fcdr (args_left));
1199 while (!NILP (args_left));
1201 UNGCPRO;
1202 return val;
1205 /* Lisp functions for creating and removing buffer-local variables. */
1207 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1208 1, 1, "vMake Variable Buffer Local: ",
1209 "Make VARIABLE have a separate value for each buffer.\n\
1210 At any time, the value for the current buffer is in effect.\n\
1211 There is also a default value which is seen in any buffer which has not yet\n\
1212 set its own value.\n\
1213 Using `set' or `setq' to set the variable causes it to have a separate value\n\
1214 for the current buffer if it was previously using the default value.\n\
1215 The function `default-value' gets the default value and `set-default' sets it.")
1216 (variable)
1217 register Lisp_Object variable;
1219 register Lisp_Object tem, valcontents, newval;
1221 CHECK_SYMBOL (variable, 0);
1223 valcontents = XSYMBOL (variable)->value;
1224 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1225 error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1227 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1228 return variable;
1229 if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1231 XMISCTYPE (XSYMBOL (variable)->value) = Lisp_Misc_Buffer_Local_Value;
1232 return variable;
1234 if (EQ (valcontents, Qunbound))
1235 XSYMBOL (variable)->value = Qnil;
1236 tem = Fcons (Qnil, Fsymbol_value (variable));
1237 XCONS (tem)->car = tem;
1238 newval = allocate_misc ();
1239 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1240 XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
1241 XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Fcurrent_buffer (), tem);
1242 XSYMBOL (variable)->value = newval;
1243 return variable;
1246 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1247 1, 1, "vMake Local Variable: ",
1248 "Make VARIABLE have a separate value in the current buffer.\n\
1249 Other buffers will continue to share a common default value.\n\
1250 \(The buffer-local value of VARIABLE starts out as the same value\n\
1251 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1252 See also `make-variable-buffer-local'.\n\n\
1253 If the variable is already arranged to become local when set,\n\
1254 this function causes a local value to exist for this buffer,\n\
1255 just as setting the variable would do.\n\
1257 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1258 Use `make-local-hook' instead.")
1259 (variable)
1260 register Lisp_Object variable;
1262 register Lisp_Object tem, valcontents;
1264 CHECK_SYMBOL (variable, 0);
1266 valcontents = XSYMBOL (variable)->value;
1267 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1268 error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1270 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1272 tem = Fboundp (variable);
1274 /* Make sure the symbol has a local value in this particular buffer,
1275 by setting it to the same value it already has. */
1276 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1277 return variable;
1279 /* Make sure symbol is set up to hold per-buffer values */
1280 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
1282 Lisp_Object newval;
1283 tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1284 XCONS (tem)->car = tem;
1285 newval = allocate_misc ();
1286 XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
1287 XBUFFER_LOCAL_VALUE (newval)->car = XSYMBOL (variable)->value;
1288 XBUFFER_LOCAL_VALUE (newval)->cdr = Fcons (Qnil, tem);
1289 XSYMBOL (variable)->value = newval;
1291 /* Make sure this buffer has its own value of symbol */
1292 tem = Fassq (variable, current_buffer->local_var_alist);
1293 if (NILP (tem))
1295 /* Swap out any local binding for some other buffer, and make
1296 sure the current value is permanently recorded, if it's the
1297 default value. */
1298 find_symbol_value (variable);
1300 current_buffer->local_var_alist
1301 = Fcons (Fcons (variable, XCONS (XCONS (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)->cdr)->cdr),
1302 current_buffer->local_var_alist);
1304 /* Make sure symbol does not think it is set up for this buffer;
1305 force it to look once again for this buffer's value */
1307 Lisp_Object *pvalbuf;
1309 valcontents = XSYMBOL (variable)->value;
1311 pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
1312 if (current_buffer == XBUFFER (*pvalbuf))
1313 *pvalbuf = Qnil;
1317 /* If the symbol forwards into a C variable, then swap in the
1318 variable for this buffer immediately. If C code modifies the
1319 variable before we swap in, then that new value will clobber the
1320 default value the next time we swap. */
1321 valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->car;
1322 if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
1323 swap_in_symval_forwarding (variable, XSYMBOL (variable)->value);
1325 return variable;
1328 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1329 1, 1, "vKill Local Variable: ",
1330 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1331 From now on the default value will apply in this buffer.")
1332 (variable)
1333 register Lisp_Object variable;
1335 register Lisp_Object tem, valcontents;
1337 CHECK_SYMBOL (variable, 0);
1339 valcontents = XSYMBOL (variable)->value;
1341 if (BUFFER_OBJFWDP (valcontents))
1343 register int idx = XBUFFER_OBJFWD (valcontents)->offset;
1344 register int mask = XINT (*((Lisp_Object*)
1345 (idx + (char *)&buffer_local_flags)));
1347 if (mask > 0)
1349 *(Lisp_Object *)(idx + (char *) current_buffer)
1350 = *(Lisp_Object *)(idx + (char *) &buffer_defaults);
1351 current_buffer->local_var_flags &= ~mask;
1353 return variable;
1356 if (!BUFFER_LOCAL_VALUEP (valcontents)
1357 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1358 return variable;
1360 /* Get rid of this buffer's alist element, if any */
1362 tem = Fassq (variable, current_buffer->local_var_alist);
1363 if (!NILP (tem))
1364 current_buffer->local_var_alist
1365 = Fdelq (tem, current_buffer->local_var_alist);
1367 /* If the symbol is set up for the current buffer, recompute its
1368 value. We have to do it now, or else forwarded objects won't
1369 work right. */
1371 Lisp_Object *pvalbuf;
1372 valcontents = XSYMBOL (variable)->value;
1373 pvalbuf = &XCONS (XBUFFER_LOCAL_VALUE (valcontents)->cdr)->car;
1374 if (current_buffer == XBUFFER (*pvalbuf))
1376 *pvalbuf = Qnil;
1377 find_symbol_value (variable);
1381 return variable;
1384 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1385 1, 2, 0,
1386 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1387 BUFFER defaults to the current buffer.")
1388 (variable, buffer)
1389 register Lisp_Object variable, buffer;
1391 Lisp_Object valcontents;
1392 register struct buffer *buf;
1394 if (NILP (buffer))
1395 buf = current_buffer;
1396 else
1398 CHECK_BUFFER (buffer, 0);
1399 buf = XBUFFER (buffer);
1402 CHECK_SYMBOL (variable, 0);
1404 valcontents = XSYMBOL (variable)->value;
1405 if (BUFFER_LOCAL_VALUEP (valcontents)
1406 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1408 Lisp_Object tail, elt;
1409 for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1411 elt = XCONS (tail)->car;
1412 if (EQ (variable, XCONS (elt)->car))
1413 return Qt;
1416 if (BUFFER_OBJFWDP (valcontents))
1418 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1419 int mask = XINT (*(Lisp_Object *)(offset + (char *)&buffer_local_flags));
1420 if (mask == -1 || (buf->local_var_flags & mask))
1421 return Qt;
1423 return Qnil;
1426 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1427 1, 2, 0,
1428 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1429 BUFFER defaults to the current buffer.")
1430 (variable, buffer)
1431 register Lisp_Object variable, buffer;
1433 Lisp_Object valcontents;
1434 register struct buffer *buf;
1436 if (NILP (buffer))
1437 buf = current_buffer;
1438 else
1440 CHECK_BUFFER (buffer, 0);
1441 buf = XBUFFER (buffer);
1444 CHECK_SYMBOL (variable, 0);
1446 valcontents = XSYMBOL (variable)->value;
1448 /* This means that make-variable-buffer-local was done. */
1449 if (BUFFER_LOCAL_VALUEP (valcontents))
1450 return Qt;
1451 /* All these slots become local if they are set. */
1452 if (BUFFER_OBJFWDP (valcontents))
1453 return Qt;
1454 if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1456 Lisp_Object tail, elt;
1457 for (tail = buf->local_var_alist; CONSP (tail); tail = XCONS (tail)->cdr)
1459 elt = XCONS (tail)->car;
1460 if (EQ (variable, XCONS (elt)->car))
1461 return Qt;
1464 return Qnil;
1467 /* Find the function at the end of a chain of symbol function indirections. */
1469 /* If OBJECT is a symbol, find the end of its function chain and
1470 return the value found there. If OBJECT is not a symbol, just
1471 return it. If there is a cycle in the function chain, signal a
1472 cyclic-function-indirection error.
1474 This is like Findirect_function, except that it doesn't signal an
1475 error if the chain ends up unbound. */
1476 Lisp_Object
1477 indirect_function (object)
1478 register Lisp_Object object;
1480 Lisp_Object tortoise, hare;
1482 hare = tortoise = object;
1484 for (;;)
1486 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1487 break;
1488 hare = XSYMBOL (hare)->function;
1489 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1490 break;
1491 hare = XSYMBOL (hare)->function;
1493 tortoise = XSYMBOL (tortoise)->function;
1495 if (EQ (hare, tortoise))
1496 Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
1499 return hare;
1502 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
1503 "Return the function at the end of OBJECT's function chain.\n\
1504 If OBJECT is a symbol, follow all function indirections and return the final\n\
1505 function binding.\n\
1506 If OBJECT is not a symbol, just return it.\n\
1507 Signal a void-function error if the final symbol is unbound.\n\
1508 Signal a cyclic-function-indirection error if there is a loop in the\n\
1509 function chain of symbols.")
1510 (object)
1511 register Lisp_Object object;
1513 Lisp_Object result;
1515 result = indirect_function (object);
1517 if (EQ (result, Qunbound))
1518 return Fsignal (Qvoid_function, Fcons (object, Qnil));
1519 return result;
1522 /* Extract and set vector and string elements */
1524 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1525 "Return the element of ARRAY at index IDX.\n\
1526 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1527 or a byte-code object. IDX starts at 0.")
1528 (array, idx)
1529 register Lisp_Object array;
1530 Lisp_Object idx;
1532 register int idxval;
1534 CHECK_NUMBER (idx, 1);
1535 idxval = XINT (idx);
1536 if (STRINGP (array))
1538 Lisp_Object val;
1539 if (idxval < 0 || idxval >= XSTRING (array)->size)
1540 args_out_of_range (array, idx);
1541 XSETFASTINT (val, (unsigned char) XSTRING (array)->data[idxval]);
1542 return val;
1544 else if (BOOL_VECTOR_P (array))
1546 int val;
1548 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1549 args_out_of_range (array, idx);
1551 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1552 return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil);
1554 else if (CHAR_TABLE_P (array))
1556 Lisp_Object val;
1558 if (idxval < 0)
1559 args_out_of_range (array, idx);
1560 if (idxval < CHAR_TABLE_SINGLE_BYTE_SLOTS)
1562 /* For ASCII and 8-bit European characters, the element is
1563 stored in the top table. */
1564 val = XCHAR_TABLE (array)->contents[idxval];
1565 if (NILP (val))
1566 val = XCHAR_TABLE (array)->defalt;
1567 while (NILP (val)) /* Follow parents until we find some value. */
1569 array = XCHAR_TABLE (array)->parent;
1570 if (NILP (array))
1571 return Qnil;
1572 val = XCHAR_TABLE (array)->contents[idxval];
1573 if (NILP (val))
1574 val = XCHAR_TABLE (array)->defalt;
1576 return val;
1578 else
1580 int code[4], i;
1581 Lisp_Object sub_table;
1583 SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
1584 if (code[0] != CHARSET_COMPOSITION)
1586 if (code[1] < 32) code[1] = -1;
1587 else if (code[2] < 32) code[2] = -1;
1589 /* Here, the possible range of CODE[0] (== charset ID) is
1590 128..MAX_CHARSET. Since the top level char table contains
1591 data for multibyte characters after 256th element, we must
1592 increment CODE[0] by 128 to get a correct index. */
1593 code[0] += 128;
1594 code[3] = -1; /* anchor */
1596 try_parent_char_table:
1597 sub_table = array;
1598 for (i = 0; code[i] >= 0; i++)
1600 val = XCHAR_TABLE (sub_table)->contents[code[i]];
1601 if (SUB_CHAR_TABLE_P (val))
1602 sub_table = val;
1603 else
1605 if (NILP (val))
1606 val = XCHAR_TABLE (sub_table)->defalt;
1607 if (NILP (val))
1609 array = XCHAR_TABLE (array)->parent;
1610 if (!NILP (array))
1611 goto try_parent_char_table;
1613 return val;
1616 /* Here, VAL is a sub char table. We try the default value
1617 and parent. */
1618 val = XCHAR_TABLE (val)->defalt;
1619 if (NILP (val))
1621 array = XCHAR_TABLE (array)->parent;
1622 if (!NILP (array))
1623 goto try_parent_char_table;
1625 return val;
1628 else
1630 int size;
1631 if (VECTORP (array))
1632 size = XVECTOR (array)->size;
1633 else if (COMPILEDP (array))
1634 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
1635 else
1636 wrong_type_argument (Qarrayp, array);
1638 if (idxval < 0 || idxval >= size)
1639 args_out_of_range (array, idx);
1640 return XVECTOR (array)->contents[idxval];
1644 DEFUN ("aset", Faset, Saset, 3, 3, 0,
1645 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1646 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1647 IDX starts at 0.")
1648 (array, idx, newelt)
1649 register Lisp_Object array;
1650 Lisp_Object idx, newelt;
1652 register int idxval;
1654 CHECK_NUMBER (idx, 1);
1655 idxval = XINT (idx);
1656 if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
1657 && ! CHAR_TABLE_P (array))
1658 array = wrong_type_argument (Qarrayp, array);
1659 CHECK_IMPURE (array);
1661 if (VECTORP (array))
1663 if (idxval < 0 || idxval >= XVECTOR (array)->size)
1664 args_out_of_range (array, idx);
1665 XVECTOR (array)->contents[idxval] = newelt;
1667 else if (BOOL_VECTOR_P (array))
1669 int val;
1671 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1672 args_out_of_range (array, idx);
1674 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1676 if (! NILP (newelt))
1677 val |= 1 << (idxval % BITS_PER_CHAR);
1678 else
1679 val &= ~(1 << (idxval % BITS_PER_CHAR));
1680 XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val;
1682 else if (CHAR_TABLE_P (array))
1684 Lisp_Object val;
1686 if (idxval < 0)
1687 args_out_of_range (array, idx);
1688 if (idxval < CHAR_TABLE_SINGLE_BYTE_SLOTS)
1689 XCHAR_TABLE (array)->contents[idxval] = newelt;
1690 else
1692 int code[4], i;
1693 Lisp_Object val;
1695 SPLIT_NON_ASCII_CHAR (idxval, code[0], code[1], code[2]);
1696 if (code[0] != CHARSET_COMPOSITION)
1698 if (code[1] < 32) code[1] = -1;
1699 else if (code[2] < 32) code[2] = -1;
1701 /* See the comment of the corresponding part in Faref. */
1702 code[0] += 128;
1703 code[3] = -1; /* anchor */
1704 for (i = 0; code[i + 1] >= 0; i++)
1706 val = XCHAR_TABLE (array)->contents[code[i]];
1707 if (SUB_CHAR_TABLE_P (val))
1708 array = val;
1709 else
1710 /* VAL is a leaf. Create a sub char table with the
1711 default value VAL or XCHAR_TABLE (array)->defalt
1712 and look into it. */
1713 array = (XCHAR_TABLE (array)->contents[code[i]]
1714 = make_sub_char_table (NILP (val)
1715 ? XCHAR_TABLE (array)->defalt
1716 : val));
1718 XCHAR_TABLE (array)->contents[code[i]] = newelt;
1721 else
1723 if (idxval < 0 || idxval >= XSTRING (array)->size)
1724 args_out_of_range (array, idx);
1725 CHECK_NUMBER (newelt, 2);
1726 XSTRING (array)->data[idxval] = XINT (newelt);
1729 return newelt;
1732 /* Arithmetic functions */
1734 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
1736 Lisp_Object
1737 arithcompare (num1, num2, comparison)
1738 Lisp_Object num1, num2;
1739 enum comparison comparison;
1741 double f1, f2;
1742 int floatp = 0;
1744 #ifdef LISP_FLOAT_TYPE
1745 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
1746 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
1748 if (FLOATP (num1) || FLOATP (num2))
1750 floatp = 1;
1751 f1 = (FLOATP (num1)) ? XFLOAT (num1)->data : XINT (num1);
1752 f2 = (FLOATP (num2)) ? XFLOAT (num2)->data : XINT (num2);
1754 #else
1755 CHECK_NUMBER_COERCE_MARKER (num1, 0);
1756 CHECK_NUMBER_COERCE_MARKER (num2, 0);
1757 #endif /* LISP_FLOAT_TYPE */
1759 switch (comparison)
1761 case equal:
1762 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
1763 return Qt;
1764 return Qnil;
1766 case notequal:
1767 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
1768 return Qt;
1769 return Qnil;
1771 case less:
1772 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
1773 return Qt;
1774 return Qnil;
1776 case less_or_equal:
1777 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
1778 return Qt;
1779 return Qnil;
1781 case grtr:
1782 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
1783 return Qt;
1784 return Qnil;
1786 case grtr_or_equal:
1787 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
1788 return Qt;
1789 return Qnil;
1791 default:
1792 abort ();
1796 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
1797 "T if two args, both numbers or markers, are equal.")
1798 (num1, num2)
1799 register Lisp_Object num1, num2;
1801 return arithcompare (num1, num2, equal);
1804 DEFUN ("<", Flss, Slss, 2, 2, 0,
1805 "T if first arg is less than second arg. Both must be numbers or markers.")
1806 (num1, num2)
1807 register Lisp_Object num1, num2;
1809 return arithcompare (num1, num2, less);
1812 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
1813 "T if first arg is greater than second arg. Both must be numbers or markers.")
1814 (num1, num2)
1815 register Lisp_Object num1, num2;
1817 return arithcompare (num1, num2, grtr);
1820 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
1821 "T if first arg is less than or equal to second arg.\n\
1822 Both must be numbers or markers.")
1823 (num1, num2)
1824 register Lisp_Object num1, num2;
1826 return arithcompare (num1, num2, less_or_equal);
1829 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
1830 "T if first arg is greater than or equal to second arg.\n\
1831 Both must be numbers or markers.")
1832 (num1, num2)
1833 register Lisp_Object num1, num2;
1835 return arithcompare (num1, num2, grtr_or_equal);
1838 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
1839 "T if first arg is not equal to second arg. Both must be numbers or markers.")
1840 (num1, num2)
1841 register Lisp_Object num1, num2;
1843 return arithcompare (num1, num2, notequal);
1846 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
1847 (number)
1848 register Lisp_Object number;
1850 #ifdef LISP_FLOAT_TYPE
1851 CHECK_NUMBER_OR_FLOAT (number, 0);
1853 if (FLOATP (number))
1855 if (XFLOAT(number)->data == 0.0)
1856 return Qt;
1857 return Qnil;
1859 #else
1860 CHECK_NUMBER (number, 0);
1861 #endif /* LISP_FLOAT_TYPE */
1863 if (!XINT (number))
1864 return Qt;
1865 return Qnil;
1868 /* Convert between long values and pairs of Lisp integers. */
1870 Lisp_Object
1871 long_to_cons (i)
1872 unsigned long i;
1874 unsigned int top = i >> 16;
1875 unsigned int bot = i & 0xFFFF;
1876 if (top == 0)
1877 return make_number (bot);
1878 if (top == (unsigned long)-1 >> 16)
1879 return Fcons (make_number (-1), make_number (bot));
1880 return Fcons (make_number (top), make_number (bot));
1883 unsigned long
1884 cons_to_long (c)
1885 Lisp_Object c;
1887 Lisp_Object top, bot;
1888 if (INTEGERP (c))
1889 return XINT (c);
1890 top = XCONS (c)->car;
1891 bot = XCONS (c)->cdr;
1892 if (CONSP (bot))
1893 bot = XCONS (bot)->car;
1894 return ((XINT (top) << 16) | XINT (bot));
1897 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
1898 "Convert NUMBER to a string by printing it in decimal.\n\
1899 Uses a minus sign if negative.\n\
1900 NUMBER may be an integer or a floating point number.")
1901 (number)
1902 Lisp_Object number;
1904 char buffer[VALBITS];
1906 #ifndef LISP_FLOAT_TYPE
1907 CHECK_NUMBER (number, 0);
1908 #else
1909 CHECK_NUMBER_OR_FLOAT (number, 0);
1911 if (FLOATP (number))
1913 char pigbuf[350]; /* see comments in float_to_string */
1915 float_to_string (pigbuf, XFLOAT(number)->data);
1916 return build_string (pigbuf);
1918 #endif /* LISP_FLOAT_TYPE */
1920 if (sizeof (int) == sizeof (EMACS_INT))
1921 sprintf (buffer, "%d", XINT (number));
1922 else if (sizeof (long) == sizeof (EMACS_INT))
1923 sprintf (buffer, "%ld", XINT (number));
1924 else
1925 abort ();
1926 return build_string (buffer);
1929 INLINE static int
1930 digit_to_number (character, base)
1931 int character, base;
1933 int digit;
1935 if (character >= '0' && character <= '9')
1936 digit = character - '0';
1937 else if (character >= 'a' && character <= 'z')
1938 digit = character - 'a' + 10;
1939 else if (character >= 'A' && character <= 'Z')
1940 digit = character - 'A' + 10;
1941 else
1942 return -1;
1944 if (digit >= base)
1945 return -1;
1946 else
1947 return digit;
1950 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
1951 "Convert STRING to a number by parsing it as a decimal number.\n\
1952 This parses both integers and floating point numbers.\n\
1953 It ignores leading spaces and tabs.\n\
1955 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
1956 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
1957 Floating point numbers always use base 10.")
1958 (string, base)
1959 register Lisp_Object string, base;
1961 register unsigned char *p;
1962 register int b, digit, v = 0;
1963 int negative = 1;
1965 CHECK_STRING (string, 0);
1967 if (NILP (base))
1968 b = 10;
1969 else
1971 CHECK_NUMBER (base, 1);
1972 b = XINT (base);
1973 if (b < 2 || b > 16)
1974 Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
1977 p = XSTRING (string)->data;
1979 /* Skip any whitespace at the front of the number. Some versions of
1980 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1981 while (*p == ' ' || *p == '\t')
1982 p++;
1984 if (*p == '-')
1986 negative = -1;
1987 p++;
1989 else if (*p == '+')
1990 p++;
1992 #ifdef LISP_FLOAT_TYPE
1993 if (isfloat_string (p))
1994 return make_float (atof (p));
1995 #endif /* LISP_FLOAT_TYPE */
1997 while (1)
1999 int digit = digit_to_number (*p++, b);
2000 if (digit < 0)
2001 break;
2002 v = v * b + digit;
2005 return make_number (negative * v);
2009 enum arithop
2010 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
2012 extern Lisp_Object float_arith_driver ();
2013 extern Lisp_Object fmod_float ();
2015 Lisp_Object
2016 arith_driver (code, nargs, args)
2017 enum arithop code;
2018 int nargs;
2019 register Lisp_Object *args;
2021 register Lisp_Object val;
2022 register int argnum;
2023 register EMACS_INT accum;
2024 register EMACS_INT next;
2026 switch (SWITCH_ENUM_CAST (code))
2028 case Alogior:
2029 case Alogxor:
2030 case Aadd:
2031 case Asub:
2032 accum = 0; break;
2033 case Amult:
2034 accum = 1; break;
2035 case Alogand:
2036 accum = -1; break;
2039 for (argnum = 0; argnum < nargs; argnum++)
2041 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2042 #ifdef LISP_FLOAT_TYPE
2043 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
2045 if (FLOATP (val)) /* time to do serious math */
2046 return (float_arith_driver ((double) accum, argnum, code,
2047 nargs, args));
2048 #else
2049 CHECK_NUMBER_COERCE_MARKER (val, argnum);
2050 #endif /* LISP_FLOAT_TYPE */
2051 args[argnum] = val; /* runs into a compiler bug. */
2052 next = XINT (args[argnum]);
2053 switch (SWITCH_ENUM_CAST (code))
2055 case Aadd: accum += next; break;
2056 case Asub:
2057 if (!argnum && nargs != 1)
2058 next = - next;
2059 accum -= next;
2060 break;
2061 case Amult: accum *= next; break;
2062 case Adiv:
2063 if (!argnum) accum = next;
2064 else
2066 if (next == 0)
2067 Fsignal (Qarith_error, Qnil);
2068 accum /= next;
2070 break;
2071 case Alogand: accum &= next; break;
2072 case Alogior: accum |= next; break;
2073 case Alogxor: accum ^= next; break;
2074 case Amax: if (!argnum || next > accum) accum = next; break;
2075 case Amin: if (!argnum || next < accum) accum = next; break;
2079 XSETINT (val, accum);
2080 return val;
2083 #undef isnan
2084 #define isnan(x) ((x) != (x))
2086 #ifdef LISP_FLOAT_TYPE
2088 Lisp_Object
2089 float_arith_driver (accum, argnum, code, nargs, args)
2090 double accum;
2091 register int argnum;
2092 enum arithop code;
2093 int nargs;
2094 register Lisp_Object *args;
2096 register Lisp_Object val;
2097 double next;
2099 for (; argnum < nargs; argnum++)
2101 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2102 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
2104 if (FLOATP (val))
2106 next = XFLOAT (val)->data;
2108 else
2110 args[argnum] = val; /* runs into a compiler bug. */
2111 next = XINT (args[argnum]);
2113 switch (SWITCH_ENUM_CAST (code))
2115 case Aadd:
2116 accum += next;
2117 break;
2118 case Asub:
2119 if (!argnum && nargs != 1)
2120 next = - next;
2121 accum -= next;
2122 break;
2123 case Amult:
2124 accum *= next;
2125 break;
2126 case Adiv:
2127 if (!argnum)
2128 accum = next;
2129 else
2131 if (! IEEE_FLOATING_POINT && next == 0)
2132 Fsignal (Qarith_error, Qnil);
2133 accum /= next;
2135 break;
2136 case Alogand:
2137 case Alogior:
2138 case Alogxor:
2139 return wrong_type_argument (Qinteger_or_marker_p, val);
2140 case Amax:
2141 if (!argnum || isnan (next) || next > accum)
2142 accum = next;
2143 break;
2144 case Amin:
2145 if (!argnum || isnan (next) || next < accum)
2146 accum = next;
2147 break;
2151 return make_float (accum);
2153 #endif /* LISP_FLOAT_TYPE */
2155 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2156 "Return sum of any number of arguments, which are numbers or markers.")
2157 (nargs, args)
2158 int nargs;
2159 Lisp_Object *args;
2161 return arith_driver (Aadd, nargs, args);
2164 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2165 "Negate number or subtract numbers or markers.\n\
2166 With one arg, negates it. With more than one arg,\n\
2167 subtracts all but the first from the first.")
2168 (nargs, args)
2169 int nargs;
2170 Lisp_Object *args;
2172 return arith_driver (Asub, nargs, args);
2175 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2176 "Returns product of any number of arguments, which are numbers or markers.")
2177 (nargs, args)
2178 int nargs;
2179 Lisp_Object *args;
2181 return arith_driver (Amult, nargs, args);
2184 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2185 "Returns first argument divided by all the remaining arguments.\n\
2186 The arguments must be numbers or markers.")
2187 (nargs, args)
2188 int nargs;
2189 Lisp_Object *args;
2191 return arith_driver (Adiv, nargs, args);
2194 DEFUN ("%", Frem, Srem, 2, 2, 0,
2195 "Returns remainder of X divided by Y.\n\
2196 Both must be integers or markers.")
2197 (x, y)
2198 register Lisp_Object x, y;
2200 Lisp_Object val;
2202 CHECK_NUMBER_COERCE_MARKER (x, 0);
2203 CHECK_NUMBER_COERCE_MARKER (y, 1);
2205 if (XFASTINT (y) == 0)
2206 Fsignal (Qarith_error, Qnil);
2208 XSETINT (val, XINT (x) % XINT (y));
2209 return val;
2212 #ifndef HAVE_FMOD
2213 double
2214 fmod (f1, f2)
2215 double f1, f2;
2217 double r = f1;
2219 if (f2 < 0.0)
2220 f2 = -f2;
2222 /* If the magnitude of the result exceeds that of the divisor, or
2223 the sign of the result does not agree with that of the dividend,
2224 iterate with the reduced value. This does not yield a
2225 particularly accurate result, but at least it will be in the
2226 range promised by fmod. */
2228 r -= f2 * floor (r / f2);
2229 while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
2231 return r;
2233 #endif /* ! HAVE_FMOD */
2235 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2236 "Returns X modulo Y.\n\
2237 The result falls between zero (inclusive) and Y (exclusive).\n\
2238 Both X and Y must be numbers or markers.")
2239 (x, y)
2240 register Lisp_Object x, y;
2242 Lisp_Object val;
2243 EMACS_INT i1, i2;
2245 #ifdef LISP_FLOAT_TYPE
2246 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x, 0);
2247 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1);
2249 if (FLOATP (x) || FLOATP (y))
2250 return fmod_float (x, y);
2252 #else /* not LISP_FLOAT_TYPE */
2253 CHECK_NUMBER_COERCE_MARKER (x, 0);
2254 CHECK_NUMBER_COERCE_MARKER (y, 1);
2255 #endif /* not LISP_FLOAT_TYPE */
2257 i1 = XINT (x);
2258 i2 = XINT (y);
2260 if (i2 == 0)
2261 Fsignal (Qarith_error, Qnil);
2263 i1 %= i2;
2265 /* If the "remainder" comes out with the wrong sign, fix it. */
2266 if (i2 < 0 ? i1 > 0 : i1 < 0)
2267 i1 += i2;
2269 XSETINT (val, i1);
2270 return val;
2273 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2274 "Return largest of all the arguments (which must be numbers or markers).\n\
2275 The value is always a number; markers are converted to numbers.")
2276 (nargs, args)
2277 int nargs;
2278 Lisp_Object *args;
2280 return arith_driver (Amax, nargs, args);
2283 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2284 "Return smallest of all the arguments (which must be numbers or markers).\n\
2285 The value is always a number; markers are converted to numbers.")
2286 (nargs, args)
2287 int nargs;
2288 Lisp_Object *args;
2290 return arith_driver (Amin, nargs, args);
2293 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2294 "Return bitwise-and of all the arguments.\n\
2295 Arguments may be integers, or markers converted to integers.")
2296 (nargs, args)
2297 int nargs;
2298 Lisp_Object *args;
2300 return arith_driver (Alogand, nargs, args);
2303 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2304 "Return bitwise-or of all the arguments.\n\
2305 Arguments may be integers, or markers converted to integers.")
2306 (nargs, args)
2307 int nargs;
2308 Lisp_Object *args;
2310 return arith_driver (Alogior, nargs, args);
2313 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2314 "Return bitwise-exclusive-or of all the arguments.\n\
2315 Arguments may be integers, or markers converted to integers.")
2316 (nargs, args)
2317 int nargs;
2318 Lisp_Object *args;
2320 return arith_driver (Alogxor, nargs, args);
2323 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2324 "Return VALUE with its bits shifted left by COUNT.\n\
2325 If COUNT is negative, shifting is actually to the right.\n\
2326 In this case, the sign bit is duplicated.")
2327 (value, count)
2328 register Lisp_Object value, count;
2330 register Lisp_Object val;
2332 CHECK_NUMBER (value, 0);
2333 CHECK_NUMBER (count, 1);
2335 if (XINT (count) > 0)
2336 XSETINT (val, XINT (value) << XFASTINT (count));
2337 else
2338 XSETINT (val, XINT (value) >> -XINT (count));
2339 return val;
2342 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2343 "Return VALUE with its bits shifted left by COUNT.\n\
2344 If COUNT is negative, shifting is actually to the right.\n\
2345 In this case, zeros are shifted in on the left.")
2346 (value, count)
2347 register Lisp_Object value, count;
2349 register Lisp_Object val;
2351 CHECK_NUMBER (value, 0);
2352 CHECK_NUMBER (count, 1);
2354 if (XINT (count) > 0)
2355 XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2356 else
2357 XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2358 return val;
2361 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2362 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2363 Markers are converted to integers.")
2364 (number)
2365 register Lisp_Object number;
2367 #ifdef LISP_FLOAT_TYPE
2368 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2370 if (FLOATP (number))
2371 return (make_float (1.0 + XFLOAT (number)->data));
2372 #else
2373 CHECK_NUMBER_COERCE_MARKER (number, 0);
2374 #endif /* LISP_FLOAT_TYPE */
2376 XSETINT (number, XINT (number) + 1);
2377 return number;
2380 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2381 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2382 Markers are converted to integers.")
2383 (number)
2384 register Lisp_Object number;
2386 #ifdef LISP_FLOAT_TYPE
2387 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2389 if (FLOATP (number))
2390 return (make_float (-1.0 + XFLOAT (number)->data));
2391 #else
2392 CHECK_NUMBER_COERCE_MARKER (number, 0);
2393 #endif /* LISP_FLOAT_TYPE */
2395 XSETINT (number, XINT (number) - 1);
2396 return number;
2399 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2400 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2401 (number)
2402 register Lisp_Object number;
2404 CHECK_NUMBER (number, 0);
2405 XSETINT (number, ~XINT (number));
2406 return number;
2409 void
2410 syms_of_data ()
2412 Lisp_Object error_tail, arith_tail;
2414 Qquote = intern ("quote");
2415 Qlambda = intern ("lambda");
2416 Qsubr = intern ("subr");
2417 Qerror_conditions = intern ("error-conditions");
2418 Qerror_message = intern ("error-message");
2419 Qtop_level = intern ("top-level");
2421 Qerror = intern ("error");
2422 Qquit = intern ("quit");
2423 Qwrong_type_argument = intern ("wrong-type-argument");
2424 Qargs_out_of_range = intern ("args-out-of-range");
2425 Qvoid_function = intern ("void-function");
2426 Qcyclic_function_indirection = intern ("cyclic-function-indirection");
2427 Qvoid_variable = intern ("void-variable");
2428 Qsetting_constant = intern ("setting-constant");
2429 Qinvalid_read_syntax = intern ("invalid-read-syntax");
2431 Qinvalid_function = intern ("invalid-function");
2432 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
2433 Qno_catch = intern ("no-catch");
2434 Qend_of_file = intern ("end-of-file");
2435 Qarith_error = intern ("arith-error");
2436 Qbeginning_of_buffer = intern ("beginning-of-buffer");
2437 Qend_of_buffer = intern ("end-of-buffer");
2438 Qbuffer_read_only = intern ("buffer-read-only");
2439 Qmark_inactive = intern ("mark-inactive");
2441 Qlistp = intern ("listp");
2442 Qconsp = intern ("consp");
2443 Qsymbolp = intern ("symbolp");
2444 Qintegerp = intern ("integerp");
2445 Qnatnump = intern ("natnump");
2446 Qwholenump = intern ("wholenump");
2447 Qstringp = intern ("stringp");
2448 Qarrayp = intern ("arrayp");
2449 Qsequencep = intern ("sequencep");
2450 Qbufferp = intern ("bufferp");
2451 Qvectorp = intern ("vectorp");
2452 Qchar_or_string_p = intern ("char-or-string-p");
2453 Qmarkerp = intern ("markerp");
2454 Qbuffer_or_string_p = intern ("buffer-or-string-p");
2455 Qinteger_or_marker_p = intern ("integer-or-marker-p");
2456 Qboundp = intern ("boundp");
2457 Qfboundp = intern ("fboundp");
2459 #ifdef LISP_FLOAT_TYPE
2460 Qfloatp = intern ("floatp");
2461 Qnumberp = intern ("numberp");
2462 Qnumber_or_marker_p = intern ("number-or-marker-p");
2463 #endif /* LISP_FLOAT_TYPE */
2465 Qchar_table_p = intern ("char-table-p");
2466 Qvector_or_char_table_p = intern ("vector-or-char-table-p");
2468 Qcdr = intern ("cdr");
2470 /* Handle automatic advice activation */
2471 Qad_advice_info = intern ("ad-advice-info");
2472 Qad_activate = intern ("ad-activate");
2474 error_tail = Fcons (Qerror, Qnil);
2476 /* ERROR is used as a signaler for random errors for which nothing else is right */
2478 Fput (Qerror, Qerror_conditions,
2479 error_tail);
2480 Fput (Qerror, Qerror_message,
2481 build_string ("error"));
2483 Fput (Qquit, Qerror_conditions,
2484 Fcons (Qquit, Qnil));
2485 Fput (Qquit, Qerror_message,
2486 build_string ("Quit"));
2488 Fput (Qwrong_type_argument, Qerror_conditions,
2489 Fcons (Qwrong_type_argument, error_tail));
2490 Fput (Qwrong_type_argument, Qerror_message,
2491 build_string ("Wrong type argument"));
2493 Fput (Qargs_out_of_range, Qerror_conditions,
2494 Fcons (Qargs_out_of_range, error_tail));
2495 Fput (Qargs_out_of_range, Qerror_message,
2496 build_string ("Args out of range"));
2498 Fput (Qvoid_function, Qerror_conditions,
2499 Fcons (Qvoid_function, error_tail));
2500 Fput (Qvoid_function, Qerror_message,
2501 build_string ("Symbol's function definition is void"));
2503 Fput (Qcyclic_function_indirection, Qerror_conditions,
2504 Fcons (Qcyclic_function_indirection, error_tail));
2505 Fput (Qcyclic_function_indirection, Qerror_message,
2506 build_string ("Symbol's chain of function indirections contains a loop"));
2508 Fput (Qvoid_variable, Qerror_conditions,
2509 Fcons (Qvoid_variable, error_tail));
2510 Fput (Qvoid_variable, Qerror_message,
2511 build_string ("Symbol's value as variable is void"));
2513 Fput (Qsetting_constant, Qerror_conditions,
2514 Fcons (Qsetting_constant, error_tail));
2515 Fput (Qsetting_constant, Qerror_message,
2516 build_string ("Attempt to set a constant symbol"));
2518 Fput (Qinvalid_read_syntax, Qerror_conditions,
2519 Fcons (Qinvalid_read_syntax, error_tail));
2520 Fput (Qinvalid_read_syntax, Qerror_message,
2521 build_string ("Invalid read syntax"));
2523 Fput (Qinvalid_function, Qerror_conditions,
2524 Fcons (Qinvalid_function, error_tail));
2525 Fput (Qinvalid_function, Qerror_message,
2526 build_string ("Invalid function"));
2528 Fput (Qwrong_number_of_arguments, Qerror_conditions,
2529 Fcons (Qwrong_number_of_arguments, error_tail));
2530 Fput (Qwrong_number_of_arguments, Qerror_message,
2531 build_string ("Wrong number of arguments"));
2533 Fput (Qno_catch, Qerror_conditions,
2534 Fcons (Qno_catch, error_tail));
2535 Fput (Qno_catch, Qerror_message,
2536 build_string ("No catch for tag"));
2538 Fput (Qend_of_file, Qerror_conditions,
2539 Fcons (Qend_of_file, error_tail));
2540 Fput (Qend_of_file, Qerror_message,
2541 build_string ("End of file during parsing"));
2543 arith_tail = Fcons (Qarith_error, error_tail);
2544 Fput (Qarith_error, Qerror_conditions,
2545 arith_tail);
2546 Fput (Qarith_error, Qerror_message,
2547 build_string ("Arithmetic error"));
2549 Fput (Qbeginning_of_buffer, Qerror_conditions,
2550 Fcons (Qbeginning_of_buffer, error_tail));
2551 Fput (Qbeginning_of_buffer, Qerror_message,
2552 build_string ("Beginning of buffer"));
2554 Fput (Qend_of_buffer, Qerror_conditions,
2555 Fcons (Qend_of_buffer, error_tail));
2556 Fput (Qend_of_buffer, Qerror_message,
2557 build_string ("End of buffer"));
2559 Fput (Qbuffer_read_only, Qerror_conditions,
2560 Fcons (Qbuffer_read_only, error_tail));
2561 Fput (Qbuffer_read_only, Qerror_message,
2562 build_string ("Buffer is read-only"));
2564 #ifdef LISP_FLOAT_TYPE
2565 Qrange_error = intern ("range-error");
2566 Qdomain_error = intern ("domain-error");
2567 Qsingularity_error = intern ("singularity-error");
2568 Qoverflow_error = intern ("overflow-error");
2569 Qunderflow_error = intern ("underflow-error");
2571 Fput (Qdomain_error, Qerror_conditions,
2572 Fcons (Qdomain_error, arith_tail));
2573 Fput (Qdomain_error, Qerror_message,
2574 build_string ("Arithmetic domain error"));
2576 Fput (Qrange_error, Qerror_conditions,
2577 Fcons (Qrange_error, arith_tail));
2578 Fput (Qrange_error, Qerror_message,
2579 build_string ("Arithmetic range error"));
2581 Fput (Qsingularity_error, Qerror_conditions,
2582 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
2583 Fput (Qsingularity_error, Qerror_message,
2584 build_string ("Arithmetic singularity error"));
2586 Fput (Qoverflow_error, Qerror_conditions,
2587 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
2588 Fput (Qoverflow_error, Qerror_message,
2589 build_string ("Arithmetic overflow error"));
2591 Fput (Qunderflow_error, Qerror_conditions,
2592 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
2593 Fput (Qunderflow_error, Qerror_message,
2594 build_string ("Arithmetic underflow error"));
2596 staticpro (&Qrange_error);
2597 staticpro (&Qdomain_error);
2598 staticpro (&Qsingularity_error);
2599 staticpro (&Qoverflow_error);
2600 staticpro (&Qunderflow_error);
2601 #endif /* LISP_FLOAT_TYPE */
2603 staticpro (&Qnil);
2604 staticpro (&Qt);
2605 staticpro (&Qquote);
2606 staticpro (&Qlambda);
2607 staticpro (&Qsubr);
2608 staticpro (&Qunbound);
2609 staticpro (&Qerror_conditions);
2610 staticpro (&Qerror_message);
2611 staticpro (&Qtop_level);
2613 staticpro (&Qerror);
2614 staticpro (&Qquit);
2615 staticpro (&Qwrong_type_argument);
2616 staticpro (&Qargs_out_of_range);
2617 staticpro (&Qvoid_function);
2618 staticpro (&Qcyclic_function_indirection);
2619 staticpro (&Qvoid_variable);
2620 staticpro (&Qsetting_constant);
2621 staticpro (&Qinvalid_read_syntax);
2622 staticpro (&Qwrong_number_of_arguments);
2623 staticpro (&Qinvalid_function);
2624 staticpro (&Qno_catch);
2625 staticpro (&Qend_of_file);
2626 staticpro (&Qarith_error);
2627 staticpro (&Qbeginning_of_buffer);
2628 staticpro (&Qend_of_buffer);
2629 staticpro (&Qbuffer_read_only);
2630 staticpro (&Qmark_inactive);
2632 staticpro (&Qlistp);
2633 staticpro (&Qconsp);
2634 staticpro (&Qsymbolp);
2635 staticpro (&Qintegerp);
2636 staticpro (&Qnatnump);
2637 staticpro (&Qwholenump);
2638 staticpro (&Qstringp);
2639 staticpro (&Qarrayp);
2640 staticpro (&Qsequencep);
2641 staticpro (&Qbufferp);
2642 staticpro (&Qvectorp);
2643 staticpro (&Qchar_or_string_p);
2644 staticpro (&Qmarkerp);
2645 staticpro (&Qbuffer_or_string_p);
2646 staticpro (&Qinteger_or_marker_p);
2647 #ifdef LISP_FLOAT_TYPE
2648 staticpro (&Qfloatp);
2649 staticpro (&Qnumberp);
2650 staticpro (&Qnumber_or_marker_p);
2651 #endif /* LISP_FLOAT_TYPE */
2652 staticpro (&Qchar_table_p);
2653 staticpro (&Qvector_or_char_table_p);
2655 staticpro (&Qboundp);
2656 staticpro (&Qfboundp);
2657 staticpro (&Qcdr);
2658 staticpro (&Qad_advice_info);
2659 staticpro (&Qad_activate);
2661 /* Types that type-of returns. */
2662 Qinteger = intern ("integer");
2663 Qsymbol = intern ("symbol");
2664 Qstring = intern ("string");
2665 Qcons = intern ("cons");
2666 Qmarker = intern ("marker");
2667 Qoverlay = intern ("overlay");
2668 Qfloat = intern ("float");
2669 Qwindow_configuration = intern ("window-configuration");
2670 Qprocess = intern ("process");
2671 Qwindow = intern ("window");
2672 /* Qsubr = intern ("subr"); */
2673 Qcompiled_function = intern ("compiled-function");
2674 Qbuffer = intern ("buffer");
2675 Qframe = intern ("frame");
2676 Qvector = intern ("vector");
2677 Qchar_table = intern ("char-table");
2678 Qbool_vector = intern ("bool-vector");
2680 staticpro (&Qinteger);
2681 staticpro (&Qsymbol);
2682 staticpro (&Qstring);
2683 staticpro (&Qcons);
2684 staticpro (&Qmarker);
2685 staticpro (&Qoverlay);
2686 staticpro (&Qfloat);
2687 staticpro (&Qwindow_configuration);
2688 staticpro (&Qprocess);
2689 staticpro (&Qwindow);
2690 /* staticpro (&Qsubr); */
2691 staticpro (&Qcompiled_function);
2692 staticpro (&Qbuffer);
2693 staticpro (&Qframe);
2694 staticpro (&Qvector);
2695 staticpro (&Qchar_table);
2696 staticpro (&Qbool_vector);
2698 defsubr (&Seq);
2699 defsubr (&Snull);
2700 defsubr (&Stype_of);
2701 defsubr (&Slistp);
2702 defsubr (&Snlistp);
2703 defsubr (&Sconsp);
2704 defsubr (&Satom);
2705 defsubr (&Sintegerp);
2706 defsubr (&Sinteger_or_marker_p);
2707 defsubr (&Snumberp);
2708 defsubr (&Snumber_or_marker_p);
2709 #ifdef LISP_FLOAT_TYPE
2710 defsubr (&Sfloatp);
2711 #endif /* LISP_FLOAT_TYPE */
2712 defsubr (&Snatnump);
2713 defsubr (&Ssymbolp);
2714 defsubr (&Sstringp);
2715 defsubr (&Svectorp);
2716 defsubr (&Schar_table_p);
2717 defsubr (&Svector_or_char_table_p);
2718 defsubr (&Sbool_vector_p);
2719 defsubr (&Sarrayp);
2720 defsubr (&Ssequencep);
2721 defsubr (&Sbufferp);
2722 defsubr (&Smarkerp);
2723 defsubr (&Ssubrp);
2724 defsubr (&Sbyte_code_function_p);
2725 defsubr (&Schar_or_string_p);
2726 defsubr (&Scar);
2727 defsubr (&Scdr);
2728 defsubr (&Scar_safe);
2729 defsubr (&Scdr_safe);
2730 defsubr (&Ssetcar);
2731 defsubr (&Ssetcdr);
2732 defsubr (&Ssymbol_function);
2733 defsubr (&Sindirect_function);
2734 defsubr (&Ssymbol_plist);
2735 defsubr (&Ssymbol_name);
2736 defsubr (&Smakunbound);
2737 defsubr (&Sfmakunbound);
2738 defsubr (&Sboundp);
2739 defsubr (&Sfboundp);
2740 defsubr (&Sfset);
2741 defsubr (&Sdefalias);
2742 defsubr (&Ssetplist);
2743 defsubr (&Ssymbol_value);
2744 defsubr (&Sset);
2745 defsubr (&Sdefault_boundp);
2746 defsubr (&Sdefault_value);
2747 defsubr (&Sset_default);
2748 defsubr (&Ssetq_default);
2749 defsubr (&Smake_variable_buffer_local);
2750 defsubr (&Smake_local_variable);
2751 defsubr (&Skill_local_variable);
2752 defsubr (&Slocal_variable_p);
2753 defsubr (&Slocal_variable_if_set_p);
2754 defsubr (&Saref);
2755 defsubr (&Saset);
2756 defsubr (&Snumber_to_string);
2757 defsubr (&Sstring_to_number);
2758 defsubr (&Seqlsign);
2759 defsubr (&Slss);
2760 defsubr (&Sgtr);
2761 defsubr (&Sleq);
2762 defsubr (&Sgeq);
2763 defsubr (&Sneq);
2764 defsubr (&Szerop);
2765 defsubr (&Splus);
2766 defsubr (&Sminus);
2767 defsubr (&Stimes);
2768 defsubr (&Squo);
2769 defsubr (&Srem);
2770 defsubr (&Smod);
2771 defsubr (&Smax);
2772 defsubr (&Smin);
2773 defsubr (&Slogand);
2774 defsubr (&Slogior);
2775 defsubr (&Slogxor);
2776 defsubr (&Slsh);
2777 defsubr (&Sash);
2778 defsubr (&Sadd1);
2779 defsubr (&Ssub1);
2780 defsubr (&Slognot);
2782 XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
2785 SIGTYPE
2786 arith_error (signo)
2787 int signo;
2789 #if defined(USG) && !defined(POSIX_SIGNALS)
2790 /* USG systems forget handlers when they are used;
2791 must reestablish each time */
2792 signal (signo, arith_error);
2793 #endif /* USG */
2794 #ifdef VMS
2795 /* VMS systems are like USG. */
2796 signal (signo, arith_error);
2797 #endif /* VMS */
2798 #ifdef BSD4_1
2799 sigrelse (SIGFPE);
2800 #else /* not BSD4_1 */
2801 sigsetmask (SIGEMPTYMASK);
2802 #endif /* not BSD4_1 */
2804 Fsignal (Qarith_error, Qnil);
2807 init_data ()
2809 /* Don't do this if just dumping out.
2810 We don't want to call `signal' in this case
2811 so that we don't have trouble with dumping
2812 signal-delivering routines in an inconsistent state. */
2813 #ifndef CANNOT_DUMP
2814 if (!initialized)
2815 return;
2816 #endif /* CANNOT_DUMP */
2817 signal (SIGFPE, arith_error);
2819 #ifdef uts
2820 signal (SIGEMT, arith_error);
2821 #endif /* uts */