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
, Qclosure
))
759 fun
= Fcdr (XCDR (fun
)), funcar
= Fcar (fun
);
760 if (EQ (funcar
, Qlambda
))
761 return Fassq (Qinteractive
, Fcdr (XCDR (fun
)));
762 else if (EQ (funcar
, Qautoload
))
766 do_autoload (fun
, cmd
);
768 return Finteractive_form (cmd
);
775 /***********************************************************************
776 Getting and Setting Values of Symbols
777 ***********************************************************************/
779 /* Return the symbol holding SYMBOL's value. Signal
780 `cyclic-variable-indirection' if SYMBOL's chain of variable
781 indirections contains a loop. */
784 indirect_variable (struct Lisp_Symbol
*symbol
)
786 struct Lisp_Symbol
*tortoise
, *hare
;
788 hare
= tortoise
= symbol
;
790 while (hare
->redirect
== SYMBOL_VARALIAS
)
792 hare
= SYMBOL_ALIAS (hare
);
793 if (hare
->redirect
!= SYMBOL_VARALIAS
)
796 hare
= SYMBOL_ALIAS (hare
);
797 tortoise
= SYMBOL_ALIAS (tortoise
);
799 if (hare
== tortoise
)
802 XSETSYMBOL (tem
, symbol
);
803 xsignal1 (Qcyclic_variable_indirection
, tem
);
811 DEFUN ("indirect-variable", Findirect_variable
, Sindirect_variable
, 1, 1, 0,
812 doc
: /* Return the variable at the end of OBJECT's variable chain.
813 If OBJECT is a symbol, follow all variable indirections and return the final
814 variable. If OBJECT is not a symbol, just return it.
815 Signal a cyclic-variable-indirection error if there is a loop in the
816 variable chain of symbols. */)
819 if (SYMBOLP (object
))
820 XSETSYMBOL (object
, indirect_variable (XSYMBOL (object
)));
825 /* Given the raw contents of a symbol value cell,
826 return the Lisp value of the symbol.
827 This does not handle buffer-local variables; use
828 swap_in_symval_forwarding for that. */
830 #define do_blv_forwarding(blv) \
831 ((blv)->forwarded ? do_symval_forwarding (BLV_FWD (blv)) : BLV_VALUE (blv))
834 do_symval_forwarding (register union Lisp_Fwd
*valcontents
)
836 register Lisp_Object val
;
837 switch (XFWDTYPE (valcontents
))
840 XSETINT (val
, *XINTFWD (valcontents
)->intvar
);
844 return (*XBOOLFWD (valcontents
)->boolvar
? Qt
: Qnil
);
847 return *XOBJFWD (valcontents
)->objvar
;
849 case Lisp_Fwd_Buffer_Obj
:
850 return PER_BUFFER_VALUE (current_buffer
,
851 XBUFFER_OBJFWD (valcontents
)->offset
);
853 case Lisp_Fwd_Kboard_Obj
:
854 /* We used to simply use current_kboard here, but from Lisp
855 code, it's value is often unexpected. It seems nicer to
856 allow constructions like this to work as intuitively expected:
858 (with-selected-frame frame
859 (define-key local-function-map "\eOP" [f1]))
861 On the other hand, this affects the semantics of
862 last-command and real-last-command, and people may rely on
863 that. I took a quick look at the Lisp codebase, and I
864 don't think anything will break. --lorentey */
865 return *(Lisp_Object
*)(XKBOARD_OBJFWD (valcontents
)->offset
866 + (char *)FRAME_KBOARD (SELECTED_FRAME ()));
871 /* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
872 of SYMBOL. If SYMBOL is buffer-local, VALCONTENTS should be the
873 buffer-independent contents of the value cell: forwarded just one
874 step past the buffer-localness.
876 BUF non-zero means set the value in buffer BUF instead of the
877 current buffer. This only plays a role for per-buffer variables. */
879 #define store_blv_forwarding(blv, newval, buf) \
881 if ((blv)->forwarded) \
882 store_symval_forwarding (BLV_FWD (blv), (newval), (buf)); \
884 SET_BLV_VALUE (blv, newval); \
888 store_symval_forwarding (union Lisp_Fwd
*valcontents
, register Lisp_Object newval
, struct buffer
*buf
)
890 switch (XFWDTYPE (valcontents
))
893 CHECK_NUMBER (newval
);
894 *XINTFWD (valcontents
)->intvar
= XINT (newval
);
898 *XBOOLFWD (valcontents
)->boolvar
= !NILP (newval
);
902 *XOBJFWD (valcontents
)->objvar
= newval
;
904 /* If this variable is a default for something stored
905 in the buffer itself, such as default-fill-column,
906 find the buffers that don't have local values for it
908 if (XOBJFWD (valcontents
)->objvar
> (Lisp_Object
*) &buffer_defaults
909 && XOBJFWD (valcontents
)->objvar
< (Lisp_Object
*) (&buffer_defaults
+ 1))
911 int offset
= ((char *) XOBJFWD (valcontents
)->objvar
912 - (char *) &buffer_defaults
);
913 int idx
= PER_BUFFER_IDX (offset
);
920 for (tail
= Vbuffer_alist
; CONSP (tail
); tail
= XCDR (tail
))
925 buf
= Fcdr (XCAR (tail
));
926 if (!BUFFERP (buf
)) continue;
929 if (! PER_BUFFER_VALUE_P (b
, idx
))
930 PER_BUFFER_VALUE (b
, offset
) = newval
;
935 case Lisp_Fwd_Buffer_Obj
:
937 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
938 Lisp_Object type
= XBUFFER_OBJFWD (valcontents
)->slottype
;
940 if (!(NILP (type
) || NILP (newval
)
941 || (XINT (type
) == LISP_INT_TAG
943 : XTYPE (newval
) == XINT (type
))))
944 buffer_slot_type_mismatch (newval
, XINT (type
));
947 buf
= current_buffer
;
948 PER_BUFFER_VALUE (buf
, offset
) = newval
;
952 case Lisp_Fwd_Kboard_Obj
:
954 char *base
= (char *) FRAME_KBOARD (SELECTED_FRAME ());
955 char *p
= base
+ XKBOARD_OBJFWD (valcontents
)->offset
;
956 *(Lisp_Object
*) p
= newval
;
961 abort (); /* goto def; */
965 /* Set up SYMBOL to refer to its global binding.
966 This makes it safe to alter the status of other bindings. */
969 swap_in_global_binding (struct Lisp_Symbol
*symbol
)
971 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (symbol
);
973 /* Unload the previously loaded binding. */
975 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
977 /* Select the global binding in the symbol. */
978 blv
->valcell
= blv
->defcell
;
980 store_symval_forwarding (blv
->fwd
, XCDR (blv
->defcell
), NULL
);
982 /* Indicate that the global binding is set up now. */
984 SET_BLV_FOUND (blv
, 0);
987 /* Set up the buffer-local symbol SYMBOL for validity in the current buffer.
988 VALCONTENTS is the contents of its value cell,
989 which points to a struct Lisp_Buffer_Local_Value.
991 Return the value forwarded one step past the buffer-local stage.
992 This could be another forwarding pointer. */
995 swap_in_symval_forwarding (struct Lisp_Symbol
*symbol
, struct Lisp_Buffer_Local_Value
*blv
)
997 register Lisp_Object tem1
;
999 eassert (blv
== SYMBOL_BLV (symbol
));
1004 || (blv
->frame_local
1005 ? !EQ (selected_frame
, tem1
)
1006 : current_buffer
!= XBUFFER (tem1
)))
1009 /* Unload the previously loaded binding. */
1010 tem1
= blv
->valcell
;
1012 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1013 /* Choose the new binding. */
1016 XSETSYMBOL (var
, symbol
);
1017 if (blv
->frame_local
)
1019 tem1
= assq_no_quit (var
, XFRAME (selected_frame
)->param_alist
);
1020 blv
->where
= selected_frame
;
1024 tem1
= assq_no_quit (var
, BVAR (current_buffer
, local_var_alist
));
1025 XSETBUFFER (blv
->where
, current_buffer
);
1028 if (!(blv
->found
= !NILP (tem1
)))
1029 tem1
= blv
->defcell
;
1031 /* Load the new binding. */
1032 blv
->valcell
= tem1
;
1034 store_symval_forwarding (blv
->fwd
, BLV_VALUE (blv
), NULL
);
1038 /* Find the value of a symbol, returning Qunbound if it's not bound.
1039 This is helpful for code which just wants to get a variable's value
1040 if it has one, without signaling an error.
1041 Note that it must not be possible to quit
1042 within this function. Great care is required for this. */
1045 find_symbol_value (Lisp_Object symbol
)
1047 struct Lisp_Symbol
*sym
;
1049 CHECK_SYMBOL (symbol
);
1050 sym
= XSYMBOL (symbol
);
1053 switch (sym
->redirect
)
1055 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1056 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1057 case SYMBOL_LOCALIZED
:
1059 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1060 swap_in_symval_forwarding (sym
, blv
);
1061 return blv
->fwd
? do_symval_forwarding (blv
->fwd
) : BLV_VALUE (blv
);
1064 case SYMBOL_FORWARDED
:
1065 return do_symval_forwarding (SYMBOL_FWD (sym
));
1070 DEFUN ("symbol-value", Fsymbol_value
, Ssymbol_value
, 1, 1, 0,
1071 doc
: /* Return SYMBOL's value. Error if that is void. */)
1072 (Lisp_Object symbol
)
1076 val
= find_symbol_value (symbol
);
1077 if (!EQ (val
, Qunbound
))
1080 xsignal1 (Qvoid_variable
, symbol
);
1083 DEFUN ("set", Fset
, Sset
, 2, 2, 0,
1084 doc
: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */)
1085 (register Lisp_Object symbol
, Lisp_Object newval
)
1087 set_internal (symbol
, newval
, Qnil
, 0);
1091 /* Return 1 if SYMBOL currently has a let-binding
1092 which was made in the buffer that is now current. */
1095 let_shadows_buffer_binding_p (struct Lisp_Symbol
*symbol
)
1097 struct specbinding
*p
;
1099 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1101 && CONSP (p
->symbol
))
1103 struct Lisp_Symbol
*let_bound_symbol
= XSYMBOL (XCAR (p
->symbol
));
1104 eassert (let_bound_symbol
->redirect
!= SYMBOL_VARALIAS
);
1105 if (symbol
== let_bound_symbol
1106 && XBUFFER (XCDR (XCDR (p
->symbol
))) == current_buffer
)
1110 return p
>= specpdl
;
1114 let_shadows_global_binding_p (Lisp_Object symbol
)
1116 struct specbinding
*p
;
1118 for (p
= specpdl_ptr
- 1; p
>= specpdl
; p
--)
1119 if (p
->func
== NULL
&& EQ (p
->symbol
, symbol
))
1122 return p
>= specpdl
;
1125 /* Store the value NEWVAL into SYMBOL.
1126 If buffer/frame-locality is an issue, WHERE specifies which context to use.
1127 (nil stands for the current buffer/frame).
1129 If BINDFLAG is zero, then if this symbol is supposed to become
1130 local in every buffer where it is set, then we make it local.
1131 If BINDFLAG is nonzero, we don't do that. */
1134 set_internal (register Lisp_Object symbol
, register Lisp_Object newval
, register Lisp_Object where
, int bindflag
)
1136 int voide
= EQ (newval
, Qunbound
);
1137 struct Lisp_Symbol
*sym
;
1140 /* If restoring in a dead buffer, do nothing. */
1141 /* if (BUFFERP (where) && NILP (XBUFFER (where)->name))
1144 CHECK_SYMBOL (symbol
);
1145 if (SYMBOL_CONSTANT_P (symbol
))
1147 if (NILP (Fkeywordp (symbol
))
1148 || !EQ (newval
, Fsymbol_value (symbol
)))
1149 xsignal1 (Qsetting_constant
, symbol
);
1151 /* Allow setting keywords to their own value. */
1155 sym
= XSYMBOL (symbol
);
1158 switch (sym
->redirect
)
1160 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1161 case SYMBOL_PLAINVAL
: SET_SYMBOL_VAL (sym
, newval
); return;
1162 case SYMBOL_LOCALIZED
:
1164 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1167 if (blv
->frame_local
)
1168 where
= selected_frame
;
1170 XSETBUFFER (where
, current_buffer
);
1172 /* If the current buffer is not the buffer whose binding is
1173 loaded, or if there may be frame-local bindings and the frame
1174 isn't the right one, or if it's a Lisp_Buffer_Local_Value and
1175 the default binding is loaded, the loaded binding may be the
1177 if (!EQ (blv
->where
, where
)
1178 /* Also unload a global binding (if the var is local_if_set). */
1179 || (EQ (blv
->valcell
, blv
->defcell
)))
1181 /* The currently loaded binding is not necessarily valid.
1182 We need to unload it, and choose a new binding. */
1184 /* Write out `realvalue' to the old loaded binding. */
1186 SET_BLV_VALUE (blv
, do_symval_forwarding (blv
->fwd
));
1188 /* Find the new binding. */
1189 XSETSYMBOL (symbol
, sym
); /* May have changed via aliasing. */
1190 tem1
= Fassq (symbol
,
1192 ? XFRAME (where
)->param_alist
1193 : BVAR (XBUFFER (where
), local_var_alist
)));
1199 /* This buffer still sees the default value. */
1201 /* If the variable is a Lisp_Some_Buffer_Local_Value,
1202 or if this is `let' rather than `set',
1203 make CURRENT-ALIST-ELEMENT point to itself,
1204 indicating that we're seeing the default value.
1205 Likewise if the variable has been let-bound
1206 in the current buffer. */
1207 if (bindflag
|| !blv
->local_if_set
1208 || let_shadows_buffer_binding_p (sym
))
1211 tem1
= blv
->defcell
;
1213 /* If it's a local_if_set, being set not bound,
1214 and we're not within a let that was made for this buffer,
1215 create a new buffer-local binding for the variable.
1216 That means, give this buffer a new assoc for a local value
1217 and load that binding. */
1220 /* local_if_set is only supported for buffer-local
1221 bindings, not for frame-local bindings. */
1222 eassert (!blv
->frame_local
);
1223 tem1
= Fcons (symbol
, XCDR (blv
->defcell
));
1224 BVAR (XBUFFER (where
), local_var_alist
)
1225 = Fcons (tem1
, BVAR (XBUFFER (where
), local_var_alist
));
1229 /* Record which binding is now loaded. */
1230 blv
->valcell
= tem1
;
1233 /* Store the new value in the cons cell. */
1234 SET_BLV_VALUE (blv
, newval
);
1239 /* If storing void (making the symbol void), forward only through
1240 buffer-local indicator, not through Lisp_Objfwd, etc. */
1243 store_symval_forwarding (blv
->fwd
, newval
,
1245 ? XBUFFER (where
) : current_buffer
);
1249 case SYMBOL_FORWARDED
:
1252 = BUFFERP (where
) ? XBUFFER (where
) : current_buffer
;
1253 union Lisp_Fwd
*innercontents
= SYMBOL_FWD (sym
);
1254 if (BUFFER_OBJFWDP (innercontents
))
1256 int offset
= XBUFFER_OBJFWD (innercontents
)->offset
;
1257 int idx
= PER_BUFFER_IDX (offset
);
1260 && !let_shadows_buffer_binding_p (sym
))
1261 SET_PER_BUFFER_VALUE_P (buf
, idx
, 1);
1265 { /* If storing void (making the symbol void), forward only through
1266 buffer-local indicator, not through Lisp_Objfwd, etc. */
1267 sym
->redirect
= SYMBOL_PLAINVAL
;
1268 SET_SYMBOL_VAL (sym
, newval
);
1271 store_symval_forwarding (/* sym, */ innercontents
, newval
, buf
);
1279 /* Access or set a buffer-local symbol's default value. */
1281 /* Return the default value of SYMBOL, but don't check for voidness.
1282 Return Qunbound if it is void. */
1285 default_value (Lisp_Object symbol
)
1287 struct Lisp_Symbol
*sym
;
1289 CHECK_SYMBOL (symbol
);
1290 sym
= XSYMBOL (symbol
);
1293 switch (sym
->redirect
)
1295 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1296 case SYMBOL_PLAINVAL
: return SYMBOL_VAL (sym
);
1297 case SYMBOL_LOCALIZED
:
1299 /* If var is set up for a buffer that lacks a local value for it,
1300 the current value is nominally the default value.
1301 But the `realvalue' slot may be more up to date, since
1302 ordinary setq stores just that slot. So use that. */
1303 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1304 if (blv
->fwd
&& EQ (blv
->valcell
, blv
->defcell
))
1305 return do_symval_forwarding (blv
->fwd
);
1307 return XCDR (blv
->defcell
);
1309 case SYMBOL_FORWARDED
:
1311 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1313 /* For a built-in buffer-local variable, get the default value
1314 rather than letting do_symval_forwarding get the current value. */
1315 if (BUFFER_OBJFWDP (valcontents
))
1317 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1318 if (PER_BUFFER_IDX (offset
) != 0)
1319 return PER_BUFFER_DEFAULT (offset
);
1322 /* For other variables, get the current value. */
1323 return do_symval_forwarding (valcontents
);
1329 DEFUN ("default-boundp", Fdefault_boundp
, Sdefault_boundp
, 1, 1, 0,
1330 doc
: /* Return t if SYMBOL has a non-void default value.
1331 This is the value that is seen in buffers that do not have their own values
1332 for this variable. */)
1333 (Lisp_Object symbol
)
1335 register Lisp_Object value
;
1337 value
= default_value (symbol
);
1338 return (EQ (value
, Qunbound
) ? Qnil
: Qt
);
1341 DEFUN ("default-value", Fdefault_value
, Sdefault_value
, 1, 1, 0,
1342 doc
: /* Return SYMBOL's default value.
1343 This is the value that is seen in buffers that do not have their own values
1344 for this variable. The default value is meaningful for variables with
1345 local bindings in certain buffers. */)
1346 (Lisp_Object symbol
)
1348 register Lisp_Object value
;
1350 value
= default_value (symbol
);
1351 if (!EQ (value
, Qunbound
))
1354 xsignal1 (Qvoid_variable
, symbol
);
1357 DEFUN ("set-default", Fset_default
, Sset_default
, 2, 2, 0,
1358 doc
: /* Set SYMBOL's default value to VALUE. SYMBOL and VALUE are evaluated.
1359 The default value is seen in buffers that do not have their own values
1360 for this variable. */)
1361 (Lisp_Object symbol
, Lisp_Object value
)
1363 struct Lisp_Symbol
*sym
;
1365 CHECK_SYMBOL (symbol
);
1366 if (SYMBOL_CONSTANT_P (symbol
))
1368 if (NILP (Fkeywordp (symbol
))
1369 || !EQ (value
, Fdefault_value (symbol
)))
1370 xsignal1 (Qsetting_constant
, symbol
);
1372 /* Allow setting keywords to their own value. */
1375 sym
= XSYMBOL (symbol
);
1378 switch (sym
->redirect
)
1380 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1381 case SYMBOL_PLAINVAL
: return Fset (symbol
, value
);
1382 case SYMBOL_LOCALIZED
:
1384 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1386 /* Store new value into the DEFAULT-VALUE slot. */
1387 XSETCDR (blv
->defcell
, value
);
1389 /* If the default binding is now loaded, set the REALVALUE slot too. */
1390 if (blv
->fwd
&& EQ (blv
->defcell
, blv
->valcell
))
1391 store_symval_forwarding (blv
->fwd
, value
, NULL
);
1394 case SYMBOL_FORWARDED
:
1396 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1398 /* Handle variables like case-fold-search that have special slots
1400 Make them work apparently like Lisp_Buffer_Local_Value variables. */
1401 if (BUFFER_OBJFWDP (valcontents
))
1403 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1404 int idx
= PER_BUFFER_IDX (offset
);
1406 PER_BUFFER_DEFAULT (offset
) = value
;
1408 /* If this variable is not always local in all buffers,
1409 set it in the buffers that don't nominally have a local value. */
1414 for (b
= all_buffers
; b
; b
= b
->next
)
1415 if (!PER_BUFFER_VALUE_P (b
, idx
))
1416 PER_BUFFER_VALUE (b
, offset
) = value
;
1421 return Fset (symbol
, value
);
1427 DEFUN ("setq-default", Fsetq_default
, Ssetq_default
, 0, UNEVALLED
, 0,
1428 doc
: /* Set the default value of variable VAR to VALUE.
1429 VAR, the variable name, is literal (not evaluated);
1430 VALUE is an expression: it is evaluated and its value returned.
1431 The default value of a variable is seen in buffers
1432 that do not have their own values for the variable.
1434 More generally, you can use multiple variables and values, as in
1435 (setq-default VAR VALUE VAR VALUE...)
1436 This sets each VAR's default value to the corresponding VALUE.
1437 The VALUE for the Nth VAR can refer to the new default values
1439 usage: (setq-default [VAR VALUE]...) */)
1442 register Lisp_Object args_left
;
1443 register Lisp_Object val
, symbol
;
1444 struct gcpro gcpro1
;
1454 val
= eval_sub (Fcar (Fcdr (args_left
)));
1455 symbol
= XCAR (args_left
);
1456 Fset_default (symbol
, val
);
1457 args_left
= Fcdr (XCDR (args_left
));
1459 while (!NILP (args_left
));
1465 /* Lisp functions for creating and removing buffer-local variables. */
1470 union Lisp_Fwd
*fwd
;
1473 static struct Lisp_Buffer_Local_Value
*
1474 make_blv (struct Lisp_Symbol
*sym
, int forwarded
, union Lisp_Val_Fwd valcontents
)
1476 struct Lisp_Buffer_Local_Value
*blv
1477 = xmalloc (sizeof (struct Lisp_Buffer_Local_Value
));
1481 XSETSYMBOL (symbol
, sym
);
1482 tem
= Fcons (symbol
, (forwarded
1483 ? do_symval_forwarding (valcontents
.fwd
)
1484 : valcontents
.value
));
1486 /* Buffer_Local_Values cannot have as realval a buffer-local
1487 or keyboard-local forwarding. */
1488 eassert (!(forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)));
1489 eassert (!(forwarded
&& KBOARD_OBJFWDP (valcontents
.fwd
)));
1490 blv
->fwd
= forwarded
? valcontents
.fwd
: NULL
;
1492 blv
->frame_local
= 0;
1493 blv
->local_if_set
= 0;
1496 SET_BLV_FOUND (blv
, 0);
1500 DEFUN ("make-variable-buffer-local", Fmake_variable_buffer_local
, Smake_variable_buffer_local
,
1501 1, 1, "vMake Variable Buffer Local: ",
1502 doc
: /* Make VARIABLE become buffer-local whenever it is set.
1503 At any time, the value for the current buffer is in effect,
1504 unless the variable has never been set in this buffer,
1505 in which case the default value is in effect.
1506 Note that binding the variable with `let', or setting it while
1507 a `let'-style binding made in this buffer is in effect,
1508 does not make the variable buffer-local. Return VARIABLE.
1510 In most cases it is better to use `make-local-variable',
1511 which makes a variable local in just one buffer.
1513 The function `default-value' gets the default value and `set-default' sets it. */)
1514 (register Lisp_Object variable
)
1516 struct Lisp_Symbol
*sym
;
1517 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1518 union Lisp_Val_Fwd valcontents
;
1521 CHECK_SYMBOL (variable
);
1522 sym
= XSYMBOL (variable
);
1525 switch (sym
->redirect
)
1527 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1528 case SYMBOL_PLAINVAL
:
1529 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1530 if (EQ (valcontents
.value
, Qunbound
))
1531 valcontents
.value
= Qnil
;
1533 case SYMBOL_LOCALIZED
:
1534 blv
= SYMBOL_BLV (sym
);
1535 if (blv
->frame_local
)
1536 error ("Symbol %s may not be buffer-local",
1537 SDATA (SYMBOL_NAME (variable
)));
1539 case SYMBOL_FORWARDED
:
1540 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1541 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1542 error ("Symbol %s may not be buffer-local",
1543 SDATA (SYMBOL_NAME (variable
)));
1544 else if (BUFFER_OBJFWDP (valcontents
.fwd
))
1551 error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable
)));
1555 blv
= make_blv (sym
, forwarded
, valcontents
);
1556 sym
->redirect
= SYMBOL_LOCALIZED
;
1557 SET_SYMBOL_BLV (sym
, blv
);
1560 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1561 if (let_shadows_global_binding_p (symbol
))
1562 message ("Making %s buffer-local while let-bound!",
1563 SDATA (SYMBOL_NAME (variable
)));
1567 blv
->local_if_set
= 1;
1571 DEFUN ("make-local-variable", Fmake_local_variable
, Smake_local_variable
,
1572 1, 1, "vMake Local Variable: ",
1573 doc
: /* Make VARIABLE have a separate value in the current buffer.
1574 Other buffers will continue to share a common default value.
1575 \(The buffer-local value of VARIABLE starts out as the same value
1576 VARIABLE previously had. If VARIABLE was void, it remains void.\)
1579 If the variable is already arranged to become local when set,
1580 this function causes a local value to exist for this buffer,
1581 just as setting the variable would do.
1583 This function returns VARIABLE, and therefore
1584 (set (make-local-variable 'VARIABLE) VALUE-EXP)
1587 See also `make-variable-buffer-local'.
1589 Do not use `make-local-variable' to make a hook variable buffer-local.
1590 Instead, use `add-hook' and specify t for the LOCAL argument. */)
1591 (register Lisp_Object variable
)
1593 register Lisp_Object tem
;
1595 union Lisp_Val_Fwd valcontents
;
1596 struct Lisp_Symbol
*sym
;
1597 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1599 CHECK_SYMBOL (variable
);
1600 sym
= XSYMBOL (variable
);
1603 switch (sym
->redirect
)
1605 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1606 case SYMBOL_PLAINVAL
:
1607 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
); break;
1608 case SYMBOL_LOCALIZED
:
1609 blv
= SYMBOL_BLV (sym
);
1610 if (blv
->frame_local
)
1611 error ("Symbol %s may not be buffer-local",
1612 SDATA (SYMBOL_NAME (variable
)));
1614 case SYMBOL_FORWARDED
:
1615 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1616 if (KBOARD_OBJFWDP (valcontents
.fwd
))
1617 error ("Symbol %s may not be buffer-local",
1618 SDATA (SYMBOL_NAME (variable
)));
1624 error ("Symbol %s may not be buffer-local",
1625 SDATA (SYMBOL_NAME (variable
)));
1627 if (blv
? blv
->local_if_set
1628 : (forwarded
&& BUFFER_OBJFWDP (valcontents
.fwd
)))
1630 tem
= Fboundp (variable
);
1631 /* Make sure the symbol has a local value in this particular buffer,
1632 by setting it to the same value it already has. */
1633 Fset (variable
, (EQ (tem
, Qt
) ? Fsymbol_value (variable
) : Qunbound
));
1638 blv
= make_blv (sym
, forwarded
, valcontents
);
1639 sym
->redirect
= SYMBOL_LOCALIZED
;
1640 SET_SYMBOL_BLV (sym
, blv
);
1643 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1644 if (let_shadows_global_binding_p (symbol
))
1645 message ("Making %s local to %s while let-bound!",
1646 SDATA (SYMBOL_NAME (variable
)),
1647 SDATA (BVAR (current_buffer
, name
)));
1651 /* Make sure this buffer has its own value of symbol. */
1652 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1653 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1656 if (let_shadows_buffer_binding_p (sym
))
1657 message ("Making %s buffer-local while locally let-bound!",
1658 SDATA (SYMBOL_NAME (variable
)));
1660 /* Swap out any local binding for some other buffer, and make
1661 sure the current value is permanently recorded, if it's the
1663 find_symbol_value (variable
);
1665 BVAR (current_buffer
, local_var_alist
)
1666 = Fcons (Fcons (variable
, XCDR (blv
->defcell
)),
1667 BVAR (current_buffer
, local_var_alist
));
1669 /* Make sure symbol does not think it is set up for this buffer;
1670 force it to look once again for this buffer's value. */
1671 if (current_buffer
== XBUFFER (blv
->where
))
1673 /* blv->valcell = blv->defcell;
1674 * SET_BLV_FOUND (blv, 0); */
1678 /* If the symbol forwards into a C variable, then load the binding
1679 for this buffer now. If C code modifies the variable before we
1680 load the binding in, then that new value will clobber the default
1681 binding the next time we unload it. */
1683 swap_in_symval_forwarding (sym
, blv
);
1688 DEFUN ("kill-local-variable", Fkill_local_variable
, Skill_local_variable
,
1689 1, 1, "vKill Local Variable: ",
1690 doc
: /* Make VARIABLE no longer have a separate value in the current buffer.
1691 From now on the default value will apply in this buffer. Return VARIABLE. */)
1692 (register Lisp_Object variable
)
1694 register Lisp_Object tem
;
1695 struct Lisp_Buffer_Local_Value
*blv
;
1696 struct Lisp_Symbol
*sym
;
1698 CHECK_SYMBOL (variable
);
1699 sym
= XSYMBOL (variable
);
1702 switch (sym
->redirect
)
1704 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1705 case SYMBOL_PLAINVAL
: return variable
;
1706 case SYMBOL_FORWARDED
:
1708 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1709 if (BUFFER_OBJFWDP (valcontents
))
1711 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1712 int idx
= PER_BUFFER_IDX (offset
);
1716 SET_PER_BUFFER_VALUE_P (current_buffer
, idx
, 0);
1717 PER_BUFFER_VALUE (current_buffer
, offset
)
1718 = PER_BUFFER_DEFAULT (offset
);
1723 case SYMBOL_LOCALIZED
:
1724 blv
= SYMBOL_BLV (sym
);
1725 if (blv
->frame_local
)
1731 /* Get rid of this buffer's alist element, if any. */
1732 XSETSYMBOL (variable
, sym
); /* Propagate variable indirection. */
1733 tem
= Fassq (variable
, BVAR (current_buffer
, local_var_alist
));
1735 BVAR (current_buffer
, local_var_alist
)
1736 = Fdelq (tem
, BVAR (current_buffer
, local_var_alist
));
1738 /* If the symbol is set up with the current buffer's binding
1739 loaded, recompute its value. We have to do it now, or else
1740 forwarded objects won't work right. */
1742 Lisp_Object buf
; XSETBUFFER (buf
, current_buffer
);
1743 if (EQ (buf
, blv
->where
))
1746 /* blv->valcell = blv->defcell;
1747 * SET_BLV_FOUND (blv, 0); */
1749 find_symbol_value (variable
);
1756 /* Lisp functions for creating and removing buffer-local variables. */
1758 /* Obsolete since 22.2. NB adjust doc of modify-frame-parameters
1759 when/if this is removed. */
1761 DEFUN ("make-variable-frame-local", Fmake_variable_frame_local
, Smake_variable_frame_local
,
1762 1, 1, "vMake Variable Frame Local: ",
1763 doc
: /* Enable VARIABLE to have frame-local bindings.
1764 This does not create any frame-local bindings for VARIABLE,
1765 it just makes them possible.
1767 A frame-local binding is actually a frame parameter value.
1768 If a frame F has a value for the frame parameter named VARIABLE,
1769 that also acts as a frame-local binding for VARIABLE in F--
1770 provided this function has been called to enable VARIABLE
1771 to have frame-local bindings at all.
1773 The only way to create a frame-local binding for VARIABLE in a frame
1774 is to set the VARIABLE frame parameter of that frame. See
1775 `modify-frame-parameters' for how to set frame parameters.
1777 Note that since Emacs 23.1, variables cannot be both buffer-local and
1778 frame-local any more (buffer-local bindings used to take precedence over
1779 frame-local bindings). */)
1780 (register Lisp_Object variable
)
1783 union Lisp_Val_Fwd valcontents
;
1784 struct Lisp_Symbol
*sym
;
1785 struct Lisp_Buffer_Local_Value
*blv
= NULL
;
1787 CHECK_SYMBOL (variable
);
1788 sym
= XSYMBOL (variable
);
1791 switch (sym
->redirect
)
1793 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1794 case SYMBOL_PLAINVAL
:
1795 forwarded
= 0; valcontents
.value
= SYMBOL_VAL (sym
);
1796 if (EQ (valcontents
.value
, Qunbound
))
1797 valcontents
.value
= Qnil
;
1799 case SYMBOL_LOCALIZED
:
1800 if (SYMBOL_BLV (sym
)->frame_local
)
1803 error ("Symbol %s may not be frame-local",
1804 SDATA (SYMBOL_NAME (variable
)));
1805 case SYMBOL_FORWARDED
:
1806 forwarded
= 1; valcontents
.fwd
= SYMBOL_FWD (sym
);
1807 if (KBOARD_OBJFWDP (valcontents
.fwd
) || BUFFER_OBJFWDP (valcontents
.fwd
))
1808 error ("Symbol %s may not be frame-local",
1809 SDATA (SYMBOL_NAME (variable
)));
1815 error ("Symbol %s may not be frame-local", SDATA (SYMBOL_NAME (variable
)));
1817 blv
= make_blv (sym
, forwarded
, valcontents
);
1818 blv
->frame_local
= 1;
1819 sym
->redirect
= SYMBOL_LOCALIZED
;
1820 SET_SYMBOL_BLV (sym
, blv
);
1823 XSETSYMBOL (symbol
, sym
); /* In case `variable' is aliased. */
1824 if (let_shadows_global_binding_p (symbol
))
1825 message ("Making %s frame-local while let-bound!",
1826 SDATA (SYMBOL_NAME (variable
)));
1831 DEFUN ("local-variable-p", Flocal_variable_p
, Slocal_variable_p
,
1833 doc
: /* Non-nil if VARIABLE has a local binding in buffer BUFFER.
1834 BUFFER defaults to the current buffer. */)
1835 (register Lisp_Object variable
, Lisp_Object buffer
)
1837 register struct buffer
*buf
;
1838 struct Lisp_Symbol
*sym
;
1841 buf
= current_buffer
;
1844 CHECK_BUFFER (buffer
);
1845 buf
= XBUFFER (buffer
);
1848 CHECK_SYMBOL (variable
);
1849 sym
= XSYMBOL (variable
);
1852 switch (sym
->redirect
)
1854 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1855 case SYMBOL_PLAINVAL
: return Qnil
;
1856 case SYMBOL_LOCALIZED
:
1858 Lisp_Object tail
, elt
, tmp
;
1859 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1860 XSETBUFFER (tmp
, buf
);
1861 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1863 for (tail
= BVAR (buf
, local_var_alist
); CONSP (tail
); tail
= XCDR (tail
))
1866 if (EQ (variable
, XCAR (elt
)))
1868 eassert (!blv
->frame_local
);
1869 eassert (BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1873 eassert (!BLV_FOUND (blv
) || !EQ (blv
->where
, tmp
));
1876 case SYMBOL_FORWARDED
:
1878 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1879 if (BUFFER_OBJFWDP (valcontents
))
1881 int offset
= XBUFFER_OBJFWD (valcontents
)->offset
;
1882 int idx
= PER_BUFFER_IDX (offset
);
1883 if (idx
== -1 || PER_BUFFER_VALUE_P (buf
, idx
))
1892 DEFUN ("local-variable-if-set-p", Flocal_variable_if_set_p
, Slocal_variable_if_set_p
,
1894 doc
: /* Non-nil if VARIABLE will be local in buffer BUFFER when set there.
1895 More precisely, this means that setting the variable \(with `set' or`setq'),
1896 while it does not have a `let'-style binding that was made in BUFFER,
1897 will produce a buffer local binding. See Info node
1898 `(elisp)Creating Buffer-Local'.
1899 BUFFER defaults to the current buffer. */)
1900 (register Lisp_Object variable
, Lisp_Object buffer
)
1902 struct Lisp_Symbol
*sym
;
1904 CHECK_SYMBOL (variable
);
1905 sym
= XSYMBOL (variable
);
1908 switch (sym
->redirect
)
1910 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1911 case SYMBOL_PLAINVAL
: return Qnil
;
1912 case SYMBOL_LOCALIZED
:
1914 struct Lisp_Buffer_Local_Value
*blv
= SYMBOL_BLV (sym
);
1915 if (blv
->local_if_set
)
1917 XSETSYMBOL (variable
, sym
); /* Update in case of aliasing. */
1918 return Flocal_variable_p (variable
, buffer
);
1920 case SYMBOL_FORWARDED
:
1921 /* All BUFFER_OBJFWD slots become local if they are set. */
1922 return (BUFFER_OBJFWDP (SYMBOL_FWD (sym
)) ? Qt
: Qnil
);
1927 DEFUN ("variable-binding-locus", Fvariable_binding_locus
, Svariable_binding_locus
,
1929 doc
: /* Return a value indicating where VARIABLE's current binding comes from.
1930 If the current binding is buffer-local, the value is the current buffer.
1931 If the current binding is frame-local, the value is the selected frame.
1932 If the current binding is global (the default), the value is nil. */)
1933 (register Lisp_Object variable
)
1935 struct Lisp_Symbol
*sym
;
1937 CHECK_SYMBOL (variable
);
1938 sym
= XSYMBOL (variable
);
1940 /* Make sure the current binding is actually swapped in. */
1941 find_symbol_value (variable
);
1944 switch (sym
->redirect
)
1946 case SYMBOL_VARALIAS
: sym
= indirect_variable (sym
); goto start
;
1947 case SYMBOL_PLAINVAL
: return Qnil
;
1948 case SYMBOL_FORWARDED
:
1950 union Lisp_Fwd
*valcontents
= SYMBOL_FWD (sym
);
1951 if (KBOARD_OBJFWDP (valcontents
))
1952 return Fframe_terminal (Fselected_frame ());
1953 else if (!BUFFER_OBJFWDP (valcontents
))
1957 case SYMBOL_LOCALIZED
:
1958 /* For a local variable, record both the symbol and which
1959 buffer's or frame's value we are saving. */
1960 if (!NILP (Flocal_variable_p (variable
, Qnil
)))
1961 return Fcurrent_buffer ();
1962 else if (sym
->redirect
== SYMBOL_LOCALIZED
1963 && BLV_FOUND (SYMBOL_BLV (sym
)))
1964 return SYMBOL_BLV (sym
)->where
;
1971 /* This code is disabled now that we use the selected frame to return
1972 keyboard-local-values. */
1974 extern struct terminal
*get_terminal (Lisp_Object display
, int);
1976 DEFUN ("terminal-local-value", Fterminal_local_value
, Sterminal_local_value
, 2, 2, 0,
1977 doc
: /* Return the terminal-local value of SYMBOL on TERMINAL.
1978 If SYMBOL is not a terminal-local variable, then return its normal
1979 value, like `symbol-value'.
1981 TERMINAL may be a terminal object, a frame, or nil (meaning the
1982 selected frame's terminal device). */)
1983 (Lisp_Object symbol
, Lisp_Object terminal
)
1986 struct terminal
*t
= get_terminal (terminal
, 1);
1987 push_kboard (t
->kboard
);
1988 result
= Fsymbol_value (symbol
);
1993 DEFUN ("set-terminal-local-value", Fset_terminal_local_value
, Sset_terminal_local_value
, 3, 3, 0,
1994 doc
: /* Set the terminal-local binding of SYMBOL on TERMINAL to VALUE.
1995 If VARIABLE is not a terminal-local variable, then set its normal
1996 binding, like `set'.
1998 TERMINAL may be a terminal object, a frame, or nil (meaning the
1999 selected frame's terminal device). */)
2000 (Lisp_Object symbol
, Lisp_Object terminal
, Lisp_Object value
)
2003 struct terminal
*t
= get_terminal (terminal
, 1);
2004 push_kboard (d
->kboard
);
2005 result
= Fset (symbol
, value
);
2011 /* Find the function at the end of a chain of symbol function indirections. */
2013 /* If OBJECT is a symbol, find the end of its function chain and
2014 return the value found there. If OBJECT is not a symbol, just
2015 return it. If there is a cycle in the function chain, signal a
2016 cyclic-function-indirection error.
2018 This is like Findirect_function, except that it doesn't signal an
2019 error if the chain ends up unbound. */
2021 indirect_function (register Lisp_Object object
)
2023 Lisp_Object tortoise
, hare
;
2025 hare
= tortoise
= object
;
2029 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2031 hare
= XSYMBOL (hare
)->function
;
2032 if (!SYMBOLP (hare
) || EQ (hare
, Qunbound
))
2034 hare
= XSYMBOL (hare
)->function
;
2036 tortoise
= XSYMBOL (tortoise
)->function
;
2038 if (EQ (hare
, tortoise
))
2039 xsignal1 (Qcyclic_function_indirection
, object
);
2045 DEFUN ("indirect-function", Findirect_function
, Sindirect_function
, 1, 2, 0,
2046 doc
: /* Return the function at the end of OBJECT's function chain.
2047 If OBJECT is not a symbol, just return it. Otherwise, follow all
2048 function indirections to find the final function binding and return it.
2049 If the final symbol in the chain is unbound, signal a void-function error.
2050 Optional arg NOERROR non-nil means to return nil instead of signalling.
2051 Signal a cyclic-function-indirection error if there is a loop in the
2052 function chain of symbols. */)
2053 (register Lisp_Object object
, Lisp_Object noerror
)
2057 /* Optimize for no indirection. */
2059 if (SYMBOLP (result
) && !EQ (result
, Qunbound
)
2060 && (result
= XSYMBOL (result
)->function
, SYMBOLP (result
)))
2061 result
= indirect_function (result
);
2062 if (!EQ (result
, Qunbound
))
2066 xsignal1 (Qvoid_function
, object
);
2071 /* Extract and set vector and string elements */
2073 DEFUN ("aref", Faref
, Saref
, 2, 2, 0,
2074 doc
: /* Return the element of ARRAY at index IDX.
2075 ARRAY may be a vector, a string, a char-table, a bool-vector,
2076 or a byte-code object. IDX starts at 0. */)
2077 (register Lisp_Object array
, Lisp_Object idx
)
2079 register EMACS_INT idxval
;
2082 idxval
= XINT (idx
);
2083 if (STRINGP (array
))
2086 EMACS_INT idxval_byte
;
2088 if (idxval
< 0 || idxval
>= SCHARS (array
))
2089 args_out_of_range (array
, idx
);
2090 if (! STRING_MULTIBYTE (array
))
2091 return make_number ((unsigned char) SREF (array
, idxval
));
2092 idxval_byte
= string_char_to_byte (array
, idxval
);
2094 c
= STRING_CHAR (SDATA (array
) + idxval_byte
);
2095 return make_number (c
);
2097 else if (BOOL_VECTOR_P (array
))
2101 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2102 args_out_of_range (array
, idx
);
2104 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2105 return (val
& (1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
)) ? Qt
: Qnil
);
2107 else if (CHAR_TABLE_P (array
))
2109 CHECK_CHARACTER (idx
);
2110 return CHAR_TABLE_REF (array
, idxval
);
2115 if (VECTORP (array
))
2116 size
= ASIZE (array
);
2117 else if (FUNVECP (array
))
2118 size
= FUNVEC_SIZE (array
);
2120 wrong_type_argument (Qarrayp
, array
);
2122 if (idxval
< 0 || idxval
>= size
)
2123 args_out_of_range (array
, idx
);
2124 return AREF (array
, idxval
);
2128 DEFUN ("aset", Faset
, Saset
, 3, 3, 0,
2129 doc
: /* Store into the element of ARRAY at index IDX the value NEWELT.
2130 Return NEWELT. ARRAY may be a vector, a string, a char-table or a
2131 bool-vector. IDX starts at 0. */)
2132 (register Lisp_Object array
, Lisp_Object idx
, Lisp_Object newelt
)
2134 register EMACS_INT idxval
;
2137 idxval
= XINT (idx
);
2138 CHECK_ARRAY (array
, Qarrayp
);
2139 CHECK_IMPURE (array
);
2141 if (VECTORP (array
))
2143 if (idxval
< 0 || idxval
>= XVECTOR (array
)->size
)
2144 args_out_of_range (array
, idx
);
2145 XVECTOR (array
)->contents
[idxval
] = newelt
;
2147 else if (BOOL_VECTOR_P (array
))
2151 if (idxval
< 0 || idxval
>= XBOOL_VECTOR (array
)->size
)
2152 args_out_of_range (array
, idx
);
2154 val
= (unsigned char) XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
];
2156 if (! NILP (newelt
))
2157 val
|= 1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
);
2159 val
&= ~(1 << (idxval
% BOOL_VECTOR_BITS_PER_CHAR
));
2160 XBOOL_VECTOR (array
)->data
[idxval
/ BOOL_VECTOR_BITS_PER_CHAR
] = val
;
2162 else if (CHAR_TABLE_P (array
))
2164 CHECK_CHARACTER (idx
);
2165 CHAR_TABLE_SET (array
, idxval
, newelt
);
2167 else if (STRING_MULTIBYTE (array
))
2169 EMACS_INT idxval_byte
, prev_bytes
, new_bytes
, nbytes
;
2170 unsigned char workbuf
[MAX_MULTIBYTE_LENGTH
], *p0
= workbuf
, *p1
;
2172 if (idxval
< 0 || idxval
>= SCHARS (array
))
2173 args_out_of_range (array
, idx
);
2174 CHECK_CHARACTER (newelt
);
2176 nbytes
= SBYTES (array
);
2178 idxval_byte
= string_char_to_byte (array
, idxval
);
2179 p1
= SDATA (array
) + idxval_byte
;
2180 prev_bytes
= BYTES_BY_CHAR_HEAD (*p1
);
2181 new_bytes
= CHAR_STRING (XINT (newelt
), p0
);
2182 if (prev_bytes
!= new_bytes
)
2184 /* We must relocate the string data. */
2185 EMACS_INT nchars
= SCHARS (array
);
2189 SAFE_ALLOCA (str
, unsigned char *, nbytes
);
2190 memcpy (str
, SDATA (array
), nbytes
);
2191 allocate_string_data (XSTRING (array
), nchars
,
2192 nbytes
+ new_bytes
- prev_bytes
);
2193 memcpy (SDATA (array
), str
, idxval_byte
);
2194 p1
= SDATA (array
) + idxval_byte
;
2195 memcpy (p1
+ new_bytes
, str
+ idxval_byte
+ prev_bytes
,
2196 nbytes
- (idxval_byte
+ prev_bytes
));
2198 clear_string_char_byte_cache ();
2205 if (idxval
< 0 || idxval
>= SCHARS (array
))
2206 args_out_of_range (array
, idx
);
2207 CHECK_NUMBER (newelt
);
2209 if (XINT (newelt
) >= 0 && ! SINGLE_BYTE_CHAR_P (XINT (newelt
)))
2213 for (i
= SBYTES (array
) - 1; i
>= 0; i
--)
2214 if (SREF (array
, i
) >= 0x80)
2215 args_out_of_range (array
, newelt
);
2216 /* ARRAY is an ASCII string. Convert it to a multibyte
2217 string, and try `aset' again. */
2218 STRING_SET_MULTIBYTE (array
);
2219 return Faset (array
, idx
, newelt
);
2221 SSET (array
, idxval
, XINT (newelt
));
2227 /* Arithmetic functions */
2229 enum comparison
{ equal
, notequal
, less
, grtr
, less_or_equal
, grtr_or_equal
};
2232 arithcompare (Lisp_Object num1
, Lisp_Object num2
, enum comparison comparison
)
2234 double f1
= 0, f2
= 0;
2237 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num1
);
2238 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (num2
);
2240 if (FLOATP (num1
) || FLOATP (num2
))
2243 f1
= (FLOATP (num1
)) ? XFLOAT_DATA (num1
) : XINT (num1
);
2244 f2
= (FLOATP (num2
)) ? XFLOAT_DATA (num2
) : 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
))
2270 if (floatp
? f1
> f2
: XINT (num1
) > XINT (num2
))
2275 if (floatp
? f1
>= f2
: XINT (num1
) >= XINT (num2
))
2284 DEFUN ("=", Feqlsign
, Seqlsign
, 2, 2, 0,
2285 doc
: /* Return t if two args, both numbers or markers, are equal. */)
2286 (register Lisp_Object num1
, Lisp_Object num2
)
2288 return arithcompare (num1
, num2
, equal
);
2291 DEFUN ("<", Flss
, Slss
, 2, 2, 0,
2292 doc
: /* Return t if first arg is less than second arg. Both must be numbers or markers. */)
2293 (register Lisp_Object num1
, Lisp_Object num2
)
2295 return arithcompare (num1
, num2
, less
);
2298 DEFUN (">", Fgtr
, Sgtr
, 2, 2, 0,
2299 doc
: /* Return t if first arg is greater than second arg. Both must be numbers or markers. */)
2300 (register Lisp_Object num1
, Lisp_Object num2
)
2302 return arithcompare (num1
, num2
, grtr
);
2305 DEFUN ("<=", Fleq
, Sleq
, 2, 2, 0,
2306 doc
: /* Return t if first arg is less than or equal to second arg.
2307 Both must be numbers or markers. */)
2308 (register Lisp_Object num1
, Lisp_Object num2
)
2310 return arithcompare (num1
, num2
, less_or_equal
);
2313 DEFUN (">=", Fgeq
, Sgeq
, 2, 2, 0,
2314 doc
: /* Return t if first arg is greater than or equal to second arg.
2315 Both must be numbers or markers. */)
2316 (register Lisp_Object num1
, Lisp_Object num2
)
2318 return arithcompare (num1
, num2
, grtr_or_equal
);
2321 DEFUN ("/=", Fneq
, Sneq
, 2, 2, 0,
2322 doc
: /* Return t if first arg is not equal to second arg. Both must be numbers or markers. */)
2323 (register Lisp_Object num1
, Lisp_Object num2
)
2325 return arithcompare (num1
, num2
, notequal
);
2328 DEFUN ("zerop", Fzerop
, Szerop
, 1, 1, 0,
2329 doc
: /* Return t if NUMBER is zero. */)
2330 (register Lisp_Object number
)
2332 CHECK_NUMBER_OR_FLOAT (number
);
2334 if (FLOATP (number
))
2336 if (XFLOAT_DATA (number
) == 0.0)
2346 /* Convert between long values and pairs of Lisp integers.
2347 Note that long_to_cons returns a single Lisp integer
2348 when the value fits in one. */
2351 long_to_cons (long unsigned int i
)
2353 unsigned long top
= i
>> 16;
2354 unsigned int bot
= i
& 0xFFFF;
2356 return make_number (bot
);
2357 if (top
== (unsigned long)-1 >> 16)
2358 return Fcons (make_number (-1), make_number (bot
));
2359 return Fcons (make_number (top
), make_number (bot
));
2363 cons_to_long (Lisp_Object c
)
2365 Lisp_Object top
, bot
;
2372 return ((XINT (top
) << 16) | XINT (bot
));
2375 DEFUN ("number-to-string", Fnumber_to_string
, Snumber_to_string
, 1, 1, 0,
2376 doc
: /* Return the decimal representation of NUMBER as a string.
2377 Uses a minus sign if negative.
2378 NUMBER may be an integer or a floating point number. */)
2379 (Lisp_Object number
)
2381 char buffer
[VALBITS
];
2383 CHECK_NUMBER_OR_FLOAT (number
);
2385 if (FLOATP (number
))
2387 char pigbuf
[FLOAT_TO_STRING_BUFSIZE
];
2389 float_to_string (pigbuf
, XFLOAT_DATA (number
));
2390 return build_string (pigbuf
);
2393 if (sizeof (int) == sizeof (EMACS_INT
))
2394 sprintf (buffer
, "%d", (int) XINT (number
));
2395 else if (sizeof (long) == sizeof (EMACS_INT
))
2396 sprintf (buffer
, "%ld", (long) XINT (number
));
2399 return build_string (buffer
);
2403 digit_to_number (int character
, int base
)
2407 if (character
>= '0' && character
<= '9')
2408 digit
= character
- '0';
2409 else if (character
>= 'a' && character
<= 'z')
2410 digit
= character
- 'a' + 10;
2411 else if (character
>= 'A' && character
<= 'Z')
2412 digit
= character
- 'A' + 10;
2422 DEFUN ("string-to-number", Fstring_to_number
, Sstring_to_number
, 1, 2, 0,
2423 doc
: /* Parse STRING as a decimal number and return the number.
2424 This parses both integers and floating point numbers.
2425 It ignores leading spaces and tabs, and all trailing chars.
2427 If BASE, interpret STRING as a number in that base. If BASE isn't
2428 present, base 10 is used. BASE must be between 2 and 16 (inclusive).
2429 If the base used is not 10, STRING is always parsed as integer. */)
2430 (register Lisp_Object string
, Lisp_Object base
)
2437 CHECK_STRING (string
);
2443 CHECK_NUMBER (base
);
2445 if (b
< 2 || b
> 16)
2446 xsignal1 (Qargs_out_of_range
, base
);
2449 /* Skip any whitespace at the front of the number. Some versions of
2450 atoi do this anyway, so we might as well make Emacs lisp consistent. */
2451 p
= SSDATA (string
);
2452 while (*p
== ' ' || *p
== '\t')
2463 if (isfloat_string (p
, 1) && b
== 10)
2464 val
= make_float (sign
* atof (p
));
2471 int digit
= digit_to_number (*p
++, b
);
2477 val
= make_fixnum_or_float (sign
* v
);
2497 static Lisp_Object
float_arith_driver (double, int, enum arithop
,
2498 int, Lisp_Object
*);
2500 arith_driver (enum arithop code
, int nargs
, register Lisp_Object
*args
)
2502 register Lisp_Object val
;
2503 register int argnum
;
2504 register EMACS_INT accum
= 0;
2505 register EMACS_INT next
;
2507 switch (SWITCH_ENUM_CAST (code
))
2525 for (argnum
= 0; argnum
< nargs
; argnum
++)
2527 /* Using args[argnum] as argument to CHECK_NUMBER_... */
2529 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2532 return float_arith_driver ((double) accum
, argnum
, code
,
2535 next
= XINT (args
[argnum
]);
2536 switch (SWITCH_ENUM_CAST (code
))
2542 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2553 xsignal0 (Qarith_error
);
2567 if (!argnum
|| next
> accum
)
2571 if (!argnum
|| next
< accum
)
2577 XSETINT (val
, accum
);
2582 #define isnan(x) ((x) != (x))
2585 float_arith_driver (double accum
, register int argnum
, enum arithop code
, int nargs
, register Lisp_Object
*args
)
2587 register Lisp_Object val
;
2590 for (; argnum
< nargs
; argnum
++)
2592 val
= args
[argnum
]; /* using args[argnum] as argument to CHECK_NUMBER_... */
2593 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (val
);
2597 next
= XFLOAT_DATA (val
);
2601 args
[argnum
] = val
; /* runs into a compiler bug. */
2602 next
= XINT (args
[argnum
]);
2604 switch (SWITCH_ENUM_CAST (code
))
2610 accum
= argnum
? accum
- next
: nargs
== 1 ? - next
: next
;
2620 if (! IEEE_FLOATING_POINT
&& next
== 0)
2621 xsignal0 (Qarith_error
);
2628 return wrong_type_argument (Qinteger_or_marker_p
, val
);
2630 if (!argnum
|| isnan (next
) || next
> accum
)
2634 if (!argnum
|| isnan (next
) || next
< accum
)
2640 return make_float (accum
);
2644 DEFUN ("+", Fplus
, Splus
, 0, MANY
, 0,
2645 doc
: /* Return sum of any number of arguments, which are numbers or markers.
2646 usage: (+ &rest NUMBERS-OR-MARKERS) */)
2647 (int nargs
, Lisp_Object
*args
)
2649 return arith_driver (Aadd
, nargs
, args
);
2652 DEFUN ("-", Fminus
, Sminus
, 0, MANY
, 0,
2653 doc
: /* Negate number or subtract numbers or markers and return the result.
2654 With one arg, negates it. With more than one arg,
2655 subtracts all but the first from the first.
2656 usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */)
2657 (int nargs
, Lisp_Object
*args
)
2659 return arith_driver (Asub
, nargs
, args
);
2662 DEFUN ("*", Ftimes
, Stimes
, 0, MANY
, 0,
2663 doc
: /* Return product of any number of arguments, which are numbers or markers.
2664 usage: (* &rest NUMBERS-OR-MARKERS) */)
2665 (int nargs
, Lisp_Object
*args
)
2667 return arith_driver (Amult
, nargs
, args
);
2670 DEFUN ("/", Fquo
, Squo
, 2, MANY
, 0,
2671 doc
: /* Return first argument divided by all the remaining arguments.
2672 The arguments must be numbers or markers.
2673 usage: (/ DIVIDEND DIVISOR &rest DIVISORS) */)
2674 (int nargs
, Lisp_Object
*args
)
2677 for (argnum
= 2; argnum
< nargs
; argnum
++)
2678 if (FLOATP (args
[argnum
]))
2679 return float_arith_driver (0, 0, Adiv
, nargs
, args
);
2680 return arith_driver (Adiv
, nargs
, args
);
2683 DEFUN ("%", Frem
, Srem
, 2, 2, 0,
2684 doc
: /* Return remainder of X divided by Y.
2685 Both must be integers or markers. */)
2686 (register Lisp_Object x
, Lisp_Object y
)
2690 CHECK_NUMBER_COERCE_MARKER (x
);
2691 CHECK_NUMBER_COERCE_MARKER (y
);
2693 if (XFASTINT (y
) == 0)
2694 xsignal0 (Qarith_error
);
2696 XSETINT (val
, XINT (x
) % XINT (y
));
2710 /* If the magnitude of the result exceeds that of the divisor, or
2711 the sign of the result does not agree with that of the dividend,
2712 iterate with the reduced value. This does not yield a
2713 particularly accurate result, but at least it will be in the
2714 range promised by fmod. */
2716 r
-= f2
* floor (r
/ f2
);
2717 while (f2
<= (r
< 0 ? -r
: r
) || ((r
< 0) != (f1
< 0) && ! isnan (r
)));
2721 #endif /* ! HAVE_FMOD */
2723 DEFUN ("mod", Fmod
, Smod
, 2, 2, 0,
2724 doc
: /* Return X modulo Y.
2725 The result falls between zero (inclusive) and Y (exclusive).
2726 Both X and Y must be numbers or markers. */)
2727 (register Lisp_Object x
, Lisp_Object y
)
2732 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (x
);
2733 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (y
);
2735 if (FLOATP (x
) || FLOATP (y
))
2736 return fmod_float (x
, y
);
2742 xsignal0 (Qarith_error
);
2746 /* If the "remainder" comes out with the wrong sign, fix it. */
2747 if (i2
< 0 ? i1
> 0 : i1
< 0)
2754 DEFUN ("max", Fmax
, Smax
, 1, MANY
, 0,
2755 doc
: /* Return largest of all the arguments (which must be numbers or markers).
2756 The value is always a number; markers are converted to numbers.
2757 usage: (max NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2758 (int nargs
, Lisp_Object
*args
)
2760 return arith_driver (Amax
, nargs
, args
);
2763 DEFUN ("min", Fmin
, Smin
, 1, MANY
, 0,
2764 doc
: /* Return smallest of all the arguments (which must be numbers or markers).
2765 The value is always a number; markers are converted to numbers.
2766 usage: (min NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS) */)
2767 (int nargs
, Lisp_Object
*args
)
2769 return arith_driver (Amin
, nargs
, args
);
2772 DEFUN ("logand", Flogand
, Slogand
, 0, MANY
, 0,
2773 doc
: /* Return bitwise-and of all the arguments.
2774 Arguments may be integers, or markers converted to integers.
2775 usage: (logand &rest INTS-OR-MARKERS) */)
2776 (int nargs
, Lisp_Object
*args
)
2778 return arith_driver (Alogand
, nargs
, args
);
2781 DEFUN ("logior", Flogior
, Slogior
, 0, MANY
, 0,
2782 doc
: /* Return bitwise-or of all the arguments.
2783 Arguments may be integers, or markers converted to integers.
2784 usage: (logior &rest INTS-OR-MARKERS) */)
2785 (int nargs
, Lisp_Object
*args
)
2787 return arith_driver (Alogior
, nargs
, args
);
2790 DEFUN ("logxor", Flogxor
, Slogxor
, 0, MANY
, 0,
2791 doc
: /* Return bitwise-exclusive-or of all the arguments.
2792 Arguments may be integers, or markers converted to integers.
2793 usage: (logxor &rest INTS-OR-MARKERS) */)
2794 (int nargs
, Lisp_Object
*args
)
2796 return arith_driver (Alogxor
, nargs
, args
);
2799 DEFUN ("ash", Fash
, Sash
, 2, 2, 0,
2800 doc
: /* Return VALUE with its bits shifted left by COUNT.
2801 If COUNT is negative, shifting is actually to the right.
2802 In this case, the sign bit is duplicated. */)
2803 (register Lisp_Object value
, Lisp_Object count
)
2805 register Lisp_Object val
;
2807 CHECK_NUMBER (value
);
2808 CHECK_NUMBER (count
);
2810 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2812 else if (XINT (count
) > 0)
2813 XSETINT (val
, XINT (value
) << XFASTINT (count
));
2814 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2815 XSETINT (val
, XINT (value
) < 0 ? -1 : 0);
2817 XSETINT (val
, XINT (value
) >> -XINT (count
));
2821 DEFUN ("lsh", Flsh
, Slsh
, 2, 2, 0,
2822 doc
: /* Return VALUE with its bits shifted left by COUNT.
2823 If COUNT is negative, shifting is actually to the right.
2824 In this case, zeros are shifted in on the left. */)
2825 (register Lisp_Object value
, Lisp_Object count
)
2827 register Lisp_Object val
;
2829 CHECK_NUMBER (value
);
2830 CHECK_NUMBER (count
);
2832 if (XINT (count
) >= BITS_PER_EMACS_INT
)
2834 else if (XINT (count
) > 0)
2835 XSETINT (val
, (EMACS_UINT
) XUINT (value
) << XFASTINT (count
));
2836 else if (XINT (count
) <= -BITS_PER_EMACS_INT
)
2839 XSETINT (val
, (EMACS_UINT
) XUINT (value
) >> -XINT (count
));
2843 DEFUN ("1+", Fadd1
, Sadd1
, 1, 1, 0,
2844 doc
: /* Return NUMBER plus one. NUMBER may be a number or a marker.
2845 Markers are converted to integers. */)
2846 (register Lisp_Object number
)
2848 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2850 if (FLOATP (number
))
2851 return (make_float (1.0 + XFLOAT_DATA (number
)));
2853 XSETINT (number
, XINT (number
) + 1);
2857 DEFUN ("1-", Fsub1
, Ssub1
, 1, 1, 0,
2858 doc
: /* Return NUMBER minus one. NUMBER may be a number or a marker.
2859 Markers are converted to integers. */)
2860 (register Lisp_Object number
)
2862 CHECK_NUMBER_OR_FLOAT_COERCE_MARKER (number
);
2864 if (FLOATP (number
))
2865 return (make_float (-1.0 + XFLOAT_DATA (number
)));
2867 XSETINT (number
, XINT (number
) - 1);
2871 DEFUN ("lognot", Flognot
, Slognot
, 1, 1, 0,
2872 doc
: /* Return the bitwise complement of NUMBER. NUMBER must be an integer. */)
2873 (register Lisp_Object number
)
2875 CHECK_NUMBER (number
);
2876 XSETINT (number
, ~XINT (number
));
2880 DEFUN ("byteorder", Fbyteorder
, Sbyteorder
, 0, 0, 0,
2881 doc
: /* Return the byteorder for the machine.
2882 Returns 66 (ASCII uppercase B) for big endian machines or 108 (ASCII
2883 lowercase l) for small endian machines. */)
2886 unsigned i
= 0x04030201;
2887 int order
= *(char *)&i
== 1 ? 108 : 66;
2889 return make_number (order
);
2897 Lisp_Object error_tail
, arith_tail
;
2899 Qquote
= intern_c_string ("quote");
2900 Qlambda
= intern_c_string ("lambda");
2901 Qsubr
= intern_c_string ("subr");
2902 Qerror_conditions
= intern_c_string ("error-conditions");
2903 Qerror_message
= intern_c_string ("error-message");
2904 Qtop_level
= intern_c_string ("top-level");
2906 Qerror
= intern_c_string ("error");
2907 Qquit
= intern_c_string ("quit");
2908 Qwrong_type_argument
= intern_c_string ("wrong-type-argument");
2909 Qargs_out_of_range
= intern_c_string ("args-out-of-range");
2910 Qvoid_function
= intern_c_string ("void-function");
2911 Qcyclic_function_indirection
= intern_c_string ("cyclic-function-indirection");
2912 Qcyclic_variable_indirection
= intern_c_string ("cyclic-variable-indirection");
2913 Qvoid_variable
= intern_c_string ("void-variable");
2914 Qsetting_constant
= intern_c_string ("setting-constant");
2915 Qinvalid_read_syntax
= intern_c_string ("invalid-read-syntax");
2917 Qinvalid_function
= intern_c_string ("invalid-function");
2918 Qwrong_number_of_arguments
= intern_c_string ("wrong-number-of-arguments");
2919 Qno_catch
= intern_c_string ("no-catch");
2920 Qend_of_file
= intern_c_string ("end-of-file");
2921 Qarith_error
= intern_c_string ("arith-error");
2922 Qbeginning_of_buffer
= intern_c_string ("beginning-of-buffer");
2923 Qend_of_buffer
= intern_c_string ("end-of-buffer");
2924 Qbuffer_read_only
= intern_c_string ("buffer-read-only");
2925 Qtext_read_only
= intern_c_string ("text-read-only");
2926 Qmark_inactive
= intern_c_string ("mark-inactive");
2928 Qlistp
= intern_c_string ("listp");
2929 Qconsp
= intern_c_string ("consp");
2930 Qsymbolp
= intern_c_string ("symbolp");
2931 Qkeywordp
= intern_c_string ("keywordp");
2932 Qintegerp
= intern_c_string ("integerp");
2933 Qnatnump
= intern_c_string ("natnump");
2934 Qwholenump
= intern_c_string ("wholenump");
2935 Qstringp
= intern_c_string ("stringp");
2936 Qarrayp
= intern_c_string ("arrayp");
2937 Qsequencep
= intern_c_string ("sequencep");
2938 Qbufferp
= intern_c_string ("bufferp");
2939 Qvectorp
= intern_c_string ("vectorp");
2940 Qchar_or_string_p
= intern_c_string ("char-or-string-p");
2941 Qmarkerp
= intern_c_string ("markerp");
2942 Qbuffer_or_string_p
= intern_c_string ("buffer-or-string-p");
2943 Qinteger_or_marker_p
= intern_c_string ("integer-or-marker-p");
2944 Qboundp
= intern_c_string ("boundp");
2945 Qfboundp
= intern_c_string ("fboundp");
2947 Qfloatp
= intern_c_string ("floatp");
2948 Qnumberp
= intern_c_string ("numberp");
2949 Qnumber_or_marker_p
= intern_c_string ("number-or-marker-p");
2951 Qchar_table_p
= intern_c_string ("char-table-p");
2952 Qvector_or_char_table_p
= intern_c_string ("vector-or-char-table-p");
2954 Qsubrp
= intern_c_string ("subrp");
2955 Qunevalled
= intern_c_string ("unevalled");
2956 Qmany
= intern_c_string ("many");
2958 Qcdr
= intern_c_string ("cdr");
2960 /* Handle automatic advice activation */
2961 Qad_advice_info
= intern_c_string ("ad-advice-info");
2962 Qad_activate_internal
= intern_c_string ("ad-activate-internal");
2964 error_tail
= pure_cons (Qerror
, Qnil
);
2966 /* ERROR is used as a signaler for random errors for which nothing else is right */
2968 Fput (Qerror
, Qerror_conditions
,
2970 Fput (Qerror
, Qerror_message
,
2971 make_pure_c_string ("error"));
2973 Fput (Qquit
, Qerror_conditions
,
2974 pure_cons (Qquit
, Qnil
));
2975 Fput (Qquit
, Qerror_message
,
2976 make_pure_c_string ("Quit"));
2978 Fput (Qwrong_type_argument
, Qerror_conditions
,
2979 pure_cons (Qwrong_type_argument
, error_tail
));
2980 Fput (Qwrong_type_argument
, Qerror_message
,
2981 make_pure_c_string ("Wrong type argument"));
2983 Fput (Qargs_out_of_range
, Qerror_conditions
,
2984 pure_cons (Qargs_out_of_range
, error_tail
));
2985 Fput (Qargs_out_of_range
, Qerror_message
,
2986 make_pure_c_string ("Args out of range"));
2988 Fput (Qvoid_function
, Qerror_conditions
,
2989 pure_cons (Qvoid_function
, error_tail
));
2990 Fput (Qvoid_function
, Qerror_message
,
2991 make_pure_c_string ("Symbol's function definition is void"));
2993 Fput (Qcyclic_function_indirection
, Qerror_conditions
,
2994 pure_cons (Qcyclic_function_indirection
, error_tail
));
2995 Fput (Qcyclic_function_indirection
, Qerror_message
,
2996 make_pure_c_string ("Symbol's chain of function indirections contains a loop"));
2998 Fput (Qcyclic_variable_indirection
, Qerror_conditions
,
2999 pure_cons (Qcyclic_variable_indirection
, error_tail
));
3000 Fput (Qcyclic_variable_indirection
, Qerror_message
,
3001 make_pure_c_string ("Symbol's chain of variable indirections contains a loop"));
3003 Qcircular_list
= intern_c_string ("circular-list");
3004 staticpro (&Qcircular_list
);
3005 Fput (Qcircular_list
, Qerror_conditions
,
3006 pure_cons (Qcircular_list
, error_tail
));
3007 Fput (Qcircular_list
, Qerror_message
,
3008 make_pure_c_string ("List contains a loop"));
3010 Fput (Qvoid_variable
, Qerror_conditions
,
3011 pure_cons (Qvoid_variable
, error_tail
));
3012 Fput (Qvoid_variable
, Qerror_message
,
3013 make_pure_c_string ("Symbol's value as variable is void"));
3015 Fput (Qsetting_constant
, Qerror_conditions
,
3016 pure_cons (Qsetting_constant
, error_tail
));
3017 Fput (Qsetting_constant
, Qerror_message
,
3018 make_pure_c_string ("Attempt to set a constant symbol"));
3020 Fput (Qinvalid_read_syntax
, Qerror_conditions
,
3021 pure_cons (Qinvalid_read_syntax
, error_tail
));
3022 Fput (Qinvalid_read_syntax
, Qerror_message
,
3023 make_pure_c_string ("Invalid read syntax"));
3025 Fput (Qinvalid_function
, Qerror_conditions
,
3026 pure_cons (Qinvalid_function
, error_tail
));
3027 Fput (Qinvalid_function
, Qerror_message
,
3028 make_pure_c_string ("Invalid function"));
3030 Fput (Qwrong_number_of_arguments
, Qerror_conditions
,
3031 pure_cons (Qwrong_number_of_arguments
, error_tail
));
3032 Fput (Qwrong_number_of_arguments
, Qerror_message
,
3033 make_pure_c_string ("Wrong number of arguments"));
3035 Fput (Qno_catch
, Qerror_conditions
,
3036 pure_cons (Qno_catch
, error_tail
));
3037 Fput (Qno_catch
, Qerror_message
,
3038 make_pure_c_string ("No catch for tag"));
3040 Fput (Qend_of_file
, Qerror_conditions
,
3041 pure_cons (Qend_of_file
, error_tail
));
3042 Fput (Qend_of_file
, Qerror_message
,
3043 make_pure_c_string ("End of file during parsing"));
3045 arith_tail
= pure_cons (Qarith_error
, error_tail
);
3046 Fput (Qarith_error
, Qerror_conditions
,
3048 Fput (Qarith_error
, Qerror_message
,
3049 make_pure_c_string ("Arithmetic error"));
3051 Fput (Qbeginning_of_buffer
, Qerror_conditions
,
3052 pure_cons (Qbeginning_of_buffer
, error_tail
));
3053 Fput (Qbeginning_of_buffer
, Qerror_message
,
3054 make_pure_c_string ("Beginning of buffer"));
3056 Fput (Qend_of_buffer
, Qerror_conditions
,
3057 pure_cons (Qend_of_buffer
, error_tail
));
3058 Fput (Qend_of_buffer
, Qerror_message
,
3059 make_pure_c_string ("End of buffer"));
3061 Fput (Qbuffer_read_only
, Qerror_conditions
,
3062 pure_cons (Qbuffer_read_only
, error_tail
));
3063 Fput (Qbuffer_read_only
, Qerror_message
,
3064 make_pure_c_string ("Buffer is read-only"));
3066 Fput (Qtext_read_only
, Qerror_conditions
,
3067 pure_cons (Qtext_read_only
, error_tail
));
3068 Fput (Qtext_read_only
, Qerror_message
,
3069 make_pure_c_string ("Text is read-only"));
3071 Qrange_error
= intern_c_string ("range-error");
3072 Qdomain_error
= intern_c_string ("domain-error");
3073 Qsingularity_error
= intern_c_string ("singularity-error");
3074 Qoverflow_error
= intern_c_string ("overflow-error");
3075 Qunderflow_error
= intern_c_string ("underflow-error");
3077 Fput (Qdomain_error
, Qerror_conditions
,
3078 pure_cons (Qdomain_error
, arith_tail
));
3079 Fput (Qdomain_error
, Qerror_message
,
3080 make_pure_c_string ("Arithmetic domain error"));
3082 Fput (Qrange_error
, Qerror_conditions
,
3083 pure_cons (Qrange_error
, arith_tail
));
3084 Fput (Qrange_error
, Qerror_message
,
3085 make_pure_c_string ("Arithmetic range error"));
3087 Fput (Qsingularity_error
, Qerror_conditions
,
3088 pure_cons (Qsingularity_error
, Fcons (Qdomain_error
, arith_tail
)));
3089 Fput (Qsingularity_error
, Qerror_message
,
3090 make_pure_c_string ("Arithmetic singularity error"));
3092 Fput (Qoverflow_error
, Qerror_conditions
,
3093 pure_cons (Qoverflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3094 Fput (Qoverflow_error
, Qerror_message
,
3095 make_pure_c_string ("Arithmetic overflow error"));
3097 Fput (Qunderflow_error
, Qerror_conditions
,
3098 pure_cons (Qunderflow_error
, Fcons (Qdomain_error
, arith_tail
)));
3099 Fput (Qunderflow_error
, Qerror_message
,
3100 make_pure_c_string ("Arithmetic underflow error"));
3102 staticpro (&Qrange_error
);
3103 staticpro (&Qdomain_error
);
3104 staticpro (&Qsingularity_error
);
3105 staticpro (&Qoverflow_error
);
3106 staticpro (&Qunderflow_error
);
3110 staticpro (&Qquote
);
3111 staticpro (&Qlambda
);
3113 staticpro (&Qunbound
);
3114 staticpro (&Qerror_conditions
);
3115 staticpro (&Qerror_message
);
3116 staticpro (&Qtop_level
);
3118 staticpro (&Qerror
);
3120 staticpro (&Qwrong_type_argument
);
3121 staticpro (&Qargs_out_of_range
);
3122 staticpro (&Qvoid_function
);
3123 staticpro (&Qcyclic_function_indirection
);
3124 staticpro (&Qcyclic_variable_indirection
);
3125 staticpro (&Qvoid_variable
);
3126 staticpro (&Qsetting_constant
);
3127 staticpro (&Qinvalid_read_syntax
);
3128 staticpro (&Qwrong_number_of_arguments
);
3129 staticpro (&Qinvalid_function
);
3130 staticpro (&Qno_catch
);
3131 staticpro (&Qend_of_file
);
3132 staticpro (&Qarith_error
);
3133 staticpro (&Qbeginning_of_buffer
);
3134 staticpro (&Qend_of_buffer
);
3135 staticpro (&Qbuffer_read_only
);
3136 staticpro (&Qtext_read_only
);
3137 staticpro (&Qmark_inactive
);
3139 staticpro (&Qlistp
);
3140 staticpro (&Qconsp
);
3141 staticpro (&Qsymbolp
);
3142 staticpro (&Qkeywordp
);
3143 staticpro (&Qintegerp
);
3144 staticpro (&Qnatnump
);
3145 staticpro (&Qwholenump
);
3146 staticpro (&Qstringp
);
3147 staticpro (&Qarrayp
);
3148 staticpro (&Qsequencep
);
3149 staticpro (&Qbufferp
);
3150 staticpro (&Qvectorp
);
3151 staticpro (&Qchar_or_string_p
);
3152 staticpro (&Qmarkerp
);
3153 staticpro (&Qbuffer_or_string_p
);
3154 staticpro (&Qinteger_or_marker_p
);
3155 staticpro (&Qfloatp
);
3156 staticpro (&Qnumberp
);
3157 staticpro (&Qnumber_or_marker_p
);
3158 staticpro (&Qchar_table_p
);
3159 staticpro (&Qvector_or_char_table_p
);
3160 staticpro (&Qsubrp
);
3162 staticpro (&Qunevalled
);
3164 staticpro (&Qboundp
);
3165 staticpro (&Qfboundp
);
3167 staticpro (&Qad_advice_info
);
3168 staticpro (&Qad_activate_internal
);
3170 /* Types that type-of returns. */
3171 Qinteger
= intern_c_string ("integer");
3172 Qsymbol
= intern_c_string ("symbol");
3173 Qstring
= intern_c_string ("string");
3174 Qcons
= intern_c_string ("cons");
3175 Qmarker
= intern_c_string ("marker");
3176 Qoverlay
= intern_c_string ("overlay");
3177 Qfloat
= intern_c_string ("float");
3178 Qwindow_configuration
= intern_c_string ("window-configuration");
3179 Qprocess
= intern_c_string ("process");
3180 Qwindow
= intern_c_string ("window");
3181 /* Qsubr = intern_c_string ("subr"); */
3182 Qcompiled_function
= intern_c_string ("compiled-function");
3183 Qfunction_vector
= intern_c_string ("function-vector");
3184 Qbuffer
= intern_c_string ("buffer");
3185 Qframe
= intern_c_string ("frame");
3186 Qvector
= intern_c_string ("vector");
3187 Qchar_table
= intern_c_string ("char-table");
3188 Qbool_vector
= intern_c_string ("bool-vector");
3189 Qhash_table
= intern_c_string ("hash-table");
3191 DEFSYM (Qfont_spec
, "font-spec");
3192 DEFSYM (Qfont_entity
, "font-entity");
3193 DEFSYM (Qfont_object
, "font-object");
3195 DEFSYM (Qinteractive_form
, "interactive-form");
3197 staticpro (&Qinteger
);
3198 staticpro (&Qsymbol
);
3199 staticpro (&Qstring
);
3201 staticpro (&Qmarker
);
3202 staticpro (&Qoverlay
);
3203 staticpro (&Qfloat
);
3204 staticpro (&Qwindow_configuration
);
3205 staticpro (&Qprocess
);
3206 staticpro (&Qwindow
);
3207 /* staticpro (&Qsubr); */
3208 staticpro (&Qcompiled_function
);
3209 staticpro (&Qfunction_vector
);
3210 staticpro (&Qbuffer
);
3211 staticpro (&Qframe
);
3212 staticpro (&Qvector
);
3213 staticpro (&Qchar_table
);
3214 staticpro (&Qbool_vector
);
3215 staticpro (&Qhash_table
);
3217 defsubr (&Sindirect_variable
);
3218 defsubr (&Sinteractive_form
);
3221 defsubr (&Stype_of
);
3226 defsubr (&Sintegerp
);
3227 defsubr (&Sinteger_or_marker_p
);
3228 defsubr (&Snumberp
);
3229 defsubr (&Snumber_or_marker_p
);
3231 defsubr (&Snatnump
);
3232 defsubr (&Ssymbolp
);
3233 defsubr (&Skeywordp
);
3234 defsubr (&Sstringp
);
3235 defsubr (&Smultibyte_string_p
);
3236 defsubr (&Svectorp
);
3237 defsubr (&Schar_table_p
);
3238 defsubr (&Svector_or_char_table_p
);
3239 defsubr (&Sbool_vector_p
);
3241 defsubr (&Ssequencep
);
3242 defsubr (&Sbufferp
);
3243 defsubr (&Smarkerp
);
3245 defsubr (&Sbyte_code_function_p
);
3246 defsubr (&Sfunvecp
);
3247 defsubr (&Schar_or_string_p
);
3250 defsubr (&Scar_safe
);
3251 defsubr (&Scdr_safe
);
3254 defsubr (&Ssymbol_function
);
3255 defsubr (&Sindirect_function
);
3256 defsubr (&Ssymbol_plist
);
3257 defsubr (&Ssymbol_name
);
3258 defsubr (&Smakunbound
);
3259 defsubr (&Sfmakunbound
);
3261 defsubr (&Sfboundp
);
3263 defsubr (&Sdefalias
);
3264 defsubr (&Ssetplist
);
3265 defsubr (&Ssymbol_value
);
3267 defsubr (&Sdefault_boundp
);
3268 defsubr (&Sdefault_value
);
3269 defsubr (&Sset_default
);
3270 defsubr (&Ssetq_default
);
3271 defsubr (&Smake_variable_buffer_local
);
3272 defsubr (&Smake_local_variable
);
3273 defsubr (&Skill_local_variable
);
3274 defsubr (&Smake_variable_frame_local
);
3275 defsubr (&Slocal_variable_p
);
3276 defsubr (&Slocal_variable_if_set_p
);
3277 defsubr (&Svariable_binding_locus
);
3278 #if 0 /* XXX Remove this. --lorentey */
3279 defsubr (&Sterminal_local_value
);
3280 defsubr (&Sset_terminal_local_value
);
3284 defsubr (&Snumber_to_string
);
3285 defsubr (&Sstring_to_number
);
3286 defsubr (&Seqlsign
);
3309 defsubr (&Sbyteorder
);
3310 defsubr (&Ssubr_arity
);
3311 defsubr (&Ssubr_name
);
3313 XSYMBOL (Qwholenump
)->function
= XSYMBOL (Qnatnump
)->function
;
3315 DEFVAR_LISP ("most-positive-fixnum", Vmost_positive_fixnum
,
3316 doc
: /* The largest value that is representable in a Lisp integer. */);
3317 Vmost_positive_fixnum
= make_number (MOST_POSITIVE_FIXNUM
);
3318 XSYMBOL (intern_c_string ("most-positive-fixnum"))->constant
= 1;
3320 DEFVAR_LISP ("most-negative-fixnum", Vmost_negative_fixnum
,
3321 doc
: /* The smallest value that is representable in a Lisp integer. */);
3322 Vmost_negative_fixnum
= make_number (MOST_NEGATIVE_FIXNUM
);
3323 XSYMBOL (intern_c_string ("most-negative-fixnum"))->constant
= 1;
3327 arith_error (int signo
)
3329 sigsetmask (SIGEMPTYMASK
);
3331 SIGNAL_THREAD_CHECK (signo
);
3332 xsignal0 (Qarith_error
);
3338 /* Don't do this if just dumping out.
3339 We don't want to call `signal' in this case
3340 so that we don't have trouble with dumping
3341 signal-delivering routines in an inconsistent state. */
3345 #endif /* CANNOT_DUMP */
3346 signal (SIGFPE
, arith_error
);
3349 signal (SIGEMT
, arith_error
);