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
, Qfunction_vector
, 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 (FUNVECP (object
))
198 if (FUNVEC_COMPILED_P (object
))
199 return Qcompiled_function
;
201 return Qfunction_vector
;
202 if (BUFFERP (object
))
204 if (CHAR_TABLE_P (object
))
206 if (BOOL_VECTOR_P (object
))
210 if (HASH_TABLE_P (object
))
212 if (FONT_SPEC_P (object
))
214 if (FONT_ENTITY_P (object
))
216 if (FONT_OBJECT_P (object
))
228 DEFUN ("consp", Fconsp
, Sconsp
, 1, 1, 0,
229 doc
: /* Return t if OBJECT is a cons cell. */)
237 DEFUN ("atom", Fatom
, Satom
, 1, 1, 0,
238 doc
: /* Return t if OBJECT is not a cons cell. This includes nil. */)
246 DEFUN ("listp", Flistp
, Slistp
, 1, 1, 0,
247 doc
: /* Return t if OBJECT is a list, that is, a cons cell or nil.
248 Otherwise, return nil. */)
251 if (CONSP (object
) || NILP (object
))
256 DEFUN ("nlistp", Fnlistp
, Snlistp
, 1, 1, 0,
257 doc
: /* Return t if OBJECT is not a list. Lists include nil. */)
260 if (CONSP (object
) || NILP (object
))
265 DEFUN ("symbolp", Fsymbolp
, Ssymbolp
, 1, 1, 0,
266 doc
: /* Return t if OBJECT is a symbol. */)
269 if (SYMBOLP (object
))
274 /* Define this in C to avoid unnecessarily consing up the symbol
276 DEFUN ("keywordp", Fkeywordp
, Skeywordp
, 1, 1, 0,
277 doc
: /* Return t if OBJECT is a keyword.
278 This means that it is a symbol with a print name beginning with `:'
279 interned in the initial obarray. */)
283 && SREF (SYMBOL_NAME (object
), 0) == ':'
284 && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object
))
289 DEFUN ("vectorp", Fvectorp
, Svectorp
, 1, 1, 0,
290 doc
: /* Return t if OBJECT is a vector. */)
293 if (VECTORP (object
))
298 DEFUN ("stringp", Fstringp
, Sstringp
, 1, 1, 0,
299 doc
: /* Return t if OBJECT is a string. */)
302 if (STRINGP (object
))
307 DEFUN ("multibyte-string-p", Fmultibyte_string_p
, Smultibyte_string_p
,
309 doc
: /* Return t if OBJECT is a multibyte string. */)
312 if (STRINGP (object
) && STRING_MULTIBYTE (object
))
317 DEFUN ("char-table-p", Fchar_table_p
, Schar_table_p
, 1, 1, 0,
318 doc
: /* Return t if OBJECT is a char-table. */)
321 if (CHAR_TABLE_P (object
))
326 DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p
,
327 Svector_or_char_table_p
, 1, 1, 0,
328 doc
: /* Return t if OBJECT is a char-table or vector. */)
331 if (VECTORP (object
) || CHAR_TABLE_P (object
))
336 DEFUN ("bool-vector-p", Fbool_vector_p
, Sbool_vector_p
, 1, 1, 0,
337 doc
: /* Return t if OBJECT is a bool-vector. */)
340 if (BOOL_VECTOR_P (object
))
345 DEFUN ("arrayp", Farrayp
, Sarrayp
, 1, 1, 0,
346 doc
: /* Return t if OBJECT is an array (string or vector). */)
354 DEFUN ("sequencep", Fsequencep
, Ssequencep
, 1, 1, 0,
355 doc
: /* Return t if OBJECT is a sequence (list or array). */)
356 (register Lisp_Object object
)
358 if (CONSP (object
) || NILP (object
) || ARRAYP (object
))
363 DEFUN ("bufferp", Fbufferp
, Sbufferp
, 1, 1, 0,
364 doc
: /* Return t if OBJECT is an editor buffer. */)
367 if (BUFFERP (object
))
372 DEFUN ("markerp", Fmarkerp
, Smarkerp
, 1, 1, 0,
373 doc
: /* Return t if OBJECT is a marker (editor pointer). */)
376 if (MARKERP (object
))
381 DEFUN ("subrp", Fsubrp
, Ssubrp
, 1, 1, 0,
382 doc
: /* Return t if OBJECT is a built-in function. */)
390 DEFUN ("byte-code-function-p", Fbyte_code_function_p
, Sbyte_code_function_p
,
392 doc
: /* Return t if OBJECT is a byte-compiled function object. */)
395 if (COMPILEDP (object
))
400 DEFUN ("funvecp", Ffunvecp
, Sfunvecp
, 1, 1, 0,
401 doc
: /* Return t if OBJECT is a `function vector' object. */)
404 return FUNVECP (object
) ? Qt
: Qnil
;
407 DEFUN ("char-or-string-p", Fchar_or_string_p
, Schar_or_string_p
, 1, 1, 0,
408 doc
: /* Return t if OBJECT is a character or a string. */)
409 (register Lisp_Object object
)
411 if (CHARACTERP (object
) || STRINGP (object
))
416 DEFUN ("integerp", Fintegerp
, Sintegerp
, 1, 1, 0,
417 doc
: /* Return t if OBJECT is an integer. */)
420 if (INTEGERP (object
))
425 DEFUN ("integer-or-marker-p", Finteger_or_marker_p
, Sinteger_or_marker_p
, 1, 1, 0,
426 doc
: /* Return t if OBJECT is an integer or a marker (editor pointer). */)
427 (register Lisp_Object object
)
429 if (MARKERP (object
) || INTEGERP (object
))
434 DEFUN ("natnump", Fnatnump
, Snatnump
, 1, 1, 0,
435 doc
: /* Return t if OBJECT is a nonnegative integer. */)
438 if (NATNUMP (object
))
443 DEFUN ("numberp", Fnumberp
, Snumberp
, 1, 1, 0,
444 doc
: /* Return t if OBJECT is a number (floating point or integer). */)
447 if (NUMBERP (object
))
453 DEFUN ("number-or-marker-p", Fnumber_or_marker_p
,
454 Snumber_or_marker_p
, 1, 1, 0,
455 doc
: /* Return t if OBJECT is a number or a marker. */)
458 if (NUMBERP (object
) || MARKERP (object
))
463 DEFUN ("floatp", Ffloatp
, Sfloatp
, 1, 1, 0,
464 doc
: /* Return t if OBJECT is a floating point number. */)
473 /* Extract and set components of lists */
475 DEFUN ("car", Fcar
, Scar
, 1, 1, 0,
476 doc
: /* Return the car of LIST. If arg is nil, return nil.
477 Error if arg is not nil and not a cons cell. See also `car-safe'.
479 See Info node `(elisp)Cons Cells' for a discussion of related basic
480 Lisp concepts such as car, cdr, cons cell and list. */)
481 (register Lisp_Object list
)
486 DEFUN ("car-safe", Fcar_safe
, Scar_safe
, 1, 1, 0,
487 doc
: /* Return the car of OBJECT if it is a cons cell, or else nil. */)
490 return CAR_SAFE (object
);
493 DEFUN ("cdr", Fcdr
, Scdr
, 1, 1, 0,
494 doc
: /* Return the cdr of LIST. If arg is nil, return nil.
495 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
497 See Info node `(elisp)Cons Cells' for a discussion of related basic
498 Lisp concepts such as cdr, car, cons cell and list. */)
499 (register Lisp_Object list
)
504 DEFUN ("cdr-safe", Fcdr_safe
, Scdr_safe
, 1, 1, 0,
505 doc
: /* Return the cdr of OBJECT if it is a cons cell, or else nil. */)
508 return CDR_SAFE (object
);
511 DEFUN ("setcar", Fsetcar
, Ssetcar
, 2, 2, 0,
512 doc
: /* Set the car of CELL to be NEWCAR. Returns NEWCAR. */)
513 (register Lisp_Object cell
, Lisp_Object newcar
)
517 XSETCAR (cell
, newcar
);
521 DEFUN ("setcdr", Fsetcdr
, Ssetcdr
, 2, 2, 0,
522 doc
: /* Set the cdr of CELL to be NEWCDR. Returns NEWCDR. */)
523 (register Lisp_Object cell
, Lisp_Object newcdr
)
527 XSETCDR (cell
, newcdr
);
531 /* Extract and set components of symbols */
533 DEFUN ("boundp", Fboundp
, Sboundp
, 1, 1, 0,
534 doc
: /* Return t if SYMBOL's value is not void. */)
535 (register Lisp_Object symbol
)
537 Lisp_Object valcontents
;
538 struct Lisp_Symbol
*sym
;
539 CHECK_SYMBOL (symbol
);
540 sym
= XSYMBOL (symbol
);
543 switch (sym
->redirect
)
545 case SYMBOL_PLAINVAL
: valcontents
= SYMBOL_VAL (sym
); break;
546 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
547 case SYMBOL_LOCALIZED
:
549 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
551 /* In set_internal, we un-forward vars when their value is
556 swap_in_symval_forwarding (sym
, blv
);
557 valcontents
= BLV_VALUE (blv
);
561 case SYMBOL_FORWARDED
:
562 /* In set_internal, we un-forward vars when their value is
568 return (EQ (valcontents
, Qunbound
) ? Qnil
: Qt
);
571 DEFUN ("fboundp", Ffboundp
, Sfboundp
, 1, 1, 0,
572 doc
: /* Return t if SYMBOL's function definition is not void. */)
573 (register Lisp_Object symbol
)
575 CHECK_SYMBOL (symbol
);
576 return (EQ (XSYMBOL (symbol
)->function
, Qunbound
) ? Qnil
: Qt
);
579 DEFUN ("makunbound", Fmakunbound
, Smakunbound
, 1, 1, 0,
580 doc
: /* Make SYMBOL's value be void.
582 (register Lisp_Object symbol
)
584 CHECK_SYMBOL (symbol
);
585 if (SYMBOL_CONSTANT_P (symbol
))
586 xsignal1 (Qsetting_constant
, symbol
);
587 Fset (symbol
, Qunbound
);
591 DEFUN ("fmakunbound", Ffmakunbound
, Sfmakunbound
, 1, 1, 0,
592 doc
: /* Make SYMBOL's function definition be void.
594 (register Lisp_Object symbol
)
596 CHECK_SYMBOL (symbol
);
597 if (NILP (symbol
) || EQ (symbol
, Qt
))
598 xsignal1 (Qsetting_constant
, symbol
);
599 XSYMBOL (symbol
)->function
= Qunbound
;
603 DEFUN ("symbol-function", Fsymbol_function
, Ssymbol_function
, 1, 1, 0,
604 doc
: /* Return SYMBOL's function definition. Error if that is void. */)
605 (register Lisp_Object symbol
)
607 CHECK_SYMBOL (symbol
);
608 if (!EQ (XSYMBOL (symbol
)->function
, Qunbound
))
609 return XSYMBOL (symbol
)->function
;
610 xsignal1 (Qvoid_function
, symbol
);
613 DEFUN ("symbol-plist", Fsymbol_plist
, Ssymbol_plist
, 1, 1, 0,
614 doc
: /* Return SYMBOL's property list. */)
615 (register Lisp_Object symbol
)
617 CHECK_SYMBOL (symbol
);
618 return XSYMBOL (symbol
)->plist
;
621 DEFUN ("symbol-name", Fsymbol_name
, Ssymbol_name
, 1, 1, 0,
622 doc
: /* Return SYMBOL's name, a string. */)
623 (register Lisp_Object symbol
)
625 register Lisp_Object name
;
627 CHECK_SYMBOL (symbol
);
628 name
= SYMBOL_NAME (symbol
);
632 DEFUN ("fset", Ffset
, Sfset
, 2, 2, 0,
633 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */)
634 (register Lisp_Object symbol
, Lisp_Object definition
)
636 register Lisp_Object function
;
638 CHECK_SYMBOL (symbol
);
639 if (NILP (symbol
) || EQ (symbol
, Qt
))
640 xsignal1 (Qsetting_constant
, symbol
);
642 function
= XSYMBOL (symbol
)->function
;
644 if (!NILP (Vautoload_queue
) && !EQ (function
, Qunbound
))
645 Vautoload_queue
= Fcons (Fcons (symbol
, function
), Vautoload_queue
);
647 if (CONSP (function
) && EQ (XCAR (function
), Qautoload
))
648 Fput (symbol
, Qautoload
, XCDR (function
));
650 XSYMBOL (symbol
)->function
= definition
;
651 /* Handle automatic advice activation */
652 if (CONSP (XSYMBOL (symbol
)->plist
) && !NILP (Fget (symbol
, Qad_advice_info
)))
654 call2 (Qad_activate_internal
, symbol
, Qnil
);
655 definition
= XSYMBOL (symbol
)->function
;
660 DEFUN ("defalias", Fdefalias
, Sdefalias
, 2, 3, 0,
661 doc
: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
662 Associates the function with the current load file, if any.
663 The optional third argument DOCSTRING specifies the documentation string
664 for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
665 determined by DEFINITION. */)
666 (register Lisp_Object symbol
, Lisp_Object definition
, Lisp_Object docstring
)
668 CHECK_SYMBOL (symbol
);
669 if (CONSP (XSYMBOL (symbol
)->function
)
670 && EQ (XCAR (XSYMBOL (symbol
)->function
), Qautoload
))
671 LOADHIST_ATTACH (Fcons (Qt
, symbol
));
672 definition
= Ffset (symbol
, definition
);
673 LOADHIST_ATTACH (Fcons (Qdefun
, symbol
));
674 if (!NILP (docstring
))
675 Fput (symbol
, Qfunction_documentation
, docstring
);
679 DEFUN ("setplist", Fsetplist
, Ssetplist
, 2, 2, 0,
680 doc
: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST. */)
681 (register Lisp_Object symbol
, Lisp_Object newplist
)
683 CHECK_SYMBOL (symbol
);
684 XSYMBOL (symbol
)->plist
= newplist
;
688 DEFUN ("subr-arity", Fsubr_arity
, Ssubr_arity
, 1, 1, 0,
689 doc
: /* Return minimum and maximum number of args allowed for SUBR.
690 SUBR must be a built-in function.
691 The returned value is a pair (MIN . MAX). MIN is the minimum number
692 of args. MAX is the maximum number or the symbol `many', for a
693 function with `&rest' args, or `unevalled' for a special form. */)
696 short minargs
, maxargs
;
698 minargs
= XSUBR (subr
)->min_args
;
699 maxargs
= XSUBR (subr
)->max_args
;
701 return Fcons (make_number (minargs
), Qmany
);
702 else if (maxargs
== UNEVALLED
)
703 return Fcons (make_number (minargs
), Qunevalled
);
705 return Fcons (make_number (minargs
), make_number (maxargs
));
708 DEFUN ("subr-name", Fsubr_name
, Ssubr_name
, 1, 1, 0,
709 doc
: /* Return name of subroutine SUBR.
710 SUBR must be a built-in function. */)
715 name
= XSUBR (subr
)->symbol_name
;
716 return make_string (name
, strlen (name
));
719 DEFUN ("interactive-form", Finteractive_form
, Sinteractive_form
, 1, 1, 0,
720 doc
: /* Return the interactive form of CMD or nil if none.
721 If CMD is not a command, the return value is nil.
722 Value, if non-nil, is a list \(interactive SPEC). */)
725 Lisp_Object fun
= indirect_function (cmd
); /* Check cycles. */
727 if (NILP (fun
) || EQ (fun
, Qunbound
))
730 /* Use an `interactive-form' property if present, analogous to the
731 function-documentation property. */
733 while (SYMBOLP (fun
))
735 Lisp_Object tmp
= Fget (fun
, Qinteractive_form
);
739 fun
= Fsymbol_function (fun
);
744 const char *spec
= XSUBR (fun
)->intspec
;
746 return list2 (Qinteractive
,
747 (*spec
!= '(') ? build_string (spec
) :
748 Fcar (Fread_from_string (build_string (spec
), Qnil
, Qnil
)));
750 else if (COMPILEDP (fun
))
752 if ((ASIZE (fun
) & PSEUDOVECTOR_SIZE_MASK
) > COMPILED_INTERACTIVE
)
753 return list2 (Qinteractive
, AREF (fun
, COMPILED_INTERACTIVE
));
755 else if (CONSP (fun
))
757 Lisp_Object funcar
= XCAR (fun
);
758 if (EQ (funcar
, Qlambda
))
759 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
760 else if (EQ (funcar
, Qautoload
))
764 do_autoload (fun
, cmd
);
766 return Finteractive_form (cmd
);
773 /***********************************************************************
774 Getting and Setting Values of Symbols
775 ***********************************************************************/
777 /* Return the symbol holding SYMBOL's value. Signal
778 `cyclic-variable-indirection' if SYMBOL's chain of variable
779 indirections contains a loop. */
782 indirect_variable (struct Lisp_Symbol
*symbol
)
784 struct Lisp_Symbol
*tortoise
, *hare
;
786 hare
= tortoise
= symbol
;
788 while (hare
->redirect
== SYMBOL_VARALIAS
)
790 hare
= SYMBOL_ALIAS (hare
);
791 if (hare
->redirect
!= SYMBOL_VARALIAS
)
794 hare
= SYMBOL_ALIAS (hare
);
795 tortoise
= SYMBOL_ALIAS (tortoise
);
797 if (hare
== tortoise
)
800 XSETSYMBOL (tem
, symbol
);
801 xsignal1 (Qcyclic_variable_indirection
, tem
);
809 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
810 doc
: /* Return the variable at the end of OBJECT's variable chain.
811 If OBJECT is a symbol, follow all variable indirections and return the final
812 variable. If OBJECT is not a symbol, just return it.
813 Signal a cyclic-variable-indirection error if there is a loop in the
814 variable chain of symbols. */)
817 if (SYMBOLP (object
))
818 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
823 /* Given the raw contents of a symbol value cell,
824 return the Lisp value of the symbol.
825 This does not handle buffer-local variables; use
826 swap_in_symval_forwarding for that. */
828 #define do_blv_forwarding(blv) \
829 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
832 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
834 register Lisp_Object val
;
835 switch (XFWDTYPE (valcontents
))
838 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
842 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
845 return *XOBJFWD (valcontents
)->objvar
;
847 case Lisp_Fwd_Buffer_Obj
:
848 return PER_BUFFER_VALUE (current_buffer
,
849 XBUFFER_OBJFWD (valcontents
)->offset
);
851 case Lisp_Fwd_Kboard_Obj
:
852 /* We used to simply use current_kboard here, but from Lisp
853 code, it's value is often unexpected. It seems nicer to
854 allow constructions like this to work as intuitively expected:
856 (with-selected-frame frame
857 (define-key local-function-map "\eOP" [f1]))
859 On the other hand, this affects the semantics of
860 last-command and real-last-command, and people may rely on
861 that. I took a quick look at the Lisp codebase, and I
862 don't think anything will break. --lorentey */
863 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
864 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
869 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
870 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
871 buffer-independent contents of the value cell: forwarded just one
872 step past the buffer-localness.
874 BUF non-zero means set the value in buffer BUF instead of the
875 current buffer. This only plays a role for per-buffer variables. */
877 #define store_blv_forwarding(blv, newval, buf) \
879 if ((blv)->forwarded) \
880 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
882 SET_BLV_VALUE (blv, newval); \
886 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
888 switch (XFWDTYPE (valcontents
))
891 CHECK_NUMBER (newval
);
892 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
896 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
900 *XOBJFWD (valcontents
)->objvar
= newval
;
902 /* If this variable is a default for something stored
903 in the buffer itself, such as default-fill-column,
904 find the buffers that don't have local values for it
906 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
907 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
909 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
910 - (char *) &buffer_defaults
);
911 int idx
= PER_BUFFER_IDX (offset
);
918 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
923 buf
= Fcdr (XCAR (tail
));
924 if (!BUFFERP (buf
)) continue;
927 if (! PER_BUFFER_VALUE_P (b
, idx
))
928 PER_BUFFER_VALUE (b
, offset
) = newval
;
933 case Lisp_Fwd_Buffer_Obj
:
935 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
936 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
938 if (!(NILP (type
) || NILP (newval
)
939 || (XINT (type
) == LISP_INT_TAG
941 : XTYPE (newval
) == XINT (type
))))
942 buffer_slot_type_mismatch (newval
, XINT (type
));
945 buf
= current_buffer
;
946 PER_BUFFER_VALUE (buf
, offset
) = newval
;
950 case Lisp_Fwd_Kboard_Obj
:
952 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
953 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
954 *(Lisp_Object
*) p
= newval
;
959 abort (); /* goto def; */
963 /* Set up SYMBOL to refer to its global binding.
964 This makes it safe to alter the status of other bindings. */
967 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
969 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
971 /* Unload the previously loaded binding. */
973 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
975 /* Select the global binding in the symbol. */
976 blv
->valcell
= blv
->defcell
;
978 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
980 /* Indicate that the global binding is set up now. */
982 SET_BLV_FOUND (blv
, 0);
985 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
986 VALCONTENTS is the contents of its value cell,
987 which points to a struct Lisp_Buffer_Local_Value.
989 Return the value forwarded one step past the buffer-local stage.
990 This could be another forwarding pointer. */
993 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
995 register Lisp_Object tem1
;
997 eassert (blv
== SYMBOL_BLV (symbol
));
1002 || (blv
->frame_local
1003 ? !EQ (selected_frame
, tem1
)
1004 : current_buffer
!= XBUFFER (tem1
)))
1007 /* Unload the previously loaded binding. */
1008 tem1
= blv
->valcell
;
1010 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1011 /* Choose the new binding. */
1014 XSETSYMBOL (var
, symbol
);
1015 if (blv
->frame_local
)
1017 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1018 blv
->where
= selected_frame
;
1022 tem1
= assq_no_quit (var
, current_buffer
->local_var_alist
);
1023 XSETBUFFER (blv
->where
, current_buffer
);
1026 if (!(blv
->found
= !NILP (tem1
)))
1027 tem1
= blv
->defcell
;
1029 /* Load the new binding. */
1030 blv
->valcell
= tem1
;
1032 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1036 /* Find the value of a symbol, returning Qunbound if it's not bound.
1037 This is helpful for code which just wants to get a variable's value
1038 if it has one, without signaling an error.
1039 Note that it must not be possible to quit
1040 within this function. Great care is required for this. */
1043 find_symbol_value (Lisp_Object symbol
)
1045 struct Lisp_Symbol
*sym
;
1047 CHECK_SYMBOL (symbol
);
1048 sym
= XSYMBOL (symbol
);
1051 switch (sym
->redirect
)
1053 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1054 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1055 case SYMBOL_LOCALIZED
:
1057 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1058 swap_in_symval_forwarding (sym
, blv
);
1059 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1062 case SYMBOL_FORWARDED
:
1063 return do_symval_forwarding (SYMBOL_FWD (sym
));
1068 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1069 doc
: /* Return SYMBOL's value. Error if that is void. */)
1070 (Lisp_Object symbol
)
1074 val
= find_symbol_value (symbol
);
1075 if (!EQ (val
, Qunbound
))
1078 xsignal1 (Qvoid_variable
, symbol
);
1081 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1082 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1083 (register Lisp_Object symbol
, Lisp_Object newval
)
1085 set_internal (symbol
, newval
, Qnil
, 0);
1089 /* Return 1 if SYMBOL currently has a let-binding
1090 which was made in the buffer that is now current. */
1093 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1095 struct specbinding
*p
;
1097 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1099 && CONSP (p
->symbol
))
1101 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1102 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1103 if (symbol
== let_bound_symbol
1104 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1108 return p
>= specpdl
;
1112 let_shadows_global_binding_p (Lisp_Object symbol
)
1114 struct specbinding
*p
;
1116 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1117 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1120 return p
>= specpdl
;
1123 /* Store the value NEWVAL into SYMBOL.
1124 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1125 (nil stands for the current buffer/frame).
1127 If BINDFLAG is zero, then if this symbol is supposed to become
1128 local in every buffer where it is set, then we make it local.
1129 If BINDFLAG is nonzero, we don't do that. */
1132 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1134 int voide
= EQ (newval
, Qunbound
);
1135 struct Lisp_Symbol
*sym
;
1138 /* If restoring in a dead buffer, do nothing. */
1139 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1142 CHECK_SYMBOL (symbol
);
1143 if (SYMBOL_CONSTANT_P (symbol
))
1145 if (NILP (Fkeywordp (symbol
))
1146 || !EQ (newval
, Fsymbol_value (symbol
)))
1147 xsignal1 (Qsetting_constant
, symbol
);
1149 /* Allow setting keywords to their own value. */
1153 sym
= XSYMBOL (symbol
);
1156 switch (sym
->redirect
)
1158 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1159 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1160 case SYMBOL_LOCALIZED
:
1162 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1165 if (blv
->frame_local
)
1166 where
= selected_frame
;
1168 XSETBUFFER (where
, current_buffer
);
1170 /* If the current buffer is not the buffer whose binding is
1171 loaded, or if there may be frame-local bindings and the frame
1172 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1173 the default binding is loaded, the loaded binding may be the
1175 if (!EQ (blv
->where
, where
)
1176 /* Also unload a global binding (if the var is local_if_set). */
1177 || (EQ (blv
->valcell
, blv
->defcell
)))
1179 /* The currently loaded binding is not necessarily valid.
1180 We need to unload it, and choose a new binding. */
1182 /* Write out `realvalue' to the old loaded binding. */
1184 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1186 /* Find the new binding. */
1187 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1188 tem1
= Fassq (symbol
,
1190 ? XFRAME (where
)->param_alist
1191 : XBUFFER (where
)->local_var_alist
));
1197 /* This buffer still sees the default value. */
1199 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1200 or if this is `let' rather than `set',
1201 make CURRENT-ALIST-ELEMENT point to itself,
1202 indicating that we're seeing the default value.
1203 Likewise if the variable has been let-bound
1204 in the current buffer. */
1205 if (bindflag
|| !blv
->local_if_set
1206 || let_shadows_buffer_binding_p (sym
))
1209 tem1
= blv
->defcell
;
1211 /* If it's a local_if_set, being set not bound,
1212 and we're not within a let that was made for this buffer,
1213 create a new buffer-local binding for the variable.
1214 That means, give this buffer a new assoc for a local value
1215 and load that binding. */
1218 /* local_if_set is only supported for buffer-local
1219 bindings, not for frame-local bindings. */
1220 eassert (!blv
->frame_local
);
1221 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1222 XBUFFER (where
)->local_var_alist
1223 = Fcons (tem1
, XBUFFER (where
)->local_var_alist
);
1227 /* Record which binding is now loaded. */
1228 blv
->valcell
= tem1
;
1231 /* Store the new value in the cons cell. */
1232 SET_BLV_VALUE (blv
, newval
);
1237 /* If storing void (making the symbol void), forward only through
1238 buffer-local indicator, not through Lisp_Objfwd, etc. */
1241 store_symval_forwarding (blv
->fwd
, newval
,
1243 ? XBUFFER (where
) : current_buffer
);
1247 case SYMBOL_FORWARDED
:
1250 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1251 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1252 if (BUFFER_OBJFWDP (innercontents
))
1254 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1255 int idx
= PER_BUFFER_IDX (offset
);
1258 && !let_shadows_buffer_binding_p (sym
))
1259 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1263 { /* If storing void (making the symbol void), forward only through
1264 buffer-local indicator, not through Lisp_Objfwd, etc. */
1265 sym
->redirect
= SYMBOL_PLAINVAL
;
1266 SET_SYMBOL_VAL (sym
, newval
);
1269 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1277 /* Access or set a buffer-local symbol's default value. */
1279 /* Return the default value of SYMBOL, but don't check for voidness.
1280 Return Qunbound if it is void. */
1283 default_value (Lisp_Object symbol
)
1285 struct Lisp_Symbol
*sym
;
1287 CHECK_SYMBOL (symbol
);
1288 sym
= XSYMBOL (symbol
);
1291 switch (sym
->redirect
)
1293 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1294 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1295 case SYMBOL_LOCALIZED
:
1297 /* If var is set up for a buffer that lacks a local value for it,
1298 the current value is nominally the default value.
1299 But the `realvalue' slot may be more up to date, since
1300 ordinary setq stores just that slot. So use that. */
1301 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1302 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1303 return do_symval_forwarding (blv
->fwd
);
1305 return XCDR (blv
->defcell
);
1307 case SYMBOL_FORWARDED
:
1309 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1311 /* For a built-in buffer-local variable, get the default value
1312 rather than letting do_symval_forwarding get the current value. */
1313 if (BUFFER_OBJFWDP (valcontents
))
1315 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1316 if (PER_BUFFER_IDX (offset
) != 0)
1317 return PER_BUFFER_DEFAULT (offset
);
1320 /* For other variables, get the current value. */
1321 return do_symval_forwarding (valcontents
);
1327 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1328 doc
: /* Return t if SYMBOL has a non-void default value.
1329 This is the value that is seen in buffers that do not have their own values
1330 for this variable. */)
1331 (Lisp_Object symbol
)
1333 register Lisp_Object value
;
1335 value
= default_value (symbol
);
1336 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1339 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1340 doc
: /* Return SYMBOL's default value.
1341 This is the value that is seen in buffers that do not have their own values
1342 for this variable. The default value is meaningful for variables with
1343 local bindings in certain buffers. */)
1344 (Lisp_Object symbol
)
1346 register Lisp_Object value
;
1348 value
= default_value (symbol
);
1349 if (!EQ (value
, Qunbound
))
1352 xsignal1 (Qvoid_variable
, symbol
);
1355 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1356 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1357 The default value is seen in buffers that do not have their own values
1358 for this variable. */)
1359 (Lisp_Object symbol
, Lisp_Object value
)
1361 struct Lisp_Symbol
*sym
;
1363 CHECK_SYMBOL (symbol
);
1364 if (SYMBOL_CONSTANT_P (symbol
))
1366 if (NILP (Fkeywordp (symbol
))
1367 || !EQ (value
, Fdefault_value (symbol
)))
1368 xsignal1 (Qsetting_constant
, symbol
);
1370 /* Allow setting keywords to their own value. */
1373 sym
= XSYMBOL (symbol
);
1376 switch (sym
->redirect
)
1378 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1379 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1380 case SYMBOL_LOCALIZED
:
1382 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1384 /* Store new value into the DEFAULT-VALUE slot. */
1385 XSETCDR (blv
->defcell
, value
);
1387 /* If the default binding is now loaded, set the REALVALUE slot too. */
1388 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1389 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1392 case SYMBOL_FORWARDED
:
1394 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1396 /* Handle variables like case-fold-search that have special slots
1398 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1399 if (BUFFER_OBJFWDP (valcontents
))
1401 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1402 int idx
= PER_BUFFER_IDX (offset
);
1404 PER_BUFFER_DEFAULT (offset
) = value
;
1406 /* If this variable is not always local in all buffers,
1407 set it in the buffers that don't nominally have a local value. */
1412 for (b
= all_buffers
; b
; b
= b
->next
)
1413 if (!PER_BUFFER_VALUE_P (b
, idx
))
1414 PER_BUFFER_VALUE (b
, offset
) = value
;
1419 return Fset (symbol
, value
);
1425 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1426 doc
: /* Set the default value of variable VAR to VALUE.
1427 VAR, the variable name, is literal (not evaluated);
1428 VALUE is an expression: it is evaluated and its value returned.
1429 The default value of a variable is seen in buffers
1430 that do not have their own values for the variable.
1432 More generally, you can use multiple variables and values, as in
1433 (setq-default VAR VALUE VAR VALUE...)
1434 This sets each VAR's default value to the corresponding VALUE.
1435 The VALUE for the Nth VAR can refer to the new default values
1437 usage: (setq-default [VAR VALUE]...) */)
1440 register Lisp_Object args_left
;
1441 register Lisp_Object val
, symbol
;
1442 struct gcpro gcpro1
;
1452 val
= eval_sub (Fcar (Fcdr (args_left
)));
1453 symbol
= XCAR (args_left
);
1454 Fset_default (symbol
, val
);
1455 args_left
= Fcdr (XCDR (args_left
));
1457 while (!NILP (args_left
));
1463 /* Lisp functions for creating and removing buffer-local variables. */
1468 union Lisp_Fwd
*fwd
;
1471 static struct Lisp_Buffer_Local_Value
*
1472 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1474 struct Lisp_Buffer_Local_Value
*blv
1475 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1479 XSETSYMBOL (symbol
, sym
);
1480 tem
= Fcons (symbol
, (forwarded
1481 ? do_symval_forwarding (valcontents
.fwd
)
1482 : valcontents
.value
));
1484 /* Buffer_Local_Values cannot have as realval a buffer-local
1485 or keyboard-local forwarding. */
1486 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1487 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1488 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1490 blv
->frame_local
= 0;
1491 blv
->local_if_set
= 0;
1494 SET_BLV_FOUND (blv
, 0);
1498 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1499 1, 1, "vMake Variable Buffer Local: ",
1500 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1501 At any time, the value for the current buffer is in effect,
1502 unless the variable has never been set in this buffer,
1503 in which case the default value is in effect.
1504 Note that binding the variable with `let', or setting it while
1505 a `let'-style binding made in this buffer is in effect,
1506 does not make the variable buffer-local. Return VARIABLE.
1508 In most cases it is better to use `make-local-variable',
1509 which makes a variable local in just one buffer.
1511 The function `default-value' gets the default value and `set-default' sets it. */)
1512 (register Lisp_Object variable
)
1514 struct Lisp_Symbol
*sym
;
1515 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1516 union Lisp_Val_Fwd valcontents
;
1519 CHECK_SYMBOL (variable
);
1520 sym
= XSYMBOL (variable
);
1523 switch (sym
->redirect
)
1525 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1526 case SYMBOL_PLAINVAL
:
1527 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1528 if (EQ (valcontents
.value
, Qunbound
))
1529 valcontents
.value
= Qnil
;
1531 case SYMBOL_LOCALIZED
:
1532 blv
= SYMBOL_BLV (sym
);
1533 if (blv
->frame_local
)
1534 error ("Symbol %s may not be buffer-local",
1535 SDATA (SYMBOL_NAME (variable
)));
1537 case SYMBOL_FORWARDED
:
1538 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1539 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1540 error ("Symbol %s may not be buffer-local",
1541 SDATA (SYMBOL_NAME (variable
)));
1542 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1549 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1553 blv
= make_blv (sym
, forwarded
, valcontents
);
1554 sym
->redirect
= SYMBOL_LOCALIZED
;
1555 SET_SYMBOL_BLV (sym
, blv
);
1558 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1559 if (let_shadows_global_binding_p (symbol
))
1560 message ("Making %s buffer-local while let-bound!",
1561 SDATA (SYMBOL_NAME (variable
)));
1565 blv
->local_if_set
= 1;
1569 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1570 1, 1, "vMake Local Variable: ",
1571 doc
: /* Make VARIABLE have a separate value in the current buffer.
1572 Other buffers will continue to share a common default value.
1573 \(The buffer-local value of VARIABLE starts out as the same value
1574 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1577 If the variable is already arranged to become local when set,
1578 this function causes a local value to exist for this buffer,
1579 just as setting the variable would do.
1581 This function returns VARIABLE, and therefore
1582 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1585 See also `make-variable-buffer-local'.
1587 Do not use `make-local-variable' to make a hook variable buffer-local.
1588 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1589 (register Lisp_Object variable
)
1591 register Lisp_Object tem
;
1593 union Lisp_Val_Fwd valcontents
;
1594 struct Lisp_Symbol
*sym
;
1595 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1597 CHECK_SYMBOL (variable
);
1598 sym
= XSYMBOL (variable
);
1601 switch (sym
->redirect
)
1603 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1604 case SYMBOL_PLAINVAL
:
1605 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1606 case SYMBOL_LOCALIZED
:
1607 blv
= SYMBOL_BLV (sym
);
1608 if (blv
->frame_local
)
1609 error ("Symbol %s may not be buffer-local",
1610 SDATA (SYMBOL_NAME (variable
)));
1612 case SYMBOL_FORWARDED
:
1613 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1614 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1615 error ("Symbol %s may not be buffer-local",
1616 SDATA (SYMBOL_NAME (variable
)));
1622 error ("Symbol %s may not be buffer-local",
1623 SDATA (SYMBOL_NAME (variable
)));
1625 if (blv
? blv
->local_if_set
1626 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1628 tem
= Fboundp (variable
);
1629 /* Make sure the symbol has a local value in this particular buffer,
1630 by setting it to the same value it already has. */
1631 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1636 blv
= make_blv (sym
, forwarded
, valcontents
);
1637 sym
->redirect
= SYMBOL_LOCALIZED
;
1638 SET_SYMBOL_BLV (sym
, blv
);
1641 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1642 if (let_shadows_global_binding_p (symbol
))
1643 message ("Making %s local to %s while let-bound!",
1644 SDATA (SYMBOL_NAME (variable
)),
1645 SDATA (current_buffer
->name
));
1649 /* Make sure this buffer has its own value of symbol. */
1650 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1651 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1654 if (let_shadows_buffer_binding_p (sym
))
1655 message ("Making %s buffer-local while locally let-bound!",
1656 SDATA (SYMBOL_NAME (variable
)));
1658 /* Swap out any local binding for some other buffer, and make
1659 sure the current value is permanently recorded, if it's the
1661 find_symbol_value (variable
);
1663 current_buffer
->local_var_alist
1664 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1665 current_buffer
->local_var_alist
);
1667 /* Make sure symbol does not think it is set up for this buffer;
1668 force it to look once again for this buffer's value. */
1669 if (current_buffer
== XBUFFER (blv
->where
))
1671 /* blv->valcell = blv->defcell;
1672 * SET_BLV_FOUND (blv, 0); */
1676 /* If the symbol forwards into a C variable, then load the binding
1677 for this buffer now. If C code modifies the variable before we
1678 load the binding in, then that new value will clobber the default
1679 binding the next time we unload it. */
1681 swap_in_symval_forwarding (sym
, blv
);
1686 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1687 1, 1, "vKill Local Variable: ",
1688 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1689 From now on the default value will apply in this buffer. Return VARIABLE. */)
1690 (register Lisp_Object variable
)
1692 register Lisp_Object tem
;
1693 struct Lisp_Buffer_Local_Value
*blv
;
1694 struct Lisp_Symbol
*sym
;
1696 CHECK_SYMBOL (variable
);
1697 sym
= XSYMBOL (variable
);
1700 switch (sym
->redirect
)
1702 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1703 case SYMBOL_PLAINVAL
: return variable
;
1704 case SYMBOL_FORWARDED
:
1706 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1707 if (BUFFER_OBJFWDP (valcontents
))
1709 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1710 int idx
= PER_BUFFER_IDX (offset
);
1714 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1715 PER_BUFFER_VALUE (current_buffer
, offset
)
1716 = PER_BUFFER_DEFAULT (offset
);
1721 case SYMBOL_LOCALIZED
:
1722 blv
= SYMBOL_BLV (sym
);
1723 if (blv
->frame_local
)
1729 /* Get rid of this buffer's alist element, if any. */
1730 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1731 tem
= Fassq (variable
, current_buffer
->local_var_alist
);
1733 current_buffer
->local_var_alist
1734 = Fdelq (tem
, current_buffer
->local_var_alist
);
1736 /* If the symbol is set up with the current buffer's binding
1737 loaded, recompute its value. We have to do it now, or else
1738 forwarded objects won't work right. */
1740 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1741 if (EQ (buf
, blv
->where
))
1744 /* blv->valcell = blv->defcell;
1745 * SET_BLV_FOUND (blv, 0); */
1747 find_symbol_value (variable
);
1754 /* Lisp functions for creating and removing buffer-local variables. */
1756 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1757 when/if this is removed. */
1759 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1760 1, 1, "vMake Variable Frame Local: ",
1761 doc
: /* Enable VARIABLE to have frame-local bindings.
1762 This does not create any frame-local bindings for VARIABLE,
1763 it just makes them possible.
1765 A frame-local binding is actually a frame parameter value.
1766 If a frame F has a value for the frame parameter named VARIABLE,
1767 that also acts as a frame-local binding for VARIABLE in F--
1768 provided this function has been called to enable VARIABLE
1769 to have frame-local bindings at all.
1771 The only way to create a frame-local binding for VARIABLE in a frame
1772 is to set the VARIABLE frame parameter of that frame. See
1773 `modify-frame-parameters' for how to set frame parameters.
1775 Note that since Emacs 23.1, variables cannot be both buffer-local and
1776 frame-local any more (buffer-local bindings used to take precedence over
1777 frame-local bindings). */)
1778 (register Lisp_Object variable
)
1781 union Lisp_Val_Fwd valcontents
;
1782 struct Lisp_Symbol
*sym
;
1783 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1785 CHECK_SYMBOL (variable
);
1786 sym
= XSYMBOL (variable
);
1789 switch (sym
->redirect
)
1791 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1792 case SYMBOL_PLAINVAL
:
1793 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1794 if (EQ (valcontents
.value
, Qunbound
))
1795 valcontents
.value
= Qnil
;
1797 case SYMBOL_LOCALIZED
:
1798 if (SYMBOL_BLV (sym
)->frame_local
)
1801 error ("Symbol %s may not be frame-local",
1802 SDATA (SYMBOL_NAME (variable
)));
1803 case SYMBOL_FORWARDED
:
1804 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1805 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1806 error ("Symbol %s may not be frame-local",
1807 SDATA (SYMBOL_NAME (variable
)));
1813 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1815 blv
= make_blv (sym
, forwarded
, valcontents
);
1816 blv
->frame_local
= 1;
1817 sym
->redirect
= SYMBOL_LOCALIZED
;
1818 SET_SYMBOL_BLV (sym
, blv
);
1821 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1822 if (let_shadows_global_binding_p (symbol
))
1823 message ("Making %s frame-local while let-bound!",
1824 SDATA (SYMBOL_NAME (variable
)));
1829 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1831 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1832 BUFFER defaults to the current buffer. */)
1833 (register Lisp_Object variable
, Lisp_Object buffer
)
1835 register struct buffer
*buf
;
1836 struct Lisp_Symbol
*sym
;
1839 buf
= current_buffer
;
1842 CHECK_BUFFER (buffer
);
1843 buf
= XBUFFER (buffer
);
1846 CHECK_SYMBOL (variable
);
1847 sym
= XSYMBOL (variable
);
1850 switch (sym
->redirect
)
1852 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1853 case SYMBOL_PLAINVAL
: return Qnil
;
1854 case SYMBOL_LOCALIZED
:
1856 Lisp_Object tail
, elt
, tmp
;
1857 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1858 XSETBUFFER (tmp
, buf
);
1859 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1861 for (tail
= buf
->local_var_alist
; CONSP (tail
); tail
= XCDR (tail
))
1864 if (EQ (variable
, XCAR (elt
)))
1866 eassert (!blv
->frame_local
);
1867 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1871 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1874 case SYMBOL_FORWARDED
:
1876 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1877 if (BUFFER_OBJFWDP (valcontents
))
1879 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1880 int idx
= PER_BUFFER_IDX (offset
);
1881 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1890 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1892 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1893 More precisely, this means that setting the variable \(with `set' or`setq'),
1894 while it does not have a `let'-style binding that was made in BUFFER,
1895 will produce a buffer local binding. See Info node
1896 `(elisp)Creating Buffer-Local'.
1897 BUFFER defaults to the current buffer. */)
1898 (register Lisp_Object variable
, Lisp_Object buffer
)
1900 struct Lisp_Symbol
*sym
;
1902 CHECK_SYMBOL (variable
);
1903 sym
= XSYMBOL (variable
);
1906 switch (sym
->redirect
)
1908 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1909 case SYMBOL_PLAINVAL
: return Qnil
;
1910 case SYMBOL_LOCALIZED
:
1912 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1913 if (blv
->local_if_set
)
1915 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1916 return Flocal_variable_p (variable
, buffer
);
1918 case SYMBOL_FORWARDED
:
1919 /* All BUFFER_OBJFWD slots become local if they are set. */
1920 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1925 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1927 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1928 If the current binding is buffer-local, the value is the current buffer.
1929 If the current binding is frame-local, the value is the selected frame.
1930 If the current binding is global (the default), the value is nil. */)
1931 (register Lisp_Object variable
)
1933 struct Lisp_Symbol
*sym
;
1935 CHECK_SYMBOL (variable
);
1936 sym
= XSYMBOL (variable
);
1938 /* Make sure the current binding is actually swapped in. */
1939 find_symbol_value (variable
);
1942 switch (sym
->redirect
)
1944 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1945 case SYMBOL_PLAINVAL
: return Qnil
;
1946 case SYMBOL_FORWARDED
:
1948 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1949 if (KBOARD_OBJFWDP (valcontents
))
1950 return Fframe_terminal (Fselected_frame ());
1951 else if (!BUFFER_OBJFWDP (valcontents
))
1955 case SYMBOL_LOCALIZED
:
1956 /* For a local variable, record both the symbol and which
1957 buffer's or frame's value we are saving. */
1958 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1959 return Fcurrent_buffer ();
1960 else if (sym
->redirect
== SYMBOL_LOCALIZED
1961 && BLV_FOUND (SYMBOL_BLV (sym
)))
1962 return SYMBOL_BLV (sym
)->where
;
1969 /* This code is disabled now that we use the selected frame to return
1970 keyboard-local-values. */
1972 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1974 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1975 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1976 If SYMBOL is not a terminal-local variable, then return its normal
1977 value, like `symbol-value'.
1979 TERMINAL may be a terminal object, a frame, or nil (meaning the
1980 selected frame's terminal device). */)
1981 (Lisp_Object symbol
, Lisp_Object terminal
)
1984 struct terminal
*t
= get_terminal (terminal
, 1);
1985 push_kboard (t
->kboard
);
1986 result
= Fsymbol_value (symbol
);
1991 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1992 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1993 If VARIABLE is not a terminal-local variable, then set its normal
1994 binding, like `set'.
1996 TERMINAL may be a terminal object, a frame, or nil (meaning the
1997 selected frame's terminal device). */)
1998 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2001 struct terminal
*t
= get_terminal (terminal
, 1);
2002 push_kboard (d
->kboard
);
2003 result
= Fset (symbol
, value
);
2009 /* Find the function at the end of a chain of symbol function indirections. */
2011 /* If OBJECT is a symbol, find the end of its function chain and
2012 return the value found there. If OBJECT is not a symbol, just
2013 return it. If there is a cycle in the function chain, signal a
2014 cyclic-function-indirection error.
2016 This is like Findirect_function, except that it doesn't signal an
2017 error if the chain ends up unbound. */
2019 indirect_function (register Lisp_Object object
)
2021 Lisp_Object tortoise
, hare
;
2023 hare
= tortoise
= object
;
2027 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2029 hare
= XSYMBOL (hare
)->function
;
2030 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2032 hare
= XSYMBOL (hare
)->function
;
2034 tortoise
= XSYMBOL (tortoise
)->function
;
2036 if (EQ (hare
, tortoise
))
2037 xsignal1 (Qcyclic_function_indirection
, object
);
2043 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2044 doc
: /* Return the function at the end of OBJECT's function chain.
2045 If OBJECT is not a symbol, just return it. Otherwise, follow all
2046 function indirections to find the final function binding and return it.
2047 If the final symbol in the chain is unbound, signal a void-function error.
2048 Optional arg NOERROR non-nil means to return nil instead of signalling.
2049 Signal a cyclic-function-indirection error if there is a loop in the
2050 function chain of symbols. */)
2051 (register Lisp_Object object
, Lisp_Object noerror
)
2055 /* Optimize for no indirection. */
2057 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2058 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2059 result
= indirect_function (result
);
2060 if (!EQ (result
, Qunbound
))
2064 xsignal1 (Qvoid_function
, object
);
2069 /* Extract and set vector and string elements */
2071 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2072 doc
: /* Return the element of ARRAY at index IDX.
2073 ARRAY may be a vector, a string, a char-table, a bool-vector,
2074 or a byte-code object. IDX starts at 0. */)
2075 (register Lisp_Object array
, Lisp_Object idx
)
2077 register EMACS_INT idxval
;
2080 idxval
= XINT (idx
);
2081 if (STRINGP (array
))
2084 EMACS_INT idxval_byte
;
2086 if (idxval
< 0 || idxval
>= SCHARS (array
))
2087 args_out_of_range (array
, idx
);
2088 if (! STRING_MULTIBYTE (array
))
2089 return make_number ((unsigned char) SREF (array
, idxval
));
2090 idxval_byte
= string_char_to_byte (array
, idxval
);
2092 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2093 return make_number (c
);
2095 else if (BOOL_VECTOR_P (array
))
2099 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2100 args_out_of_range (array
, idx
);
2102 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2103 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2105 else if (CHAR_TABLE_P (array
))
2107 CHECK_CHARACTER (idx
);
2108 return CHAR_TABLE_REF (array
, idxval
);
2113 if (VECTORP (array
))
2114 size
= ASIZE (array
);
2115 else if (FUNVECP (array
))
2116 size
= FUNVEC_SIZE (array
);
2118 wrong_type_argument (Qarrayp
, array
);
2120 if (idxval
< 0 || idxval
>= size
)
2121 args_out_of_range (array
, idx
);
2122 return AREF (array
, idxval
);
2126 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2127 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2128 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2129 bool-vector. IDX starts at 0. */)
2130 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2132 register EMACS_INT idxval
;
2135 idxval
= XINT (idx
);
2136 CHECK_ARRAY (array
, Qarrayp
);
2137 CHECK_IMPURE (array
);
2139 if (VECTORP (array
))
2141 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2142 args_out_of_range (array
, idx
);
2143 XVECTOR (array
)->contents
[idxval
] = newelt
;
2145 else if (BOOL_VECTOR_P (array
))
2149 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2150 args_out_of_range (array
, idx
);
2152 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2154 if (! NILP (newelt
))
2155 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2157 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2158 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2160 else if (CHAR_TABLE_P (array
))
2162 CHECK_CHARACTER (idx
);
2163 CHAR_TABLE_SET (array
, idxval
, newelt
);
2165 else if (STRING_MULTIBYTE (array
))
2167 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2168 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2170 if (idxval
< 0 || idxval
>= SCHARS (array
))
2171 args_out_of_range (array
, idx
);
2172 CHECK_CHARACTER (newelt
);
2174 nbytes
= SBYTES (array
);
2176 idxval_byte
= string_char_to_byte (array
, idxval
);
2177 p1
= SDATA (array
) + idxval_byte
;
2178 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2179 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2180 if (prev_bytes
!= new_bytes
)
2182 /* We must relocate the string data. */
2183 EMACS_INT nchars
= SCHARS (array
);
2187 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2188 memcpy (str
, SDATA (array
), nbytes
);
2189 allocate_string_data (XSTRING (array
), nchars
,
2190 nbytes
+ new_bytes
- prev_bytes
);
2191 memcpy (SDATA (array
), str
, idxval_byte
);
2192 p1
= SDATA (array
) + idxval_byte
;
2193 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2194 nbytes
- (idxval_byte
+ prev_bytes
));
2196 clear_string_char_byte_cache ();
2203 if (idxval
< 0 || idxval
>= SCHARS (array
))
2204 args_out_of_range (array
, idx
);
2205 CHECK_NUMBER (newelt
);
2207 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2211 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2212 if (SREF (array
, i
) >= 0x80)
2213 args_out_of_range (array
, newelt
);
2214 /* ARRAY is an ASCII string. Convert it to a multibyte
2215 string, and try `aset' again. */
2216 STRING_SET_MULTIBYTE (array
);
2217 return Faset (array
, idx
, newelt
);
2219 SSET (array
, idxval
, XINT (newelt
));
2225 /* Arithmetic functions */
2227 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2230 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2232 double f1
= 0, f2
= 0;
2235 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2236 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2238 if (FLOATP (num1
) || FLOATP (num2
))
2241 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2242 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : XINT (num2
);
2248 if (floatp
? f1
== f2
: XINT (num1
) == XINT (num2
))
2253 if (floatp
? f1
!= f2
: XINT (num1
) != XINT (num2
))
2258 if (floatp
? f1
< f2
: XINT (num1
) < XINT (num2
))
2263 if (floatp
? f1
<= f2
: XINT (num1
) <= XINT (num2
))
2268 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2273 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2282 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2283 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2284 (register Lisp_Object num1
, Lisp_Object num2
)
2286 return arithcompare (num1
, num2
, equal
);
2289 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2290 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2291 (register Lisp_Object num1
, Lisp_Object num2
)
2293 return arithcompare (num1
, num2
, less
);
2296 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2297 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2298 (register Lisp_Object num1
, Lisp_Object num2
)
2300 return arithcompare (num1
, num2
, grtr
);
2303 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2304 doc
: /* Return t if first arg is less 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
, less_or_equal
);
2311 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2312 doc
: /* Return t if first arg is greater than or equal to second arg.
2313 Both must be numbers or markers. */)
2314 (register Lisp_Object num1
, Lisp_Object num2
)
2316 return arithcompare (num1
, num2
, grtr_or_equal
);
2319 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2320 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2321 (register Lisp_Object num1
, Lisp_Object num2
)
2323 return arithcompare (num1
, num2
, notequal
);
2326 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2327 doc
: /* Return t if NUMBER is zero. */)
2328 (register Lisp_Object number
)
2330 CHECK_NUMBER_OR_FLOAT (number
);
2332 if (FLOATP (number
))
2334 if (XFLOAT_DATA (number
) == 0.0)
2344 /* Convert between long values and pairs of Lisp integers.
2345 Note that long_to_cons returns a single Lisp integer
2346 when the value fits in one. */
2349 long_to_cons (long unsigned int i
)
2351 unsigned long top
= i
>> 16;
2352 unsigned int bot
= i
& 0xFFFF;
2354 return make_number (bot
);
2355 if (top
== (unsigned long)-1 >> 16)
2356 return Fcons (make_number (-1), make_number (bot
));
2357 return Fcons (make_number (top
), make_number (bot
));
2361 cons_to_long (Lisp_Object c
)
2363 Lisp_Object top
, bot
;
2370 return ((XINT (top
) << 16) | XINT (bot
));
2373 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2374 doc
: /* Return the decimal representation of NUMBER as a string.
2375 Uses a minus sign if negative.
2376 NUMBER may be an integer or a floating point number. */)
2377 (Lisp_Object number
)
2379 char buffer
[VALBITS
];
2381 CHECK_NUMBER_OR_FLOAT (number
);
2383 if (FLOATP (number
))
2385 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2387 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2388 return build_string (pigbuf
);
2391 if (sizeof (int) == sizeof (EMACS_INT
))
2392 sprintf (buffer
, "%d", (int) XINT (number
));
2393 else if (sizeof (long) == sizeof (EMACS_INT
))
2394 sprintf (buffer
, "%ld", (long) XINT (number
));
2397 return build_string (buffer
);
2401 digit_to_number (int character
, int base
)
2405 if (character
>= '0' && character
<= '9')
2406 digit
= character
- '0';
2407 else if (character
>= 'a' && character
<= 'z')
2408 digit
= character
- 'a' + 10;
2409 else if (character
>= 'A' && character
<= 'Z')
2410 digit
= character
- 'A' + 10;
2420 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2421 doc
: /* Parse STRING as a decimal number and return the number.
2422 This parses both integers and floating point numbers.
2423 It ignores leading spaces and tabs, and all trailing chars.
2425 If BASE, interpret STRING as a number in that base. If BASE isn't
2426 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2427 If the base used is not 10, STRING is always parsed as integer. */)
2428 (register Lisp_Object string
, Lisp_Object base
)
2435 CHECK_STRING (string
);
2441 CHECK_NUMBER (base
);
2443 if (b
< 2 || b
> 16)
2444 xsignal1 (Qargs_out_of_range
, base
);
2447 /* Skip any whitespace at the front of the number. Some versions of
2448 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2449 p
= SSDATA (string
);
2450 while (*p
== ' ' || *p
== '\t')
2461 if (isfloat_string (p
, 1) && b
== 10)
2462 val
= make_float (sign
* atof (p
));
2469 int digit
= digit_to_number (*p
++, b
);
2475 val
= make_fixnum_or_float (sign
* v
);
2495 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2496 int, Lisp_Object
*);
2498 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2500 register Lisp_Object val
;
2501 register int argnum
;
2502 register EMACS_INT accum
= 0;
2503 register EMACS_INT next
;
2505 switch (SWITCH_ENUM_CAST (code
))
2523 for (argnum
= 0; argnum
< nargs
; argnum
++)
2525 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2527 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2530 return float_arith_driver ((double) accum
, argnum
, code
,
2533 next
= XINT (args
[argnum
]);
2534 switch (SWITCH_ENUM_CAST (code
))
2540 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2551 xsignal0 (Qarith_error
);
2565 if (!argnum
|| next
> accum
)
2569 if (!argnum
|| next
< accum
)
2575 XSETINT (val
, accum
);
2580 #define isnan(x) ((x) != (x))
2583 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2585 register Lisp_Object val
;
2588 for (; argnum
< nargs
; argnum
++)
2590 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2591 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2595 next
= XFLOAT_DATA (val
);
2599 args
[argnum
] = val
; /* runs into a compiler bug. */
2600 next
= XINT (args
[argnum
]);
2602 switch (SWITCH_ENUM_CAST (code
))
2608 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2618 if (! IEEE_FLOATING_POINT
&& next
== 0)
2619 xsignal0 (Qarith_error
);
2626 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2628 if (!argnum
|| isnan (next
) || next
> accum
)
2632 if (!argnum
|| isnan (next
) || next
< accum
)
2638 return make_float (accum
);
2642 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2643 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2644 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2645 (int nargs
, Lisp_Object
*args
)
2647 return arith_driver (Aadd
, nargs
, args
);
2650 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2651 doc
: /* Negate number or subtract numbers or markers and return the result.
2652 With one arg, negates it. With more than one arg,
2653 subtracts all but the first from the first.
2654 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2655 (int nargs
, Lisp_Object
*args
)
2657 return arith_driver (Asub
, nargs
, args
);
2660 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2661 doc
: /* Return product of any number of arguments, which are numbers or markers.
2662 usage: (* &rest NUMBERS-OR-MARKERS) */)
2663 (int nargs
, Lisp_Object
*args
)
2665 return arith_driver (Amult
, nargs
, args
);
2668 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2669 doc
: /* Return first argument divided by all the remaining arguments.
2670 The arguments must be numbers or markers.
2671 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2672 (int nargs
, Lisp_Object
*args
)
2675 for (argnum
= 2; argnum
< nargs
; argnum
++)
2676 if (FLOATP (args
[argnum
]))
2677 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2678 return arith_driver (Adiv
, nargs
, args
);
2681 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2682 doc
: /* Return remainder of X divided by Y.
2683 Both must be integers or markers. */)
2684 (register Lisp_Object x
, Lisp_Object y
)
2688 CHECK_NUMBER_COERCE_MARKER (x
);
2689 CHECK_NUMBER_COERCE_MARKER (y
);
2691 if (XFASTINT (y
) == 0)
2692 xsignal0 (Qarith_error
);
2694 XSETINT (val
, XINT (x
) % XINT (y
));
2708 /* If the magnitude of the result exceeds that of the divisor, or
2709 the sign of the result does not agree with that of the dividend,
2710 iterate with the reduced value. This does not yield a
2711 particularly accurate result, but at least it will be in the
2712 range promised by fmod. */
2714 r
-= f2
* floor (r
/ f2
);
2715 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2719 #endif /* ! HAVE_FMOD */
2721 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2722 doc
: /* Return X modulo Y.
2723 The result falls between zero (inclusive) and Y (exclusive).
2724 Both X and Y must be numbers or markers. */)
2725 (register Lisp_Object x
, Lisp_Object y
)
2730 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2731 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2733 if (FLOATP (x
) || FLOATP (y
))
2734 return fmod_float (x
, y
);
2740 xsignal0 (Qarith_error
);
2744 /* If the "remainder" comes out with the wrong sign, fix it. */
2745 if (i2
< 0 ? i1
> 0 : i1
< 0)
2752 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2753 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2754 The value is always a number; markers are converted to numbers.
2755 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2756 (int nargs
, Lisp_Object
*args
)
2758 return arith_driver (Amax
, nargs
, args
);
2761 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2762 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2763 The value is always a number; markers are converted to numbers.
2764 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2765 (int nargs
, Lisp_Object
*args
)
2767 return arith_driver (Amin
, nargs
, args
);
2770 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2771 doc
: /* Return bitwise-and of all the arguments.
2772 Arguments may be integers, or markers converted to integers.
2773 usage: (logand &rest INTS-OR-MARKERS) */)
2774 (int nargs
, Lisp_Object
*args
)
2776 return arith_driver (Alogand
, nargs
, args
);
2779 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2780 doc
: /* Return bitwise-or of all the arguments.
2781 Arguments may be integers, or markers converted to integers.
2782 usage: (logior &rest INTS-OR-MARKERS) */)
2783 (int nargs
, Lisp_Object
*args
)
2785 return arith_driver (Alogior
, nargs
, args
);
2788 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2789 doc
: /* Return bitwise-exclusive-or of all the arguments.
2790 Arguments may be integers, or markers converted to integers.
2791 usage: (logxor &rest INTS-OR-MARKERS) */)
2792 (int nargs
, Lisp_Object
*args
)
2794 return arith_driver (Alogxor
, nargs
, args
);
2797 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2798 doc
: /* Return VALUE with its bits shifted left by COUNT.
2799 If COUNT is negative, shifting is actually to the right.
2800 In this case, the sign bit is duplicated. */)
2801 (register Lisp_Object value
, Lisp_Object count
)
2803 register Lisp_Object val
;
2805 CHECK_NUMBER (value
);
2806 CHECK_NUMBER (count
);
2808 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2810 else if (XINT (count
) > 0)
2811 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2812 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2813 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2815 XSETINT (val
, XINT (value
) >> -XINT (count
));
2819 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2820 doc
: /* Return VALUE with its bits shifted left by COUNT.
2821 If COUNT is negative, shifting is actually to the right.
2822 In this case, zeros are shifted in on the left. */)
2823 (register Lisp_Object value
, Lisp_Object count
)
2825 register Lisp_Object val
;
2827 CHECK_NUMBER (value
);
2828 CHECK_NUMBER (count
);
2830 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2832 else if (XINT (count
) > 0)
2833 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2834 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2837 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2841 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2842 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2843 Markers are converted to integers. */)
2844 (register Lisp_Object number
)
2846 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2848 if (FLOATP (number
))
2849 return (make_float (1.0 + XFLOAT_DATA (number
)));
2851 XSETINT (number
, XINT (number
) + 1);
2855 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2856 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2857 Markers are converted to integers. */)
2858 (register Lisp_Object number
)
2860 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2862 if (FLOATP (number
))
2863 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2865 XSETINT (number
, XINT (number
) - 1);
2869 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2870 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2871 (register Lisp_Object number
)
2873 CHECK_NUMBER (number
);
2874 XSETINT (number
, ~XINT (number
));
2878 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2879 doc
: /* Return the byteorder for the machine.
2880 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2881 lowercase l) for small endian machines. */)
2884 unsigned i
= 0x04030201;
2885 int order
= *(char *)&i
== 1 ? 108 : 66;
2887 return make_number (order
);
2895 Lisp_Object error_tail
, arith_tail
;
2897 Qquote
= intern_c_string ("quote");
2898 Qlambda
= intern_c_string ("lambda");
2899 Qsubr
= intern_c_string ("subr");
2900 Qerror_conditions
= intern_c_string ("error-conditions");
2901 Qerror_message
= intern_c_string ("error-message");
2902 Qtop_level
= intern_c_string ("top-level");
2904 Qerror
= intern_c_string ("error");
2905 Qquit
= intern_c_string ("quit");
2906 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2907 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2908 Qvoid_function
= intern_c_string ("void-function");
2909 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2910 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2911 Qvoid_variable
= intern_c_string ("void-variable");
2912 Qsetting_constant
= intern_c_string ("setting-constant");
2913 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2915 Qinvalid_function
= intern_c_string ("invalid-function");
2916 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2917 Qno_catch
= intern_c_string ("no-catch");
2918 Qend_of_file
= intern_c_string ("end-of-file");
2919 Qarith_error
= intern_c_string ("arith-error");
2920 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2921 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2922 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2923 Qtext_read_only
= intern_c_string ("text-read-only");
2924 Qmark_inactive
= intern_c_string ("mark-inactive");
2926 Qlistp
= intern_c_string ("listp");
2927 Qconsp
= intern_c_string ("consp");
2928 Qsymbolp
= intern_c_string ("symbolp");
2929 Qkeywordp
= intern_c_string ("keywordp");
2930 Qintegerp
= intern_c_string ("integerp");
2931 Qnatnump
= intern_c_string ("natnump");
2932 Qwholenump
= intern_c_string ("wholenump");
2933 Qstringp
= intern_c_string ("stringp");
2934 Qarrayp
= intern_c_string ("arrayp");
2935 Qsequencep
= intern_c_string ("sequencep");
2936 Qbufferp
= intern_c_string ("bufferp");
2937 Qvectorp
= intern_c_string ("vectorp");
2938 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2939 Qmarkerp
= intern_c_string ("markerp");
2940 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2941 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2942 Qboundp
= intern_c_string ("boundp");
2943 Qfboundp
= intern_c_string ("fboundp");
2945 Qfloatp
= intern_c_string ("floatp");
2946 Qnumberp
= intern_c_string ("numberp");
2947 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2949 Qchar_table_p
= intern_c_string ("char-table-p");
2950 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2952 Qsubrp
= intern_c_string ("subrp");
2953 Qunevalled
= intern_c_string ("unevalled");
2954 Qmany
= intern_c_string ("many");
2956 Qcdr
= intern_c_string ("cdr");
2958 /* Handle automatic advice activation */
2959 Qad_advice_info
= intern_c_string ("ad-advice-info");
2960 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2962 error_tail
= pure_cons (Qerror
, Qnil
);
2964 /* ERROR is used as a signaler for random errors for which nothing else is right */
2966 Fput (Qerror
, Qerror_conditions
,
2968 Fput (Qerror
, Qerror_message
,
2969 make_pure_c_string ("error"));
2971 Fput (Qquit
, Qerror_conditions
,
2972 pure_cons (Qquit
, Qnil
));
2973 Fput (Qquit
, Qerror_message
,
2974 make_pure_c_string ("Quit"));
2976 Fput (Qwrong_type_argument
, Qerror_conditions
,
2977 pure_cons (Qwrong_type_argument
, error_tail
));
2978 Fput (Qwrong_type_argument
, Qerror_message
,
2979 make_pure_c_string ("Wrong type argument"));
2981 Fput (Qargs_out_of_range
, Qerror_conditions
,
2982 pure_cons (Qargs_out_of_range
, error_tail
));
2983 Fput (Qargs_out_of_range
, Qerror_message
,
2984 make_pure_c_string ("Args out of range"));
2986 Fput (Qvoid_function
, Qerror_conditions
,
2987 pure_cons (Qvoid_function
, error_tail
));
2988 Fput (Qvoid_function
, Qerror_message
,
2989 make_pure_c_string ("Symbol's function definition is void"));
2991 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2992 pure_cons (Qcyclic_function_indirection
, error_tail
));
2993 Fput (Qcyclic_function_indirection
, Qerror_message
,
2994 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2996 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2997 pure_cons (Qcyclic_variable_indirection
, error_tail
));
2998 Fput (Qcyclic_variable_indirection
, Qerror_message
,
2999 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3001 Qcircular_list
= intern_c_string ("circular-list");
3002 staticpro (&Qcircular_list
);
3003 Fput (Qcircular_list
, Qerror_conditions
,
3004 pure_cons (Qcircular_list
, error_tail
));
3005 Fput (Qcircular_list
, Qerror_message
,
3006 make_pure_c_string ("List contains a loop"));
3008 Fput (Qvoid_variable
, Qerror_conditions
,
3009 pure_cons (Qvoid_variable
, error_tail
));
3010 Fput (Qvoid_variable
, Qerror_message
,
3011 make_pure_c_string ("Symbol's value as variable is void"));
3013 Fput (Qsetting_constant
, Qerror_conditions
,
3014 pure_cons (Qsetting_constant
, error_tail
));
3015 Fput (Qsetting_constant
, Qerror_message
,
3016 make_pure_c_string ("Attempt to set a constant symbol"));
3018 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3019 pure_cons (Qinvalid_read_syntax
, error_tail
));
3020 Fput (Qinvalid_read_syntax
, Qerror_message
,
3021 make_pure_c_string ("Invalid read syntax"));
3023 Fput (Qinvalid_function
, Qerror_conditions
,
3024 pure_cons (Qinvalid_function
, error_tail
));
3025 Fput (Qinvalid_function
, Qerror_message
,
3026 make_pure_c_string ("Invalid function"));
3028 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3029 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3030 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3031 make_pure_c_string ("Wrong number of arguments"));
3033 Fput (Qno_catch
, Qerror_conditions
,
3034 pure_cons (Qno_catch
, error_tail
));
3035 Fput (Qno_catch
, Qerror_message
,
3036 make_pure_c_string ("No catch for tag"));
3038 Fput (Qend_of_file
, Qerror_conditions
,
3039 pure_cons (Qend_of_file
, error_tail
));
3040 Fput (Qend_of_file
, Qerror_message
,
3041 make_pure_c_string ("End of file during parsing"));
3043 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3044 Fput (Qarith_error
, Qerror_conditions
,
3046 Fput (Qarith_error
, Qerror_message
,
3047 make_pure_c_string ("Arithmetic error"));
3049 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3050 pure_cons (Qbeginning_of_buffer
, error_tail
));
3051 Fput (Qbeginning_of_buffer
, Qerror_message
,
3052 make_pure_c_string ("Beginning of buffer"));
3054 Fput (Qend_of_buffer
, Qerror_conditions
,
3055 pure_cons (Qend_of_buffer
, error_tail
));
3056 Fput (Qend_of_buffer
, Qerror_message
,
3057 make_pure_c_string ("End of buffer"));
3059 Fput (Qbuffer_read_only
, Qerror_conditions
,
3060 pure_cons (Qbuffer_read_only
, error_tail
));
3061 Fput (Qbuffer_read_only
, Qerror_message
,
3062 make_pure_c_string ("Buffer is read-only"));
3064 Fput (Qtext_read_only
, Qerror_conditions
,
3065 pure_cons (Qtext_read_only
, error_tail
));
3066 Fput (Qtext_read_only
, Qerror_message
,
3067 make_pure_c_string ("Text is read-only"));
3069 Qrange_error
= intern_c_string ("range-error");
3070 Qdomain_error
= intern_c_string ("domain-error");
3071 Qsingularity_error
= intern_c_string ("singularity-error");
3072 Qoverflow_error
= intern_c_string ("overflow-error");
3073 Qunderflow_error
= intern_c_string ("underflow-error");
3075 Fput (Qdomain_error
, Qerror_conditions
,
3076 pure_cons (Qdomain_error
, arith_tail
));
3077 Fput (Qdomain_error
, Qerror_message
,
3078 make_pure_c_string ("Arithmetic domain error"));
3080 Fput (Qrange_error
, Qerror_conditions
,
3081 pure_cons (Qrange_error
, arith_tail
));
3082 Fput (Qrange_error
, Qerror_message
,
3083 make_pure_c_string ("Arithmetic range error"));
3085 Fput (Qsingularity_error
, Qerror_conditions
,
3086 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3087 Fput (Qsingularity_error
, Qerror_message
,
3088 make_pure_c_string ("Arithmetic singularity error"));
3090 Fput (Qoverflow_error
, Qerror_conditions
,
3091 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3092 Fput (Qoverflow_error
, Qerror_message
,
3093 make_pure_c_string ("Arithmetic overflow error"));
3095 Fput (Qunderflow_error
, Qerror_conditions
,
3096 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3097 Fput (Qunderflow_error
, Qerror_message
,
3098 make_pure_c_string ("Arithmetic underflow error"));
3100 staticpro (&Qrange_error
);
3101 staticpro (&Qdomain_error
);
3102 staticpro (&Qsingularity_error
);
3103 staticpro (&Qoverflow_error
);
3104 staticpro (&Qunderflow_error
);
3108 staticpro (&Qquote
);
3109 staticpro (&Qlambda
);
3111 staticpro (&Qunbound
);
3112 staticpro (&Qerror_conditions
);
3113 staticpro (&Qerror_message
);
3114 staticpro (&Qtop_level
);
3116 staticpro (&Qerror
);
3118 staticpro (&Qwrong_type_argument
);
3119 staticpro (&Qargs_out_of_range
);
3120 staticpro (&Qvoid_function
);
3121 staticpro (&Qcyclic_function_indirection
);
3122 staticpro (&Qcyclic_variable_indirection
);
3123 staticpro (&Qvoid_variable
);
3124 staticpro (&Qsetting_constant
);
3125 staticpro (&Qinvalid_read_syntax
);
3126 staticpro (&Qwrong_number_of_arguments
);
3127 staticpro (&Qinvalid_function
);
3128 staticpro (&Qno_catch
);
3129 staticpro (&Qend_of_file
);
3130 staticpro (&Qarith_error
);
3131 staticpro (&Qbeginning_of_buffer
);
3132 staticpro (&Qend_of_buffer
);
3133 staticpro (&Qbuffer_read_only
);
3134 staticpro (&Qtext_read_only
);
3135 staticpro (&Qmark_inactive
);
3137 staticpro (&Qlistp
);
3138 staticpro (&Qconsp
);
3139 staticpro (&Qsymbolp
);
3140 staticpro (&Qkeywordp
);
3141 staticpro (&Qintegerp
);
3142 staticpro (&Qnatnump
);
3143 staticpro (&Qwholenump
);
3144 staticpro (&Qstringp
);
3145 staticpro (&Qarrayp
);
3146 staticpro (&Qsequencep
);
3147 staticpro (&Qbufferp
);
3148 staticpro (&Qvectorp
);
3149 staticpro (&Qchar_or_string_p
);
3150 staticpro (&Qmarkerp
);
3151 staticpro (&Qbuffer_or_string_p
);
3152 staticpro (&Qinteger_or_marker_p
);
3153 staticpro (&Qfloatp
);
3154 staticpro (&Qnumberp
);
3155 staticpro (&Qnumber_or_marker_p
);
3156 staticpro (&Qchar_table_p
);
3157 staticpro (&Qvector_or_char_table_p
);
3158 staticpro (&Qsubrp
);
3160 staticpro (&Qunevalled
);
3162 staticpro (&Qboundp
);
3163 staticpro (&Qfboundp
);
3165 staticpro (&Qad_advice_info
);
3166 staticpro (&Qad_activate_internal
);
3168 /* Types that type-of returns. */
3169 Qinteger
= intern_c_string ("integer");
3170 Qsymbol
= intern_c_string ("symbol");
3171 Qstring
= intern_c_string ("string");
3172 Qcons
= intern_c_string ("cons");
3173 Qmarker
= intern_c_string ("marker");
3174 Qoverlay
= intern_c_string ("overlay");
3175 Qfloat
= intern_c_string ("float");
3176 Qwindow_configuration
= intern_c_string ("window-configuration");
3177 Qprocess
= intern_c_string ("process");
3178 Qwindow
= intern_c_string ("window");
3179 /* Qsubr = intern_c_string ("subr"); */
3180 Qcompiled_function
= intern_c_string ("compiled-function");
3181 Qfunction_vector
= intern_c_string ("function-vector");
3182 Qbuffer
= intern_c_string ("buffer");
3183 Qframe
= intern_c_string ("frame");
3184 Qvector
= intern_c_string ("vector");
3185 Qchar_table
= intern_c_string ("char-table");
3186 Qbool_vector
= intern_c_string ("bool-vector");
3187 Qhash_table
= intern_c_string ("hash-table");
3189 DEFSYM (Qfont_spec
, "font-spec");
3190 DEFSYM (Qfont_entity
, "font-entity");
3191 DEFSYM (Qfont_object
, "font-object");
3193 DEFSYM (Qinteractive_form
, "interactive-form");
3195 staticpro (&Qinteger
);
3196 staticpro (&Qsymbol
);
3197 staticpro (&Qstring
);
3199 staticpro (&Qmarker
);
3200 staticpro (&Qoverlay
);
3201 staticpro (&Qfloat
);
3202 staticpro (&Qwindow_configuration
);
3203 staticpro (&Qprocess
);
3204 staticpro (&Qwindow
);
3205 /* staticpro (&Qsubr); */
3206 staticpro (&Qcompiled_function
);
3207 staticpro (&Qfunction_vector
);
3208 staticpro (&Qbuffer
);
3209 staticpro (&Qframe
);
3210 staticpro (&Qvector
);
3211 staticpro (&Qchar_table
);
3212 staticpro (&Qbool_vector
);
3213 staticpro (&Qhash_table
);
3215 defsubr (&Sindirect_variable
);
3216 defsubr (&Sinteractive_form
);
3219 defsubr (&Stype_of
);
3224 defsubr (&Sintegerp
);
3225 defsubr (&Sinteger_or_marker_p
);
3226 defsubr (&Snumberp
);
3227 defsubr (&Snumber_or_marker_p
);
3229 defsubr (&Snatnump
);
3230 defsubr (&Ssymbolp
);
3231 defsubr (&Skeywordp
);
3232 defsubr (&Sstringp
);
3233 defsubr (&Smultibyte_string_p
);
3234 defsubr (&Svectorp
);
3235 defsubr (&Schar_table_p
);
3236 defsubr (&Svector_or_char_table_p
);
3237 defsubr (&Sbool_vector_p
);
3239 defsubr (&Ssequencep
);
3240 defsubr (&Sbufferp
);
3241 defsubr (&Smarkerp
);
3243 defsubr (&Sbyte_code_function_p
);
3244 defsubr (&Sfunvecp
);
3245 defsubr (&Schar_or_string_p
);
3248 defsubr (&Scar_safe
);
3249 defsubr (&Scdr_safe
);
3252 defsubr (&Ssymbol_function
);
3253 defsubr (&Sindirect_function
);
3254 defsubr (&Ssymbol_plist
);
3255 defsubr (&Ssymbol_name
);
3256 defsubr (&Smakunbound
);
3257 defsubr (&Sfmakunbound
);
3259 defsubr (&Sfboundp
);
3261 defsubr (&Sdefalias
);
3262 defsubr (&Ssetplist
);
3263 defsubr (&Ssymbol_value
);
3265 defsubr (&Sdefault_boundp
);
3266 defsubr (&Sdefault_value
);
3267 defsubr (&Sset_default
);
3268 defsubr (&Ssetq_default
);
3269 defsubr (&Smake_variable_buffer_local
);
3270 defsubr (&Smake_local_variable
);
3271 defsubr (&Skill_local_variable
);
3272 defsubr (&Smake_variable_frame_local
);
3273 defsubr (&Slocal_variable_p
);
3274 defsubr (&Slocal_variable_if_set_p
);
3275 defsubr (&Svariable_binding_locus
);
3276 #if 0 /* XXX Remove this. --lorentey */
3277 defsubr (&Sterminal_local_value
);
3278 defsubr (&Sset_terminal_local_value
);
3282 defsubr (&Snumber_to_string
);
3283 defsubr (&Sstring_to_number
);
3284 defsubr (&Seqlsign
);
3307 defsubr (&Sbyteorder
);
3308 defsubr (&Ssubr_arity
);
3309 defsubr (&Ssubr_name
);
3311 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3313 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3314 doc
: /* The largest value that is representable in a Lisp integer. */);
3315 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3316 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3318 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3319 doc
: /* The smallest value that is representable in a Lisp integer. */);
3320 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3321 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3325 arith_error (int signo
)
3327 sigsetmask (SIGEMPTYMASK
);
3329 SIGNAL_THREAD_CHECK (signo
);
3330 xsignal0 (Qarith_error
);
3336 /* Don't do this if just dumping out.
3337 We don't want to call `signal' in this case
3338 so that we don't have trouble with dumping
3339 signal-delivering routines in an inconsistent state. */
3343 #endif /* CANNOT_DUMP */
3344 signal (SIGFPE
, arith_error
);
3347 signal (SIGEMT
, arith_error
);