*** empty log message ***
[emacs.git] / src / data.c
blobc85e5485d6945e8ac4ab09e3a6f09fa41c8ecbe7
1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985,86,88,93,94,95,97,98,99,2000 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 <config.h>
23 #include <signal.h>
24 #include <stdio.h>
25 #include "lisp.h"
26 #include "puresize.h"
27 #include "charset.h"
28 #include "buffer.h"
29 #include "keyboard.h"
30 #include "frame.h"
31 #include "syssignal.h"
33 #ifdef STDC_HEADERS
34 #include <float.h>
35 #endif
37 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
38 #ifndef IEEE_FLOATING_POINT
39 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
40 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
41 #define IEEE_FLOATING_POINT 1
42 #else
43 #define IEEE_FLOATING_POINT 0
44 #endif
45 #endif
47 /* Work around a problem that happens because math.h on hpux 7
48 defines two static variables--which, in Emacs, are not really static,
49 because `static' is defined as nothing. The problem is that they are
50 here, in floatfns.c, and in lread.c.
51 These macros prevent the name conflict. */
52 #if defined (HPUX) && !defined (HPUX8)
53 #define _MAXLDBL data_c_maxldbl
54 #define _NMAXLDBL data_c_nmaxldbl
55 #endif
57 #include <math.h>
59 #if !defined (atof)
60 extern double atof ();
61 #endif /* !atof */
63 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
64 Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
65 Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
66 Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
67 Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
68 Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
69 Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
70 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
71 Lisp_Object Qtext_read_only;
72 Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
73 Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
74 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
75 Lisp_Object Qbuffer_or_string_p, Qkeywordp;
76 Lisp_Object Qboundp, Qfboundp;
77 Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
79 Lisp_Object Qcdr;
80 Lisp_Object Qad_advice_info, Qad_activate_internal;
82 Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
83 Lisp_Object Qoverflow_error, Qunderflow_error;
85 Lisp_Object Qfloatp;
86 Lisp_Object Qnumberp, Qnumber_or_marker_p;
88 static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
89 static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
90 Lisp_Object Qprocess;
91 static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
92 static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
93 static Lisp_Object Qsubrp, Qmany, Qunevalled;
95 static Lisp_Object swap_in_symval_forwarding ();
97 Lisp_Object set_internal ();
99 Lisp_Object
100 wrong_type_argument (predicate, value)
101 register Lisp_Object predicate, value;
103 register Lisp_Object tem;
106 if (!EQ (Vmocklisp_arguments, Qt))
108 if (STRINGP (value) &&
109 (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
110 return Fstring_to_number (value, Qnil);
111 if (INTEGERP (value) && EQ (predicate, Qstringp))
112 return Fnumber_to_string (value);
115 /* If VALUE is not even a valid Lisp object, abort here
116 where we can get a backtrace showing where it came from. */
117 if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
118 abort ();
120 value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
121 tem = call1 (predicate, value);
123 while (NILP (tem));
124 return value;
127 void
128 pure_write_error ()
130 error ("Attempt to modify read-only object");
133 void
134 args_out_of_range (a1, a2)
135 Lisp_Object a1, a2;
137 while (1)
138 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
141 void
142 args_out_of_range_3 (a1, a2, a3)
143 Lisp_Object a1, a2, a3;
145 while (1)
146 Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
149 /* On some machines, XINT needs a temporary location.
150 Here it is, in case it is needed. */
152 int sign_extend_temp;
154 /* On a few machines, XINT can only be done by calling this. */
157 sign_extend_lisp_int (num)
158 EMACS_INT num;
160 if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
161 return num | (((EMACS_INT) (-1)) << VALBITS);
162 else
163 return num & ((((EMACS_INT) 1) << VALBITS) - 1);
166 /* Data type predicates */
168 DEFUN ("eq", Feq, Seq, 2, 2, 0,
169 "Return t if the two args are the same Lisp object.")
170 (obj1, obj2)
171 Lisp_Object obj1, obj2;
173 if (EQ (obj1, obj2))
174 return Qt;
175 return Qnil;
178 DEFUN ("null", Fnull, Snull, 1, 1, 0, "Return t if OBJECT is nil.")
179 (object)
180 Lisp_Object object;
182 if (NILP (object))
183 return Qt;
184 return Qnil;
187 DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
188 "Return a symbol representing the type of OBJECT.\n\
189 The symbol returned names the object's basic type;\n\
190 for example, (type-of 1) returns `integer'.")
191 (object)
192 Lisp_Object object;
194 switch (XGCTYPE (object))
196 case Lisp_Int:
197 return Qinteger;
199 case Lisp_Symbol:
200 return Qsymbol;
202 case Lisp_String:
203 return Qstring;
205 case Lisp_Cons:
206 return Qcons;
208 case Lisp_Misc:
209 switch (XMISCTYPE (object))
211 case Lisp_Misc_Marker:
212 return Qmarker;
213 case Lisp_Misc_Overlay:
214 return Qoverlay;
215 case Lisp_Misc_Float:
216 return Qfloat;
218 abort ();
220 case Lisp_Vectorlike:
221 if (GC_WINDOW_CONFIGURATIONP (object))
222 return Qwindow_configuration;
223 if (GC_PROCESSP (object))
224 return Qprocess;
225 if (GC_WINDOWP (object))
226 return Qwindow;
227 if (GC_SUBRP (object))
228 return Qsubr;
229 if (GC_COMPILEDP (object))
230 return Qcompiled_function;
231 if (GC_BUFFERP (object))
232 return Qbuffer;
233 if (GC_CHAR_TABLE_P (object))
234 return Qchar_table;
235 if (GC_BOOL_VECTOR_P (object))
236 return Qbool_vector;
237 if (GC_FRAMEP (object))
238 return Qframe;
239 if (GC_HASH_TABLE_P (object))
240 return Qhash_table;
241 return Qvector;
243 case Lisp_Float:
244 return Qfloat;
246 default:
247 abort ();
251 DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "Return t if OBJECT is a cons cell.")
252 (object)
253 Lisp_Object object;
255 if (CONSP (object))
256 return Qt;
257 return Qnil;
260 DEFUN ("atom", Fatom, Satom, 1, 1, 0,
261 "Return t if OBJECT is not a cons cell. This includes nil.")
262 (object)
263 Lisp_Object object;
265 if (CONSP (object))
266 return Qnil;
267 return Qt;
270 DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
271 "Return t if OBJECT is a list. This includes nil.")
272 (object)
273 Lisp_Object object;
275 if (CONSP (object) || NILP (object))
276 return Qt;
277 return Qnil;
280 DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
281 "Return t if OBJECT is not a list. Lists include nil.")
282 (object)
283 Lisp_Object object;
285 if (CONSP (object) || NILP (object))
286 return Qnil;
287 return Qt;
290 DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
291 "Return t if OBJECT is a symbol.")
292 (object)
293 Lisp_Object object;
295 if (SYMBOLP (object))
296 return Qt;
297 return Qnil;
300 /* Define this in C to avoid unnecessarily consing up the symbol
301 name. */
302 DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
303 "Return t if OBJECT is a keyword.\n\
304 This means that it is a symbol with a print name beginning with `:'\n\
305 interned in the initial obarray.")
306 (object)
307 Lisp_Object object;
309 if (SYMBOLP (object)
310 && XSYMBOL (object)->name->data[0] == ':'
311 && EQ (XSYMBOL (object)->obarray, initial_obarray))
312 return Qt;
313 return Qnil;
316 DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
317 "Return t if OBJECT is a vector.")
318 (object)
319 Lisp_Object object;
321 if (VECTORP (object))
322 return Qt;
323 return Qnil;
326 DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
327 "Return t if OBJECT is a string.")
328 (object)
329 Lisp_Object object;
331 if (STRINGP (object))
332 return Qt;
333 return Qnil;
336 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
337 1, 1, 0, "Return t if OBJECT is a multibyte string.")
338 (object)
339 Lisp_Object object;
341 if (STRINGP (object) && STRING_MULTIBYTE (object))
342 return Qt;
343 return Qnil;
346 DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
347 "Return t if OBJECT is a char-table.")
348 (object)
349 Lisp_Object object;
351 if (CHAR_TABLE_P (object))
352 return Qt;
353 return Qnil;
356 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
357 Svector_or_char_table_p, 1, 1, 0,
358 "Return t if OBJECT is a char-table or vector.")
359 (object)
360 Lisp_Object object;
362 if (VECTORP (object) || CHAR_TABLE_P (object))
363 return Qt;
364 return Qnil;
367 DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
368 (object)
369 Lisp_Object object;
371 if (BOOL_VECTOR_P (object))
372 return Qt;
373 return Qnil;
376 DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
377 (object)
378 Lisp_Object object;
380 if (VECTORP (object) || STRINGP (object)
381 || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
382 return Qt;
383 return Qnil;
386 DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
387 "Return t if OBJECT is a sequence (list or array).")
388 (object)
389 register Lisp_Object object;
391 if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
392 || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
393 return Qt;
394 return Qnil;
397 DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
398 (object)
399 Lisp_Object object;
401 if (BUFFERP (object))
402 return Qt;
403 return Qnil;
406 DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
407 (object)
408 Lisp_Object object;
410 if (MARKERP (object))
411 return Qt;
412 return Qnil;
415 DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "Return t if OBJECT is a built-in function.")
416 (object)
417 Lisp_Object object;
419 if (SUBRP (object))
420 return Qt;
421 return Qnil;
424 DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
425 1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
426 (object)
427 Lisp_Object object;
429 if (COMPILEDP (object))
430 return Qt;
431 return Qnil;
434 DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
435 "Return t if OBJECT is a character (an integer) or a string.")
436 (object)
437 register Lisp_Object object;
439 if (INTEGERP (object) || STRINGP (object))
440 return Qt;
441 return Qnil;
444 DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "Return t if OBJECT is an integer.")
445 (object)
446 Lisp_Object object;
448 if (INTEGERP (object))
449 return Qt;
450 return Qnil;
453 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
454 "Return t if OBJECT is an integer or a marker (editor pointer).")
455 (object)
456 register Lisp_Object object;
458 if (MARKERP (object) || INTEGERP (object))
459 return Qt;
460 return Qnil;
463 DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
464 "Return t if OBJECT is a nonnegative integer.")
465 (object)
466 Lisp_Object object;
468 if (NATNUMP (object))
469 return Qt;
470 return Qnil;
473 DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
474 "Return t if OBJECT is a number (floating point or integer).")
475 (object)
476 Lisp_Object object;
478 if (NUMBERP (object))
479 return Qt;
480 else
481 return Qnil;
484 DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
485 Snumber_or_marker_p, 1, 1, 0,
486 "Return t if OBJECT is a number or a marker.")
487 (object)
488 Lisp_Object object;
490 if (NUMBERP (object) || MARKERP (object))
491 return Qt;
492 return Qnil;
495 DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
496 "Return t if OBJECT is a floating point number.")
497 (object)
498 Lisp_Object object;
500 if (FLOATP (object))
501 return Qt;
502 return Qnil;
506 /* Extract and set components of lists */
508 DEFUN ("car", Fcar, Scar, 1, 1, 0,
509 "Return the car of LIST. If arg is nil, return nil.\n\
510 Error if arg is not nil and not a cons cell. See also `car-safe'.")
511 (list)
512 register Lisp_Object list;
514 while (1)
516 if (CONSP (list))
517 return XCAR (list);
518 else if (EQ (list, Qnil))
519 return Qnil;
520 else
521 list = wrong_type_argument (Qlistp, list);
525 DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
526 "Return the car of OBJECT if it is a cons cell, or else nil.")
527 (object)
528 Lisp_Object object;
530 if (CONSP (object))
531 return XCAR (object);
532 else
533 return Qnil;
536 DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
537 "Return the cdr of LIST. If arg is nil, return nil.\n\
538 Error if arg is not nil and not a cons cell. See also `cdr-safe'.")
540 (list)
541 register Lisp_Object list;
543 while (1)
545 if (CONSP (list))
546 return XCDR (list);
547 else if (EQ (list, Qnil))
548 return Qnil;
549 else
550 list = wrong_type_argument (Qlistp, list);
554 DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
555 "Return the cdr of OBJECT if it is a cons cell, or else nil.")
556 (object)
557 Lisp_Object object;
559 if (CONSP (object))
560 return XCDR (object);
561 else
562 return Qnil;
565 DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
566 "Set the car of CELL to be NEWCAR. Returns NEWCAR.")
567 (cell, newcar)
568 register Lisp_Object cell, newcar;
570 if (!CONSP (cell))
571 cell = wrong_type_argument (Qconsp, cell);
573 CHECK_IMPURE (cell);
574 XCAR (cell) = newcar;
575 return newcar;
578 DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
579 "Set the cdr of CELL to be NEWCDR. Returns NEWCDR.")
580 (cell, newcdr)
581 register Lisp_Object cell, newcdr;
583 if (!CONSP (cell))
584 cell = wrong_type_argument (Qconsp, cell);
586 CHECK_IMPURE (cell);
587 XCDR (cell) = newcdr;
588 return newcdr;
591 /* Extract and set components of symbols */
593 DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "Return t if SYMBOL's value is not void.")
594 (symbol)
595 register Lisp_Object symbol;
597 Lisp_Object valcontents;
598 CHECK_SYMBOL (symbol, 0);
600 valcontents = XSYMBOL (symbol)->value;
602 if (BUFFER_LOCAL_VALUEP (valcontents)
603 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
604 valcontents = swap_in_symval_forwarding (symbol, valcontents);
606 return (EQ (valcontents, Qunbound) ? Qnil : Qt);
609 DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
610 (symbol)
611 register Lisp_Object symbol;
613 CHECK_SYMBOL (symbol, 0);
614 return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
617 DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
618 (symbol)
619 register Lisp_Object symbol;
621 CHECK_SYMBOL (symbol, 0);
622 if (NILP (symbol) || EQ (symbol, Qt)
623 || (XSYMBOL (symbol)->name->data[0] == ':'
624 && EQ (XSYMBOL (symbol)->obarray, initial_obarray)))
625 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
626 Fset (symbol, Qunbound);
627 return symbol;
630 DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
631 (symbol)
632 register Lisp_Object symbol;
634 CHECK_SYMBOL (symbol, 0);
635 if (NILP (symbol) || EQ (symbol, Qt))
636 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
637 XSYMBOL (symbol)->function = Qunbound;
638 return symbol;
641 DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
642 "Return SYMBOL's function definition. Error if that is void.")
643 (symbol)
644 register Lisp_Object symbol;
646 CHECK_SYMBOL (symbol, 0);
647 if (EQ (XSYMBOL (symbol)->function, Qunbound))
648 return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
649 return XSYMBOL (symbol)->function;
652 DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
653 (symbol)
654 register Lisp_Object symbol;
656 CHECK_SYMBOL (symbol, 0);
657 return XSYMBOL (symbol)->plist;
660 DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
661 (symbol)
662 register Lisp_Object symbol;
664 register Lisp_Object name;
666 CHECK_SYMBOL (symbol, 0);
667 XSETSTRING (name, XSYMBOL (symbol)->name);
668 return name;
671 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
672 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
673 (symbol, definition)
674 register Lisp_Object symbol, definition;
676 CHECK_SYMBOL (symbol, 0);
677 if (NILP (symbol) || EQ (symbol, Qt))
678 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
679 if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
680 Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
681 Vautoload_queue);
682 XSYMBOL (symbol)->function = definition;
683 /* Handle automatic advice activation */
684 if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
686 call2 (Qad_activate_internal, symbol, Qnil);
687 definition = XSYMBOL (symbol)->function;
689 return definition;
692 DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
693 "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
694 Associates the function with the current load file, if any.")
695 (symbol, definition)
696 register Lisp_Object symbol, definition;
698 definition = Ffset (symbol, definition);
699 LOADHIST_ATTACH (symbol);
700 return definition;
703 DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
704 "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
705 (symbol, newplist)
706 register Lisp_Object symbol, newplist;
708 CHECK_SYMBOL (symbol, 0);
709 XSYMBOL (symbol)->plist = newplist;
710 return newplist;
713 DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
714 "Return minimum and maximum number of args allowed for SUBR.\n\
715 SUBR must be a built-in function.\n\
716 The returned value is a pair (MIN . MAX). MIN is the minimum number\n\
717 of args. MAX is the maximum number or the symbol `many', for a\n\
718 function with `&rest' args, or `unevalled' for a special form.")
719 (subr)
720 Lisp_Object subr;
722 short minargs, maxargs;
723 if (!SUBRP (subr))
724 wrong_type_argument (Qsubrp, subr);
725 minargs = XSUBR (subr)->min_args;
726 maxargs = XSUBR (subr)->max_args;
727 if (maxargs == MANY)
728 return Fcons (make_number (minargs), Qmany);
729 else if (maxargs == UNEVALLED)
730 return Fcons (make_number (minargs), Qunevalled);
731 else
732 return Fcons (make_number (minargs), make_number (maxargs));
736 /* Getting and setting values of symbols */
738 /* Given the raw contents of a symbol value cell,
739 return the Lisp value of the symbol.
740 This does not handle buffer-local variables; use
741 swap_in_symval_forwarding for that. */
743 Lisp_Object
744 do_symval_forwarding (valcontents)
745 register Lisp_Object valcontents;
747 register Lisp_Object val;
748 int offset;
749 if (MISCP (valcontents))
750 switch (XMISCTYPE (valcontents))
752 case Lisp_Misc_Intfwd:
753 XSETINT (val, *XINTFWD (valcontents)->intvar);
754 return val;
756 case Lisp_Misc_Boolfwd:
757 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
759 case Lisp_Misc_Objfwd:
760 return *XOBJFWD (valcontents)->objvar;
762 case Lisp_Misc_Buffer_Objfwd:
763 offset = XBUFFER_OBJFWD (valcontents)->offset;
764 return PER_BUFFER_VALUE (current_buffer, offset);
766 case Lisp_Misc_Kboard_Objfwd:
767 offset = XKBOARD_OBJFWD (valcontents)->offset;
768 return *(Lisp_Object *)(offset + (char *)current_kboard);
770 return valcontents;
773 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
774 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
775 buffer-independent contents of the value cell: forwarded just one
776 step past the buffer-localness. */
778 void
779 store_symval_forwarding (symbol, valcontents, newval)
780 Lisp_Object symbol;
781 register Lisp_Object valcontents, newval;
783 switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
785 case Lisp_Misc:
786 switch (XMISCTYPE (valcontents))
788 case Lisp_Misc_Intfwd:
789 CHECK_NUMBER (newval, 1);
790 *XINTFWD (valcontents)->intvar = XINT (newval);
791 if (*XINTFWD (valcontents)->intvar != XINT (newval))
792 error ("Value out of range for variable `%s'",
793 XSYMBOL (symbol)->name->data);
794 break;
796 case Lisp_Misc_Boolfwd:
797 *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
798 break;
800 case Lisp_Misc_Objfwd:
801 *XOBJFWD (valcontents)->objvar = newval;
802 break;
804 case Lisp_Misc_Buffer_Objfwd:
806 int offset = XBUFFER_OBJFWD (valcontents)->offset;
807 Lisp_Object type;
809 type = PER_BUFFER_TYPE (offset);
810 if (XINT (type) == -1)
811 error ("Variable %s is read-only", XSYMBOL (symbol)->name->data);
813 if (! NILP (type) && ! NILP (newval)
814 && XTYPE (newval) != XINT (type))
815 buffer_slot_type_mismatch (offset);
817 PER_BUFFER_VALUE (current_buffer, offset) = newval;
819 break;
821 case Lisp_Misc_Kboard_Objfwd:
822 (*(Lisp_Object *)((char *)current_kboard
823 + XKBOARD_OBJFWD (valcontents)->offset))
824 = newval;
825 break;
827 default:
828 goto def;
830 break;
832 default:
833 def:
834 valcontents = XSYMBOL (symbol)->value;
835 if (BUFFER_LOCAL_VALUEP (valcontents)
836 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
837 XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
838 else
839 XSYMBOL (symbol)->value = newval;
843 /* Set up SYMBOL to refer to its global binding.
844 This makes it safe to alter the status of other bindings. */
846 void
847 swap_in_global_binding (symbol)
848 Lisp_Object symbol;
850 Lisp_Object valcontents, cdr;
852 valcontents = XSYMBOL (symbol)->value;
853 if (!BUFFER_LOCAL_VALUEP (valcontents)
854 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
855 abort ();
856 cdr = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
858 /* Unload the previously loaded binding. */
859 Fsetcdr (XCAR (cdr),
860 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
862 /* Select the global binding in the symbol. */
863 XCAR (cdr) = cdr;
864 store_symval_forwarding (symbol, valcontents, XCDR (cdr));
866 /* Indicate that the global binding is set up now. */
867 XBUFFER_LOCAL_VALUE (valcontents)->frame = Qnil;
868 XBUFFER_LOCAL_VALUE (valcontents)->buffer = Qnil;
869 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
870 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
873 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
874 VALCONTENTS is the contents of its value cell,
875 which points to a struct Lisp_Buffer_Local_Value.
877 Return the value forwarded one step past the buffer-local stage.
878 This could be another forwarding pointer. */
880 static Lisp_Object
881 swap_in_symval_forwarding (symbol, valcontents)
882 Lisp_Object symbol, valcontents;
884 register Lisp_Object tem1;
885 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer;
887 if (NILP (tem1)
888 || current_buffer != XBUFFER (tem1)
889 || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
890 && ! EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame)))
892 /* Unload the previously loaded binding. */
893 tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
894 Fsetcdr (tem1,
895 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
896 /* Choose the new binding. */
897 tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
898 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
899 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
900 if (NILP (tem1))
902 if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
903 tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist);
904 if (! NILP (tem1))
905 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
906 else
907 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
909 else
910 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
912 /* Load the new binding. */
913 XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = tem1;
914 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer);
915 XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
916 store_symval_forwarding (symbol,
917 XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
918 Fcdr (tem1));
920 return XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
923 /* Find the value of a symbol, returning Qunbound if it's not bound.
924 This is helpful for code which just wants to get a variable's value
925 if it has one, without signaling an error.
926 Note that it must not be possible to quit
927 within this function. Great care is required for this. */
929 Lisp_Object
930 find_symbol_value (symbol)
931 Lisp_Object symbol;
933 register Lisp_Object valcontents;
934 register Lisp_Object val;
935 CHECK_SYMBOL (symbol, 0);
936 valcontents = XSYMBOL (symbol)->value;
938 if (BUFFER_LOCAL_VALUEP (valcontents)
939 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
940 valcontents = swap_in_symval_forwarding (symbol, valcontents,
941 current_buffer);
943 if (MISCP (valcontents))
945 switch (XMISCTYPE (valcontents))
947 case Lisp_Misc_Intfwd:
948 XSETINT (val, *XINTFWD (valcontents)->intvar);
949 return val;
951 case Lisp_Misc_Boolfwd:
952 return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
954 case Lisp_Misc_Objfwd:
955 return *XOBJFWD (valcontents)->objvar;
957 case Lisp_Misc_Buffer_Objfwd:
958 return PER_BUFFER_VALUE (current_buffer,
959 XBUFFER_OBJFWD (valcontents)->offset);
961 case Lisp_Misc_Kboard_Objfwd:
962 return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
963 + (char *)current_kboard);
967 return valcontents;
970 DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
971 "Return SYMBOL's value. Error if that is void.")
972 (symbol)
973 Lisp_Object symbol;
975 Lisp_Object val;
977 val = find_symbol_value (symbol);
978 if (EQ (val, Qunbound))
979 return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
980 else
981 return val;
984 DEFUN ("set", Fset, Sset, 2, 2, 0,
985 "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
986 (symbol, newval)
987 register Lisp_Object symbol, newval;
989 return set_internal (symbol, newval, current_buffer, 0);
992 /* Return 1 if SYMBOL currently has a let-binding
993 which was made in the buffer that is now current. */
995 static int
996 let_shadows_buffer_binding_p (symbol)
997 Lisp_Object symbol;
999 struct specbinding *p;
1001 for (p = specpdl_ptr - 1; p >= specpdl; p--)
1002 if (p->func == 0
1003 && CONSP (p->symbol)
1004 && EQ (symbol, XCAR (p->symbol))
1005 && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
1006 return 1;
1008 return 0;
1011 /* Store the value NEWVAL into SYMBOL.
1012 If buffer-locality is an issue, BUF specifies which buffer to use.
1013 (0 stands for the current buffer.)
1015 If BINDFLAG is zero, then if this symbol is supposed to become
1016 local in every buffer where it is set, then we make it local.
1017 If BINDFLAG is nonzero, we don't do that. */
1019 Lisp_Object
1020 set_internal (symbol, newval, buf, bindflag)
1021 register Lisp_Object symbol, newval;
1022 struct buffer *buf;
1023 int bindflag;
1025 int voide = EQ (newval, Qunbound);
1027 register Lisp_Object valcontents, innercontents, tem1, current_alist_element;
1029 if (buf == 0)
1030 buf = current_buffer;
1032 /* If restoring in a dead buffer, do nothing. */
1033 if (NILP (buf->name))
1034 return newval;
1036 CHECK_SYMBOL (symbol, 0);
1037 if (NILP (symbol) || EQ (symbol, Qt)
1038 || (XSYMBOL (symbol)->name->data[0] == ':'
1039 && EQ (XSYMBOL (symbol)->obarray, initial_obarray)
1040 && !EQ (newval, symbol)))
1041 return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
1043 innercontents = valcontents = XSYMBOL (symbol)->value;
1045 if (BUFFER_OBJFWDP (valcontents))
1047 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1048 int idx = PER_BUFFER_IDX (offset);
1049 if (idx > 0
1050 && !bindflag
1051 && !let_shadows_buffer_binding_p (symbol))
1052 SET_PER_BUFFER_VALUE_P (buf, idx, 1);
1055 else if (BUFFER_LOCAL_VALUEP (valcontents)
1056 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1058 /* valcontents is a struct Lisp_Buffer_Local_Value. */
1060 /* What binding is loaded right now? */
1061 current_alist_element
1062 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1064 /* If the current buffer is not the buffer whose binding is
1065 loaded, or if there may be frame-local bindings and the frame
1066 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1067 the default binding is loaded, the loaded binding may be the
1068 wrong one. */
1069 if (!BUFFERP (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
1070 || buf != XBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer)
1071 || (XBUFFER_LOCAL_VALUE (valcontents)->check_frame
1072 && !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))
1073 || (BUFFER_LOCAL_VALUEP (valcontents)
1074 && EQ (XCAR (current_alist_element),
1075 current_alist_element)))
1077 /* The currently loaded binding is not necessarily valid.
1078 We need to unload it, and choose a new binding. */
1080 /* Write out `realvalue' to the old loaded binding. */
1081 Fsetcdr (current_alist_element,
1082 do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
1084 /* Find the new binding. */
1085 tem1 = Fassq (symbol, buf->local_var_alist);
1086 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;
1087 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
1089 if (NILP (tem1))
1091 /* This buffer still sees the default value. */
1093 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1094 or if this is `let' rather than `set',
1095 make CURRENT-ALIST-ELEMENT point to itself,
1096 indicating that we're seeing the default value.
1097 Likewise if the variable has been let-bound
1098 in the current buffer. */
1099 if (bindflag || SOME_BUFFER_LOCAL_VALUEP (valcontents)
1100 || let_shadows_buffer_binding_p (symbol))
1102 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1104 if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
1105 tem1 = Fassq (symbol,
1106 XFRAME (selected_frame)->param_alist);
1108 if (! NILP (tem1))
1109 XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
1110 else
1111 tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
1113 /* If it's a Lisp_Buffer_Local_Value, being set not bound,
1114 and we're not within a let that was made for this buffer,
1115 create a new buffer-local binding for the variable.
1116 That means, give this buffer a new assoc for a local value
1117 and load that binding. */
1118 else
1120 tem1 = Fcons (symbol, Fcdr (current_alist_element));
1121 buf->local_var_alist
1122 = Fcons (tem1, buf->local_var_alist);
1126 /* Record which binding is now loaded. */
1127 XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr)
1128 = tem1;
1130 /* Set `buffer' and `frame' slots for thebinding now loaded. */
1131 XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, buf);
1132 XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
1134 innercontents = XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
1137 /* If storing void (making the symbol void), forward only through
1138 buffer-local indicator, not through Lisp_Objfwd, etc. */
1139 if (voide)
1140 store_symval_forwarding (symbol, Qnil, newval);
1141 else
1142 store_symval_forwarding (symbol, innercontents, newval);
1144 /* If we just set a variable whose current binding is frame-local,
1145 store the new value in the frame parameter too. */
1147 if (BUFFER_LOCAL_VALUEP (valcontents)
1148 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1150 /* What binding is loaded right now? */
1151 current_alist_element
1152 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1154 /* If the current buffer is not the buffer whose binding is
1155 loaded, or if there may be frame-local bindings and the frame
1156 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1157 the default binding is loaded, the loaded binding may be the
1158 wrong one. */
1159 if (XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame)
1160 XCDR (current_alist_element) = newval;
1163 return newval;
1166 /* Access or set a buffer-local symbol's default value. */
1168 /* Return the default value of SYMBOL, but don't check for voidness.
1169 Return Qunbound if it is void. */
1171 Lisp_Object
1172 default_value (symbol)
1173 Lisp_Object symbol;
1175 register Lisp_Object valcontents;
1177 CHECK_SYMBOL (symbol, 0);
1178 valcontents = XSYMBOL (symbol)->value;
1180 /* For a built-in buffer-local variable, get the default value
1181 rather than letting do_symval_forwarding get the current value. */
1182 if (BUFFER_OBJFWDP (valcontents))
1184 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1185 if (PER_BUFFER_IDX (offset) != 0)
1186 return PER_BUFFER_DEFAULT (offset);
1189 /* Handle user-created local variables. */
1190 if (BUFFER_LOCAL_VALUEP (valcontents)
1191 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1193 /* If var is set up for a buffer that lacks a local value for it,
1194 the current value is nominally the default value.
1195 But the `realvalue' slot may be more up to date, since
1196 ordinary setq stores just that slot. So use that. */
1197 Lisp_Object current_alist_element, alist_element_car;
1198 current_alist_element
1199 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1200 alist_element_car = XCAR (current_alist_element);
1201 if (EQ (alist_element_car, current_alist_element))
1202 return do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue);
1203 else
1204 return XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1206 /* For other variables, get the current value. */
1207 return do_symval_forwarding (valcontents);
1210 DEFUN ("default-boundp", Fdefault_boundp, Sdefault_boundp, 1, 1, 0,
1211 "Return t if SYMBOL has a non-void default value.\n\
1212 This is the value that is seen in buffers that do not have their own values\n\
1213 for this variable.")
1214 (symbol)
1215 Lisp_Object symbol;
1217 register Lisp_Object value;
1219 value = default_value (symbol);
1220 return (EQ (value, Qunbound) ? Qnil : Qt);
1223 DEFUN ("default-value", Fdefault_value, Sdefault_value, 1, 1, 0,
1224 "Return SYMBOL's default value.\n\
1225 This is the value that is seen in buffers that do not have their own values\n\
1226 for this variable. The default value is meaningful for variables with\n\
1227 local bindings in certain buffers.")
1228 (symbol)
1229 Lisp_Object symbol;
1231 register Lisp_Object value;
1233 value = default_value (symbol);
1234 if (EQ (value, Qunbound))
1235 return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
1236 return value;
1239 DEFUN ("set-default", Fset_default, Sset_default, 2, 2, 0,
1240 "Set SYMBOL's default value to VAL. SYMBOL and VAL are evaluated.\n\
1241 The default value is seen in buffers that do not have their own values\n\
1242 for this variable.")
1243 (symbol, value)
1244 Lisp_Object symbol, value;
1246 register Lisp_Object valcontents, current_alist_element, alist_element_buffer;
1248 CHECK_SYMBOL (symbol, 0);
1249 valcontents = XSYMBOL (symbol)->value;
1251 /* Handle variables like case-fold-search that have special slots
1252 in the buffer. Make them work apparently like Lisp_Buffer_Local_Value
1253 variables. */
1254 if (BUFFER_OBJFWDP (valcontents))
1256 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1257 int idx = PER_BUFFER_IDX (offset);
1259 PER_BUFFER_DEFAULT (offset) = value;
1261 /* If this variable is not always local in all buffers,
1262 set it in the buffers that don't nominally have a local value. */
1263 if (idx > 0)
1265 struct buffer *b;
1267 for (b = all_buffers; b; b = b->next)
1268 if (!PER_BUFFER_VALUE_P (b, idx))
1269 PER_BUFFER_VALUE (b, offset) = value;
1271 return value;
1274 if (!BUFFER_LOCAL_VALUEP (valcontents)
1275 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1276 return Fset (symbol, value);
1278 /* Store new value into the DEFAULT-VALUE slot. */
1279 XCDR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = value;
1281 /* If the default binding is now loaded, set the REALVALUE slot too. */
1282 current_alist_element
1283 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
1284 alist_element_buffer = Fcar (current_alist_element);
1285 if (EQ (alist_element_buffer, current_alist_element))
1286 store_symval_forwarding (symbol, XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
1287 value);
1289 return value;
1292 DEFUN ("setq-default", Fsetq_default, Ssetq_default, 2, UNEVALLED, 0,
1293 "Set the default value of variable VAR to VALUE.\n\
1294 VAR, the variable name, is literal (not evaluated);\n\
1295 VALUE is an expression and it is evaluated.\n\
1296 The default value of a variable is seen in buffers\n\
1297 that do not have their own values for the variable.\n\
1299 More generally, you can use multiple variables and values, as in\n\
1300 (setq-default SYMBOL VALUE SYMBOL VALUE...)\n\
1301 This sets each SYMBOL's default value to the corresponding VALUE.\n\
1302 The VALUE for the Nth SYMBOL can refer to the new default values\n\
1303 of previous SYMs.")
1304 (args)
1305 Lisp_Object args;
1307 register Lisp_Object args_left;
1308 register Lisp_Object val, symbol;
1309 struct gcpro gcpro1;
1311 if (NILP (args))
1312 return Qnil;
1314 args_left = args;
1315 GCPRO1 (args);
1319 val = Feval (Fcar (Fcdr (args_left)));
1320 symbol = Fcar (args_left);
1321 Fset_default (symbol, val);
1322 args_left = Fcdr (Fcdr (args_left));
1324 while (!NILP (args_left));
1326 UNGCPRO;
1327 return val;
1330 /* Lisp functions for creating and removing buffer-local variables. */
1332 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local, Smake_variable_buffer_local,
1333 1, 1, "vMake Variable Buffer Local: ",
1334 "Make VARIABLE become buffer-local whenever it is set.\n\
1335 At any time, the value for the current buffer is in effect,\n\
1336 unless the variable has never been set in this buffer,\n\
1337 in which case the default value is in effect.\n\
1338 Note that binding the variable with `let', or setting it while\n\
1339 a `let'-style binding made in this buffer is in effect,\n\
1340 does not make the variable buffer-local.\n\
1342 The function `default-value' gets the default value and `set-default' sets it.")
1343 (variable)
1344 register Lisp_Object variable;
1346 register Lisp_Object tem, valcontents, newval;
1348 CHECK_SYMBOL (variable, 0);
1350 valcontents = XSYMBOL (variable)->value;
1351 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1352 error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1354 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1355 return variable;
1356 if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1358 XMISCTYPE (XSYMBOL (variable)->value) = Lisp_Misc_Buffer_Local_Value;
1359 return variable;
1361 if (EQ (valcontents, Qunbound))
1362 XSYMBOL (variable)->value = Qnil;
1363 tem = Fcons (Qnil, Fsymbol_value (variable));
1364 XCAR (tem) = tem;
1365 newval = allocate_misc ();
1366 XMISCTYPE (newval) = Lisp_Misc_Buffer_Local_Value;
1367 XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value;
1368 XBUFFER_LOCAL_VALUE (newval)->buffer = Fcurrent_buffer ();
1369 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
1370 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
1371 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
1372 XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
1373 XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
1374 XSYMBOL (variable)->value = newval;
1375 return variable;
1378 DEFUN ("make-local-variable", Fmake_local_variable, Smake_local_variable,
1379 1, 1, "vMake Local Variable: ",
1380 "Make VARIABLE have a separate value in the current buffer.\n\
1381 Other buffers will continue to share a common default value.\n\
1382 \(The buffer-local value of VARIABLE starts out as the same value\n\
1383 VARIABLE previously had. If VARIABLE was void, it remains void.\)\n\
1384 See also `make-variable-buffer-local'.\n\
1386 If the variable is already arranged to become local when set,\n\
1387 this function causes a local value to exist for this buffer,\n\
1388 just as setting the variable would do.\n\
1390 This function returns VARIABLE, and therefore\n\
1391 (set (make-local-variable 'VARIABLE) VALUE-EXP)\n\
1392 works.\n\
1394 Do not use `make-local-variable' to make a hook variable buffer-local.\n\
1395 Use `make-local-hook' instead.")
1396 (variable)
1397 register Lisp_Object variable;
1399 register Lisp_Object tem, valcontents;
1401 CHECK_SYMBOL (variable, 0);
1403 valcontents = XSYMBOL (variable)->value;
1404 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents))
1405 error ("Symbol %s may not be buffer-local", XSYMBOL (variable)->name->data);
1407 if (BUFFER_LOCAL_VALUEP (valcontents) || BUFFER_OBJFWDP (valcontents))
1409 tem = Fboundp (variable);
1411 /* Make sure the symbol has a local value in this particular buffer,
1412 by setting it to the same value it already has. */
1413 Fset (variable, (EQ (tem, Qt) ? Fsymbol_value (variable) : Qunbound));
1414 return variable;
1416 /* Make sure symbol is set up to hold per-buffer values. */
1417 if (!SOME_BUFFER_LOCAL_VALUEP (valcontents))
1419 Lisp_Object newval;
1420 tem = Fcons (Qnil, do_symval_forwarding (valcontents));
1421 XCAR (tem) = tem;
1422 newval = allocate_misc ();
1423 XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
1424 XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value;
1425 XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
1426 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
1427 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
1428 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
1429 XBUFFER_LOCAL_VALUE (newval)->check_frame = 0;
1430 XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
1431 XSYMBOL (variable)->value = newval;
1433 /* Make sure this buffer has its own value of symbol. */
1434 tem = Fassq (variable, current_buffer->local_var_alist);
1435 if (NILP (tem))
1437 /* Swap out any local binding for some other buffer, and make
1438 sure the current value is permanently recorded, if it's the
1439 default value. */
1440 find_symbol_value (variable);
1442 current_buffer->local_var_alist
1443 = Fcons (Fcons (variable, XCDR (XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->cdr)),
1444 current_buffer->local_var_alist);
1446 /* Make sure symbol does not think it is set up for this buffer;
1447 force it to look once again for this buffer's value. */
1449 Lisp_Object *pvalbuf;
1451 valcontents = XSYMBOL (variable)->value;
1453 pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
1454 if (current_buffer == XBUFFER (*pvalbuf))
1455 *pvalbuf = Qnil;
1456 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1460 /* If the symbol forwards into a C variable, then load the binding
1461 for this buffer now. If C code modifies the variable before we
1462 load the binding in, then that new value will clobber the default
1463 binding the next time we unload it. */
1464 valcontents = XBUFFER_LOCAL_VALUE (XSYMBOL (variable)->value)->realvalue;
1465 if (INTFWDP (valcontents) || BOOLFWDP (valcontents) || OBJFWDP (valcontents))
1466 swap_in_symval_forwarding (variable, XSYMBOL (variable)->value);
1468 return variable;
1471 DEFUN ("kill-local-variable", Fkill_local_variable, Skill_local_variable,
1472 1, 1, "vKill Local Variable: ",
1473 "Make VARIABLE no longer have a separate value in the current buffer.\n\
1474 From now on the default value will apply in this buffer.")
1475 (variable)
1476 register Lisp_Object variable;
1478 register Lisp_Object tem, valcontents;
1480 CHECK_SYMBOL (variable, 0);
1482 valcontents = XSYMBOL (variable)->value;
1484 if (BUFFER_OBJFWDP (valcontents))
1486 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1487 int idx = PER_BUFFER_IDX (offset);
1489 if (idx > 0)
1491 SET_PER_BUFFER_VALUE_P (current_buffer, idx, 0);
1492 PER_BUFFER_VALUE (current_buffer, offset)
1493 = PER_BUFFER_DEFAULT (offset);
1495 return variable;
1498 if (!BUFFER_LOCAL_VALUEP (valcontents)
1499 && !SOME_BUFFER_LOCAL_VALUEP (valcontents))
1500 return variable;
1502 /* Get rid of this buffer's alist element, if any. */
1504 tem = Fassq (variable, current_buffer->local_var_alist);
1505 if (!NILP (tem))
1506 current_buffer->local_var_alist
1507 = Fdelq (tem, current_buffer->local_var_alist);
1509 /* If the symbol is set up with the current buffer's binding
1510 loaded, recompute its value. We have to do it now, or else
1511 forwarded objects won't work right. */
1513 Lisp_Object *pvalbuf;
1514 valcontents = XSYMBOL (variable)->value;
1515 pvalbuf = &XBUFFER_LOCAL_VALUE (valcontents)->buffer;
1516 if (current_buffer == XBUFFER (*pvalbuf))
1518 *pvalbuf = Qnil;
1519 XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
1520 find_symbol_value (variable);
1524 return variable;
1527 /* Lisp functions for creating and removing buffer-local variables. */
1529 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local, Smake_variable_frame_local,
1530 1, 1, "vMake Variable Frame Local: ",
1531 "Enable VARIABLE to have frame-local bindings.\n\
1532 When a frame-local binding exists in the current frame,\n\
1533 it is in effect whenever the current buffer has no buffer-local binding.\n\
1534 A frame-local binding is actual a frame parameter value;\n\
1535 thus, any given frame has a local binding for VARIABLE\n\
1536 if it has a value for the frame parameter named VARIABLE.\n\
1537 See `modify-frame-parameters'.")
1538 (variable)
1539 register Lisp_Object variable;
1541 register Lisp_Object tem, valcontents, newval;
1543 CHECK_SYMBOL (variable, 0);
1545 valcontents = XSYMBOL (variable)->value;
1546 if (EQ (variable, Qnil) || EQ (variable, Qt) || KBOARD_OBJFWDP (valcontents)
1547 || BUFFER_OBJFWDP (valcontents))
1548 error ("Symbol %s may not be frame-local", XSYMBOL (variable)->name->data);
1550 if (BUFFER_LOCAL_VALUEP (valcontents)
1551 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1553 XBUFFER_LOCAL_VALUE (valcontents)->check_frame = 1;
1554 return variable;
1557 if (EQ (valcontents, Qunbound))
1558 XSYMBOL (variable)->value = Qnil;
1559 tem = Fcons (Qnil, Fsymbol_value (variable));
1560 XCAR (tem) = tem;
1561 newval = allocate_misc ();
1562 XMISCTYPE (newval) = Lisp_Misc_Some_Buffer_Local_Value;
1563 XBUFFER_LOCAL_VALUE (newval)->realvalue = XSYMBOL (variable)->value;
1564 XBUFFER_LOCAL_VALUE (newval)->buffer = Qnil;
1565 XBUFFER_LOCAL_VALUE (newval)->frame = Qnil;
1566 XBUFFER_LOCAL_VALUE (newval)->found_for_buffer = 0;
1567 XBUFFER_LOCAL_VALUE (newval)->found_for_frame = 0;
1568 XBUFFER_LOCAL_VALUE (newval)->check_frame = 1;
1569 XBUFFER_LOCAL_VALUE (newval)->cdr = tem;
1570 XSYMBOL (variable)->value = newval;
1571 return variable;
1574 DEFUN ("local-variable-p", Flocal_variable_p, Slocal_variable_p,
1575 1, 2, 0,
1576 "Non-nil if VARIABLE has a local binding in buffer BUFFER.\n\
1577 BUFFER defaults to the current buffer.")
1578 (variable, buffer)
1579 register Lisp_Object variable, buffer;
1581 Lisp_Object valcontents;
1582 register struct buffer *buf;
1584 if (NILP (buffer))
1585 buf = current_buffer;
1586 else
1588 CHECK_BUFFER (buffer, 0);
1589 buf = XBUFFER (buffer);
1592 CHECK_SYMBOL (variable, 0);
1594 valcontents = XSYMBOL (variable)->value;
1595 if (BUFFER_LOCAL_VALUEP (valcontents)
1596 || SOME_BUFFER_LOCAL_VALUEP (valcontents))
1598 Lisp_Object tail, elt;
1599 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
1601 elt = XCAR (tail);
1602 if (EQ (variable, XCAR (elt)))
1603 return Qt;
1606 if (BUFFER_OBJFWDP (valcontents))
1608 int offset = XBUFFER_OBJFWD (valcontents)->offset;
1609 int idx = PER_BUFFER_IDX (offset);
1610 if (idx == -1 || PER_BUFFER_VALUE_P (buf, idx))
1611 return Qt;
1613 return Qnil;
1616 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p, Slocal_variable_if_set_p,
1617 1, 2, 0,
1618 "Non-nil if VARIABLE will be local in buffer BUFFER if it is set there.\n\
1619 BUFFER defaults to the current buffer.")
1620 (variable, buffer)
1621 register Lisp_Object variable, buffer;
1623 Lisp_Object valcontents;
1624 register struct buffer *buf;
1626 if (NILP (buffer))
1627 buf = current_buffer;
1628 else
1630 CHECK_BUFFER (buffer, 0);
1631 buf = XBUFFER (buffer);
1634 CHECK_SYMBOL (variable, 0);
1636 valcontents = XSYMBOL (variable)->value;
1638 /* This means that make-variable-buffer-local was done. */
1639 if (BUFFER_LOCAL_VALUEP (valcontents))
1640 return Qt;
1641 /* All these slots become local if they are set. */
1642 if (BUFFER_OBJFWDP (valcontents))
1643 return Qt;
1644 if (SOME_BUFFER_LOCAL_VALUEP (valcontents))
1646 Lisp_Object tail, elt;
1647 for (tail = buf->local_var_alist; CONSP (tail); tail = XCDR (tail))
1649 elt = XCAR (tail);
1650 if (EQ (variable, XCAR (elt)))
1651 return Qt;
1654 return Qnil;
1657 /* Find the function at the end of a chain of symbol function indirections. */
1659 /* If OBJECT is a symbol, find the end of its function chain and
1660 return the value found there. If OBJECT is not a symbol, just
1661 return it. If there is a cycle in the function chain, signal a
1662 cyclic-function-indirection error.
1664 This is like Findirect_function, except that it doesn't signal an
1665 error if the chain ends up unbound. */
1666 Lisp_Object
1667 indirect_function (object)
1668 register Lisp_Object object;
1670 Lisp_Object tortoise, hare;
1672 hare = tortoise = object;
1674 for (;;)
1676 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1677 break;
1678 hare = XSYMBOL (hare)->function;
1679 if (!SYMBOLP (hare) || EQ (hare, Qunbound))
1680 break;
1681 hare = XSYMBOL (hare)->function;
1683 tortoise = XSYMBOL (tortoise)->function;
1685 if (EQ (hare, tortoise))
1686 Fsignal (Qcyclic_function_indirection, Fcons (object, Qnil));
1689 return hare;
1692 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
1693 "Return the function at the end of OBJECT's function chain.\n\
1694 If OBJECT is a symbol, follow all function indirections and return the final\n\
1695 function binding.\n\
1696 If OBJECT is not a symbol, just return it.\n\
1697 Signal a void-function error if the final symbol is unbound.\n\
1698 Signal a cyclic-function-indirection error if there is a loop in the\n\
1699 function chain of symbols.")
1700 (object)
1701 register Lisp_Object object;
1703 Lisp_Object result;
1705 result = indirect_function (object);
1707 if (EQ (result, Qunbound))
1708 return Fsignal (Qvoid_function, Fcons (object, Qnil));
1709 return result;
1712 /* Extract and set vector and string elements */
1714 DEFUN ("aref", Faref, Saref, 2, 2, 0,
1715 "Return the element of ARRAY at index IDX.\n\
1716 ARRAY may be a vector, a string, a char-table, a bool-vector,\n\
1717 or a byte-code object. IDX starts at 0.")
1718 (array, idx)
1719 register Lisp_Object array;
1720 Lisp_Object idx;
1722 register int idxval;
1724 CHECK_NUMBER (idx, 1);
1725 idxval = XINT (idx);
1726 if (STRINGP (array))
1728 int c, idxval_byte;
1730 if (idxval < 0 || idxval >= XSTRING (array)->size)
1731 args_out_of_range (array, idx);
1732 if (! STRING_MULTIBYTE (array))
1733 return make_number ((unsigned char) XSTRING (array)->data[idxval]);
1734 idxval_byte = string_char_to_byte (array, idxval);
1736 c = STRING_CHAR (&XSTRING (array)->data[idxval_byte],
1737 STRING_BYTES (XSTRING (array)) - idxval_byte);
1738 return make_number (c);
1740 else if (BOOL_VECTOR_P (array))
1742 int val;
1744 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1745 args_out_of_range (array, idx);
1747 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1748 return (val & (1 << (idxval % BITS_PER_CHAR)) ? Qt : Qnil);
1750 else if (CHAR_TABLE_P (array))
1752 Lisp_Object val;
1754 val = Qnil;
1756 if (idxval < 0)
1757 args_out_of_range (array, idx);
1758 if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
1760 /* For ASCII and 8-bit European characters, the element is
1761 stored in the top table. */
1762 val = XCHAR_TABLE (array)->contents[idxval];
1763 if (NILP (val))
1764 val = XCHAR_TABLE (array)->defalt;
1765 while (NILP (val)) /* Follow parents until we find some value. */
1767 array = XCHAR_TABLE (array)->parent;
1768 if (NILP (array))
1769 return Qnil;
1770 val = XCHAR_TABLE (array)->contents[idxval];
1771 if (NILP (val))
1772 val = XCHAR_TABLE (array)->defalt;
1774 return val;
1776 else
1778 int code[4], i;
1779 Lisp_Object sub_table;
1781 SPLIT_CHAR (idxval, code[0], code[1], code[2]);
1782 if (code[1] < 32) code[1] = -1;
1783 else if (code[2] < 32) code[2] = -1;
1785 /* Here, the possible range of CODE[0] (== charset ID) is
1786 128..MAX_CHARSET. Since the top level char table contains
1787 data for multibyte characters after 256th element, we must
1788 increment CODE[0] by 128 to get a correct index. */
1789 code[0] += 128;
1790 code[3] = -1; /* anchor */
1792 try_parent_char_table:
1793 sub_table = array;
1794 for (i = 0; code[i] >= 0; i++)
1796 val = XCHAR_TABLE (sub_table)->contents[code[i]];
1797 if (SUB_CHAR_TABLE_P (val))
1798 sub_table = val;
1799 else
1801 if (NILP (val))
1802 val = XCHAR_TABLE (sub_table)->defalt;
1803 if (NILP (val))
1805 array = XCHAR_TABLE (array)->parent;
1806 if (!NILP (array))
1807 goto try_parent_char_table;
1809 return val;
1812 /* Here, VAL is a sub char table. We try the default value
1813 and parent. */
1814 val = XCHAR_TABLE (val)->defalt;
1815 if (NILP (val))
1817 array = XCHAR_TABLE (array)->parent;
1818 if (!NILP (array))
1819 goto try_parent_char_table;
1821 return val;
1824 else
1826 int size = 0;
1827 if (VECTORP (array))
1828 size = XVECTOR (array)->size;
1829 else if (COMPILEDP (array))
1830 size = XVECTOR (array)->size & PSEUDOVECTOR_SIZE_MASK;
1831 else
1832 wrong_type_argument (Qarrayp, array);
1834 if (idxval < 0 || idxval >= size)
1835 args_out_of_range (array, idx);
1836 return XVECTOR (array)->contents[idxval];
1840 /* Don't use alloca for relocating string data larger than this, lest
1841 we overflow their stack. The value is the same as what used in
1842 fns.c for base64 handling. */
1843 #define MAX_ALLOCA 16*1024
1845 DEFUN ("aset", Faset, Saset, 3, 3, 0,
1846 "Store into the element of ARRAY at index IDX the value NEWELT.\n\
1847 ARRAY may be a vector, a string, a char-table or a bool-vector.\n\
1848 IDX starts at 0.")
1849 (array, idx, newelt)
1850 register Lisp_Object array;
1851 Lisp_Object idx, newelt;
1853 register int idxval;
1855 CHECK_NUMBER (idx, 1);
1856 idxval = XINT (idx);
1857 if (!VECTORP (array) && !STRINGP (array) && !BOOL_VECTOR_P (array)
1858 && ! CHAR_TABLE_P (array))
1859 array = wrong_type_argument (Qarrayp, array);
1860 CHECK_IMPURE (array);
1862 if (VECTORP (array))
1864 if (idxval < 0 || idxval >= XVECTOR (array)->size)
1865 args_out_of_range (array, idx);
1866 XVECTOR (array)->contents[idxval] = newelt;
1868 else if (BOOL_VECTOR_P (array))
1870 int val;
1872 if (idxval < 0 || idxval >= XBOOL_VECTOR (array)->size)
1873 args_out_of_range (array, idx);
1875 val = (unsigned char) XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR];
1877 if (! NILP (newelt))
1878 val |= 1 << (idxval % BITS_PER_CHAR);
1879 else
1880 val &= ~(1 << (idxval % BITS_PER_CHAR));
1881 XBOOL_VECTOR (array)->data[idxval / BITS_PER_CHAR] = val;
1883 else if (CHAR_TABLE_P (array))
1885 if (idxval < 0)
1886 args_out_of_range (array, idx);
1887 if (idxval < CHAR_TABLE_ORDINARY_SLOTS)
1888 XCHAR_TABLE (array)->contents[idxval] = newelt;
1889 else
1891 int code[4], i;
1892 Lisp_Object val;
1894 SPLIT_CHAR (idxval, code[0], code[1], code[2]);
1895 if (code[1] < 32) code[1] = -1;
1896 else if (code[2] < 32) code[2] = -1;
1898 /* See the comment of the corresponding part in Faref. */
1899 code[0] += 128;
1900 code[3] = -1; /* anchor */
1901 for (i = 0; code[i + 1] >= 0; i++)
1903 val = XCHAR_TABLE (array)->contents[code[i]];
1904 if (SUB_CHAR_TABLE_P (val))
1905 array = val;
1906 else
1908 Lisp_Object temp;
1910 /* VAL is a leaf. Create a sub char table with the
1911 default value VAL or XCHAR_TABLE (array)->defalt
1912 and look into it. */
1914 temp = make_sub_char_table (NILP (val)
1915 ? XCHAR_TABLE (array)->defalt
1916 : val);
1917 XCHAR_TABLE (array)->contents[code[i]] = temp;
1918 array = temp;
1921 XCHAR_TABLE (array)->contents[code[i]] = newelt;
1924 else if (STRING_MULTIBYTE (array))
1926 int idxval_byte, prev_bytes, new_bytes;
1927 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
1929 if (idxval < 0 || idxval >= XSTRING (array)->size)
1930 args_out_of_range (array, idx);
1931 CHECK_NUMBER (newelt, 2);
1933 idxval_byte = string_char_to_byte (array, idxval);
1934 p1 = &XSTRING (array)->data[idxval_byte];
1935 PARSE_MULTIBYTE_SEQ (p1, nbytes - idxval_byte, prev_bytes);
1936 new_bytes = CHAR_STRING (XINT (newelt), p0);
1937 if (prev_bytes != new_bytes)
1939 /* We must relocate the string data. */
1940 int nchars = XSTRING (array)->size;
1941 int nbytes = STRING_BYTES (XSTRING (array));
1942 unsigned char *str;
1944 str = (nbytes <= MAX_ALLOCA
1945 ? (unsigned char *) alloca (nbytes)
1946 : (unsigned char *) xmalloc (nbytes));
1947 bcopy (XSTRING (array)->data, str, nbytes);
1948 allocate_string_data (XSTRING (array), nchars,
1949 nbytes + new_bytes - prev_bytes);
1950 bcopy (str, XSTRING (array)->data, idxval_byte);
1951 p1 = XSTRING (array)->data + idxval_byte;
1952 bcopy (str + idxval_byte + prev_bytes, p1 + new_bytes,
1953 nbytes - (idxval_byte + prev_bytes));
1954 if (nbytes > MAX_ALLOCA)
1955 xfree (str);
1956 clear_string_char_byte_cache ();
1958 while (new_bytes--)
1959 *p1++ = *p0++;
1961 else
1963 if (idxval < 0 || idxval >= XSTRING (array)->size)
1964 args_out_of_range (array, idx);
1965 CHECK_NUMBER (newelt, 2);
1967 if (XINT (newelt) < 0 || SINGLE_BYTE_CHAR_P (XINT (newelt)))
1968 XSTRING (array)->data[idxval] = XINT (newelt);
1969 else
1971 /* We must relocate the string data while converting it to
1972 multibyte. */
1973 int idxval_byte, prev_bytes, new_bytes;
1974 unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1;
1975 unsigned char *origstr = XSTRING (array)->data, *str;
1976 int nchars, nbytes;
1978 nchars = XSTRING (array)->size;
1979 nbytes = idxval_byte = count_size_as_multibyte (origstr, idxval);
1980 nbytes += count_size_as_multibyte (origstr + idxval,
1981 nchars - idxval);
1982 str = (nbytes <= MAX_ALLOCA
1983 ? (unsigned char *) alloca (nbytes)
1984 : (unsigned char *) xmalloc (nbytes));
1985 copy_text (XSTRING (array)->data, str, nchars, 0, 1);
1986 PARSE_MULTIBYTE_SEQ (str + idxval_byte, nbytes - idxval_byte,
1987 prev_bytes);
1988 new_bytes = CHAR_STRING (XINT (newelt), p0);
1989 allocate_string_data (XSTRING (array), nchars,
1990 nbytes + new_bytes - prev_bytes);
1991 bcopy (str, XSTRING (array)->data, idxval_byte);
1992 p1 = XSTRING (array)->data + idxval_byte;
1993 while (new_bytes--)
1994 *p1++ = *p0++;
1995 bcopy (str + idxval_byte + prev_bytes, p1,
1996 nbytes - (idxval_byte + prev_bytes));
1997 if (nbytes > MAX_ALLOCA)
1998 xfree (str);
1999 clear_string_char_byte_cache ();
2003 return newelt;
2006 /* Arithmetic functions */
2008 enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
2010 Lisp_Object
2011 arithcompare (num1, num2, comparison)
2012 Lisp_Object num1, num2;
2013 enum comparison comparison;
2015 double f1 = 0, f2 = 0;
2016 int floatp = 0;
2018 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1, 0);
2019 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2, 0);
2021 if (FLOATP (num1) || FLOATP (num2))
2023 floatp = 1;
2024 f1 = (FLOATP (num1)) ? XFLOAT_DATA (num1) : XINT (num1);
2025 f2 = (FLOATP (num2)) ? XFLOAT_DATA (num2) : XINT (num2);
2028 switch (comparison)
2030 case equal:
2031 if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
2032 return Qt;
2033 return Qnil;
2035 case notequal:
2036 if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
2037 return Qt;
2038 return Qnil;
2040 case less:
2041 if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
2042 return Qt;
2043 return Qnil;
2045 case less_or_equal:
2046 if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
2047 return Qt;
2048 return Qnil;
2050 case grtr:
2051 if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
2052 return Qt;
2053 return Qnil;
2055 case grtr_or_equal:
2056 if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
2057 return Qt;
2058 return Qnil;
2060 default:
2061 abort ();
2065 DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
2066 "Return t if two args, both numbers or markers, are equal.")
2067 (num1, num2)
2068 register Lisp_Object num1, num2;
2070 return arithcompare (num1, num2, equal);
2073 DEFUN ("<", Flss, Slss, 2, 2, 0,
2074 "Return t if first arg is less than second arg. Both must be numbers or markers.")
2075 (num1, num2)
2076 register Lisp_Object num1, num2;
2078 return arithcompare (num1, num2, less);
2081 DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
2082 "Return t if first arg is greater than second arg. Both must be numbers or markers.")
2083 (num1, num2)
2084 register Lisp_Object num1, num2;
2086 return arithcompare (num1, num2, grtr);
2089 DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
2090 "Return t if first arg is less than or equal to second arg.\n\
2091 Both must be numbers or markers.")
2092 (num1, num2)
2093 register Lisp_Object num1, num2;
2095 return arithcompare (num1, num2, less_or_equal);
2098 DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
2099 "Return t if first arg is greater than or equal to second arg.\n\
2100 Both must be numbers or markers.")
2101 (num1, num2)
2102 register Lisp_Object num1, num2;
2104 return arithcompare (num1, num2, grtr_or_equal);
2107 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
2108 "Return t if first arg is not equal to second arg. Both must be numbers or markers.")
2109 (num1, num2)
2110 register Lisp_Object num1, num2;
2112 return arithcompare (num1, num2, notequal);
2115 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "Return t if NUMBER is zero.")
2116 (number)
2117 register Lisp_Object number;
2119 CHECK_NUMBER_OR_FLOAT (number, 0);
2121 if (FLOATP (number))
2123 if (XFLOAT_DATA (number) == 0.0)
2124 return Qt;
2125 return Qnil;
2128 if (!XINT (number))
2129 return Qt;
2130 return Qnil;
2133 /* Convert between long values and pairs of Lisp integers. */
2135 Lisp_Object
2136 long_to_cons (i)
2137 unsigned long i;
2139 unsigned int top = i >> 16;
2140 unsigned int bot = i & 0xFFFF;
2141 if (top == 0)
2142 return make_number (bot);
2143 if (top == (unsigned long)-1 >> 16)
2144 return Fcons (make_number (-1), make_number (bot));
2145 return Fcons (make_number (top), make_number (bot));
2148 unsigned long
2149 cons_to_long (c)
2150 Lisp_Object c;
2152 Lisp_Object top, bot;
2153 if (INTEGERP (c))
2154 return XINT (c);
2155 top = XCAR (c);
2156 bot = XCDR (c);
2157 if (CONSP (bot))
2158 bot = XCAR (bot);
2159 return ((XINT (top) << 16) | XINT (bot));
2162 DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
2163 "Convert NUMBER to a string by printing it in decimal.\n\
2164 Uses a minus sign if negative.\n\
2165 NUMBER may be an integer or a floating point number.")
2166 (number)
2167 Lisp_Object number;
2169 char buffer[VALBITS];
2171 CHECK_NUMBER_OR_FLOAT (number, 0);
2173 if (FLOATP (number))
2175 char pigbuf[350]; /* see comments in float_to_string */
2177 float_to_string (pigbuf, XFLOAT_DATA (number));
2178 return build_string (pigbuf);
2181 if (sizeof (int) == sizeof (EMACS_INT))
2182 sprintf (buffer, "%d", XINT (number));
2183 else if (sizeof (long) == sizeof (EMACS_INT))
2184 sprintf (buffer, "%ld", (long) XINT (number));
2185 else
2186 abort ();
2187 return build_string (buffer);
2190 INLINE static int
2191 digit_to_number (character, base)
2192 int character, base;
2194 int digit;
2196 if (character >= '0' && character <= '9')
2197 digit = character - '0';
2198 else if (character >= 'a' && character <= 'z')
2199 digit = character - 'a' + 10;
2200 else if (character >= 'A' && character <= 'Z')
2201 digit = character - 'A' + 10;
2202 else
2203 return -1;
2205 if (digit >= base)
2206 return -1;
2207 else
2208 return digit;
2211 DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 2, 0,
2212 "Convert STRING to a number by parsing it as a decimal number.\n\
2213 This parses both integers and floating point numbers.\n\
2214 It ignores leading spaces and tabs.\n\
2216 If BASE, interpret STRING as a number in that base. If BASE isn't\n\
2217 present, base 10 is used. BASE must be between 2 and 16 (inclusive).\n\
2218 If the base used is not 10, floating point is not recognized.")
2219 (string, base)
2220 register Lisp_Object string, base;
2222 register unsigned char *p;
2223 register int b;
2224 int sign = 1;
2225 Lisp_Object val;
2227 CHECK_STRING (string, 0);
2229 if (NILP (base))
2230 b = 10;
2231 else
2233 CHECK_NUMBER (base, 1);
2234 b = XINT (base);
2235 if (b < 2 || b > 16)
2236 Fsignal (Qargs_out_of_range, Fcons (base, Qnil));
2239 /* Skip any whitespace at the front of the number. Some versions of
2240 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2241 p = XSTRING (string)->data;
2242 while (*p == ' ' || *p == '\t')
2243 p++;
2245 if (*p == '-')
2247 sign = -1;
2248 p++;
2250 else if (*p == '+')
2251 p++;
2253 if (isfloat_string (p) && b == 10)
2254 val = make_float (sign * atof (p));
2255 else
2257 double v = 0;
2259 while (1)
2261 int digit = digit_to_number (*p++, b);
2262 if (digit < 0)
2263 break;
2264 v = v * b + digit;
2267 if (v > (EMACS_UINT) (VALMASK >> 1))
2268 val = make_float (sign * v);
2269 else
2270 val = make_number (sign * (int) v);
2273 return val;
2277 enum arithop
2278 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
2280 extern Lisp_Object float_arith_driver ();
2281 extern Lisp_Object fmod_float ();
2283 Lisp_Object
2284 arith_driver (code, nargs, args)
2285 enum arithop code;
2286 int nargs;
2287 register Lisp_Object *args;
2289 register Lisp_Object val;
2290 register int argnum;
2291 register EMACS_INT accum;
2292 register EMACS_INT next;
2294 switch (SWITCH_ENUM_CAST (code))
2296 case Alogior:
2297 case Alogxor:
2298 case Aadd:
2299 case Asub:
2300 accum = 0; break;
2301 case Amult:
2302 accum = 1; break;
2303 case Alogand:
2304 accum = -1; break;
2307 for (argnum = 0; argnum < nargs; argnum++)
2309 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2310 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
2312 if (FLOATP (val)) /* time to do serious math */
2313 return (float_arith_driver ((double) accum, argnum, code,
2314 nargs, args));
2315 args[argnum] = val; /* runs into a compiler bug. */
2316 next = XINT (args[argnum]);
2317 switch (SWITCH_ENUM_CAST (code))
2319 case Aadd: accum += next; break;
2320 case Asub:
2321 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2322 break;
2323 case Amult: accum *= next; break;
2324 case Adiv:
2325 if (!argnum) accum = next;
2326 else
2328 if (next == 0)
2329 Fsignal (Qarith_error, Qnil);
2330 accum /= next;
2332 break;
2333 case Alogand: accum &= next; break;
2334 case Alogior: accum |= next; break;
2335 case Alogxor: accum ^= next; break;
2336 case Amax: if (!argnum || next > accum) accum = next; break;
2337 case Amin: if (!argnum || next < accum) accum = next; break;
2341 XSETINT (val, accum);
2342 return val;
2345 #undef isnan
2346 #define isnan(x) ((x) != (x))
2348 Lisp_Object
2349 float_arith_driver (accum, argnum, code, nargs, args)
2350 double accum;
2351 register int argnum;
2352 enum arithop code;
2353 int nargs;
2354 register Lisp_Object *args;
2356 register Lisp_Object val;
2357 double next;
2359 for (; argnum < nargs; argnum++)
2361 val = args[argnum]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2362 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val, argnum);
2364 if (FLOATP (val))
2366 next = XFLOAT_DATA (val);
2368 else
2370 args[argnum] = val; /* runs into a compiler bug. */
2371 next = XINT (args[argnum]);
2373 switch (SWITCH_ENUM_CAST (code))
2375 case Aadd:
2376 accum += next;
2377 break;
2378 case Asub:
2379 accum = argnum ? accum - next : nargs == 1 ? - next : next;
2380 break;
2381 case Amult:
2382 accum *= next;
2383 break;
2384 case Adiv:
2385 if (!argnum)
2386 accum = next;
2387 else
2389 if (! IEEE_FLOATING_POINT && next == 0)
2390 Fsignal (Qarith_error, Qnil);
2391 accum /= next;
2393 break;
2394 case Alogand:
2395 case Alogior:
2396 case Alogxor:
2397 return wrong_type_argument (Qinteger_or_marker_p, val);
2398 case Amax:
2399 if (!argnum || isnan (next) || next > accum)
2400 accum = next;
2401 break;
2402 case Amin:
2403 if (!argnum || isnan (next) || next < accum)
2404 accum = next;
2405 break;
2409 return make_float (accum);
2413 DEFUN ("+", Fplus, Splus, 0, MANY, 0,
2414 "Return sum of any number of arguments, which are numbers or markers.")
2415 (nargs, args)
2416 int nargs;
2417 Lisp_Object *args;
2419 return arith_driver (Aadd, nargs, args);
2422 DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
2423 "Negate number or subtract numbers or markers.\n\
2424 With one arg, negates it. With more than one arg,\n\
2425 subtracts all but the first from the first.")
2426 (nargs, args)
2427 int nargs;
2428 Lisp_Object *args;
2430 return arith_driver (Asub, nargs, args);
2433 DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
2434 "Returns product of any number of arguments, which are numbers or markers.")
2435 (nargs, args)
2436 int nargs;
2437 Lisp_Object *args;
2439 return arith_driver (Amult, nargs, args);
2442 DEFUN ("/", Fquo, Squo, 2, MANY, 0,
2443 "Returns first argument divided by all the remaining arguments.\n\
2444 The arguments must be numbers or markers.")
2445 (nargs, args)
2446 int nargs;
2447 Lisp_Object *args;
2449 return arith_driver (Adiv, nargs, args);
2452 DEFUN ("%", Frem, Srem, 2, 2, 0,
2453 "Returns remainder of X divided by Y.\n\
2454 Both must be integers or markers.")
2455 (x, y)
2456 register Lisp_Object x, y;
2458 Lisp_Object val;
2460 CHECK_NUMBER_COERCE_MARKER (x, 0);
2461 CHECK_NUMBER_COERCE_MARKER (y, 1);
2463 if (XFASTINT (y) == 0)
2464 Fsignal (Qarith_error, Qnil);
2466 XSETINT (val, XINT (x) % XINT (y));
2467 return val;
2470 #ifndef HAVE_FMOD
2471 double
2472 fmod (f1, f2)
2473 double f1, f2;
2475 double r = f1;
2477 if (f2 < 0.0)
2478 f2 = -f2;
2480 /* If the magnitude of the result exceeds that of the divisor, or
2481 the sign of the result does not agree with that of the dividend,
2482 iterate with the reduced value. This does not yield a
2483 particularly accurate result, but at least it will be in the
2484 range promised by fmod. */
2486 r -= f2 * floor (r / f2);
2487 while (f2 <= (r < 0 ? -r : r) || ((r < 0) != (f1 < 0) && ! isnan (r)));
2489 return r;
2491 #endif /* ! HAVE_FMOD */
2493 DEFUN ("mod", Fmod, Smod, 2, 2, 0,
2494 "Returns X modulo Y.\n\
2495 The result falls between zero (inclusive) and Y (exclusive).\n\
2496 Both X and Y must be numbers or markers.")
2497 (x, y)
2498 register Lisp_Object x, y;
2500 Lisp_Object val;
2501 EMACS_INT i1, i2;
2503 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x, 0);
2504 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y, 1);
2506 if (FLOATP (x) || FLOATP (y))
2507 return fmod_float (x, y);
2509 i1 = XINT (x);
2510 i2 = XINT (y);
2512 if (i2 == 0)
2513 Fsignal (Qarith_error, Qnil);
2515 i1 %= i2;
2517 /* If the "remainder" comes out with the wrong sign, fix it. */
2518 if (i2 < 0 ? i1 > 0 : i1 < 0)
2519 i1 += i2;
2521 XSETINT (val, i1);
2522 return val;
2525 DEFUN ("max", Fmax, Smax, 1, MANY, 0,
2526 "Return largest of all the arguments (which must be numbers or markers).\n\
2527 The value is always a number; markers are converted to numbers.")
2528 (nargs, args)
2529 int nargs;
2530 Lisp_Object *args;
2532 return arith_driver (Amax, nargs, args);
2535 DEFUN ("min", Fmin, Smin, 1, MANY, 0,
2536 "Return smallest of all the arguments (which must be numbers or markers).\n\
2537 The value is always a number; markers are converted to numbers.")
2538 (nargs, args)
2539 int nargs;
2540 Lisp_Object *args;
2542 return arith_driver (Amin, nargs, args);
2545 DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
2546 "Return bitwise-and of all the arguments.\n\
2547 Arguments may be integers, or markers converted to integers.")
2548 (nargs, args)
2549 int nargs;
2550 Lisp_Object *args;
2552 return arith_driver (Alogand, nargs, args);
2555 DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
2556 "Return bitwise-or of all the arguments.\n\
2557 Arguments may be integers, or markers converted to integers.")
2558 (nargs, args)
2559 int nargs;
2560 Lisp_Object *args;
2562 return arith_driver (Alogior, nargs, args);
2565 DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
2566 "Return bitwise-exclusive-or of all the arguments.\n\
2567 Arguments may be integers, or markers converted to integers.")
2568 (nargs, args)
2569 int nargs;
2570 Lisp_Object *args;
2572 return arith_driver (Alogxor, nargs, args);
2575 DEFUN ("ash", Fash, Sash, 2, 2, 0,
2576 "Return VALUE with its bits shifted left by COUNT.\n\
2577 If COUNT is negative, shifting is actually to the right.\n\
2578 In this case, the sign bit is duplicated.")
2579 (value, count)
2580 register Lisp_Object value, count;
2582 register Lisp_Object val;
2584 CHECK_NUMBER (value, 0);
2585 CHECK_NUMBER (count, 1);
2587 if (XINT (count) >= BITS_PER_EMACS_INT)
2588 XSETINT (val, 0);
2589 else if (XINT (count) > 0)
2590 XSETINT (val, XINT (value) << XFASTINT (count));
2591 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2592 XSETINT (val, XINT (value) < 0 ? -1 : 0);
2593 else
2594 XSETINT (val, XINT (value) >> -XINT (count));
2595 return val;
2598 DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
2599 "Return VALUE with its bits shifted left by COUNT.\n\
2600 If COUNT is negative, shifting is actually to the right.\n\
2601 In this case, zeros are shifted in on the left.")
2602 (value, count)
2603 register Lisp_Object value, count;
2605 register Lisp_Object val;
2607 CHECK_NUMBER (value, 0);
2608 CHECK_NUMBER (count, 1);
2610 if (XINT (count) >= BITS_PER_EMACS_INT)
2611 XSETINT (val, 0);
2612 else if (XINT (count) > 0)
2613 XSETINT (val, (EMACS_UINT) XUINT (value) << XFASTINT (count));
2614 else if (XINT (count) <= -BITS_PER_EMACS_INT)
2615 XSETINT (val, 0);
2616 else
2617 XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
2618 return val;
2621 DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
2622 "Return NUMBER plus one. NUMBER may be a number or a marker.\n\
2623 Markers are converted to integers.")
2624 (number)
2625 register Lisp_Object number;
2627 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2629 if (FLOATP (number))
2630 return (make_float (1.0 + XFLOAT_DATA (number)));
2632 XSETINT (number, XINT (number) + 1);
2633 return number;
2636 DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
2637 "Return NUMBER minus one. NUMBER may be a number or a marker.\n\
2638 Markers are converted to integers.")
2639 (number)
2640 register Lisp_Object number;
2642 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number, 0);
2644 if (FLOATP (number))
2645 return (make_float (-1.0 + XFLOAT_DATA (number)));
2647 XSETINT (number, XINT (number) - 1);
2648 return number;
2651 DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
2652 "Return the bitwise complement of NUMBER. NUMBER must be an integer.")
2653 (number)
2654 register Lisp_Object number;
2656 CHECK_NUMBER (number, 0);
2657 XSETINT (number, ~XINT (number));
2658 return number;
2661 void
2662 syms_of_data ()
2664 Lisp_Object error_tail, arith_tail;
2666 Qquote = intern ("quote");
2667 Qlambda = intern ("lambda");
2668 Qsubr = intern ("subr");
2669 Qerror_conditions = intern ("error-conditions");
2670 Qerror_message = intern ("error-message");
2671 Qtop_level = intern ("top-level");
2673 Qerror = intern ("error");
2674 Qquit = intern ("quit");
2675 Qwrong_type_argument = intern ("wrong-type-argument");
2676 Qargs_out_of_range = intern ("args-out-of-range");
2677 Qvoid_function = intern ("void-function");
2678 Qcyclic_function_indirection = intern ("cyclic-function-indirection");
2679 Qvoid_variable = intern ("void-variable");
2680 Qsetting_constant = intern ("setting-constant");
2681 Qinvalid_read_syntax = intern ("invalid-read-syntax");
2683 Qinvalid_function = intern ("invalid-function");
2684 Qwrong_number_of_arguments = intern ("wrong-number-of-arguments");
2685 Qno_catch = intern ("no-catch");
2686 Qend_of_file = intern ("end-of-file");
2687 Qarith_error = intern ("arith-error");
2688 Qbeginning_of_buffer = intern ("beginning-of-buffer");
2689 Qend_of_buffer = intern ("end-of-buffer");
2690 Qbuffer_read_only = intern ("buffer-read-only");
2691 Qtext_read_only = intern ("text-read-only");
2692 Qmark_inactive = intern ("mark-inactive");
2694 Qlistp = intern ("listp");
2695 Qconsp = intern ("consp");
2696 Qsymbolp = intern ("symbolp");
2697 Qkeywordp = intern ("keywordp");
2698 Qintegerp = intern ("integerp");
2699 Qnatnump = intern ("natnump");
2700 Qwholenump = intern ("wholenump");
2701 Qstringp = intern ("stringp");
2702 Qarrayp = intern ("arrayp");
2703 Qsequencep = intern ("sequencep");
2704 Qbufferp = intern ("bufferp");
2705 Qvectorp = intern ("vectorp");
2706 Qchar_or_string_p = intern ("char-or-string-p");
2707 Qmarkerp = intern ("markerp");
2708 Qbuffer_or_string_p = intern ("buffer-or-string-p");
2709 Qinteger_or_marker_p = intern ("integer-or-marker-p");
2710 Qboundp = intern ("boundp");
2711 Qfboundp = intern ("fboundp");
2713 Qfloatp = intern ("floatp");
2714 Qnumberp = intern ("numberp");
2715 Qnumber_or_marker_p = intern ("number-or-marker-p");
2717 Qchar_table_p = intern ("char-table-p");
2718 Qvector_or_char_table_p = intern ("vector-or-char-table-p");
2720 Qsubrp = intern ("subrp");
2721 Qunevalled = intern ("unevalled");
2722 Qmany = intern ("many");
2724 Qcdr = intern ("cdr");
2726 /* Handle automatic advice activation */
2727 Qad_advice_info = intern ("ad-advice-info");
2728 Qad_activate_internal = intern ("ad-activate-internal");
2730 error_tail = Fcons (Qerror, Qnil);
2732 /* ERROR is used as a signaler for random errors for which nothing else is right */
2734 Fput (Qerror, Qerror_conditions,
2735 error_tail);
2736 Fput (Qerror, Qerror_message,
2737 build_string ("error"));
2739 Fput (Qquit, Qerror_conditions,
2740 Fcons (Qquit, Qnil));
2741 Fput (Qquit, Qerror_message,
2742 build_string ("Quit"));
2744 Fput (Qwrong_type_argument, Qerror_conditions,
2745 Fcons (Qwrong_type_argument, error_tail));
2746 Fput (Qwrong_type_argument, Qerror_message,
2747 build_string ("Wrong type argument"));
2749 Fput (Qargs_out_of_range, Qerror_conditions,
2750 Fcons (Qargs_out_of_range, error_tail));
2751 Fput (Qargs_out_of_range, Qerror_message,
2752 build_string ("Args out of range"));
2754 Fput (Qvoid_function, Qerror_conditions,
2755 Fcons (Qvoid_function, error_tail));
2756 Fput (Qvoid_function, Qerror_message,
2757 build_string ("Symbol's function definition is void"));
2759 Fput (Qcyclic_function_indirection, Qerror_conditions,
2760 Fcons (Qcyclic_function_indirection, error_tail));
2761 Fput (Qcyclic_function_indirection, Qerror_message,
2762 build_string ("Symbol's chain of function indirections contains a loop"));
2764 Fput (Qvoid_variable, Qerror_conditions,
2765 Fcons (Qvoid_variable, error_tail));
2766 Fput (Qvoid_variable, Qerror_message,
2767 build_string ("Symbol's value as variable is void"));
2769 Fput (Qsetting_constant, Qerror_conditions,
2770 Fcons (Qsetting_constant, error_tail));
2771 Fput (Qsetting_constant, Qerror_message,
2772 build_string ("Attempt to set a constant symbol"));
2774 Fput (Qinvalid_read_syntax, Qerror_conditions,
2775 Fcons (Qinvalid_read_syntax, error_tail));
2776 Fput (Qinvalid_read_syntax, Qerror_message,
2777 build_string ("Invalid read syntax"));
2779 Fput (Qinvalid_function, Qerror_conditions,
2780 Fcons (Qinvalid_function, error_tail));
2781 Fput (Qinvalid_function, Qerror_message,
2782 build_string ("Invalid function"));
2784 Fput (Qwrong_number_of_arguments, Qerror_conditions,
2785 Fcons (Qwrong_number_of_arguments, error_tail));
2786 Fput (Qwrong_number_of_arguments, Qerror_message,
2787 build_string ("Wrong number of arguments"));
2789 Fput (Qno_catch, Qerror_conditions,
2790 Fcons (Qno_catch, error_tail));
2791 Fput (Qno_catch, Qerror_message,
2792 build_string ("No catch for tag"));
2794 Fput (Qend_of_file, Qerror_conditions,
2795 Fcons (Qend_of_file, error_tail));
2796 Fput (Qend_of_file, Qerror_message,
2797 build_string ("End of file during parsing"));
2799 arith_tail = Fcons (Qarith_error, error_tail);
2800 Fput (Qarith_error, Qerror_conditions,
2801 arith_tail);
2802 Fput (Qarith_error, Qerror_message,
2803 build_string ("Arithmetic error"));
2805 Fput (Qbeginning_of_buffer, Qerror_conditions,
2806 Fcons (Qbeginning_of_buffer, error_tail));
2807 Fput (Qbeginning_of_buffer, Qerror_message,
2808 build_string ("Beginning of buffer"));
2810 Fput (Qend_of_buffer, Qerror_conditions,
2811 Fcons (Qend_of_buffer, error_tail));
2812 Fput (Qend_of_buffer, Qerror_message,
2813 build_string ("End of buffer"));
2815 Fput (Qbuffer_read_only, Qerror_conditions,
2816 Fcons (Qbuffer_read_only, error_tail));
2817 Fput (Qbuffer_read_only, Qerror_message,
2818 build_string ("Buffer is read-only"));
2820 Fput (Qtext_read_only, Qerror_conditions,
2821 Fcons (Qtext_read_only, error_tail));
2822 Fput (Qtext_read_only, Qerror_message,
2823 build_string ("Text is read-only"));
2825 Qrange_error = intern ("range-error");
2826 Qdomain_error = intern ("domain-error");
2827 Qsingularity_error = intern ("singularity-error");
2828 Qoverflow_error = intern ("overflow-error");
2829 Qunderflow_error = intern ("underflow-error");
2831 Fput (Qdomain_error, Qerror_conditions,
2832 Fcons (Qdomain_error, arith_tail));
2833 Fput (Qdomain_error, Qerror_message,
2834 build_string ("Arithmetic domain error"));
2836 Fput (Qrange_error, Qerror_conditions,
2837 Fcons (Qrange_error, arith_tail));
2838 Fput (Qrange_error, Qerror_message,
2839 build_string ("Arithmetic range error"));
2841 Fput (Qsingularity_error, Qerror_conditions,
2842 Fcons (Qsingularity_error, Fcons (Qdomain_error, arith_tail)));
2843 Fput (Qsingularity_error, Qerror_message,
2844 build_string ("Arithmetic singularity error"));
2846 Fput (Qoverflow_error, Qerror_conditions,
2847 Fcons (Qoverflow_error, Fcons (Qdomain_error, arith_tail)));
2848 Fput (Qoverflow_error, Qerror_message,
2849 build_string ("Arithmetic overflow error"));
2851 Fput (Qunderflow_error, Qerror_conditions,
2852 Fcons (Qunderflow_error, Fcons (Qdomain_error, arith_tail)));
2853 Fput (Qunderflow_error, Qerror_message,
2854 build_string ("Arithmetic underflow error"));
2856 staticpro (&Qrange_error);
2857 staticpro (&Qdomain_error);
2858 staticpro (&Qsingularity_error);
2859 staticpro (&Qoverflow_error);
2860 staticpro (&Qunderflow_error);
2862 staticpro (&Qnil);
2863 staticpro (&Qt);
2864 staticpro (&Qquote);
2865 staticpro (&Qlambda);
2866 staticpro (&Qsubr);
2867 staticpro (&Qunbound);
2868 staticpro (&Qerror_conditions);
2869 staticpro (&Qerror_message);
2870 staticpro (&Qtop_level);
2872 staticpro (&Qerror);
2873 staticpro (&Qquit);
2874 staticpro (&Qwrong_type_argument);
2875 staticpro (&Qargs_out_of_range);
2876 staticpro (&Qvoid_function);
2877 staticpro (&Qcyclic_function_indirection);
2878 staticpro (&Qvoid_variable);
2879 staticpro (&Qsetting_constant);
2880 staticpro (&Qinvalid_read_syntax);
2881 staticpro (&Qwrong_number_of_arguments);
2882 staticpro (&Qinvalid_function);
2883 staticpro (&Qno_catch);
2884 staticpro (&Qend_of_file);
2885 staticpro (&Qarith_error);
2886 staticpro (&Qbeginning_of_buffer);
2887 staticpro (&Qend_of_buffer);
2888 staticpro (&Qbuffer_read_only);
2889 staticpro (&Qtext_read_only);
2890 staticpro (&Qmark_inactive);
2892 staticpro (&Qlistp);
2893 staticpro (&Qconsp);
2894 staticpro (&Qsymbolp);
2895 staticpro (&Qkeywordp);
2896 staticpro (&Qintegerp);
2897 staticpro (&Qnatnump);
2898 staticpro (&Qwholenump);
2899 staticpro (&Qstringp);
2900 staticpro (&Qarrayp);
2901 staticpro (&Qsequencep);
2902 staticpro (&Qbufferp);
2903 staticpro (&Qvectorp);
2904 staticpro (&Qchar_or_string_p);
2905 staticpro (&Qmarkerp);
2906 staticpro (&Qbuffer_or_string_p);
2907 staticpro (&Qinteger_or_marker_p);
2908 staticpro (&Qfloatp);
2909 staticpro (&Qnumberp);
2910 staticpro (&Qnumber_or_marker_p);
2911 staticpro (&Qchar_table_p);
2912 staticpro (&Qvector_or_char_table_p);
2913 staticpro (&Qsubrp);
2914 staticpro (&Qmany);
2915 staticpro (&Qunevalled);
2917 staticpro (&Qboundp);
2918 staticpro (&Qfboundp);
2919 staticpro (&Qcdr);
2920 staticpro (&Qad_advice_info);
2921 staticpro (&Qad_activate_internal);
2923 /* Types that type-of returns. */
2924 Qinteger = intern ("integer");
2925 Qsymbol = intern ("symbol");
2926 Qstring = intern ("string");
2927 Qcons = intern ("cons");
2928 Qmarker = intern ("marker");
2929 Qoverlay = intern ("overlay");
2930 Qfloat = intern ("float");
2931 Qwindow_configuration = intern ("window-configuration");
2932 Qprocess = intern ("process");
2933 Qwindow = intern ("window");
2934 /* Qsubr = intern ("subr"); */
2935 Qcompiled_function = intern ("compiled-function");
2936 Qbuffer = intern ("buffer");
2937 Qframe = intern ("frame");
2938 Qvector = intern ("vector");
2939 Qchar_table = intern ("char-table");
2940 Qbool_vector = intern ("bool-vector");
2941 Qhash_table = intern ("hash-table");
2943 staticpro (&Qinteger);
2944 staticpro (&Qsymbol);
2945 staticpro (&Qstring);
2946 staticpro (&Qcons);
2947 staticpro (&Qmarker);
2948 staticpro (&Qoverlay);
2949 staticpro (&Qfloat);
2950 staticpro (&Qwindow_configuration);
2951 staticpro (&Qprocess);
2952 staticpro (&Qwindow);
2953 /* staticpro (&Qsubr); */
2954 staticpro (&Qcompiled_function);
2955 staticpro (&Qbuffer);
2956 staticpro (&Qframe);
2957 staticpro (&Qvector);
2958 staticpro (&Qchar_table);
2959 staticpro (&Qbool_vector);
2960 staticpro (&Qhash_table);
2962 defsubr (&Seq);
2963 defsubr (&Snull);
2964 defsubr (&Stype_of);
2965 defsubr (&Slistp);
2966 defsubr (&Snlistp);
2967 defsubr (&Sconsp);
2968 defsubr (&Satom);
2969 defsubr (&Sintegerp);
2970 defsubr (&Sinteger_or_marker_p);
2971 defsubr (&Snumberp);
2972 defsubr (&Snumber_or_marker_p);
2973 defsubr (&Sfloatp);
2974 defsubr (&Snatnump);
2975 defsubr (&Ssymbolp);
2976 defsubr (&Skeywordp);
2977 defsubr (&Sstringp);
2978 defsubr (&Smultibyte_string_p);
2979 defsubr (&Svectorp);
2980 defsubr (&Schar_table_p);
2981 defsubr (&Svector_or_char_table_p);
2982 defsubr (&Sbool_vector_p);
2983 defsubr (&Sarrayp);
2984 defsubr (&Ssequencep);
2985 defsubr (&Sbufferp);
2986 defsubr (&Smarkerp);
2987 defsubr (&Ssubrp);
2988 defsubr (&Sbyte_code_function_p);
2989 defsubr (&Schar_or_string_p);
2990 defsubr (&Scar);
2991 defsubr (&Scdr);
2992 defsubr (&Scar_safe);
2993 defsubr (&Scdr_safe);
2994 defsubr (&Ssetcar);
2995 defsubr (&Ssetcdr);
2996 defsubr (&Ssymbol_function);
2997 defsubr (&Sindirect_function);
2998 defsubr (&Ssymbol_plist);
2999 defsubr (&Ssymbol_name);
3000 defsubr (&Smakunbound);
3001 defsubr (&Sfmakunbound);
3002 defsubr (&Sboundp);
3003 defsubr (&Sfboundp);
3004 defsubr (&Sfset);
3005 defsubr (&Sdefalias);
3006 defsubr (&Ssetplist);
3007 defsubr (&Ssymbol_value);
3008 defsubr (&Sset);
3009 defsubr (&Sdefault_boundp);
3010 defsubr (&Sdefault_value);
3011 defsubr (&Sset_default);
3012 defsubr (&Ssetq_default);
3013 defsubr (&Smake_variable_buffer_local);
3014 defsubr (&Smake_local_variable);
3015 defsubr (&Skill_local_variable);
3016 defsubr (&Smake_variable_frame_local);
3017 defsubr (&Slocal_variable_p);
3018 defsubr (&Slocal_variable_if_set_p);
3019 defsubr (&Saref);
3020 defsubr (&Saset);
3021 defsubr (&Snumber_to_string);
3022 defsubr (&Sstring_to_number);
3023 defsubr (&Seqlsign);
3024 defsubr (&Slss);
3025 defsubr (&Sgtr);
3026 defsubr (&Sleq);
3027 defsubr (&Sgeq);
3028 defsubr (&Sneq);
3029 defsubr (&Szerop);
3030 defsubr (&Splus);
3031 defsubr (&Sminus);
3032 defsubr (&Stimes);
3033 defsubr (&Squo);
3034 defsubr (&Srem);
3035 defsubr (&Smod);
3036 defsubr (&Smax);
3037 defsubr (&Smin);
3038 defsubr (&Slogand);
3039 defsubr (&Slogior);
3040 defsubr (&Slogxor);
3041 defsubr (&Slsh);
3042 defsubr (&Sash);
3043 defsubr (&Sadd1);
3044 defsubr (&Ssub1);
3045 defsubr (&Slognot);
3046 defsubr (&Ssubr_arity);
3048 XSYMBOL (Qwholenump)->function = XSYMBOL (Qnatnump)->function;
3051 SIGTYPE
3052 arith_error (signo)
3053 int signo;
3055 #if defined(USG) && !defined(POSIX_SIGNALS)
3056 /* USG systems forget handlers when they are used;
3057 must reestablish each time */
3058 signal (signo, arith_error);
3059 #endif /* USG */
3060 #ifdef VMS
3061 /* VMS systems are like USG. */
3062 signal (signo, arith_error);
3063 #endif /* VMS */
3064 #ifdef BSD4_1
3065 sigrelse (SIGFPE);
3066 #else /* not BSD4_1 */
3067 sigsetmask (SIGEMPTYMASK);
3068 #endif /* not BSD4_1 */
3070 Fsignal (Qarith_error, Qnil);
3073 void
3074 init_data ()
3076 /* Don't do this if just dumping out.
3077 We don't want to call `signal' in this case
3078 so that we don't have trouble with dumping
3079 signal-delivering routines in an inconsistent state. */
3080 #ifndef CANNOT_DUMP
3081 if (!initialized)
3082 return;
3083 #endif /* CANNOT_DUMP */
3084 signal (SIGFPE, arith_error);
3086 #ifdef uts
3087 signal (SIGEMT, arith_error);
3088 #endif /* uts */