1 /* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2 Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2011
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
27 #include "character.h"
31 #include "syssignal.h"
32 #include "termhooks.h" /* For FRAME_KBOARD reference in y-or-n-p. */
39 /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
40 #ifndef IEEE_FLOATING_POINT
41 #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
42 && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
43 #define IEEE_FLOATING_POINT 1
45 #define IEEE_FLOATING_POINT 0
52 extern double atof (const char *);
55 Lisp_Object Qnil
, Qt
, Qquote
, Qlambda
, Qsubr
, Qunbound
;
56 Lisp_Object Qerror_conditions
, Qerror_message
, Qtop_level
;
57 Lisp_Object Qerror
, Qquit
, Qwrong_type_argument
, Qargs_out_of_range
;
58 Lisp_Object Qvoid_variable
, Qvoid_function
, Qcyclic_function_indirection
;
59 Lisp_Object Qcyclic_variable_indirection
, Qcircular_list
;
60 Lisp_Object Qsetting_constant
, Qinvalid_read_syntax
;
61 Lisp_Object Qinvalid_function
, Qwrong_number_of_arguments
, Qno_catch
;
62 Lisp_Object Qend_of_file
, Qarith_error
, Qmark_inactive
;
63 Lisp_Object Qbeginning_of_buffer
, Qend_of_buffer
, Qbuffer_read_only
;
64 Lisp_Object Qtext_read_only
;
66 Lisp_Object Qintegerp
, Qnatnump
, Qwholenump
, Qsymbolp
, Qlistp
, Qconsp
;
67 Lisp_Object Qstringp
, Qarrayp
, Qsequencep
, Qbufferp
;
68 Lisp_Object Qchar_or_string_p
, Qmarkerp
, Qinteger_or_marker_p
, Qvectorp
;
69 Lisp_Object Qbuffer_or_string_p
, Qkeywordp
;
70 Lisp_Object Qboundp
, Qfboundp
;
71 Lisp_Object Qchar_table_p
, Qvector_or_char_table_p
;
74 Lisp_Object Qad_advice_info
, Qad_activate_internal
;
76 Lisp_Object Qrange_error
, Qdomain_error
, Qsingularity_error
;
77 Lisp_Object Qoverflow_error
, Qunderflow_error
;
80 Lisp_Object Qnumberp
, Qnumber_or_marker_p
;
83 static Lisp_Object Qsymbol
, Qstring
, Qcons
, Qmarker
, Qoverlay
;
85 static Lisp_Object Qfloat
, Qwindow_configuration
;
87 static Lisp_Object Qcompiled_function
, Qbuffer
, Qframe
, Qvector
;
88 static Lisp_Object Qchar_table
, Qbool_vector
, Qhash_table
;
89 static Lisp_Object Qsubrp
, Qmany
, Qunevalled
;
90 Lisp_Object Qfont_spec
, Qfont_entity
, Qfont_object
;
92 Lisp_Object Qinteractive_form
;
94 static void swap_in_symval_forwarding (struct Lisp_Symbol
*, struct Lisp_Buffer_Local_Value
*);
98 circular_list_error (Lisp_Object list
)
100 xsignal (Qcircular_list
, list
);
105 wrong_type_argument (register Lisp_Object predicate
, register Lisp_Object value
)
107 /* If VALUE is not even a valid Lisp object, we'd want to abort here
108 where we can get a backtrace showing where it came from. We used
109 to try and do that by checking the tagbits, but nowadays all
110 tagbits are potentially valid. */
111 /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
114 xsignal2 (Qwrong_type_argument
, predicate
, value
);
118 pure_write_error (void)
120 error ("Attempt to modify read-only object");
124 args_out_of_range (Lisp_Object a1
, Lisp_Object a2
)
126 xsignal2 (Qargs_out_of_range
, a1
, a2
);
130 args_out_of_range_3 (Lisp_Object a1
, Lisp_Object a2
, Lisp_Object a3
)
132 xsignal3 (Qargs_out_of_range
, a1
, a2
, a3
);
136 /* Data type predicates */
138 DEFUN ("eq", Feq
, Seq
, 2, 2, 0,
139 doc
: /* Return t if the two args are the same Lisp object. */)
140 (Lisp_Object obj1
, Lisp_Object obj2
)
147 DEFUN ("null", Fnull
, Snull
, 1, 1, 0,
148 doc
: /* Return t if OBJECT is nil. */)
156 DEFUN ("type-of", Ftype_of
, Stype_of
, 1, 1, 0,
157 doc
: /* Return a symbol representing the type of OBJECT.
158 The symbol returned names the object's basic type;
159 for example, (type-of 1) returns `integer'. */)
162 switch (XTYPE (object
))
177 switch (XMISCTYPE (object
))
179 case Lisp_Misc_Marker
:
181 case Lisp_Misc_Overlay
:
183 case Lisp_Misc_Float
:
188 case Lisp_Vectorlike
:
189 if (WINDOW_CONFIGURATIONP (object
))
190 return Qwindow_configuration
;
191 if (PROCESSP (object
))
193 if (WINDOWP (object
))
197 if (COMPILEDP (object
))
198 return Qcompiled_function
;
199 if (BUFFERP (object
))
201 if (CHAR_TABLE_P (object
))
203 if (BOOL_VECTOR_P (object
))
207 if (HASH_TABLE_P (object
))
209 if (FONT_SPEC_P (object
))
211 if (FONT_ENTITY_P (object
))
213 if (FONT_OBJECT_P (object
))
225 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
226 doc
: /* Return t if OBJECT is a cons cell. */)
234 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
235 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
243 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
244 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
245 Otherwise, return nil. */)
248 if (CONSP (object
) || NILP (object
))
253 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
254 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
257 if (CONSP (object
) || NILP (object
))
262 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
263 doc
: /* Return t if OBJECT is a symbol. */)
266 if (SYMBOLP (object
))
271 /* Define this in C to avoid unnecessarily consing up the symbol
273 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
274 doc
: /* Return t if OBJECT is a keyword.
275 This means that it is a symbol with a print name beginning with `:'
276 interned in the initial obarray. */)
280 && SREF (SYMBOL_NAME (object
), 0) == ':'
281 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
286 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
287 doc
: /* Return t if OBJECT is a vector. */)
290 if (VECTORP (object
))
295 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
296 doc
: /* Return t if OBJECT is a string. */)
299 if (STRINGP (object
))
304 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
306 doc
: /* Return t if OBJECT is a multibyte string. */)
309 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
314 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
315 doc
: /* Return t if OBJECT is a char-table. */)
318 if (CHAR_TABLE_P (object
))
323 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
324 Svector_or_char_table_p
, 1, 1, 0,
325 doc
: /* Return t if OBJECT is a char-table or vector. */)
328 if (VECTORP (object
) || CHAR_TABLE_P (object
))
333 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
334 doc
: /* Return t if OBJECT is a bool-vector. */)
337 if (BOOL_VECTOR_P (object
))
342 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
343 doc
: /* Return t if OBJECT is an array (string or vector). */)
351 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
352 doc
: /* Return t if OBJECT is a sequence (list or array). */)
353 (register Lisp_Object object
)
355 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
360 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
361 doc
: /* Return t if OBJECT is an editor buffer. */)
364 if (BUFFERP (object
))
369 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
370 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
373 if (MARKERP (object
))
378 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
379 doc
: /* Return t if OBJECT is a built-in function. */)
387 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
389 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
392 if (COMPILEDP (object
))
397 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
398 doc
: /* Return t if OBJECT is a character or a string. */)
399 (register Lisp_Object object
)
401 if (CHARACTERP (object
) || STRINGP (object
))
406 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
407 doc
: /* Return t if OBJECT is an integer. */)
410 if (INTEGERP (object
))
415 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
416 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
417 (register Lisp_Object object
)
419 if (MARKERP (object
) || INTEGERP (object
))
424 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
425 doc
: /* Return t if OBJECT is a nonnegative integer. */)
428 if (NATNUMP (object
))
433 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
434 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
437 if (NUMBERP (object
))
443 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
444 Snumber_or_marker_p
, 1, 1, 0,
445 doc
: /* Return t if OBJECT is a number or a marker. */)
448 if (NUMBERP (object
) || MARKERP (object
))
453 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
454 doc
: /* Return t if OBJECT is a floating point number. */)
463 /* Extract and set components of lists */
465 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
466 doc
: /* Return the car of LIST. If arg is nil, return nil.
467 Error if arg is not nil and not a cons cell. See also `car-safe'.
469 See Info node `(elisp)Cons Cells' for a discussion of related basic
470 Lisp concepts such as car, cdr, cons cell and list. */)
471 (register Lisp_Object list
)
476 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
477 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
480 return CAR_SAFE (object
);
483 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
484 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
485 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
487 See Info node `(elisp)Cons Cells' for a discussion of related basic
488 Lisp concepts such as cdr, car, cons cell and list. */)
489 (register Lisp_Object list
)
494 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
495 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
498 return CDR_SAFE (object
);
501 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
502 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
503 (register Lisp_Object cell
, Lisp_Object newcar
)
507 XSETCAR (cell
, newcar
);
511 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
512 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
513 (register Lisp_Object cell
, Lisp_Object newcdr
)
517 XSETCDR (cell
, newcdr
);
521 /* Extract and set components of symbols */
523 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
524 doc
: /* Return t if SYMBOL's value is not void. */)
525 (register Lisp_Object symbol
)
527 Lisp_Object valcontents
;
528 struct Lisp_Symbol
*sym
;
529 CHECK_SYMBOL (symbol
);
530 sym
= XSYMBOL (symbol
);
533 switch (sym
->redirect
)
535 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
536 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
537 case SYMBOL_LOCALIZED
:
539 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
541 /* In set_internal, we un-forward vars when their value is
546 swap_in_symval_forwarding (sym
, blv
);
547 valcontents
= BLV_VALUE (blv
);
551 case SYMBOL_FORWARDED
:
552 /* In set_internal, we un-forward vars when their value is
558 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
561 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
562 doc
: /* Return t if SYMBOL's function definition is not void. */)
563 (register Lisp_Object symbol
)
565 CHECK_SYMBOL (symbol
);
566 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
569 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
570 doc
: /* Make SYMBOL's value be void.
572 (register Lisp_Object symbol
)
574 CHECK_SYMBOL (symbol
);
575 if (SYMBOL_CONSTANT_P (symbol
))
576 xsignal1 (Qsetting_constant
, symbol
);
577 Fset (symbol
, Qunbound
);
581 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
582 doc
: /* Make SYMBOL's function definition be void.
584 (register Lisp_Object symbol
)
586 CHECK_SYMBOL (symbol
);
587 if (NILP (symbol
) || EQ (symbol
, Qt
))
588 xsignal1 (Qsetting_constant
, symbol
);
589 XSYMBOL (symbol
)->function
= Qunbound
;
593 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
594 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
595 (register Lisp_Object symbol
)
597 CHECK_SYMBOL (symbol
);
598 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
599 return XSYMBOL (symbol
)->function
;
600 xsignal1 (Qvoid_function
, symbol
);
603 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
604 doc
: /* Return SYMBOL's property list. */)
605 (register Lisp_Object symbol
)
607 CHECK_SYMBOL (symbol
);
608 return XSYMBOL (symbol
)->plist
;
611 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
612 doc
: /* Return SYMBOL's name, a string. */)
613 (register Lisp_Object symbol
)
615 register Lisp_Object name
;
617 CHECK_SYMBOL (symbol
);
618 name
= SYMBOL_NAME (symbol
);
622 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
623 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
624 (register Lisp_Object symbol
, Lisp_Object definition
)
626 register Lisp_Object function
;
628 CHECK_SYMBOL (symbol
);
629 if (NILP (symbol
) || EQ (symbol
, Qt
))
630 xsignal1 (Qsetting_constant
, symbol
);
632 function
= XSYMBOL (symbol
)->function
;
634 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
635 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
637 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
638 Fput (symbol
, Qautoload
, XCDR (function
));
640 XSYMBOL (symbol
)->function
= definition
;
641 /* Handle automatic advice activation */
642 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
644 call2 (Qad_activate_internal
, symbol
, Qnil
);
645 definition
= XSYMBOL (symbol
)->function
;
650 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
651 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
652 Associates the function with the current load file, if any.
653 The optional third argument DOCSTRING specifies the documentation string
654 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
655 determined by DEFINITION. */)
656 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
658 CHECK_SYMBOL (symbol
);
659 if (CONSP (XSYMBOL (symbol
)->function
)
660 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
661 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
662 definition
= Ffset (symbol
, definition
);
663 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
664 if (!NILP (docstring
))
665 Fput (symbol
, Qfunction_documentation
, docstring
);
669 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
670 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
671 (register Lisp_Object symbol
, Lisp_Object newplist
)
673 CHECK_SYMBOL (symbol
);
674 XSYMBOL (symbol
)->plist
= newplist
;
678 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
679 doc
: /* Return minimum and maximum number of args allowed for SUBR.
680 SUBR must be a built-in function.
681 The returned value is a pair (MIN . MAX). MIN is the minimum number
682 of args. MAX is the maximum number or the symbol `many', for a
683 function with `&rest' args, or `unevalled' for a special form. */)
686 short minargs
, maxargs
;
688 minargs
= XSUBR (subr
)->min_args
;
689 maxargs
= XSUBR (subr
)->max_args
;
691 return Fcons (make_number (minargs
), Qmany
);
692 else if (maxargs
== UNEVALLED
)
693 return Fcons (make_number (minargs
), Qunevalled
);
695 return Fcons (make_number (minargs
), make_number (maxargs
));
698 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
699 doc
: /* Return name of subroutine SUBR.
700 SUBR must be a built-in function. */)
705 name
= XSUBR (subr
)->symbol_name
;
706 return make_string (name
, strlen (name
));
709 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
710 doc
: /* Return the interactive form of CMD or nil if none.
711 If CMD is not a command, the return value is nil.
712 Value, if non-nil, is a list \(interactive SPEC). */)
715 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
717 if (NILP (fun
) || EQ (fun
, Qunbound
))
720 /* Use an `interactive-form' property if present, analogous to the
721 function-documentation property. */
723 while (SYMBOLP (fun
))
725 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
729 fun
= Fsymbol_function (fun
);
734 const char *spec
= XSUBR (fun
)->intspec
;
736 return list2 (Qinteractive
,
737 (*spec
!= '(') ? build_string (spec
) :
738 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
740 else if (COMPILEDP (fun
))
742 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
743 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
745 else if (CONSP (fun
))
747 Lisp_Object funcar
= XCAR (fun
);
748 if (EQ (funcar
, Qclosure
))
749 return Fassq (Qinteractive
, Fcdr (Fcdr (XCDR (fun
))));
750 else if (EQ (funcar
, Qlambda
))
751 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
752 else if (EQ (funcar
, Qautoload
))
756 do_autoload (fun
, cmd
);
758 return Finteractive_form (cmd
);
765 /***********************************************************************
766 Getting and Setting Values of Symbols
767 ***********************************************************************/
769 /* Return the symbol holding SYMBOL's value. Signal
770 `cyclic-variable-indirection' if SYMBOL's chain of variable
771 indirections contains a loop. */
774 indirect_variable (struct Lisp_Symbol
*symbol
)
776 struct Lisp_Symbol
*tortoise
, *hare
;
778 hare
= tortoise
= symbol
;
780 while (hare
->redirect
== SYMBOL_VARALIAS
)
782 hare
= SYMBOL_ALIAS (hare
);
783 if (hare
->redirect
!= SYMBOL_VARALIAS
)
786 hare
= SYMBOL_ALIAS (hare
);
787 tortoise
= SYMBOL_ALIAS (tortoise
);
789 if (hare
== tortoise
)
792 XSETSYMBOL (tem
, symbol
);
793 xsignal1 (Qcyclic_variable_indirection
, tem
);
801 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
802 doc
: /* Return the variable at the end of OBJECT's variable chain.
803 If OBJECT is a symbol, follow all variable indirections and return the final
804 variable. If OBJECT is not a symbol, just return it.
805 Signal a cyclic-variable-indirection error if there is a loop in the
806 variable chain of symbols. */)
809 if (SYMBOLP (object
))
810 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
815 /* Given the raw contents of a symbol value cell,
816 return the Lisp value of the symbol.
817 This does not handle buffer-local variables; use
818 swap_in_symval_forwarding for that. */
820 #define do_blv_forwarding(blv) \
821 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
824 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
826 register Lisp_Object val
;
827 switch (XFWDTYPE (valcontents
))
830 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
834 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
837 return *XOBJFWD (valcontents
)->objvar
;
839 case Lisp_Fwd_Buffer_Obj
:
840 return PER_BUFFER_VALUE (current_buffer
,
841 XBUFFER_OBJFWD (valcontents
)->offset
);
843 case Lisp_Fwd_Kboard_Obj
:
844 /* We used to simply use current_kboard here, but from Lisp
845 code, it's value is often unexpected. It seems nicer to
846 allow constructions like this to work as intuitively expected:
848 (with-selected-frame frame
849 (define-key local-function-map "\eOP" [f1]))
851 On the other hand, this affects the semantics of
852 last-command and real-last-command, and people may rely on
853 that. I took a quick look at the Lisp codebase, and I
854 don't think anything will break. --lorentey */
855 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
856 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
861 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
862 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
863 buffer-independent contents of the value cell: forwarded just one
864 step past the buffer-localness.
866 BUF non-zero means set the value in buffer BUF instead of the
867 current buffer. This only plays a role for per-buffer variables. */
869 #define store_blv_forwarding(blv, newval, buf) \
871 if ((blv)->forwarded) \
872 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
874 SET_BLV_VALUE (blv, newval); \
878 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
880 switch (XFWDTYPE (valcontents
))
883 CHECK_NUMBER (newval
);
884 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
888 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
892 *XOBJFWD (valcontents
)->objvar
= newval
;
894 /* If this variable is a default for something stored
895 in the buffer itself, such as default-fill-column,
896 find the buffers that don't have local values for it
898 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
899 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
901 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
902 - (char *) &buffer_defaults
);
903 int idx
= PER_BUFFER_IDX (offset
);
910 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
915 buf
= Fcdr (XCAR (tail
));
916 if (!BUFFERP (buf
)) continue;
919 if (! PER_BUFFER_VALUE_P (b
, idx
))
920 PER_BUFFER_VALUE (b
, offset
) = newval
;
925 case Lisp_Fwd_Buffer_Obj
:
927 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
928 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
930 if (!(NILP (type
) || NILP (newval
)
931 || (XINT (type
) == LISP_INT_TAG
933 : XTYPE (newval
) == XINT (type
))))
934 buffer_slot_type_mismatch (newval
, XINT (type
));
937 buf
= current_buffer
;
938 PER_BUFFER_VALUE (buf
, offset
) = newval
;
942 case Lisp_Fwd_Kboard_Obj
:
944 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
945 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
946 *(Lisp_Object
*) p
= newval
;
951 abort (); /* goto def; */
955 /* Set up SYMBOL to refer to its global binding.
956 This makes it safe to alter the status of other bindings. */
959 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
961 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
963 /* Unload the previously loaded binding. */
965 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
967 /* Select the global binding in the symbol. */
968 blv
->valcell
= blv
->defcell
;
970 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
972 /* Indicate that the global binding is set up now. */
974 SET_BLV_FOUND (blv
, 0);
977 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
978 VALCONTENTS is the contents of its value cell,
979 which points to a struct Lisp_Buffer_Local_Value.
981 Return the value forwarded one step past the buffer-local stage.
982 This could be another forwarding pointer. */
985 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
987 register Lisp_Object tem1
;
989 eassert (blv
== SYMBOL_BLV (symbol
));
995 ? !EQ (selected_frame
, tem1
)
996 : current_buffer
!= XBUFFER (tem1
)))
999 /* Unload the previously loaded binding. */
1000 tem1
= blv
->valcell
;
1002 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1003 /* Choose the new binding. */
1006 XSETSYMBOL (var
, symbol
);
1007 if (blv
->frame_local
)
1009 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1010 blv
->where
= selected_frame
;
1014 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1015 XSETBUFFER (blv
->where
, current_buffer
);
1018 if (!(blv
->found
= !NILP (tem1
)))
1019 tem1
= blv
->defcell
;
1021 /* Load the new binding. */
1022 blv
->valcell
= tem1
;
1024 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1028 /* Find the value of a symbol, returning Qunbound if it's not bound.
1029 This is helpful for code which just wants to get a variable's value
1030 if it has one, without signaling an error.
1031 Note that it must not be possible to quit
1032 within this function. Great care is required for this. */
1035 find_symbol_value (Lisp_Object symbol
)
1037 struct Lisp_Symbol
*sym
;
1039 CHECK_SYMBOL (symbol
);
1040 sym
= XSYMBOL (symbol
);
1043 switch (sym
->redirect
)
1045 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1046 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1047 case SYMBOL_LOCALIZED
:
1049 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1050 swap_in_symval_forwarding (sym
, blv
);
1051 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1054 case SYMBOL_FORWARDED
:
1055 return do_symval_forwarding (SYMBOL_FWD (sym
));
1060 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1061 doc
: /* Return SYMBOL's value. Error if that is void. */)
1062 (Lisp_Object symbol
)
1066 val
= find_symbol_value (symbol
);
1067 if (!EQ (val
, Qunbound
))
1070 xsignal1 (Qvoid_variable
, symbol
);
1073 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1074 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1075 (register Lisp_Object symbol
, Lisp_Object newval
)
1077 set_internal (symbol
, newval
, Qnil
, 0);
1081 /* Return 1 if SYMBOL currently has a let-binding
1082 which was made in the buffer that is now current. */
1085 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1087 struct specbinding
*p
;
1089 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1091 && CONSP (p
->symbol
))
1093 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1094 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1095 if (symbol
== let_bound_symbol
1096 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1100 return p
>= specpdl
;
1104 let_shadows_global_binding_p (Lisp_Object symbol
)
1106 struct specbinding
*p
;
1108 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1109 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1112 return p
>= specpdl
;
1115 /* Store the value NEWVAL into SYMBOL.
1116 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1117 (nil stands for the current buffer/frame).
1119 If BINDFLAG is zero, then if this symbol is supposed to become
1120 local in every buffer where it is set, then we make it local.
1121 If BINDFLAG is nonzero, we don't do that. */
1124 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1126 int voide
= EQ (newval
, Qunbound
);
1127 struct Lisp_Symbol
*sym
;
1130 /* If restoring in a dead buffer, do nothing. */
1131 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1134 CHECK_SYMBOL (symbol
);
1135 if (SYMBOL_CONSTANT_P (symbol
))
1137 if (NILP (Fkeywordp (symbol
))
1138 || !EQ (newval
, Fsymbol_value (symbol
)))
1139 xsignal1 (Qsetting_constant
, symbol
);
1141 /* Allow setting keywords to their own value. */
1145 sym
= XSYMBOL (symbol
);
1148 switch (sym
->redirect
)
1150 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1151 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1152 case SYMBOL_LOCALIZED
:
1154 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1157 if (blv
->frame_local
)
1158 where
= selected_frame
;
1160 XSETBUFFER (where
, current_buffer
);
1162 /* If the current buffer is not the buffer whose binding is
1163 loaded, or if there may be frame-local bindings and the frame
1164 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1165 the default binding is loaded, the loaded binding may be the
1167 if (!EQ (blv
->where
, where
)
1168 /* Also unload a global binding (if the var is local_if_set). */
1169 || (EQ (blv
->valcell
, blv
->defcell
)))
1171 /* The currently loaded binding is not necessarily valid.
1172 We need to unload it, and choose a new binding. */
1174 /* Write out `realvalue' to the old loaded binding. */
1176 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1178 /* Find the new binding. */
1179 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1180 tem1
= Fassq (symbol
,
1182 ? XFRAME (where
)->param_alist
1183 : BVAR (XBUFFER (where
), local_var_alist
)));
1189 /* This buffer still sees the default value. */
1191 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1192 or if this is `let' rather than `set',
1193 make CURRENT-ALIST-ELEMENT point to itself,
1194 indicating that we're seeing the default value.
1195 Likewise if the variable has been let-bound
1196 in the current buffer. */
1197 if (bindflag
|| !blv
->local_if_set
1198 || let_shadows_buffer_binding_p (sym
))
1201 tem1
= blv
->defcell
;
1203 /* If it's a local_if_set, being set not bound,
1204 and we're not within a let that was made for this buffer,
1205 create a new buffer-local binding for the variable.
1206 That means, give this buffer a new assoc for a local value
1207 and load that binding. */
1210 /* local_if_set is only supported for buffer-local
1211 bindings, not for frame-local bindings. */
1212 eassert (!blv
->frame_local
);
1213 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1214 BVAR (XBUFFER (where
), local_var_alist
)
1215 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1219 /* Record which binding is now loaded. */
1220 blv
->valcell
= tem1
;
1223 /* Store the new value in the cons cell. */
1224 SET_BLV_VALUE (blv
, newval
);
1229 /* If storing void (making the symbol void), forward only through
1230 buffer-local indicator, not through Lisp_Objfwd, etc. */
1233 store_symval_forwarding (blv
->fwd
, newval
,
1235 ? XBUFFER (where
) : current_buffer
);
1239 case SYMBOL_FORWARDED
:
1242 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1243 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1244 if (BUFFER_OBJFWDP (innercontents
))
1246 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1247 int idx
= PER_BUFFER_IDX (offset
);
1250 && !let_shadows_buffer_binding_p (sym
))
1251 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1255 { /* If storing void (making the symbol void), forward only through
1256 buffer-local indicator, not through Lisp_Objfwd, etc. */
1257 sym
->redirect
= SYMBOL_PLAINVAL
;
1258 SET_SYMBOL_VAL (sym
, newval
);
1261 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1269 /* Access or set a buffer-local symbol's default value. */
1271 /* Return the default value of SYMBOL, but don't check for voidness.
1272 Return Qunbound if it is void. */
1275 default_value (Lisp_Object symbol
)
1277 struct Lisp_Symbol
*sym
;
1279 CHECK_SYMBOL (symbol
);
1280 sym
= XSYMBOL (symbol
);
1283 switch (sym
->redirect
)
1285 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1286 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1287 case SYMBOL_LOCALIZED
:
1289 /* If var is set up for a buffer that lacks a local value for it,
1290 the current value is nominally the default value.
1291 But the `realvalue' slot may be more up to date, since
1292 ordinary setq stores just that slot. So use that. */
1293 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1294 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1295 return do_symval_forwarding (blv
->fwd
);
1297 return XCDR (blv
->defcell
);
1299 case SYMBOL_FORWARDED
:
1301 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1303 /* For a built-in buffer-local variable, get the default value
1304 rather than letting do_symval_forwarding get the current value. */
1305 if (BUFFER_OBJFWDP (valcontents
))
1307 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1308 if (PER_BUFFER_IDX (offset
) != 0)
1309 return PER_BUFFER_DEFAULT (offset
);
1312 /* For other variables, get the current value. */
1313 return do_symval_forwarding (valcontents
);
1319 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1320 doc
: /* Return t if SYMBOL has a non-void default value.
1321 This is the value that is seen in buffers that do not have their own values
1322 for this variable. */)
1323 (Lisp_Object symbol
)
1325 register Lisp_Object value
;
1327 value
= default_value (symbol
);
1328 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1331 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1332 doc
: /* Return SYMBOL's default value.
1333 This is the value that is seen in buffers that do not have their own values
1334 for this variable. The default value is meaningful for variables with
1335 local bindings in certain buffers. */)
1336 (Lisp_Object symbol
)
1338 register Lisp_Object value
;
1340 value
= default_value (symbol
);
1341 if (!EQ (value
, Qunbound
))
1344 xsignal1 (Qvoid_variable
, symbol
);
1347 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1348 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1349 The default value is seen in buffers that do not have their own values
1350 for this variable. */)
1351 (Lisp_Object symbol
, Lisp_Object value
)
1353 struct Lisp_Symbol
*sym
;
1355 CHECK_SYMBOL (symbol
);
1356 if (SYMBOL_CONSTANT_P (symbol
))
1358 if (NILP (Fkeywordp (symbol
))
1359 || !EQ (value
, Fdefault_value (symbol
)))
1360 xsignal1 (Qsetting_constant
, symbol
);
1362 /* Allow setting keywords to their own value. */
1365 sym
= XSYMBOL (symbol
);
1368 switch (sym
->redirect
)
1370 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1371 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1372 case SYMBOL_LOCALIZED
:
1374 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1376 /* Store new value into the DEFAULT-VALUE slot. */
1377 XSETCDR (blv
->defcell
, value
);
1379 /* If the default binding is now loaded, set the REALVALUE slot too. */
1380 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1381 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1384 case SYMBOL_FORWARDED
:
1386 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1388 /* Handle variables like case-fold-search that have special slots
1390 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1391 if (BUFFER_OBJFWDP (valcontents
))
1393 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1394 int idx
= PER_BUFFER_IDX (offset
);
1396 PER_BUFFER_DEFAULT (offset
) = value
;
1398 /* If this variable is not always local in all buffers,
1399 set it in the buffers that don't nominally have a local value. */
1404 for (b
= all_buffers
; b
; b
= b
->next
)
1405 if (!PER_BUFFER_VALUE_P (b
, idx
))
1406 PER_BUFFER_VALUE (b
, offset
) = value
;
1411 return Fset (symbol
, value
);
1417 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1418 doc
: /* Set the default value of variable VAR to VALUE.
1419 VAR, the variable name, is literal (not evaluated);
1420 VALUE is an expression: it is evaluated and its value returned.
1421 The default value of a variable is seen in buffers
1422 that do not have their own values for the variable.
1424 More generally, you can use multiple variables and values, as in
1425 (setq-default VAR VALUE VAR VALUE...)
1426 This sets each VAR's default value to the corresponding VALUE.
1427 The VALUE for the Nth VAR can refer to the new default values
1429 usage: (setq-default [VAR VALUE]...) */)
1432 register Lisp_Object args_left
;
1433 register Lisp_Object val
, symbol
;
1434 struct gcpro gcpro1
;
1444 val
= eval_sub (Fcar (Fcdr (args_left
)));
1445 symbol
= XCAR (args_left
);
1446 Fset_default (symbol
, val
);
1447 args_left
= Fcdr (XCDR (args_left
));
1449 while (!NILP (args_left
));
1455 /* Lisp functions for creating and removing buffer-local variables. */
1460 union Lisp_Fwd
*fwd
;
1463 static struct Lisp_Buffer_Local_Value
*
1464 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1466 struct Lisp_Buffer_Local_Value
*blv
1467 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1471 XSETSYMBOL (symbol
, sym
);
1472 tem
= Fcons (symbol
, (forwarded
1473 ? do_symval_forwarding (valcontents
.fwd
)
1474 : valcontents
.value
));
1476 /* Buffer_Local_Values cannot have as realval a buffer-local
1477 or keyboard-local forwarding. */
1478 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1479 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1480 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1482 blv
->frame_local
= 0;
1483 blv
->local_if_set
= 0;
1486 SET_BLV_FOUND (blv
, 0);
1490 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1491 1, 1, "vMake Variable Buffer Local: ",
1492 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1493 At any time, the value for the current buffer is in effect,
1494 unless the variable has never been set in this buffer,
1495 in which case the default value is in effect.
1496 Note that binding the variable with `let', or setting it while
1497 a `let'-style binding made in this buffer is in effect,
1498 does not make the variable buffer-local. Return VARIABLE.
1500 In most cases it is better to use `make-local-variable',
1501 which makes a variable local in just one buffer.
1503 The function `default-value' gets the default value and `set-default' sets it. */)
1504 (register Lisp_Object variable
)
1506 struct Lisp_Symbol
*sym
;
1507 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1508 union Lisp_Val_Fwd valcontents
;
1511 CHECK_SYMBOL (variable
);
1512 sym
= XSYMBOL (variable
);
1515 switch (sym
->redirect
)
1517 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1518 case SYMBOL_PLAINVAL
:
1519 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1520 if (EQ (valcontents
.value
, Qunbound
))
1521 valcontents
.value
= Qnil
;
1523 case SYMBOL_LOCALIZED
:
1524 blv
= SYMBOL_BLV (sym
);
1525 if (blv
->frame_local
)
1526 error ("Symbol %s may not be buffer-local",
1527 SDATA (SYMBOL_NAME (variable
)));
1529 case SYMBOL_FORWARDED
:
1530 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1531 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1532 error ("Symbol %s may not be buffer-local",
1533 SDATA (SYMBOL_NAME (variable
)));
1534 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1541 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1545 blv
= make_blv (sym
, forwarded
, valcontents
);
1546 sym
->redirect
= SYMBOL_LOCALIZED
;
1547 SET_SYMBOL_BLV (sym
, blv
);
1550 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1551 if (let_shadows_global_binding_p (symbol
))
1552 message ("Making %s buffer-local while let-bound!",
1553 SDATA (SYMBOL_NAME (variable
)));
1557 blv
->local_if_set
= 1;
1561 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1562 1, 1, "vMake Local Variable: ",
1563 doc
: /* Make VARIABLE have a separate value in the current buffer.
1564 Other buffers will continue to share a common default value.
1565 \(The buffer-local value of VARIABLE starts out as the same value
1566 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1569 If the variable is already arranged to become local when set,
1570 this function causes a local value to exist for this buffer,
1571 just as setting the variable would do.
1573 This function returns VARIABLE, and therefore
1574 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1577 See also `make-variable-buffer-local'.
1579 Do not use `make-local-variable' to make a hook variable buffer-local.
1580 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1581 (register Lisp_Object variable
)
1583 register Lisp_Object tem
;
1585 union Lisp_Val_Fwd valcontents
;
1586 struct Lisp_Symbol
*sym
;
1587 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1589 CHECK_SYMBOL (variable
);
1590 sym
= XSYMBOL (variable
);
1593 switch (sym
->redirect
)
1595 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1596 case SYMBOL_PLAINVAL
:
1597 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1598 case SYMBOL_LOCALIZED
:
1599 blv
= SYMBOL_BLV (sym
);
1600 if (blv
->frame_local
)
1601 error ("Symbol %s may not be buffer-local",
1602 SDATA (SYMBOL_NAME (variable
)));
1604 case SYMBOL_FORWARDED
:
1605 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1606 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1607 error ("Symbol %s may not be buffer-local",
1608 SDATA (SYMBOL_NAME (variable
)));
1614 error ("Symbol %s may not be buffer-local",
1615 SDATA (SYMBOL_NAME (variable
)));
1617 if (blv
? blv
->local_if_set
1618 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1620 tem
= Fboundp (variable
);
1621 /* Make sure the symbol has a local value in this particular buffer,
1622 by setting it to the same value it already has. */
1623 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1628 blv
= make_blv (sym
, forwarded
, valcontents
);
1629 sym
->redirect
= SYMBOL_LOCALIZED
;
1630 SET_SYMBOL_BLV (sym
, blv
);
1633 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1634 if (let_shadows_global_binding_p (symbol
))
1635 message ("Making %s local to %s while let-bound!",
1636 SDATA (SYMBOL_NAME (variable
)),
1637 SDATA (BVAR (current_buffer
, name
)));
1641 /* Make sure this buffer has its own value of symbol. */
1642 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1643 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1646 if (let_shadows_buffer_binding_p (sym
))
1647 message ("Making %s buffer-local while locally let-bound!",
1648 SDATA (SYMBOL_NAME (variable
)));
1650 /* Swap out any local binding for some other buffer, and make
1651 sure the current value is permanently recorded, if it's the
1653 find_symbol_value (variable
);
1655 BVAR (current_buffer
, local_var_alist
)
1656 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1657 BVAR (current_buffer
, local_var_alist
));
1659 /* Make sure symbol does not think it is set up for this buffer;
1660 force it to look once again for this buffer's value. */
1661 if (current_buffer
== XBUFFER (blv
->where
))
1663 /* blv->valcell = blv->defcell;
1664 * SET_BLV_FOUND (blv, 0); */
1668 /* If the symbol forwards into a C variable, then load the binding
1669 for this buffer now. If C code modifies the variable before we
1670 load the binding in, then that new value will clobber the default
1671 binding the next time we unload it. */
1673 swap_in_symval_forwarding (sym
, blv
);
1678 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1679 1, 1, "vKill Local Variable: ",
1680 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1681 From now on the default value will apply in this buffer. Return VARIABLE. */)
1682 (register Lisp_Object variable
)
1684 register Lisp_Object tem
;
1685 struct Lisp_Buffer_Local_Value
*blv
;
1686 struct Lisp_Symbol
*sym
;
1688 CHECK_SYMBOL (variable
);
1689 sym
= XSYMBOL (variable
);
1692 switch (sym
->redirect
)
1694 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1695 case SYMBOL_PLAINVAL
: return variable
;
1696 case SYMBOL_FORWARDED
:
1698 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1699 if (BUFFER_OBJFWDP (valcontents
))
1701 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1702 int idx
= PER_BUFFER_IDX (offset
);
1706 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1707 PER_BUFFER_VALUE (current_buffer
, offset
)
1708 = PER_BUFFER_DEFAULT (offset
);
1713 case SYMBOL_LOCALIZED
:
1714 blv
= SYMBOL_BLV (sym
);
1715 if (blv
->frame_local
)
1721 /* Get rid of this buffer's alist element, if any. */
1722 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1723 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1725 BVAR (current_buffer
, local_var_alist
)
1726 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1728 /* If the symbol is set up with the current buffer's binding
1729 loaded, recompute its value. We have to do it now, or else
1730 forwarded objects won't work right. */
1732 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1733 if (EQ (buf
, blv
->where
))
1736 /* blv->valcell = blv->defcell;
1737 * SET_BLV_FOUND (blv, 0); */
1739 find_symbol_value (variable
);
1746 /* Lisp functions for creating and removing buffer-local variables. */
1748 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1749 when/if this is removed. */
1751 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1752 1, 1, "vMake Variable Frame Local: ",
1753 doc
: /* Enable VARIABLE to have frame-local bindings.
1754 This does not create any frame-local bindings for VARIABLE,
1755 it just makes them possible.
1757 A frame-local binding is actually a frame parameter value.
1758 If a frame F has a value for the frame parameter named VARIABLE,
1759 that also acts as a frame-local binding for VARIABLE in F--
1760 provided this function has been called to enable VARIABLE
1761 to have frame-local bindings at all.
1763 The only way to create a frame-local binding for VARIABLE in a frame
1764 is to set the VARIABLE frame parameter of that frame. See
1765 `modify-frame-parameters' for how to set frame parameters.
1767 Note that since Emacs 23.1, variables cannot be both buffer-local and
1768 frame-local any more (buffer-local bindings used to take precedence over
1769 frame-local bindings). */)
1770 (register Lisp_Object variable
)
1773 union Lisp_Val_Fwd valcontents
;
1774 struct Lisp_Symbol
*sym
;
1775 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1777 CHECK_SYMBOL (variable
);
1778 sym
= XSYMBOL (variable
);
1781 switch (sym
->redirect
)
1783 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1784 case SYMBOL_PLAINVAL
:
1785 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1786 if (EQ (valcontents
.value
, Qunbound
))
1787 valcontents
.value
= Qnil
;
1789 case SYMBOL_LOCALIZED
:
1790 if (SYMBOL_BLV (sym
)->frame_local
)
1793 error ("Symbol %s may not be frame-local",
1794 SDATA (SYMBOL_NAME (variable
)));
1795 case SYMBOL_FORWARDED
:
1796 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1797 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1798 error ("Symbol %s may not be frame-local",
1799 SDATA (SYMBOL_NAME (variable
)));
1805 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1807 blv
= make_blv (sym
, forwarded
, valcontents
);
1808 blv
->frame_local
= 1;
1809 sym
->redirect
= SYMBOL_LOCALIZED
;
1810 SET_SYMBOL_BLV (sym
, blv
);
1813 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1814 if (let_shadows_global_binding_p (symbol
))
1815 message ("Making %s frame-local while let-bound!",
1816 SDATA (SYMBOL_NAME (variable
)));
1821 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1823 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1824 BUFFER defaults to the current buffer. */)
1825 (register Lisp_Object variable
, Lisp_Object buffer
)
1827 register struct buffer
*buf
;
1828 struct Lisp_Symbol
*sym
;
1831 buf
= current_buffer
;
1834 CHECK_BUFFER (buffer
);
1835 buf
= XBUFFER (buffer
);
1838 CHECK_SYMBOL (variable
);
1839 sym
= XSYMBOL (variable
);
1842 switch (sym
->redirect
)
1844 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1845 case SYMBOL_PLAINVAL
: return Qnil
;
1846 case SYMBOL_LOCALIZED
:
1848 Lisp_Object tail
, elt
, tmp
;
1849 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1850 XSETBUFFER (tmp
, buf
);
1851 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1853 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1856 if (EQ (variable
, XCAR (elt
)))
1858 eassert (!blv
->frame_local
);
1859 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1863 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1866 case SYMBOL_FORWARDED
:
1868 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1869 if (BUFFER_OBJFWDP (valcontents
))
1871 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1872 int idx
= PER_BUFFER_IDX (offset
);
1873 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1882 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1884 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1885 More precisely, this means that setting the variable \(with `set' or`setq'),
1886 while it does not have a `let'-style binding that was made in BUFFER,
1887 will produce a buffer local binding. See Info node
1888 `(elisp)Creating Buffer-Local'.
1889 BUFFER defaults to the current buffer. */)
1890 (register Lisp_Object variable
, Lisp_Object buffer
)
1892 struct Lisp_Symbol
*sym
;
1894 CHECK_SYMBOL (variable
);
1895 sym
= XSYMBOL (variable
);
1898 switch (sym
->redirect
)
1900 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1901 case SYMBOL_PLAINVAL
: return Qnil
;
1902 case SYMBOL_LOCALIZED
:
1904 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1905 if (blv
->local_if_set
)
1907 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1908 return Flocal_variable_p (variable
, buffer
);
1910 case SYMBOL_FORWARDED
:
1911 /* All BUFFER_OBJFWD slots become local if they are set. */
1912 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1917 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1919 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1920 If the current binding is buffer-local, the value is the current buffer.
1921 If the current binding is frame-local, the value is the selected frame.
1922 If the current binding is global (the default), the value is nil. */)
1923 (register Lisp_Object variable
)
1925 struct Lisp_Symbol
*sym
;
1927 CHECK_SYMBOL (variable
);
1928 sym
= XSYMBOL (variable
);
1930 /* Make sure the current binding is actually swapped in. */
1931 find_symbol_value (variable
);
1934 switch (sym
->redirect
)
1936 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1937 case SYMBOL_PLAINVAL
: return Qnil
;
1938 case SYMBOL_FORWARDED
:
1940 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1941 if (KBOARD_OBJFWDP (valcontents
))
1942 return Fframe_terminal (Fselected_frame ());
1943 else if (!BUFFER_OBJFWDP (valcontents
))
1947 case SYMBOL_LOCALIZED
:
1948 /* For a local variable, record both the symbol and which
1949 buffer's or frame's value we are saving. */
1950 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1951 return Fcurrent_buffer ();
1952 else if (sym
->redirect
== SYMBOL_LOCALIZED
1953 && BLV_FOUND (SYMBOL_BLV (sym
)))
1954 return SYMBOL_BLV (sym
)->where
;
1961 /* This code is disabled now that we use the selected frame to return
1962 keyboard-local-values. */
1964 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1966 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1967 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1968 If SYMBOL is not a terminal-local variable, then return its normal
1969 value, like `symbol-value'.
1971 TERMINAL may be a terminal object, a frame, or nil (meaning the
1972 selected frame's terminal device). */)
1973 (Lisp_Object symbol
, Lisp_Object terminal
)
1976 struct terminal
*t
= get_terminal (terminal
, 1);
1977 push_kboard (t
->kboard
);
1978 result
= Fsymbol_value (symbol
);
1983 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1984 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1985 If VARIABLE is not a terminal-local variable, then set its normal
1986 binding, like `set'.
1988 TERMINAL may be a terminal object, a frame, or nil (meaning the
1989 selected frame's terminal device). */)
1990 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
1993 struct terminal
*t
= get_terminal (terminal
, 1);
1994 push_kboard (d
->kboard
);
1995 result
= Fset (symbol
, value
);
2001 /* Find the function at the end of a chain of symbol function indirections. */
2003 /* If OBJECT is a symbol, find the end of its function chain and
2004 return the value found there. If OBJECT is not a symbol, just
2005 return it. If there is a cycle in the function chain, signal a
2006 cyclic-function-indirection error.
2008 This is like Findirect_function, except that it doesn't signal an
2009 error if the chain ends up unbound. */
2011 indirect_function (register Lisp_Object object
)
2013 Lisp_Object tortoise
, hare
;
2015 hare
= tortoise
= object
;
2019 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2021 hare
= XSYMBOL (hare
)->function
;
2022 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2024 hare
= XSYMBOL (hare
)->function
;
2026 tortoise
= XSYMBOL (tortoise
)->function
;
2028 if (EQ (hare
, tortoise
))
2029 xsignal1 (Qcyclic_function_indirection
, object
);
2035 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2036 doc
: /* Return the function at the end of OBJECT's function chain.
2037 If OBJECT is not a symbol, just return it. Otherwise, follow all
2038 function indirections to find the final function binding and return it.
2039 If the final symbol in the chain is unbound, signal a void-function error.
2040 Optional arg NOERROR non-nil means to return nil instead of signalling.
2041 Signal a cyclic-function-indirection error if there is a loop in the
2042 function chain of symbols. */)
2043 (register Lisp_Object object
, Lisp_Object noerror
)
2047 /* Optimize for no indirection. */
2049 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2050 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2051 result
= indirect_function (result
);
2052 if (!EQ (result
, Qunbound
))
2056 xsignal1 (Qvoid_function
, object
);
2061 /* Extract and set vector and string elements */
2063 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2064 doc
: /* Return the element of ARRAY at index IDX.
2065 ARRAY may be a vector, a string, a char-table, a bool-vector,
2066 or a byte-code object. IDX starts at 0. */)
2067 (register Lisp_Object array
, Lisp_Object idx
)
2069 register EMACS_INT idxval
;
2072 idxval
= XINT (idx
);
2073 if (STRINGP (array
))
2076 EMACS_INT idxval_byte
;
2078 if (idxval
< 0 || idxval
>= SCHARS (array
))
2079 args_out_of_range (array
, idx
);
2080 if (! STRING_MULTIBYTE (array
))
2081 return make_number ((unsigned char) SREF (array
, idxval
));
2082 idxval_byte
= string_char_to_byte (array
, idxval
);
2084 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2085 return make_number (c
);
2087 else if (BOOL_VECTOR_P (array
))
2091 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2092 args_out_of_range (array
, idx
);
2094 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2095 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2097 else if (CHAR_TABLE_P (array
))
2099 CHECK_CHARACTER (idx
);
2100 return CHAR_TABLE_REF (array
, idxval
);
2105 if (VECTORP (array
))
2106 size
= XVECTOR (array
)->size
;
2107 else if (COMPILEDP (array
))
2108 size
= XVECTOR (array
)->size
& PSEUDOVECTOR_SIZE_MASK
;
2110 wrong_type_argument (Qarrayp
, array
);
2112 if (idxval
< 0 || idxval
>= size
)
2113 args_out_of_range (array
, idx
);
2114 return AREF (array
, idxval
);
2118 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2119 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2120 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2121 bool-vector. IDX starts at 0. */)
2122 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2124 register EMACS_INT idxval
;
2127 idxval
= XINT (idx
);
2128 CHECK_ARRAY (array
, Qarrayp
);
2129 CHECK_IMPURE (array
);
2131 if (VECTORP (array
))
2133 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2134 args_out_of_range (array
, idx
);
2135 XVECTOR (array
)->contents
[idxval
] = newelt
;
2137 else if (BOOL_VECTOR_P (array
))
2141 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2142 args_out_of_range (array
, idx
);
2144 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2146 if (! NILP (newelt
))
2147 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2149 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2150 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2152 else if (CHAR_TABLE_P (array
))
2154 CHECK_CHARACTER (idx
);
2155 CHAR_TABLE_SET (array
, idxval
, newelt
);
2157 else if (STRING_MULTIBYTE (array
))
2159 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2160 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2162 if (idxval
< 0 || idxval
>= SCHARS (array
))
2163 args_out_of_range (array
, idx
);
2164 CHECK_CHARACTER (newelt
);
2166 nbytes
= SBYTES (array
);
2168 idxval_byte
= string_char_to_byte (array
, idxval
);
2169 p1
= SDATA (array
) + idxval_byte
;
2170 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2171 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2172 if (prev_bytes
!= new_bytes
)
2174 /* We must relocate the string data. */
2175 EMACS_INT nchars
= SCHARS (array
);
2179 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2180 memcpy (str
, SDATA (array
), nbytes
);
2181 allocate_string_data (XSTRING (array
), nchars
,
2182 nbytes
+ new_bytes
- prev_bytes
);
2183 memcpy (SDATA (array
), str
, idxval_byte
);
2184 p1
= SDATA (array
) + idxval_byte
;
2185 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2186 nbytes
- (idxval_byte
+ prev_bytes
));
2188 clear_string_char_byte_cache ();
2195 if (idxval
< 0 || idxval
>= SCHARS (array
))
2196 args_out_of_range (array
, idx
);
2197 CHECK_NUMBER (newelt
);
2199 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2203 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2204 if (SREF (array
, i
) >= 0x80)
2205 args_out_of_range (array
, newelt
);
2206 /* ARRAY is an ASCII string. Convert it to a multibyte
2207 string, and try `aset' again. */
2208 STRING_SET_MULTIBYTE (array
);
2209 return Faset (array
, idx
, newelt
);
2211 SSET (array
, idxval
, XINT (newelt
));
2217 /* Arithmetic functions */
2219 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2222 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2224 double f1
= 0, f2
= 0;
2227 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2228 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2230 if (FLOATP (num1
) || FLOATP (num2
))
2233 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2234 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2240 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2245 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2250 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2255 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2260 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2265 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2274 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2275 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2276 (register Lisp_Object num1
, Lisp_Object num2
)
2278 return arithcompare (num1
, num2
, equal
);
2281 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2282 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2283 (register Lisp_Object num1
, Lisp_Object num2
)
2285 return arithcompare (num1
, num2
, less
);
2288 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2289 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2290 (register Lisp_Object num1
, Lisp_Object num2
)
2292 return arithcompare (num1
, num2
, grtr
);
2295 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2296 doc
: /* Return t if first arg is less than or equal to second arg.
2297 Both must be numbers or markers. */)
2298 (register Lisp_Object num1
, Lisp_Object num2
)
2300 return arithcompare (num1
, num2
, less_or_equal
);
2303 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2304 doc
: /* Return t if first arg is greater than or equal to second arg.
2305 Both must be numbers or markers. */)
2306 (register Lisp_Object num1
, Lisp_Object num2
)
2308 return arithcompare (num1
, num2
, grtr_or_equal
);
2311 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2312 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2313 (register Lisp_Object num1
, Lisp_Object num2
)
2315 return arithcompare (num1
, num2
, notequal
);
2318 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2319 doc
: /* Return t if NUMBER is zero. */)
2320 (register Lisp_Object number
)
2322 CHECK_NUMBER_OR_FLOAT (number
);
2324 if (FLOATP (number
))
2326 if (XFLOAT_DATA (number
) == 0.0)
2336 /* Convert between long values and pairs of Lisp integers.
2337 Note that long_to_cons returns a single Lisp integer
2338 when the value fits in one. */
2341 long_to_cons (long unsigned int i
)
2343 unsigned long top
= i
>> 16;
2344 unsigned int bot
= i
& 0xFFFF;
2346 return make_number (bot
);
2347 if (top
== (unsigned long)-1 >> 16)
2348 return Fcons (make_number (-1), make_number (bot
));
2349 return Fcons (make_number (top
), make_number (bot
));
2353 cons_to_long (Lisp_Object c
)
2355 Lisp_Object top
, bot
;
2362 return ((XINT (top
) << 16) | XINT (bot
));
2365 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2366 doc
: /* Return the decimal representation of NUMBER as a string.
2367 Uses a minus sign if negative.
2368 NUMBER may be an integer or a floating point number. */)
2369 (Lisp_Object number
)
2371 char buffer
[VALBITS
];
2373 CHECK_NUMBER_OR_FLOAT (number
);
2375 if (FLOATP (number
))
2377 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2379 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2380 return build_string (pigbuf
);
2383 if (sizeof (int) == sizeof (EMACS_INT
))
2384 sprintf (buffer
, "%d", (int) XINT (number
));
2385 else if (sizeof (long) == sizeof (EMACS_INT
))
2386 sprintf (buffer
, "%ld", (long) XINT (number
));
2389 return build_string (buffer
);
2393 digit_to_number (int character
, int base
)
2397 if (character
>= '0' && character
<= '9')
2398 digit
= character
- '0';
2399 else if (character
>= 'a' && character
<= 'z')
2400 digit
= character
- 'a' + 10;
2401 else if (character
>= 'A' && character
<= 'Z')
2402 digit
= character
- 'A' + 10;
2412 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2413 doc
: /* Parse STRING as a decimal number and return the number.
2414 This parses both integers and floating point numbers.
2415 It ignores leading spaces and tabs, and all trailing chars.
2417 If BASE, interpret STRING as a number in that base. If BASE isn't
2418 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2419 If the base used is not 10, STRING is always parsed as integer. */)
2420 (register Lisp_Object string
, Lisp_Object base
)
2427 CHECK_STRING (string
);
2433 CHECK_NUMBER (base
);
2435 if (b
< 2 || b
> 16)
2436 xsignal1 (Qargs_out_of_range
, base
);
2439 /* Skip any whitespace at the front of the number. Some versions of
2440 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2441 p
= SSDATA (string
);
2442 while (*p
== ' ' || *p
== '\t')
2453 if (isfloat_string (p
, 1) && b
== 10)
2454 val
= make_float (sign
* atof (p
));
2461 int digit
= digit_to_number (*p
++, b
);
2467 val
= make_fixnum_or_float (sign
* v
);
2487 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2488 int, Lisp_Object
*);
2490 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2492 register Lisp_Object val
;
2493 register int argnum
;
2494 register EMACS_INT accum
= 0;
2495 register EMACS_INT next
;
2497 switch (SWITCH_ENUM_CAST (code
))
2515 for (argnum
= 0; argnum
< nargs
; argnum
++)
2517 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2519 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2522 return float_arith_driver ((double) accum
, argnum
, code
,
2525 next
= XINT (args
[argnum
]);
2526 switch (SWITCH_ENUM_CAST (code
))
2532 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2543 xsignal0 (Qarith_error
);
2557 if (!argnum
|| next
> accum
)
2561 if (!argnum
|| next
< accum
)
2567 XSETINT (val
, accum
);
2572 #define isnan(x) ((x) != (x))
2575 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2577 register Lisp_Object val
;
2580 for (; argnum
< nargs
; argnum
++)
2582 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2583 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2587 next
= XFLOAT_DATA (val
);
2591 args
[argnum
] = val
; /* runs into a compiler bug. */
2592 next
= XINT (args
[argnum
]);
2594 switch (SWITCH_ENUM_CAST (code
))
2600 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2610 if (! IEEE_FLOATING_POINT
&& next
== 0)
2611 xsignal0 (Qarith_error
);
2618 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2620 if (!argnum
|| isnan (next
) || next
> accum
)
2624 if (!argnum
|| isnan (next
) || next
< accum
)
2630 return make_float (accum
);
2634 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2635 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2636 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2637 (int nargs
, Lisp_Object
*args
)
2639 return arith_driver (Aadd
, nargs
, args
);
2642 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2643 doc
: /* Negate number or subtract numbers or markers and return the result.
2644 With one arg, negates it. With more than one arg,
2645 subtracts all but the first from the first.
2646 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2647 (int nargs
, Lisp_Object
*args
)
2649 return arith_driver (Asub
, nargs
, args
);
2652 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2653 doc
: /* Return product of any number of arguments, which are numbers or markers.
2654 usage: (* &rest NUMBERS-OR-MARKERS) */)
2655 (int nargs
, Lisp_Object
*args
)
2657 return arith_driver (Amult
, nargs
, args
);
2660 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2661 doc
: /* Return first argument divided by all the remaining arguments.
2662 The arguments must be numbers or markers.
2663 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2664 (int nargs
, Lisp_Object
*args
)
2667 for (argnum
= 2; argnum
< nargs
; argnum
++)
2668 if (FLOATP (args
[argnum
]))
2669 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2670 return arith_driver (Adiv
, nargs
, args
);
2673 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2674 doc
: /* Return remainder of X divided by Y.
2675 Both must be integers or markers. */)
2676 (register Lisp_Object x
, Lisp_Object y
)
2680 CHECK_NUMBER_COERCE_MARKER (x
);
2681 CHECK_NUMBER_COERCE_MARKER (y
);
2683 if (XFASTINT (y
) == 0)
2684 xsignal0 (Qarith_error
);
2686 XSETINT (val
, XINT (x
) % XINT (y
));
2700 /* If the magnitude of the result exceeds that of the divisor, or
2701 the sign of the result does not agree with that of the dividend,
2702 iterate with the reduced value. This does not yield a
2703 particularly accurate result, but at least it will be in the
2704 range promised by fmod. */
2706 r
-= f2
* floor (r
/ f2
);
2707 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2711 #endif /* ! HAVE_FMOD */
2713 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2714 doc
: /* Return X modulo Y.
2715 The result falls between zero (inclusive) and Y (exclusive).
2716 Both X and Y must be numbers or markers. */)
2717 (register Lisp_Object x
, Lisp_Object y
)
2722 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2723 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2725 if (FLOATP (x
) || FLOATP (y
))
2726 return fmod_float (x
, y
);
2732 xsignal0 (Qarith_error
);
2736 /* If the "remainder" comes out with the wrong sign, fix it. */
2737 if (i2
< 0 ? i1
> 0 : i1
< 0)
2744 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2745 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2746 The value is always a number; markers are converted to numbers.
2747 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2748 (int nargs
, Lisp_Object
*args
)
2750 return arith_driver (Amax
, nargs
, args
);
2753 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2754 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2755 The value is always a number; markers are converted to numbers.
2756 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2757 (int nargs
, Lisp_Object
*args
)
2759 return arith_driver (Amin
, nargs
, args
);
2762 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2763 doc
: /* Return bitwise-and of all the arguments.
2764 Arguments may be integers, or markers converted to integers.
2765 usage: (logand &rest INTS-OR-MARKERS) */)
2766 (int nargs
, Lisp_Object
*args
)
2768 return arith_driver (Alogand
, nargs
, args
);
2771 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2772 doc
: /* Return bitwise-or of all the arguments.
2773 Arguments may be integers, or markers converted to integers.
2774 usage: (logior &rest INTS-OR-MARKERS) */)
2775 (int nargs
, Lisp_Object
*args
)
2777 return arith_driver (Alogior
, nargs
, args
);
2780 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2781 doc
: /* Return bitwise-exclusive-or of all the arguments.
2782 Arguments may be integers, or markers converted to integers.
2783 usage: (logxor &rest INTS-OR-MARKERS) */)
2784 (int nargs
, Lisp_Object
*args
)
2786 return arith_driver (Alogxor
, nargs
, args
);
2789 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2790 doc
: /* Return VALUE with its bits shifted left by COUNT.
2791 If COUNT is negative, shifting is actually to the right.
2792 In this case, the sign bit is duplicated. */)
2793 (register Lisp_Object value
, Lisp_Object count
)
2795 register Lisp_Object val
;
2797 CHECK_NUMBER (value
);
2798 CHECK_NUMBER (count
);
2800 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2802 else if (XINT (count
) > 0)
2803 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2804 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2805 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2807 XSETINT (val
, XINT (value
) >> -XINT (count
));
2811 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2812 doc
: /* Return VALUE with its bits shifted left by COUNT.
2813 If COUNT is negative, shifting is actually to the right.
2814 In this case, zeros are shifted in on the left. */)
2815 (register Lisp_Object value
, Lisp_Object count
)
2817 register Lisp_Object val
;
2819 CHECK_NUMBER (value
);
2820 CHECK_NUMBER (count
);
2822 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2824 else if (XINT (count
) > 0)
2825 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2826 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2829 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2833 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2834 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2835 Markers are converted to integers. */)
2836 (register Lisp_Object number
)
2838 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2840 if (FLOATP (number
))
2841 return (make_float (1.0 + XFLOAT_DATA (number
)));
2843 XSETINT (number
, XINT (number
) + 1);
2847 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2848 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2849 Markers are converted to integers. */)
2850 (register Lisp_Object number
)
2852 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2854 if (FLOATP (number
))
2855 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2857 XSETINT (number
, XINT (number
) - 1);
2861 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2862 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2863 (register Lisp_Object number
)
2865 CHECK_NUMBER (number
);
2866 XSETINT (number
, ~XINT (number
));
2870 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2871 doc
: /* Return the byteorder for the machine.
2872 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2873 lowercase l) for small endian machines. */)
2876 unsigned i
= 0x04030201;
2877 int order
= *(char *)&i
== 1 ? 108 : 66;
2879 return make_number (order
);
2887 Lisp_Object error_tail
, arith_tail
;
2889 Qquote
= intern_c_string ("quote");
2890 Qlambda
= intern_c_string ("lambda");
2891 Qsubr
= intern_c_string ("subr");
2892 Qerror_conditions
= intern_c_string ("error-conditions");
2893 Qerror_message
= intern_c_string ("error-message");
2894 Qtop_level
= intern_c_string ("top-level");
2896 Qerror
= intern_c_string ("error");
2897 Qquit
= intern_c_string ("quit");
2898 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2899 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2900 Qvoid_function
= intern_c_string ("void-function");
2901 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2902 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2903 Qvoid_variable
= intern_c_string ("void-variable");
2904 Qsetting_constant
= intern_c_string ("setting-constant");
2905 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2907 Qinvalid_function
= intern_c_string ("invalid-function");
2908 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2909 Qno_catch
= intern_c_string ("no-catch");
2910 Qend_of_file
= intern_c_string ("end-of-file");
2911 Qarith_error
= intern_c_string ("arith-error");
2912 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2913 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2914 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2915 Qtext_read_only
= intern_c_string ("text-read-only");
2916 Qmark_inactive
= intern_c_string ("mark-inactive");
2918 Qlistp
= intern_c_string ("listp");
2919 Qconsp
= intern_c_string ("consp");
2920 Qsymbolp
= intern_c_string ("symbolp");
2921 Qkeywordp
= intern_c_string ("keywordp");
2922 Qintegerp
= intern_c_string ("integerp");
2923 Qnatnump
= intern_c_string ("natnump");
2924 Qwholenump
= intern_c_string ("wholenump");
2925 Qstringp
= intern_c_string ("stringp");
2926 Qarrayp
= intern_c_string ("arrayp");
2927 Qsequencep
= intern_c_string ("sequencep");
2928 Qbufferp
= intern_c_string ("bufferp");
2929 Qvectorp
= intern_c_string ("vectorp");
2930 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2931 Qmarkerp
= intern_c_string ("markerp");
2932 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2933 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2934 Qboundp
= intern_c_string ("boundp");
2935 Qfboundp
= intern_c_string ("fboundp");
2937 Qfloatp
= intern_c_string ("floatp");
2938 Qnumberp
= intern_c_string ("numberp");
2939 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2941 Qchar_table_p
= intern_c_string ("char-table-p");
2942 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2944 Qsubrp
= intern_c_string ("subrp");
2945 Qunevalled
= intern_c_string ("unevalled");
2946 Qmany
= intern_c_string ("many");
2948 Qcdr
= intern_c_string ("cdr");
2950 /* Handle automatic advice activation */
2951 Qad_advice_info
= intern_c_string ("ad-advice-info");
2952 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2954 error_tail
= pure_cons (Qerror
, Qnil
);
2956 /* ERROR is used as a signaler for random errors for which nothing else is right */
2958 Fput (Qerror
, Qerror_conditions
,
2960 Fput (Qerror
, Qerror_message
,
2961 make_pure_c_string ("error"));
2963 Fput (Qquit
, Qerror_conditions
,
2964 pure_cons (Qquit
, Qnil
));
2965 Fput (Qquit
, Qerror_message
,
2966 make_pure_c_string ("Quit"));
2968 Fput (Qwrong_type_argument
, Qerror_conditions
,
2969 pure_cons (Qwrong_type_argument
, error_tail
));
2970 Fput (Qwrong_type_argument
, Qerror_message
,
2971 make_pure_c_string ("Wrong type argument"));
2973 Fput (Qargs_out_of_range
, Qerror_conditions
,
2974 pure_cons (Qargs_out_of_range
, error_tail
));
2975 Fput (Qargs_out_of_range
, Qerror_message
,
2976 make_pure_c_string ("Args out of range"));
2978 Fput (Qvoid_function
, Qerror_conditions
,
2979 pure_cons (Qvoid_function
, error_tail
));
2980 Fput (Qvoid_function
, Qerror_message
,
2981 make_pure_c_string ("Symbol's function definition is void"));
2983 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2984 pure_cons (Qcyclic_function_indirection
, error_tail
));
2985 Fput (Qcyclic_function_indirection
, Qerror_message
,
2986 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2988 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2989 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2990 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2991 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
2993 Qcircular_list
= intern_c_string ("circular-list");
2994 staticpro (&Qcircular_list
);
2995 Fput (Qcircular_list
, Qerror_conditions
,
2996 pure_cons (Qcircular_list
, error_tail
));
2997 Fput (Qcircular_list
, Qerror_message
,
2998 make_pure_c_string ("List contains a loop"));
3000 Fput (Qvoid_variable
, Qerror_conditions
,
3001 pure_cons (Qvoid_variable
, error_tail
));
3002 Fput (Qvoid_variable
, Qerror_message
,
3003 make_pure_c_string ("Symbol's value as variable is void"));
3005 Fput (Qsetting_constant
, Qerror_conditions
,
3006 pure_cons (Qsetting_constant
, error_tail
));
3007 Fput (Qsetting_constant
, Qerror_message
,
3008 make_pure_c_string ("Attempt to set a constant symbol"));
3010 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3011 pure_cons (Qinvalid_read_syntax
, error_tail
));
3012 Fput (Qinvalid_read_syntax
, Qerror_message
,
3013 make_pure_c_string ("Invalid read syntax"));
3015 Fput (Qinvalid_function
, Qerror_conditions
,
3016 pure_cons (Qinvalid_function
, error_tail
));
3017 Fput (Qinvalid_function
, Qerror_message
,
3018 make_pure_c_string ("Invalid function"));
3020 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3021 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3022 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3023 make_pure_c_string ("Wrong number of arguments"));
3025 Fput (Qno_catch
, Qerror_conditions
,
3026 pure_cons (Qno_catch
, error_tail
));
3027 Fput (Qno_catch
, Qerror_message
,
3028 make_pure_c_string ("No catch for tag"));
3030 Fput (Qend_of_file
, Qerror_conditions
,
3031 pure_cons (Qend_of_file
, error_tail
));
3032 Fput (Qend_of_file
, Qerror_message
,
3033 make_pure_c_string ("End of file during parsing"));
3035 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3036 Fput (Qarith_error
, Qerror_conditions
,
3038 Fput (Qarith_error
, Qerror_message
,
3039 make_pure_c_string ("Arithmetic error"));
3041 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3042 pure_cons (Qbeginning_of_buffer
, error_tail
));
3043 Fput (Qbeginning_of_buffer
, Qerror_message
,
3044 make_pure_c_string ("Beginning of buffer"));
3046 Fput (Qend_of_buffer
, Qerror_conditions
,
3047 pure_cons (Qend_of_buffer
, error_tail
));
3048 Fput (Qend_of_buffer
, Qerror_message
,
3049 make_pure_c_string ("End of buffer"));
3051 Fput (Qbuffer_read_only
, Qerror_conditions
,
3052 pure_cons (Qbuffer_read_only
, error_tail
));
3053 Fput (Qbuffer_read_only
, Qerror_message
,
3054 make_pure_c_string ("Buffer is read-only"));
3056 Fput (Qtext_read_only
, Qerror_conditions
,
3057 pure_cons (Qtext_read_only
, error_tail
));
3058 Fput (Qtext_read_only
, Qerror_message
,
3059 make_pure_c_string ("Text is read-only"));
3061 Qrange_error
= intern_c_string ("range-error");
3062 Qdomain_error
= intern_c_string ("domain-error");
3063 Qsingularity_error
= intern_c_string ("singularity-error");
3064 Qoverflow_error
= intern_c_string ("overflow-error");
3065 Qunderflow_error
= intern_c_string ("underflow-error");
3067 Fput (Qdomain_error
, Qerror_conditions
,
3068 pure_cons (Qdomain_error
, arith_tail
));
3069 Fput (Qdomain_error
, Qerror_message
,
3070 make_pure_c_string ("Arithmetic domain error"));
3072 Fput (Qrange_error
, Qerror_conditions
,
3073 pure_cons (Qrange_error
, arith_tail
));
3074 Fput (Qrange_error
, Qerror_message
,
3075 make_pure_c_string ("Arithmetic range error"));
3077 Fput (Qsingularity_error
, Qerror_conditions
,
3078 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3079 Fput (Qsingularity_error
, Qerror_message
,
3080 make_pure_c_string ("Arithmetic singularity error"));
3082 Fput (Qoverflow_error
, Qerror_conditions
,
3083 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3084 Fput (Qoverflow_error
, Qerror_message
,
3085 make_pure_c_string ("Arithmetic overflow error"));
3087 Fput (Qunderflow_error
, Qerror_conditions
,
3088 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3089 Fput (Qunderflow_error
, Qerror_message
,
3090 make_pure_c_string ("Arithmetic underflow error"));
3092 staticpro (&Qrange_error
);
3093 staticpro (&Qdomain_error
);
3094 staticpro (&Qsingularity_error
);
3095 staticpro (&Qoverflow_error
);
3096 staticpro (&Qunderflow_error
);
3100 staticpro (&Qquote
);
3101 staticpro (&Qlambda
);
3103 staticpro (&Qunbound
);
3104 staticpro (&Qerror_conditions
);
3105 staticpro (&Qerror_message
);
3106 staticpro (&Qtop_level
);
3108 staticpro (&Qerror
);
3110 staticpro (&Qwrong_type_argument
);
3111 staticpro (&Qargs_out_of_range
);
3112 staticpro (&Qvoid_function
);
3113 staticpro (&Qcyclic_function_indirection
);
3114 staticpro (&Qcyclic_variable_indirection
);
3115 staticpro (&Qvoid_variable
);
3116 staticpro (&Qsetting_constant
);
3117 staticpro (&Qinvalid_read_syntax
);
3118 staticpro (&Qwrong_number_of_arguments
);
3119 staticpro (&Qinvalid_function
);
3120 staticpro (&Qno_catch
);
3121 staticpro (&Qend_of_file
);
3122 staticpro (&Qarith_error
);
3123 staticpro (&Qbeginning_of_buffer
);
3124 staticpro (&Qend_of_buffer
);
3125 staticpro (&Qbuffer_read_only
);
3126 staticpro (&Qtext_read_only
);
3127 staticpro (&Qmark_inactive
);
3129 staticpro (&Qlistp
);
3130 staticpro (&Qconsp
);
3131 staticpro (&Qsymbolp
);
3132 staticpro (&Qkeywordp
);
3133 staticpro (&Qintegerp
);
3134 staticpro (&Qnatnump
);
3135 staticpro (&Qwholenump
);
3136 staticpro (&Qstringp
);
3137 staticpro (&Qarrayp
);
3138 staticpro (&Qsequencep
);
3139 staticpro (&Qbufferp
);
3140 staticpro (&Qvectorp
);
3141 staticpro (&Qchar_or_string_p
);
3142 staticpro (&Qmarkerp
);
3143 staticpro (&Qbuffer_or_string_p
);
3144 staticpro (&Qinteger_or_marker_p
);
3145 staticpro (&Qfloatp
);
3146 staticpro (&Qnumberp
);
3147 staticpro (&Qnumber_or_marker_p
);
3148 staticpro (&Qchar_table_p
);
3149 staticpro (&Qvector_or_char_table_p
);
3150 staticpro (&Qsubrp
);
3152 staticpro (&Qunevalled
);
3154 staticpro (&Qboundp
);
3155 staticpro (&Qfboundp
);
3157 staticpro (&Qad_advice_info
);
3158 staticpro (&Qad_activate_internal
);
3160 /* Types that type-of returns. */
3161 Qinteger
= intern_c_string ("integer");
3162 Qsymbol
= intern_c_string ("symbol");
3163 Qstring
= intern_c_string ("string");
3164 Qcons
= intern_c_string ("cons");
3165 Qmarker
= intern_c_string ("marker");
3166 Qoverlay
= intern_c_string ("overlay");
3167 Qfloat
= intern_c_string ("float");
3168 Qwindow_configuration
= intern_c_string ("window-configuration");
3169 Qprocess
= intern_c_string ("process");
3170 Qwindow
= intern_c_string ("window");
3171 /* Qsubr = intern_c_string ("subr"); */
3172 Qcompiled_function
= intern_c_string ("compiled-function");
3173 Qbuffer
= intern_c_string ("buffer");
3174 Qframe
= intern_c_string ("frame");
3175 Qvector
= intern_c_string ("vector");
3176 Qchar_table
= intern_c_string ("char-table");
3177 Qbool_vector
= intern_c_string ("bool-vector");
3178 Qhash_table
= intern_c_string ("hash-table");
3180 DEFSYM (Qfont_spec
, "font-spec");
3181 DEFSYM (Qfont_entity
, "font-entity");
3182 DEFSYM (Qfont_object
, "font-object");
3184 DEFSYM (Qinteractive_form
, "interactive-form");
3186 staticpro (&Qinteger
);
3187 staticpro (&Qsymbol
);
3188 staticpro (&Qstring
);
3190 staticpro (&Qmarker
);
3191 staticpro (&Qoverlay
);
3192 staticpro (&Qfloat
);
3193 staticpro (&Qwindow_configuration
);
3194 staticpro (&Qprocess
);
3195 staticpro (&Qwindow
);
3196 /* staticpro (&Qsubr); */
3197 staticpro (&Qcompiled_function
);
3198 staticpro (&Qbuffer
);
3199 staticpro (&Qframe
);
3200 staticpro (&Qvector
);
3201 staticpro (&Qchar_table
);
3202 staticpro (&Qbool_vector
);
3203 staticpro (&Qhash_table
);
3205 defsubr (&Sindirect_variable
);
3206 defsubr (&Sinteractive_form
);
3209 defsubr (&Stype_of
);
3214 defsubr (&Sintegerp
);
3215 defsubr (&Sinteger_or_marker_p
);
3216 defsubr (&Snumberp
);
3217 defsubr (&Snumber_or_marker_p
);
3219 defsubr (&Snatnump
);
3220 defsubr (&Ssymbolp
);
3221 defsubr (&Skeywordp
);
3222 defsubr (&Sstringp
);
3223 defsubr (&Smultibyte_string_p
);
3224 defsubr (&Svectorp
);
3225 defsubr (&Schar_table_p
);
3226 defsubr (&Svector_or_char_table_p
);
3227 defsubr (&Sbool_vector_p
);
3229 defsubr (&Ssequencep
);
3230 defsubr (&Sbufferp
);
3231 defsubr (&Smarkerp
);
3233 defsubr (&Sbyte_code_function_p
);
3234 defsubr (&Schar_or_string_p
);
3237 defsubr (&Scar_safe
);
3238 defsubr (&Scdr_safe
);
3241 defsubr (&Ssymbol_function
);
3242 defsubr (&Sindirect_function
);
3243 defsubr (&Ssymbol_plist
);
3244 defsubr (&Ssymbol_name
);
3245 defsubr (&Smakunbound
);
3246 defsubr (&Sfmakunbound
);
3248 defsubr (&Sfboundp
);
3250 defsubr (&Sdefalias
);
3251 defsubr (&Ssetplist
);
3252 defsubr (&Ssymbol_value
);
3254 defsubr (&Sdefault_boundp
);
3255 defsubr (&Sdefault_value
);
3256 defsubr (&Sset_default
);
3257 defsubr (&Ssetq_default
);
3258 defsubr (&Smake_variable_buffer_local
);
3259 defsubr (&Smake_local_variable
);
3260 defsubr (&Skill_local_variable
);
3261 defsubr (&Smake_variable_frame_local
);
3262 defsubr (&Slocal_variable_p
);
3263 defsubr (&Slocal_variable_if_set_p
);
3264 defsubr (&Svariable_binding_locus
);
3265 #if 0 /* XXX Remove this. --lorentey */
3266 defsubr (&Sterminal_local_value
);
3267 defsubr (&Sset_terminal_local_value
);
3271 defsubr (&Snumber_to_string
);
3272 defsubr (&Sstring_to_number
);
3273 defsubr (&Seqlsign
);
3296 defsubr (&Sbyteorder
);
3297 defsubr (&Ssubr_arity
);
3298 defsubr (&Ssubr_name
);
3300 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3302 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3303 doc
: /* The largest value that is representable in a Lisp integer. */);
3304 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3305 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3307 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3308 doc
: /* The smallest value that is representable in a Lisp integer. */);
3309 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3310 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3314 arith_error (int signo
)
3316 sigsetmask (SIGEMPTYMASK
);
3318 SIGNAL_THREAD_CHECK (signo
);
3319 xsignal0 (Qarith_error
);
3325 /* Don't do this if just dumping out.
3326 We don't want to call `signal' in this case
3327 so that we don't have trouble with dumping
3328 signal-delivering routines in an inconsistent state. */
3332 #endif /* CANNOT_DUMP */
3333 signal (SIGFPE
, arith_error
);
3336 signal (SIGEMT
, arith_error
);